line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# $Id: Echo.pm,v 1.3 2005/01/27 08:37:22 chris Exp $ |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# POE::Component::Server::Echo, by Chris 'BinGOs' Williams |
4
|
|
|
|
|
|
|
# |
5
|
|
|
|
|
|
|
# This module may be used, modified, and distributed under the same |
6
|
|
|
|
|
|
|
# terms as Perl itself. Please see the license that came with your Perl |
7
|
|
|
|
|
|
|
# distribution for details. |
8
|
|
|
|
|
|
|
# |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
package POE::Component::Server::Echo; |
11
|
|
|
|
|
|
|
|
12
|
3
|
|
|
3
|
|
116966
|
use strict; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
137
|
|
13
|
3
|
|
|
3
|
|
18
|
use warnings; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
117
|
|
14
|
3
|
|
|
|
|
24
|
use POE qw( Wheel::SocketFactory Wheel::ReadWrite Driver::SysRW |
15
|
3
|
|
|
3
|
|
3209
|
Filter::Line ); |
|
3
|
|
|
|
|
171253
|
|
16
|
3
|
|
|
3
|
|
484773
|
use Carp; |
|
3
|
|
|
|
|
9
|
|
|
3
|
|
|
|
|
312
|
|
17
|
3
|
|
|
3
|
|
18
|
use Socket; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
2422
|
|
18
|
3
|
|
|
3
|
|
96
|
use IO::Socket::INET; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
46
|
|
19
|
3
|
|
|
3
|
|
4141
|
use vars qw($VERSION); |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
135
|
|
20
|
|
|
|
|
|
|
|
21
|
3
|
|
|
3
|
|
14
|
use constant DATAGRAM_MAXLEN => 1024; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
196
|
|
22
|
3
|
|
|
3
|
|
13
|
use constant DEFAULT_PORT => 7; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
3907
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
$VERSION = '1.64'; |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
sub spawn { |
27
|
2
|
|
|
2
|
1
|
30
|
my $package = shift; |
28
|
2
|
50
|
|
|
|
12
|
croak "$package requires an even number of parameters" if @_ & 1; |
29
|
|
|
|
|
|
|
|
30
|
2
|
|
|
|
|
16
|
my %parms = @_; |
31
|
|
|
|
|
|
|
|
32
|
2
|
50
|
33
|
|
|
24
|
$parms{'Alias'} = 'Echo-Server' unless defined $parms{'Alias'} and $parms{'Alias'}; |
33
|
2
|
50
|
33
|
|
|
13
|
$parms{'tcp'} = 1 unless defined $parms{'tcp'} and $parms{'tcp'} == 0; |
34
|
2
|
50
|
33
|
|
|
13
|
$parms{'udp'} = 1 unless defined $parms{'udp'} and $parms{'udp'} == 0; |
35
|
|
|
|
|
|
|
|
36
|
2
|
|
|
|
|
9
|
my $self = bless( { }, $package ); |
37
|
|
|
|
|
|
|
|
38
|
2
|
|
|
|
|
15
|
$self->{CONFIG} = \%parms; |
39
|
|
|
|
|
|
|
|
40
|
2
|
50
|
|
|
|
48
|
POE::Session->create( |
41
|
|
|
|
|
|
|
object_states => [ |
42
|
|
|
|
|
|
|
$self => { _start => '_server_start', |
43
|
|
|
|
|
|
|
_stop => '_server_stop', |
44
|
|
|
|
|
|
|
shutdown => '_server_close' }, |
45
|
|
|
|
|
|
|
$self => [ qw(_accept_new_client _accept_failed _client_input _client_error _get_datagram) ], |
46
|
|
|
|
|
|
|
], |
47
|
|
|
|
|
|
|
( ref $parms{'options'} eq 'HASH' ? ( options => $parms{'options'} ) : () ), |
48
|
|
|
|
|
|
|
); |
49
|
|
|
|
|
|
|
|
50
|
2
|
|
|
|
|
328
|
return $self; |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
sub _server_start { |
54
|
2
|
|
|
2
|
|
811
|
my ($kernel,$self) = @_[KERNEL,OBJECT]; |
55
|
|
|
|
|
|
|
|
56
|
2
|
|
|
|
|
18
|
$kernel->alias_set( $self->{CONFIG}->{Alias} ); |
57
|
|
|
|
|
|
|
|
58
|
2
|
50
|
|
|
|
97
|
if ( $self->{CONFIG}->{tcp} ) { |
59
|
2
|
50
|
|
|
|
41
|
$self->{Listener} = POE::Wheel::SocketFactory->new( |
|
|
50
|
|
|
|
|
|
60
|
|
|
|
|
|
|
( defined ( $self->{CONFIG}->{BindAddress} ) ? ( BindAddress => $self->{CONFIG}->{BindAddress} ) : () ), |
61
|
|
|
|
|
|
|
( defined ( $self->{CONFIG}->{BindPort} ) ? ( BindPort => $self->{CONFIG}->{BindPort} ) : ( BindPort => DEFAULT_PORT ) ), |
62
|
|
|
|
|
|
|
SuccessEvent => '_accept_new_client', |
63
|
|
|
|
|
|
|
FailureEvent => '_accept_failed', |
64
|
|
|
|
|
|
|
SocketDomain => AF_INET, # Sets the socket() domain |
65
|
|
|
|
|
|
|
SocketType => SOCK_STREAM, # Sets the socket() type |
66
|
|
|
|
|
|
|
SocketProtocol => 'tcp', # Sets the socket() protocol |
67
|
|
|
|
|
|
|
Reuse => 'on', # Lets the port be reused |
68
|
|
|
|
|
|
|
); |
69
|
|
|
|
|
|
|
} |
70
|
2
|
50
|
|
|
|
3017
|
if ( $self->{CONFIG}->{udp} ) { |
71
|
2
|
|
|
|
|
140
|
my $proto = getprotobyname('udp'); |
72
|
2
|
50
|
|
|
|
13
|
my $port = defined ( $self->{CONFIG}->{BindPort} ) ? $self->{CONFIG}->{BindPort} : DEFAULT_PORT; |
73
|
2
|
|
|
|
|
16
|
my $paddr = sockaddr_in($port, INADDR_ANY); |
74
|
2
|
50
|
|
|
|
78
|
socket( my $socket, PF_INET, SOCK_DGRAM, $proto) || die "socket: $!"; |
75
|
2
|
50
|
|
|
|
18
|
bind( $socket, $paddr) || die "bind: $!"; |
76
|
2
|
|
|
|
|
6
|
$self->{udp_socket} = $socket; |
77
|
2
|
|
|
|
|
11
|
$kernel->select_read( $self->{udp_socket}, "_get_datagram" ); |
78
|
|
|
|
|
|
|
} |
79
|
2
|
|
|
|
|
158
|
undef; |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
sub _server_stop { |
83
|
2
|
|
|
2
|
|
194
|
my ($kernel,$self) = @_[KERNEL,OBJECT]; |
84
|
2
|
|
|
|
|
7
|
undef; |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
sub _server_close { |
88
|
2
|
|
|
2
|
|
1514
|
my ($kernel,$self) = @_[KERNEL,OBJECT]; |
89
|
|
|
|
|
|
|
|
90
|
2
|
|
|
|
|
16
|
delete $self->{Listener}; |
91
|
2
|
|
|
|
|
364
|
delete $self->{Clients}; |
92
|
2
|
|
|
|
|
10
|
$kernel->select( $self->{udp_socket} ); |
93
|
2
|
|
|
|
|
226
|
delete $self->{udp_socket}; |
94
|
2
|
|
|
|
|
12
|
$kernel->alias_remove( $self->{CONFIG}->{Alias} ); |
95
|
2
|
|
|
|
|
93
|
undef; |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
sub _accept_new_client { |
99
|
1
|
|
|
1
|
|
929
|
my ($kernel,$self,$socket,$peeraddr,$peerport) = @_[KERNEL,OBJECT,ARG0 .. ARG2]; |
100
|
1
|
|
|
|
|
31
|
$peeraddr = inet_ntoa($peeraddr); |
101
|
|
|
|
|
|
|
|
102
|
1
|
|
|
|
|
10
|
my $wheel = POE::Wheel::ReadWrite->new ( |
103
|
|
|
|
|
|
|
Handle => $socket, |
104
|
|
|
|
|
|
|
Filter => POE::Filter::Line->new(), |
105
|
|
|
|
|
|
|
InputEvent => '_client_input', |
106
|
|
|
|
|
|
|
ErrorEvent => '_client_error', |
107
|
|
|
|
|
|
|
); |
108
|
|
|
|
|
|
|
|
109
|
1
|
|
|
|
|
342
|
my $wheel_id = $wheel->ID(); |
110
|
1
|
|
|
|
|
6
|
$self->{Clients}->{ $wheel_id }->{Wheel} = $wheel; |
111
|
1
|
|
|
|
|
3
|
$self->{Clients}->{ $wheel_id }->{peeraddr} = $peeraddr; |
112
|
1
|
|
|
|
|
2
|
$self->{Clients}->{ $wheel_id }->{peerport} = $peerport; |
113
|
1
|
|
|
|
|
4
|
undef; |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
sub _accept_failed { |
117
|
0
|
|
|
0
|
|
0
|
my ($kernel,$self) = @_[KERNEL,OBJECT]; |
118
|
0
|
|
|
|
|
0
|
$kernel->yield( 'shutdown' ); |
119
|
0
|
|
|
|
|
0
|
undef; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
sub _client_input { |
123
|
1
|
|
|
1
|
|
1998
|
my ($kernel,$self,$input,$wheel_id) = @_[KERNEL,OBJECT,ARG0,ARG1]; |
124
|
|
|
|
|
|
|
|
125
|
1
|
50
|
33
|
|
|
12
|
if ( defined ( $self->{Clients}->{ $wheel_id } ) and defined ( $self->{Clients}->{ $wheel_id }->{Wheel} ) ) { |
126
|
1
|
|
|
|
|
5
|
$self->{Clients}->{ $wheel_id }->{Wheel}->put($input); |
127
|
|
|
|
|
|
|
} |
128
|
1
|
|
|
|
|
59
|
undef; |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
sub _client_error { |
132
|
1
|
|
|
1
|
|
1635
|
my ($self,$wheel_id) = @_[OBJECT,ARG3]; |
133
|
1
|
|
|
|
|
6
|
delete $self->{Clients}->{ $wheel_id }; |
134
|
1
|
|
|
|
|
184
|
undef; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
sub _get_datagram { |
138
|
1
|
|
|
1
|
|
1127
|
my ( $kernel, $socket ) = @_[ KERNEL, ARG0 ]; |
139
|
|
|
|
|
|
|
|
140
|
1
|
|
|
|
|
22
|
my $remote_address = recv( $socket, my $message = "", DATAGRAM_MAXLEN, 0 ); |
141
|
1
|
50
|
|
|
|
6
|
return unless defined $remote_address; |
142
|
|
|
|
|
|
|
|
143
|
1
|
50
|
|
|
|
51
|
send( $socket, $message, 0, $remote_address ) == length($message) |
144
|
|
|
|
|
|
|
or warn "Trouble sending response: $!"; |
145
|
1
|
|
|
|
|
5
|
undef; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
sub sockname_tcp { |
149
|
1
|
|
|
1
|
1
|
941
|
my $self = shift; |
150
|
1
|
|
|
|
|
2
|
my $name; |
151
|
1
|
50
|
|
|
|
9
|
$name = $self->{Listener}->getsockname() if $self->{CONFIG}->{tcp}; |
152
|
1
|
50
|
|
|
|
16
|
return unless $name; |
153
|
1
|
|
|
|
|
4
|
return sockaddr_in($name); |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
sub sockname_udp { |
157
|
1
|
|
|
1
|
1
|
1124
|
my $self = shift; |
158
|
1
|
50
|
33
|
|
|
19
|
return unless $self->{CONFIG}->{udp} and $self->{udp_socket}; |
159
|
1
|
|
|
|
|
16
|
return sockaddr_in( getsockname $self->{udp_socket} ); |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
1; |
163
|
|
|
|
|
|
|
__END__ |