File Coverage

blib/lib/IPC/Run/Win32IO.pm

Criterion	Covered	Total	%
statement	51	186	27.4
branch	0	112	0.0
condition	0	12	0.0
subroutine	19	31	61.2
pod	1	1	100.0
total	71	342	20.7

package IPC::Run::Win32IO;

=pod

=head1 NAME

IPC::Run::Win32IO - helper routines for IPC::Run on Win32 platforms.

=head1 SYNOPSIS

    use IPC::Run::Win32IO;   # Exports all by default

=head1 DESCRIPTION

IPC::Run needs to use sockets to redirect subprocess I/O so that the select()
loop will work on Win32. This seems to only work on WinNT and Win2K at this
time, not sure if it will ever work on Win95 or Win98. If you have experience
in this area, please contact me at [e-mail], thanks!.

=head1 DESCRIPTION

A specialized IO class used on Win32.

=cut

use strict;
use warnings;
use Carp;
use IO::Handle;
use Socket;
require POSIX;

use vars qw{$VERSION};

BEGIN {
    $VERSION = '20220807.0';
}

use Socket qw( IPPROTO_TCP TCP_NODELAY );
use Symbol;
use Text::ParseWords;
use Win32::Process;
use IPC::Run::Debug qw( :default _debugging_level );
use IPC::Run::Win32Helper qw( _inherit _dont_inherit );
use Fcntl qw( O_TEXT O_RDONLY );

use base qw( IPC::Run::IO );
my @cleanup_fields;

BEGIN {
    ## These fields will be set to undef in _cleanup to close
    ## the handles.
    @cleanup_fields = (
        'SEND_THROUGH_TEMP_FILE',    ## Set by WinHelper::optimize()
        'RECV_THROUGH_TEMP_FILE',    ## Set by WinHelper::optimize()
        'TEMP_FILE_NAME',            ## The name of the temp file, needed for
        ## error reporting / debugging only.

        'PARENT_HANDLE',             ## The handle of the socket for the parent
        'PUMP_SOCKET_HANDLE',        ## The socket handle for the pump
        'PUMP_PIPE_HANDLE',          ## The anon pipe handle for the pump
        'CHILD_HANDLE',              ## The anon pipe handle for the child

        'TEMP_FILE_HANDLE',          ## The Win32 filehandle for the temp file
    );
}

## REMOVE OSFHandleOpen
use Win32API::File qw(
  GetOsFHandle
  OsFHandleOpenFd
  OsFHandleOpen
  FdGetOsFHandle
  SetHandleInformation
  SetFilePointer
  HANDLE_FLAG_INHERIT
  INVALID_HANDLE_VALUE

  createFile
  WriteFile
  ReadFile
  CloseHandle

  FILE_ATTRIBUTE_TEMPORARY
  FILE_FLAG_DELETE_ON_CLOSE
  FILE_FLAG_WRITE_THROUGH

  FILE_BEGIN
);

#   FILE_ATTRIBUTE_HIDDEN
#   FILE_ATTRIBUTE_SYSTEM

BEGIN {
    ## Force AUTOLOADED constants to be, well, constant by getting them
    ## to AUTOLOAD before compilation continues.  Sigh.
    () = (
        SOL_SOCKET,
        SO_REUSEADDR,
        IPPROTO_TCP,
        TCP_NODELAY,
        HANDLE_FLAG_INHERIT,
        INVALID_HANDLE_VALUE,
    );
}

use constant temp_file_flags => ( FILE_ATTRIBUTE_TEMPORARY() | FILE_FLAG_DELETE_ON_CLOSE() | FILE_FLAG_WRITE_THROUGH() );

#   FILE_ATTRIBUTE_HIDDEN()    |
#   FILE_ATTRIBUTE_SYSTEM()    |
my $tmp_file_counter;
my $tmp_dir;

