tools/cmake/scripts/IPC/Run.pm

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