Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

291 lines (218 sloc) 7.904 kB
# 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.020'; # 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.
Jump to Line
Something went wrong with that request. Please try again.