Source/t/lib/IPC/Run/Win32IO.pm

   1 package IPC::Run::Win32IO;
   2
   3 =head1 NAME
   4
   5 IPC::Run::Win32IO - helper routines for IPC::Run on Win32 platforms.
   6
   7 =head1 SYNOPSIS
   8
   9     use IPC::Run::Win32IO;   # Exports all by default
  10
  11 =head1 DESCRIPTION
  12
  13 IPC::Run needs to use sockets to redirect subprocess I/O so that the select()
  14 loop will work on Win32. This seems to only work on WinNT and Win2K at this
  15 time, not sure if it will ever work on Win95 or Win98. If you have experience
  16 in this area, please contact me at barries@slaysys.com, thanks!.
  17
  18 =cut
  19
  20 =head1 DESCRIPTION
  21
  22 A specialized IO class used on Win32.
  23
  24 =cut
  25
  26 use strict ;
  27 use Carp ;
  28 use IO::Handle ;
  29 use Socket ;
  30 require POSIX ;
  31
  32 use Socket qw( IPPROTO_TCP TCP_NODELAY ) ;
  33 use Symbol ;
  34 use Text::ParseWords ;
  35 use Win32::Process ;
  36 use IPC::Run::Debug qw( :default _debugging_level );
  37 use IPC::Run::Win32Helper qw( _inherit _dont_inherit );
  38 use Fcntl qw( O_TEXT O_RDONLY );
  39
  40 use base qw( IPC::Run::IO );
  41 my @cleanup_fields;
  42 BEGIN {
  43    ## These fields will be set to undef in _cleanup to close
  44    ## the handles.
  45    @cleanup_fields = (
  46       'SEND_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize()
  47       'RECV_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize()
  48       'TEMP_FILE_NAME',         ## The name of the temp file, needed for
  49                                 ## error reporting / debugging only.
  50
  51       'PARENT_HANDLE',       ## The handle of the socket for the parent
  52       'PUMP_SOCKET_HANDLE',  ## The socket handle for the pump
  53       'PUMP_PIPE_HANDLE',    ## The anon pipe handle for the pump
  54       'CHILD_HANDLE',        ## The anon pipe handle for the child
  55
  56       'TEMP_FILE_HANDLE',    ## The Win32 filehandle for the temp file
  57    );
  58 }
  59
  60 ## REMOVE OSFHandleOpen
  61 use Win32API::File qw(
  62    GetOsFHandle
  63    OsFHandleOpenFd
  64    OsFHandleOpen
  65    FdGetOsFHandle
  66    SetHandleInformation
  67    SetFilePointer
  68    HANDLE_FLAG_INHERIT
  69    INVALID_HANDLE_VALUE
  70
  71    createFile
  72    WriteFile
  73    ReadFile
  74    CloseHandle
  75
  76    FILE_ATTRIBUTE_TEMPORARY
  77    FILE_FLAG_DELETE_ON_CLOSE
  78    FILE_FLAG_WRITE_THROUGH
  79
  80    FILE_BEGIN
  81 ) ;
  82
  83 #   FILE_ATTRIBUTE_HIDDEN
  84 #   FILE_ATTRIBUTE_SYSTEM
  85
  86
  87 BEGIN {
  88    ## Force AUTOLOADED constants to be, well, constant by getting them
  89    ## to AUTOLOAD before compilation continues.  Sigh.
  90    () = (
  91       SOL_SOCKET,
  92       SO_REUSEADDR,
  93       IPPROTO_TCP,
  94       TCP_NODELAY,
  95       HANDLE_FLAG_INHERIT,
  96       INVALID_HANDLE_VALUE,
  97    );
  98 }
  99
 100
 101 use constant temp_file_flags => (
 102    FILE_ATTRIBUTE_TEMPORARY()   |
 103    FILE_FLAG_DELETE_ON_CLOSE()  |
 104    FILE_FLAG_WRITE_THROUGH()
 105 );
 106
 107 #   FILE_ATTRIBUTE_HIDDEN()    |
 108 #   FILE_ATTRIBUTE_SYSTEM()    |
 109 my $tmp_file_counter;
 110 my $tmp_dir;
 111
 112 sub _cleanup {
 113     my IPC::Run::Win32IO $self = shift;
 114     my ( $harness ) = @_;
 115
 116     $self->_recv_through_temp_file( $harness )
 117        if $self->{RECV_THROUGH_TEMP_FILE};
 118
 119     CloseHandle( $self->{TEMP_FILE_HANDLE} )
 120        if defined $self->{TEMP_FILE_HANDLE};
 121
 122     $self->{$_} = undef for @cleanup_fields;
 123 }
 124
 125
 126 sub _create_temp_file {
 127    my IPC::Run::Win32IO $self = shift;
 128
 129    ## Create a hidden temp file that Win32 will delete when we close
 130    ## it.
 131    unless ( defined $tmp_dir ) {
 132       $tmp_dir = File::Spec->catdir(
 133          File::Spec->tmpdir, "IPC-Run.tmp"
 134       );
 135
 136       ## Trust in the user's umask.
 137       ## This could possibly be a security hole, perhaps
 138       ## we should offer an option.  Hmmmm, really, people coding
 139       ## security conscious apps should audit this code and
 140       ## tell me how to make it better.  Nice cop-out :).
 141       unless ( -d $tmp_dir ) {
 142          mkdir $tmp_dir or croak "$!: $tmp_dir";
 143       }
 144    }
 145
 146    $self->{TEMP_FILE_NAME} = File::Spec->catfile(
 147       ## File name is designed for easy sorting and not conflicting
 148       ## with other processes.  This should allow us to use "t"runcate
 149       ## access in CreateFile in case something left some droppings
 150       ## around (which should never happen because we specify
 151       ## FLAG_DELETE_ON_CLOSE.
 152       ## heh, belt and suspenders are better than bug reports; God forbid
 153       ## that NT should ever crash before a temp file gets deleted!
 154       $tmp_dir, sprintf "Win32io-%06d-%08d", $$, $tmp_file_counter++
 155    );
 156
 157    $self->{TEMP_FILE_HANDLE} = createFile(
 158       $self->{TEMP_FILE_NAME},
 159       "trw",         ## new, truncate, read, write
 160       {
 161          Flags      => temp_file_flags,
 162       },
 163    ) or croak "Can't create temporary file, $self->{TEMP_FILE_NAME}: $^E";
 164
 165    $self->{TFD} = OsFHandleOpenFd $self->{TEMP_FILE_HANDLE}, 0;
 166    $self->{FD} = undef;
 167
 168    _debug
 169       "Win32 Optimizer: temp file (",
 170       $self->{KFD},
 171       $self->{TYPE},
 172       $self->{TFD},
 173       ", fh ",
 174       $self->{TEMP_FILE_HANDLE},
 175       "): ",
 176       $self->{TEMP_FILE_NAME}
 177       if _debugging_details;
 178 }
 179
 180
 181 sub _reset_temp_file_pointer {
 182    my $self = shift;
 183    SetFilePointer( $self->{TEMP_FILE_HANDLE}, 0, 0, FILE_BEGIN )
 184       or confess "$^E seeking on (fd $self->{TFD}) $self->{TEMP_FILE_NAME} for kid's fd $self->{KFD}";
 185 }
 186
 187
 188 sub _send_through_temp_file {
 189    my IPC::Run::Win32IO $self = shift;
 190
 191    _debug
 192       "Win32 optimizer: optimizing "
 193       . " $self->{KFD} $self->{TYPE} temp file instead of ",
 194          ref $self->{SOURCE} || $self->{SOURCE}
 195       if _debugging_details;
 196
 197    $self->_create_temp_file;
 198
 199    if ( defined ${$self->{SOURCE}} ) {
 200       my $bytes_written = 0;
 201       my $data_ref;
 202       if ( $self->binmode ) {
 203          $data_ref = $self->{SOURCE};
 204       }
 205       else {
 206          my $data = ${$self->{SOURCE}};  # Ugh, a copy.
 207          $data =~ s/(?<!\r)\n/\r\n/g;
 208          $data_ref = \$data;
 209       }
 210
 211       WriteFile(
 212          $self->{TEMP_FILE_HANDLE},
 213          $$data_ref,
 214          0,              ## Write entire buffer
 215          $bytes_written,
 216          [],             ## Not overlapped.
 217       ) or croak
 218          "$^E writing $self->{TEMP_FILE_NAME} for kid to read on fd $self->{KFD}";
 219       _debug
 220          "Win32 optimizer: wrote $bytes_written to temp file $self->{TEMP_FILE_NAME}"
 221          if _debugging_data;
 222
 223       $self->_reset_temp_file_pointer;
 224
 225    }
 226
 227
 228    _debug "Win32 optimizer: kid to read $self->{KFD} from temp file on $self->{TFD}"
 229       if _debugging_details;
 230 }
 231
 232
 233 sub _init_recv_through_temp_file {
 234    my IPC::Run::Win32IO $self = shift;
 235
 236    $self->_create_temp_file;
 237 }
 238
 239
 240 ## TODO: USe the Win32 API in the select loop to see if the file has grown
 241 ## and read it incrementally if it has.
 242 sub _recv_through_temp_file {
 243    my IPC::Run::Win32IO $self = shift;
 244
 245    ## This next line kicks in if the run() never got to initting things
 246    ## and needs to clean up.
 247    return undef unless defined $self->{TEMP_FILE_HANDLE};
 248
 249    push @{$self->{FILTERS}}, sub {
 250       my ( undef, $out_ref ) = @_;
 251
 252       return undef unless defined $self->{TEMP_FILE_HANDLE};
 253
 254       my $r;
 255       my $s;
 256       ReadFile(
 257          $self->{TEMP_FILE_HANDLE},
 258          $s,
 259          999_999,  ## Hmmm, should read the size.
 260          $r,
 261          []
 262       ) or croak "$^E reading from $self->{TEMP_FILE_NAME}";
 263
 264       _debug "ReadFile( $self->{TFD} ) = $r chars '$s'" if _debugging_data ;
 265
 266       return undef unless $r;
 267
 268       $s =~ s/\r\n/\n/g unless $self->binmode;
 269
 270       my $pos = pos $$out_ref;
 271       $$out_ref .= $s;
 272       pos( $out_ref ) = $pos;
 273       return 1;
 274    };
 275
 276    my ( $harness ) = @_;
 277
 278    $self->_reset_temp_file_pointer;
 279
 280    1 while $self->_do_filters( $harness );
 281
 282    pop @{$self->{FILTERS}};
 283
 284    IPC::Run::_close( $self->{TFD} );
 285 }
 286
 287
 288 sub poll {
 289    my IPC::Run::Win32IO $self = shift;
 290
 291    return if $self->{SEND_THROUGH_TEMP_FILE} || $self->{RECV_THROUGH_TEMP_FILE};
 292
 293    return $self->SUPER::poll( @_ );
 294 }
 295
 296
 297 ## When threaded Perls get good enough, we should use threads here.
 298 ## The problem with threaded perls is that they dup() all sorts of
 299 ## filehandles and fds and don't allow sufficient control over
 300 ## closing off the ones we don't want.
 301
 302 sub _spawn_pumper {
 303    my ( $stdin, $stdout, $debug_fd, $binmode, $child_label, @opts ) = @_ ;
 304    my ( $stdin_fd, $stdout_fd ) = ( fileno $stdin, fileno $stdout ) ;
 305
 306    _debug "pumper stdin = ", $stdin_fd if _debugging_details;
 307    _debug "pumper stdout = ", $stdout_fd if _debugging_details;
 308    _inherit $stdin_fd, $stdout_fd, $debug_fd ;
 309    my @I_options = map qq{"-I$_"}, @INC;
 310
 311    my $cmd_line = join( " ",
 312       qq{"$^X"},
 313       @I_options,
 314       qw(-MIPC::Run::Win32Pump -e 1 ),
 315 ## I'm using this clunky way of passing filehandles to the child process
 316 ## in order to avoid some kind of premature closure of filehandles
 317 ## problem I was having with VCP's test suite when passing them
 318 ## via CreateProcess.  All of the ## REMOVE code is stuff I'd like
 319 ## to be rid of and the ## ADD code is what I'd like to use.
 320       FdGetOsFHandle( $stdin_fd ), ## REMOVE
 321       FdGetOsFHandle( $stdout_fd ), ## REMOVE
 322       FdGetOsFHandle( $debug_fd ), ## REMOVE
 323       $binmode ? 1 : 0,
 324       $$, $^T, _debugging_level, qq{"$child_label"},
 325       @opts
 326    ) ;
 327
 328 #   open SAVEIN,  "<&STDIN"  or croak "$! saving STDIN" ;       #### ADD
 329 #   open SAVEOUT, ">&STDOUT" or croak "$! saving STDOUT" ;       #### ADD
 330 #   open SAVEERR, ">&STDERR" or croak "$! saving STDERR" ;       #### ADD
 331 #   _dont_inherit \*SAVEIN ;       #### ADD
 332 #   _dont_inherit \*SAVEOUT ;       #### ADD
 333 #   _dont_inherit \*SAVEERR ;       #### ADD
 334 #   open STDIN,  "<&$stdin_fd"  or croak "$! dup2()ing $stdin_fd (pumper's STDIN)" ;       #### ADD
 335 #   open STDOUT, ">&$stdout_fd" or croak "$! dup2()ing $stdout_fd (pumper's STDOUT)" ;       #### ADD
 336 #   open STDERR, ">&$debug_fd" or croak "$! dup2()ing $debug_fd (pumper's STDERR/debug_fd)" ;       #### ADD
 337
 338    _debug "pump cmd line: ", $cmd_line if _debugging_details;
 339
 340    my $process ;
 341    Win32::Process::Create(
 342       $process,
 343       $^X,
 344       $cmd_line,
 345       1,  ## Inherit handles
 346       NORMAL_PRIORITY_CLASS,
 347       ".",
 348    ) or croak "$!: Win32::Process::Create()" ;
 349
 350 #   open STDIN,  "<&SAVEIN"  or croak "$! restoring STDIN" ;       #### ADD
 351 #   open STDOUT, ">&SAVEOUT" or croak "$! restoring STDOUT" ;       #### ADD
 352 #   open STDERR, ">&SAVEERR" or croak "$! restoring STDERR" ;       #### ADD
 353 #   close SAVEIN             or croak "$! closing SAVEIN" ;       #### ADD
 354 #   close SAVEOUT            or croak "$! closing SAVEOUT" ;       #### ADD
 355 #   close SAVEERR            or croak "$! closing SAVEERR" ;       #### ADD
 356
 357    close $stdin  or croak "$! closing pumper's stdin in parent" ;
 358    close $stdout or croak "$! closing pumper's stdout in parent" ;
 359    # Don't close $debug_fd, we need it, as do other pumpers.
 360
 361    # Pause a moment to allow the child to get up and running and emit
 362    # debug messages.  This does not always work.
 363    #   select undef, undef, undef, 1 if _debugging_details ;
 364
 365    _debug "_spawn_pumper pid = ", $process->GetProcessID
 366       if _debugging_data;
 367 }
 368
 369
 370 my $next_port = 2048 ;
 371 my $loopback  = inet_aton "127.0.0.1" ;
 372 my $tcp_proto = getprotobyname('tcp');
 373 croak "$!: getprotobyname('tcp')" unless defined $tcp_proto ;
 374
 375 sub _socket {
 376    my ( $server ) = @_ ;
 377    $server ||= gensym ;
 378    my $client = gensym ;
 379
 380    my $listener = gensym ;
 381    socket $listener, PF_INET, SOCK_STREAM, $tcp_proto
 382       or croak "$!: socket()";
 383    setsockopt $listener, SOL_SOCKET, SO_REUSEADDR, pack("l", 0)
 384       or croak "$!: setsockopt()";
 385
 386    my $port ;
 387    my @errors ;
 388 PORT_FINDER_LOOP:
 389    {
 390       $port = $next_port ;
 391       $next_port = 2048 if ++$next_port > 65_535 ;
 392       unless ( bind $listener, sockaddr_in( $port, INADDR_ANY ) ) {
 393          push @errors, "$! on port $port" ;
 394          croak join "\n", @errors if @errors > 10 ;
 395          goto PORT_FINDER_LOOP;
 396       }
 397    }
 398
 399    _debug "win32 port = $port" if _debugging_details;
 400
 401    listen $listener, my $queue_size = 1
 402       or croak "$!: listen()" ;
 403
 404    {
 405       socket $client, PF_INET, SOCK_STREAM, $tcp_proto
 406          or croak "$!: socket()";
 407
 408       my $paddr = sockaddr_in($port, $loopback );
 409
 410       connect $client, $paddr
 411          or croak "$!: connect()" ;
 412
 413       croak "$!: accept" unless defined $paddr ;
 414
 415       ## The windows "default" is SO_DONTLINGER, which should make
 416       ## sure all socket data goes through.  I have my doubts based
 417       ## on experimentation, but nothing prompts me to set SO_LINGER
 418       ## at this time...
 419       setsockopt $client, IPPROTO_TCP, TCP_NODELAY, pack("l", 0)
 420          or croak "$!: setsockopt()";
 421    }
 422
 423    {
 424       _debug "accept()ing on port $port" if _debugging_details;
 425       my $paddr = accept( $server, $listener ) ;
 426       croak "$!: accept()" unless defined $paddr ;
 427    }
 428
 429    _debug
 430       "win32 _socket = ( ", fileno $server, ", ", fileno $client, " ) on port $port"
 431       if _debugging_details;
 432    return ( $server, $client ) ;
 433 }
 434
 435
 436 sub _open_socket_pipe {
 437    my IPC::Run::Win32IO $self = shift;
 438    my ( $debug_fd, $parent_handle ) = @_ ;
 439
 440    my $is_send_to_child = $self->dir eq "<";
 441
 442    $self->{CHILD_HANDLE}     = gensym;
 443    $self->{PUMP_PIPE_HANDLE} = gensym;
 444
 445    (
 446       $self->{PARENT_HANDLE},
 447       $self->{PUMP_SOCKET_HANDLE}
 448    ) = _socket $parent_handle ;
 449
 450    ## These binmodes seem to have no effect on Win2K, but just to be safe
 451    ## I do them.
 452    binmode $self->{PARENT_HANDLE}      or die $!;
 453    binmode $self->{PUMP_SOCKET_HANDLE} or die $!;
 454
 455 _debug "PUMP_SOCKET_HANDLE = ", fileno $self->{PUMP_SOCKET_HANDLE}
 456    if _debugging_details;
 457 ##my $buf ;
 458 ##$buf = "write on child end of " . fileno( $self->{WRITE_HANDLE} ) . "\n\n\n\n\n" ;
 459 ##POSIX::write(fileno $self->{WRITE_HANDLE}, $buf, length $buf) or warn "$! in syswrite" ;
 460 ##$buf = "write on parent end of " . fileno( $self->{CHILD_HANDLE} ) . "\r\n" ;
 461 ##POSIX::write(fileno $self->{CHILD_HANDLE},$buf, length $buf) or warn "$! in syswrite" ;
 462 ##   $self->{CHILD_HANDLE}->autoflush( 1 ) ;
 463 ##   $self->{WRITE_HANDLE}->autoflush( 1 ) ;
 464
 465    ## Now fork off a data pump and arrange to return the correct fds.
 466    if ( $is_send_to_child ) {
 467       pipe $self->{CHILD_HANDLE}, $self->{PUMP_PIPE_HANDLE}
 468          or croak "$! opening child pipe" ;
 469 _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
 470    if _debugging_details;
 471 _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
 472    if _debugging_details;
 473    }
 474    else {
 475       pipe $self->{PUMP_PIPE_HANDLE}, $self->{CHILD_HANDLE}
 476          or croak "$! opening child pipe" ;
 477 _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE}
 478    if _debugging_details;
 479 _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE}
 480    if _debugging_details;
 481    }
 482
 483    ## These binmodes seem to have no effect on Win2K, but just to be safe
 484    ## I do them.
 485    binmode $self->{CHILD_HANDLE};
 486    binmode $self->{PUMP_PIPE_HANDLE};
 487
 488    ## No child should ever see this.
 489    _dont_inherit $self->{PARENT_HANDLE} ;
 490
 491    ## We clear the inherit flag so these file descriptors are not inherited.
 492    ## It'll be dup()ed on to STDIN/STDOUT/STDERR before CreateProcess is
 493    ## called and *that* fd will be inheritable.
 494    _dont_inherit $self->{PUMP_SOCKET_HANDLE} ;
 495    _dont_inherit $self->{PUMP_PIPE_HANDLE} ;
 496    _dont_inherit $self->{CHILD_HANDLE} ;
 497
 498    ## Need to return $self so the HANDLEs don't get freed.
 499    ## Return $self, $parent_fd, $child_fd
 500    my ( $parent_fd, $child_fd ) = (
 501       fileno $self->{PARENT_HANDLE},
 502       fileno $self->{CHILD_HANDLE}
 503    ) ;
 504
 505    ## Both PUMP_..._HANDLEs will be closed, no need to worry about
 506    ## inheritance.
 507    _debug "binmode on" if _debugging_data && $self->binmode;
 508    _spawn_pumper(
 509       $is_send_to_child
 510          ? ( $self->{PUMP_SOCKET_HANDLE}, $self->{PUMP_PIPE_HANDLE} )
 511          : ( $self->{PUMP_PIPE_HANDLE}, $self->{PUMP_SOCKET_HANDLE} ),
 512       $debug_fd,
 513       $self->binmode,
 514       $child_fd . $self->dir . "pump" . $self->dir . $parent_fd,
 515    ) ;
 516
 517 {
 518 my $foo ;
 519 confess "PARENT_HANDLE no longer open"
 520    unless POSIX::read( $parent_fd, $foo, 0 ) ;
 521 }
 522
 523    _debug "win32_fake_pipe = ( $parent_fd, $child_fd )"
 524       if _debugging_details;
 525
 526    $self->{FD}  = $parent_fd;
 527    $self->{TFD} = $child_fd;
 528 }
 529
 530 sub _do_open {
 531    my IPC::Run::Win32IO $self = shift;
 532
 533    if ( $self->{SEND_THROUGH_TEMP_FILE} ) {
 534       return $self->_send_through_temp_file( @_ );
 535    }
 536    elsif ( $self->{RECV_THROUGH_TEMP_FILE} ) {
 537       return $self->_init_recv_through_temp_file( @_ );
 538    }
 539    else {
 540       return $self->_open_socket_pipe( @_ );
 541    }
 542 }
 543
 544 =head1 AUTHOR
 545
 546 Barries Slaymaker <barries@slaysys.com>.  Funded by Perforce Software, Inc.
 547
 548 =head1 COPYRIGHT
 549
 550 Copyright 2001, Barrie Slaymaker, All Rights Reserved.
 551
 552 You may use this under the terms of either the GPL 2.0 ir the Artistic License.
 553
 554 =cut
 555
 556 1;