Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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.291'; # 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.