sub _cleanup {
    my IPC::Run::Win32IO $self = shift;
    my ($harness) = @_;

    $self->_recv_through_temp_file($harness)
      if $self->{RECV_THROUGH_TEMP_FILE};

    CloseHandle( $self->{TEMP_FILE_HANDLE} )
      if defined $self->{TEMP_FILE_HANDLE};

    close( $self->{CHILD_HANDLE} )
      if defined $self->{CHILD_HANDLE};

    $self->{$_} = undef for @cleanup_fields;
}

sub _create_temp_file {
    my IPC::Run::Win32IO $self = shift;

    ## Create a hidden temp file that Win32 will delete when we close
    ## it.
    unless ( defined $tmp_dir ) {
        $tmp_dir = File::Spec->catdir( File::Spec->tmpdir, "IPC-Run.tmp" );

        ## Trust in the user's umask.
        ## This could possibly be a security hole, perhaps
        ## we should offer an option.  Hmmmm, really, people coding
        ## security conscious apps should audit this code and
        ## tell me how to make it better.  Nice cop-out :).
        unless ( -d $tmp_dir ) {
            mkdir $tmp_dir or croak "$!: $tmp_dir";
        }
    }

    $self->{TEMP_FILE_NAME} = File::Spec->catfile(
        ## File name is designed for easy sorting and not conflicting
        ## with other processes.  This should allow us to use "t"runcate
        ## access in CreateFile in case something left some droppings
        ## around (which should never happen because we specify
        ## FLAG_DELETE_ON_CLOSE.
        ## heh, belt and suspenders are better than bug reports; God forbid
        ## that NT should ever crash before a temp file gets deleted!
        $tmp_dir, sprintf "Win32io-%06d-%08d", $$, $tmp_file_counter++
    );

    $self->{TEMP_FILE_HANDLE} = createFile(
        $self->{TEMP_FILE_NAME},
        "trw",    ## new, truncate, read, write
        {
            Flags => temp_file_flags,
        },
    ) or croak "Can't create temporary file, $self->{TEMP_FILE_NAME}: $^E";

    $self->{TFD} = OsFHandleOpenFd $self->{TEMP_FILE_HANDLE}, 0;
    $self->{FD} = undef;

    _debug
      "Win32 Optimizer: temp file (",
      $self->{KFD},
      $self->{TYPE},
      $self->{TFD},
      ", fh ",
      $self->{TEMP_FILE_HANDLE},
      "): ",
      $self->{TEMP_FILE_NAME}
      if _debugging_details;
}

sub _reset_temp_file_pointer {
    my $self = shift;
    SetFilePointer( $self->{TEMP_FILE_HANDLE}, 0, 0, FILE_BEGIN )
      or confess "$^E seeking on (fd $self->{TFD}) $self->{TEMP_FILE_NAME} for kid's fd $self->{KFD}";
}

