package Win32::SelectablePipe; use strict; use Socket; use POSIX (); use vars qw( @EXPORT @EXPORT_OK ); BEGIN { require Exporter; @EXPORT= qw( pipe ); @EXPORT_OK= qw( FIONBIO EAGAIN ); *import= \&Exporter::import; } sub SO_OPENTYPE { 0x7008 } sub POSIX::FIONBIO { ( 0x80000000 | (4<<16) | (unpack('c','f')<<8) | 126 ) } # 0x8004667E sub POSIX::EAGAIN { 10035 } sub POSIX::EISCONN { 10056 } sub pipe { my( $one, $two )= @_; my( $server )= do { local(*SERVER); *SERVER }; if( 2 != @_ ) { require Carp; Carp::croak( "Win32::SelectablePipe usage: pipe(*ONE,*TWO)" ); } { my $pkg= caller; for my $handle ( $one, $two ) { if( ! ref($handle) && "GLOB" ne ref(\$handle) && $handle !~ /'|::/ ) { $handle= "$pkg::$handle" } } } my $tcp= getprotobyname('tcp'); socket( $server, PF_INET, SOCK_STREAM, $tcp ) or die "Can't create TCP socket ($server): $!"; socket( $two, PF_INET, SOCK_STREAM, $tcp ) or die "Can't create TCP socket ($two): $!"; my $local= gethostbyname('localhost') or die "Can't find localhost: $!"; my $addr= sockaddr_in( 0, $local ) or die "Can't build localhost address: $!"; bind( $server, $addr ) or die "Can't bind socket ($server) to localhost address: ",0+$!; bind( $two, $addr ) or die "Can't bind socket ($two) to localhost address: ",0+$!; listen( $server, 1 ) or die "Can't listen on socket ($server): ",0+$!; $addr= getsockname( $server ) or die "Can't get socket ($server) address: ",0+$!; { my $true= 1; ioctl( $two, POSIX::FIONBIO(), \$true ) or die "Can't ioctl socket ($two) to non-blocking: ", 0+$!; } if( connect( $two, $addr ) ) { warn "Strange, connect() succeeded?"; } elsif( $! != POSIX::EAGAIN ) { die "Can't non-blockingly connect: ", 0+$!; } accept( $one, $server ) or die "Can't accept: ", 0+$!; sleep( 1 ); die "Can't connect: ", 0+$!; if ! connect( $two, $addr ) && $! != POSIX::EISCONN; close( $server ); return 1; } # Total *HACK* to allow winsock connect() to work on non-blocking sockets # Culprit is in perl source /win32/win32sck.c function set_socktype. We # undo the result of this function. See MSDN support on overlapped I/O # for info: http://support.microsoft.com/support/kb/articles/Q181/6/11.ASP #BEGIN { # my $sock = gensym(); # socket( $sock, PF_INET, SOCK_STREAM, getprotobyname('tcp') ) # or die "ERROR - can't create socket\n"; # setsockopt( $sock, SOL_SOCKET, SO_OPENTYPE, 0 ) # or die "PORTABLE::BEGIN ERROR - Can't setsockopt to overlapped: $!\n"; # close $sock; #} 1;