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

   1 package IPC::Run::Win32Helper ;
   2
   3 =head1 NAME
   4
   5 IPC::Run::Win32Helper - helper routines for IPC::Run on Win32 platforms.
   6
   7 =head1 SYNOPSIS
   8
   9     use IPC::Run::Win32Helper;   # 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() loop
  14 will work on Win32. This seems to only work on WinNT and Win2K at this time, not
  15 sure if it will ever work on Win95 or Win98. If you have experience in this area, please
  16 contact me at barries@slaysys.com, thanks!.
  17
  18 =cut
  19
  20 @ISA = qw( Exporter ) ;
  21
  22 @EXPORT = qw(
  23    win32_spawn
  24    win32_parse_cmd_line
  25    _dont_inherit
  26    _inherit
  27 ) ;
  28
  29 use strict ;
  30 use Carp ;
  31 use IO::Handle ;
  32 #use IPC::Open3 ();
  33 require POSIX ;
  34
  35 use Text::ParseWords ;
  36 use Win32::Process ;
  37 use IPC::Run::Debug;
  38 ## REMOVE OSFHandleOpen
  39 use Win32API::File qw(
  40    FdGetOsFHandle
  41    SetHandleInformation
  42    HANDLE_FLAG_INHERIT
  43    INVALID_HANDLE_VALUE
  44 ) ;
  45
  46 ## Takes an fd or a GLOB ref, never never never a Win32 handle.
  47 sub _dont_inherit {
  48    for ( @_ ) {
  49       next unless defined $_ ;
  50       my $fd = $_ ;
  51       $fd = fileno $fd if ref $fd ;
  52       _debug "disabling inheritance of ", $fd if _debugging_details ;
  53       my $osfh = FdGetOsFHandle $fd ;
  54       croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE ;
  55
  56       SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 0 ) ;
  57    }
  58 }
  59
  60 sub _inherit {       #### REMOVE
  61    for ( @_ ) {       #### REMOVE
  62       next unless defined $_ ;       #### REMOVE
  63       my $fd = $_ ;       #### REMOVE
  64       $fd = fileno $fd if ref $fd ;       #### REMOVE
  65       _debug "enabling inheritance of ", $fd if _debugging_details ;       #### REMOVE
  66       my $osfh = FdGetOsFHandle $fd ;       #### REMOVE
  67       croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE ;       #### REMOVE
  68        #### REMOVE
  69       SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 1 ) ;       #### REMOVE
  70    }       #### REMOVE
  71 }       #### REMOVE
  72        #### REMOVE
  73 #sub _inherit {
  74 #   for ( @_ ) {
  75 #      next unless defined $_ ;
  76 #      my $osfh = GetOsFHandle $_ ;
  77 #      croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE ;
  78 #      SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT ) ;
  79 #   }
  80 #}
  81
  82 =head1 FUNCTIONS
  83
  84 =over
  85
  86 =cut
  87
  88 =item optimize()
  89
  90 Most common incantations of C<run()> (I<not> C<harness()>, C<start()>,
  91 or C<finish()>) now use temporary files to redirect input and output
  92 instead of pumper processes.
  93
  94 Temporary files are used when sending to child processes if input is
  95 taken from a scalar with no filter subroutines.  This is the only time
  96 we can assume that the parent is not interacting with the child's
  97 redirected input as it runs.
  98
  99 Temporary files are used when receiving from children when output is
 100 to a scalar or subroutine with or without filters, but only if
 101 the child in question closes its inputs or takes input from
 102 unfiltered SCALARs or named files.  Normally, a child inherits its STDIN
 103 from its parent; to close it, use "0<&-" or the C<noinherit => 1> option.
 104 If data is sent to the child from CODE refs, filehandles or from
 105 scalars through filters than the child's outputs will not be optimized
 106 because C<optimize()> assumes the parent is interacting with the child.
 107 It is ok if the output is filtered or handled by a subroutine, however.
 108
 109 This assumes that all named files are real files (as opposed to named
 110 pipes) and won't change; and that a process is not communicating with
 111 the child indirectly (through means not visible to IPC::Run).
 112 These can be an invalid assumptions, but are the 99% case.
 113 Write me if you need an option to enable or disable optimizations; I
 114 suspect it will work like the C<binary()> modifier.
 115
 116 To detect cases that you might want to optimize by closing inputs, try
 117 setting the C<IPCRUNDEBUG> environment variable to the special C<notopt>
 118 value:
 119
 120    C:> set IPCRUNDEBUG=notopt
 121    C:> my_app_that_uses_IPC_Run.pl
 122
 123 =item optimizer() rationalizations
 124
 125 Only for that limited case can we be sure that it's ok to batch all the
 126 input in to a temporary file.  If STDIN is from a SCALAR or from a named
 127 file or filehandle (again, only in C<run()>), then outputs to CODE refs
 128 are also assumed to be safe enough to batch through a temp file,
 129 otherwise only outputs to SCALAR refs are batched.  This can cause a bit
 130 of grief if the parent process benefits from or relies on a bit of
 131 "early returns" coming in before the child program exits.  As long as
 132 the output is redirected to a SCALAR ref, this will not be visible.
 133 When output is redirected to a subroutine or (deprecated) filters, the
 134 subroutine will not get any data until after the child process exits,
 135 and it is likely to get bigger chunks of data at once.
 136
 137 The reason for the optimization is that, without it, "pumper" processes
 138 are used to overcome the inconsistancies of the Win32 API.  We need to
 139 use anonymous pipes to connect to the child processes' stdin, stdout,
 140 and stderr, yet select() does not work on these.  select() only works on
 141 sockets on Win32.  So for each redirected child handle, there is
 142 normally a "pumper" process that connects to the parent using a
 143 socket--so the parent can select() on that fd--and to the child on an
 144 anonymous pipe--so the child can read/write a pipe.
 145
 146 Using a socket to connect directly to the child (as at least one MSDN
 147 article suggests) seems to cause the trailing output from most children
 148 to be lost.  I think this is because child processes rarely close their
 149 stdout and stderr explicitly, and the winsock dll does not seem to flush
 150 output when a process that uses it exits without explicitly closing
 151 them.
 152
 153 Because of these pumpers and the inherent slowness of Win32
 154 CreateProcess(), child processes with redirects are quite slow to
 155 launch; so this routine looks for the very common case of
 156 reading/writing to/from scalar references in a run() routine and
 157 converts such reads and writes in to temporary file reads and writes.
 158
 159 Such files are marked as FILE_ATTRIBUTE_TEMPORARY to increase speed and
 160 as FILE_FLAG_DELETE_ON_CLOSE so it will be cleaned up when the child
 161 process exits (for input files).  The user's default permissions are
 162 used for both the temporary files and the directory that contains them,
 163 hope your Win32 permissions are secure enough for you.  Files are
 164 created with the Win32API::File defaults of
 165 FILE_SHARE_READ|FILE_SHARE_WRITE.
 166
 167 Setting the debug level to "details" or "gory" will give detailed
 168 information about the optimization process; setting it to "basic" or
 169 higher will tell whether or not a given call is optimized.  Setting
 170 it to "notopt" will highligh those calls that aren't optimized.
 171
 172 =cut
 173
 174 sub optimize {
 175    my ( $h ) = @_;
 176
 177    my @kids = @{$h->{KIDS}};
 178
 179    my $saw_pipe;
 180
 181    my ( $ok_to_optimize_outputs, $veto_output_optimization );
 182
 183    for my $kid ( @kids ) {
 184       ( $ok_to_optimize_outputs, $veto_output_optimization ) = ()
 185          unless $saw_pipe;
 186
 187       _debug
 188          "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over ok of non-SCALAR output optimization"
 189          if _debugging_details && $ok_to_optimize_outputs;
 190       _debug
 191          "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over veto of non-SCALAR output optimization"
 192          if _debugging_details && $veto_output_optimization;
 193
 194       if ( $h->{noinherit} && ! $ok_to_optimize_outputs ) {
 195          _debug
 196             "Win32 optimizer: (kid $kid->{NUM}) STDIN not inherited from parent oking non-SCALAR output optimization"
 197             if _debugging_details && $ok_to_optimize_outputs;
 198          $ok_to_optimize_outputs = 1;
 199       }
 200
 201       for ( @{$kid->{OPS}} ) {
 202          if ( substr( $_->{TYPE}, 0, 1 ) eq "<" ) {
 203             if ( $_->{TYPE} eq "<" ) {
 204                if ( @{$_->{FILTERS}} > 1 ) {
 205                   ## Can't assume that the filters are idempotent.
 206                }
 207                elsif ( ref $_->{SOURCE} eq "SCALAR"
 208                   || ref $_->{SOURCE} eq "GLOB"
 209                   || UNIVERSAL::isa( $_, "IO::Handle" )
 210                ) {
 211                   if ( $_->{KFD} == 0 ) {
 212                      _debug
 213                         "Win32 optimizer: (kid $kid->{NUM}) 0$_->{TYPE}",
 214                         ref $_->{SOURCE},
 215                         ", ok to optimize outputs"
 216                         if _debugging_details;
 217                      $ok_to_optimize_outputs = 1;
 218                   }
 219                   $_->{SEND_THROUGH_TEMP_FILE} = 1;
 220                   next;
 221                }
 222                elsif ( ! ref $_->{SOURCE} && defined $_->{SOURCE} ) {
 223                   if ( $_->{KFD} == 0 ) {
 224                      _debug
 225                         "Win32 optimizer: (kid $kid->{NUM}) 0<$_->{SOURCE}, ok to optimize outputs",
 226                         if _debugging_details;
 227                      $ok_to_optimize_outputs = 1;
 228                   }
 229                   next;
 230                }
 231             }
 232             _debug
 233                "Win32 optimizer: (kid $kid->{NUM}) ",
 234                $_->{KFD},
 235                $_->{TYPE},
 236                defined $_->{SOURCE}
 237                   ? ref $_->{SOURCE}      ? ref $_->{SOURCE}
 238                                           : $_->{SOURCE}
 239                   : defined $_->{FILENAME}
 240                                           ? $_->{FILENAME}
 241                                           : "",
 242                @{$_->{FILTERS}} > 1 ? " with filters" : (),
 243                ", VETOING output opt."
 244                if _debugging_details || _debugging_not_optimized;
 245             $veto_output_optimization = 1;
 246          }
 247          elsif ( $_->{TYPE} eq "close" && $_->{KFD} == 0 ) {
 248             $ok_to_optimize_outputs = 1;
 249             _debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&-, ok to optimize outputs"
 250                if _debugging_details;
 251          }
 252          elsif ( $_->{TYPE} eq "dup" && $_->{KFD2} == 0 ) {
 253             $veto_output_optimization = 1;
 254             _debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&$_->{KFD2}, VETOING output opt."
 255                if _debugging_details || _debugging_not_optimized;
 256          }
 257          elsif ( $_->{TYPE} eq "|" ) {
 258             $saw_pipe = 1;
 259          }
 260       }
 261
 262       if ( ! $ok_to_optimize_outputs && ! $veto_output_optimization ) {
 263          _debug
 264             "Win32 optimizer: (kid $kid->{NUM}) child STDIN not redirected, VETOING non-SCALAR output opt."
 265             if _debugging_details || _debugging_not_optimized;
 266          $veto_output_optimization = 1;
 267       }
 268
 269       if ( $ok_to_optimize_outputs && $veto_output_optimization ) {
 270          $ok_to_optimize_outputs = 0;
 271          _debug "Win32 optimizer: (kid $kid->{NUM}) non-SCALAR output optimizations VETOed"
 272             if _debugging_details || _debugging_not_optimized;
 273       }
 274
 275       ## SOURCE/DEST ARRAY means it's a filter.
 276       ## TODO: think about checking to see if the final input/output of
 277       ## a filter chain (an ARRAY SOURCE or DEST) is a scalar...but
 278       ## we may be deprecating filters.
 279
 280       for ( @{$kid->{OPS}} ) {
 281          if ( $_->{TYPE} eq ">" ) {
 282             if ( ref $_->{DEST} eq "SCALAR"
 283                || (
 284                   ( @{$_->{FILTERS}} > 1
 285                      || ref $_->{DEST} eq "CODE"
 286                      || ref $_->{DEST} eq "ARRAY"  ## Filters?
 287                   )
 288                   && ( $ok_to_optimize_outputs && ! $veto_output_optimization )
 289                )
 290             ) {
 291                $_->{RECV_THROUGH_TEMP_FILE} = 1;
 292                next;
 293             }
 294             _debug
 295                "Win32 optimizer: NOT optimizing (kid $kid->{NUM}) ",
 296                $_->{KFD},
 297                $_->{TYPE},
 298                defined $_->{DEST}
 299                   ? ref $_->{DEST}      ? ref $_->{DEST}
 300                                           : $_->{SOURCE}
 301                   : defined $_->{FILENAME}
 302                                           ? $_->{FILENAME}
 303                                           : "",
 304                   @{$_->{FILTERS}} ? " with filters" : (),
 305                if _debugging_details;
 306          }
 307       }
 308    }
 309
 310 }
 311
 312 =item win32_parse_cmd_line
 313
 314    @words = win32_parse_cmd_line( q{foo bar 'baz baz' "bat bat"} ) ;
 315
 316 returns 4 words. This parses like the bourne shell (see
 317 the bit about shellwords() in L<Text::ParseWords>), assuming we're
 318 trying to be a little cross-platform here.  The only difference is
 319 that "\" is *not* treated as an escape except when it precedes
 320 punctuation, since it's used all over the place in DOS path specs.
 321
 322 TODO: globbing? probably not (it's unDOSish).
 323
 324 TODO: shebang emulation? Probably, but perhaps that should be part
 325 of Run.pm so all spawned processes get the benefit.
 326
 327 LIMITATIONS: shellwords dies silently on malformed input like
 328
 329    a\"
 330
 331 =cut
 332
 333 sub win32_parse_cmd_line {
 334    my $line = shift ;
 335    $line =~ s{(\\[\w\s])}{\\$1}g ;
 336    return shellwords $line ;
 337 }
 338
 339
 340 =item win32_spawn
 341
 342 Spawns a child process, possibly with STDIN, STDOUT, and STDERR (file descriptors 0, 1, and 2, respectively) redirected.
 343
 344 B<LIMITATIONS>.
 345
 346 Cannot redirect higher file descriptors due to lack of support for this in the
 347 Win32 environment.
 348
 349 This can be worked around by marking a handle as inheritable in the
 350 parent (or leaving it marked; this is the default in perl), obtaining it's
 351 Win32 handle with C<Win32API::GetOSFHandle(FH)> or
 352 C<Win32API::FdGetOsFHandle($fd)> and passing it to the child using the command
 353 line, the environment, or any other IPC mechanism (it's a plain old integer).
 354 The child can then use C<OsFHandleOpen()> or C<OsFHandleOpenFd()> and possibly
 355 C<<open FOO ">&BAR">> or C<<open FOO ">&$fd>> as need be.  Ach, the pain!
 356
 357 Remember to check the Win32 handle against INVALID_HANDLE_VALUE.
 358
 359 =cut
 360
 361 sub _save {
 362    my ( $saved, $saved_as, $fd ) = @_ ;
 363
 364    ## We can only save aside the original fds once.
 365    return if exists $saved->{$fd} ;
 366
 367    my $saved_fd = IPC::Run::_dup( $fd ) ;
 368    _dont_inherit $saved_fd ;
 369
 370    $saved->{$fd} = $saved_fd ;
 371    $saved_as->{$saved_fd} = $fd ;
 372
 373    _dont_inherit $saved->{$fd} ;
 374 }
 375
 376 sub _dup2_gently {
 377    my ( $saved, $saved_as, $fd1, $fd2 ) = @_ ;
 378    _save $saved, $saved_as, $fd2 ;
 379
 380    if ( exists $saved_as->{$fd2} ) {
 381       ## The target fd is colliding with a saved-as fd, gotta bump
 382       ## the saved-as fd to another fd.
 383       my $orig_fd = delete $saved_as->{$fd2} ;
 384       my $saved_fd = IPC::Run::_dup( $fd2 ) ;
 385       _dont_inherit $saved_fd ;
 386
 387       $saved->{$orig_fd} = $saved_fd ;
 388       $saved_as->{$saved_fd} = $orig_fd ;
 389    }
 390    _debug "moving $fd1 to kid's $fd2" if _debugging_details ;
 391    IPC::Run::_dup2_rudely( $fd1, $fd2 ) ;
 392 }
 393
 394 sub win32_spawn {
 395    my ( $cmd, $ops) = @_ ;
 396
 397    ## NOTE: The debug pipe write handle is passed to pump processes as STDOUT.
 398    ## and is not to the "real" child process, since they would not know
 399    ## what to do with it...unlike Unix, we have no code executing in the
 400    ## child before the "real" child is exec()ed.
 401
 402    my %saved ;      ## Map of parent's orig fd -> saved fd
 403    my %saved_as ;   ## Map of parent's saved fd -> orig fd, used to
 404                     ## detect collisions between a KFD and the fd a
 405                     ## parent's fd happened to be saved to.
 406
 407    for my $op ( @$ops ) {
 408       _dont_inherit $op->{FD}  if defined $op->{FD} ;
 409
 410       if ( defined $op->{KFD} && $op->{KFD} > 2 ) {
 411          ## TODO: Detect this in harness()
 412          ## TODO: enable temporary redirections if ever necessary, not
 413          ## sure why they would be...
 414          ## 4>&1 1>/dev/null 1>&4 4>&-
 415          croak "Can't redirect fd #", $op->{KFD}, " on Win32" ;
 416       }
 417
 418       ## This is very similar logic to IPC::Run::_do_kid_and_exit().
 419       if ( defined $op->{TFD} ) {
 420          unless ( $op->{TFD} == $op->{KFD} ) {
 421             _dup2_gently \%saved, \%saved_as, $op->{TFD}, $op->{KFD} ;
 422             _dont_inherit $op->{TFD} ;
 423          }
 424       }
 425       elsif ( $op->{TYPE} eq "dup" ) {
 426          _dup2_gently \%saved, \%saved_as, $op->{KFD1}, $op->{KFD2}
 427             unless $op->{KFD1} == $op->{KFD2} ;
 428       }
 429       elsif ( $op->{TYPE} eq "close" ) {
 430          _save \%saved, \%saved_as, $op->{KFD} ;
 431          IPC::Run::_close( $op->{KFD} ) ;
 432       }
 433       elsif ( $op->{TYPE} eq "init" ) {
 434          ## TODO: detect this in harness()
 435          croak "init subs not allowed on Win32" ;
 436       }
 437    }
 438
 439    my $process ;
 440    my $cmd_line = join " ", map {
 441       ( my $s = $_ ) =~ s/"/"""/g;
 442       $s = qq{"$s"} if /["\s]/;
 443       $s ;
 444    } @$cmd ;
 445
 446    _debug "cmd line: ", $cmd_line
 447       if _debugging;
 448
 449    Win32::Process::Create(
 450       $process,
 451       $cmd->[0],
 452       $cmd_line,
 453       1,  ## Inherit handles
 454       NORMAL_PRIORITY_CLASS,
 455       ".",
 456    ) or croak "$!: Win32::Process::Create()" ;
 457
 458    for my $orig_fd ( keys %saved ) {
 459       IPC::Run::_dup2_rudely( $saved{$orig_fd}, $orig_fd ) ;
 460       IPC::Run::_close( $saved{$orig_fd} ) ;
 461    }
 462
 463    return ( $process->GetProcessID(), $process ) ;
 464 }
 465
 466
 467 =back
 468
 469 =head1 AUTHOR
 470
 471 Barries Slaymaker <barries@slaysys.com>.  Funded by Perforce Software, Inc.
 472
 473 =head1 COPYRIGHT
 474
 475 Copyright 2001, Barrie Slaymaker, All Rights Reserved.
 476
 477 You may use this under the terms of either the GPL 2.0 ir the Artistic License.
 478
 479 =cut
 480
 481 1 ;