line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package POE::Wheel::SocketFactory; |
2
|
|
|
|
|
|
|
|
3
|
23
|
|
|
23
|
|
103
|
use strict; |
|
23
|
|
|
|
|
34
|
|
|
23
|
|
|
|
|
884
|
|
4
|
|
|
|
|
|
|
|
5
|
23
|
|
|
23
|
|
100
|
use vars qw($VERSION @ISA); |
|
23
|
|
|
|
|
37
|
|
|
23
|
|
|
|
|
1437
|
|
6
|
|
|
|
|
|
|
$VERSION = '1.367'; # NOTE - Should be #.### (three decimal places) |
7
|
|
|
|
|
|
|
|
8
|
23
|
|
|
23
|
|
106
|
use Carp qw( carp croak ); |
|
23
|
|
|
|
|
36
|
|
|
23
|
|
|
|
|
1250
|
|
9
|
23
|
|
|
23
|
|
119
|
use Symbol qw( gensym ); |
|
23
|
|
|
|
|
51
|
|
|
23
|
|
|
|
|
1003
|
|
10
|
|
|
|
|
|
|
|
11
|
23
|
|
|
23
|
|
112
|
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); |
|
23
|
|
|
|
|
36
|
|
|
23
|
|
|
|
|
1426
|
|
12
|
23
|
|
|
|
|
1497
|
use Errno qw( |
13
|
|
|
|
|
|
|
EWOULDBLOCK EADDRNOTAVAIL EINPROGRESS EADDRINUSE ECONNABORTED |
14
|
|
|
|
|
|
|
ESPIPE |
15
|
23
|
|
|
23
|
|
108
|
); |
|
23
|
|
|
|
|
36
|
|
16
|
|
|
|
|
|
|
|
17
|
23
|
|
|
|
|
2442
|
use Socket qw( |
18
|
|
|
|
|
|
|
AF_INET SOCK_STREAM SOL_SOCKET AF_UNIX PF_UNIX |
19
|
|
|
|
|
|
|
PF_INET SOCK_DGRAM SO_ERROR unpack_sockaddr_in |
20
|
|
|
|
|
|
|
unpack_sockaddr_un PF_UNSPEC SO_REUSEADDR INADDR_ANY |
21
|
|
|
|
|
|
|
pack_sockaddr_in pack_sockaddr_un inet_aton SOMAXCONN |
22
|
23
|
|
|
23
|
|
114
|
); |
|
23
|
|
|
|
|
40
|
|
23
|
|
|
|
|
|
|
|
24
|
23
|
|
|
23
|
|
118
|
use IO::Handle (); |
|
23
|
|
|
|
|
29
|
|
|
23
|
|
|
|
|
315
|
|
25
|
23
|
|
|
23
|
|
99
|
use FileHandle (); |
|
23
|
|
|
|
|
32
|
|
|
23
|
|
|
|
|
382
|
|
26
|
23
|
|
|
23
|
|
93
|
use POE qw( Wheel ); |
|
23
|
|
|
|
|
43
|
|
|
23
|
|
|
|
|
160
|
|
27
|
|
|
|
|
|
|
push @ISA, qw(POE::Wheel); |
28
|
|
|
|
|
|
|
|
29
|
0
|
|
|
0
|
0
|
0
|
sub CRIMSON_SCOPE_HACK ($) { 0 } |
30
|
|
|
|
|
|
|
sub DEBUG () { 0 } |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
sub MY_SOCKET_HANDLE () { 0 } |
33
|
|
|
|
|
|
|
sub MY_UNIQUE_ID () { 1 } |
34
|
|
|
|
|
|
|
sub MY_EVENT_SUCCESS () { 2 } |
35
|
|
|
|
|
|
|
sub MY_EVENT_FAILURE () { 3 } |
36
|
|
|
|
|
|
|
sub MY_SOCKET_DOMAIN () { 4 } |
37
|
|
|
|
|
|
|
sub MY_STATE_ACCEPT () { 5 } |
38
|
|
|
|
|
|
|
sub MY_STATE_CONNECT () { 6 } |
39
|
|
|
|
|
|
|
sub MY_MINE_SUCCESS () { 7 } |
40
|
|
|
|
|
|
|
sub MY_MINE_FAILURE () { 8 } |
41
|
|
|
|
|
|
|
sub MY_SOCKET_PROTOCOL () { 9 } |
42
|
|
|
|
|
|
|
sub MY_SOCKET_TYPE () { 10 } |
43
|
|
|
|
|
|
|
sub MY_STATE_ERROR () { 11 } |
44
|
|
|
|
|
|
|
sub MY_SOCKET_SELECTED () { 12 } |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# Fletch has subclassed SSLSocketFactory from SocketFactory. |
47
|
|
|
|
|
|
|
# He's added new members after MY_SOCKET_SELECTED. Be sure, if you |
48
|
|
|
|
|
|
|
# extend this, to extend add stuff BEFORE MY_SOCKET_SELECTED or let |
49
|
|
|
|
|
|
|
# Fletch know you've broken his module. |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# If IPv6 support can't be loaded, then provide dummies so the code at |
52
|
|
|
|
|
|
|
# least compiles. Suggested in rt.cpan.org 27250. |
53
|
|
|
|
|
|
|
BEGIN { |
54
|
|
|
|
|
|
|
|
55
|
23
|
|
|
23
|
|
48
|
eval { Socket->import( qw(getaddrinfo unpack_sockaddr_in6) ) }; |
|
23
|
|
|
|
|
771
|
|
56
|
23
|
50
|
|
|
|
88
|
if ($@) { |
57
|
0
|
|
|
|
|
0
|
*getaddrinfo = sub { Carp::confess("Unable to use IPv6: Socket doesn't provide getaddrinfo()") }; |
|
0
|
|
|
|
|
0
|
|
58
|
0
|
|
|
|
|
0
|
*unpack_sockaddr_in6 = sub { Carp::confess("Unable to use IPv6: Socket doesn't provide unpack_sockaddr_in6()") }; |
|
0
|
|
|
|
|
0
|
|
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# Socket6 provides AF_INET6 and PF_INET6 where earlier Perls' Socket don't. |
62
|
23
|
|
|
|
|
31
|
eval { Socket->import( qw(AF_INET6 PF_INET6) ) }; |
|
23
|
|
|
|
|
490
|
|
63
|
23
|
50
|
|
|
|
107
|
if ($@) { |
64
|
0
|
|
|
|
|
0
|
eval { require Socket6; Socket6->import( qw(AF_INET6 PF_INET6) ) }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
65
|
0
|
0
|
|
|
|
0
|
if ($@) { |
66
|
0
|
|
|
|
|
0
|
*AF_INET6 = sub { -1 }; |
|
0
|
|
|
|
|
0
|
|
67
|
0
|
|
|
|
|
0
|
*PF_INET6 = sub { -1 }; |
|
0
|
|
|
|
|
0
|
|
68
|
|
|
|
|
|
|
} |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
23
|
|
|
|
|
34
|
eval { Socket->import( 'IPPROTO_TCP' ) }; |
|
23
|
|
|
|
|
336
|
|
72
|
23
|
50
|
|
|
|
97
|
if ($@) { |
73
|
0
|
|
|
|
|
0
|
*IPPROTO_TCP = (getprotobyname 'tcp')[2]; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
23
|
|
|
|
|
40
|
eval { Socket->import( 'IPPROTO_UDP' ) }; |
|
23
|
|
|
|
|
350
|
|
77
|
23
|
50
|
|
|
|
58985
|
if ($@) { |
78
|
0
|
|
|
|
|
0
|
*IPPROTO_UDP = (getprotobyname 'udp')[2]; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
# Common protocols to help support systems that don't have |
83
|
|
|
|
|
|
|
# getprotobyname(). |
84
|
|
|
|
|
|
|
my %proto_by_name = ( |
85
|
|
|
|
|
|
|
tcp => IPPROTO_TCP, |
86
|
|
|
|
|
|
|
udp => IPPROTO_UDP, |
87
|
|
|
|
|
|
|
); |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
my %proto_by_number = reverse %proto_by_name; |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
92
|
|
|
|
|
|
|
# These tables customize the socketfactory. Many protocols share the |
93
|
|
|
|
|
|
|
# same operations, it seems, and this is a way to add new ones with a |
94
|
|
|
|
|
|
|
# minimum of additional code. |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
sub DOM_UNIX () { 'unix' } # UNIX domain socket |
97
|
|
|
|
|
|
|
sub DOM_INET () { 'inet' } # INET domain socket |
98
|
|
|
|
|
|
|
sub DOM_INET6 () { 'inet6' } # INET v6 domain socket |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
# AF_XYZ and PF_XYZ may be different. |
101
|
|
|
|
|
|
|
my %map_family_to_domain = ( |
102
|
|
|
|
|
|
|
AF_UNIX, DOM_UNIX, PF_UNIX, DOM_UNIX, |
103
|
|
|
|
|
|
|
AF_INET, DOM_INET, PF_INET, DOM_INET, |
104
|
|
|
|
|
|
|
AF_INET6, DOM_INET6, |
105
|
|
|
|
|
|
|
PF_INET6, DOM_INET6, |
106
|
|
|
|
|
|
|
); |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
sub SVROP_LISTENS () { 'listens' } # connect/listen sockets |
109
|
|
|
|
|
|
|
sub SVROP_NOTHING () { 'nothing' } # connectionless sockets |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
# Map family/protocol pairs to connection or connectionless |
112
|
|
|
|
|
|
|
# operations. |
113
|
|
|
|
|
|
|
my %supported_protocol = ( |
114
|
|
|
|
|
|
|
DOM_UNIX, { |
115
|
|
|
|
|
|
|
none => SVROP_LISTENS |
116
|
|
|
|
|
|
|
}, |
117
|
|
|
|
|
|
|
DOM_INET, { |
118
|
|
|
|
|
|
|
tcp => SVROP_LISTENS, |
119
|
|
|
|
|
|
|
udp => SVROP_NOTHING, |
120
|
|
|
|
|
|
|
}, |
121
|
|
|
|
|
|
|
DOM_INET6, { |
122
|
|
|
|
|
|
|
tcp => SVROP_LISTENS, |
123
|
|
|
|
|
|
|
udp => SVROP_NOTHING, |
124
|
|
|
|
|
|
|
}, |
125
|
|
|
|
|
|
|
); |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
# Sane default socket types for each supported protocol. TODO Maybe |
128
|
|
|
|
|
|
|
# this structure can be combined with %supported_protocol? |
129
|
|
|
|
|
|
|
my %default_socket_type = ( |
130
|
|
|
|
|
|
|
DOM_UNIX, { |
131
|
|
|
|
|
|
|
none => SOCK_STREAM |
132
|
|
|
|
|
|
|
}, |
133
|
|
|
|
|
|
|
DOM_INET, { |
134
|
|
|
|
|
|
|
tcp => SOCK_STREAM, |
135
|
|
|
|
|
|
|
udp => SOCK_DGRAM, |
136
|
|
|
|
|
|
|
}, |
137
|
|
|
|
|
|
|
DOM_INET6, { |
138
|
|
|
|
|
|
|
tcp => SOCK_STREAM, |
139
|
|
|
|
|
|
|
udp => SOCK_DGRAM, |
140
|
|
|
|
|
|
|
}, |
141
|
|
|
|
|
|
|
); |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
144
|
|
|
|
|
|
|
# Perform system-dependent translations on Unix addresses, if |
145
|
|
|
|
|
|
|
# necessary. |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
sub _condition_unix_address { |
148
|
4
|
|
|
4
|
|
5
|
my ($address) = @_; |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# OS/2 would like sockets to use backwhacks, and please place them |
151
|
|
|
|
|
|
|
# in the virtual \socket\ directory. Thank you. |
152
|
4
|
50
|
|
|
|
24
|
if ($^O eq 'os2') { |
153
|
0
|
|
|
|
|
0
|
$address =~ tr[\\][/]; |
154
|
0
|
0
|
|
|
|
0
|
if ($address !~ m{^/socket/}) { |
155
|
0
|
|
|
|
|
0
|
$address =~ s{^/?}{/socket/}; |
156
|
|
|
|
|
|
|
} |
157
|
0
|
|
|
|
|
0
|
$address =~ tr[/][\\]; |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
4
|
|
|
|
|
9
|
$address; |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
164
|
|
|
|
|
|
|
# Define the select handler that will accept connections. |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
sub _define_accept_state { |
167
|
22
|
|
|
22
|
|
47
|
my $self = shift; |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
# We do these stupid closure tricks to avoid putting $self in it |
170
|
|
|
|
|
|
|
# directly. If you include $self in one of the state() closures, |
171
|
|
|
|
|
|
|
# the component will fail to shut down properly: there will be a |
172
|
|
|
|
|
|
|
# circular definition in the closure holding $self alive. |
173
|
|
|
|
|
|
|
|
174
|
22
|
|
|
|
|
53
|
my $domain = $map_family_to_domain{ $self->[MY_SOCKET_DOMAIN] }; |
175
|
22
|
50
|
|
|
|
69
|
$domain = '(undef)' unless defined $domain; |
176
|
22
|
|
|
|
|
42
|
my $event_success = \$self->[MY_EVENT_SUCCESS]; |
177
|
22
|
|
|
|
|
45
|
my $event_failure = \$self->[MY_EVENT_FAILURE]; |
178
|
22
|
|
|
|
|
41
|
my $unique_id = $self->[MY_UNIQUE_ID]; |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
$poe_kernel->state( |
181
|
|
|
|
|
|
|
$self->[MY_STATE_ACCEPT] = ref($self) . "($unique_id) -> select accept", |
182
|
|
|
|
|
|
|
sub { |
183
|
|
|
|
|
|
|
# prevents SEGV |
184
|
64
|
|
|
64
|
|
84
|
0 && CRIMSON_SCOPE_HACK('<'); |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
# subroutine starts here |
187
|
64
|
|
|
|
|
165
|
my ($k, $me, $handle) = @_[KERNEL, SESSION, ARG0]; |
188
|
|
|
|
|
|
|
|
189
|
64
|
|
|
|
|
257
|
my $new_socket = gensym; |
190
|
64
|
|
|
|
|
2469
|
my $peer = accept($new_socket, $handle); |
191
|
|
|
|
|
|
|
|
192
|
64
|
50
|
0
|
|
|
172
|
if ($peer) { |
|
|
0
|
0
|
|
|
|
|
193
|
64
|
|
|
|
|
91
|
my ($peer_addr, $peer_port); |
194
|
64
|
100
|
|
|
|
295
|
if ( $domain eq DOM_UNIX ) { |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
195
|
2
|
|
|
|
|
2
|
$peer_port = undef; |
196
|
2
|
|
|
|
|
3
|
eval { $peer_addr = unpack_sockaddr_un($peer) }; |
|
2
|
|
|
|
|
9
|
|
197
|
2
|
50
|
|
|
|
11
|
$peer_addr = undef if length $@; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
elsif ( $domain eq DOM_INET ) { |
200
|
62
|
|
|
|
|
348
|
($peer_port, $peer_addr) = unpack_sockaddr_in($peer); |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
elsif ( $domain eq DOM_INET6 ) { |
203
|
0
|
|
|
|
|
0
|
($peer_port, $peer_addr) = unpack_sockaddr_in6($peer); |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
else { |
206
|
0
|
|
|
|
|
0
|
die "sanity failure: socket domain == $domain"; |
207
|
|
|
|
|
|
|
} |
208
|
64
|
|
|
|
|
300
|
$k->call( |
209
|
|
|
|
|
|
|
$me, $$event_success, |
210
|
|
|
|
|
|
|
$new_socket, $peer_addr, $peer_port, |
211
|
|
|
|
|
|
|
$unique_id |
212
|
|
|
|
|
|
|
); |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
elsif ($! != EWOULDBLOCK and $! != ECONNABORTED and $! != ESPIPE) { |
215
|
|
|
|
|
|
|
# OSX reports ESPIPE, which isn't documented anywhere. |
216
|
0
|
0
|
|
|
|
0
|
$$event_failure && $k->call( |
217
|
|
|
|
|
|
|
$me, $$event_failure, |
218
|
|
|
|
|
|
|
'accept', ($!+0), $!, $unique_id |
219
|
|
|
|
|
|
|
); |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
} |
222
|
22
|
|
|
|
|
306
|
); |
223
|
|
|
|
|
|
|
|
224
|
22
|
|
|
|
|
50
|
$self->[MY_SOCKET_SELECTED] = 'yes'; |
225
|
22
|
|
|
|
|
114
|
$poe_kernel->select_read( |
226
|
|
|
|
|
|
|
$self->[MY_SOCKET_HANDLE], |
227
|
|
|
|
|
|
|
$self->[MY_STATE_ACCEPT] |
228
|
|
|
|
|
|
|
); |
229
|
|
|
|
|
|
|
} |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
232
|
|
|
|
|
|
|
# Define the select handler that will finalize an established |
233
|
|
|
|
|
|
|
# connection. |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
sub _define_connect_state { |
236
|
77
|
|
|
77
|
|
110
|
my $self = shift; |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
# We do these stupid closure tricks to avoid putting $self in it |
239
|
|
|
|
|
|
|
# directly. If you include $self in one of the state() closures, |
240
|
|
|
|
|
|
|
# the component will fail to shut down properly: there will be a |
241
|
|
|
|
|
|
|
# circular definition in the closure holding $self alive. |
242
|
|
|
|
|
|
|
|
243
|
77
|
|
|
|
|
175
|
my $domain = $map_family_to_domain{ $self->[MY_SOCKET_DOMAIN] }; |
244
|
77
|
50
|
|
|
|
171
|
$domain = '(undef)' unless defined $domain; |
245
|
77
|
|
|
|
|
130
|
my $event_success = \$self->[MY_EVENT_SUCCESS]; |
246
|
77
|
|
|
|
|
121
|
my $event_failure = \$self->[MY_EVENT_FAILURE]; |
247
|
77
|
|
|
|
|
143
|
my $unique_id = $self->[MY_UNIQUE_ID]; |
248
|
77
|
|
|
|
|
125
|
my $socket_selected = \$self->[MY_SOCKET_SELECTED]; |
249
|
|
|
|
|
|
|
|
250
|
77
|
|
|
|
|
127
|
my $socket_handle = \$self->[MY_SOCKET_HANDLE]; |
251
|
77
|
|
|
|
|
103
|
my $state_accept = \$self->[MY_STATE_ACCEPT]; |
252
|
77
|
|
|
|
|
104
|
my $state_connect = \$self->[MY_STATE_CONNECT]; |
253
|
77
|
|
|
|
|
115
|
my $mine_success = \$self->[MY_MINE_SUCCESS]; |
254
|
77
|
|
|
|
|
106
|
my $mine_failure = \$self->[MY_MINE_FAILURE]; |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
$poe_kernel->state( |
257
|
|
|
|
|
|
|
$self->[MY_STATE_CONNECT] = ( |
258
|
|
|
|
|
|
|
ref($self) . "($unique_id) -> select connect" |
259
|
|
|
|
|
|
|
), |
260
|
|
|
|
|
|
|
sub { |
261
|
|
|
|
|
|
|
# This prevents SEGV in older versions of Perl. |
262
|
77
|
|
|
77
|
|
88
|
0 && CRIMSON_SCOPE_HACK('<'); |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
# Grab some values and stop watching the socket. |
265
|
77
|
|
|
|
|
162
|
my ($k, $me, $handle) = @_[KERNEL, SESSION, ARG0]; |
266
|
|
|
|
|
|
|
|
267
|
77
|
|
|
|
|
179
|
_shutdown( |
268
|
|
|
|
|
|
|
$socket_selected, $socket_handle, |
269
|
|
|
|
|
|
|
$state_accept, $state_connect, |
270
|
|
|
|
|
|
|
$mine_success, $event_success, |
271
|
|
|
|
|
|
|
$mine_failure, $event_failure, |
272
|
|
|
|
|
|
|
); |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
# Throw a failure if the connection failed. |
275
|
77
|
|
|
|
|
769
|
$! = unpack('i', getsockopt($handle, SOL_SOCKET, SO_ERROR)); |
276
|
77
|
100
|
|
|
|
297
|
if ($!) { |
277
|
3
|
50
|
|
|
|
66
|
(defined $$event_failure) and $k->call( |
278
|
|
|
|
|
|
|
$me, $$event_failure, |
279
|
|
|
|
|
|
|
'connect', ($!+0), $!, $unique_id |
280
|
|
|
|
|
|
|
); |
281
|
3
|
|
|
|
|
82
|
return; |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
# Get the remote address, or throw an error if that fails. |
285
|
74
|
|
|
|
|
246
|
my $peer = getpeername($handle); |
286
|
74
|
50
|
|
|
|
171
|
if ($!) { |
287
|
0
|
0
|
|
|
|
0
|
(defined $$event_failure) and $k->call( |
288
|
|
|
|
|
|
|
$me, $$event_failure, |
289
|
|
|
|
|
|
|
'getpeername', ($!+0), $!, $unique_id |
290
|
|
|
|
|
|
|
); |
291
|
0
|
|
|
|
|
0
|
return; |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
# Parse the remote address according to the socket's domain. |
295
|
74
|
|
|
|
|
83
|
my ($peer_addr, $peer_port); |
296
|
|
|
|
|
|
|
|
297
|
|
|
|
|
|
|
# UNIX sockets have some trouble with peer addresses. |
298
|
74
|
100
|
|
|
|
218
|
if ($domain eq DOM_UNIX) { |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
299
|
2
|
50
|
|
|
|
6
|
if (defined $peer) { |
300
|
2
|
|
|
|
|
2
|
eval { $peer_addr = unpack_sockaddr_un($peer) }; |
|
2
|
|
|
|
|
14
|
|
301
|
2
|
50
|
|
|
|
7
|
$peer_addr = undef if length $@; |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
# INET socket stacks tend not to. |
306
|
|
|
|
|
|
|
elsif ($domain eq DOM_INET) { |
307
|
72
|
50
|
|
|
|
188
|
if (defined $peer) { |
308
|
72
|
|
|
|
|
90
|
eval { |
309
|
72
|
|
|
|
|
304
|
($peer_port, $peer_addr) = unpack_sockaddr_in($peer); |
310
|
|
|
|
|
|
|
}; |
311
|
72
|
50
|
|
|
|
183
|
if (length $@) { |
312
|
0
|
|
|
|
|
0
|
$peer_port = $peer_addr = undef; |
313
|
|
|
|
|
|
|
} |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
# INET6 socket stacks tend not to. |
318
|
|
|
|
|
|
|
elsif ($domain eq DOM_INET6) { |
319
|
0
|
0
|
|
|
|
0
|
if (defined $peer) { |
320
|
0
|
|
|
|
|
0
|
eval { |
321
|
0
|
|
|
|
|
0
|
($peer_port, $peer_addr) = unpack_sockaddr_in6($peer); |
322
|
|
|
|
|
|
|
}; |
323
|
0
|
0
|
|
|
|
0
|
if (length $@) { |
324
|
0
|
|
|
|
|
0
|
$peer_port = $peer_addr = undef; |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
# What are we doing here? |
330
|
|
|
|
|
|
|
else { |
331
|
0
|
|
|
|
|
0
|
die "sanity failure: socket domain == $domain"; |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
|
334
|
|
|
|
|
|
|
# Tell the session it went okay. Also let go of the socket. |
335
|
74
|
|
|
|
|
238
|
$k->call( |
336
|
|
|
|
|
|
|
$me, $$event_success, |
337
|
|
|
|
|
|
|
$handle, $peer_addr, $peer_port, $unique_id |
338
|
|
|
|
|
|
|
); |
339
|
|
|
|
|
|
|
} |
340
|
77
|
|
|
|
|
1330
|
); |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
# Cygwin and Windows expect an error state registered to expedite. |
343
|
|
|
|
|
|
|
# This code is nearly identical the stuff above. |
344
|
77
|
50
|
33
|
|
|
493
|
if ($^O eq "cygwin" or $^O eq "MSWin32") { |
345
|
|
|
|
|
|
|
$poe_kernel->state( |
346
|
|
|
|
|
|
|
$self->[MY_STATE_ERROR] = ( |
347
|
|
|
|
|
|
|
ref($self) . "($unique_id) -> connect error" |
348
|
|
|
|
|
|
|
), |
349
|
|
|
|
|
|
|
sub { |
350
|
|
|
|
|
|
|
# This prevents SEGV in older versions of Perl. |
351
|
0
|
|
|
0
|
|
0
|
0 && CRIMSON_SCOPE_HACK('<'); |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
# Grab some values and stop watching the socket. |
354
|
0
|
|
|
|
|
0
|
my ($k, $me, $handle) = @_[KERNEL, SESSION, ARG0]; |
355
|
|
|
|
|
|
|
|
356
|
0
|
|
|
|
|
0
|
_shutdown( |
357
|
|
|
|
|
|
|
$socket_selected, $socket_handle, |
358
|
|
|
|
|
|
|
$state_accept, $state_connect, |
359
|
|
|
|
|
|
|
$mine_success, $event_success, |
360
|
|
|
|
|
|
|
$mine_failure, $event_failure, |
361
|
|
|
|
|
|
|
); |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
# Throw a failure if the connection failed. |
364
|
0
|
|
|
|
|
0
|
$! = unpack('i', getsockopt($handle, SOL_SOCKET, SO_ERROR)); |
365
|
0
|
0
|
|
|
|
0
|
if ($!) { |
366
|
0
|
0
|
|
|
|
0
|
(defined $$event_failure) and $k->call( |
367
|
|
|
|
|
|
|
$me, $$event_failure, 'connect', ($!+0), $!, $unique_id |
368
|
|
|
|
|
|
|
); |
369
|
0
|
|
|
|
|
0
|
return; |
370
|
|
|
|
|
|
|
} |
371
|
|
|
|
|
|
|
} |
372
|
0
|
|
|
|
|
0
|
); |
373
|
0
|
|
|
|
|
0
|
$poe_kernel->select_expedite( |
374
|
|
|
|
|
|
|
$self->[MY_SOCKET_HANDLE], |
375
|
|
|
|
|
|
|
$self->[MY_STATE_ERROR] |
376
|
|
|
|
|
|
|
); |
377
|
|
|
|
|
|
|
} |
378
|
|
|
|
|
|
|
|
379
|
77
|
|
|
|
|
124
|
$self->[MY_SOCKET_SELECTED] = 'yes'; |
380
|
77
|
|
|
|
|
268
|
$poe_kernel->select_write( |
381
|
|
|
|
|
|
|
$self->[MY_SOCKET_HANDLE], |
382
|
|
|
|
|
|
|
$self->[MY_STATE_CONNECT] |
383
|
|
|
|
|
|
|
); |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
sub event { |
389
|
101
|
|
|
101
|
1
|
129
|
my $self = shift; |
390
|
101
|
50
|
|
|
|
368
|
push(@_, undef) if (scalar(@_) & 1); |
391
|
|
|
|
|
|
|
|
392
|
101
|
|
|
|
|
252
|
while (@_) { |
393
|
202
|
|
|
|
|
414
|
my ($name, $event) = splice(@_, 0, 2); |
394
|
|
|
|
|
|
|
|
395
|
202
|
100
|
|
|
|
466
|
if ($name eq 'SuccessEvent') { |
|
|
50
|
|
|
|
|
|
396
|
101
|
50
|
|
|
|
186
|
if (defined $event) { |
397
|
101
|
50
|
|
|
|
1457
|
if (ref($event)) { |
398
|
0
|
|
|
|
|
0
|
carp "reference for SuccessEvent will be treated as an event name" |
399
|
|
|
|
|
|
|
} |
400
|
101
|
|
|
|
|
154
|
$self->[MY_EVENT_SUCCESS] = $event; |
401
|
101
|
|
|
|
|
280
|
undef $self->[MY_MINE_SUCCESS]; |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
else { |
404
|
0
|
|
|
|
|
0
|
carp "SuccessEvent requires an event name. ignoring undef"; |
405
|
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
elsif ($name eq 'FailureEvent') { |
408
|
101
|
50
|
|
|
|
199
|
if (defined $event) { |
409
|
101
|
50
|
|
|
|
217
|
if (ref($event)) { |
410
|
0
|
|
|
|
|
0
|
carp "reference for FailureEvent will be treated as an event name"; |
411
|
|
|
|
|
|
|
} |
412
|
101
|
|
|
|
|
124
|
$self->[MY_EVENT_FAILURE] = $event; |
413
|
101
|
|
|
|
|
249
|
undef $self->[MY_MINE_FAILURE]; |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
else { |
416
|
0
|
|
|
|
|
0
|
carp "FailureEvent requires an event name. ignoring undef"; |
417
|
|
|
|
|
|
|
} |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
else { |
420
|
0
|
|
|
|
|
0
|
carp "ignoring unknown SocketFactory parameter '$name'"; |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
|
424
|
101
|
|
|
|
|
150
|
$self->[MY_SOCKET_SELECTED] = 'yes'; |
425
|
101
|
100
|
|
|
|
292
|
if (defined $self->[MY_STATE_ACCEPT]) { |
|
|
50
|
|
|
|
|
|
426
|
22
|
|
|
|
|
91
|
$poe_kernel->select_read( |
427
|
|
|
|
|
|
|
$self->[MY_SOCKET_HANDLE], |
428
|
|
|
|
|
|
|
$self->[MY_STATE_ACCEPT] |
429
|
|
|
|
|
|
|
); |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
elsif (defined $self->[MY_STATE_CONNECT]) { |
432
|
79
|
|
|
|
|
236
|
$poe_kernel->select_write( |
433
|
|
|
|
|
|
|
$self->[MY_SOCKET_HANDLE], |
434
|
|
|
|
|
|
|
$self->[MY_STATE_CONNECT] |
435
|
|
|
|
|
|
|
); |
436
|
79
|
50
|
33
|
|
|
510
|
if ($^O eq "cygwin" or $^O eq "MSWin32") { |
437
|
0
|
|
|
|
|
0
|
$poe_kernel->select_expedite( |
438
|
|
|
|
|
|
|
$self->[MY_SOCKET_HANDLE], |
439
|
|
|
|
|
|
|
$self->[MY_STATE_ERROR] |
440
|
|
|
|
|
|
|
); |
441
|
|
|
|
|
|
|
} |
442
|
|
|
|
|
|
|
} |
443
|
|
|
|
|
|
|
else { |
444
|
0
|
|
|
|
|
0
|
die "POE developer error - no state defined"; |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
sub getsockname { |
451
|
24
|
|
|
24
|
1
|
148
|
my $self = shift; |
452
|
|
|
|
|
|
|
return undef unless ( |
453
|
24
|
50
|
33
|
|
|
194
|
defined $self->[MY_SOCKET_HANDLE] and |
454
|
|
|
|
|
|
|
fileno($self->[MY_SOCKET_HANDLE]) |
455
|
|
|
|
|
|
|
); |
456
|
24
|
|
|
|
|
252
|
return getsockname($self->[MY_SOCKET_HANDLE]); |
457
|
|
|
|
|
|
|
} |
458
|
|
|
|
|
|
|
|
459
|
|
|
|
|
|
|
sub ID { |
460
|
10
|
|
|
10
|
1
|
63
|
return $_[0]->[MY_UNIQUE_ID]; |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
464
|
|
|
|
|
|
|
|
465
|
|
|
|
|
|
|
sub new { |
466
|
103
|
|
|
103
|
1
|
549
|
my $type = shift; |
467
|
|
|
|
|
|
|
|
468
|
|
|
|
|
|
|
# Don't take responsibility for a bad parameter count. |
469
|
103
|
50
|
|
|
|
300
|
croak "$type requires an even number of parameters" if @_ & 1; |
470
|
|
|
|
|
|
|
|
471
|
103
|
|
|
|
|
473
|
my %params = @_; |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
# The calling convention experienced a hard deprecation. |
474
|
103
|
50
|
33
|
|
|
543
|
croak "wheels no longer require a kernel reference as their first parameter" |
475
|
|
|
|
|
|
|
if (@_ && (ref($_[0]) eq 'POE::Kernel')); |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
# Ensure some of the basic things are present. |
478
|
103
|
50
|
|
|
|
242
|
croak "$type requires a working Kernel" unless (defined $poe_kernel); |
479
|
103
|
50
|
|
|
|
253
|
croak 'SuccessEvent required' unless (defined $params{SuccessEvent}); |
480
|
103
|
50
|
|
|
|
220
|
croak 'FailureEvent required' unless (defined $params{FailureEvent}); |
481
|
103
|
|
|
|
|
138
|
my $event_success = $params{SuccessEvent}; |
482
|
103
|
|
|
|
|
130
|
my $event_failure = $params{FailureEvent}; |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
# Create the SocketServer. Cache a copy of the socket handle. |
485
|
103
|
|
|
|
|
353
|
my $socket_handle = gensym(); |
486
|
103
|
|
|
|
|
1551
|
my $self = bless( |
487
|
|
|
|
|
|
|
[ |
488
|
|
|
|
|
|
|
$socket_handle, # MY_SOCKET_HANDLE |
489
|
|
|
|
|
|
|
&POE::Wheel::allocate_wheel_id(), # MY_UNIQUE_ID |
490
|
|
|
|
|
|
|
$event_success, # MY_EVENT_SUCCESS |
491
|
|
|
|
|
|
|
$event_failure, # MY_EVENT_FAILURE |
492
|
|
|
|
|
|
|
undef, # MY_SOCKET_DOMAIN |
493
|
|
|
|
|
|
|
undef, # MY_STATE_ACCEPT |
494
|
|
|
|
|
|
|
undef, # MY_STATE_CONNECT |
495
|
|
|
|
|
|
|
undef, # MY_MINE_SUCCESS |
496
|
|
|
|
|
|
|
undef, # MY_MINE_FAILURE |
497
|
|
|
|
|
|
|
undef, # MY_SOCKET_PROTOCOL |
498
|
|
|
|
|
|
|
undef, # MY_SOCKET_TYPE |
499
|
|
|
|
|
|
|
undef, # MY_STATE_ERROR |
500
|
|
|
|
|
|
|
undef, # MY_SOCKET_SELECTED |
501
|
|
|
|
|
|
|
], |
502
|
|
|
|
|
|
|
$type |
503
|
|
|
|
|
|
|
); |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
# Default to Internet sockets. |
506
|
103
|
|
|
|
|
230
|
my $domain = delete $params{SocketDomain}; |
507
|
103
|
100
|
|
|
|
249
|
if (defined $domain) { |
508
|
|
|
|
|
|
|
# [rt.cpan.org 76314] Untaint the domain. |
509
|
24
|
|
|
|
|
190
|
($domain) = ($domain =~ /\A(.*)\z/s); |
510
|
|
|
|
|
|
|
} |
511
|
|
|
|
|
|
|
else { |
512
|
79
|
|
|
|
|
118
|
$domain = AF_INET; |
513
|
|
|
|
|
|
|
} |
514
|
103
|
|
|
|
|
296
|
$self->[MY_SOCKET_DOMAIN] = $domain; |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
# Abstract the socket domain into something we don't have to keep |
517
|
|
|
|
|
|
|
# testing duplicates of. |
518
|
103
|
|
|
|
|
215
|
my $abstract_domain = $map_family_to_domain{$self->[MY_SOCKET_DOMAIN]}; |
519
|
103
|
50
|
|
|
|
243
|
unless (defined $abstract_domain) { |
520
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
521
|
|
|
|
|
|
|
$event_failure, |
522
|
|
|
|
|
|
|
'domain', |
523
|
|
|
|
|
|
|
0, |
524
|
|
|
|
|
|
|
"SocketDomain $domain is currently unsupported on this platform", |
525
|
|
|
|
|
|
|
$self->[MY_UNIQUE_ID] |
526
|
|
|
|
|
|
|
); |
527
|
0
|
|
|
|
|
0
|
return $self; |
528
|
|
|
|
|
|
|
} |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
#---------------# |
531
|
|
|
|
|
|
|
# Create Socket # |
532
|
|
|
|
|
|
|
#---------------# |
533
|
|
|
|
|
|
|
|
534
|
|
|
|
|
|
|
# Declare the protocol name out here; it'll be needed by |
535
|
|
|
|
|
|
|
# getservbyname later. |
536
|
103
|
|
|
|
|
107
|
my $protocol_name; |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
# Unix sockets don't use protocols; warn the programmer, and force |
539
|
|
|
|
|
|
|
# PF_UNSPEC. |
540
|
103
|
100
|
33
|
|
|
437
|
if ($abstract_domain eq DOM_UNIX) { |
|
|
50
|
|
|
|
|
|
541
|
4
|
50
|
|
|
|
17
|
carp 'SocketProtocol ignored for Unix socket' |
542
|
|
|
|
|
|
|
if defined $params{SocketProtocol}; |
543
|
4
|
|
|
|
|
9
|
$self->[MY_SOCKET_PROTOCOL] = PF_UNSPEC; |
544
|
4
|
|
|
|
|
8
|
$protocol_name = 'none'; |
545
|
|
|
|
|
|
|
} |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
# Internet sockets use protocols. Default the INET protocol to tcp, |
548
|
|
|
|
|
|
|
# and try to resolve it. |
549
|
|
|
|
|
|
|
elsif ( |
550
|
|
|
|
|
|
|
$abstract_domain eq DOM_INET or |
551
|
|
|
|
|
|
|
$abstract_domain eq DOM_INET6 |
552
|
|
|
|
|
|
|
) { |
553
|
99
|
100
|
|
|
|
351
|
my $socket_protocol = ( |
554
|
|
|
|
|
|
|
(defined $params{SocketProtocol}) |
555
|
|
|
|
|
|
|
? $params{SocketProtocol} |
556
|
|
|
|
|
|
|
: 'tcp' |
557
|
|
|
|
|
|
|
); |
558
|
|
|
|
|
|
|
|
559
|
|
|
|
|
|
|
|
560
|
99
|
50
|
|
|
|
433
|
if ($socket_protocol !~ /^\d+$/) { |
561
|
99
|
50
|
33
|
|
|
477
|
unless ($socket_protocol = $proto_by_name{$socket_protocol} || eval { getprotobyname($socket_protocol) }) { |
562
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
563
|
|
|
|
|
|
|
$event_failure, 'getprotobyname', $!+0, $!, $self->[MY_UNIQUE_ID] |
564
|
|
|
|
|
|
|
); |
565
|
0
|
|
|
|
|
0
|
return $self; |
566
|
|
|
|
|
|
|
} |
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
# Get the protocol's name regardless of what was provided. If the |
570
|
|
|
|
|
|
|
# protocol isn't supported, croak now instead of making the |
571
|
|
|
|
|
|
|
# programmer wonder why things fail later. |
572
|
99
|
|
33
|
|
|
259
|
$protocol_name = $proto_by_number{$socket_protocol} || eval { lc(getprotobynumber($socket_protocol)) }; |
573
|
99
|
50
|
|
|
|
197
|
unless ($protocol_name) { |
574
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
575
|
|
|
|
|
|
|
$event_failure, 'getprotobynumber', $!+0, $!, $self->[MY_UNIQUE_ID] |
576
|
|
|
|
|
|
|
); |
577
|
0
|
|
|
|
|
0
|
return $self; |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
|
580
|
99
|
50
|
|
|
|
293
|
unless (defined $supported_protocol{$abstract_domain}->{$protocol_name}) { |
581
|
0
|
|
|
|
|
0
|
croak "SocketFactory does not support Internet $protocol_name sockets"; |
582
|
|
|
|
|
|
|
} |
583
|
|
|
|
|
|
|
|
584
|
99
|
|
|
|
|
182
|
$self->[MY_SOCKET_PROTOCOL] = $socket_protocol; |
585
|
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
|
else { |
587
|
0
|
|
|
|
|
0
|
die "Mail this error to the author of POE: Internal consistency error"; |
588
|
|
|
|
|
|
|
} |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
# If no SocketType, default it to something appropriate. |
591
|
103
|
50
|
|
|
|
378
|
if (defined $params{SocketType}) { |
592
|
0
|
|
|
|
|
0
|
$self->[MY_SOCKET_TYPE] = $params{SocketType}; |
593
|
|
|
|
|
|
|
} |
594
|
|
|
|
|
|
|
else { |
595
|
103
|
50
|
|
|
|
306
|
unless (defined $default_socket_type{$abstract_domain}->{$protocol_name}) { |
596
|
0
|
|
|
|
|
0
|
croak "SocketFactory does not support $abstract_domain $protocol_name"; |
597
|
|
|
|
|
|
|
} |
598
|
103
|
|
|
|
|
184
|
$self->[MY_SOCKET_TYPE] = |
599
|
|
|
|
|
|
|
$default_socket_type{$abstract_domain}->{$protocol_name}; |
600
|
|
|
|
|
|
|
} |
601
|
|
|
|
|
|
|
|
602
|
|
|
|
|
|
|
# o create a dummy socket |
603
|
|
|
|
|
|
|
# o cache the value of SO_OPENTYPE in $win32_socket_opt |
604
|
|
|
|
|
|
|
# o set the overlapped io attribute |
605
|
|
|
|
|
|
|
# o close dummy socket |
606
|
103
|
|
|
|
|
112
|
my $win32_socket_opt; |
607
|
103
|
50
|
|
|
|
293
|
if ( POE::Kernel::RUNNING_IN_HELL) { |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
# Constants are evaluated first so they exist when the code uses |
610
|
|
|
|
|
|
|
# them. |
611
|
0
|
|
|
|
|
0
|
eval { |
612
|
0
|
|
|
|
|
0
|
*SO_OPENTYPE = sub () { 0x7008 }; |
613
|
0
|
|
|
|
|
0
|
*SO_SYNCHRONOUS_ALERT = sub () { 0x10 }; |
614
|
0
|
|
|
|
|
0
|
*SO_SYNCHRONOUS_NONALERT = sub () { 0x20 }; |
615
|
|
|
|
|
|
|
}; |
616
|
0
|
0
|
|
|
|
0
|
die "Could not install SO constants [$@]" if $@; |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
# Turn on socket overlapped IO attribute per MSKB: Q181611. |
619
|
|
|
|
|
|
|
|
620
|
0
|
|
|
|
|
0
|
eval { |
621
|
0
|
0
|
|
|
|
0
|
socket(POE, AF_INET, SOCK_STREAM, IPPROTO_TCP) |
622
|
|
|
|
|
|
|
or die "socket failed: $!"; |
623
|
0
|
|
|
|
|
0
|
my $opt = unpack("I", getsockopt(POE, SOL_SOCKET, SO_OPENTYPE())); |
624
|
0
|
|
|
|
|
0
|
$win32_socket_opt = $opt; |
625
|
0
|
|
|
|
|
0
|
$opt &= ~(SO_SYNCHRONOUS_ALERT()|SO_SYNCHRONOUS_NONALERT()); |
626
|
0
|
|
|
|
|
0
|
setsockopt(POE, SOL_SOCKET, SO_OPENTYPE(), $opt); |
627
|
0
|
|
|
|
|
0
|
close POE; |
628
|
|
|
|
|
|
|
}; |
629
|
|
|
|
|
|
|
|
630
|
0
|
0
|
|
|
|
0
|
die if $@; |
631
|
|
|
|
|
|
|
} |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
# Create the socket. |
634
|
103
|
50
|
|
|
|
3128
|
unless ( |
635
|
|
|
|
|
|
|
socket( $socket_handle, $self->[MY_SOCKET_DOMAIN], |
636
|
|
|
|
|
|
|
$self->[MY_SOCKET_TYPE], $self->[MY_SOCKET_PROTOCOL] |
637
|
|
|
|
|
|
|
) |
638
|
|
|
|
|
|
|
) { |
639
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
640
|
|
|
|
|
|
|
$event_failure, 'socket', $!+0, $!, $self->[MY_UNIQUE_ID] |
641
|
|
|
|
|
|
|
); |
642
|
0
|
|
|
|
|
0
|
return $self; |
643
|
|
|
|
|
|
|
} |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
# o create a dummy socket |
646
|
|
|
|
|
|
|
# o restore previous value of SO_OPENTYPE |
647
|
|
|
|
|
|
|
# o close dummy socket |
648
|
|
|
|
|
|
|
# |
649
|
|
|
|
|
|
|
# This way we'd only be turning on the overlap attribute for |
650
|
|
|
|
|
|
|
# the socket we created... and not all subsequent sockets. |
651
|
103
|
50
|
|
|
|
277
|
if ( POE::Kernel::RUNNING_IN_HELL) { |
652
|
0
|
|
|
|
|
0
|
eval { |
653
|
0
|
0
|
|
|
|
0
|
socket(POE, AF_INET, SOCK_STREAM, IPPROTO_TCP) |
654
|
|
|
|
|
|
|
or die "socket failed: $!"; |
655
|
0
|
|
|
|
|
0
|
setsockopt(POE, SOL_SOCKET, SO_OPENTYPE(), $win32_socket_opt); |
656
|
0
|
|
|
|
|
0
|
close POE; |
657
|
|
|
|
|
|
|
}; |
658
|
|
|
|
|
|
|
|
659
|
0
|
0
|
|
|
|
0
|
die if $@; |
660
|
|
|
|
|
|
|
} |
661
|
103
|
|
|
|
|
132
|
DEBUG && warn "socket"; |
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
#------------------# |
664
|
|
|
|
|
|
|
# Configure Socket # |
665
|
|
|
|
|
|
|
#------------------# |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
# Make the socket binary. It's wrapped in eval{} because tied |
668
|
|
|
|
|
|
|
# filehandle classes may actually die in their binmode methods. |
669
|
103
|
|
|
|
|
143
|
eval { binmode($socket_handle) }; |
|
103
|
|
|
|
|
271
|
|
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
# Don't block on socket operations, because the socket will be |
672
|
|
|
|
|
|
|
# driven by a select loop. |
673
|
103
|
|
|
|
|
579
|
$socket_handle->blocking(0); |
674
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
# Make the socket reusable, if requested. |
676
|
103
|
0
|
33
|
|
|
403
|
if ( |
|
|
|
66
|
|
|
|
|
677
|
|
|
|
|
|
|
(defined $params{Reuse}) |
678
|
|
|
|
|
|
|
and ( (lc($params{Reuse}) eq 'yes') |
679
|
|
|
|
|
|
|
or (lc($params{Reuse}) eq 'on') |
680
|
|
|
|
|
|
|
or ( ($params{Reuse} =~ /\d+/) |
681
|
|
|
|
|
|
|
and $params{Reuse} |
682
|
|
|
|
|
|
|
) |
683
|
|
|
|
|
|
|
) |
684
|
|
|
|
|
|
|
) |
685
|
|
|
|
|
|
|
{ |
686
|
24
|
50
|
|
|
|
213
|
setsockopt($socket_handle, SOL_SOCKET, SO_REUSEADDR, 1) or do { |
687
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
688
|
|
|
|
|
|
|
$event_failure, |
689
|
|
|
|
|
|
|
'setsockopt', $!+0, $!, $self->[MY_UNIQUE_ID] |
690
|
|
|
|
|
|
|
); |
691
|
0
|
|
|
|
|
0
|
return $self; |
692
|
|
|
|
|
|
|
}; |
693
|
|
|
|
|
|
|
} |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
#-------------# |
696
|
|
|
|
|
|
|
# Bind Socket # |
697
|
|
|
|
|
|
|
#-------------# |
698
|
|
|
|
|
|
|
|
699
|
103
|
|
|
|
|
123
|
my $bind_address; |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
# Check SocketFactory /Bind.*/ parameters in an Internet socket |
702
|
|
|
|
|
|
|
# context, and translate them into parameters that bind() |
703
|
|
|
|
|
|
|
# understands. |
704
|
103
|
100
|
|
|
|
249
|
if ($abstract_domain eq DOM_INET) { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
705
|
|
|
|
|
|
|
# Don't bind if the creator doesn't specify a related parameter. |
706
|
99
|
100
|
66
|
|
|
509
|
if ((defined $params{BindAddress}) or (defined $params{BindPort})) { |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
# Set the bind address, or default to INADDR_ANY. |
709
|
24
|
50
|
|
|
|
89
|
$bind_address = ( |
710
|
|
|
|
|
|
|
(defined $params{BindAddress}) |
711
|
|
|
|
|
|
|
? $params{BindAddress} |
712
|
|
|
|
|
|
|
: INADDR_ANY |
713
|
|
|
|
|
|
|
); |
714
|
|
|
|
|
|
|
|
715
|
|
|
|
|
|
|
# Need to check lengths in octets, not characters. |
716
|
23
|
50
|
|
23
|
|
58
|
BEGIN { eval { require bytes } and bytes->import; } |
|
23
|
|
|
|
|
1473
|
|
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
# Resolve the bind address if it's not already packed. |
719
|
24
|
50
|
|
|
|
109
|
unless (length($bind_address) == 4) { |
720
|
24
|
|
|
|
|
1065
|
$bind_address = inet_aton($bind_address); |
721
|
|
|
|
|
|
|
} |
722
|
|
|
|
|
|
|
|
723
|
24
|
50
|
|
|
|
79
|
unless (defined $bind_address) { |
724
|
0
|
|
|
|
|
0
|
$! = EADDRNOTAVAIL; |
725
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
726
|
|
|
|
|
|
|
$event_failure, |
727
|
|
|
|
|
|
|
"inet_aton", $!+0, $!, $self->[MY_UNIQUE_ID] |
728
|
|
|
|
|
|
|
); |
729
|
0
|
|
|
|
|
0
|
return $self; |
730
|
|
|
|
|
|
|
} |
731
|
|
|
|
|
|
|
|
732
|
|
|
|
|
|
|
# Set the bind port, or default to 0 (any) if none specified. |
733
|
|
|
|
|
|
|
# Resolve it to a number, if at all possible. |
734
|
24
|
50
|
|
|
|
99
|
my $bind_port = (defined $params{BindPort}) ? $params{BindPort} : 0; |
735
|
24
|
50
|
|
|
|
139
|
if ($bind_port =~ /[^0-9]/) { |
736
|
0
|
|
|
|
|
0
|
$bind_port = getservbyname($bind_port, $protocol_name); |
737
|
0
|
0
|
|
|
|
0
|
unless (defined $bind_port) { |
738
|
0
|
|
|
|
|
0
|
$! = EADDRNOTAVAIL; |
739
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
740
|
|
|
|
|
|
|
$event_failure, |
741
|
|
|
|
|
|
|
'getservbyname', $!+0, $!, $self->[MY_UNIQUE_ID] |
742
|
|
|
|
|
|
|
); |
743
|
0
|
|
|
|
|
0
|
return $self; |
744
|
|
|
|
|
|
|
} |
745
|
|
|
|
|
|
|
} |
746
|
|
|
|
|
|
|
|
747
|
24
|
|
|
|
|
102
|
$bind_address = pack_sockaddr_in($bind_port, $bind_address); |
748
|
24
|
50
|
|
|
|
80
|
unless (defined $bind_address) { |
749
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
750
|
|
|
|
|
|
|
$event_failure, |
751
|
|
|
|
|
|
|
"pack_sockaddr_in", $!+0, $!, $self->[MY_UNIQUE_ID] |
752
|
|
|
|
|
|
|
); |
753
|
0
|
|
|
|
|
0
|
return $self; |
754
|
|
|
|
|
|
|
} |
755
|
|
|
|
|
|
|
} |
756
|
|
|
|
|
|
|
} |
757
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
# Check SocketFactory /Bind.*/ parameters in an Internet socket |
759
|
|
|
|
|
|
|
# context, and translate them into parameters that bind() |
760
|
|
|
|
|
|
|
# understands. |
761
|
|
|
|
|
|
|
elsif ($abstract_domain eq DOM_INET6) { |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
# Don't bind if the creator doesn't specify a related parameter. |
764
|
0
|
0
|
0
|
|
|
0
|
if ((defined $params{BindAddress}) or (defined $params{BindPort})) { |
765
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
# Set the bind address, or default to INADDR_ANY. |
767
|
0
|
0
|
|
|
|
0
|
$bind_address = ( |
768
|
|
|
|
|
|
|
(defined $params{BindAddress}) |
769
|
|
|
|
|
|
|
? $params{BindAddress} |
770
|
|
|
|
|
|
|
: "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" # XXX - Only Socket6 has? |
771
|
|
|
|
|
|
|
); |
772
|
|
|
|
|
|
|
|
773
|
|
|
|
|
|
|
# Set the bind port, or default to 0 (any) if none specified. |
774
|
|
|
|
|
|
|
# Resolve it to a number, if at all possible. |
775
|
0
|
0
|
|
|
|
0
|
my $bind_port = (defined $params{BindPort}) ? $params{BindPort} : 0; |
776
|
0
|
0
|
|
|
|
0
|
if ($bind_port =~ /[^0-9]/) { |
777
|
0
|
|
|
|
|
0
|
$bind_port = getservbyname($bind_port, $protocol_name); |
778
|
0
|
0
|
|
|
|
0
|
unless (defined $bind_port) { |
779
|
0
|
|
|
|
|
0
|
$! = EADDRNOTAVAIL; |
780
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
781
|
|
|
|
|
|
|
$event_failure, |
782
|
|
|
|
|
|
|
'getservbyname', $!+0, $!, $self->[MY_UNIQUE_ID] |
783
|
|
|
|
|
|
|
); |
784
|
0
|
|
|
|
|
0
|
return $self; |
785
|
|
|
|
|
|
|
} |
786
|
|
|
|
|
|
|
} |
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
# Need to check lengths in octets, not characters. |
789
|
23
|
50
|
|
23
|
|
8376
|
BEGIN { eval { require bytes } and bytes->import; } |
|
23
|
|
|
|
|
244
|
|
790
|
|
|
|
|
|
|
|
791
|
|
|
|
|
|
|
# Undef $bind_address if IN6ADDR_ANY and handle with AI_PASSIVE |
792
|
0
|
0
|
0
|
|
|
0
|
if ( $bind_address eq '::' || $bind_address eq "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" ) { |
793
|
0
|
|
|
|
|
0
|
$bind_address = undef; |
794
|
|
|
|
|
|
|
} |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
# Resolve the bind address. |
797
|
0
|
0
|
|
|
|
0
|
my ($error, @addresses) = getaddrinfo( |
798
|
|
|
|
|
|
|
$bind_address, $bind_port, { |
799
|
|
|
|
|
|
|
family => $self->[MY_SOCKET_DOMAIN], |
800
|
|
|
|
|
|
|
socktype => $self->[MY_SOCKET_TYPE], |
801
|
|
|
|
|
|
|
( defined $bind_address ? () : ( flags => 1 ) ), |
802
|
|
|
|
|
|
|
} |
803
|
|
|
|
|
|
|
); |
804
|
|
|
|
|
|
|
|
805
|
0
|
0
|
|
|
|
0
|
unless (@addresses) { |
806
|
0
|
0
|
|
|
|
0
|
warn $error if $error; |
807
|
|
|
|
|
|
|
|
808
|
0
|
|
|
|
|
0
|
$! = EADDRNOTAVAIL; |
809
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
810
|
|
|
|
|
|
|
$event_failure, |
811
|
|
|
|
|
|
|
"getaddrinfo", $!+0, $!, $self->[MY_UNIQUE_ID] |
812
|
|
|
|
|
|
|
); |
813
|
0
|
|
|
|
|
0
|
return $self; |
814
|
|
|
|
|
|
|
} |
815
|
|
|
|
|
|
|
|
816
|
0
|
|
|
|
|
0
|
$bind_address = $addresses[0]->{addr}; |
817
|
|
|
|
|
|
|
} |
818
|
|
|
|
|
|
|
} |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
# Check SocketFactory /Bind.*/ parameters in a Unix context, and |
821
|
|
|
|
|
|
|
# translate them into parameters bind() understands. |
822
|
|
|
|
|
|
|
elsif ($abstract_domain eq DOM_UNIX) { |
823
|
4
|
50
|
|
|
|
15
|
carp 'BindPort ignored for Unix socket' if defined $params{BindPort}; |
824
|
|
|
|
|
|
|
|
825
|
4
|
100
|
|
|
|
13
|
if (defined $params{BindAddress}) { |
826
|
|
|
|
|
|
|
# Is this necessary, or will bind() return EADDRINUSE? |
827
|
2
|
50
|
|
|
|
9
|
if (defined $params{RemotePort}) { |
828
|
0
|
|
|
|
|
0
|
$! = EADDRINUSE; |
829
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
830
|
|
|
|
|
|
|
$event_failure, |
831
|
|
|
|
|
|
|
'bind', $!+0, $!, $self->[MY_UNIQUE_ID] |
832
|
|
|
|
|
|
|
); |
833
|
0
|
|
|
|
|
0
|
return $self; |
834
|
|
|
|
|
|
|
} |
835
|
|
|
|
|
|
|
|
836
|
2
|
|
|
|
|
9
|
$bind_address = &_condition_unix_address($params{BindAddress}); |
837
|
2
|
|
|
|
|
19
|
$bind_address = pack_sockaddr_un($bind_address); |
838
|
2
|
50
|
|
|
|
7
|
unless ($bind_address) { |
839
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
840
|
|
|
|
|
|
|
$event_failure, |
841
|
|
|
|
|
|
|
'pack_sockaddr_un', $!+0, $!, $self->[MY_UNIQUE_ID] |
842
|
|
|
|
|
|
|
); |
843
|
0
|
|
|
|
|
0
|
return $self; |
844
|
|
|
|
|
|
|
} |
845
|
|
|
|
|
|
|
} |
846
|
|
|
|
|
|
|
} |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
# This is an internal consistency error, and it should be hard |
849
|
|
|
|
|
|
|
# trapped right away. |
850
|
|
|
|
|
|
|
else { |
851
|
0
|
|
|
|
|
0
|
die "Mail this error to the author of POE: Internal consistency error"; |
852
|
|
|
|
|
|
|
} |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
# Perform the actual bind, if there's a bind address to bind to. |
855
|
103
|
100
|
|
|
|
231
|
if (defined $bind_address) { |
856
|
26
|
50
|
|
|
|
414
|
unless (bind($socket_handle, $bind_address)) { |
857
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
858
|
|
|
|
|
|
|
$event_failure, |
859
|
|
|
|
|
|
|
'bind', $!+0, $!, $self->[MY_UNIQUE_ID] |
860
|
|
|
|
|
|
|
); |
861
|
0
|
|
|
|
|
0
|
return $self; |
862
|
|
|
|
|
|
|
} |
863
|
|
|
|
|
|
|
|
864
|
26
|
|
|
|
|
39
|
DEBUG && warn "bind"; |
865
|
|
|
|
|
|
|
} |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
#---------# |
868
|
|
|
|
|
|
|
# Connect # |
869
|
|
|
|
|
|
|
#---------# |
870
|
|
|
|
|
|
|
|
871
|
103
|
|
|
|
|
124
|
my $connect_address; |
872
|
|
|
|
|
|
|
|
873
|
103
|
100
|
|
|
|
223
|
if (defined $params{RemoteAddress}) { |
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
# Check SocketFactory /Remote.*/ parameters in an Internet socket |
876
|
|
|
|
|
|
|
# context, and translate them into parameters that connect() |
877
|
|
|
|
|
|
|
# understands. |
878
|
77
|
100
|
66
|
|
|
259
|
if ( |
|
|
50
|
|
|
|
|
|
879
|
|
|
|
|
|
|
$abstract_domain eq DOM_INET or |
880
|
|
|
|
|
|
|
$abstract_domain eq DOM_INET6 |
881
|
|
|
|
|
|
|
) { |
882
|
|
|
|
|
|
|
# connecting if RemoteAddress |
883
|
75
|
50
|
|
|
|
176
|
croak 'RemotePort required' unless (defined $params{RemotePort}); |
884
|
75
|
50
|
|
|
|
161
|
carp 'ListenQueue ignored' if (defined $params{ListenQueue}); |
885
|
|
|
|
|
|
|
|
886
|
75
|
|
|
|
|
105
|
my $remote_port = $params{RemotePort}; |
887
|
75
|
50
|
|
|
|
297
|
if ($remote_port =~ /[^0-9]/) { |
888
|
0
|
0
|
|
|
|
0
|
unless ($remote_port = getservbyname($remote_port, $protocol_name)) { |
889
|
0
|
|
|
|
|
0
|
$! = EADDRNOTAVAIL; |
890
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
891
|
|
|
|
|
|
|
$event_failure, |
892
|
|
|
|
|
|
|
'getservbyname', $!+0, $!, $self->[MY_UNIQUE_ID] |
893
|
|
|
|
|
|
|
); |
894
|
0
|
|
|
|
|
0
|
return $self; |
895
|
|
|
|
|
|
|
} |
896
|
|
|
|
|
|
|
} |
897
|
|
|
|
|
|
|
|
898
|
75
|
|
|
|
|
98
|
my $error_tag; |
899
|
75
|
50
|
|
|
|
140
|
if ($abstract_domain eq DOM_INET) { |
|
|
0
|
|
|
|
|
|
900
|
75
|
|
|
|
|
1957
|
$connect_address = inet_aton($params{RemoteAddress}); |
901
|
75
|
|
|
|
|
129
|
$error_tag = "inet_aton"; |
902
|
|
|
|
|
|
|
} |
903
|
|
|
|
|
|
|
elsif ($abstract_domain eq DOM_INET6) { |
904
|
0
|
|
|
|
|
0
|
my ($error, @addresses) = getaddrinfo( |
905
|
|
|
|
|
|
|
$params{RemoteAddress}, $remote_port, { |
906
|
|
|
|
|
|
|
family => $self->[MY_SOCKET_DOMAIN], |
907
|
|
|
|
|
|
|
socktype => $self->[MY_SOCKET_TYPE], |
908
|
|
|
|
|
|
|
}, |
909
|
|
|
|
|
|
|
); |
910
|
|
|
|
|
|
|
|
911
|
0
|
0
|
|
|
|
0
|
unless (@addresses) { |
912
|
0
|
0
|
|
|
|
0
|
warn $error if $error; |
913
|
0
|
|
|
|
|
0
|
$connect_address = undef; |
914
|
|
|
|
|
|
|
} |
915
|
|
|
|
|
|
|
else { |
916
|
0
|
|
|
|
|
0
|
$connect_address = $addresses[0]->{addr}; |
917
|
|
|
|
|
|
|
} |
918
|
|
|
|
|
|
|
|
919
|
0
|
|
|
|
|
0
|
$error_tag = "getaddrinfo"; |
920
|
|
|
|
|
|
|
} |
921
|
|
|
|
|
|
|
else { |
922
|
0
|
|
|
|
|
0
|
die "unknown domain $abstract_domain"; |
923
|
|
|
|
|
|
|
} |
924
|
|
|
|
|
|
|
|
925
|
|
|
|
|
|
|
# TODO - If the gethostbyname2() code is removed, then we can |
926
|
|
|
|
|
|
|
# combine the previous code with the following code, and perhaps |
927
|
|
|
|
|
|
|
# remove one of these redundant $connect_address checks. The |
928
|
|
|
|
|
|
|
# 0.29 release should tell us pretty quickly whether it's |
929
|
|
|
|
|
|
|
# needed. If we reach 0.30 without incident, it's probably safe |
930
|
|
|
|
|
|
|
# to remove the old gethostbyname2() code and clean this up. |
931
|
75
|
50
|
|
|
|
175
|
unless (defined $connect_address) { |
932
|
0
|
|
|
|
|
0
|
$! = EADDRNOTAVAIL; |
933
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
934
|
|
|
|
|
|
|
$event_failure, |
935
|
|
|
|
|
|
|
$error_tag, $!+0, $!, $self->[MY_UNIQUE_ID] |
936
|
|
|
|
|
|
|
); |
937
|
0
|
|
|
|
|
0
|
return $self; |
938
|
|
|
|
|
|
|
} |
939
|
|
|
|
|
|
|
|
940
|
75
|
50
|
|
|
|
145
|
if ($abstract_domain eq DOM_INET) { |
|
|
0
|
|
|
|
|
|
941
|
75
|
|
|
|
|
218
|
$connect_address = pack_sockaddr_in($remote_port, $connect_address); |
942
|
75
|
|
|
|
|
115
|
$error_tag = "pack_sockaddr_in"; |
943
|
|
|
|
|
|
|
} |
944
|
|
|
|
|
|
|
elsif ($abstract_domain eq DOM_INET6) { |
945
|
0
|
|
|
|
|
0
|
$error_tag = "pack_sockaddr_in6"; |
946
|
|
|
|
|
|
|
} |
947
|
|
|
|
|
|
|
else { |
948
|
0
|
|
|
|
|
0
|
die "unknown domain $abstract_domain"; |
949
|
|
|
|
|
|
|
} |
950
|
|
|
|
|
|
|
|
951
|
75
|
50
|
|
|
|
202
|
unless ($connect_address) { |
952
|
0
|
|
|
|
|
0
|
$! = EADDRNOTAVAIL; |
953
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
954
|
|
|
|
|
|
|
$event_failure, |
955
|
|
|
|
|
|
|
$error_tag, $!+0, $!, $self->[MY_UNIQUE_ID] |
956
|
|
|
|
|
|
|
); |
957
|
0
|
|
|
|
|
0
|
return $self; |
958
|
|
|
|
|
|
|
} |
959
|
|
|
|
|
|
|
} |
960
|
|
|
|
|
|
|
|
961
|
|
|
|
|
|
|
# Check SocketFactory /Remote.*/ parameters in a Unix socket |
962
|
|
|
|
|
|
|
# context, and translate them into parameters connect() |
963
|
|
|
|
|
|
|
# understands. |
964
|
|
|
|
|
|
|
elsif ($abstract_domain eq DOM_UNIX) { |
965
|
|
|
|
|
|
|
|
966
|
2
|
|
|
|
|
8
|
$connect_address = _condition_unix_address($params{RemoteAddress}); |
967
|
2
|
|
|
|
|
11
|
$connect_address = pack_sockaddr_un($connect_address); |
968
|
2
|
50
|
|
|
|
15
|
unless (defined $connect_address) { |
969
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
970
|
|
|
|
|
|
|
$event_failure, |
971
|
|
|
|
|
|
|
'pack_sockaddr_un', $!+0, $!, $self->[MY_UNIQUE_ID] |
972
|
|
|
|
|
|
|
); |
973
|
0
|
|
|
|
|
0
|
return $self; |
974
|
|
|
|
|
|
|
} |
975
|
|
|
|
|
|
|
} |
976
|
|
|
|
|
|
|
|
977
|
|
|
|
|
|
|
# This is an internal consistency error, and it should be trapped |
978
|
|
|
|
|
|
|
# right away. |
979
|
|
|
|
|
|
|
else { |
980
|
0
|
|
|
|
|
0
|
die "Mail this error to the author of POE: Internal consistency error"; |
981
|
|
|
|
|
|
|
} |
982
|
|
|
|
|
|
|
} |
983
|
|
|
|
|
|
|
|
984
|
|
|
|
|
|
|
else { |
985
|
26
|
50
|
|
|
|
74
|
carp "RemotePort ignored without RemoteAddress" |
986
|
|
|
|
|
|
|
if defined $params{RemotePort}; |
987
|
|
|
|
|
|
|
} |
988
|
|
|
|
|
|
|
|
989
|
|
|
|
|
|
|
# Perform the actual connection, if a connection was requested. If |
990
|
|
|
|
|
|
|
# the connection can be established, then return the SocketFactory |
991
|
|
|
|
|
|
|
# handle. |
992
|
103
|
100
|
|
|
|
285
|
if (defined $connect_address) { |
993
|
77
|
100
|
|
|
|
6050
|
unless (connect($socket_handle, $connect_address)) { |
994
|
75
|
50
|
33
|
|
|
1048
|
if ($! and ($! != EINPROGRESS) and ($! != EWOULDBLOCK)) { |
|
|
|
33
|
|
|
|
|
995
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
996
|
|
|
|
|
|
|
$event_failure, |
997
|
|
|
|
|
|
|
'connect', $!+0, $!, $self->[MY_UNIQUE_ID] |
998
|
|
|
|
|
|
|
); |
999
|
0
|
|
|
|
|
0
|
return $self; |
1000
|
|
|
|
|
|
|
} |
1001
|
|
|
|
|
|
|
} |
1002
|
|
|
|
|
|
|
|
1003
|
77
|
|
|
|
|
76
|
DEBUG && warn "connect"; |
1004
|
|
|
|
|
|
|
|
1005
|
77
|
|
|
|
|
166
|
$self->[MY_SOCKET_HANDLE] = $socket_handle; |
1006
|
77
|
|
|
|
|
276
|
$self->_define_connect_state(); |
1007
|
77
|
|
|
|
|
280
|
$self->event( |
1008
|
|
|
|
|
|
|
SuccessEvent => $params{SuccessEvent}, |
1009
|
|
|
|
|
|
|
FailureEvent => $params{FailureEvent}, |
1010
|
|
|
|
|
|
|
); |
1011
|
77
|
|
|
|
|
446
|
return $self; |
1012
|
|
|
|
|
|
|
} |
1013
|
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
#---------------------# |
1015
|
|
|
|
|
|
|
# Listen, or Whatever # |
1016
|
|
|
|
|
|
|
#---------------------# |
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
# A connection wasn't requested, so this must be a server socket. |
1019
|
|
|
|
|
|
|
# Do whatever it is that needs to be done for whatever type of |
1020
|
|
|
|
|
|
|
# server socket this is. |
1021
|
26
|
50
|
|
|
|
88
|
if (exists $supported_protocol{$abstract_domain}->{$protocol_name}) { |
1022
|
26
|
|
|
|
|
58
|
my $protocol_op = $supported_protocol{$abstract_domain}->{$protocol_name}; |
1023
|
|
|
|
|
|
|
|
1024
|
26
|
|
|
|
|
29
|
DEBUG && warn "$abstract_domain + $protocol_name = $protocol_op"; |
1025
|
|
|
|
|
|
|
|
1026
|
26
|
100
|
|
|
|
75
|
if ($protocol_op eq SVROP_LISTENS) { |
1027
|
22
|
|
50
|
|
|
115
|
my $listen_queue = $params{ListenQueue} || SOMAXCONN; |
1028
|
|
|
|
|
|
|
# In SocketFactory, you limit the ListenQueue parameter |
1029
|
|
|
|
|
|
|
# to SOMAXCON (or is it SOCONNMAX?)...why? |
1030
|
|
|
|
|
|
|
# ah, here's czth, he'll have more to say on this issue |
1031
|
|
|
|
|
|
|
# not really. just that SOMAXCONN can lie, notably on |
1032
|
|
|
|
|
|
|
# Solaris and reportedly on BSDs too |
1033
|
|
|
|
|
|
|
# |
1034
|
|
|
|
|
|
|
# ($listen_queue > SOMAXCONN) && ($listen_queue = SOMAXCONN); |
1035
|
22
|
50
|
|
|
|
306
|
unless (listen($socket_handle, $listen_queue)) { |
1036
|
0
|
|
|
|
|
0
|
$poe_kernel->yield( |
1037
|
|
|
|
|
|
|
$event_failure, |
1038
|
|
|
|
|
|
|
'listen', $!+0, $!, $self->[MY_UNIQUE_ID] |
1039
|
|
|
|
|
|
|
); |
1040
|
0
|
|
|
|
|
0
|
return $self; |
1041
|
|
|
|
|
|
|
} |
1042
|
|
|
|
|
|
|
|
1043
|
22
|
|
|
|
|
28
|
DEBUG && warn "listen"; |
1044
|
|
|
|
|
|
|
|
1045
|
22
|
|
|
|
|
60
|
$self->[MY_SOCKET_HANDLE] = $socket_handle; |
1046
|
22
|
|
|
|
|
91
|
$self->_define_accept_state(); |
1047
|
22
|
|
|
|
|
110
|
$self->event( |
1048
|
|
|
|
|
|
|
SuccessEvent => $params{SuccessEvent}, |
1049
|
|
|
|
|
|
|
FailureEvent => $params{FailureEvent}, |
1050
|
|
|
|
|
|
|
); |
1051
|
22
|
|
|
|
|
143
|
return $self; |
1052
|
|
|
|
|
|
|
} |
1053
|
|
|
|
|
|
|
else { |
1054
|
4
|
50
|
|
|
|
9
|
carp "Ignoring ListenQueue parameter for non-listening socket" |
1055
|
|
|
|
|
|
|
if defined $params{ListenQueue}; |
1056
|
4
|
50
|
|
|
|
9
|
if ($protocol_op eq SVROP_NOTHING) { |
1057
|
|
|
|
|
|
|
# Do nothing. Duh. Fire off a success event immediately, and |
1058
|
|
|
|
|
|
|
# return. |
1059
|
4
|
|
|
|
|
17
|
$poe_kernel->yield( |
1060
|
|
|
|
|
|
|
$event_success, |
1061
|
|
|
|
|
|
|
$socket_handle, undef, undef, $self->[MY_UNIQUE_ID] |
1062
|
|
|
|
|
|
|
); |
1063
|
4
|
|
|
|
|
19
|
return $self; |
1064
|
|
|
|
|
|
|
} |
1065
|
|
|
|
|
|
|
else { |
1066
|
0
|
|
|
|
|
0
|
die "Mail this error to the author of POE: Internal consistency error"; |
1067
|
|
|
|
|
|
|
} |
1068
|
|
|
|
|
|
|
} |
1069
|
|
|
|
|
|
|
} |
1070
|
|
|
|
|
|
|
else { |
1071
|
0
|
|
|
|
|
0
|
die "SocketFactory doesn't support $abstract_domain $protocol_name socket"; |
1072
|
|
|
|
|
|
|
} |
1073
|
|
|
|
|
|
|
|
1074
|
0
|
|
|
|
|
0
|
die "Mail this error to the author of POE: Internal consistency error"; |
1075
|
|
|
|
|
|
|
} |
1076
|
|
|
|
|
|
|
|
1077
|
|
|
|
|
|
|
# Pause and resume accept. |
1078
|
|
|
|
|
|
|
sub pause_accept { |
1079
|
24
|
|
|
24
|
1
|
41
|
my $self = shift; |
1080
|
24
|
50
|
33
|
|
|
180
|
if ( |
|
|
|
33
|
|
|
|
|
1081
|
|
|
|
|
|
|
defined $self->[MY_SOCKET_HANDLE] and |
1082
|
|
|
|
|
|
|
defined $self->[MY_STATE_ACCEPT] and |
1083
|
|
|
|
|
|
|
defined $self->[MY_SOCKET_SELECTED] |
1084
|
|
|
|
|
|
|
) { |
1085
|
24
|
|
|
|
|
88
|
$poe_kernel->select_pause_read($self->[MY_SOCKET_HANDLE]); |
1086
|
|
|
|
|
|
|
} |
1087
|
|
|
|
|
|
|
} |
1088
|
|
|
|
|
|
|
|
1089
|
|
|
|
|
|
|
sub resume_accept { |
1090
|
22
|
|
|
22
|
1
|
32
|
my $self = shift; |
1091
|
22
|
50
|
33
|
|
|
184
|
if ( |
|
|
|
33
|
|
|
|
|
1092
|
|
|
|
|
|
|
defined $self->[MY_SOCKET_HANDLE] and |
1093
|
|
|
|
|
|
|
defined $self->[MY_STATE_ACCEPT] and |
1094
|
|
|
|
|
|
|
defined $self->[MY_SOCKET_SELECTED] |
1095
|
|
|
|
|
|
|
) { |
1096
|
22
|
|
|
|
|
84
|
$poe_kernel->select_resume_read($self->[MY_SOCKET_HANDLE]); |
1097
|
|
|
|
|
|
|
} |
1098
|
|
|
|
|
|
|
} |
1099
|
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1101
|
|
|
|
|
|
|
# DESTROY and _shutdown pass things by reference because _shutdown is |
1102
|
|
|
|
|
|
|
# called from the state() closures above. As a result, we can't |
1103
|
|
|
|
|
|
|
# mention $self explicitly, or the wheel won't shut itself down |
1104
|
|
|
|
|
|
|
# properly. Rather, it will form a circular reference on $self. |
1105
|
|
|
|
|
|
|
|
1106
|
|
|
|
|
|
|
sub DESTROY { |
1107
|
103
|
|
|
103
|
|
1567
|
my $self = shift; |
1108
|
103
|
|
|
|
|
531
|
_shutdown( |
1109
|
|
|
|
|
|
|
\$self->[MY_SOCKET_SELECTED], |
1110
|
|
|
|
|
|
|
\$self->[MY_SOCKET_HANDLE], |
1111
|
|
|
|
|
|
|
\$self->[MY_STATE_ACCEPT], |
1112
|
|
|
|
|
|
|
\$self->[MY_STATE_CONNECT], |
1113
|
|
|
|
|
|
|
\$self->[MY_MINE_SUCCESS], |
1114
|
|
|
|
|
|
|
\$self->[MY_EVENT_SUCCESS], |
1115
|
|
|
|
|
|
|
\$self->[MY_MINE_FAILURE], |
1116
|
|
|
|
|
|
|
\$self->[MY_EVENT_FAILURE], |
1117
|
|
|
|
|
|
|
); |
1118
|
103
|
|
|
|
|
392
|
&POE::Wheel::free_wheel_id($self->[MY_UNIQUE_ID]); |
1119
|
|
|
|
|
|
|
} |
1120
|
|
|
|
|
|
|
|
1121
|
|
|
|
|
|
|
sub _shutdown { |
1122
|
|
|
|
|
|
|
my ( |
1123
|
180
|
|
|
180
|
|
307
|
$socket_selected, $socket_handle, |
1124
|
|
|
|
|
|
|
$state_accept, $state_connect, |
1125
|
|
|
|
|
|
|
$mine_success, $event_success, |
1126
|
|
|
|
|
|
|
$mine_failure, $event_failure, |
1127
|
|
|
|
|
|
|
) = @_; |
1128
|
|
|
|
|
|
|
|
1129
|
180
|
100
|
|
|
|
406
|
if (defined $$socket_selected) { |
1130
|
99
|
|
|
|
|
361
|
$poe_kernel->select($$socket_handle); |
1131
|
99
|
|
|
|
|
506
|
$$socket_selected = undef; |
1132
|
|
|
|
|
|
|
} |
1133
|
|
|
|
|
|
|
|
1134
|
180
|
100
|
|
|
|
409
|
if (defined $$state_accept) { |
1135
|
22
|
|
|
|
|
92
|
$poe_kernel->state($$state_accept); |
1136
|
22
|
|
|
|
|
41
|
$$state_accept = undef; |
1137
|
|
|
|
|
|
|
} |
1138
|
|
|
|
|
|
|
|
1139
|
180
|
100
|
|
|
|
359
|
if (defined $$state_connect) { |
1140
|
77
|
|
|
|
|
234
|
$poe_kernel->state($$state_connect); |
1141
|
77
|
|
|
|
|
95
|
$$state_connect = undef; |
1142
|
|
|
|
|
|
|
} |
1143
|
|
|
|
|
|
|
|
1144
|
180
|
50
|
|
|
|
380
|
if (defined $$mine_success) { |
1145
|
0
|
|
|
|
|
0
|
$poe_kernel->state($$event_success); |
1146
|
0
|
|
|
|
|
0
|
$$mine_success = $$event_success = undef; |
1147
|
|
|
|
|
|
|
} |
1148
|
|
|
|
|
|
|
|
1149
|
180
|
50
|
|
|
|
503
|
if (defined $$mine_failure) { |
1150
|
0
|
|
|
|
|
|
$poe_kernel->state($$event_failure); |
1151
|
0
|
|
|
|
|
|
$$mine_failure = $$event_failure = undef; |
1152
|
|
|
|
|
|
|
} |
1153
|
|
|
|
|
|
|
} |
1154
|
|
|
|
|
|
|
|
1155
|
|
|
|
|
|
|
1; |
1156
|
|
|
|
|
|
|
|
1157
|
|
|
|
|
|
|
__END__ |