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