add helper functions for POE::Pipe::OneWay and ::TwoWay

lib/POE/Pipe.pm

@@ -0,0 +1,194 @@
+# $Id$
+
+# 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 Symbol qw(gensym);
+use IO::Socket;
+use POSIX qw(fcntl_h errno_h);
+
+# Provide a dummy EINPROGRESS for systems that don't have one.  Give
+# it a documented value.  This code is stolen from
+# POE::Wheel::SocketFactory.
+
+BEGIN {
+  # http://support.microsoft.com/support/kb/articles/Q150/5/37.asp
+  # defines EINPROGRESS as 10035.  We provide it here because some
+  # Win32 users report POSIX::EINPROGRESS is not vendor-supported.
+  if ($^O eq 'MSWin32') {
+    eval '*EINPROGRESS = sub { 10036 };';
+    eval '*EWOULDBLOCK = sub { 10035 };';
+    eval '*F_GETFL     = sub {     0 };';
+    eval '*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;
+
+  # Do it the Win32 way.  XXX This is incomplete.
+  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: $!";
+  }
+
+  # Do it the way everyone else does.
+  else {
+    my $flags = fcntl($socket_handle, F_GETFL, 0) or die "getfl: $!";
+    $flags = fcntl($socket_handle, F_SETFL, $flags | O_NONBLOCK)
+      or die "setfl: $!";
+  }
+}
+
+# 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;
+
+  # Do it the Win32 way.  XXX This is incomplete.
+  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: $!";
+  }
+
+  # Do it the way everyone else does.
+  else {
+    my $flags = fcntl($socket_handle, F_GETFL, 0) or die "getfl: $!";
+    $flags = fcntl($socket_handle, F_SETFL, $flags & ~O_NONBLOCK)
+      or die "setfl: $!";
+  }
+}
+
+# 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 (connect( $connector, $server_addr )) {
+    die "connect: $!" if $! and ($! != EINPROGRESS) and ($! != EWOULDBLOCK);
+  }
+
+  ### 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
+                     );
+    die "select: $!" unless $hits;
+
+    # Accept happened.
+    if (vec($out_read, fileno($acceptor), 1)) {
+      my $peer = accept($accepted, $acceptor);
+      if ($peer eq getsockname($connector)) {
+        $done |= 0x10;
+      }
+    }
+
+    # Connect happened.
+    if (vec($out_write, fileno($connector), 1)) {
+      $! = unpack('i', getsockopt($connector, SOL_SOCKET, SO_ERROR));
+      die "connect: $!" if $!;
+
+      my $peer = getpeername($connector) or die "getpeername: $!";
+      die "peer not server" unless $peer eq getsockname($acceptor);
+      $done |= 0x01;
+    }
+  }
+
+  # Turn blocking back on, damnit.
+  _start_blocking($accepted);
+  _start_blocking($connector);
+
+  return ($accepted, $connector);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+POE::Pipe - common functions for POE::Pipe::OneWay and ::TwoWay
+
+=head1 SYNOPSIS
+
+  None.
+
+=head1 DESCRIPTION
+
+POE::Pipe contains some helper functions to create a socketpair out of
+discrete Internet sockets.  It's used by POE::Pipe::OneWay and
+POE::Pipe::TwoWay as a last resort if pipe() and socketpair() fail.
+
+=head1 BUGS
+
+The functions implemented here die outright upon failure, requiring
+eval{} around their calls.
+
+=head1 AUTHOR & COPYRIGHT
+
+POE::Pipe is copyright 2001 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