sub _send_through_temp_file {
    my IPC::Run::Win32IO $self = shift;

    _debug "Win32 optimizer: optimizing " . " $self->{KFD} $self->{TYPE} temp file instead of ",
      ref $self->{SOURCE} || $self->{SOURCE}
      if _debugging_details;

    $self->_create_temp_file;

    if ( defined ${ $self->{SOURCE} } ) {
        my $bytes_written = 0;
        my $data_ref;
        if ( $self->binmode ) {
            $data_ref = $self->{SOURCE};
        }
        else {
            my $data = ${ $self->{SOURCE} };    # Ugh, a copy.
            $data =~ s/(?
            $data_ref = \$data;
        }

        WriteFile(
            $self->{TEMP_FILE_HANDLE},
            $$data_ref,
            0,                                  ## Write entire buffer
            $bytes_written,
            [],                                 ## Not overlapped.
        ) or croak "$^E writing $self->{TEMP_FILE_NAME} for kid to read on fd $self->{KFD}";
        _debug "Win32 optimizer: wrote $bytes_written to temp file $self->{TEMP_FILE_NAME}"
          if _debugging_data;

        $self->_reset_temp_file_pointer;

    }

    _debug "Win32 optimizer: kid to read $self->{KFD} from temp file on $self->{TFD}"
      if _debugging_details;
}

sub _init_recv_through_temp_file {
    my IPC::Run::Win32IO $self = shift;

    $self->_create_temp_file;
}

## TODO: Use the Win32 API in the select loop to see if the file has grown
## and read it incrementally if it has.
sub _recv_through_temp_file {
    my IPC::Run::Win32IO $self = shift;

    ## This next line kicks in if the run() never got to initting things
    ## and needs to clean up.
    return undef unless defined $self->{TEMP_FILE_HANDLE};

    push @{ $self->{FILTERS} }, sub {
        my ( undef, $out_ref ) = @_;

        return undef unless defined $self->{TEMP_FILE_HANDLE};

        my $r;
        my $s;
        ReadFile(
            $self->{TEMP_FILE_HANDLE},
            $s,
            999_999,    ## Hmmm, should read the size.
            $r,
            []
        ) or croak "$^E reading from $self->{TEMP_FILE_NAME}";

        _debug "ReadFile( $self->{TFD} ) = $r chars '$s'" if _debugging_data;

        return undef unless $r;

        $s =~ s/\r\n/\n/g unless $self->binmode;

        my $pos = pos $$out_ref;
        $$out_ref .= $s;
        pos($out_ref) = $pos;
        return 1;
    };

    my ($harness) = @_;

    $self->_reset_temp_file_pointer;

    1 while $self->_do_filters($harness);

    pop @{ $self->{FILTERS} };

    IPC::Run::_close( $self->{TFD} );
}

=head1 SUBROUTINES

=over

=item poll

Windows version of IPC::Run::IP::poll.

=back

=cut

sub poll {
    my IPC::Run::Win32IO $self = shift;

    return if $self->{SEND_THROUGH_TEMP_FILE} || $self->{RECV_THROUGH_TEMP_FILE};

    return $self->SUPER::poll(@_);
}

## When threaded Perls get good enough, we should use threads here.
## The problem with threaded perls is that they dup() all sorts of
## filehandles and fds and don't allow sufficient control over
## closing off the ones we don't want.

sub _spawn_pumper {
    my ( $stdin, $stdout, $debug_fd, $binmode, $child_label, @opts ) = @_;
    my ( $stdin_fd, $stdout_fd ) = ( fileno $stdin, fileno $stdout );

    _debug "pumper stdin = ",  $stdin_fd  if _debugging_details;
    _debug "pumper stdout = ", $stdout_fd if _debugging_details;
    _inherit $stdin_fd, $stdout_fd, $debug_fd;
    my @I_options = map qq{"-I$_"}, @INC;

    my $cmd_line = join(
        " ",
        qq{"$^X"},
        @I_options,
        qw(-MIPC::Run::Win32Pump -e 1 ),
## I'm using this clunky way of passing filehandles to the child process
## in order to avoid some kind of premature closure of filehandles
## problem I was having with VCP's test suite when passing them
## via CreateProcess.  All of the ## REMOVE code is stuff I'd like
## to be rid of and the ## ADD code is what I'd like to use.
        FdGetOsFHandle($stdin_fd),     ## REMOVE
        FdGetOsFHandle($stdout_fd),    ## REMOVE
        FdGetOsFHandle($debug_fd),     ## REMOVE
        $binmode ? 1 : 0,
        $$, $^T, _debugging_level, qq{"$child_label"},
        @opts
    );

    #   open SAVEIN,  "<&STDIN"  or croak "$! saving STDIN";       #### ADD
    #   open SAVEOUT, ">&STDOUT" or croak "$! saving STDOUT";       #### ADD
    #   open SAVEERR, ">&STDERR" or croak "$! saving STDERR";       #### ADD
    #   _dont_inherit \*SAVEIN;       #### ADD
    #   _dont_inherit \*SAVEOUT;       #### ADD
    #   _dont_inherit \*SAVEERR;       #### ADD
    #   open STDIN,  "<&$stdin_fd"  or croak "$! dup2()ing $stdin_fd (pumper's STDIN)";       #### ADD
    #   open STDOUT, ">&$stdout_fd" or croak "$! dup2()ing $stdout_fd (pumper's STDOUT)";       #### ADD
    #   open STDERR, ">&$debug_fd" or croak "$! dup2()ing $debug_fd (pumper's STDERR/debug_fd)";       #### ADD

    _debug "pump cmd line: ", $cmd_line if _debugging_details;

    my $process;
    Win32::Process::Create(
        $process,
        $^X,
        $cmd_line,
        1,    ## Inherit handles
        NORMAL_PRIORITY_CLASS,
        ".",
    ) or croak "$!: Win32::Process::Create()";

    #   open STDIN,  "<&SAVEIN"  or croak "$! restoring STDIN";       #### ADD
    #   open STDOUT, ">&SAVEOUT" or croak "$! restoring STDOUT";       #### ADD
    #   open STDERR, ">&SAVEERR" or croak "$! restoring STDERR";       #### ADD
    #   close SAVEIN             or croak "$! closing SAVEIN";       #### ADD
    #   close SAVEOUT            or croak "$! closing SAVEOUT";       #### ADD
    #   close SAVEERR            or croak "$! closing SAVEERR";       #### ADD

    # In case of a sleep right here, need the IPC::Run::_close() treatment.
    IPC::Run::_close fileno($stdin);
    close $stdin;
    IPC::Run::_close fileno($stdout);
    close $stdout;

    # Don't close $debug_fd, we need it, as do other pumpers.

    # Pause a moment to allow the child to get up and running and emit
    # debug messages.  This does not always work.
    #   select undef, undef, undef, 1 if _debugging_details;

    _debug "_spawn_pumper pid = ", $process->GetProcessID
      if _debugging_data;
}

my $loopback  = inet_aton "127.0.0.1";
my $tcp_proto = getprotobyname('tcp');
croak "$!: getprotobyname('tcp')" unless defined $tcp_proto;

sub _socket {
    my ($server) = @_;
    $server ||= gensym;
    my $client = gensym;

    my $listener = gensym;
    socket $listener, PF_INET, SOCK_STREAM, $tcp_proto
      or croak "$!: socket()";
    setsockopt $listener, SOL_SOCKET, SO_REUSEADDR, pack( "l", 0 )
      or croak "$!: setsockopt()";

    unless ( bind $listener, sockaddr_in( 0, $loopback ) ) {
        croak "Error binding: $!";
    }

    my ($port) = sockaddr_in( getsockname($listener) );

    _debug "win32 port = $port" if _debugging_details;

    listen $listener, my $queue_size = 1
      or croak "$!: listen()";

    {
        socket $client, PF_INET, SOCK_STREAM, $tcp_proto
          or croak "$!: socket()";

        my $paddr = sockaddr_in( $port, $loopback );

        connect $client, $paddr
          or croak "$!: connect()";

        croak "$!: accept" unless defined $paddr;

        ## The windows "default" is SO_DONTLINGER, which should make
        ## sure all socket data goes through.  I have my doubts based
        ## on experimentation, but nothing prompts me to set SO_LINGER
        ## at this time...
        setsockopt $client, IPPROTO_TCP, TCP_NODELAY, pack( "l", 0 )
          or croak "$!: setsockopt()";
    }

    {
        _debug "accept()ing on port $port" if _debugging_details;
        my $paddr = accept( $server, $listener );
        croak "$!: accept()" unless defined $paddr;
    }

    _debug "win32 _socket = ( ", fileno $server, ", ", fileno $client, " ) on port $port"
      if _debugging_details;
    return ( $server, $client );
}

sub _open_socket_pipe {
    my IPC::Run::Win32IO $self = shift;
    my ( $debug_fd, $parent_handle ) = @_;

    my $is_send_to_child = $self->dir eq "<";

    $self->{CHILD_HANDLE}     = gensym;
    $self->{PUMP_PIPE_HANDLE} = gensym;

    (
        $self->{PARENT_HANDLE},
        $self->{PUMP_SOCKET_HANDLE}
    ) = _socket $parent_handle;

    ## These binmodes seem to have no effect on Win2K, but just to be safe
    ## I do them.
    binmode $self->{PARENT_HANDLE}      or die $!;
    binmode $self->{PUMP_SOCKET_HANDLE} or die $!;

    _debug "PUMP_SOCKET_HANDLE = ", fileno $self->{PUMP_SOCKET_HANDLE}
      if _debugging_details;
##my $buf;
##$buf = "write on child end of " . fileno( $self->{WRITE_HANDLE} ) . "\n\n\n\n\n";
##POSIX::write(fileno $self->{WRITE_HANDLE}, $buf, length $buf) or warn "$! in syswrite";
##$buf = "write on parent end of " . fileno( $self->{CHILD_HANDLE} ) . "\r\n";
##POSIX::write(fileno $self->{CHILD_HANDLE},$buf, length $buf) or warn "$! in syswrite";
##   $self->{CHILD_HANDLE}->autoflush( 1 );
##   $self->{WRITE_HANDLE}->autoflush( 1 );

    ## Now fork off a data pump and arrange to return the correct fds.
    if ($is_send_to_child) {
        pipe $self->{CHILD_HANDLE}, $self->{PUMP_PIPE_HANDLE}
          or croak "$! opening child pipe";
        _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
          if _debugging_details;
        _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
          if _debugging_details;
    }
    else {
        pipe $self->{PUMP_PIPE_HANDLE}, $self->{CHILD_HANDLE}
          or croak "$! opening child pipe";
        _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
          if _debugging_details;
        _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
          if _debugging_details;
    }

    ## These binmodes seem to have no effect on Win2K, but just to be safe
    ## I do them.
    binmode $self->{CHILD_HANDLE};
    binmode $self->{PUMP_PIPE_HANDLE};

    ## No child should ever see this.
    _dont_inherit $self->{PARENT_HANDLE};

    ## We clear the inherit flag so these file descriptors are not inherited.
    ## It'll be dup()ed on to STDIN/STDOUT/STDERR before CreateProcess is
    ## called and *that* fd will be inheritable.
    _dont_inherit $self->{PUMP_SOCKET_HANDLE};
    _dont_inherit $self->{PUMP_PIPE_HANDLE};
    _dont_inherit $self->{CHILD_HANDLE};

    ## Need to return $self so the HANDLEs don't get freed.
    ## Return $self, $parent_fd, $child_fd
    my ( $parent_fd, $child_fd ) = (
        fileno $self->{PARENT_HANDLE},
        fileno $self->{CHILD_HANDLE}
    );

    ## Both PUMP_..._HANDLEs will be closed, no need to worry about
    ## inheritance.
    _debug "binmode on" if _debugging_data && $self->binmode;
    _spawn_pumper(
        $is_send_to_child
        ? ( $self->{PUMP_SOCKET_HANDLE}, $self->{PUMP_PIPE_HANDLE} )
        : ( $self->{PUMP_PIPE_HANDLE}, $self->{PUMP_SOCKET_HANDLE} ),
        $debug_fd,
        $self->binmode,
        $child_fd . $self->dir . "pump" . $self->dir . $parent_fd,
    );

    {
        my $foo;
        confess "PARENT_HANDLE no longer open"
          unless POSIX::read( $parent_fd, $foo, 0 );
    }

    _debug "win32_fake_pipe = ( $parent_fd, $child_fd )"
      if _debugging_details;

    $self->{FD}  = $parent_fd;
    $self->{TFD} = $child_fd;
}

sub _do_open {
    my IPC::Run::Win32IO $self = shift;

    if ( $self->{SEND_THROUGH_TEMP_FILE} ) {
        return $self->_send_through_temp_file(@_);
    }
    elsif ( $self->{RECV_THROUGH_TEMP_FILE} ) {
        return $self->_init_recv_through_temp_file(@_);
    }
    else {
        return $self->_open_socket_pipe(@_);
    }
}

1;

=pod

=head1 AUTHOR

Barries Slaymaker .  Funded by Perforce Software, Inc.

=head1 COPYRIGHT

Copyright 2001, Barrie Slaymaker, All Rights Reserved.

You may use this under the terms of either the GPL 2.0 or the Artistic License.

=cut