1package IPC::Run; 2use bytes; 3 4=pod 5 6=head1 NAME 7 8IPC::Run - system() and background procs w/ piping, redirs, ptys (Unix, Win32) 9 10=head1 SYNOPSIS 11 12 ## First,a command to run: 13 my @cat = qw( cat ); 14 15 ## Using run() instead of system(): 16 use IPC::Run qw( run timeout ); 17 18 run \@cat, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?"; 19 20 # Can do I/O to sub refs and filenames, too: 21 run \@cat, '<', "in.txt", \&out, \&err or die "cat: $?"; 22 run \@cat, '<', "in.txt", '>>', "out.txt", '2>>', "err.txt"; 23 24 25 # Redirecting using pseudo-terminals instead of pipes. 26 run \@cat, '<pty<', \$in, '>pty>', \$out_and_err; 27 28 ## Scripting subprocesses (like Expect): 29 30 use IPC::Run qw( start pump finish timeout ); 31 32 # Incrementally read from / write to scalars. 33 # $in is drained as it is fed to cat's stdin, 34 # $out accumulates cat's stdout 35 # $err accumulates cat's stderr 36 # $h is for "harness". 37 my $h = start \@cat, \$in, \$out, \$err, timeout( 10 ); 38 39 $in .= "some input\n"; 40 pump $h until $out =~ /input\n/g; 41 42 $in .= "some more input\n"; 43 pump $h until $out =~ /\G.*more input\n/; 44 45 $in .= "some final input\n"; 46 finish $h or die "cat returned $?"; 47 48 warn $err if $err; 49 print $out; ## All of cat's output 50 51 # Piping between children 52 run \@cat, '|', \@gzip; 53 54 # Multiple children simultaneously (run() blocks until all 55 # children exit, use start() for background execution): 56 run \@foo1, '&', \@foo2; 57 58 # Calling \&set_up_child in the child before it executes the 59 # command (only works on systems with true fork() & exec()) 60 # exceptions thrown in set_up_child() will be propagated back 61 # to the parent and thrown from run(). 62 run \@cat, \$in, \$out, 63 init => \&set_up_child; 64 65 # Read from / write to file handles you open and close 66 open IN, '<in.txt' or die $!; 67 open OUT, '>out.txt' or die $!; 68 print OUT "preamble\n"; 69 run \@cat, \*IN, \*OUT or die "cat returned $?"; 70 print OUT "postamble\n"; 71 close IN; 72 close OUT; 73 74 # Create pipes for you to read / write (like IPC::Open2 & 3). 75 $h = start 76 \@cat, 77 '<pipe', \*IN, # may also be a lexical filehandle e.g. \my $infh 78 '>pipe', \*OUT, 79 '2>pipe', \*ERR 80 or die "cat returned $?"; 81 print IN "some input\n"; 82 close IN; 83 print <OUT>, <ERR>; 84 finish $h; 85 86 # Mixing input and output modes 87 run \@cat, 'in.txt', \&catch_some_out, \*ERR_LOG; 88 89 # Other redirection constructs 90 run \@cat, '>&', \$out_and_err; 91 run \@cat, '2>&1'; 92 run \@cat, '0<&3'; 93 run \@cat, '<&-'; 94 run \@cat, '3<', \$in3; 95 run \@cat, '4>', \$out4; 96 # etc. 97 98 # Passing options: 99 run \@cat, 'in.txt', debug => 1; 100 101 # Call this system's shell, returns TRUE on 0 exit code 102 # THIS IS THE OPPOSITE SENSE OF system()'s RETURN VALUE 103 run "cat a b c" or die "cat returned $?"; 104 105 # Launch a sub process directly, no shell. Can't do redirection 106 # with this form, it's here to behave like system() with an 107 # inverted result. 108 $r = run "cat a b c"; 109 110 # Read from a file in to a scalar 111 run io( "filename", 'r', \$recv ); 112 run io( \*HANDLE, 'r', \$recv ); 113 114=head1 DESCRIPTION 115 116IPC::Run allows you to run and interact with child processes using files, pipes, 117and pseudo-ttys. Both system()-style and scripted usages are supported and 118may be mixed. Likewise, functional and OO API styles are both supported and 119may be mixed. 120 121Various redirection operators reminiscent of those seen on common Unix and DOS 122command lines are provided. 123 124Before digging in to the details a few LIMITATIONS are important enough 125to be mentioned right up front: 126 127=over 128 129=item Win32 Support 130 131Win32 support is working but B<EXPERIMENTAL>, but does pass all relevant tests 132on NT 4.0. See L</Win32 LIMITATIONS>. 133 134=item pty Support 135 136If you need pty support, IPC::Run should work well enough most of the 137time, but IO::Pty is being improved, and IPC::Run will be improved to 138use IO::Pty's new features when it is release. 139 140The basic problem is that the pty needs to initialize itself before the 141parent writes to the master pty, or the data written gets lost. So 142IPC::Run does a sleep(1) in the parent after forking to (hopefully) give 143the child a chance to run. This is a kludge that works well on non 144heavily loaded systems :(. 145 146ptys are not supported yet under Win32, but will be emulated... 147 148=item Debugging Tip 149 150You may use the environment variable C<IPCRUNDEBUG> to see what's going on 151under the hood: 152 153 $ IPCRUNDEBUG=basic myscript # prints minimal debugging 154 $ IPCRUNDEBUG=data myscript # prints all data reads/writes 155 $ IPCRUNDEBUG=details myscript # prints lots of low-level details 156 $ IPCRUNDEBUG=gory myscript # (Win32 only) prints data moving through 157 # the helper processes. 158 159=back 160 161We now return you to your regularly scheduled documentation. 162 163=head2 Harnesses 164 165Child processes and I/O handles are gathered in to a harness, then 166started and run until the processing is finished or aborted. 167 168=head2 run() vs. start(); pump(); finish(); 169 170There are two modes you can run harnesses in: run() functions as an 171enhanced system(), and start()/pump()/finish() allow for background 172processes and scripted interactions with them. 173 174When using run(), all data to be sent to the harness is set up in 175advance (though one can feed subprocesses input from subroutine refs to 176get around this limitation). The harness is run and all output is 177collected from it, then any child processes are waited for: 178 179 run \@cmd, \<<IN, \$out; 180 blah 181 IN 182 183 ## To precompile harnesses and run them later: 184 my $h = harness \@cmd, \<<IN, \$out; 185 blah 186 IN 187 188 run $h; 189 190The background and scripting API is provided by start(), pump(), and 191finish(): start() creates a harness if need be (by calling harness()) 192and launches any subprocesses, pump() allows you to poll them for 193activity, and finish() then monitors the harnessed activities until they 194complete. 195 196 ## Build the harness, open all pipes, and launch the subprocesses 197 my $h = start \@cat, \$in, \$out; 198 $in = "first input\n"; 199 200 ## Now do I/O. start() does no I/O. 201 pump $h while length $in; ## Wait for all input to go 202 203 ## Now do some more I/O. 204 $in = "second input\n"; 205 pump $h until $out =~ /second input/; 206 207 ## Clean up 208 finish $h or die "cat returned $?"; 209 210You can optionally compile the harness with harness() prior to 211start()ing or run()ing, and you may omit start() between harness() and 212pump(). You might want to do these things if you compile your harnesses 213ahead of time. 214 215=head2 Using regexps to match output 216 217As shown in most of the scripting examples, the read-to-scalar facility 218for gathering subcommand's output is often used with regular expressions 219to detect stopping points. This is because subcommand output often 220arrives in dribbles and drabs, often only a character or line at a time. 221This output is input for the main program and piles up in variables like 222the C<$out> and C<$err> in our examples. 223 224Regular expressions can be used to wait for appropriate output in 225several ways. The C<cat> example in the previous section demonstrates 226how to pump() until some string appears in the output. Here's an 227example that uses C<smb> to fetch files from a remote server: 228 229 $h = harness \@smbclient, \$in, \$out; 230 231 $in = "cd /src\n"; 232 $h->pump until $out =~ /^smb.*> \Z/m; 233 die "error cding to /src:\n$out" if $out =~ "ERR"; 234 $out = ''; 235 236 $in = "mget *\n"; 237 $h->pump until $out =~ /^smb.*> \Z/m; 238 die "error retrieving files:\n$out" if $out =~ "ERR"; 239 240 $in = "quit\n"; 241 $h->finish; 242 243Notice that we carefully clear $out after the first command/response 244cycle? That's because IPC::Run does not delete $out when we continue, 245and we don't want to trip over the old output in the second 246command/response cycle. 247 248Say you want to accumulate all the output in $out and analyze it 249afterwards. Perl offers incremental regular expression matching using 250the C<m//gc> and pattern matching idiom and the C<\G> assertion. 251IPC::Run is careful not to disturb the current C<pos()> value for 252scalars it appends data to, so we could modify the above so as not to 253destroy $out by adding a couple of C</gc> modifiers. The C</g> keeps us 254from tripping over the previous prompt and the C</c> keeps us from 255resetting the prior match position if the expected prompt doesn't 256materialize immediately: 257 258 $h = harness \@smbclient, \$in, \$out; 259 260 $in = "cd /src\n"; 261 $h->pump until $out =~ /^smb.*> \Z/mgc; 262 die "error cding to /src:\n$out" if $out =~ "ERR"; 263 264 $in = "mget *\n"; 265 $h->pump until $out =~ /^smb.*> \Z/mgc; 266 die "error retrieving files:\n$out" if $out =~ "ERR"; 267 268 $in = "quit\n"; 269 $h->finish; 270 271 analyze( $out ); 272 273When using this technique, you may want to preallocate $out to have 274plenty of memory or you may find that the act of growing $out each time 275new input arrives causes an C<O(length($out)^2)> slowdown as $out grows. 276Say we expect no more than 10,000 characters of input at the most. To 277preallocate memory to $out, do something like: 278 279 my $out = "x" x 10_000; 280 $out = ""; 281 282C<perl> will allocate at least 10,000 characters' worth of space, then 283mark the $out as having 0 length without freeing all that yummy RAM. 284 285=head2 Timeouts and Timers 286 287More than likely, you don't want your subprocesses to run forever, and 288sometimes it's nice to know that they're going a little slowly. 289Timeouts throw exceptions after a some time has elapsed, timers merely 290cause pump() to return after some time has elapsed. Neither is 291reset/restarted automatically. 292 293Timeout objects are created by calling timeout( $interval ) and passing 294the result to run(), start() or harness(). The timeout period starts 295ticking just after all the child processes have been fork()ed or 296spawn()ed, and are polled for expiration in run(), pump() and finish(). 297If/when they expire, an exception is thrown. This is typically useful 298to keep a subprocess from taking too long. 299 300If a timeout occurs in run(), all child processes will be terminated and 301all file/pipe/ptty descriptors opened by run() will be closed. File 302descriptors opened by the parent process and passed in to run() are not 303closed in this event. 304 305If a timeout occurs in pump(), pump_nb(), or finish(), it's up to you to 306decide whether to kill_kill() all the children or to implement some more 307graceful fallback. No I/O will be closed in pump(), pump_nb() or 308finish() by such an exception (though I/O is often closed down in those 309routines during the natural course of events). 310 311Often an exception is too harsh. timer( $interval ) creates timer 312objects that merely prevent pump() from blocking forever. This can be 313useful for detecting stalled I/O or printing a soothing message or "." 314to pacify an anxious user. 315 316Timeouts and timers can both be restarted at any time using the timer's 317start() method (this is not the start() that launches subprocesses). To 318restart a timer, you need to keep a reference to the timer: 319 320 ## Start with a nice long timeout to let smbclient connect. If 321 ## pump or finish take too long, an exception will be thrown. 322 323 my $h; 324 eval { 325 $h = harness \@smbclient, \$in, \$out, \$err, ( my $t = timeout 30 ); 326 sleep 11; # No effect: timer not running yet 327 328 start $h; 329 $in = "cd /src\n"; 330 pump $h until ! length $in; 331 332 $in = "ls\n"; 333 ## Now use a short timeout, since this should be faster 334 $t->start( 5 ); 335 pump $h until ! length $in; 336 337 $t->start( 10 ); ## Give smbclient a little while to shut down. 338 $h->finish; 339 }; 340 if ( $@ ) { 341 my $x = $@; ## Preserve $@ in case another exception occurs 342 $h->kill_kill; ## kill it gently, then brutally if need be, or just 343 ## brutally on Win32. 344 die $x; 345 } 346 347Timeouts and timers are I<not> checked once the subprocesses are shut 348down; they will not expire in the interval between the last valid 349process and when IPC::Run scoops up the processes' result codes, for 350instance. 351 352=head2 Spawning synchronization, child exception propagation 353 354start() pauses the parent until the child executes the command or CODE 355reference and propagates any exceptions thrown (including exec() 356failure) back to the parent. This has several pleasant effects: any 357exceptions thrown in the child, including exec() failure, come flying 358out of start() or run() as though they had occurred in the parent. 359 360This includes exceptions your code thrown from init subs. In this 361example: 362 363 eval { 364 run \@cmd, init => sub { die "blast it! foiled again!" }; 365 }; 366 print $@; 367 368the exception "blast it! foiled again" will be thrown from the child 369process (preventing the exec()) and printed by the parent. 370 371In situations like 372 373 run \@cmd1, "|", \@cmd2, "|", \@cmd3; 374 375@cmd1 will be initted and exec()ed before @cmd2, and @cmd2 before @cmd3. 376This can save time and prevent oddball errors emitted by later commands 377when earlier commands fail to execute. Note that IPC::Run doesn't start 378any commands unless it can find the executables referenced by all 379commands. These executables must pass both the C<-f> and C<-x> tests 380described in L<perlfunc>. 381 382Another nice effect is that init() subs can take their time doing things 383and there will be no problems caused by a parent continuing to execute 384before a child's init() routine is complete. Say the init() routine 385needs to open a socket or a temp file that the parent wants to connect 386to; without this synchronization, the parent will need to implement a 387retry loop to wait for the child to run, since often, the parent gets a 388lot of things done before the child's first timeslice is allocated. 389 390This is also quite necessary for pseudo-tty initialization, which needs 391to take place before the parent writes to the child via pty. Writes 392that occur before the pty is set up can get lost. 393 394A final, minor, nicety is that debugging output from the child will be 395emitted before the parent continues on, making for much clearer debugging 396output in complex situations. 397 398The only drawback I can conceive of is that the parent can't continue to 399operate while the child is being initted. If this ever becomes a 400problem in the field, we can implement an option to avoid this behavior, 401but I don't expect it to. 402 403B<Win32>: executing CODE references isn't supported on Win32, see 404L</Win32 LIMITATIONS> for details. 405 406=head2 Syntax 407 408run(), start(), and harness() can all take a harness specification 409as input. A harness specification is either a single string to be passed 410to the systems' shell: 411 412 run "echo 'hi there'"; 413 414or a list of commands, io operations, and/or timers/timeouts to execute. 415Consecutive commands must be separated by a pipe operator '|' or an '&'. 416External commands are passed in as array references, and, on systems 417supporting fork(), Perl code may be passed in as subs: 418 419 run \@cmd; 420 run \@cmd1, '|', \@cmd2; 421 run \@cmd1, '&', \@cmd2; 422 run \&sub1; 423 run \&sub1, '|', \&sub2; 424 run \&sub1, '&', \&sub2; 425 426'|' pipes the stdout of \@cmd1 the stdin of \@cmd2, just like a 427shell pipe. '&' does not. Child processes to the right of a '&' 428will have their stdin closed unless it's redirected-to. 429 430L<IPC::Run::IO> objects may be passed in as well, whether or not 431child processes are also specified: 432 433 run io( "infile", ">", \$in ), io( "outfile", "<", \$in ); 434 435as can L<IPC::Run::Timer> objects: 436 437 run \@cmd, io( "outfile", "<", \$in ), timeout( 10 ); 438 439Commands may be followed by scalar, sub, or i/o handle references for 440redirecting 441child process input & output: 442 443 run \@cmd, \undef, \$out; 444 run \@cmd, \$in, \$out; 445 run \@cmd1, \&in, '|', \@cmd2, \*OUT; 446 run \@cmd1, \*IN, '|', \@cmd2, \&out; 447 448This is known as succinct redirection syntax, since run(), start() 449and harness(), figure out which file descriptor to redirect and how. 450File descriptor 0 is presumed to be an input for 451the child process, all others are outputs. The assumed file 452descriptor always starts at 0, unless the command is being piped to, 453in which case it starts at 1. 454 455To be explicit about your redirects, or if you need to do more complex 456things, there's also a redirection operator syntax: 457 458 run \@cmd, '<', \undef, '>', \$out; 459 run \@cmd, '<', \undef, '>&', \$out_and_err; 460 run( 461 \@cmd1, 462 '<', \$in, 463 '|', \@cmd2, 464 \$out 465 ); 466 467Operator syntax is required if you need to do something other than simple 468redirection to/from scalars or subs, like duping or closing file descriptors 469or redirecting to/from a named file. The operators are covered in detail 470below. 471 472After each \@cmd (or \&foo), parsing begins in succinct mode and toggles to 473operator syntax mode when an operator (ie plain scalar, not a ref) is seen. 474Once in 475operator syntax mode, parsing only reverts to succinct mode when a '|' or 476'&' is seen. 477 478In succinct mode, each parameter after the \@cmd specifies what to 479do with the next highest file descriptor. These File descriptor start 480with 0 (stdin) unless stdin is being piped to (C<'|', \@cmd>), in which 481case they start with 1 (stdout). Currently, being on the left of 482a pipe (C<\@cmd, \$out, \$err, '|'>) does I<not> cause stdout to be 483skipped, though this may change since it's not as DWIMerly as it 484could be. Only stdin is assumed to be an 485input in succinct mode, all others are assumed to be outputs. 486 487If no piping or redirection is specified for a child, it will inherit 488the parent's open file handles as dictated by your system's 489close-on-exec behavior and the $^F flag, except that processes after a 490'&' will not inherit the parent's stdin. Also note that $^F does not 491affect file descriptors obtained via POSIX, since it only applies to 492full-fledged Perl file handles. Such processes will have their stdin 493closed unless it has been redirected-to. 494 495If you want to close a child processes stdin, you may do any of: 496 497 run \@cmd, \undef; 498 run \@cmd, \""; 499 run \@cmd, '<&-'; 500 run \@cmd, '0<&-'; 501 502Redirection is done by placing redirection specifications immediately 503after a command or child subroutine: 504 505 run \@cmd1, \$in, '|', \@cmd2, \$out; 506 run \@cmd1, '<', \$in, '|', \@cmd2, '>', \$out; 507 508If you omit the redirection operators, descriptors are counted 509starting at 0. Descriptor 0 is assumed to be input, all others 510are outputs. A leading '|' consumes descriptor 0, so this 511works as expected. 512 513 run \@cmd1, \$in, '|', \@cmd2, \$out; 514 515The parameter following a redirection operator can be a scalar ref, 516a subroutine ref, a file name, an open filehandle, or a closed 517filehandle. 518 519If it's a scalar ref, the child reads input from or sends output to 520that variable: 521 522 $in = "Hello World.\n"; 523 run \@cat, \$in, \$out; 524 print $out; 525 526Scalars used in incremental (start()/pump()/finish()) applications are treated 527as queues: input is removed from input scalers, resulting in them dwindling 528to '', and output is appended to output scalars. This is not true of 529harnesses run() in batch mode. 530 531It's usually wise to append new input to be sent to the child to the input 532queue, and you'll often want to zap output queues to '' before pumping. 533 534 $h = start \@cat, \$in; 535 $in = "line 1\n"; 536 pump $h; 537 $in .= "line 2\n"; 538 pump $h; 539 $in .= "line 3\n"; 540 finish $h; 541 542The final call to finish() must be there: it allows the child process(es) 543to run to completion and waits for their exit values. 544 545=head1 OBSTINATE CHILDREN 546 547Interactive applications are usually optimized for human use. This 548can help or hinder trying to interact with them through modules like 549IPC::Run. Frequently, programs alter their behavior when they detect 550that stdin, stdout, or stderr are not connected to a tty, assuming that 551they are being run in batch mode. Whether this helps or hurts depends 552on which optimizations change. And there's often no way of telling 553what a program does in these areas other than trial and error and 554occasionally, reading the source. This includes different versions 555and implementations of the same program. 556 557All hope is not lost, however. Most programs behave in reasonably 558tractable manners, once you figure out what it's trying to do. 559 560Here are some of the issues you might need to be aware of. 561 562=over 563 564=item * 565 566fflush()ing stdout and stderr 567 568This lets the user see stdout and stderr immediately. Many programs 569undo this optimization if stdout is not a tty, making them harder to 570manage by things like IPC::Run. 571 572Many programs decline to fflush stdout or stderr if they do not 573detect a tty there. Some ftp commands do this, for instance. 574 575If this happens to you, look for a way to force interactive behavior, 576like a command line switch or command. If you can't, you will 577need to use a pseudo terminal ('<pty<' and '>pty>'). 578 579=item * 580 581false prompts 582 583Interactive programs generally do not guarantee that output from user 584commands won't contain a prompt string. For example, your shell prompt 585might be a '$', and a file named '$' might be the only file in a directory 586listing. 587 588This can make it hard to guarantee that your output parser won't be fooled 589into early termination of results. 590 591To help work around this, you can see if the program can alter it's 592prompt, and use something you feel is never going to occur in actual 593practice. 594 595You should also look for your prompt to be the only thing on a line: 596 597 pump $h until $out =~ /^<SILLYPROMPT>\s?\z/m; 598 599(use C<(?!\n)\Z> in place of C<\z> on older perls). 600 601You can also take the approach that IPC::ChildSafe takes and emit a 602command with known output after each 'real' command you issue, then 603look for this known output. See new_appender() and new_chunker() for 604filters that can help with this task. 605 606If it's not convenient or possibly to alter a prompt or use a known 607command/response pair, you might need to autodetect the prompt in case 608the local version of the child program is different then the one 609you tested with, or if the user has control over the look & feel of 610the prompt. 611 612=item * 613 614Refusing to accept input unless stdin is a tty. 615 616Some programs, for security reasons, will only accept certain types 617of input from a tty. su, notable, will not prompt for a password unless 618it's connected to a tty. 619 620If this is your situation, use a pseudo terminal ('<pty<' and '>pty>'). 621 622=item * 623 624Not prompting unless connected to a tty. 625 626Some programs don't prompt unless stdin or stdout is a tty. See if you can 627turn prompting back on. If not, see if you can come up with a command that 628you can issue after every real command and look for it's output, as 629IPC::ChildSafe does. There are two filters included with IPC::Run that 630can help with doing this: appender and chunker (see new_appender() and 631new_chunker()). 632 633=item * 634 635Different output format when not connected to a tty. 636 637Some commands alter their formats to ease machine parsability when they 638aren't connected to a pipe. This is actually good, but can be surprising. 639 640=back 641 642=head1 PSEUDO TERMINALS 643 644On systems providing pseudo terminals under /dev, IPC::Run can use IO::Pty 645(available on CPAN) to provide a terminal environment to subprocesses. 646This is necessary when the subprocess really wants to think it's connected 647to a real terminal. 648 649=head2 CAVEATS 650 651Pseudo-terminals are not pipes, though they are similar. Here are some 652differences to watch out for. 653 654=over 655 656=item Echoing 657 658Sending to stdin will cause an echo on stdout, which occurs before each 659line is passed to the child program. There is currently no way to 660disable this, although the child process can and should disable it for 661things like passwords. 662 663=item Shutdown 664 665IPC::Run cannot close a pty until all output has been collected. This 666means that it is not possible to send an EOF to stdin by half-closing 667the pty, as we can when using a pipe to stdin. 668 669This means that you need to send the child process an exit command or 670signal, or run() / finish() will time out. Be careful not to expect a 671prompt after sending the exit command. 672 673=item Command line editing 674 675Some subprocesses, notable shells that depend on the user's prompt 676settings, will reissue the prompt plus the command line input so far 677once for each character. 678 679=item '>pty>' means '&>pty>', not '1>pty>' 680 681The pseudo terminal redirects both stdout and stderr unless you specify 682a file descriptor. If you want to grab stderr separately, do this: 683 684 start \@cmd, '<pty<', \$in, '>pty>', \$out, '2>', \$err; 685 686=item stdin, stdout, and stderr not inherited 687 688Child processes harnessed to a pseudo terminal have their stdin, stdout, 689and stderr completely closed before any redirection operators take 690effect. This casts of the bonds of the controlling terminal. This is 691not done when using pipes. 692 693Right now, this affects all children in a harness that has a pty in use, 694even if that pty would not affect a particular child. That's a bug and 695will be fixed. Until it is, it's best not to mix-and-match children. 696 697=back 698 699=head2 Redirection Operators 700 701 Operator SHNP Description 702 ======== ==== =========== 703 <, N< SHN Redirects input to a child's fd N (0 assumed) 704 705 >, N> SHN Redirects output from a child's fd N (1 assumed) 706 >>, N>> SHN Like '>', but appends to scalars or named files 707 >&, &> SHN Redirects stdout & stderr from a child process 708 709 <pty, N<pty S Like '<', but uses a pseudo-tty instead of a pipe 710 >pty, N>pty S Like '>', but uses a pseudo-tty instead of a pipe 711 712 N<&M Dups input fd N to input fd M 713 M>&N Dups output fd N to input fd M 714 N<&- Closes fd N 715 716 <pipe, N<pipe P Pipe opens H for caller to read, write, close. 717 >pipe, N>pipe P Pipe opens H for caller to read, write, close. 718 719'N' and 'M' are placeholders for integer file descriptor numbers. The 720terms 'input' and 'output' are from the child process's perspective. 721 722The SHNP field indicates what parameters an operator can take: 723 724 S: \$scalar or \&function references. Filters may be used with 725 these operators (and only these). 726 H: \*HANDLE or IO::Handle for caller to open, and close 727 N: "file name". 728 P: \*HANDLE or lexical filehandle opened by IPC::Run as the parent end of a pipe, but read 729 and written to and closed by the caller (like IPC::Open3). 730 731=over 732 733=item Redirecting input: [n]<, [n]<pipe 734 735You can input the child reads on file descriptor number n to come from a 736scalar variable, subroutine, file handle, or a named file. If stdin 737is not redirected, the parent's stdin is inherited. 738 739 run \@cat, \undef ## Closes child's stdin immediately 740 or die "cat returned $?"; 741 742 run \@cat, \$in; 743 744 run \@cat, \<<TOHERE; 745 blah 746 TOHERE 747 748 run \@cat, \&input; ## Calls &input, feeding data returned 749 ## to child's. Closes child's stdin 750 ## when undef is returned. 751 752Redirecting from named files requires you to use the input 753redirection operator: 754 755 run \@cat, '<.profile'; 756 run \@cat, '<', '.profile'; 757 758 open IN, "<foo"; 759 run \@cat, \*IN; 760 run \@cat, *IN{IO}; 761 762The form used second example here is the safest, 763since filenames like "0" and "&more\n" won't confuse &run: 764 765You can't do either of 766 767 run \@a, *IN; ## INVALID 768 run \@a, '<', *IN; ## BUGGY: Reads file named like "*main::A" 769 770because perl passes a scalar containing a string that 771looks like "*main::A" to &run, and &run can't tell the difference 772between that and a redirection operator or a file name. &run guarantees 773that any scalar you pass after a redirection operator is a file name. 774 775If your child process will take input from file descriptors other 776than 0 (stdin), you can use a redirection operator with any of the 777valid input forms (scalar ref, sub ref, etc.): 778 779 run \@cat, '3<', \$in3; 780 781When redirecting input from a scalar ref, the scalar ref is 782used as a queue. This allows you to use &harness and pump() to 783feed incremental bits of input to a coprocess. See L</Coprocesses> 784below for more information. 785 786The <pipe operator opens the write half of a pipe on the filehandle 787glob reference it takes as an argument: 788 789 $h = start \@cat, '<pipe', \*IN; 790 print IN "hello world\n"; 791 pump $h; 792 close IN; 793 finish $h; 794 795Unlike the other '<' operators, IPC::Run does nothing further with 796it: you are responsible for it. The previous example is functionally 797equivalent to: 798 799 pipe( \*R, \*IN ) or die $!; 800 $h = start \@cat, '<', \*IN; 801 print IN "hello world\n"; 802 pump $h; 803 close IN; 804 finish $h; 805 806This is like the behavior of IPC::Open2 and IPC::Open3. 807 808B<Win32>: The handle returned is actually a socket handle, so you can 809use select() on it. 810 811=item Redirecting output: [n]>, [n]>>, [n]>&[m], [n]>pipe 812 813You can redirect any output the child emits 814to a scalar variable, subroutine, file handle, or file name. You 815can have &run truncate or append to named files or scalars. If 816you are redirecting stdin as well, or if the command is on the 817receiving end of a pipeline ('|'), you can omit the redirection 818operator: 819 820 @ls = ( 'ls' ); 821 run \@ls, \undef, \$out 822 or die "ls returned $?"; 823 824 run \@ls, \undef, \&out; ## Calls &out each time some output 825 ## is received from the child's 826 ## when undef is returned. 827 828 run \@ls, \undef, '2>ls.err'; 829 run \@ls, '2>', 'ls.err'; 830 831The two parameter form guarantees that the filename 832will not be interpreted as a redirection operator: 833 834 run \@ls, '>', "&more"; 835 run \@ls, '2>', ">foo\n"; 836 837You can pass file handles you've opened for writing: 838 839 open( *OUT, ">out.txt" ); 840 open( *ERR, ">err.txt" ); 841 run \@cat, \*OUT, \*ERR; 842 843Passing a scalar reference and a code reference requires a little 844more work, but allows you to capture all of the output in a scalar 845or each piece of output by a callback: 846 847These two do the same things: 848 849 run( [ 'ls' ], '2>', sub { $err_out .= $_[0] } ); 850 851does the same basic thing as: 852 853 run( [ 'ls' ], '2>', \$err_out ); 854 855The subroutine will be called each time some data is read from the child. 856 857The >pipe operator is different in concept than the other '>' operators, 858although it's syntax is similar: 859 860 $h = start \@cat, $in, '>pipe', \*OUT, '2>pipe', \*ERR; 861 $in = "hello world\n"; 862 finish $h; 863 print <OUT>; 864 print <ERR>; 865 close OUT; 866 close ERR; 867 868causes two pipe to be created, with one end attached to cat's stdout 869and stderr, respectively, and the other left open on OUT and ERR, so 870that the script can manually 871read(), select(), etc. on them. This is like 872the behavior of IPC::Open2 and IPC::Open3. 873 874B<Win32>: The handle returned is actually a socket handle, so you can 875use select() on it. 876 877=item Duplicating output descriptors: >&m, n>&m 878 879This duplicates output descriptor number n (default is 1 if n is omitted) 880from descriptor number m. 881 882=item Duplicating input descriptors: <&m, n<&m 883 884This duplicates input descriptor number n (default is 0 if n is omitted) 885from descriptor number m 886 887=item Closing descriptors: <&-, 3<&- 888 889This closes descriptor number n (default is 0 if n is omitted). The 890following commands are equivalent: 891 892 run \@cmd, \undef; 893 run \@cmd, '<&-'; 894 run \@cmd, '<in.txt', '<&-'; 895 896Doing 897 898 run \@cmd, \$in, '<&-'; ## SIGPIPE recipe. 899 900is dangerous: the parent will get a SIGPIPE if $in is not empty. 901 902=item Redirecting both stdout and stderr: &>, >&, &>pipe, >pipe& 903 904The following pairs of commands are equivalent: 905 906 run \@cmd, '>&', \$out; run \@cmd, '>', \$out, '2>&1'; 907 run \@cmd, '>&', 'out.txt'; run \@cmd, '>', 'out.txt', '2>&1'; 908 909etc. 910 911File descriptor numbers are not permitted to the left or the right of 912these operators, and the '&' may occur on either end of the operator. 913 914The '&>pipe' and '>pipe&' variants behave like the '>pipe' operator, except 915that both stdout and stderr write to the created pipe. 916 917=item Redirection Filters 918 919Both input redirections and output redirections that use scalars or 920subs as endpoints may have an arbitrary number of filter subs placed 921between them and the child process. This is useful if you want to 922receive output in chunks, or if you want to massage each chunk of 923data sent to the child. To use this feature, you must use operator 924syntax: 925 926 run( 927 \@cmd 928 '<', \&in_filter_2, \&in_filter_1, $in, 929 '>', \&out_filter_1, \&in_filter_2, $out, 930 ); 931 932This capability is not provided for IO handles or named files. 933 934Two filters are provided by IPC::Run: appender and chunker. Because 935these may take an argument, you need to use the constructor functions 936new_appender() and new_chunker() rather than using \& syntax: 937 938 run( 939 \@cmd 940 '<', new_appender( "\n" ), $in, 941 '>', new_chunker, $out, 942 ); 943 944=back 945 946=head2 Just doing I/O 947 948If you just want to do I/O to a handle or file you open yourself, you 949may specify a filehandle or filename instead of a command in the harness 950specification: 951 952 run io( "filename", '>', \$recv ); 953 954 $h = start io( $io, '>', \$recv ); 955 956 $h = harness \@cmd, '&', io( "file", '<', \$send ); 957 958=head2 Options 959 960Options are passed in as name/value pairs: 961 962 run \@cat, \$in, debug => 1; 963 964If you pass the debug option, you may want to pass it in first, so you 965can see what parsing is going on: 966 967 run debug => 1, \@cat, \$in; 968 969=over 970 971=item debug 972 973Enables debugging output in parent and child. Debugging info is emitted 974to the STDERR that was present when IPC::Run was first C<use()>ed (it's 975C<dup()>ed out of the way so that it can be redirected in children without 976having debugging output emitted on it). 977 978=back 979 980=head1 RETURN VALUES 981 982harness() and start() return a reference to an IPC::Run harness. This is 983blessed in to the IPC::Run package, so you may make later calls to 984functions as members if you like: 985 986 $h = harness( ... ); 987 $h->start; 988 $h->pump; 989 $h->finish; 990 991 $h = start( .... ); 992 $h->pump; 993 ... 994 995Of course, using method call syntax lets you deal with any IPC::Run 996subclasses that might crop up, but don't hold your breath waiting for 997any. 998 999run() and finish() return TRUE when all subcommands exit with a 0 result 1000code. B<This is the opposite of perl's system() command>. 1001 1002All routines raise exceptions (via die()) when error conditions are 1003recognized. A non-zero command result is not treated as an error 1004condition, since some commands are tests whose results are reported 1005in their exit codes. 1006 1007=head1 ROUTINES 1008 1009=over 1010 1011=cut 1012 1013use strict; 1014use Exporter (); 1015use vars qw{$VERSION @ISA @FILTER_IMP @FILTERS @API @EXPORT_OK %EXPORT_TAGS}; 1016 1017BEGIN { 1018 $VERSION = '20200505.0'; 1019 @ISA = qw{ Exporter }; 1020 1021 ## We use @EXPORT for the end user's convenience: there's only one function 1022 ## exported, it's homonymous with the module, it's an unusual name, and 1023 ## it can be suppressed by "use IPC::Run ();". 1024 @FILTER_IMP = qw( input_avail get_more_input ); 1025 @FILTERS = qw( 1026 new_appender 1027 new_chunker 1028 new_string_source 1029 new_string_sink 1030 ); 1031 @API = qw( 1032 run 1033 harness start pump pumpable finish 1034 signal kill_kill reap_nb 1035 io timer timeout 1036 close_terminal 1037 binary 1038 ); 1039 @EXPORT_OK = ( @API, @FILTER_IMP, @FILTERS, qw( Win32_MODE ) ); 1040 %EXPORT_TAGS = ( 1041 'filter_imp' => \@FILTER_IMP, 1042 'all' => \@EXPORT_OK, 1043 'filters' => \@FILTERS, 1044 'api' => \@API, 1045 ); 1046 1047} 1048 1049use strict; 1050use IPC::Run::Debug; 1051use Exporter; 1052use Fcntl; 1053use POSIX (); 1054 1055BEGIN { 1056 if ( $] < 5.008 ) { require Symbol; } 1057} 1058use Carp; 1059use File::Spec (); 1060use IO::Handle; 1061require IPC::Run::IO; 1062require IPC::Run::Timer; 1063 1064use constant Win32_MODE => $^O =~ /os2|Win32/i; 1065 1066BEGIN { 1067 if (Win32_MODE) { 1068 eval "use IPC::Run::Win32Helper; 1;" 1069 or ( $@ && die ) 1070 or die "$!"; 1071 } 1072 else { 1073 eval "use File::Basename; 1;" or die $!; 1074 } 1075} 1076 1077sub input_avail(); 1078sub get_more_input(); 1079 1080############################################################################### 1081 1082## 1083## Error constants, not too locale-dependent 1084use vars qw( $_EIO $_EAGAIN ); 1085use Errno qw( EIO EAGAIN ); 1086 1087BEGIN { 1088 local $!; 1089 $! = EIO; 1090 $_EIO = qr/^$!/; 1091 $! = EAGAIN; 1092 $_EAGAIN = qr/^$!/; 1093} 1094 1095## 1096## State machine states, set in $self->{STATE} 1097## 1098## These must be in ascending order numerically 1099## 1100sub _newed() { 0 } 1101sub _harnessed() { 1 } 1102sub _finished() { 2 } ## _finished behave almost exactly like _harnessed 1103sub _started() { 3 } 1104 1105## 1106## Which fds have been opened in the parent. This may have extra fds, since 1107## we aren't all that rigorous about closing these off, but that's ok. This 1108## is used on Unixish OSs to close all fds in the child that aren't needed 1109## by that particular child. 1110my %fds; 1111 1112## There's a bit of hackery going on here. 1113## 1114## We want to have any code anywhere be able to emit 1115## debugging statements without knowing what harness the code is 1116## being called in/from, since we'd need to pass a harness around to 1117## everything. 1118## 1119## Thus, $cur_self was born. 1120 1121use vars qw( $cur_self ); 1122 1123sub _debug_fd { 1124 return fileno STDERR unless defined $cur_self; 1125 1126 if ( _debugging && !defined $cur_self->{DEBUG_FD} ) { 1127 my $fd = select STDERR; 1128 $| = 1; 1129 select $fd; 1130 $cur_self->{DEBUG_FD} = POSIX::dup fileno STDERR; 1131 _debug("debugging fd is $cur_self->{DEBUG_FD}\n") 1132 if _debugging_details; 1133 } 1134 1135 return fileno STDERR unless defined $cur_self->{DEBUG_FD}; 1136 1137 return $cur_self->{DEBUG_FD}; 1138} 1139 1140sub DESTROY { 1141 ## We absolutely do not want to do anything else here. We are likely 1142 ## to be in a child process and we don't want to do things like kill_kill 1143 ## ourself or cause other destruction. 1144 my IPC::Run $self = shift; 1145 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD}; 1146 $self->{DEBUG_FD} = undef; 1147 1148 for my $kid ( @{$self->{KIDS}} ) { 1149 for my $op ( @{$kid->{OPS}} ) { 1150 delete $op->{FILTERS}; 1151 } 1152 } 1153} 1154 1155## 1156## Support routines (NOT METHODS) 1157## 1158my %cmd_cache; 1159 1160sub _search_path { 1161 my ($cmd_name) = @_; 1162 if ( File::Spec->file_name_is_absolute($cmd_name) && -x $cmd_name ) { 1163 _debug "'", $cmd_name, "' is absolute" 1164 if _debugging_details; 1165 return $cmd_name; 1166 } 1167 1168 my $dirsep = ( 1169 Win32_MODE ? '[/\\\\]' 1170 : $^O =~ /MacOS/ ? ':' 1171 : $^O =~ /VMS/ ? '[\[\]]' 1172 : '/' 1173 ); 1174 1175 if ( Win32_MODE 1176 && ( $cmd_name =~ /$dirsep/ ) 1177 && ( $cmd_name !~ m!\.[^\\/\.]+$! ) ) { 1178 1179 _debug "no extension(.exe), checking ENV{PATHEXT}" if _debugging; 1180 for ( split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE" ) { 1181 my $name = "$cmd_name$_"; 1182 $cmd_name = $name, last if -f $name && -x _; 1183 } 1184 _debug "cmd_name is now '$cmd_name'" if _debugging; 1185 } 1186 1187 if ( $cmd_name =~ /($dirsep)/ ) { 1188 _debug "'$cmd_name' contains '$1'" if _debugging; 1189 croak "file not found: $cmd_name" unless -e $cmd_name; 1190 croak "not a file: $cmd_name" unless -f $cmd_name; 1191 croak "permission denied: $cmd_name" unless -x $cmd_name; 1192 return $cmd_name; 1193 } 1194 1195 if ( exists $cmd_cache{$cmd_name} ) { 1196 _debug "'$cmd_name' found in cache: '$cmd_cache{$cmd_name}'" 1197 if _debugging; 1198 return $cmd_cache{$cmd_name} if -x $cmd_cache{$cmd_name}; 1199 _debug "'$cmd_cache{$cmd_name}' no longer executable, searching..." 1200 if _debugging; 1201 delete $cmd_cache{$cmd_name}; 1202 } 1203 1204 my @searched_in; 1205 1206 ## This next bit is Unix/Win32 specific, unfortunately. 1207 ## There's been some conversation about extending File::Spec to provide 1208 ## a universal interface to PATH, but I haven't seen it yet. 1209 my $re = Win32_MODE ? qr/;/ : qr/:/; 1210 1211 LOOP: 1212 for ( split( $re, $ENV{PATH} || '', -1 ) ) { 1213 $_ = "." unless length $_; 1214 push @searched_in, $_; 1215 1216 my $prospect = File::Spec->catfile( $_, $cmd_name ); 1217 my @prospects; 1218 1219 @prospects = 1220 ( Win32_MODE && !( -f $prospect && -x _ ) ) 1221 ? map "$prospect$_", split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE" 1222 : ($prospect); 1223 1224 for my $found (@prospects) { 1225 if ( -f $found && -x _ ) { 1226 $cmd_cache{$cmd_name} = $found; 1227 last LOOP; 1228 } 1229 } 1230 } 1231 1232 if ( exists $cmd_cache{$cmd_name} ) { 1233 _debug "'", $cmd_name, "' added to cache: '", $cmd_cache{$cmd_name}, "'" 1234 if _debugging_details; 1235 return $cmd_cache{$cmd_name}; 1236 } 1237 1238 croak "Command '$cmd_name' not found in " . join( ", ", @searched_in ); 1239} 1240 1241sub _empty($) { !( defined $_[0] && length $_[0] ) } 1242 1243## 'safe' versions of otherwise fun things to do. See also IPC::Run::Win32Helper. 1244sub _close { 1245 confess 'undef' unless defined $_[0]; 1246 my $fd = $_[0] =~ /^\d+$/ ? $_[0] : fileno $_[0]; 1247 my $r = POSIX::close $fd; 1248 $r = $r ? '' : " ERROR $!"; 1249 delete $fds{$fd}; 1250 _debug "close( $fd ) = " . ( $r || 0 ) if _debugging_details; 1251} 1252 1253sub _dup { 1254 confess 'undef' unless defined $_[0]; 1255 my $r = POSIX::dup( $_[0] ); 1256 croak "$!: dup( $_[0] )" unless defined $r; 1257 $r = 0 if $r eq '0 but true'; 1258 _debug "dup( $_[0] ) = $r" if _debugging_details; 1259 $fds{$r} = {}; 1260 return $r; 1261} 1262 1263sub _dup2_rudely { 1264 confess 'undef' unless defined $_[0] && defined $_[1]; 1265 my $r = POSIX::dup2( $_[0], $_[1] ); 1266 croak "$!: dup2( $_[0], $_[1] )" unless defined $r; 1267 $r = 0 if $r eq '0 but true'; 1268 _debug "dup2( $_[0], $_[1] ) = $r" if _debugging_details; 1269 $fds{$r} = {}; 1270 return $r; 1271} 1272 1273sub _exec { 1274 confess 'undef passed' if grep !defined, @_; 1275 1276 # exec @_ or croak "$!: exec( " . join( ', ', @_ ) . " )"; 1277 _debug 'exec()ing ', join " ", map "'$_'", @_ if _debugging_details; 1278 1279 # { 1280## Commented out since we don't call this on Win32. 1281 # # This works around the bug where 5.6.1 complains 1282 # # "Can't exec ...: No error" after an exec on NT, where 1283 # # exec() is simulated and actually returns in Perl's C 1284 # # code, though Perl's &exec does not... 1285 # no warnings "exec"; 1286 # 1287 # # Just in case the no warnings workaround 1288 # # stops being a workaround, we don't want 1289 # # old values of $! causing spurious strerr() 1290 # # messages to appear in the "Can't exec" message 1291 # undef $!; 1292 exec { $_[0] } @_; 1293 1294 # } 1295 # croak "$!: exec( " . join( ', ', map "'$_'", @_ ) . " )"; 1296 ## Fall through so $! can be reported to parent. 1297} 1298 1299sub _sysopen { 1300 confess 'undef' unless defined $_[0] && defined $_[1]; 1301 _debug sprintf( "O_RDONLY=0x%02x ", O_RDONLY ), 1302 sprintf( "O_WRONLY=0x%02x ", O_WRONLY ), 1303 sprintf( "O_RDWR=0x%02x ", O_RDWR ), 1304 sprintf( "O_TRUNC=0x%02x ", O_TRUNC ), 1305 sprintf( "O_CREAT=0x%02x ", O_CREAT ), 1306 sprintf( "O_APPEND=0x%02x ", O_APPEND ), 1307 if _debugging_details; 1308 my $r = POSIX::open( $_[0], $_[1], 0666 ); 1309 croak "$!: open( $_[0], ", sprintf( "0x%03x", $_[1] ), " )" unless defined $r; 1310 _debug "open( $_[0], ", sprintf( "0x%03x", $_[1] ), " ) = $r" 1311 if _debugging_data; 1312 $fds{$r} = {}; 1313 return $r; 1314} 1315 1316sub _pipe { 1317 ## Normal, blocking write for pipes that we read and the child writes, 1318 ## since most children expect writes to stdout to block rather than 1319 ## do a partial write. 1320 my ( $r, $w ) = POSIX::pipe; 1321 croak "$!: pipe()" unless defined $r; 1322 _debug "pipe() = ( $r, $w ) " if _debugging_details; 1323 @fds{$r, $w} = ( {}, {} ); 1324 return ( $r, $w ); 1325} 1326 1327sub _pipe_nb { 1328 ## For pipes that we write, unblock the write side, so we can fill a buffer 1329 ## and continue to select(). 1330 ## Contributed by Borislav Deianov <borislav@ensim.com>, with minor 1331 ## bugfix on fcntl result by me. 1332 local ( *R, *W ); 1333 my $f = pipe( R, W ); 1334 croak "$!: pipe()" unless defined $f; 1335 my ( $r, $w ) = ( fileno R, fileno W ); 1336 _debug "pipe_nb pipe() = ( $r, $w )" if _debugging_details; 1337 unless (Win32_MODE) { 1338 ## POSIX::fcntl doesn't take fd numbers, so gotta use Perl's and 1339 ## then _dup the originals (which get closed on leaving this block) 1340 my $fres = fcntl( W, &F_SETFL, O_WRONLY | O_NONBLOCK ); 1341 croak "$!: fcntl( $w, F_SETFL, O_NONBLOCK )" unless $fres; 1342 _debug "fcntl( $w, F_SETFL, O_NONBLOCK )" if _debugging_details; 1343 } 1344 ( $r, $w ) = ( _dup($r), _dup($w) ); 1345 _debug "pipe_nb() = ( $r, $w )" if _debugging_details; 1346 return ( $r, $w ); 1347} 1348 1349sub _pty { 1350 require IO::Pty; 1351 my $pty = IO::Pty->new(); 1352 croak "$!: pty ()" unless $pty; 1353 $pty->autoflush(); 1354 $pty->blocking(0) or croak "$!: pty->blocking ( 0 )"; 1355 _debug "pty() = ( ", $pty->fileno, ", ", $pty->slave->fileno, " )" 1356 if _debugging_details; 1357 @fds{ $pty->fileno, $pty->slave->fileno } = ( {}, {} ); 1358 return $pty; 1359} 1360 1361sub _read { 1362 confess 'undef' unless defined $_[0]; 1363 my $s = ''; 1364 my $r = POSIX::read( $_[0], $s, 10_000 ); 1365 croak "$!: read( $_[0] )" if not($r) and !$!{EINTR}; 1366 $r ||= 0; 1367 _debug "read( $_[0] ) = $r chars '$s'" if _debugging_data; 1368 return $s; 1369} 1370 1371## A METHOD, not a function. 1372sub _spawn { 1373 my IPC::Run $self = shift; 1374 my ($kid) = @_; 1375 1376 _debug "opening sync pipe ", $kid->{PID} if _debugging_details; 1377 my $sync_reader_fd; 1378 ( $sync_reader_fd, $self->{SYNC_WRITER_FD} ) = _pipe; 1379 $kid->{PID} = fork(); 1380 croak "$! during fork" unless defined $kid->{PID}; 1381 1382 unless ( $kid->{PID} ) { 1383 ## _do_kid_and_exit closes sync_reader_fd since it closes all unwanted and 1384 ## unloved fds. 1385 $self->_do_kid_and_exit($kid); 1386 } 1387 _debug "fork() = ", $kid->{PID} if _debugging_details; 1388 1389 ## Wait for kid to get to it's exec() and see if it fails. 1390 _close $self->{SYNC_WRITER_FD}; 1391 my $sync_pulse = _read $sync_reader_fd; 1392 _close $sync_reader_fd; 1393 1394 if ( !defined $sync_pulse || length $sync_pulse ) { 1395 if ( waitpid( $kid->{PID}, 0 ) >= 0 ) { 1396 $kid->{RESULT} = $?; 1397 } 1398 else { 1399 $kid->{RESULT} = -1; 1400 } 1401 $sync_pulse = "error reading synchronization pipe for $kid->{NUM}, pid $kid->{PID}" 1402 unless length $sync_pulse; 1403 croak $sync_pulse; 1404 } 1405 return $kid->{PID}; 1406 1407## Wait for pty to get set up. This is a hack until we get synchronous 1408## selects. 1409 if ( keys %{ $self->{PTYS} } && $IO::Pty::VERSION < 0.9 ) { 1410 _debug "sleeping to give pty a chance to init, will fix when newer IO::Pty arrives."; 1411 sleep 1; 1412 } 1413} 1414 1415sub _write { 1416 confess 'undef' unless defined $_[0] && defined $_[1]; 1417 my $r = POSIX::write( $_[0], $_[1], length $_[1] ); 1418 croak "$!: write( $_[0], '$_[1]' )" unless $r; 1419 _debug "write( $_[0], '$_[1]' ) = $r" if _debugging_data; 1420 return $r; 1421} 1422 1423=pod 1424 1425=over 1426 1427=item run 1428 1429Run takes a harness or harness specification and runs it, pumping 1430all input to the child(ren), closing the input pipes when no more 1431input is available, collecting all output that arrives, until the 1432pipes delivering output are closed, then waiting for the children to 1433exit and reaping their result codes. 1434 1435You may think of C<run( ... )> as being like 1436 1437 start( ... )->finish(); 1438 1439, though there is one subtle difference: run() does not 1440set \$input_scalars to '' like finish() does. If an exception is thrown 1441from run(), all children will be killed off "gently", and then "annihilated" 1442if they do not go gently (in to that dark night. sorry). 1443 1444If any exceptions are thrown, this does a L</kill_kill> before propagating 1445them. 1446 1447=cut 1448 1449use vars qw( $in_run ); ## No, not Enron;) 1450 1451sub run { 1452 local $in_run = 1; ## Allow run()-only optimizations. 1453 my IPC::Run $self = start(@_); 1454 my $r = eval { 1455 $self->{clear_ins} = 0; 1456 $self->finish; 1457 }; 1458 if ($@) { 1459 my $x = $@; 1460 $self->kill_kill; 1461 die $x; 1462 } 1463 return $r; 1464} 1465 1466=pod 1467 1468=item signal 1469 1470 ## To send it a specific signal by name ("USR1"): 1471 signal $h, "USR1"; 1472 $h->signal ( "USR1" ); 1473 1474If $signal is provided and defined, sends a signal to all child processes. Try 1475not to send numeric signals, use C<"KILL"> instead of C<9>, for instance. 1476Numeric signals aren't portable. 1477 1478Throws an exception if $signal is undef. 1479 1480This will I<not> clean up the harness, C<finish> it if you kill it. 1481 1482Normally TERM kills a process gracefully (this is what the command line utility 1483C<kill> does by default), INT is sent by one of the keys C<^C>, C<Backspace> or 1484C<E<lt>DelE<gt>>, and C<QUIT> is used to kill a process and make it coredump. 1485 1486The C<HUP> signal is often used to get a process to "restart", rereading 1487config files, and C<USR1> and C<USR2> for really application-specific things. 1488 1489Often, running C<kill -l> (that's a lower case "L") on the command line will 1490list the signals present on your operating system. 1491 1492B<WARNING>: The signal subsystem is not at all portable. We *may* offer 1493to simulate C<TERM> and C<KILL> on some operating systems, submit code 1494to me if you want this. 1495 1496B<WARNING 2>: Up to and including perl v5.6.1, doing almost anything in a 1497signal handler could be dangerous. The most safe code avoids all 1498mallocs and system calls, usually by preallocating a flag before 1499entering the signal handler, altering the flag's value in the 1500handler, and responding to the changed value in the main system: 1501 1502 my $got_usr1 = 0; 1503 sub usr1_handler { ++$got_signal } 1504 1505 $SIG{USR1} = \&usr1_handler; 1506 while () { sleep 1; print "GOT IT" while $got_usr1--; } 1507 1508Even this approach is perilous if ++ and -- aren't atomic on your system 1509(I've never heard of this on any modern CPU large enough to run perl). 1510 1511=cut 1512 1513sub signal { 1514 my IPC::Run $self = shift; 1515 1516 local $cur_self = $self; 1517 1518 $self->_kill_kill_kill_pussycat_kill unless @_; 1519 1520 Carp::cluck "Ignoring extra parameters passed to kill()" if @_ > 1; 1521 1522 my ($signal) = @_; 1523 croak "Undefined signal passed to signal" unless defined $signal; 1524 for ( grep $_->{PID} && !defined $_->{RESULT}, @{ $self->{KIDS} } ) { 1525 _debug "sending $signal to $_->{PID}" 1526 if _debugging; 1527 kill $signal, $_->{PID} 1528 or _debugging && _debug "$! sending $signal to $_->{PID}"; 1529 } 1530 1531 return; 1532} 1533 1534=pod 1535 1536=item kill_kill 1537 1538 ## To kill off a process: 1539 $h->kill_kill; 1540 kill_kill $h; 1541 1542 ## To specify the grace period other than 30 seconds: 1543 kill_kill $h, grace => 5; 1544 1545 ## To send QUIT instead of KILL if a process refuses to die: 1546 kill_kill $h, coup_d_grace => "QUIT"; 1547 1548Sends a C<TERM>, waits for all children to exit for up to 30 seconds, then 1549sends a C<KILL> to any that survived the C<TERM>. 1550 1551Will wait for up to 30 more seconds for the OS to successfully C<KILL> the 1552processes. 1553 1554The 30 seconds may be overridden by setting the C<grace> option, this 1555overrides both timers. 1556 1557The harness is then cleaned up. 1558 1559The doubled name indicates that this function may kill again and avoids 1560colliding with the core Perl C<kill> function. 1561 1562Returns a 1 if the C<TERM> was sufficient, or a 0 if C<KILL> was 1563required. Throws an exception if C<KILL> did not permit the children 1564to be reaped. 1565 1566B<NOTE>: The grace period is actually up to 1 second longer than that 1567given. This is because the granularity of C<time> is 1 second. Let me 1568know if you need finer granularity, we can leverage Time::HiRes here. 1569 1570B<Win32>: Win32 does not know how to send real signals, so C<TERM> is 1571a full-force kill on Win32. Thus all talk of grace periods, etc. do 1572not apply to Win32. 1573 1574=cut 1575 1576sub kill_kill { 1577 my IPC::Run $self = shift; 1578 1579 my %options = @_; 1580 my $grace = $options{grace}; 1581 $grace = 30 unless defined $grace; 1582 ++$grace; ## Make grace time a _minimum_ 1583 1584 my $coup_d_grace = $options{coup_d_grace}; 1585 $coup_d_grace = "KILL" unless defined $coup_d_grace; 1586 1587 delete $options{$_} for qw( grace coup_d_grace ); 1588 Carp::cluck "Ignoring unknown options for kill_kill: ", 1589 join " ", keys %options 1590 if keys %options; 1591 1592 if (Win32_MODE) { 1593 # immediate brutal death for Win32 1594 # TERM has unfortunate side-effects 1595 $self->signal("KILL") 1596 } 1597 else { 1598 $self->signal("TERM"); 1599 } 1600 1601 my $quitting_time = time + $grace; 1602 my $delay = 0.01; 1603 my $accum_delay; 1604 1605 my $have_killed_before; 1606 1607 while () { 1608 ## delay first to yield to other processes 1609 select undef, undef, undef, $delay; 1610 $accum_delay += $delay; 1611 1612 $self->reap_nb; 1613 last unless $self->_running_kids; 1614 1615 if ( $accum_delay >= $grace * 0.8 ) { 1616 ## No point in checking until delay has grown some. 1617 if ( time >= $quitting_time ) { 1618 if ( !$have_killed_before ) { 1619 $self->signal($coup_d_grace); 1620 $have_killed_before = 1; 1621 $quitting_time += $grace; 1622 $delay = 0.01; 1623 $accum_delay = 0; 1624 next; 1625 } 1626 croak "Unable to reap all children, even after KILLing them"; 1627 } 1628 } 1629 1630 $delay *= 2; 1631 $delay = 0.5 if $delay >= 0.5; 1632 } 1633 1634 $self->_cleanup; 1635 return $have_killed_before; 1636} 1637 1638=pod 1639 1640=item harness 1641 1642Takes a harness specification and returns a harness. This harness is 1643blessed in to IPC::Run, allowing you to use method call syntax for 1644run(), start(), et al if you like. 1645 1646harness() is provided so that you can pre-build harnesses if you 1647would like to, but it's not required.. 1648 1649You may proceed to run(), start() or pump() after calling harness() (pump() 1650calls start() if need be). Alternatively, you may pass your 1651harness specification to run() or start() and let them harness() for 1652you. You can't pass harness specifications to pump(), though. 1653 1654=cut 1655 1656## 1657## Notes: I've avoided handling a scalar that doesn't look like an 1658## opcode as a here document or as a filename, though I could DWIM 1659## those. I'm not sure that the advantages outweigh the danger when 1660## the DWIMer guesses wrong. 1661## 1662## TODO: allow user to spec default shell. Hmm, globally, in the 1663## lexical scope hash, or per instance? 'Course they can do that 1664## now by using a [...] to hold the command. 1665## 1666my $harness_id = 0; 1667 1668sub harness { 1669 my $options; 1670 if ( @_ && ref $_[-1] eq 'HASH' ) { 1671 $options = pop; 1672 require Data::Dumper; 1673 carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper($options); 1674 } 1675 1676 # local $IPC::Run::debug = $options->{debug} 1677 # if $options && defined $options->{debug}; 1678 1679 my @args; 1680 if ( @_ == 1 && !ref $_[0] ) { 1681 if (Win32_MODE) { 1682 my $command = $ENV{ComSpec} || 'cmd'; 1683 @args = ( [ $command, '/c', win32_parse_cmd_line $_[0] ] ); 1684 } 1685 else { 1686 @args = ( [ qw( sh -c ), @_ ] ); 1687 } 1688 } 1689 elsif ( @_ > 1 && !grep ref $_, @_ ) { 1690 @args = ( [@_] ); 1691 } 1692 else { 1693 @args = map { !defined $_ ? bless(\$_, 'IPC::Run::Undef') : $_ } @_; 1694 } 1695 1696 my @errs; # Accum errors, emit them when done. 1697 1698 my $succinct; # set if no redir ops are required yet. Cleared 1699 # if an op is seen. 1700 1701 my $cur_kid; # references kid or handle being parsed 1702 my $next_kid_close_stdin = 0; 1703 1704 my $assumed_fd = 0; # fd to assume in succinct mode (no redir ops) 1705 my $handle_num = 0; # 1... is which handle we're parsing 1706 1707 my IPC::Run $self = bless {}, __PACKAGE__; 1708 1709 local $cur_self = $self; 1710 1711 $self->{ID} = ++$harness_id; 1712 $self->{IOS} = []; 1713 $self->{KIDS} = []; 1714 $self->{PIPES} = []; 1715 $self->{PTYS} = {}; 1716 $self->{STATE} = _newed; 1717 1718 if ($options) { 1719 $self->{$_} = $options->{$_} for keys %$options; 1720 } 1721 1722 _debug "****** harnessing *****" if _debugging; 1723 1724 my $first_parse; 1725 local $_; 1726 my $arg_count = @args; 1727 while (@args) { 1728 for ( shift @args ) { 1729 eval { 1730 $first_parse = 1; 1731 _debug( 1732 "parsing ", 1733 defined $_ 1734 ? ref $_ eq 'ARRAY' 1735 ? ( '[ ', join( ', ', map "'$_'", @$_ ), ' ]' ) 1736 : ( 1737 ref $_ 1738 || ( 1739 length $_ < 50 1740 ? "'$_'" 1741 : join( '', "'", substr( $_, 0, 10 ), "...'" ) 1742 ) 1743 ) 1744 : '<undef>' 1745 ) if _debugging; 1746 1747 REPARSE: 1748 if ( ref eq 'ARRAY' || ( !$cur_kid && ref eq 'CODE' ) ) { 1749 croak "Process control symbol ('|', '&') missing" if $cur_kid; 1750 croak "Can't spawn a subroutine on Win32" 1751 if Win32_MODE && ref eq "CODE"; 1752 $cur_kid = { 1753 TYPE => 'cmd', 1754 VAL => $_, 1755 NUM => @{ $self->{KIDS} } + 1, 1756 OPS => [], 1757 PID => '', 1758 RESULT => undef, 1759 }; 1760 1761 unshift @{ $cur_kid->{OPS} }, { 1762 TYPE => 'close', 1763 KFD => 0, 1764 } if $next_kid_close_stdin; 1765 $next_kid_close_stdin = 0; 1766 1767 push @{ $self->{KIDS} }, $cur_kid; 1768 $succinct = 1; 1769 } 1770 1771 elsif ( UNIVERSAL::isa( $_, 'IPC::Run::IO' ) ) { 1772 push @{ $self->{IOS} }, $_; 1773 $cur_kid = undef; 1774 $succinct = 1; 1775 } 1776 1777 elsif ( UNIVERSAL::isa( $_, 'IPC::Run::Timer' ) ) { 1778 push @{ $self->{TIMERS} }, $_; 1779 $cur_kid = undef; 1780 $succinct = 1; 1781 } 1782 1783 elsif (/^(\d*)>&(\d+)$/) { 1784 croak "No command before '$_'" unless $cur_kid; 1785 push @{ $cur_kid->{OPS} }, { 1786 TYPE => 'dup', 1787 KFD1 => $2, 1788 KFD2 => length $1 ? $1 : 1, 1789 }; 1790 _debug "redirect operators now required" if _debugging_details; 1791 $succinct = !$first_parse; 1792 } 1793 1794 elsif (/^(\d*)<&(\d+)$/) { 1795 croak "No command before '$_'" unless $cur_kid; 1796 push @{ $cur_kid->{OPS} }, { 1797 TYPE => 'dup', 1798 KFD1 => $2, 1799 KFD2 => length $1 ? $1 : 0, 1800 }; 1801 $succinct = !$first_parse; 1802 } 1803 1804 elsif (/^(\d*)<&-$/) { 1805 croak "No command before '$_'" unless $cur_kid; 1806 push @{ $cur_kid->{OPS} }, { 1807 TYPE => 'close', 1808 KFD => length $1 ? $1 : 0, 1809 }; 1810 $succinct = !$first_parse; 1811 } 1812 1813 elsif (/^(\d*) (<pipe)() () () $/x 1814 || /^(\d*) (<pty) ((?:\s+\S+)?) (<) () $/x 1815 || /^(\d*) (<) () () (.*)$/x ) { 1816 croak "No command before '$_'" unless $cur_kid; 1817 1818 $succinct = !$first_parse; 1819 1820 my $type = $2 . $4; 1821 1822 my $kfd = length $1 ? $1 : 0; 1823 1824 my $pty_id; 1825 if ( $type eq '<pty<' ) { 1826 $pty_id = length $3 ? $3 : '0'; 1827 ## do the require here to cause early error reporting 1828 require IO::Pty; 1829 ## Just flag the pyt's existence for now. It'll be 1830 ## converted to a real IO::Pty by _open_pipes. 1831 $self->{PTYS}->{$pty_id} = undef; 1832 } 1833 1834 my $source = $5; 1835 1836 my @filters; 1837 my $binmode; 1838 1839 unless ( length $source ) { 1840 if ( !$succinct ) { 1841 while ( @args > 1 1842 && ( ( ref $args[1] && !UNIVERSAL::isa $args[1], "IPC::Run::Timer" ) || UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) ) { 1843 if ( UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) { 1844 $binmode = shift(@args)->(); 1845 } 1846 else { 1847 push @filters, shift @args; 1848 } 1849 } 1850 } 1851 $source = shift @args; 1852 croak "'$_' missing a source" if _empty $source; 1853 1854 _debug( 1855 'Kid ', $cur_kid->{NUM}, "'s input fd ", $kfd, 1856 ' has ', scalar(@filters), ' filters.' 1857 ) if _debugging_details && @filters; 1858 } 1859 1860 my IPC::Run::IO $pipe = IPC::Run::IO->_new_internal( $type, $kfd, $pty_id, $source, $binmode, @filters ); 1861 1862 if ( ( ref $source eq 'GLOB' || UNIVERSAL::isa $source, 'IO::Handle' ) 1863 && $type !~ /^<p(ty<|ipe)$/ ) { 1864 _debug "setting DONT_CLOSE" if _debugging_details; 1865 $pipe->{DONT_CLOSE} = 1; ## this FD is not closed by us. 1866 _dont_inherit($source) if Win32_MODE; 1867 } 1868 1869 push @{ $cur_kid->{OPS} }, $pipe; 1870 } 1871 1872 elsif ( 1873 /^() (>>?) (&) () (.*)$/x 1874 || /^() (&) (>pipe) () () $/x 1875 || /^() (>pipe)(&) () () $/x 1876 || /^(\d*)() (>pipe) () () $/x 1877 || /^() (&) (>pty) ( \w*)> () $/x 1878## TODO: || /^() (>pty) (\d*)> (&) () $/x 1879 || /^(\d*)() (>pty) ( \w*)> () $/x 1880 || /^() (&) (>>?) () (.*)$/x || /^(\d*)() (>>?) () (.*)$/x 1881 ) { 1882 croak "No command before '$_'" unless $cur_kid; 1883 1884 $succinct = !$first_parse; 1885 1886 my $type = ( 1887 $2 eq '>pipe' || $3 eq '>pipe' ? '>pipe' 1888 : $2 eq '>pty' || $3 eq '>pty' ? '>pty>' 1889 : '>' 1890 ); 1891 my $kfd = length $1 ? $1 : 1; 1892 my $trunc = !( $2 eq '>>' || $3 eq '>>' ); 1893 my $pty_id = ( 1894 $2 eq '>pty' || $3 eq '>pty' 1895 ? length $4 1896 ? $4 1897 : 0 1898 : undef 1899 ); 1900 1901 my $stderr_too = 1902 $2 eq '&' 1903 || $3 eq '&' 1904 || ( !length $1 && substr( $type, 0, 4 ) eq '>pty' ); 1905 1906 my $dest = $5; 1907 my @filters; 1908 my $binmode = 0; 1909 unless ( length $dest ) { 1910 if ( !$succinct ) { 1911 ## unshift...shift: '>' filters source...sink left...right 1912 while ( @args > 1 1913 && ( ( ref $args[1] && !UNIVERSAL::isa $args[1], "IPC::Run::Timer" ) || UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) ) { 1914 if ( UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) { 1915 $binmode = shift(@args)->(); 1916 } 1917 else { 1918 unshift @filters, shift @args; 1919 } 1920 } 1921 } 1922 1923 if ( @args && ref $args[0] eq 'IPC::Run::Undef' ) { 1924 require Symbol; 1925 ${ $args[0] } = $dest = Symbol::gensym(); 1926 shift @args; 1927 } 1928 else { 1929 $dest = shift @args; 1930 } 1931 1932 _debug( 1933 'Kid ', $cur_kid->{NUM}, "'s output fd ", $kfd, 1934 ' has ', scalar(@filters), ' filters.' 1935 ) if _debugging_details && @filters; 1936 1937 if ( $type eq '>pty>' ) { 1938 ## do the require here to cause early error reporting 1939 require IO::Pty; 1940 ## Just flag the pyt's existence for now. _open_pipes() 1941 ## will new an IO::Pty for each key. 1942 $self->{PTYS}->{$pty_id} = undef; 1943 } 1944 } 1945 1946 croak "'$_' missing a destination" if _empty $dest; 1947 my $pipe = IPC::Run::IO->_new_internal( $type, $kfd, $pty_id, $dest, $binmode, @filters ); 1948 $pipe->{TRUNC} = $trunc; 1949 1950 if ( ( UNIVERSAL::isa( $dest, 'GLOB' ) || UNIVERSAL::isa( $dest, 'IO::Handle' ) ) 1951 && $type !~ /^>(pty>|pipe)$/ ) { 1952 _debug "setting DONT_CLOSE" if _debugging_details; 1953 $pipe->{DONT_CLOSE} = 1; ## this FD is not closed by us. 1954 } 1955 push @{ $cur_kid->{OPS} }, $pipe; 1956 push @{ $cur_kid->{OPS} }, { 1957 TYPE => 'dup', 1958 KFD1 => 1, 1959 KFD2 => 2, 1960 } if $stderr_too; 1961 } 1962 1963 elsif ( $_ eq "|" ) { 1964 croak "No command before '$_'" unless $cur_kid; 1965 unshift @{ $cur_kid->{OPS} }, { 1966 TYPE => '|', 1967 KFD => 1, 1968 }; 1969 $succinct = 1; 1970 $assumed_fd = 1; 1971 $cur_kid = undef; 1972 } 1973 1974 elsif ( $_ eq "&" ) { 1975 croak "No command before '$_'" unless $cur_kid; 1976 $next_kid_close_stdin = 1; 1977 $succinct = 1; 1978 $assumed_fd = 0; 1979 $cur_kid = undef; 1980 } 1981 1982 elsif ( $_ eq 'init' ) { 1983 croak "No command before '$_'" unless $cur_kid; 1984 push @{ $cur_kid->{OPS} }, { 1985 TYPE => 'init', 1986 SUB => shift @args, 1987 }; 1988 } 1989 1990 elsif ( !ref $_ ) { 1991 $self->{$_} = shift @args; 1992 } 1993 1994 elsif ( $_ eq 'init' ) { 1995 croak "No command before '$_'" unless $cur_kid; 1996 push @{ $cur_kid->{OPS} }, { 1997 TYPE => 'init', 1998 SUB => shift @args, 1999 }; 2000 } 2001 2002 elsif ( $succinct && $first_parse ) { 2003 ## It's not an opcode, and no explicit opcodes have been 2004 ## seen yet, so assume it's a file name. 2005 unshift @args, $_; 2006 if ( !$assumed_fd ) { 2007 $_ = "$assumed_fd<", 2008 } 2009 else { 2010 $_ = "$assumed_fd>", 2011 } 2012 _debug "assuming '", $_, "'" if _debugging_details; 2013 ++$assumed_fd; 2014 $first_parse = 0; 2015 goto REPARSE; 2016 } 2017 2018 else { 2019 croak join( 2020 '', 2021 'Unexpected ', 2022 ( ref() ? $_ : 'scalar' ), 2023 ' in harness() parameter ', 2024 $arg_count - @args 2025 ); 2026 } 2027 }; 2028 if ($@) { 2029 push @errs, $@; 2030 _debug 'caught ', $@ if _debugging; 2031 } 2032 } 2033 } 2034 2035 die join( '', @errs ) if @errs; 2036 2037 $self->{STATE} = _harnessed; 2038 2039 # $self->timeout( $options->{timeout} ) if exists $options->{timeout}; 2040 return $self; 2041} 2042 2043sub _open_pipes { 2044 my IPC::Run $self = shift; 2045 2046 my @errs; 2047 2048 my @close_on_fail; 2049 2050 ## When a pipe character is seen, a pipe is created. $pipe_read_fd holds 2051 ## the dangling read end of the pipe until we get to the next process. 2052 my $pipe_read_fd; 2053 2054 ## Output descriptors for the last command are shared by all children. 2055 ## @output_fds_accum accumulates the current set of output fds. 2056 my @output_fds_accum; 2057 2058 for ( sort keys %{ $self->{PTYS} } ) { 2059 _debug "opening pty '", $_, "'" if _debugging_details; 2060 my $pty = _pty; 2061 $self->{PTYS}->{$_} = $pty; 2062 } 2063 2064 for ( @{ $self->{IOS} } ) { 2065 eval { $_->init; }; 2066 if ($@) { 2067 push @errs, $@; 2068 _debug 'caught ', $@ if _debugging; 2069 } 2070 else { 2071 push @close_on_fail, $_; 2072 } 2073 } 2074 2075 ## Loop through the kids and their OPS, interpreting any that require 2076 ## parent-side actions. 2077 for my $kid ( @{ $self->{KIDS} } ) { 2078 unless ( ref $kid->{VAL} eq 'CODE' ) { 2079 $kid->{PATH} = _search_path $kid->{VAL}->[0]; 2080 } 2081 if ( defined $pipe_read_fd ) { 2082 _debug "placing write end of pipe on kid $kid->{NUM}'s stdin" 2083 if _debugging_details; 2084 unshift @{ $kid->{OPS} }, { 2085 TYPE => 'PIPE', ## Prevent next loop from triggering on this 2086 KFD => 0, 2087 TFD => $pipe_read_fd, 2088 }; 2089 $pipe_read_fd = undef; 2090 } 2091 @output_fds_accum = (); 2092 for my $op ( @{ $kid->{OPS} } ) { 2093 2094 # next if $op->{IS_DEBUG}; 2095 my $ok = eval { 2096 if ( $op->{TYPE} eq '<' ) { 2097 my $source = $op->{SOURCE}; 2098 if ( !ref $source ) { 2099 _debug( 2100 "kid ", $kid->{NUM}, " to read ", $op->{KFD}, 2101 " from '" . $source, "' (read only)" 2102 ) if _debugging_details; 2103 croak "simulated open failure" 2104 if $self->{_simulate_open_failure}; 2105 $op->{TFD} = _sysopen( $source, O_RDONLY ); 2106 push @close_on_fail, $op->{TFD}; 2107 } 2108 elsif (UNIVERSAL::isa( $source, 'GLOB' ) 2109 || UNIVERSAL::isa( $source, 'IO::Handle' ) ) { 2110 croak "Unopened filehandle in input redirect for $op->{KFD}" 2111 unless defined fileno $source; 2112 $op->{TFD} = fileno $source; 2113 _debug( 2114 "kid ", $kid->{NUM}, " to read ", $op->{KFD}, 2115 " from fd ", $op->{TFD} 2116 ) if _debugging_details; 2117 } 2118 elsif ( UNIVERSAL::isa( $source, 'SCALAR' ) ) { 2119 _debug( 2120 "kid ", $kid->{NUM}, " to read ", $op->{KFD}, 2121 " from SCALAR" 2122 ) if _debugging_details; 2123 2124 $op->open_pipe( $self->_debug_fd ); 2125 push @close_on_fail, $op->{KFD}, $op->{FD}; 2126 2127 my $s = ''; 2128 $op->{KIN_REF} = \$s; 2129 } 2130 elsif ( UNIVERSAL::isa( $source, 'CODE' ) ) { 2131 _debug( 'kid ', $kid->{NUM}, ' to read ', $op->{KFD}, ' from CODE' ) if _debugging_details; 2132 2133 $op->open_pipe( $self->_debug_fd ); 2134 push @close_on_fail, $op->{KFD}, $op->{FD}; 2135 2136 my $s = ''; 2137 $op->{KIN_REF} = \$s; 2138 } 2139 else { 2140 croak( "'" . ref($source) . "' not allowed as a source for input redirection" ); 2141 } 2142 $op->_init_filters; 2143 } 2144 elsif ( $op->{TYPE} eq '<pipe' ) { 2145 _debug( 2146 'kid to read ', $op->{KFD}, 2147 ' from a pipe IPC::Run opens and returns', 2148 ) if _debugging_details; 2149 2150 my ( $r, $w ) = $op->open_pipe( $self->_debug_fd, $op->{SOURCE} ); 2151 _debug "caller will write to ", fileno $op->{SOURCE} 2152 if _debugging_details; 2153 2154 $op->{TFD} = $r; 2155 $op->{FD} = undef; # we don't manage this fd 2156 $op->_init_filters; 2157 } 2158 elsif ( $op->{TYPE} eq '<pty<' ) { 2159 _debug( 2160 'kid to read ', $op->{KFD}, " from pty '", $op->{PTY_ID}, "'", 2161 ) if _debugging_details; 2162 2163 for my $source ( $op->{SOURCE} ) { 2164 if ( UNIVERSAL::isa( $source, 'SCALAR' ) ) { 2165 _debug( 2166 "kid ", $kid->{NUM}, " to read ", $op->{KFD}, 2167 " from SCALAR via pty '", $op->{PTY_ID}, "'" 2168 ) if _debugging_details; 2169 2170 my $s = ''; 2171 $op->{KIN_REF} = \$s; 2172 } 2173 elsif ( UNIVERSAL::isa( $source, 'CODE' ) ) { 2174 _debug( 2175 "kid ", $kid->{NUM}, " to read ", $op->{KFD}, 2176 " from CODE via pty '", $op->{PTY_ID}, "'" 2177 ) if _debugging_details; 2178 my $s = ''; 2179 $op->{KIN_REF} = \$s; 2180 } 2181 else { 2182 croak( "'" . ref($source) . "' not allowed as a source for '<pty<' redirection" ); 2183 } 2184 } 2185 $op->{FD} = $self->{PTYS}->{ $op->{PTY_ID} }->fileno; 2186 $op->{TFD} = undef; # The fd isn't known until after fork(). 2187 $op->_init_filters; 2188 } 2189 elsif ( $op->{TYPE} eq '>' ) { 2190 ## N> output redirection. 2191 my $dest = $op->{DEST}; 2192 if ( !ref $dest ) { 2193 _debug( 2194 "kid ", $kid->{NUM}, " to write ", $op->{KFD}, 2195 " to '", $dest, "' (write only, create, ", 2196 ( $op->{TRUNC} ? 'truncate' : 'append' ), 2197 ")" 2198 ) if _debugging_details; 2199 croak "simulated open failure" 2200 if $self->{_simulate_open_failure}; 2201 $op->{TFD} = _sysopen( 2202 $dest, 2203 ( O_WRONLY | O_CREAT | ( $op->{TRUNC} ? O_TRUNC : O_APPEND ) ) 2204 ); 2205 if (Win32_MODE) { 2206 ## I have no idea why this is needed to make the current 2207 ## file position survive the gyrations TFD must go 2208 ## through... 2209 POSIX::lseek( $op->{TFD}, 0, POSIX::SEEK_END() ); 2210 } 2211 push @close_on_fail, $op->{TFD}; 2212 } 2213 elsif ( UNIVERSAL::isa( $dest, 'GLOB' ) ) { 2214 croak("Unopened filehandle in output redirect, command $kid->{NUM}") unless defined fileno $dest; 2215 ## Turn on autoflush, mostly just to flush out 2216 ## existing output. 2217 my $old_fh = select($dest); 2218 $| = 1; 2219 select($old_fh); 2220 $op->{TFD} = fileno $dest; 2221 _debug( 'kid to write ', $op->{KFD}, ' to handle ', $op->{TFD} ) if _debugging_details; 2222 } 2223 elsif ( UNIVERSAL::isa( $dest, 'SCALAR' ) ) { 2224 _debug( "kid ", $kid->{NUM}, " to write $op->{KFD} to SCALAR" ) if _debugging_details; 2225 2226 $op->open_pipe( $self->_debug_fd ); 2227 push @close_on_fail, $op->{FD}, $op->{TFD}; 2228 $$dest = '' if $op->{TRUNC}; 2229 } 2230 elsif ( UNIVERSAL::isa( $dest, 'CODE' ) ) { 2231 _debug("kid $kid->{NUM} to write $op->{KFD} to CODE") if _debugging_details; 2232 2233 $op->open_pipe( $self->_debug_fd ); 2234 push @close_on_fail, $op->{FD}, $op->{TFD}; 2235 } 2236 else { 2237 croak( "'" . ref($dest) . "' not allowed as a sink for output redirection" ); 2238 } 2239 $output_fds_accum[ $op->{KFD} ] = $op; 2240 $op->_init_filters; 2241 } 2242 2243 elsif ( $op->{TYPE} eq '>pipe' ) { 2244 ## N> output redirection to a pipe we open, but don't select() 2245 ## on. 2246 _debug( 2247 "kid ", $kid->{NUM}, " to write ", $op->{KFD}, 2248 ' to a pipe IPC::Run opens and returns' 2249 ) if _debugging_details; 2250 2251 my ( $r, $w ) = $op->open_pipe( $self->_debug_fd, $op->{DEST} ); 2252 _debug "caller will read from ", fileno $op->{DEST} 2253 if _debugging_details; 2254 2255 $op->{TFD} = $w; 2256 $op->{FD} = undef; # we don't manage this fd 2257 $op->_init_filters; 2258 2259 $output_fds_accum[ $op->{KFD} ] = $op; 2260 } 2261 elsif ( $op->{TYPE} eq '>pty>' ) { 2262 my $dest = $op->{DEST}; 2263 if ( UNIVERSAL::isa( $dest, 'SCALAR' ) ) { 2264 _debug( 2265 "kid ", $kid->{NUM}, " to write ", $op->{KFD}, 2266 " to SCALAR via pty '", $op->{PTY_ID}, "'" 2267 ) if _debugging_details; 2268 2269 $$dest = '' if $op->{TRUNC}; 2270 } 2271 elsif ( UNIVERSAL::isa( $dest, 'CODE' ) ) { 2272 _debug( 2273 "kid ", $kid->{NUM}, " to write ", $op->{KFD}, 2274 " to CODE via pty '", $op->{PTY_ID}, "'" 2275 ) if _debugging_details; 2276 } 2277 else { 2278 croak( "'" . ref($dest) . "' not allowed as a sink for output redirection" ); 2279 } 2280 2281 $op->{FD} = $self->{PTYS}->{ $op->{PTY_ID} }->fileno; 2282 $op->{TFD} = undef; # The fd isn't known until after fork(). 2283 $output_fds_accum[ $op->{KFD} ] = $op; 2284 $op->_init_filters; 2285 } 2286 elsif ( $op->{TYPE} eq '|' ) { 2287 _debug( "pipelining $kid->{NUM} and " . ( $kid->{NUM} + 1 ) ) if _debugging_details; 2288 ( $pipe_read_fd, $op->{TFD} ) = _pipe; 2289 if (Win32_MODE) { 2290 _dont_inherit($pipe_read_fd); 2291 _dont_inherit( $op->{TFD} ); 2292 } 2293 @output_fds_accum = (); 2294 } 2295 elsif ( $op->{TYPE} eq '&' ) { 2296 @output_fds_accum = (); 2297 } # end if $op->{TYPE} tree 2298 1; 2299 }; # end eval 2300 unless ($ok) { 2301 push @errs, $@; 2302 _debug 'caught ', $@ if _debugging; 2303 } 2304 } # end for ( OPS } 2305 } 2306 2307 if (@errs) { 2308 for (@close_on_fail) { 2309 _close($_); 2310 $_ = undef; 2311 } 2312 for ( keys %{ $self->{PTYS} } ) { 2313 next unless $self->{PTYS}->{$_}; 2314 close $self->{PTYS}->{$_}; 2315 $self->{PTYS}->{$_} = undef; 2316 } 2317 die join( '', @errs ); 2318 } 2319 2320 ## give all but the last child all of the output file descriptors 2321 ## These will be reopened (and thus rendered useless) if the child 2322 ## dup2s on to these descriptors, since we unshift these. This way 2323 ## each process emits output to the same file descriptors that the 2324 ## last child will write to. This is probably not quite correct, 2325 ## since each child should write to the file descriptors inherited 2326 ## from the parent. 2327 ## TODO: fix the inheritance of output file descriptors. 2328 ## NOTE: This sharing of OPS among kids means that we can't easily put 2329 ## a kid number in each OPS structure to ping the kid when all ops 2330 ## have closed (when $self->{PIPES} has emptied). This means that we 2331 ## need to scan the KIDS whenever @{$self->{PIPES}} is empty to see 2332 ## if there any of them are still alive. 2333 for ( my $num = 0; $num < $#{ $self->{KIDS} }; ++$num ) { 2334 for ( reverse @output_fds_accum ) { 2335 next unless defined $_; 2336 _debug( 2337 'kid ', $self->{KIDS}->[$num]->{NUM}, ' also to write ', $_->{KFD}, 2338 ' to ', ref $_->{DEST} 2339 ) if _debugging_details; 2340 unshift @{ $self->{KIDS}->[$num]->{OPS} }, $_; 2341 } 2342 } 2343 2344 ## Open the debug pipe if we need it 2345 ## Create the list of PIPES we need to scan and the bit vectors needed by 2346 ## select(). Do this first so that _cleanup can _clobber() them if an 2347 ## exception occurs. 2348 @{ $self->{PIPES} } = (); 2349 $self->{RIN} = ''; 2350 $self->{WIN} = ''; 2351 $self->{EIN} = ''; 2352 ## PIN is a vec()tor that indicates who's paused. 2353 $self->{PIN} = ''; 2354 for my $kid ( @{ $self->{KIDS} } ) { 2355 for ( @{ $kid->{OPS} } ) { 2356 if ( defined $_->{FD} ) { 2357 _debug( 2358 'kid ', $kid->{NUM}, '[', $kid->{PID}, "]'s ", $_->{KFD}, 2359 ' is my ', $_->{FD} 2360 ) if _debugging_details; 2361 vec( $self->{ $_->{TYPE} =~ /^</ ? 'WIN' : 'RIN' }, $_->{FD}, 1 ) = 1; 2362 2363 # vec( $self->{EIN}, $_->{FD}, 1 ) = 1; 2364 push @{ $self->{PIPES} }, $_; 2365 } 2366 } 2367 } 2368 2369 for my $io ( @{ $self->{IOS} } ) { 2370 my $fd = $io->fileno; 2371 vec( $self->{RIN}, $fd, 1 ) = 1 if $io->mode =~ /r/; 2372 vec( $self->{WIN}, $fd, 1 ) = 1 if $io->mode =~ /w/; 2373 2374 # vec( $self->{EIN}, $fd, 1 ) = 1; 2375 push @{ $self->{PIPES} }, $io; 2376 } 2377 2378 ## Put filters on the end of the filter chains to read & write the pipes. 2379 ## Clear pipe states 2380 for my $pipe ( @{ $self->{PIPES} } ) { 2381 $pipe->{SOURCE_EMPTY} = 0; 2382 $pipe->{PAUSED} = 0; 2383 if ( $pipe->{TYPE} =~ /^>/ ) { 2384 my $pipe_reader = sub { 2385 my ( undef, $out_ref ) = @_; 2386 2387 return undef unless defined $pipe->{FD}; 2388 return 0 unless vec( $self->{ROUT}, $pipe->{FD}, 1 ); 2389 2390 vec( $self->{ROUT}, $pipe->{FD}, 1 ) = 0; 2391 2392 _debug_desc_fd( 'reading from', $pipe ) if _debugging_details; 2393 my $in = eval { _read( $pipe->{FD} ) }; 2394 if ($@) { 2395 $in = ''; 2396 ## IO::Pty throws the Input/output error if the kid dies. 2397 ## read() throws the bad file descriptor message if the 2398 ## kid dies on Win32. 2399 die $@ 2400 unless $@ =~ $_EIO 2401 || ( $@ =~ /input or output/ && $^O =~ /aix/ ) 2402 || ( Win32_MODE && $@ =~ /Bad file descriptor/ ); 2403 } 2404 2405 unless ( length $in ) { 2406 $self->_clobber($pipe); 2407 return undef; 2408 } 2409 2410 ## Protect the position so /.../g matches may be used. 2411 my $pos = pos $$out_ref; 2412 $$out_ref .= $in; 2413 pos($$out_ref) = $pos; 2414 return 1; 2415 }; 2416 ## Input filters are the last filters 2417 push @{ $pipe->{FILTERS} }, $pipe_reader; 2418 push @{ $self->{TEMP_FILTERS} }, $pipe_reader; 2419 } 2420 else { 2421 my $pipe_writer = sub { 2422 my ( $in_ref, $out_ref ) = @_; 2423 return undef unless defined $pipe->{FD}; 2424 return 0 2425 unless vec( $self->{WOUT}, $pipe->{FD}, 1 ) 2426 || $pipe->{PAUSED}; 2427 2428 vec( $self->{WOUT}, $pipe->{FD}, 1 ) = 0; 2429 2430 if ( !length $$in_ref ) { 2431 if ( !defined get_more_input ) { 2432 $self->_clobber($pipe); 2433 return undef; 2434 } 2435 } 2436 2437 unless ( length $$in_ref ) { 2438 unless ( $pipe->{PAUSED} ) { 2439 _debug_desc_fd( 'pausing', $pipe ) if _debugging_details; 2440 vec( $self->{WIN}, $pipe->{FD}, 1 ) = 0; 2441 2442 # vec( $self->{EIN}, $pipe->{FD}, 1 ) = 0; 2443 vec( $self->{PIN}, $pipe->{FD}, 1 ) = 1; 2444 $pipe->{PAUSED} = 1; 2445 } 2446 return 0; 2447 } 2448 _debug_desc_fd( 'writing to', $pipe ) if _debugging_details; 2449 2450 if ( length $$in_ref && $$in_ref ) { 2451 my $c = _write( $pipe->{FD}, $$in_ref ); 2452 substr( $$in_ref, 0, $c, '' ); 2453 } 2454 else { 2455 $self->_clobber($pipe); 2456 return undef; 2457 } 2458 2459 return 1; 2460 }; 2461 ## Output filters are the first filters 2462 unshift @{ $pipe->{FILTERS} }, $pipe_writer; 2463 push @{ $self->{TEMP_FILTERS} }, $pipe_writer; 2464 } 2465 } 2466} 2467 2468sub _dup2_gently { 2469 ## A METHOD, NOT A FUNCTION, NEEDS $self! 2470 my IPC::Run $self = shift; 2471 my ( $files, $fd1, $fd2 ) = @_; 2472 ## Moves TFDs that are using the destination fd out of the 2473 ## way before calling _dup2 2474 for (@$files) { 2475 next unless defined $_->{TFD}; 2476 $_->{TFD} = _dup( $_->{TFD} ) if $_->{TFD} == $fd2; 2477 } 2478 if ( defined $self->{DEBUG_FD} && $self->{DEBUG_FD} == $fd2 ) { 2479 $self->{DEBUG_FD} = _dup $self->{DEBUG_FD}; 2480 $fds{$self->{DEBUG_FD}}{needed} = 1; 2481 } 2482 _dup2_rudely( $fd1, $fd2 ); 2483} 2484 2485=pod 2486 2487=item close_terminal 2488 2489This is used as (or in) an init sub to cast off the bonds of a controlling 2490terminal. It must precede all other redirection ops that affect 2491STDIN, STDOUT, or STDERR to be guaranteed effective. 2492 2493=cut 2494 2495sub close_terminal { 2496 ## Cast of the bonds of a controlling terminal 2497 2498 # Just in case the parent (I'm talking to you FCGI) had these tied. 2499 untie *STDIN; 2500 untie *STDOUT; 2501 untie *STDERR; 2502 2503 POSIX::setsid() || croak "POSIX::setsid() failed"; 2504 _debug "closing stdin, out, err" 2505 if _debugging_details; 2506 close STDIN; 2507 close STDERR; 2508 close STDOUT; 2509} 2510 2511sub _do_kid_and_exit { 2512 my IPC::Run $self = shift; 2513 my ($kid) = @_; 2514 2515 my ( $s1, $s2 ); 2516 if ( $] < 5.008 ) { 2517 ## For unknown reasons, placing these two statements in the eval{} 2518 ## causes the eval {} to not catch errors after they are executed in 2519 ## perl 5.6.0, godforsaken version that it is...not sure about 5.6.1. 2520 ## Part of this could be that these symbols get destructed when 2521 ## exiting the eval, and that destruction might be what's (wrongly) 2522 ## confusing the eval{}, allowing the exception to propagate. 2523 $s1 = Symbol::gensym(); 2524 $s2 = Symbol::gensym(); 2525 } 2526 2527 eval { 2528 local $cur_self = $self; 2529 2530 if (_debugging) { 2531 _set_child_debug_name( 2532 ref $kid->{VAL} eq "CODE" 2533 ? "CODE" 2534 : basename( $kid->{VAL}->[0] ) 2535 ); 2536 } 2537 2538 ## close parent FD's first so they're out of the way. 2539 ## Don't close STDIN, STDOUT, STDERR: they should be inherited or 2540 ## overwritten below. 2541 do { $_->{needed} = 1 for @fds{0..2} } 2542 unless $self->{noinherit}; 2543 2544 $fds{$self->{SYNC_WRITER_FD}}{needed} = 1; 2545 $fds{$self->{DEBUG_FD}}{needed} = 1 if defined $self->{DEBUG_FD}; 2546 2547 $fds{$_->{TFD}}{needed} = 1 2548 foreach grep { defined $_->{TFD} } @{$kid->{OPS} }; 2549 2550 2551 ## TODO: use the forthcoming IO::Pty to close the terminal and 2552 ## make the first pty for this child the controlling terminal. 2553 ## This will also make it so that pty-laden kids don't cause 2554 ## other kids to lose stdin/stdout/stderr. 2555 2556 if ( %{ $self->{PTYS} } ) { 2557 ## Clean up the parent's fds. 2558 for ( keys %{ $self->{PTYS} } ) { 2559 _debug "Cleaning up parent's ptty '$_'" if _debugging_details; 2560 $self->{PTYS}->{$_}->make_slave_controlling_terminal; 2561 my $slave = $self->{PTYS}->{$_}->slave; 2562 delete $fds{$self->{PTYS}->{$_}->fileno}; 2563 close $self->{PTYS}->{$_}; 2564 $self->{PTYS}->{$_} = $slave; 2565 } 2566 2567 close_terminal; 2568 delete @fds{0..2}; 2569 } 2570 2571 for my $sibling ( @{ $self->{KIDS} } ) { 2572 for ( @{ $sibling->{OPS} } ) { 2573 if ( $_->{TYPE} =~ /^.pty.$/ ) { 2574 $_->{TFD} = $self->{PTYS}->{ $_->{PTY_ID} }->fileno; 2575 $fds{$_->{TFD}}{needed} = 1; 2576 } 2577 2578 # for ( $_->{FD}, ( $sibling != $kid ? $_->{TFD} : () ) ) { 2579 # if ( defined $_ && ! $closed[$_] && ! $needed[$_] ) { 2580 # _close( $_ ); 2581 # $closed[$_] = 1; 2582 # $_ = undef; 2583 # } 2584 # } 2585 } 2586 } 2587 2588 ## This is crude: we have no way of keeping track of browsing all open 2589 ## fds, so we scan to a fairly high fd. 2590 _debug "open fds: ", join " ", keys %fds if _debugging_details; 2591 2592 _close( $_ ) foreach grep { ! $fds{$_}{needed} } keys %fds; 2593 2594 for ( @{ $kid->{OPS} } ) { 2595 if ( defined $_->{TFD} ) { 2596 2597 # we're always creating KFD 2598 $fds{$_->{KFD}}{needed} = 1; 2599 2600 unless ( $_->{TFD} == $_->{KFD} ) { 2601 $self->_dup2_gently( $kid->{OPS}, $_->{TFD}, $_->{KFD} ); 2602 $fds{$_->{TFD}}{lazy_close} = 1; 2603 } else { 2604 my $fd = _dup($_->{TFD}); 2605 $self->_dup2_gently( $kid->{OPS}, $fd, $_->{KFD} ); 2606 _close($fd); 2607 } 2608 } 2609 elsif ( $_->{TYPE} eq 'dup' ) { 2610 $self->_dup2_gently( $kid->{OPS}, $_->{KFD1}, $_->{KFD2} ) 2611 unless $_->{KFD1} == $_->{KFD2}; 2612 $fds{$_->{KFD2}}{needed} = 1; 2613 } 2614 elsif ( $_->{TYPE} eq 'close' ) { 2615 for ( $_->{KFD} ) { 2616 if ( $fds{$_} ) { 2617 _close($_); 2618 $_ = undef; 2619 } 2620 } 2621 } 2622 elsif ( $_->{TYPE} eq 'init' ) { 2623 $_->{SUB}->(); 2624 } 2625 } 2626 2627 _close( $_ ) foreach grep { $fds{$_}{lazy_close} } keys %fds; 2628 2629 if ( ref $kid->{VAL} ne 'CODE' ) { 2630 open $s1, ">&=$self->{SYNC_WRITER_FD}" 2631 or croak "$! setting filehandle to fd SYNC_WRITER_FD"; 2632 fcntl $s1, F_SETFD, 1; 2633 2634 if ( defined $self->{DEBUG_FD} ) { 2635 open $s2, ">&=$self->{DEBUG_FD}" 2636 or croak "$! setting filehandle to fd DEBUG_FD"; 2637 fcntl $s2, F_SETFD, 1; 2638 } 2639 2640 if (_debugging) { 2641 my @cmd = ( $kid->{PATH}, @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ] ); 2642 _debug 'execing ', join " ", map { /[\s\"]/ ? "'$_'" : $_ } @cmd; 2643 } 2644 2645 die "exec failed: simulating exec() failure" 2646 if $self->{_simulate_exec_failure}; 2647 2648 _exec $kid->{PATH}, @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ]; 2649 2650 croak "exec failed: $!"; 2651 } 2652 }; 2653 if ($@) { 2654 _write $self->{SYNC_WRITER_FD}, $@; 2655 ## Avoid DESTROY. 2656 POSIX::_exit(1); 2657 } 2658 2659 ## We must be executing code in the child, otherwise exec() would have 2660 ## prevented us from being here. 2661 _close $self->{SYNC_WRITER_FD}; 2662 _debug 'calling fork()ed CODE ref' if _debugging; 2663 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD}; 2664 ## TODO: Overload CORE::GLOBAL::exit... 2665 $kid->{VAL}->(); 2666 2667 ## There are bugs in perl closures up to and including 5.6.1 2668 ## that may keep this next line from having any effect, and it 2669 ## won't have any effect if our caller has kept a copy of it, but 2670 ## this may cause the closure to be cleaned up. Maybe. 2671 $kid->{VAL} = undef; 2672 2673 ## Use POSIX::_exit to avoid global destruction, since this might 2674 ## cause DESTROY() to be called on objects created in the parent 2675 ## and thus cause double cleanup. For instance, if DESTROY() unlinks 2676 ## a file in the child, we don't want the parent to suddenly miss 2677 ## it. 2678 POSIX::_exit(0); 2679} 2680 2681=pod 2682 2683=item start 2684 2685 $h = start( 2686 \@cmd, \$in, \$out, ..., 2687 timeout( 30, name => "process timeout" ), 2688 $stall_timeout = timeout( 10, name => "stall timeout" ), 2689 ); 2690 2691 $h = start \@cmd, '<', \$in, '|', \@cmd2, ...; 2692 2693start() accepts a harness or harness specification and returns a harness 2694after building all of the pipes and launching (via fork()/exec(), or, maybe 2695someday, spawn()) all the child processes. It does not send or receive any 2696data on the pipes, see pump() and finish() for that. 2697 2698You may call harness() and then pass it's result to start() if you like, 2699but you only need to if it helps you structure or tune your application. 2700If you do call harness(), you may skip start() and proceed directly to 2701pump. 2702 2703start() also starts all timers in the harness. See L<IPC::Run::Timer> 2704for more information. 2705 2706start() flushes STDOUT and STDERR to help you avoid duplicate output. 2707It has no way of asking Perl to flush all your open filehandles, so 2708you are going to need to flush any others you have open. Sorry. 2709 2710Here's how if you don't want to alter the state of $| for your 2711filehandle: 2712 2713 $ofh = select HANDLE; $of = $|; $| = 1; $| = $of; select $ofh; 2714 2715If you don't mind leaving output unbuffered on HANDLE, you can do 2716the slightly shorter 2717 2718 $ofh = select HANDLE; $| = 1; select $ofh; 2719 2720Or, you can use IO::Handle's flush() method: 2721 2722 use IO::Handle; 2723 flush HANDLE; 2724 2725Perl needs the equivalent of C's fflush( (FILE *)NULL ). 2726 2727=cut 2728 2729sub start { 2730 2731 # $SIG{__DIE__} = sub { my $s = shift; Carp::cluck $s; die $s }; 2732 my $options; 2733 if ( @_ && ref $_[-1] eq 'HASH' ) { 2734 $options = pop; 2735 require Data::Dumper; 2736 carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper($options); 2737 } 2738 2739 my IPC::Run $self; 2740 if ( @_ == 1 && UNIVERSAL::isa( $_[0], __PACKAGE__ ) ) { 2741 $self = shift; 2742 $self->{$_} = $options->{$_} for keys %$options; 2743 } 2744 else { 2745 $self = harness( @_, $options ? $options : () ); 2746 } 2747 2748 local $cur_self = $self; 2749 2750 $self->kill_kill if $self->{STATE} == _started; 2751 2752 _debug "** starting" if _debugging; 2753 2754 $_->{RESULT} = undef for @{ $self->{KIDS} }; 2755 2756 ## Assume we're not being called from &run. It will correct our 2757 ## assumption if need be. This affects whether &_select_loop clears 2758 ## input queues to '' when they're empty. 2759 $self->{clear_ins} = 1; 2760 2761 IPC::Run::Win32Helper::optimize $self 2762 if Win32_MODE && $in_run; 2763 2764 my @errs; 2765 2766 for ( @{ $self->{TIMERS} } ) { 2767 eval { $_->start }; 2768 if ($@) { 2769 push @errs, $@; 2770 _debug 'caught ', $@ if _debugging; 2771 } 2772 } 2773 2774 eval { $self->_open_pipes }; 2775 if ($@) { 2776 push @errs, $@; 2777 _debug 'caught ', $@ if _debugging; 2778 } 2779 2780 if ( !@errs ) { 2781 ## This is a bit of a hack, we should do it for all open filehandles. 2782 ## Since there's no way I know of to enumerate open filehandles, we 2783 ## autoflush STDOUT and STDERR. This is done so that the children don't 2784 ## inherit output buffers chock full o' redundant data. It's really 2785 ## confusing to track that down. 2786 { my $ofh = select STDOUT; my $of = $|; $| = 1; $| = $of; select $ofh; } 2787 { my $ofh = select STDERR; my $of = $|; $| = 1; $| = $of; select $ofh; } 2788 for my $kid ( @{ $self->{KIDS} } ) { 2789 $kid->{RESULT} = undef; 2790 _debug "child: ", 2791 ref( $kid->{VAL} ) eq "CODE" 2792 ? "CODE ref" 2793 : ( 2794 "`", 2795 join( " ", map /[^\w.-]/ ? "'$_'" : $_, @{ $kid->{VAL} } ), 2796 "`" 2797 ) if _debugging_details; 2798 eval { 2799 croak "simulated failure of fork" 2800 if $self->{_simulate_fork_failure}; 2801 unless (Win32_MODE) { 2802 $self->_spawn($kid); 2803 } 2804 else { 2805## TODO: Test and debug spawning code. Someday. 2806 _debug( 2807 'spawning ', 2808 join( 2809 ' ', 2810 map( "'$_'", 2811 ( $kid->{PATH}, @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ] ) ) 2812 ) 2813 ) if _debugging; 2814 ## The external kid wouldn't know what to do with it anyway. 2815 ## This is only used by the "helper" pump processes on Win32. 2816 _dont_inherit( $self->{DEBUG_FD} ); 2817 ( $kid->{PID}, $kid->{PROCESS} ) = IPC::Run::Win32Helper::win32_spawn( 2818 [ $kid->{PATH}, @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ] ], 2819 $kid->{OPS}, 2820 ); 2821 _debug "spawn() = ", $kid->{PID} if _debugging; 2822 } 2823 }; 2824 if ($@) { 2825 push @errs, $@; 2826 _debug 'caught ', $@ if _debugging; 2827 } 2828 } 2829 } 2830 2831 ## Close all those temporary filehandles that the kids needed. 2832 for my $pty ( values %{ $self->{PTYS} } ) { 2833 close $pty->slave; 2834 } 2835 2836 my @closed; 2837 for my $kid ( @{ $self->{KIDS} } ) { 2838 for ( @{ $kid->{OPS} } ) { 2839 my $close_it = eval { 2840 defined $_->{TFD} 2841 && !$_->{DONT_CLOSE} 2842 && !$closed[ $_->{TFD} ] 2843 && ( !Win32_MODE || !$_->{RECV_THROUGH_TEMP_FILE} ) ## Win32 hack 2844 }; 2845 if ($@) { 2846 push @errs, $@; 2847 _debug 'caught ', $@ if _debugging; 2848 } 2849 if ( $close_it || $@ ) { 2850 eval { 2851 _close( $_->{TFD} ); 2852 $closed[ $_->{TFD} ] = 1; 2853 $_->{TFD} = undef; 2854 }; 2855 if ($@) { 2856 push @errs, $@; 2857 _debug 'caught ', $@ if _debugging; 2858 } 2859 } 2860 } 2861 } 2862 confess "gak!" unless defined $self->{PIPES}; 2863 2864 if (@errs) { 2865 eval { $self->_cleanup }; 2866 warn $@ if $@; 2867 die join( '', @errs ); 2868 } 2869 2870 $self->{STATE} = _started; 2871 return $self; 2872} 2873 2874=item adopt 2875 2876Experimental feature. NOT FUNCTIONAL YET, NEED TO CLOSE FDS BETTER IN CHILDREN. SEE t/adopt.t for a test suite. 2877 2878=cut 2879 2880sub adopt { 2881 my IPC::Run $self = shift; 2882 2883 for my $adoptee (@_) { 2884 push @{ $self->{IOS} }, @{ $adoptee->{IOS} }; 2885 ## NEED TO RENUMBER THE KIDS!! 2886 push @{ $self->{KIDS} }, @{ $adoptee->{KIDS} }; 2887 push @{ $self->{PIPES} }, @{ $adoptee->{PIPES} }; 2888 $self->{PTYS}->{$_} = $adoptee->{PTYS}->{$_} for keys %{ $adoptee->{PYTS} }; 2889 push @{ $self->{TIMERS} }, @{ $adoptee->{TIMERS} }; 2890 $adoptee->{STATE} = _finished; 2891 } 2892} 2893 2894sub _clobber { 2895 my IPC::Run $self = shift; 2896 my ($file) = @_; 2897 _debug_desc_fd( "closing", $file ) if _debugging_details; 2898 my $doomed = $file->{FD}; 2899 my $dir = $file->{TYPE} =~ /^</ ? 'WIN' : 'RIN'; 2900 vec( $self->{$dir}, $doomed, 1 ) = 0; 2901 2902 # vec( $self->{EIN}, $doomed, 1 ) = 0; 2903 vec( $self->{PIN}, $doomed, 1 ) = 0; 2904 if ( $file->{TYPE} =~ /^(.)pty.$/ ) { 2905 if ( $1 eq '>' ) { 2906 ## Only close output ptys. This is so that ptys as inputs are 2907 ## never autoclosed, which would risk losing data that was 2908 ## in the slave->parent queue. 2909 _debug_desc_fd "closing pty", $file if _debugging_details; 2910 close $self->{PTYS}->{ $file->{PTY_ID} } 2911 if defined $self->{PTYS}->{ $file->{PTY_ID} }; 2912 $self->{PTYS}->{ $file->{PTY_ID} } = undef; 2913 } 2914 } 2915 elsif ( UNIVERSAL::isa( $file, 'IPC::Run::IO' ) ) { 2916 $file->close unless $file->{DONT_CLOSE}; 2917 } 2918 else { 2919 _close($doomed); 2920 } 2921 2922 @{ $self->{PIPES} } = grep 2923 defined $_->{FD} && ( $_->{TYPE} ne $file->{TYPE} || $_->{FD} ne $doomed ), 2924 @{ $self->{PIPES} }; 2925 2926 $file->{FD} = undef; 2927} 2928 2929sub _select_loop { 2930 my IPC::Run $self = shift; 2931 2932 my $io_occurred; 2933 2934 my $not_forever = 0.01; 2935 2936 SELECT: 2937 while ( $self->pumpable ) { 2938 if ( $io_occurred && $self->{break_on_io} ) { 2939 _debug "exiting _select(): io occurred and break_on_io set" 2940 if _debugging_details; 2941 last; 2942 } 2943 2944 my $timeout = $self->{non_blocking} ? 0 : undef; 2945 2946 if ( @{ $self->{TIMERS} } ) { 2947 my $now = time; 2948 my $time_left; 2949 for ( @{ $self->{TIMERS} } ) { 2950 next unless $_->is_running; 2951 $time_left = $_->check($now); 2952 ## Return when a timer expires 2953 return if defined $time_left && !$time_left; 2954 $timeout = $time_left 2955 if !defined $timeout || $time_left < $timeout; 2956 } 2957 } 2958 2959 ## 2960 ## See if we can unpause any input channels 2961 ## 2962 my $paused = 0; 2963 2964 for my $file ( @{ $self->{PIPES} } ) { 2965 next unless $file->{PAUSED} && $file->{TYPE} =~ /^</; 2966 2967 _debug_desc_fd( "checking for more input", $file ) if _debugging_details; 2968 my $did; 2969 1 while $did = $file->_do_filters($self); 2970 if ( defined $file->{FD} && !defined($did) || $did ) { 2971 _debug_desc_fd( "unpausing", $file ) if _debugging_details; 2972 $file->{PAUSED} = 0; 2973 vec( $self->{WIN}, $file->{FD}, 1 ) = 1; 2974 2975 # vec( $self->{EIN}, $file->{FD}, 1 ) = 1; 2976 vec( $self->{PIN}, $file->{FD}, 1 ) = 0; 2977 } 2978 else { 2979 ## This gets incremented occasionally when the IO channel 2980 ## was actually closed. That's a bug, but it seems mostly 2981 ## harmless: it causes us to exit if break_on_io, or to set 2982 ## the timeout to not be forever. I need to fix it, though. 2983 ++$paused; 2984 } 2985 } 2986 2987 if (_debugging_details) { 2988 my $map = join( 2989 '', 2990 map { 2991 my $out; 2992 $out = 'r' if vec( $self->{RIN}, $_, 1 ); 2993 $out = $out ? 'b' : 'w' if vec( $self->{WIN}, $_, 1 ); 2994 $out = 'p' if !$out && vec( $self->{PIN}, $_, 1 ); 2995 $out = $out ? uc($out) : 'x' if vec( $self->{EIN}, $_, 1 ); 2996 $out = '-' unless $out; 2997 $out; 2998 } ( 0 .. 1024 ) 2999 ); 3000 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/; 3001 _debug 'fds for select: ', $map if _debugging_details; 3002 } 3003 3004 ## _do_filters may have closed our last fd, and we need to see if 3005 ## we have I/O, or are just waiting for children to exit. 3006 my $p = $self->pumpable; 3007 last unless $p; 3008 if ( $p != 0 && ( !defined $timeout || $timeout > 0.1 ) ) { 3009 ## No I/O will wake the select loop up, but we have children 3010 ## lingering, so we need to poll them with a short timeout. 3011 ## Otherwise, assume more input will be coming. 3012 $timeout = $not_forever; 3013 $not_forever *= 2; 3014 $not_forever = 0.5 if $not_forever >= 0.5; 3015 } 3016 3017 ## Make sure we don't block forever in select() because inputs are 3018 ## paused. 3019 if ( !defined $timeout && !( @{ $self->{PIPES} } - $paused ) ) { 3020 ## Need to return if we're in pump and all input is paused, or 3021 ## we'll loop until all inputs are unpaused, which is darn near 3022 ## forever. And a day. 3023 if ( $self->{break_on_io} ) { 3024 _debug "exiting _select(): no I/O to do and timeout=forever" 3025 if _debugging; 3026 last; 3027 } 3028 3029 ## Otherwise, assume more input will be coming. 3030 $timeout = $not_forever; 3031 $not_forever *= 2; 3032 $not_forever = 0.5 if $not_forever >= 0.5; 3033 } 3034 3035 _debug 'timeout=', defined $timeout ? $timeout : 'forever' 3036 if _debugging_details; 3037 3038 my $nfound; 3039 unless (Win32_MODE) { 3040 $nfound = select( 3041 $self->{ROUT} = $self->{RIN}, 3042 $self->{WOUT} = $self->{WIN}, 3043 $self->{EOUT} = $self->{EIN}, 3044 $timeout 3045 ); 3046 } 3047 else { 3048 my @in = map $self->{$_}, qw( RIN WIN EIN ); 3049 ## Win32's select() on Win32 seems to die if passed vectors of 3050 ## all 0's. Need to report this when I get back online. 3051 for (@in) { 3052 $_ = undef unless index( ( unpack "b*", $_ ), 1 ) >= 0; 3053 } 3054 3055 $nfound = select( 3056 $self->{ROUT} = $in[0], 3057 $self->{WOUT} = $in[1], 3058 $self->{EOUT} = $in[2], 3059 $timeout 3060 ); 3061 3062 for ( $self->{ROUT}, $self->{WOUT}, $self->{EOUT} ) { 3063 $_ = "" unless defined $_; 3064 } 3065 } 3066 last if !$nfound && $self->{non_blocking}; 3067 3068 if ( $nfound < 0 ) { 3069 if ( $!{EINTR} ) { 3070 3071 # Caught a signal before any FD went ready. Ensure that 3072 # the bit fields reflect "no FDs ready". 3073 $self->{ROUT} = $self->{WOUT} = $self->{EOUT} = ''; 3074 $nfound = 0; 3075 } 3076 else { 3077 croak "$! in select"; 3078 } 3079 } 3080 ## TODO: Analyze the EINTR failure mode and see if this patch 3081 ## is adequate and optimal. 3082 ## TODO: Add an EINTR test to the test suite. 3083 3084 if (_debugging_details) { 3085 my $map = join( 3086 '', 3087 map { 3088 my $out; 3089 $out = 'r' if vec( $self->{ROUT}, $_, 1 ); 3090 $out = $out ? 'b' : 'w' if vec( $self->{WOUT}, $_, 1 ); 3091 $out = $out ? uc($out) : 'x' if vec( $self->{EOUT}, $_, 1 ); 3092 $out = '-' unless $out; 3093 $out; 3094 } ( 0 .. 128 ) 3095 ); 3096 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/; 3097 _debug "selected ", $map; 3098 } 3099 3100 ## Need to copy since _clobber alters @{$self->{PIPES}}. 3101 ## TODO: Rethink _clobber(). Rethink $file->{PAUSED}, too. 3102 my @pipes = @{ $self->{PIPES} }; 3103 $io_occurred = $_->poll($self) ? 1 : $io_occurred for @pipes; 3104 3105 # FILE: 3106 # for my $pipe ( @pipes ) { 3107 # ## Pipes can be shared among kids. If another kid closes the 3108 # ## pipe, then it's {FD} will be undef. Also, on Win32, pipes can 3109 # ## be optimized to be files, in which case the FD is left undef 3110 # ## so we don't try to select() on it. 3111 # if ( $pipe->{TYPE} =~ /^>/ 3112 # && defined $pipe->{FD} 3113 # && vec( $self->{ROUT}, $pipe->{FD}, 1 ) 3114 # ) { 3115 # _debug_desc_fd( "filtering data from", $pipe ) if _debugging_details; 3116 #confess "phooey" unless UNIVERSAL::isa( $pipe, "IPC::Run::IO" ); 3117 # $io_occurred = 1 if $pipe->_do_filters( $self ); 3118 # 3119 # next FILE unless defined $pipe->{FD}; 3120 # } 3121 # 3122 # ## On Win32, pipes to the child can be optimized to be files 3123 # ## and FD left undefined so we won't select on it. 3124 # if ( $pipe->{TYPE} =~ /^</ 3125 # && defined $pipe->{FD} 3126 # && vec( $self->{WOUT}, $pipe->{FD}, 1 ) 3127 # ) { 3128 # _debug_desc_fd( "filtering data to", $pipe ) if _debugging_details; 3129 # $io_occurred = 1 if $pipe->_do_filters( $self ); 3130 # 3131 # next FILE unless defined $pipe->{FD}; 3132 # } 3133 # 3134 # if ( defined $pipe->{FD} && vec( $self->{EOUT}, $pipe->{FD}, 1 ) ) { 3135 # ## BSD seems to sometimes raise the exceptional condition flag 3136 # ## when a pipe is closed before we read it's last data. This 3137 # ## causes spurious warnings and generally renders the exception 3138 # ## mechanism useless for our purposes. The exception 3139 # ## flag semantics are too variable (they're device driver 3140 # ## specific) for me to easily map to any automatic action like 3141 # ## warning or croaking (try running v0.42 if you don't believe me 3142 # ## :-). 3143 # warn "Exception on descriptor $pipe->{FD}"; 3144 # } 3145 # } 3146 } 3147 3148 return; 3149} 3150 3151sub _cleanup { 3152 my IPC::Run $self = shift; 3153 _debug "cleaning up" if _debugging_details; 3154 3155 for ( values %{ $self->{PTYS} } ) { 3156 next unless ref $_; 3157 eval { 3158 _debug "closing slave fd ", fileno $_->slave if _debugging_data; 3159 close $_->slave; 3160 }; 3161 carp $@ . " while closing ptys" if $@; 3162 eval { 3163 _debug "closing master fd ", fileno $_ if _debugging_data; 3164 close $_; 3165 }; 3166 carp $@ . " closing ptys" if $@; 3167 } 3168 3169 _debug "cleaning up pipes" if _debugging_details; 3170 ## _clobber modifies PIPES 3171 $self->_clobber( $self->{PIPES}->[0] ) while @{ $self->{PIPES} }; 3172 3173 for my $kid ( @{ $self->{KIDS} } ) { 3174 _debug "cleaning up kid ", $kid->{NUM} if _debugging_details; 3175 if ( !length $kid->{PID} ) { 3176 _debug 'never ran child ', $kid->{NUM}, ", can't reap" 3177 if _debugging; 3178 for my $op ( @{ $kid->{OPS} } ) { 3179 _close( $op->{TFD} ) 3180 if defined $op->{TFD} && !defined $op->{TEMP_FILE_HANDLE}; 3181 } 3182 } 3183 elsif ( !defined $kid->{RESULT} ) { 3184 _debug 'reaping child ', $kid->{NUM}, ' (pid ', $kid->{PID}, ')' 3185 if _debugging; 3186 my $pid = waitpid $kid->{PID}, 0; 3187 $kid->{RESULT} = $?; 3188 _debug 'reaped ', $pid, ', $?=', $kid->{RESULT} 3189 if _debugging; 3190 } 3191 3192 # if ( defined $kid->{DEBUG_FD} ) { 3193 # die; 3194 # @{$kid->{OPS}} = grep 3195 # ! defined $_->{KFD} || $_->{KFD} != $kid->{DEBUG_FD}, 3196 # @{$kid->{OPS}}; 3197 # $kid->{DEBUG_FD} = undef; 3198 # } 3199 3200 _debug "cleaning up filters" if _debugging_details; 3201 for my $op ( @{ $kid->{OPS} } ) { 3202 @{ $op->{FILTERS} } = grep { 3203 my $filter = $_; 3204 !grep $filter == $_, @{ $self->{TEMP_FILTERS} }; 3205 } @{ $op->{FILTERS} }; 3206 } 3207 3208 for my $op ( @{ $kid->{OPS} } ) { 3209 $op->_cleanup($self) if UNIVERSAL::isa( $op, "IPC::Run::IO" ); 3210 } 3211 } 3212 $self->{STATE} = _finished; 3213 @{ $self->{TEMP_FILTERS} } = (); 3214 _debug "done cleaning up" if _debugging_details; 3215 3216 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD}; 3217 $self->{DEBUG_FD} = undef; 3218} 3219 3220=pod 3221 3222=item pump 3223 3224 pump $h; 3225 $h->pump; 3226 3227Pump accepts a single parameter harness. It blocks until it delivers some 3228input or receives some output. It returns TRUE if there is still input or 3229output to be done, FALSE otherwise. 3230 3231pump() will automatically call start() if need be, so you may call harness() 3232then proceed to pump() if that helps you structure your application. 3233 3234If pump() is called after all harnessed activities have completed, a "process 3235ended prematurely" exception to be thrown. This allows for simple scripting 3236of external applications without having to add lots of error handling code at 3237each step of the script: 3238 3239 $h = harness \@smbclient, \$in, \$out, $err; 3240 3241 $in = "cd /foo\n"; 3242 $h->pump until $out =~ /^smb.*> \Z/m; 3243 die "error cding to /foo:\n$out" if $out =~ "ERR"; 3244 $out = ''; 3245 3246 $in = "mget *\n"; 3247 $h->pump until $out =~ /^smb.*> \Z/m; 3248 die "error retrieving files:\n$out" if $out =~ "ERR"; 3249 3250 $h->finish; 3251 3252 warn $err if $err; 3253 3254=cut 3255 3256sub pump { 3257 die "pump() takes only a single harness as a parameter" 3258 unless @_ == 1 && UNIVERSAL::isa( $_[0], __PACKAGE__ ); 3259 3260 my IPC::Run $self = shift; 3261 3262 local $cur_self = $self; 3263 3264 _debug "** pumping" 3265 if _debugging; 3266 3267 # my $r = eval { 3268 $self->start if $self->{STATE} < _started; 3269 croak "process ended prematurely" unless $self->pumpable; 3270 3271 $self->{auto_close_ins} = 0; 3272 $self->{break_on_io} = 1; 3273 $self->_select_loop; 3274 return $self->pumpable; 3275 3276 # }; 3277 # if ( $@ ) { 3278 # my $x = $@; 3279 # _debug $x if _debugging && $x; 3280 # eval { $self->_cleanup }; 3281 # warn $@ if $@; 3282 # die $x; 3283 # } 3284 # return $r; 3285} 3286 3287=pod 3288 3289=item pump_nb 3290 3291 pump_nb $h; 3292 $h->pump_nb; 3293 3294"pump() non-blocking", pumps if anything's ready to be pumped, returns 3295immediately otherwise. This is useful if you're doing some long-running 3296task in the foreground, but don't want to starve any child processes. 3297 3298=cut 3299 3300sub pump_nb { 3301 my IPC::Run $self = shift; 3302 3303 $self->{non_blocking} = 1; 3304 my $r = eval { $self->pump }; 3305 $self->{non_blocking} = 0; 3306 die $@ if $@; 3307 return $r; 3308} 3309 3310=pod 3311 3312=item pumpable 3313 3314Returns TRUE if calling pump() won't throw an immediate "process ended 3315prematurely" exception. This means that there are open I/O channels or 3316active processes. May yield the parent processes' time slice for 0.01 3317second if all pipes are to the child and all are paused. In this case 3318we can't tell if the child is dead, so we yield the processor and 3319then attempt to reap the child in a nonblocking way. 3320 3321=cut 3322 3323## Undocumented feature (don't depend on it outside this module): 3324## returns -1 if we have I/O channels open, or >0 if no I/O channels 3325## open, but we have kids running. This allows the select loop 3326## to poll for child exit. 3327sub pumpable { 3328 my IPC::Run $self = shift; 3329 3330 ## There's a catch-22 we can get in to if there is only one pipe left 3331 ## open to the child and it's paused (ie the SCALAR it's tied to 3332 ## is ''). It's paused, so we're not select()ing on it, so we don't 3333 ## check it to see if the child attached to it is alive and it stays 3334 ## in @{$self->{PIPES}} forever. So, if all pipes are paused, see if 3335 ## we can reap the child. 3336 return -1 if grep !$_->{PAUSED}, @{ $self->{PIPES} }; 3337 3338 ## See if the child is dead. 3339 $self->reap_nb; 3340 return 0 unless $self->_running_kids; 3341 3342 ## If we reap_nb and it's not dead yet, yield to it to see if it 3343 ## exits. 3344 ## 3345 ## A better solution would be to unpause all the pipes, but I tried that 3346 ## and it never errored on linux. Sigh. 3347 select undef, undef, undef, 0.0001; 3348 3349 ## try again 3350 $self->reap_nb; 3351 return 0 unless $self->_running_kids; 3352 3353 return -1; ## There are pipes waiting 3354} 3355 3356sub _running_kids { 3357 my IPC::Run $self = shift; 3358 return grep 3359 defined $_->{PID} && !defined $_->{RESULT}, 3360 @{ $self->{KIDS} }; 3361} 3362 3363=pod 3364 3365=item reap_nb 3366 3367Attempts to reap child processes, but does not block. 3368 3369Does not currently take any parameters, one day it will allow specific 3370children to be reaped. 3371 3372Only call this from a signal handler if your C<perl> is recent enough 3373to have safe signal handling (5.6.1 did not, IIRC, but it was being discussed 3374on perl5-porters). Calling this (or doing any significant work) in a signal 3375handler on older C<perl>s is asking for seg faults. 3376 3377=cut 3378 3379my $still_runnings; 3380 3381sub reap_nb { 3382 my IPC::Run $self = shift; 3383 3384 local $cur_self = $self; 3385 3386 ## No more pipes, look to see if all the kids yet live, reaping those 3387 ## that haven't. I'd use $SIG{CHLD}/$SIG{CLD}, but that's broken 3388 ## on older (SYSV) platforms and perhaps less portable than waitpid(). 3389 ## This could be slow with a lot of kids, but that's rare and, well, 3390 ## a lot of kids is slow in the first place. 3391 ## Oh, and this keeps us from reaping other children the process 3392 ## may have spawned. 3393 for my $kid ( @{ $self->{KIDS} } ) { 3394 if (Win32_MODE) { 3395 next if !defined $kid->{PROCESS} || defined $kid->{RESULT}; 3396 unless ( $kid->{PROCESS}->Wait(0) ) { 3397 _debug "kid $kid->{NUM} ($kid->{PID}) still running" 3398 if _debugging_details; 3399 next; 3400 } 3401 3402 _debug "kid $kid->{NUM} ($kid->{PID}) exited" 3403 if _debugging; 3404 3405 $kid->{PROCESS}->GetExitCode( $kid->{RESULT} ) 3406 or croak "$! while GetExitCode()ing for Win32 process"; 3407 3408 unless ( defined $kid->{RESULT} ) { 3409 $kid->{RESULT} = "0 but true"; 3410 $? = $kid->{RESULT} = 0x0F; 3411 } 3412 else { 3413 $? = $kid->{RESULT} << 8; 3414 } 3415 } 3416 else { 3417 next if !defined $kid->{PID} || defined $kid->{RESULT}; 3418 my $pid = waitpid $kid->{PID}, POSIX::WNOHANG(); 3419 unless ($pid) { 3420 _debug "$kid->{NUM} ($kid->{PID}) still running" 3421 if _debugging_details; 3422 next; 3423 } 3424 3425 if ( $pid < 0 ) { 3426 _debug "No such process: $kid->{PID}\n" if _debugging; 3427 $kid->{RESULT} = "unknown result, unknown PID"; 3428 } 3429 else { 3430 _debug "kid $kid->{NUM} ($kid->{PID}) exited" 3431 if _debugging; 3432 3433 confess "waitpid returned the wrong PID: $pid instead of $kid->{PID}" 3434 unless $pid == $kid->{PID}; 3435 _debug "$kid->{PID} returned $?\n" if _debugging; 3436 $kid->{RESULT} = $?; 3437 } 3438 } 3439 } 3440} 3441 3442=pod 3443 3444=item finish 3445 3446This must be called after the last start() or pump() call for a harness, 3447or your system will accumulate defunct processes and you may "leak" 3448file descriptors. 3449 3450finish() returns TRUE if all children returned 0 (and were not signaled and did 3451not coredump, ie ! $?), and FALSE otherwise (this is like run(), and the 3452opposite of system()). 3453 3454Once a harness has been finished, it may be run() or start()ed again, 3455including by pump()s auto-start. 3456 3457If this throws an exception rather than a normal exit, the harness may 3458be left in an unstable state, it's best to kill the harness to get rid 3459of all the child processes, etc. 3460 3461Specifically, if a timeout expires in finish(), finish() will not 3462kill all the children. Call C<<$h->kill_kill>> in this case if you care. 3463This differs from the behavior of L</run>. 3464 3465=cut 3466 3467sub finish { 3468 my IPC::Run $self = shift; 3469 my $options = @_ && ref $_[-1] eq 'HASH' ? pop : {}; 3470 3471 local $cur_self = $self; 3472 3473 _debug "** finishing" if _debugging; 3474 3475 $self->{non_blocking} = 0; 3476 $self->{auto_close_ins} = 1; 3477 $self->{break_on_io} = 0; 3478 3479 # We don't alter $self->{clear_ins}, start() and run() control it. 3480 3481 while ( $self->pumpable ) { 3482 $self->_select_loop($options); 3483 } 3484 $self->_cleanup; 3485 3486 return !$self->full_result; 3487} 3488 3489=pod 3490 3491=item result 3492 3493 $h->result; 3494 3495Returns the first non-zero result code (ie $? >> 8). See L</full_result> to 3496get the $? value for a child process. 3497 3498To get the result of a particular child, do: 3499 3500 $h->result( 0 ); # first child's $? >> 8 3501 $h->result( 1 ); # second child 3502 3503or 3504 3505 ($h->results)[0] 3506 ($h->results)[1] 3507 3508Returns undef if no child processes were spawned and no child number was 3509specified. Throws an exception if an out-of-range child number is passed. 3510 3511=cut 3512 3513sub _assert_finished { 3514 my IPC::Run $self = $_[0]; 3515 3516 croak "Harness not run" unless $self->{STATE} >= _finished; 3517 croak "Harness not finished running" unless $self->{STATE} == _finished; 3518} 3519 3520sub _child_result { 3521 my IPC::Run $self = shift; 3522 3523 my ($which) = @_; 3524 croak( 3525 "Only ", 3526 scalar( @{ $self->{KIDS} } ), 3527 " child processes, no process $which" 3528 ) unless $which >= 0 && $which <= $#{ $self->{KIDS} }; 3529 return $self->{KIDS}->[$which]->{RESULT}; 3530} 3531 3532sub result { 3533 &_assert_finished; 3534 my IPC::Run $self = shift; 3535 3536 if (@_) { 3537 my ($which) = @_; 3538 return $self->_child_result($which) >> 8; 3539 } 3540 else { 3541 return undef unless @{ $self->{KIDS} }; 3542 for ( @{ $self->{KIDS} } ) { 3543 return $_->{RESULT} >> 8 if $_->{RESULT} >> 8; 3544 } 3545 } 3546} 3547 3548=pod 3549 3550=item results 3551 3552Returns a list of child exit values. See L</full_results> if you want to 3553know if a signal killed the child. 3554 3555Throws an exception if the harness is not in a finished state. 3556 3557=cut 3558 3559sub results { 3560 &_assert_finished; 3561 my IPC::Run $self = shift; 3562 3563 # we add 0 here to stop warnings associated with "unknown result, unknown PID" 3564 return map { ( 0 + $_->{RESULT} ) >> 8 } @{ $self->{KIDS} }; 3565} 3566 3567=pod 3568 3569=item full_result 3570 3571 $h->full_result; 3572 3573Returns the first non-zero $?. See L</result> to get the first $? >> 8 3574value for a child process. 3575 3576To get the result of a particular child, do: 3577 3578 $h->full_result( 0 ); # first child's $? 3579 $h->full_result( 1 ); # second child 3580 3581or 3582 3583 ($h->full_results)[0] 3584 ($h->full_results)[1] 3585 3586Returns undef if no child processes were spawned and no child number was 3587specified. Throws an exception if an out-of-range child number is passed. 3588 3589=cut 3590 3591sub full_result { 3592 &_assert_finished; 3593 3594 my IPC::Run $self = shift; 3595 3596 if (@_) { 3597 my ($which) = @_; 3598 return $self->_child_result($which); 3599 } 3600 else { 3601 return undef unless @{ $self->{KIDS} }; 3602 for ( @{ $self->{KIDS} } ) { 3603 return $_->{RESULT} if $_->{RESULT}; 3604 } 3605 } 3606} 3607 3608=pod 3609 3610=item full_results 3611 3612Returns a list of child exit values as returned by C<wait>. See L</results> 3613if you don't care about coredumps or signals. 3614 3615Throws an exception if the harness is not in a finished state. 3616 3617=cut 3618 3619sub full_results { 3620 &_assert_finished; 3621 my IPC::Run $self = shift; 3622 3623 croak "Harness not run" unless $self->{STATE} >= _finished; 3624 croak "Harness not finished running" unless $self->{STATE} == _finished; 3625 3626 return map $_->{RESULT}, @{ $self->{KIDS} }; 3627} 3628 3629## 3630## Filter Scaffolding 3631## 3632use vars ( 3633 '$filter_op', ## The op running a filter chain right now 3634 '$filter_num', ## Which filter is being run right now. 3635); 3636 3637## 3638## A few filters and filter constructors 3639## 3640 3641=pod 3642 3643=back 3644 3645=back 3646 3647=head1 FILTERS 3648 3649These filters are used to modify input our output between a child 3650process and a scalar or subroutine endpoint. 3651 3652=over 3653 3654=item binary 3655 3656 run \@cmd, ">", binary, \$out; 3657 run \@cmd, ">", binary, \$out; ## Any TRUE value to enable 3658 run \@cmd, ">", binary 0, \$out; ## Any FALSE value to disable 3659 3660This is a constructor for a "binmode" "filter" that tells IPC::Run to keep 3661the carriage returns that would ordinarily be edited out for you (binmode 3662is usually off). This is not a real filter, but an option masquerading as 3663a filter. 3664 3665It's not named "binmode" because you're likely to want to call Perl's binmode 3666in programs that are piping binary data around. 3667 3668=cut 3669 3670sub binary(;$) { 3671 my $enable = @_ ? shift : 1; 3672 return bless sub { $enable }, "IPC::Run::binmode_pseudo_filter"; 3673} 3674 3675=pod 3676 3677=item new_chunker 3678 3679This breaks a stream of data in to chunks, based on an optional 3680scalar or regular expression parameter. The default is the Perl 3681input record separator in $/, which is a newline be default. 3682 3683 run \@cmd, '>', new_chunker, \&lines_handler; 3684 run \@cmd, '>', new_chunker( "\r\n" ), \&lines_handler; 3685 3686Because this uses $/ by default, you should always pass in a parameter 3687if you are worried about other code (modules, etc) modifying $/. 3688 3689If this filter is last in a filter chain that dumps in to a scalar, 3690the scalar must be set to '' before a new chunk will be written to it. 3691 3692As an example of how a filter like this can be written, here's a 3693chunker that splits on newlines: 3694 3695 sub line_splitter { 3696 my ( $in_ref, $out_ref ) = @_; 3697 3698 return 0 if length $$out_ref; 3699 3700 return input_avail && do { 3701 while (1) { 3702 if ( $$in_ref =~ s/\A(.*?\n)// ) { 3703 $$out_ref .= $1; 3704 return 1; 3705 } 3706 my $hmm = get_more_input; 3707 unless ( defined $hmm ) { 3708 $$out_ref = $$in_ref; 3709 $$in_ref = ''; 3710 return length $$out_ref ? 1 : 0; 3711 } 3712 return 0 if $hmm eq 0; 3713 } 3714 } 3715 }; 3716 3717=cut 3718 3719sub new_chunker(;$) { 3720 my ($re) = @_; 3721 $re = $/ if _empty $re; 3722 $re = quotemeta($re) unless ref $re eq 'Regexp'; 3723 $re = qr/\A(.*?$re)/s; 3724 3725 return sub { 3726 my ( $in_ref, $out_ref ) = @_; 3727 3728 return 0 if length $$out_ref; 3729 3730 return input_avail && do { 3731 while (1) { 3732 if ( $$in_ref =~ s/$re// ) { 3733 $$out_ref .= $1; 3734 return 1; 3735 } 3736 my $hmm = get_more_input; 3737 unless ( defined $hmm ) { 3738 $$out_ref = $$in_ref; 3739 $$in_ref = ''; 3740 return length $$out_ref ? 1 : 0; 3741 } 3742 return 0 if $hmm eq 0; 3743 } 3744 } 3745 }; 3746} 3747 3748=pod 3749 3750=item new_appender 3751 3752This appends a fixed string to each chunk of data read from the source 3753scalar or sub. This might be useful if you're writing commands to a 3754child process that always must end in a fixed string, like "\n": 3755 3756 run( \@cmd, 3757 '<', new_appender( "\n" ), \&commands, 3758 ); 3759 3760Here's a typical filter sub that might be created by new_appender(): 3761 3762 sub newline_appender { 3763 my ( $in_ref, $out_ref ) = @_; 3764 3765 return input_avail && do { 3766 $$out_ref = join( '', $$out_ref, $$in_ref, "\n" ); 3767 $$in_ref = ''; 3768 1; 3769 } 3770 }; 3771 3772=cut 3773 3774sub new_appender($) { 3775 my ($suffix) = @_; 3776 croak "\$suffix undefined" unless defined $suffix; 3777 3778 return sub { 3779 my ( $in_ref, $out_ref ) = @_; 3780 3781 return input_avail && do { 3782 $$out_ref = join( '', $$out_ref, $$in_ref, $suffix ); 3783 $$in_ref = ''; 3784 1; 3785 } 3786 }; 3787} 3788 3789=item new_string_source 3790 3791TODO: Needs confirmation. Was previously undocumented. in this module. 3792 3793This is a filter which is exportable. Returns a sub which appends the data passed in to the output buffer and returns 1 if data was appended. 0 if it was an empty string and undef if no data was passed. 3794 3795NOTE: Any additional variables passed to new_string_source will be passed to the sub every time it's called and appended to the output. 3796 3797=cut 3798 3799sub new_string_source { 3800 my $ref; 3801 if ( @_ > 1 ) { 3802 $ref = [@_], 3803 } 3804 else { 3805 $ref = shift; 3806 } 3807 3808 return ref $ref eq 'SCALAR' 3809 ? sub { 3810 my ( $in_ref, $out_ref ) = @_; 3811 3812 return defined $$ref 3813 ? do { 3814 $$out_ref .= $$ref; 3815 my $r = length $$ref ? 1 : 0; 3816 $$ref = undef; 3817 $r; 3818 } 3819 : undef; 3820 } 3821 : sub { 3822 my ( $in_ref, $out_ref ) = @_; 3823 3824 return @$ref 3825 ? do { 3826 my $s = shift @$ref; 3827 $$out_ref .= $s; 3828 length $s ? 1 : 0; 3829 } 3830 : undef; 3831 } 3832} 3833 3834=item new_string_sink 3835 3836TODO: Needs confirmation. Was previously undocumented. 3837 3838This is a filter which is exportable. Returns a sub which pops the data out of the input stream and pushes it onto the string. 3839 3840=cut 3841 3842sub new_string_sink { 3843 my ($string_ref) = @_; 3844 3845 return sub { 3846 my ( $in_ref, $out_ref ) = @_; 3847 3848 return input_avail && do { 3849 $$string_ref .= $$in_ref; 3850 $$in_ref = ''; 3851 1; 3852 } 3853 }; 3854} 3855 3856#=item timeout 3857# 3858#This function defines a time interval, starting from when start() is 3859#called, or when timeout() is called. If all processes have not finished 3860#by the end of the timeout period, then a "process timed out" exception 3861#is thrown. 3862# 3863#The time interval may be passed in seconds, or as an end time in 3864#"HH:MM:SS" format (any non-digit other than '.' may be used as 3865#spacing and punctuation). This is probably best shown by example: 3866# 3867# $h->timeout( $val ); 3868# 3869# $val Effect 3870# ======================== ===================================== 3871# undef Timeout timer disabled 3872# '' Almost immediate timeout 3873# 0 Almost immediate timeout 3874# 0.000001 timeout > 0.0000001 seconds 3875# 30 timeout > 30 seconds 3876# 30.0000001 timeout > 30 seconds 3877# 10:30 timeout > 10 minutes, 30 seconds 3878# 3879#Timeouts are currently evaluated with a 1 second resolution, though 3880#this may change in the future. This means that setting 3881#timeout($h,1) will cause a pokey child to be aborted sometime after 3882#one second has elapsed and typically before two seconds have elapsed. 3883# 3884#This sub does not check whether or not the timeout has expired already. 3885# 3886#Returns the number of seconds set as the timeout (this does not change 3887#as time passes, unless you call timeout( val ) again). 3888# 3889#The timeout does not include the time needed to fork() or spawn() 3890#the child processes, though some setup time for the child processes can 3891#included. It also does not include the length of time it takes for 3892#the children to exit after they've closed all their pipes to the 3893#parent process. 3894# 3895#=cut 3896# 3897#sub timeout { 3898# my IPC::Run $self = shift; 3899# 3900# if ( @_ ) { 3901# ( $self->{TIMEOUT} ) = @_; 3902# $self->{TIMEOUT_END} = undef; 3903# if ( defined $self->{TIMEOUT} ) { 3904# if ( $self->{TIMEOUT} =~ /[^\d.]/ ) { 3905# my @f = split( /[^\d\.]+/i, $self->{TIMEOUT} ); 3906# unshift @f, 0 while @f < 3; 3907# $self->{TIMEOUT} = (($f[0]*60)+$f[1])*60+$f[2]; 3908# } 3909# elsif ( $self->{TIMEOUT} =~ /^(\d*)(?:\.(\d*))/ ) { 3910# $self->{TIMEOUT} = $1 + 1; 3911# } 3912# $self->_calc_timeout_end if $self->{STATE} >= _started; 3913# } 3914# } 3915# return $self->{TIMEOUT}; 3916#} 3917# 3918# 3919#sub _calc_timeout_end { 3920# my IPC::Run $self = shift; 3921# 3922# $self->{TIMEOUT_END} = defined $self->{TIMEOUT} 3923# ? time + $self->{TIMEOUT} 3924# : undef; 3925# 3926# ## We add a second because we might be at the very end of the current 3927# ## second, and we want to guarantee that we don't have a timeout even 3928# ## one second less then the timeout period. 3929# ++$self->{TIMEOUT_END} if $self->{TIMEOUT}; 3930#} 3931 3932=pod 3933 3934=item io 3935 3936Takes a filename or filehandle, a redirection operator, optional filters, 3937and a source or destination (depends on the redirection operator). Returns 3938an IPC::Run::IO object suitable for harness()ing (including via start() 3939or run()). 3940 3941This is shorthand for 3942 3943 3944 require IPC::Run::IO; 3945 3946 ... IPC::Run::IO->new(...) ... 3947 3948=cut 3949 3950sub io { 3951 require IPC::Run::IO; 3952 IPC::Run::IO->new(@_); 3953} 3954 3955=pod 3956 3957=item timer 3958 3959 $h = start( \@cmd, \$in, \$out, $t = timer( 5 ) ); 3960 3961 pump $h until $out =~ /expected stuff/ || $t->is_expired; 3962 3963Instantiates a non-fatal timer. pump() returns once each time a timer 3964expires. Has no direct effect on run(), but you can pass a subroutine 3965to fire when the timer expires. 3966 3967See L</timeout> for building timers that throw exceptions on 3968expiration. 3969 3970See L<IPC::Run::Timer/timer> for details. 3971 3972=cut 3973 3974# Doing the prototype suppresses 'only used once' on older perls. 3975sub timer; 3976*timer = \&IPC::Run::Timer::timer; 3977 3978=pod 3979 3980=item timeout 3981 3982 $h = start( \@cmd, \$in, \$out, $t = timeout( 5 ) ); 3983 3984 pump $h until $out =~ /expected stuff/; 3985 3986Instantiates a timer that throws an exception when it expires. 3987If you don't provide an exception, a default exception that matches 3988/^IPC::Run: .*timed out/ is thrown by default. You can pass in your own 3989exception scalar or reference: 3990 3991 $h = start( 3992 \@cmd, \$in, \$out, 3993 $t = timeout( 5, exception => 'slowpoke' ), 3994 ); 3995 3996or set the name used in debugging message and in the default exception 3997string: 3998 3999 $h = start( 4000 \@cmd, \$in, \$out, 4001 timeout( 50, name => 'process timer' ), 4002 $stall_timer = timeout( 5, name => 'stall timer' ), 4003 ); 4004 4005 pump $h until $out =~ /started/; 4006 4007 $in = 'command 1'; 4008 $stall_timer->start; 4009 pump $h until $out =~ /command 1 finished/; 4010 4011 $in = 'command 2'; 4012 $stall_timer->start; 4013 pump $h until $out =~ /command 2 finished/; 4014 4015 $in = 'very slow command 3'; 4016 $stall_timer->start( 10 ); 4017 pump $h until $out =~ /command 3 finished/; 4018 4019 $stall_timer->start( 5 ); 4020 $in = 'command 4'; 4021 pump $h until $out =~ /command 4 finished/; 4022 4023 $stall_timer->reset; # Prevent restarting or expirng 4024 finish $h; 4025 4026See L</timer> for building non-fatal timers. 4027 4028See L<IPC::Run::Timer/timer> for details. 4029 4030=cut 4031 4032# Doing the prototype suppresses 'only used once' on older perls. 4033sub timeout; 4034*timeout = \&IPC::Run::Timer::timeout; 4035 4036=pod 4037 4038=back 4039 4040=head1 FILTER IMPLEMENTATION FUNCTIONS 4041 4042These functions are for use from within filters. 4043 4044=over 4045 4046=item input_avail 4047 4048Returns TRUE if input is available. If none is available, then 4049&get_more_input is called and its result is returned. 4050 4051This is usually used in preference to &get_more_input so that the 4052calling filter removes all data from the $in_ref before more data 4053gets read in to $in_ref. 4054 4055C<input_avail> is usually used as part of a return expression: 4056 4057 return input_avail && do { 4058 ## process the input just gotten 4059 1; 4060 }; 4061 4062This technique allows input_avail to return the undef or 0 that a 4063filter normally returns when there's no input to process. If a filter 4064stores intermediate values, however, it will need to react to an 4065undef: 4066 4067 my $got = input_avail; 4068 if ( ! defined $got ) { 4069 ## No more input ever, flush internal buffers to $out_ref 4070 } 4071 return $got unless $got; 4072 ## Got some input, move as much as need be 4073 return 1 if $added_to_out_ref; 4074 4075=cut 4076 4077sub input_avail() { 4078 confess "Undefined FBUF ref for $filter_num+1" 4079 unless defined $filter_op->{FBUFS}->[ $filter_num + 1 ]; 4080 length ${ $filter_op->{FBUFS}->[ $filter_num + 1 ] } || get_more_input; 4081} 4082 4083=pod 4084 4085=item get_more_input 4086 4087This is used to fetch more input in to the input variable. It returns 4088undef if there will never be any more input, 0 if there is none now, 4089but there might be in the future, and TRUE if more input was gotten. 4090 4091C<get_more_input> is usually used as part of a return expression, 4092see L</input_avail> for more information. 4093 4094=cut 4095 4096## 4097## Filter implementation interface 4098## 4099sub get_more_input() { 4100 ++$filter_num; 4101 my $r = eval { 4102 confess "get_more_input() called and no more filters in chain" 4103 unless defined $filter_op->{FILTERS}->[$filter_num]; 4104 $filter_op->{FILTERS}->[$filter_num]->( 4105 $filter_op->{FBUFS}->[ $filter_num + 1 ], 4106 $filter_op->{FBUFS}->[$filter_num], 4107 ); # if defined ${$filter_op->{FBUFS}->[$filter_num+1]}; 4108 }; 4109 --$filter_num; 4110 die $@ if $@; 4111 return $r; 4112} 4113 41141; 4115 4116=pod 4117 4118=back 4119 4120=head1 TODO 4121 4122These will be addressed as needed and as time allows. 4123 4124Stall timeout. 4125 4126Expose a list of child process objects. When I do this, 4127each child process is likely to be blessed into IPC::Run::Proc. 4128 4129$kid->abort(), $kid->kill(), $kid->signal( $num_or_name ). 4130 4131Write tests for /(full_)?results?/ subs. 4132 4133Currently, pump() and run() only work on systems where select() works on the 4134filehandles returned by pipe(). This does *not* include ActiveState on Win32, 4135although it does work on cygwin under Win32 (thought the tests whine a bit). 4136I'd like to rectify that, suggestions and patches welcome. 4137 4138Likewise start() only fully works on fork()/exec() machines (well, just 4139fork() if you only ever pass perl subs as subprocesses). There's 4140some scaffolding for calling Open3::spawn_with_handles(), but that's 4141untested, and not that useful with limited select(). 4142 4143Support for C<\@sub_cmd> as an argument to a command which 4144gets replaced with /dev/fd or the name of a temporary file containing foo's 4145output. This is like <(sub_cmd ...) found in bash and csh (IIRC). 4146 4147Allow multiple harnesses to be combined as independent sets of processes 4148in to one 'meta-harness'. 4149 4150Allow a harness to be passed in place of an \@cmd. This would allow 4151multiple harnesses to be aggregated. 4152 4153Ability to add external file descriptors w/ filter chains and endpoints. 4154 4155Ability to add timeouts and timing generators (i.e. repeating timeouts). 4156 4157High resolution timeouts. 4158 4159=head1 Win32 LIMITATIONS 4160 4161=over 4162 4163=item Fails on Win9X 4164 4165If you want Win9X support, you'll have to debug it or fund me because I 4166don't use that system any more. The Win32 subsysem has been extended to 4167use temporary files in simple run() invocations and these may actually 4168work on Win9X too, but I don't have time to work on it. 4169 4170=item May deadlock on Win2K (but not WinNT4 or WinXPPro) 4171 4172Spawning more than one subprocess on Win2K causes a deadlock I haven't 4173figured out yet, but simple uses of run() often work. Passes all tests 4174on WinXPPro and WinNT. 4175 4176=item no support yet for <pty< and >pty> 4177 4178These are likely to be implemented as "<" and ">" with binmode on, not 4179sure. 4180 4181=item no support for file descriptors higher than 2 (stderr) 4182 4183Win32 only allows passing explicit fds 0, 1, and 2. If you really, really need to pass file handles, us Win32API:: GetOsFHandle() or ::FdGetOsFHandle() to 4184get the integer handle and pass it to the child process using the command 4185line, environment, stdin, intermediary file, or other IPC mechanism. Then 4186use that handle in the child (Win32API.pm provides ways to reconstitute 4187Perl file handles from Win32 file handles). 4188 4189=item no support for subroutine subprocesses (CODE refs) 4190 4191Can't fork(), so the subroutines would have no context, and closures certainly 4192have no meaning 4193 4194Perhaps with Win32 fork() emulation, this can be supported in a limited 4195fashion, but there are other very serious problems with that: all parent 4196fds get dup()ed in to the thread emulating the forked process, and that 4197keeps the parent from being able to close all of the appropriate fds. 4198 4199=item no support for init => sub {} routines. 4200 4201Win32 processes are created from scratch, there is no way to do an init 4202routine that will affect the running child. Some limited support might 4203be implemented one day, do chdir() and %ENV changes can be made. 4204 4205=item signals 4206 4207Win32 does not fully support signals. signal() is likely to cause errors 4208unless sending a signal that Perl emulates, and C<kill_kill()> is immediately 4209fatal (there is no grace period). 4210 4211=item helper processes 4212 4213IPC::Run uses helper processes, one per redirected file, to adapt between the 4214anonymous pipe connected to the child and the TCP socket connected to the 4215parent. This is a waste of resources and will change in the future to either 4216use threads (instead of helper processes) or a WaitForMultipleObjects call 4217(instead of select). Please contact me if you can help with the 4218WaitForMultipleObjects() approach; I haven't figured out how to get at it 4219without C code. 4220 4221=item shutdown pause 4222 4223There seems to be a pause of up to 1 second between when a child program exits 4224and the corresponding sockets indicate that they are closed in the parent. 4225Not sure why. 4226 4227=item binmode 4228 4229binmode is not supported yet. The underpinnings are implemented, just ask 4230if you need it. 4231 4232=item IPC::Run::IO 4233 4234IPC::Run::IO objects can be used on Unix to read or write arbitrary files. On 4235Win32, they will need to use the same helper processes to adapt from 4236non-select()able filehandles to select()able ones (or perhaps 4237WaitForMultipleObjects() will work with them, not sure). 4238 4239=item startup race conditions 4240 4241There seems to be an occasional race condition between child process startup 4242and pipe closings. It seems like if the child is not fully created by the time 4243CreateProcess returns and we close the TCP socket being handed to it, the 4244parent socket can also get closed. This is seen with the Win32 pumper 4245applications, not the "real" child process being spawned. 4246 4247I assume this is because the kernel hasn't gotten around to incrementing the 4248reference count on the child's end (since the child was slow in starting), so 4249the parent's closing of the child end causes the socket to be closed, thus 4250closing the parent socket. 4251 4252Being a race condition, it's hard to reproduce, but I encountered it while 4253testing this code on a drive share to a samba box. In this case, it takes 4254t/run.t a long time to spawn it's child processes (the parent hangs in the 4255first select for several seconds until the child emits any debugging output). 4256 4257I have not seen it on local drives, and can't reproduce it at will, 4258unfortunately. The symptom is a "bad file descriptor in select()" error, and, 4259by turning on debugging, it's possible to see that select() is being called on 4260a no longer open file descriptor that was returned from the _socket() routine 4261in Win32Helper. There's a new confess() that checks for this ("PARENT_HANDLE 4262no longer open"), but I haven't been able to reproduce it (typically). 4263 4264=back 4265 4266=head1 LIMITATIONS 4267 4268On Unix, requires a system that supports C<waitpid( $pid, WNOHANG )> so 4269it can tell if a child process is still running. 4270 4271PTYs don't seem to be non-blocking on some versions of Solaris. Here's a 4272test script contributed by Borislav Deianov <borislav@ensim.com> to see 4273if you have the problem. If it dies, you have the problem. 4274 4275 #!/usr/bin/perl 4276 4277 use IPC::Run qw(run); 4278 use Fcntl; 4279 use IO::Pty; 4280 4281 sub makecmd { 4282 return ['perl', '-e', 4283 '<STDIN>, print "\n" x '.$_[0].'; while(<STDIN>){last if /end/}']; 4284 } 4285 4286 #pipe R, W; 4287 #fcntl(W, F_SETFL, O_NONBLOCK); 4288 #while (syswrite(W, "\n", 1)) { $pipebuf++ }; 4289 #print "pipe buffer size is $pipebuf\n"; 4290 my $pipebuf=4096; 4291 my $in = "\n" x ($pipebuf * 2) . "end\n"; 4292 my $out; 4293 4294 $SIG{ALRM} = sub { die "Never completed!\n" }; 4295 4296 print "reading from scalar via pipe..."; 4297 alarm( 2 ); 4298 run(makecmd($pipebuf * 2), '<', \$in, '>', \$out); 4299 alarm( 0 ); 4300 print "done\n"; 4301 4302 print "reading from code via pipe... "; 4303 alarm( 2 ); 4304 run(makecmd($pipebuf * 3), '<', sub { $t = $in; undef $in; $t}, '>', \$out); 4305 alarm( 0 ); 4306 print "done\n"; 4307 4308 $pty = IO::Pty->new(); 4309 $pty->blocking(0); 4310 $slave = $pty->slave(); 4311 while ($pty->syswrite("\n", 1)) { $ptybuf++ }; 4312 print "pty buffer size is $ptybuf\n"; 4313 $in = "\n" x ($ptybuf * 3) . "end\n"; 4314 4315 print "reading via pty... "; 4316 alarm( 2 ); 4317 run(makecmd($ptybuf * 3), '<pty<', \$in, '>', \$out); 4318 alarm(0); 4319 print "done\n"; 4320 4321No support for ';', '&&', '||', '{ ... }', etc: use perl's, since run() 4322returns TRUE when the command exits with a 0 result code. 4323 4324Does not provide shell-like string interpolation. 4325 4326No support for C<cd>, C<setenv>, or C<export>: do these in an init() sub 4327 4328 run( 4329 \cmd, 4330 ... 4331 init => sub { 4332 chdir $dir or die $!; 4333 $ENV{FOO}='BAR' 4334 } 4335 ); 4336 4337Timeout calculation does not allow absolute times, or specification of 4338days, months, etc. 4339 4340B<WARNING:> Function coprocesses (C<run \&foo, ...>) suffer from two 4341limitations. The first is that it is difficult to close all filehandles the 4342child inherits from the parent, since there is no way to scan all open 4343FILEHANDLEs in Perl and it both painful and a bit dangerous to close all open 4344file descriptors with C<POSIX::close()>. Painful because we can't tell which 4345fds are open at the POSIX level, either, so we'd have to scan all possible fds 4346and close any that we don't want open (normally C<exec()> closes any 4347non-inheritable but we don't C<exec()> for &sub processes. 4348 4349The second problem is that Perl's DESTROY subs and other on-exit cleanup gets 4350run in the child process. If objects are instantiated in the parent before the 4351child is forked, the DESTROY will get run once in the parent and once in 4352the child. When coprocess subs exit, POSIX::_exit is called to work around this, 4353but it means that objects that are still referred to at that time are not 4354cleaned up. So setting package vars or closure vars to point to objects that 4355rely on DESTROY to affect things outside the process (files, etc), will 4356lead to bugs. 4357 4358I goofed on the syntax: "<pipe" vs. "<pty<" and ">filename" are both 4359oddities. 4360 4361=head1 TODO 4362 4363=over 4364 4365=item Allow one harness to "adopt" another: 4366 4367 $new_h = harness \@cmd2; 4368 $h->adopt( $new_h ); 4369 4370=item Close all filehandles not explicitly marked to stay open. 4371 4372The problem with this one is that there's no good way to scan all open 4373FILEHANDLEs in Perl, yet you don't want child processes inheriting handles 4374willy-nilly. 4375 4376=back 4377 4378=head1 INSPIRATION 4379 4380Well, select() and waitpid() badly needed wrapping, and open3() isn't 4381open-minded enough for me. 4382 4383The shell-like API inspired by a message Russ Allbery sent to perl5-porters, 4384which included: 4385 4386 I've thought for some time that it would be 4387 nice to have a module that could handle full Bourne shell pipe syntax 4388 internally, with fork and exec, without ever invoking a shell. Something 4389 that you could give things like: 4390 4391 pipeopen (PIPE, [ qw/cat file/ ], '|', [ 'analyze', @args ], '>&3'); 4392 4393Message ylln51p2b6.fsf@windlord.stanford.edu, on 2000/02/04. 4394 4395=head1 SUPPORT 4396 4397Bugs should always be submitted via the GitHub bug tracker 4398 4399L<https://github.com/toddr/IPC-Run/issues> 4400 4401=head1 AUTHORS 4402 4403Adam Kennedy <adamk@cpan.org> 4404 4405Barrie Slaymaker <barries@slaysys.com> 4406 4407=head1 COPYRIGHT 4408 4409Some parts copyright 2008 - 2009 Adam Kennedy. 4410 4411Copyright 1999 Barrie Slaymaker. 4412 4413You may distribute under the terms of either the GNU General Public 4414License or the Artistic License, as specified in the README file. 4415 4416=cut 4417