File Coverage

blib/lib/Win32/Socketpair.pm

Criterion	Covered	Total	%
statement	16	16	100.0
branch	1	2	50.0
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	23	24	95.8

package Win32::Socketpair;
use strict;
use warnings;
use Carp qw(croak carp);
use Socket;
use Errno 'EINPROGRESS';

our $VERSION = '0.02';

BEGIN {
    $^O =~ /mswin/i
    or croak __PACKAGE__ . " can be only used on MSWin32 systems";
}

require Exporter;
our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(winsocketpair winopen2 winopen2_5 ) ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

sub winsocketpair {
    my $proto = getprotobyname('tcp');
    my $true = 1;
    my $false = 0;

    for (1..5) {
        carp "winsocketpair failed: $!, retrying" unless $_ == 1;

        socket( my $listener, AF_INET, SOCK_STREAM, $proto ) or return ();
        socket( my $server,   AF_INET, SOCK_STREAM, $proto ) or return ();
        socket( my $client,   AF_INET, SOCK_STREAM, $proto ) or return ();

        ioctl( $client, 0x8004667e, \$true );

        my $addr = sockaddr_in( 0, INADDR_LOOPBACK );
        bind( $listener, $addr ) or return ();
        listen( $listener, 1 ) or return ();
        $addr = getsockname( $listener );

        connect( $client, $addr )
            or $! ==  10035 or $! == EINPROGRESS
            or next;
        my $peer = accept( $server, $listener ) or next;

        ioctl( $client, 0x8004667e, \$false );

        if( $peer eq getsockname( $client ) ) {
            return( $server, $client );
        }
    }
    return ();
}

sub winopen2 {
    my ($pid, $oldin, $oldout);

    my ($server, $client) = winsocketpair
    or return undef;

    open $oldin, '<&', \*STDIN or return ();
    open $oldout, '>&', \*STDOUT or return ();

    if( open( STDIN, '<&', $server )
    and open( STDOUT, '>&', $server )
    ) {
        $pid = eval { system 1, @_ or die "system command failed: $!"};
        # print STDERR "error: $@\n" if $@;
    }
    close STDOUT;
    open STDOUT, '>&', $oldout
        or carp "unable to reestablish STDOUT";

    close STDIN;
    open STDIN, '<&', $oldin
        or carp "unable to reestablish STDIN";

    #printf STDERR "pid %d, fileno %d, stdout %d, stdin %d\n",
    #    $pid, fileno($client), fileno STDOUT, fileno STDIN;

    return ($pid and $pid > 0) ? ($pid, $client) : ();
}

sub winopen2_5 {
    my( $pid, $oldin, $oldout, $olderr );

    my( $server, $client ) = winsocketpair
    or return undef;

    open $oldin,  '<&', \*STDIN  or return ();
    open $oldout, '>&', \*STDOUT or return ();
    open $olderr, '>&', \*STDERR or return ();

    if( open( STDIN,  '<&', $server )
    and open (STDOUT, '>&', $server)
    and open (STDERR, '>&', $server)
    ) {
        $pid = eval{ system 1, @_ or die "system command failed: $!" };
        # print STDERR "error: $@\n" if $@;
    }
    close STDERR;
    open STDERR, '>&', $olderr
        or carp "unable to reestablish STDERR";

    close STDOUT;
    open STDOUT, '>&', $oldout
        or carp "unable to reestablish STDOUT";

    close STDIN;
    open STDIN, '<&', $oldin
        or carp "unable to reestablish STDIN";

    #printf STDERR "pid %d, fileno %d, stdout %d, stdin %d\n",
    #    $pid, fileno($client), fileno STDOUT, fileno STDIN;

    return ( $pid and $pid > 0 ) ? ( $pid, $client ) : ();
}


1;

__END__