forked from rcaputo/poe
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Pipe.pm
290 lines (218 loc) · 7.72 KB
/
Pipe.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
# Common routines for POE::Pipe::OneWay and ::TwoWay. This is meant
# to be inherited. This is ugly, messy code right now. It fails
# terribly upon the slightest error, which is generally bad.
package POE::Pipe;
use strict;
use vars qw($VERSION);
$VERSION = '1.284'; # NOTE - Should be #.### (three decimal places)
use Symbol qw(gensym);
use IO::Socket qw(
PF_INET SOCK_STREAM SOL_SOCKET SO_REUSEADDR
pack_sockaddr_in unpack_sockaddr_in inet_aton
SOMAXCONN SO_ERROR
);
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
use Errno qw(EINPROGRESS EWOULDBLOCK);
# CygWin seems to have a problem with socketpair() and exec(). When
# an exec'd process closes, any data on sockets created with
# socketpair() is not flushed. From irc.rhizomatic.net #poe:
#
# <dngnand> Sounds like a lapse in cygwin's exec implementation. It
# works ok under Unix-ish systems?
# <jdeluise2> yes, it works perfectly
# <jdeluise2> but, if we just use POE::Pipe::TwoWay->new("pipe") it
# always works fine on cygwin
# <jdeluise2> by the way, it looks like the reason is that
# POE::Pipe::OneWay works because it tries to make a pipe
# first instead of a socketpair
# <jdeluise2> this socketpair problem seems like a long-standing one
# with cygwin, according to searches on google, but never
# been fixed.
# The order of pipe primitives depends on our platform. Placed in the
# base class and given accessors so we can use it from both OneWay and
# TwoWay.
my @preference;
if ($^O eq "MSWin32" or $^O eq "MacOS") {
@preference = qw(inet socketpair pipe);
}
elsif ($^O eq "cygwin") {
@preference = qw(pipe inet socketpair);
}
else {
@preference = qw(socketpair pipe inet);
}
sub _get_next_preference {
return $preference[0];
}
sub _shift_preference {
shift @preference;
}
# Provide dummy constants so things at least compile. These constants
# aren't used if we're RUNNING_IN_HELL, but Perl needs to see them.
BEGIN {
# older perls than 5.10 needs a kick in the arse to AUTOLOAD the constant...
eval "F_GETFL" if $] < 5.010;
if ( ! defined &Fcntl::F_GETFL ) {
if ( ! defined prototype "F_GETFL" ) {
*F_GETFL = sub { 0 };
*F_SETFL = sub { 0 };
} else {
*F_GETFL = sub () { 0 };
*F_SETFL = sub () { 0 };
}
}
}
# Static member. Call like a regular function. Turn off blocking on
# sockets created by make_socket.
sub _stop_blocking {
my $socket_handle = shift;
# RCC 2002-12-19: Replace the complex blocking checks and methods
# with IO::Handle's blocking(0) method. This is theoretically more
# portable and less maintenance than rolling our own. If things
# work out, we'll replace this function entirely.
# RCC 2003-01-20: Perl 5.005_03 doesn't like blocking(), so we'll
# only call it in perl 5.8.0 and beyond.
# Do it the Win32 way.
if ($^O eq 'MSWin32') {
my $set_it = "1";
# 126 is FIONBIO (some docs say 0x7F << 16)
ioctl(
$socket_handle,
0x80000000 | (4 << 16) | (ord('f') << 8) | 126,
\$set_it
) or die "ioctl fails: $!";
return;
}
# Do it the 5.8+ way.
if ($] >= 5.008) {
$socket_handle->blocking(0);
return;
}
# Do it the old way.
my $flags = fcntl($socket_handle, F_GETFL, 0) or die "getfl fails: $!";
$flags = fcntl($socket_handle, F_SETFL, $flags | O_NONBLOCK)
or die "setfl fails: $!";
return;
}
# Another static member. Turn blocking on when we're done, in case
# someone wants blocking pipes for some reason.
sub _start_blocking {
my $socket_handle = shift;
# RCC 2002-12-19: Replace the complex blocking checks and methods
# with IO::Handle's blocking(1) method. This is theoretically more
# portable and less maintenance than rolling our own. If things
# work out, we'll replace this function entirely.
# RCC 2003-01-20: Perl 5.005_03 doesn't like blocking(), so we'll
# only call it in perl 5.8.0 and beyond.
# Do it the Win32 way.
if ($^O eq 'MSWin32') {
my $unset_it = "0";
# 126 is FIONBIO (some docs say 0x7F << 16)
ioctl(
$socket_handle,
0x80000000 | (4 << 16) | (ord('f') << 8) | 126,
\$unset_it
) or die "ioctl fails: $!";
return;
}
# Do it the 5.8+ way.
if ($] >= 5.008) {
$socket_handle->blocking(1);
return;
}
# Do it the old way.
my $flags = fcntl($socket_handle, F_GETFL, 0) or die "getfl fails: $!";
$flags = fcntl($socket_handle, F_SETFL, $flags & ~O_NONBLOCK)
or die "setfl fails: $!";
return;
}
# Make a socket. This is a homebrew socketpair() for systems that
# don't support it. The things I must do to make Windows happy.
sub _make_socket {
### Server side.
my $acceptor = gensym();
my $accepted = gensym();
my $tcp = getprotobyname('tcp') or die "getprotobyname: $!";
socket( $acceptor, PF_INET, SOCK_STREAM, $tcp ) or die "socket: $!";
setsockopt( $acceptor, SOL_SOCKET, SO_REUSEADDR, 1) or die "reuse: $!";
my $server_addr = inet_aton('127.0.0.1') or die "inet_aton: $!";
$server_addr = pack_sockaddr_in(0, $server_addr)
or die "sockaddr_in: $!";
bind( $acceptor, $server_addr ) or die "bind: $!";
_stop_blocking($acceptor);
$server_addr = getsockname($acceptor);
listen( $acceptor, SOMAXCONN ) or die "listen: $!";
### Client side.
my $connector = gensym();
socket( $connector, PF_INET, SOCK_STREAM, $tcp ) or die "socket: $!";
_stop_blocking($connector) unless $^O eq 'MSWin32';
unless (connect( $connector, $server_addr )) {
die "connect: $!" if $! and ($! != EINPROGRESS) and ($! != EWOULDBLOCK);
}
my $connector_address = getsockname($connector);
my ($connector_port, $connector_addr) =
unpack_sockaddr_in($connector_address);
### Loop around 'til it's all done. I thought I was done writing
### select loops. Damnit.
my $in_read = '';
my $in_write = '';
vec( $in_read, fileno($acceptor), 1 ) = 1;
vec( $in_write, fileno($connector), 1 ) = 1;
my $done = 0;
while ($done != 0x11) {
my $hits = select( my $out_read = $in_read,
my $out_write = $in_write,
undef,
5
);
unless ($hits) {
next if ($! and ($! == EINPROGRESS) or ($! == EWOULDBLOCK));
die "select: $!" unless $hits;
}
# Accept happened.
if (vec($out_read, fileno($acceptor), 1)) {
my $peer = accept($accepted, $acceptor);
my ($peer_port, $peer_addr) = unpack_sockaddr_in($peer);
if ( $peer_port == $connector_port and
$peer_addr eq $connector_addr
) {
vec($in_read, fileno($acceptor), 1) = 0;
$done |= 0x10;
}
}
# Connect happened.
if (vec($out_write, fileno($connector), 1)) {
$! = unpack('i', getsockopt($connector, SOL_SOCKET, SO_ERROR));
die "connect: $!" if $!;
vec($in_write, fileno($connector), 1) = 0;
$done |= 0x01;
}
}
# Turn blocking back on, damnit.
_start_blocking($accepted);
_start_blocking($connector);
return ($accepted, $connector);
}
1;
__END__
=head1 NAME
POE::Pipe - common methods for POE::Pipe::OneWay and POE::Pipe::TwoWay
=head1 SYNOPSIS
None.
=head1 DESCRIPTION
POE::Pipe implements lower-level internal methods that are common
among its subclasses: POE::Pipe::OneWay and POE::Pipe::TwoWay.
The POE::Pipe classes may be used outside of POE, as they don't use
POE internally.
=head1 BUGS
The functions implemented here die outright upon failure, requiring
eval{} around their calls.
=head1 SEE ALSO
L<POE::Pipe::OneWay>, L<POE::Pipe::TwoWay>, L<POE>
=head1 AUTHOR & COPYRIGHT
POE::Pipe is copyright 2001-2008 by Rocco Caputo. All rights
reserved. POE::Pipe is free software; you may redistribute it and/or
modify it under the same terms as Perl itself.
=cut
# rocco // vim: ts=2 sw=2 expandtab
# TODO - Edit.