tools/cmake/scripts/IPC/Run/Win32Helper.pm

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