8 IPC::Run - system() and background procs w/ piping, redirs, ptys (Unix, Win32)
12 ## First,a command to run:
15 ## Using run() instead of system():
16 use IPC::Run qw( run timeout );
18 run \@cmd, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?"
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";
25 # Redirecting using psuedo-terminals instad of pipes.
26 run \@cat, '<pty<', \$in, '>pty>', \$out_and_err;
28 ## Scripting subprocesses (like Expect):
30 use IPC::Run qw( start pump finish timeout );
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 );
39 $in .= "some input\n";
40 pump $h until $out =~ /input\n/g;
42 $in .= "some more input\n";
43 pump $h until $out =~ /\G.*more input\n/;
45 $in .= "some final input\n";
46 finish $h or die "cat returned $?";
49 print $out; ## All of cat's output
51 # Piping between children
52 run \@cat, '|', \@gzip;
54 # Multiple children simultaneously (run() blocks until all
55 # children exit, use start() for background execution):
56 run \@foo1, '&', \@foo2;
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;
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";
74 # Create pipes for you to read / write (like IPC::Open2 & 3).
80 or die "cat returned $?";
81 print IN "some input\n";
86 # Mixing input and output modes
87 run \@cat, 'in.txt', \&catch_some_out, \*ERR_LOG );
89 # Other redirection constructs
90 run \@cat, '>&', \$out_and_err;
94 run \@cat, '3<', \$in3;
95 run \@cat, '4>', \$out4;
99 run \@cat, 'in.txt', debug => 1;
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 $?";
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
108 $r = run "cat a b c";
110 # Read from a file in to a scalar
111 run io( "filename", 'r', \$recv );
112 run io( \*HANDLE, 'r', \$recv );
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
121 Various redirection operators reminiscent of those seen on common Unix and DOS
122 command lines are provided.
124 Before digging in to the details a few LIMITATIONS are important enough
125 to be mentioned right up front:
131 Win32 support is working but B<EXPERIMENTAL>, but does pass all relevant tests
132 on NT 4.0. See L</Win32 LIMITATIONS>.
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.
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 :(.
146 ptys are not supported yet under Win32, but will be emulated...
150 You may use the environment variable C<IPCRUNDEBUG> to see what's going on
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.
161 We now return you to your regularly scheduled documentation.
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.
168 =head2 run() vs. start(); pump(); finish();
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.
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:
179 run \@cmd, \<<IN, \$out;
183 ## To precompile harnesses and run them later:
184 my $h = harness \@cmd, \<<IN, \$out;
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
196 ## Build the harness, open all pipes, and launch the subprocesses
197 my $h = start \@cat, \$in, \$out;
198 $in = "first input\n";
200 ## Now do I/O. start() does no I/O.
201 pump $h while length $in; ## Wait for all input to go
203 ## Now do some more I/O.
204 $in = "second input\n";
205 pump $h until $out =~ /second input/;
208 finish $h or die "cat returned $?";
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
215 =head2 Using regexps to match output
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.
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:
229 $h = harness \@smbclient, \$in, \$out;
232 $h->pump until $out =~ /^smb.*> \Z/m;
233 die "error cding to /src:\n$out" if $out =~ "ERR";
237 $h->pump until $out =~ /^smb.*> \Z/m;
238 die "error retrieving files:\n$out" if $out =~ "ERR";
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.
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:
258 $h = harness \@smbclient, \$in, \$out;
261 $h->pump until $out =~ /^smb.*> \Z/mgc;
262 die "error cding to /src:\n$out" if $out =~ "ERR";
265 $h->pump until $out =~ /^smb.*> \Z/mgc;
266 die "error retrieving files:\n$out" if $out =~ "ERR";
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:
279 my $out = "x" x 10_000;
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.
285 =head2 Timeouts and Timers
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.
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.
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.
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).
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.
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:
320 ## Start with a nice long timeout to let smbclient connect. If
321 ## pump or finish take too long, an exception will be thrown.
325 $h = harness \@smbclient, \$in, \$out, \$err, ( my $t = timeout 30 );
326 sleep 11; # No effect: timer not running yet
330 pump $h until ! length $in;
333 ## Now use a short timeout, since this should be faster
335 pump $h until ! length $in;
337 $t->start( 10 ); ## Give smbclient a little while to shut down.
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.
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
352 =head2 Spawning synchronization, child exception propagation
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.
360 This includes exceptions your code thrown from init subs. In this
364 run \@cmd, init => sub { die "blast it! foiled again!" };
368 the exception "blast it! foiled again" will be thrown from the child
369 process (preventing the exec()) and printed by the parent.
373 run \@cmd1, "|", \@cmd2, "|", \@cmd3;
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>.
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.
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.
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.
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.
403 B<Win32>: executing CODE references isn't supported on Win32, see
404 L</Win32 LIMITATIONS> for details.
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:
412 run "echo 'hi there'";
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:
420 run \@cmd1, '|', \@cmd2;
421 run \@cmd1, '&', \@cmd2;
423 run \&sub1, '|', \&sub2;
424 run \&sub1, '&', \&sub2;
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.
430 L<IPC::Run::IO> objects may be passed in as well, whether or not
431 child processes are also specified:
433 run io( "infile", ">", \$in ), io( "outfile", "<", \$in );
435 as can L<IPC::Run::Timer> objects:
437 run \@cmd, io( "outfile", "<", \$in ), timeout( 10 );
439 Commands may be followed by scalar, sub, or i/o handle references for
441 child process input & output:
443 run \@cmd, \undef, \$out;
444 run \@cmd, \$in, \$out;
445 run \@cmd1, \&in, '|', \@cmd2, \*OUT;
446 run \@cmd1, \*IN, '|', \@cmd2, \&out;
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.
455 To be explicit about your redirects, or if you need to do more complex
456 things, there's also a redirection operator syntax:
458 run \@cmd, '<', \undef, '>', \$out;
459 run \@cmd, '<', \undef, '>&', \$out_and_err;
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
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.
475 operator syntax mode, parsing only reverts to succinct mode when a '|' or
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.
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.
495 If you want to close a child processes stdin, you may do any of:
502 Redirection is done by placing redirection specifications immediately
503 after a command or child subroutine:
505 run \@cmd1, \$in, '|', \@cmd2, \$out;
506 run \@cmd1, '<', \$in, '|', \@cmd2, '>', \$out;
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
513 run \@cmd1, \$in, '|', \@cmd2, \$out;
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
519 If it's a scalar ref, the child reads input from or sends output to
522 $in = "Hello World.\n";
523 run \@cat, \$in, \$out;
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.
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.
534 $h = start \@cat, \$in;
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.
545 =head1 OBSTINATE CHILDREN
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.
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.
560 Here are some of the issues you might need to be aware of.
566 fflush()ing stdout and stderr
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.
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.
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>').
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
588 This can make it hard to guarantee that your output parser won't be fooled
589 into early termination of results.
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
595 You should also look for your prompt to be the only thing on a line:
597 pump $h until $out =~ /^<SILLYPROMPT>\s?\z/m;
599 (use C<(?!\n)\Z> in place of C<\z> on older perls).
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.
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
614 Refusing to accept input unless stdin is a tty.
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.
620 If this is your situation, use a pseudo terminal ('<pty<' and '>pty>').
624 Not prompting unless connected to a tty.
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
635 Different output format when not connected to a tty.
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.
642 =head1 PSEUDO TERMINALS
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
651 Psuedo-terminals are not pipes, though they are similar. Here are some
652 differences to watch out for.
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.
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.
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.
673 =item Command line editing
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.
679 =item '>pty>' means '&>pty>', not '1>pty>'
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:
684 start \@cmd, '<pty<', \$in, '>pty>', \$out, '2>', \$err;
686 =item stdin, stdout, and stderr not inherited
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.
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.
699 =head2 Redirection Operators
701 Operator SHNP Description
702 ======== ==== ===========
703 <, N< SHN Redirects input to a child's fd N (0 assumed)
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
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
712 N<&M Dups input fd N to input fd M
713 M>&N Dups output fd N to input fd M
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.
719 'N' and 'M' are placeholders for integer file descriptor numbers. The
720 terms 'input' and 'output' are from the child process's perspective.
722 The SHNP field indicates what parameters an operator can take:
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
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).
733 =item Redirecting input: [n]<, [n]<pipe
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.
739 run \@cat, \undef ## Closes child's stdin immediately
740 or die "cat returned $?";
744 run \@cat, \<<TOHERE;
748 run \@cat, \&input; ## Calls &input, feeding data returned
749 ## to child's. Closes child's stdin
750 ## when undef is returned.
752 Redirecting from named files requires you to use the input
753 redirection operator:
755 run \@cat, '<.profile';
756 run \@cat, '<', '.profile';
762 The form used second example here is the safest,
763 since filenames like "0" and "&more\n" won't confuse &run:
765 You can't do either of
767 run \@a, *IN; ## INVALID
768 run \@a, '<', *IN; ## BUGGY: Reads file named like "*main::A"
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.
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.):
779 run \@cat, '3<', \$in3;
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.
786 The <pipe operator opens the write half of a pipe on the filehandle
787 glob reference it takes as an argument:
789 $h = start \@cat, '<pipe', \*IN;
790 print IN "hello world\n";
795 Unlike the other '<' operators, IPC::Run does nothing further with
796 it: you are responsible for it. The previous example is functionally
799 pipe( \*R, \*IN ) or die $!;
800 $h = start \@cat, '<', \*IN;
801 print IN "hello world\n";
806 This is like the behavior of IPC::Open2 and IPC::Open3.
808 B<Win32>: The handle returned is actually a socket handle, so you can
811 =item Redirecting output: [n]>, [n]>>, [n]>&[m], [n]>pipe
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
821 run \@ls, \undef, \$out
822 or die "ls returned $?";
824 run \@ls, \undef, \&out; ## Calls &out each time some output
825 ## is received from the child's
826 ## when undef is returned.
828 run \@ls, \undef, '2>ls.err';
829 run \@ls, '2>', 'ls.err';
831 The two parameter form guarantees that the filename
832 will not be interpreted as a redirection operator:
834 run \@ls, '>', "&more";
835 run \@ls, '2>', ">foo\n";
837 You can pass file handles you've opened for writing:
839 open( *OUT, ">out.txt" );
840 open( *ERR, ">err.txt" );
841 run \@cat, \*OUT, \*ERR;
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:
847 These two do the same things:
849 run( [ 'ls' ], '2>', sub { $err_out .= $_[0] } );
851 does the same basic thing as:
853 run( [ 'ls' ], '2>', \$err_out );
855 The subroutine will be called each time some data is read from the child.
857 The >pipe operator is different in concept than the other '>' operators,
858 although it's syntax is similar:
860 $h = start \@cat, $in, '>pipe', \*OUT, '2>pipe', \*ERR;
861 $in = "hello world\n";
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.
874 B<Win32>: The handle returned is actually a socket handle, so you can
877 =item Duplicating output descriptors: >&m, n>&m
879 This duplicates output descriptor number n (default is 1 if n is omitted)
880 from descriptor number m.
882 =item Duplicating input descriptors: <&m, n<&m
884 This duplicates input descriptor number n (default is 0 if n is omitted)
885 from descriptor number m
887 =item Closing descriptors: <&-, 3<&-
889 This closes descriptor number n (default is 0 if n is omitted). The
890 following commands are equivalent:
894 run \@cmd, '<in.txt', '<&-';
898 run \@cmd, \$in, '<&-'; ## SIGPIPE recipe.
900 is dangerous: the parent will get a SIGPIPE if $in is not empty.
902 =item Redirecting both stdout and stderr: &>, >&, &>pipe, >pipe&
904 The following pairs of commands are equivalent:
906 run \@cmd, '>&', \$out; run \@cmd, '>', \$out, '2>&1';
907 run \@cmd, '>&', 'out.txt'; run \@cmd, '>', 'out.txt', '2>&1';
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.
914 The '&>pipe' and '>pipe&' variants behave like the '>pipe' operator, except
915 that both stdout and stderr write to the created pipe.
917 =item Redirection Filters
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
928 '<', \&in_filter_2, \&in_filter_1, $in,
929 '>', \&out_filter_1, \&in_filter_2, $out,
932 This capability is not provided for IO handles or named files.
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:
940 '<', new_appender( "\n" ), $in,
941 '>', new_chunker, $out,
946 =head2 Just doing I/O
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
952 run io( "filename", '>', \$recv );
954 $h = start io( $io, '>', \$recv );
956 $h = harness \@cmd, '&', io( "file", '<', \$send );
960 Options are passed in as name/value pairs:
962 run \@cat, \$in, debug => 1;
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:
967 run debug => 1, \@cat, \$in;
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).
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:
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
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>.
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.
1015 use vars qw{$VERSION @ISA @FILTER_IMP @FILTERS @API @EXPORT_OK %EXPORT_TAGS};
1018 @ISA = qw{ Exporter };
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 );
1032 harness start pump pumpable finish
1033 signal kill_kill reap_nb
1038 @EXPORT_OK = ( @API, @FILTER_IMP, @FILTERS, qw( Win32_MODE ) );
1040 'filter_imp' => \@FILTER_IMP,
1041 'all' => \@EXPORT_OK,
1042 'filters' => \@FILTERS,
1049 use IPC::Run::Debug;
1053 BEGIN { if ($] < 5.008) { require Symbol; } }
1057 require IPC::Run::IO;
1058 require IPC::Run::Timer;
1061 use constant Win32_MODE => $^O =~ /os2|Win32/i;
1065 eval "use IPC::Run::Win32Helper; 1;"
1066 or ( $@ && die ) or die "$!";
1069 eval "use File::Basename; 1;" or die $!;
1074 sub get_more_input();
1076 ###############################################################################
1079 ## Error constants, not too locale-dependant
1080 use vars qw( $_EIO $_EAGAIN );
1081 use Errno qw( EIO EAGAIN );
1084 $! = EIO; $_EIO = qr/^$!/;
1085 $! = EAGAIN; $_EAGAIN = qr/^$!/;
1089 ## State machine states, set in $self->{STATE}
1091 ## These must be in ascending order numerically
1095 sub _finished() {2} ## _finished behave almost exactly like _harnessed
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.
1105 ## There's a bit of hackery going on here.
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
1112 ## Thus, $cur_self was born.
1114 use vars qw( $cur_self );
1117 return fileno STDERR unless defined $cur_self;
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;
1126 return fileno STDERR unless defined $cur_self->{DEBUG_FD};
1128 return $cur_self->{DEBUG_FD}
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;
1141 ## Support routines (NOT METHODS)
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;
1164 && ( $cmd_name =~ /$dirsep/ )
1165 # && ( $cmd_name !~ /\..+$/ ) ## Only run if cmd_name has no extension?
1166 && ( $cmd_name !~ m!\.[^\\/\.]+$! )
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 _;
1174 _debug "cmd_name is now '$cmd_name'" if _debugging;
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;
1185 if ( exists $cmd_cache{$cmd_name} ) {
1186 _debug "'$cmd_name' found in cache: '$cmd_cache{$cmd_name}'"
1188 return $cmd_cache{$cmd_name} if -x $cmd_cache{$cmd_name};
1189 _debug "'$cmd_cache{$cmd_name}' no longer executable, searching..."
1191 delete $cmd_cache{$cmd_name};
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/:/;
1202 for ( split( $re, $ENV{PATH} || '', -1 ) ) {
1203 $_ = "." unless length $_;
1204 push @searched_in, $_;
1206 my $prospect = File::Spec->catfile( $_, $cmd_name );
1210 ( Win32_MODE && ! ( -f $prospect && -x _ ) )
1211 ? map "$prospect$_", split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE"
1214 for my $found ( @prospects ) {
1215 if ( -f $found && -x _ ) {
1216 $cmd_cache{$cmd_name} = $found;
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};
1228 croak "Command '$cmd_name' not found in " . join( ", ", @searched_in );
1232 sub _empty($) { ! ( defined $_[0] && length $_[0] ) }
1234 ## 'safe' versions of otherwise fun things to do. See also IPC::Run::Win32Helper.
1236 confess 'undef' unless defined $_[0];
1237 my $fd = $_[0] =~ /^\d+$/ ? $_[0] : fileno $_[0];
1238 my $r = POSIX::close $fd;
1239 $r = $r ? '' : " ERROR $!";
1241 _debug "close( $fd ) = " . ( $r || 0 ) if _debugging_details;
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;
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;
1266 confess 'undef passed' if grep !defined, @_;
1267 # exec @_ or croak "$!: exec( " . join( ', ', @_ ) . " )";
1268 _debug 'exec()ing ', join " ", map "'$_'", @_ if _debugging_details;
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";
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
1285 # croak "$!: exec( " . join( ', ', map "'$_'", @_ ) . " )";
1286 ## Fall through so $! can be reported to parent.
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"
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;
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.
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;
1335 ( $r, $w ) = ( _dup( $r ), _dup( $w ) );
1336 _debug "pipe_nb() = ( $r, $w )" if _debugging_details;
1342 my $pty = IO::Pty->new();
1343 croak "$!: pty ()" unless $pty;
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;
1354 confess 'undef' unless defined $_[0];
1356 my $r = POSIX::read( $_[0], $s, 10_000 );
1357 croak "$!: read( $_[0] )" if not($r) and $! != POSIX::EINTR;
1359 _debug "read( $_[0] ) = $r chars '$s'" if _debugging_data;
1364 ## A METHOD, not a function.
1366 my IPC::Run $self = shift;
1369 _debug "opening sync pipe ", $kid->{PID} if _debugging_details;
1371 ( $sync_reader_fd, $self->{SYNC_WRITER_FD} ) = _pipe;
1372 $kid->{PID} = fork();
1373 croak "$! during fork" unless defined $kid->{PID};
1375 unless ( $kid->{PID} ) {
1376 ## _do_kid_and_exit closes sync_reader_fd since it closes all unwanted and
1378 $self->_do_kid_and_exit( $kid );
1380 _debug "fork() = ", $kid->{PID} if _debugging_details;
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;
1387 if ( ! defined $sync_pulse || length $sync_pulse ) {
1388 if ( waitpid( $kid->{PID}, 0 ) >= 0 ) {
1389 $kid->{RESULT} = $?;
1392 $kid->{RESULT} = -1;
1395 "error reading synchronization pipe for $kid->{NUM}, pid $kid->{PID}"
1396 unless length $sync_pulse;
1401 ## Wait for pty to get set up. This is a hack until we get synchronous
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.";
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;
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.
1430 You may think of C<run( ... )> as being like
1432 start( ... )->finish();
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).
1439 If any exceptions are thrown, this does a L</kill_kill> before propagating
1444 use vars qw( $in_run ); ## No, not Enron;)
1447 local $in_run = 1; ## Allow run()-only optimizations.
1448 my IPC::Run $self = start( @_ );
1450 $self->{clear_ins} = 0;
1465 ## To send it a specific signal by name ("USR1"):
1467 $h->signal ( "USR1" );
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.
1473 Throws an exception if $signal is undef.
1475 This will I<not> clean up the harness, C<finish> it if you kill it.
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.
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.
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.
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.
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:
1498 sub usr1_handler { ++$got_signal }
1500 $SIG{USR1} = \&usr1_handler;
1501 while () { sleep 1; print "GOT IT" while $got_usr1--; }
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).
1509 my IPC::Run $self = shift;
1511 local $cur_self = $self;
1513 $self->_kill_kill_kill_pussycat_kill unless @_;
1515 Carp::cluck "Ignoring extra parameters passed to kill()" if @_ > 1;
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}"
1522 kill $signal, $_->{PID}
1523 or _debugging && _debug "$! sending $signal to $_->{PID}";
1533 ## To kill off a process:
1537 ## To specify the grace period other than 30 seconds:
1538 kill_kill $h, grace => 5;
1540 ## To send QUIT instead of KILL if a process refuses to die:
1541 kill_kill $h, coup_d_grace => "QUIT";
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>.
1546 Will wait for up to 30 more seconds for the OS to successfully C<KILL> the
1549 The 30 seconds may be overridden by setting the C<grace> option, this
1550 overrides both timers.
1552 The harness is then cleaned up.
1554 The doubled name indicates that this function may kill again and avoids
1555 colliding with the core Perl C<kill> function.
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
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.
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
1572 my IPC::Run $self = shift;
1575 my $grace = $options{grace};
1576 $grace = 30 unless defined $grace;
1577 ++$grace; ## Make grace time a _minimum_
1579 my $coup_d_grace = $options{coup_d_grace};
1580 $coup_d_grace = "KILL" unless defined $coup_d_grace;
1582 delete $options{$_} for qw( grace coup_d_grace );
1583 Carp::cluck "Ignoring unknown options for kill_kill: ",
1584 join " ",keys %options
1587 $self->signal( "TERM" );
1589 my $quitting_time = time + $grace;
1593 my $have_killed_before;
1596 ## delay first to yield to other processes
1597 select undef, undef, undef, $delay;
1598 $accum_delay += $delay;
1601 last unless $self->_running_kids;
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;
1614 croak "Unable to reap all children, even after KILLing them"
1619 $delay = 0.5 if $delay >= 0.5;
1623 return $have_killed_before;
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.
1634 harness() is provided so that you can pre-build harnesses if you
1635 would like to, but it's not required..
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.
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.
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.
1657 if ( @_ && ref $_[-1] eq 'HASH' ) {
1659 require Data::Dumper;
1660 carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper( $options );
1663 # local $IPC::Run::debug = $options->{debug}
1664 # if $options && defined $options->{debug};
1667 if ( @_ == 1 && ! ref $_[0] ) {
1669 my $command = $ENV{ComSpec} || 'cmd';
1670 @args = ( [ $command, '/c', win32_parse_cmd_line $_[0] ] );
1673 @args = ( [ qw( sh -c ), @_ ] );
1676 elsif ( @_ > 1 && ! grep ref $_, @_ ) {
1683 my @errs; # Accum errors, emit them when done.
1685 my $succinct; # set if no redir ops are required yet. Cleared
1688 my $cur_kid; # references kid or handle being parsed
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
1693 my IPC::Run $self = bless {}, __PACKAGE__;
1695 local $cur_self = $self;
1697 $self->{ID} = ++$harness_id;
1700 $self->{PIPES} = [];
1702 $self->{STATE} = _newed;
1705 $self->{$_} = $options->{$_}
1709 _debug "****** harnessing *****" if _debugging;
1713 my $arg_count = @args;
1714 while ( @args ) { for ( shift @args ) {
1721 ? ( '[ ', join( ', ', map "'$_'", @$_ ), ' ]' )
1725 : join( '', "'", substr( $_, 0, 10 ), "...'" )
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";
1739 NUM => @{$self->{KIDS}} + 1,
1744 push @{$self->{KIDS}}, $cur_kid;
1748 elsif ( UNIVERSAL::isa( $_, 'IPC::Run::IO' ) ) {
1749 push @{$self->{IOS}}, $_;
1754 elsif ( UNIVERSAL::isa( $_, 'IPC::Run::Timer' ) ) {
1755 push @{$self->{TIMERS}}, $_;
1760 elsif ( /^(\d*)>&(\d+)$/ ) {
1761 croak "No command before '$_'" unless $cur_kid;
1762 push @{$cur_kid->{OPS}}, {
1765 KFD2 => length $1 ? $1 : 1,
1767 _debug "redirect operators now required" if _debugging_details;
1768 $succinct = ! $first_parse;
1771 elsif ( /^(\d*)<&(\d+)$/ ) {
1772 croak "No command before '$_'" unless $cur_kid;
1773 push @{$cur_kid->{OPS}}, {
1776 KFD2 => length $1 ? $1 : 0,
1778 $succinct = ! $first_parse;
1781 elsif ( /^(\d*)<&-$/ ) {
1782 croak "No command before '$_'" unless $cur_kid;
1783 push @{$cur_kid->{OPS}}, {
1785 KFD => length $1 ? $1 : 0,
1787 $succinct = ! $first_parse;
1791 /^(\d*) (<pipe)() () () $/x
1792 || /^(\d*) (<pty) ((?:\s+\S+)?) (<) () $/x
1793 || /^(\d*) (<) () () (.*)$/x
1795 croak "No command before '$_'" unless $cur_kid;
1797 $succinct = ! $first_parse;
1801 my $kfd = length $1 ? $1 : 0;
1804 if ( $type eq '<pty<' ) {
1805 $pty_id = length $3 ? $3 : '0';
1806 ## do the require here to cause early error reporting
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;
1818 unless ( length $source ) {
1819 if ( ! $succinct ) {
1822 ( ref $args[1] && ! UNIVERSAL::isa $args[1], "IPC::Run::Timer" )
1823 || UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter"
1826 if ( UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
1827 $binmode = shift( @args )->();
1830 push @filters, shift @args
1834 $source = shift @args;
1835 croak "'$_' missing a source" if _empty $source;
1838 'Kid ', $cur_kid->{NUM}, "'s input fd ", $kfd,
1839 ' has ', scalar( @filters ), ' filters.'
1840 ) if _debugging_details && @filters;
1843 my IPC::Run::IO $pipe = IPC::Run::IO->_new_internal(
1844 $type, $kfd, $pty_id, $source, $binmode, @filters
1847 if ( ( ref $source eq 'GLOB' || UNIVERSAL::isa $source, 'IO::Handle' )
1848 && $type !~ /^<p(ty<|ipe)$/
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;
1855 push @{$cur_kid->{OPS}}, $pipe;
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
1868 croak "No command before '$_'" unless $cur_kid;
1870 $succinct = ! $first_parse;
1873 $2 eq '>pipe' || $3 eq '>pipe'
1875 : $2 eq '>pty' || $3 eq '>pty'
1879 my $kfd = length $1 ? $1 : 1;
1880 my $trunc = ! ( $2 eq '>>' || $3 eq '>>' );
1882 $2 eq '>pty' || $3 eq '>pty'
1883 ? length $4 ? $4 : 0
1890 || ( ! length $1 && substr( $type, 0, 4 ) eq '>pty' );
1895 unless ( length $dest ) {
1896 if ( ! $succinct ) {
1897 ## unshift...shift: '>' filters source...sink left...right
1900 ( ref $args[1] && ! UNIVERSAL::isa $args[1], "IPC::Run::Timer" )
1901 || UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter"
1904 if ( UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
1905 $binmode = shift( @args )->();
1908 unshift @filters, shift @args;
1913 $dest = shift @args;
1916 'Kid ', $cur_kid->{NUM}, "'s output fd ", $kfd,
1917 ' has ', scalar( @filters ), ' filters.'
1918 ) if _debugging_details && @filters;
1920 if ( $type eq '>pty>' ) {
1921 ## do the require here to cause early error reporting
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;
1929 croak "'$_' missing a destination" if _empty $dest;
1930 my $pipe = IPC::Run::IO->_new_internal(
1931 $type, $kfd, $pty_id, $dest, $binmode, @filters
1933 $pipe->{TRUNC} = $trunc;
1935 if ( ( UNIVERSAL::isa( $dest, 'GLOB' ) || UNIVERSAL::isa( $dest, 'IO::Handle' ) )
1936 && $type !~ /^>(pty>|pipe)$/
1938 _debug "setting DONT_CLOSE" if _debugging_details;
1939 $pipe->{DONT_CLOSE} = 1; ## this FD is not closed by us.
1941 push @{$cur_kid->{OPS}}, $pipe;
1942 push @{$cur_kid->{OPS}}, {
1949 elsif ( $_ eq "|" ) {
1950 croak "No command before '$_'" unless $cur_kid;
1951 unshift @{$cur_kid->{OPS}}, {
1960 elsif ( $_ eq "&" ) {
1961 croak "No command before '$_'" unless $cur_kid;
1962 unshift @{$cur_kid->{OPS}}, {
1971 elsif ( $_ eq 'init' ) {
1972 croak "No command before '$_'" unless $cur_kid;
1973 push @{$cur_kid->{OPS}}, {
1979 elsif ( ! ref $_ ) {
1980 $self->{$_} = shift @args;
1983 elsif ( $_ eq 'init' ) {
1984 croak "No command before '$_'" unless $cur_kid;
1985 push @{$cur_kid->{OPS}}, {
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.
1995 if ( ! $assumed_fd ) {
1996 $_ = "$assumed_fd<",
1999 $_ = "$assumed_fd>",
2001 _debug "assuming '", $_, "'" if _debugging_details;
2011 ( ref() ? $_ : 'scalar' ),
2012 ' in harness() parameter ',
2019 _debug 'caught ', $@ if _debugging;
2023 die join( '', @errs ) if @errs;
2026 $self->{STATE} = _harnessed;
2027 # $self->timeout( $options->{timeout} ) if exists $options->{timeout};
2033 my IPC::Run $self = shift;
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.
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;
2047 for ( sort keys %{$self->{PTYS}} ) {
2048 _debug "opening pty '", $_, "'" if _debugging_details;
2050 $self->{PTYS}->{$_} = $pty;
2053 for ( @{$self->{IOS}} ) {
2057 _debug 'caught ', $@ if _debugging;
2060 push @close_on_fail, $_;
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];
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
2076 TFD => $pipe_read_fd,
2078 $pipe_read_fd = undef;
2080 @output_fds_accum = ();
2081 for my $op ( @{$kid->{OPS}} ) {
2082 # next if $op->{IS_DEBUG};
2084 if ( $op->{TYPE} eq '<' ) {
2085 my $source = $op->{SOURCE};
2086 if ( ! ref $source ) {
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};
2096 elsif ( UNIVERSAL::isa( $source, 'GLOB' )
2097 || UNIVERSAL::isa( $source, 'IO::Handle' )
2100 "Unopened filehandle in input redirect for $op->{KFD}"
2101 unless defined fileno $source;
2102 $op->{TFD} = fileno $source;
2104 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2105 " from fd ", $op->{TFD}
2106 ) if _debugging_details;
2108 elsif ( UNIVERSAL::isa( $source, 'SCALAR' ) ) {
2110 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2112 ) if _debugging_details;
2114 $op->open_pipe( $self->_debug_fd );
2115 push @close_on_fail, $op->{KFD}, $op->{FD};
2118 $op->{KIN_REF} = \$s;
2120 elsif ( UNIVERSAL::isa( $source, 'CODE' ) ) {
2122 'kid ', $kid->{NUM}, ' to read ', $op->{KFD}, ' from CODE'
2123 ) if _debugging_details;
2125 $op->open_pipe( $self->_debug_fd );
2126 push @close_on_fail, $op->{KFD}, $op->{FD};
2129 $op->{KIN_REF} = \$s;
2135 . "' not allowed as a source for input redirection"
2140 elsif ( $op->{TYPE} eq '<pipe' ) {
2142 'kid to read ', $op->{KFD},
2143 ' from a pipe IPC::Run opens and returns',
2144 ) if _debugging_details;
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;
2151 $op->{FD} = undef; # we don't manage this fd
2154 elsif ( $op->{TYPE} eq '<pty<' ) {
2156 'kid to read ', $op->{KFD}, " from pty '", $op->{PTY_ID}, "'",
2157 ) if _debugging_details;
2159 for my $source ( $op->{SOURCE} ) {
2160 if ( UNIVERSAL::isa( $source, 'SCALAR' ) ) {
2162 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2163 " from SCALAR via pty '", $op->{PTY_ID}, "'"
2164 ) if _debugging_details;
2167 $op->{KIN_REF} = \$s;
2169 elsif ( UNIVERSAL::isa( $source, 'CODE' ) ) {
2171 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2172 " from CODE via pty '", $op->{PTY_ID}, "'"
2173 ) if _debugging_details;
2175 $op->{KIN_REF} = \$s;
2181 . "' not allowed as a source for '<pty<' redirection"
2185 $op->{FD} = $self->{PTYS}->{$op->{PTY_ID}}->fileno;
2186 $op->{TFD} = undef; # The fd isn't known until after fork().
2189 elsif ( $op->{TYPE} eq '>' ) {
2190 ## N> output redirection.
2191 my $dest = $op->{DEST};
2192 if ( ! ref $dest ) {
2194 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2195 " to '", $dest, "' (write only, create, ",
2196 ( $op->{TRUNC} ? 'truncate' : 'append' ),
2198 ) if _debugging_details;
2199 croak "simulated open failure"
2200 if $self->{_simulate_open_failure};
2201 $op->{TFD} = _sysopen(
2205 | ( $op->{TRUNC} ? O_TRUNC : O_APPEND )
2209 ## I have no idea why this is needed to make the current
2210 ## file position survive the gyrations TFD must go
2212 POSIX::lseek( $op->{TFD}, 0, POSIX::SEEK_END() );
2214 push @close_on_fail, $op->{TFD};
2216 elsif ( UNIVERSAL::isa( $dest, 'GLOB' ) ) {
2218 "Unopened filehandle in output redirect, command $kid->{NUM}"
2219 ) unless defined fileno $dest;
2220 ## Turn on autoflush, mostly just to flush out
2222 my $old_fh = select( $dest ); $| = 1; select( $old_fh );
2223 $op->{TFD} = fileno $dest;
2225 'kid to write ', $op->{KFD}, ' to handle ', $op->{TFD}
2226 ) if _debugging_details;
2228 elsif ( UNIVERSAL::isa( $dest, 'SCALAR' ) ) {
2230 "kid ", $kid->{NUM}, " to write $op->{KFD} to SCALAR"
2231 ) if _debugging_details;
2233 $op->open_pipe( $self->_debug_fd );
2234 push @close_on_fail, $op->{FD}, $op->{TFD};
2235 $$dest = '' if $op->{TRUNC};
2237 elsif ( UNIVERSAL::isa( $dest, 'CODE' ) ) {
2239 "kid $kid->{NUM} to write $op->{KFD} to CODE"
2240 ) if _debugging_details;
2242 $op->open_pipe( $self->_debug_fd );
2243 push @close_on_fail, $op->{FD}, $op->{TFD};
2249 . "' not allowed as a sink for output redirection"
2252 $output_fds_accum[$op->{KFD}] = $op;
2256 elsif ( $op->{TYPE} eq '>pipe' ) {
2257 ## N> output redirection to a pipe we open, but don't select()
2260 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2261 ' to a pipe IPC::Run opens and returns'
2262 ) if _debugging_details;
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;
2269 $op->{FD} = undef; # we don't manage this fd
2272 $output_fds_accum[$op->{KFD}] = $op;
2274 elsif ( $op->{TYPE} eq '>pty>' ) {
2275 my $dest = $op->{DEST};
2276 if ( UNIVERSAL::isa( $dest, 'SCALAR' ) ) {
2278 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2279 " to SCALAR via pty '", $op->{PTY_ID}, "'"
2280 ) if _debugging_details;
2282 $$dest = '' if $op->{TRUNC};
2284 elsif ( UNIVERSAL::isa( $dest, 'CODE' ) ) {
2286 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2287 " to CODE via pty '", $op->{PTY_ID}, "'"
2288 ) if _debugging_details;
2294 . "' not allowed as a sink for output redirection"
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;
2303 elsif ( $op->{TYPE} eq '|' ) {
2305 "pipelining $kid->{NUM} and "
2306 . ( $kid->{NUM} + 1 )
2307 ) if _debugging_details;
2308 ( $pipe_read_fd, $op->{TFD} ) = _pipe;
2310 _dont_inherit( $pipe_read_fd );
2311 _dont_inherit( $op->{TFD} );
2313 @output_fds_accum = ();
2315 elsif ( $op->{TYPE} eq '&' ) {
2316 @output_fds_accum = ();
2317 } # end if $op->{TYPE} tree
2322 _debug 'caught ', $@ if _debugging;
2328 for ( @close_on_fail ) {
2332 for ( keys %{$self->{PTYS}} ) {
2333 next unless $self->{PTYS}->{$_};
2334 close $self->{PTYS}->{$_};
2335 $self->{PTYS}->{$_} = undef;
2337 die join( '', @errs )
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
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 $_;
2357 'kid ', $self->{KIDS}->[$num]->{NUM}, ' also to write ', $_->{KFD},
2358 ' to ', ref $_->{DEST}
2359 ) if _debugging_details;
2360 unshift @{$self->{KIDS}->[$num]->{OPS}}, $_;
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}} = ();
2372 ## PIN is a vec()tor that indicates who's paused.
2374 for my $kid ( @{$self->{KIDS}} ) {
2375 for ( @{$kid->{OPS}} ) {
2376 if ( defined $_->{FD} ) {
2378 'kid ', $kid->{NUM}, '[', $kid->{PID}, "]'s ", $_->{KFD},
2380 ) if _debugging_details;
2381 vec( $self->{ $_->{TYPE} =~ /^</ ? 'WIN' : 'RIN' }, $_->{FD}, 1 ) = 1;
2382 # vec( $self->{EIN}, $_->{FD}, 1 ) = 1;
2383 push @{$self->{PIPES}}, $_;
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;
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 ) = @_;
2405 return undef unless defined $pipe->{FD};
2406 return 0 unless vec( $self->{ROUT}, $pipe->{FD}, 1 );
2408 vec( $self->{ROUT}, $pipe->{FD}, 1 ) = 0;
2410 _debug_desc_fd( 'reading from', $pipe ) if _debugging_details;
2411 my $in = eval { _read( $pipe->{FD} ) };
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.
2419 ($@ =~ /input or output/ && $^O =~ /aix/)
2420 || ( Win32_MODE && $@ =~ /Bad file descriptor/ );
2423 unless ( length $in ) {
2424 $self->_clobber( $pipe );
2428 ## Protect the position so /.../g matches may be used.
2429 my $pos = pos $$out_ref;
2431 pos( $$out_ref ) = $pos;
2434 ## Input filters are the last filters
2435 push @{$pipe->{FILTERS}}, $pipe_reader;
2436 push @{$self->{TEMP_FILTERS}}, $pipe_reader;
2439 my $pipe_writer = sub {
2440 my ( $in_ref, $out_ref ) = @_;
2441 return undef unless defined $pipe->{FD};
2443 unless vec( $self->{WOUT}, $pipe->{FD}, 1 )
2446 vec( $self->{WOUT}, $pipe->{FD}, 1 ) = 0;
2448 if ( ! length $$in_ref ) {
2449 if ( ! defined get_more_input ) {
2450 $self->_clobber( $pipe );
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;
2465 _debug_desc_fd( 'writing to', $pipe ) if _debugging_details;
2467 my $c = _write( $pipe->{FD}, $$in_ref );
2468 substr( $$in_ref, 0, $c, '' );
2471 ## Output filters are the first filters
2472 unshift @{$pipe->{FILTERS}}, $pipe_writer;
2473 push @{$self->{TEMP_FILTERS}}, $pipe_writer;
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
2486 next unless defined $_->{TFD};
2487 $_->{TFD} = _dup( $_->{TFD} ) if $_->{TFD} == $fd2;
2489 $self->{DEBUG_FD} = _dup $self->{DEBUG_FD}
2490 if defined $self->{DEBUG_FD} && $self->{DEBUG_FD} == $fd2;
2492 _dup2_rudely( $fd1, $fd2 );
2497 =item close_terminal
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.
2506 sub close_terminal {
2507 ## Cast of the bonds of a controlling terminal
2509 POSIX::setsid() || croak "POSIX::setsid() failed";
2510 _debug "closing stdin, out, err"
2511 if _debugging_details;
2518 sub _do_kid_and_exit {
2519 my IPC::Run $self = shift;
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();
2535 local $cur_self = $self;
2538 _set_child_debug_name( ref $kid->{VAL} eq "CODE"
2540 : basename( $kid->{VAL}->[0] )
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};
2551 for ( @{$kid->{OPS}} ) {
2552 $needed[ $_->{TFD} ] = 1 if defined $_->{TFD};
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.
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;
2571 $closed[ $_ ] = 1 for ( 0..2 );
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;
2581 # for ( $_->{FD}, ( $sibling != $kid ? $_->{TFD} : () ) ) {
2582 # if ( defined $_ && ! $closed[$_] && ! $needed[$_] ) {
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;
2595 if ( ! $closed[$_] && ! $needed[$_] ) {
2601 ## Lazy closing is so the same fd (ie the same TFD value) can be dup2'ed on
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};
2611 elsif ( $_->{TYPE} eq 'dup' ) {
2612 $self->_dup2_gently( $kid->{OPS}, $_->{KFD1}, $_->{KFD2} )
2613 unless $_->{KFD1} == $_->{KFD2};
2615 elsif ( $_->{TYPE} eq 'close' ) {
2617 if ( ! $closed[$_] ) {
2624 elsif ( $_->{TYPE} eq 'init' ) {
2629 for ( @lazy_close ) {
2630 unless ( $closed[$_] ) {
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;
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;
2648 my @cmd = ( $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] );
2649 _debug 'execing ', join " ", map { /[\s\"]/ ? "'$_'" : $_ } @cmd;
2652 die "exec failed: simulating exec() failure"
2653 if $self->{_simulate_exec_failure};
2655 _exec $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}];
2657 croak "exec failed: $!";
2661 _write $self->{SYNC_WRITER_FD}, $@;
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...
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;
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
2693 \@cmd, \$in, \$out, ...,
2694 timeout( 30, name => "process timeout" ),
2695 $stall_timeout = timeout( 10, name => "stall timeout" ),
2698 $h = start \@cmd, '<', \$in, '|', \@cmd2, ...;
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.
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
2710 start() also starts all timers in the harness. See L<IPC::Run::Timer>
2711 for more information.
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.
2717 Here's how if you don't want to alter the state of $| for your
2720 $ofh = select HANDLE; $of = $|; $| = 1; $| = $of; select $ofh;
2722 If you don't mind leaving output unbuffered on HANDLE, you can do
2723 the slightly shorter
2725 $ofh = select HANDLE; $| = 1; select $ofh;
2727 Or, you can use IO::Handle's flush() method:
2732 Perl needs the equivalent of C's fflush( (FILE *)NULL ).
2737 # $SIG{__DIE__} = sub { my $s = shift; Carp::cluck $s; die $s };
2739 if ( @_ && ref $_[-1] eq 'HASH' ) {
2741 require Data::Dumper;
2742 carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper( $options );
2746 if ( @_ == 1 && UNIVERSAL::isa( $_[0], __PACKAGE__ ) ) {
2748 $self->{$_} = $options->{$_} for keys %$options;
2751 $self = harness( @_, $options ? $options : () );
2754 local $cur_self = $self;
2756 $self->kill_kill if $self->{STATE} == _started;
2758 _debug "** starting" if _debugging;
2760 $_->{RESULT} = undef for @{$self->{KIDS}};
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;
2767 IPC::Run::Win32Helper::optimize $self
2768 if Win32_MODE && $in_run;
2772 for ( @{$self->{TIMERS}} ) {
2776 _debug 'caught ', $@ if _debugging;
2780 eval { $self->_open_pipes };
2783 _debug 'caught ', $@ if _debugging;
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;
2797 ref( $kid->{VAL} ) eq "CODE"
2801 join( " ", map /[^\w.-]/ ? "'$_'" : $_, @{$kid->{VAL}} ),
2803 ) if _debugging_details;
2805 croak "simulated failure of fork"
2806 if $self->{_simulate_fork_failure};
2807 unless ( Win32_MODE ) {
2808 $self->_spawn( $kid );
2811 ## TODO: Test and debug spawning code. Someday.
2818 ( $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] )
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}}] ],
2830 _debug "spawn() = ", $kid->{PID} if _debugging;
2835 _debug 'caught ', $@ if _debugging;
2840 ## Close all those temporary filehandles that the kids needed.
2841 for my $pty ( values %{$self->{PTYS}} ) {
2846 for my $kid ( @{$self->{KIDS}} ) {
2847 for ( @{$kid->{OPS}} ) {
2848 my $close_it = eval {
2850 && ! $_->{DONT_CLOSE}
2851 && ! $closed[$_->{TFD}]
2852 && ( ! Win32_MODE || ! $_->{RECV_THROUGH_TEMP_FILE} ) ## Win32 hack
2856 _debug 'caught ', $@ if _debugging;
2858 if ( $close_it || $@ ) {
2860 _close( $_->{TFD} );
2861 $closed[$_->{TFD}] = 1;
2866 _debug 'caught ', $@ if _debugging;
2871 confess "gak!" unless defined $self->{PIPES};
2874 eval { $self->_cleanup };
2876 die join( '', @errs );
2879 $self->{STATE} = _started;
2885 Experimental feature. NOT FUNCTIONAL YET, NEED TO CLOSE FDS BETTER IN CHILDREN. SEE t/adopt.t for a test suite.
2890 my IPC::Run $self = shift;
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;
2906 my IPC::Run $self = shift;
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.$/ ) {
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;
2925 elsif ( UNIVERSAL::isa( $file, 'IPC::Run::IO' ) ) {
2926 $file->close unless $file->{DONT_CLOSE};
2932 @{$self->{PIPES}} = grep
2933 defined $_->{FD} && ( $_->{TYPE} ne $file->{TYPE} || $_->{FD} ne $doomed),
2936 $file->{FD} = undef;
2940 my IPC::Run $self = shift;
2944 my $not_forever = 0.01;
2947 while ( $self->pumpable ) {
2948 if ( $io_occurred && $self->{break_on_io} ) {
2949 _debug "exiting _select(): io occured and break_on_io set"
2950 if _debugging_details;
2954 my $timeout = $self->{non_blocking} ? 0 : undef;
2956 if ( @{$self->{TIMERS}} ) {
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;
2970 ## See if we can unpause any input channels
2974 for my $file ( @{$self->{PIPES}} ) {
2975 next unless $file->{PAUSED} && $file->{TYPE} =~ /^</;
2977 _debug_desc_fd( "checking for more input", $file ) if _debugging_details;
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;
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.
2996 if ( _debugging_details ) {
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;
3009 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/;
3010 _debug 'fds for select: ', $map if _debugging_details;
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;
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;
3023 $not_forever = 0.5 if $not_forever >= 0.5;
3026 ## Make sure we don't block forever in select() because inputs are
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"
3038 ## Otherwise, assume more input will be coming.
3039 $timeout = $not_forever;
3041 $not_forever = 0.5 if $not_forever >= 0.5;
3044 _debug 'timeout=', defined $timeout ? $timeout : 'forever'
3045 if _debugging_details;
3048 unless ( Win32_MODE ) {
3050 $self->{ROUT} = $self->{RIN},
3051 $self->{WOUT} = $self->{WIN},
3052 $self->{EOUT} = $self->{EIN},
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.
3061 $_ = undef unless index( ( unpack "b*", $_ ), 1 ) >= 0;
3065 $self->{ROUT} = $in[0],
3066 $self->{WOUT} = $in[1],
3067 $self->{EOUT} = $in[2],
3071 for ( $self->{ROUT}, $self->{WOUT}, $self->{EOUT} ) {
3072 $_ = "" unless defined $_;
3075 last if ! $nfound && $self->{non_blocking};
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} = '';
3085 croak "$! in select";
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.
3092 if ( _debugging_details ) {
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;
3104 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/;
3105 _debug "selected ", $map;
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;
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 )
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 );
3126 # next FILE unless defined $pipe->{FD};
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 )
3135 # _debug_desc_fd( "filtering data to", $pipe ) if _debugging_details;
3136 # $io_occurred = 1 if $pipe->_do_filters( $self );
3138 # next FILE unless defined $pipe->{FD};
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
3150 # warn "Exception on descriptor $pipe->{FD}";
3160 my IPC::Run $self = shift;
3161 _debug "cleaning up" if _debugging_details;
3163 for ( values %{$self->{PTYS}} ) {
3166 _debug "closing slave fd ", fileno $_->slave if _debugging_data;
3169 carp $@ . " while closing ptys" if $@;
3171 _debug "closing master fd ", fileno $_ if _debugging_data;
3174 carp $@ . " closing ptys" if $@;
3177 _debug "cleaning up pipes" if _debugging_details;
3178 ## _clobber modifies PIPES
3179 $self->_clobber( $self->{PIPES}->[0] ) while @{$self->{PIPES}};
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"
3186 for my $op ( @{$kid->{OPS}} ) {
3187 _close( $op->{TFD} )
3188 if defined $op->{TFD} && ! defined $op->{TEMP_FILE_HANDLE};
3191 elsif ( ! defined $kid->{RESULT} ) {
3192 _debug 'reaping child ', $kid->{NUM}, ' (pid ', $kid->{PID}, ')'
3194 my $pid = waitpid $kid->{PID}, 0;
3195 $kid->{RESULT} = $?;
3196 _debug 'reaped ', $pid, ', $?=', $kid->{RESULT}
3200 # if ( defined $kid->{DEBUG_FD} ) {
3202 # @{$kid->{OPS}} = grep
3203 # ! defined $_->{KFD} || $_->{KFD} != $kid->{DEBUG_FD},
3205 # $kid->{DEBUG_FD} = undef;
3208 _debug "cleaning up filters" if _debugging_details;
3209 for my $op ( @{$kid->{OPS}} ) {
3210 @{$op->{FILTERS}} = grep {
3212 ! grep $filter == $_, @{$self->{TEMP_FILTERS}};
3213 } @{$op->{FILTERS}};
3216 for my $op ( @{$kid->{OPS}} ) {
3217 $op->_cleanup( $self ) if UNIVERSAL::isa( $op, "IPC::Run::IO" );
3220 $self->{STATE} = _finished;
3221 @{$self->{TEMP_FILTERS}} = ();
3222 _debug "done cleaning up" if _debugging_details;
3224 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD};
3225 $self->{DEBUG_FD} = undef;
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.
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.
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:
3247 $h = harness \@smbclient, \$in, \$out, $err;
3250 $h->pump until $out =~ /^smb.*> \Z/m;
3251 die "error cding to /foo:\n$out" if $out =~ "ERR";
3255 $h->pump until $out =~ /^smb.*> \Z/m;
3256 die "error retrieving files:\n$out" if $out =~ "ERR";
3265 die "pump() takes only a a single harness as a parameter"
3266 unless @_ == 1 && UNIVERSAL::isa( $_[0], __PACKAGE__ );
3268 my IPC::Run $self = shift;
3270 local $cur_self = $self;
3276 $self->start if $self->{STATE} < _started;
3277 croak "process ended prematurely" unless $self->pumpable;
3279 $self->{auto_close_ins} = 0;
3280 $self->{break_on_io} = 1;
3281 $self->_select_loop;
3282 return $self->pumpable;
3286 # _debug $x if _debugging && $x;
3287 # eval { $self->_cleanup };
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.
3308 my IPC::Run $self = shift;
3310 $self->{non_blocking} = 1;
3311 my $r = eval { $self->pump };
3312 $self->{non_blocking} = 0;
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.
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.
3335 my IPC::Run $self = shift;
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}};
3345 ## See if the child is dead.
3347 return 0 unless $self->_running_kids;
3349 ## If we reap_nb and it's not dead yet, yield to it to see if it
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;
3358 return 0 unless $self->_running_kids;
3360 return -1; ## There are pipes waiting
3365 my IPC::Run $self = shift;
3367 defined $_->{PID} && ! defined $_->{RESULT},
3375 Attempts to reap child processes, but does not block.
3377 Does not currently take any parameters, one day it will allow specific
3378 children to be reaped.
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.
3390 my IPC::Run $self = shift;
3392 local $cur_self = $self;
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}} ) {
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;
3410 _debug "kid $kid->{NUM} ($kid->{PID}) exited"
3413 $kid->{PROCESS}->GetExitCode( $kid->{RESULT} )
3414 or croak "$! while GetExitCode()ing for Win32 process";
3416 unless ( defined $kid->{RESULT} ) {
3417 $kid->{RESULT} = "0 but true";
3418 $? = $kid->{RESULT} = 0x0F;
3421 $? = $kid->{RESULT} << 8;
3425 next if ! defined $kid->{PID} || defined $kid->{RESULT};
3426 my $pid = waitpid $kid->{PID}, POSIX::WNOHANG();
3428 _debug "$kid->{NUM} ($kid->{PID}) still running"
3429 if _debugging_details;
3434 _debug "No such process: $kid->{PID}\n" if _debugging;
3435 $kid->{RESULT} = "unknown result, unknown PID";
3438 _debug "kid $kid->{NUM} ($kid->{PID}) exited"
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} = $?;
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"
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()).
3462 Once a harness has been finished, it may be run() or start()ed again,
3463 including by pump()s auto-start.
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.
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>.
3476 my IPC::Run $self = shift;
3477 my $options = @_ && ref $_[-1] eq 'HASH' ? pop : {};
3479 local $cur_self = $self;
3481 _debug "** finishing" if _debugging;
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.
3488 while ( $self->pumpable ) {
3489 $self->_select_loop( $options );
3493 return ! $self->full_result;
3502 Returns the first non-zero result code (ie $? >> 8). See L</full_result> to
3503 get the $? value for a child process.
3505 To get the result of a particular child, do:
3507 $h->result( 0 ); # first child's $? >> 8
3508 $h->result( 1 ); # second child
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.
3520 sub _assert_finished {
3521 my IPC::Run $self = $_[0];
3523 croak "Harness not run" unless $self->{STATE} >= _finished;
3524 croak "Harness not finished running" unless $self->{STATE} == _finished;
3530 my IPC::Run $self = shift;
3536 scalar( @{$self->{KIDS}} ),
3537 " child processes, no process $which"
3539 unless $which >= 0 && $which <= $#{$self->{KIDS}};
3540 return $self->{KIDS}->[$which]->{RESULT} >> 8;
3543 return undef unless @{$self->{KIDS}};
3544 for ( @{$self->{KIDS}} ) {
3545 return $_->{RESULT} >> 8 if $_->{RESULT} >> 8;
3554 Returns a list of child exit values. See L</full_results> if you want to
3555 know if a signal killed the child.
3557 Throws an exception if the harness is not in a finished state.
3563 my IPC::Run $self = shift;
3565 # we add 0 here to stop warnings associated with "unknown result, unknown PID"
3566 return map { (0+$_->{RESULT}) >> 8 } @{$self->{KIDS}};
3575 Returns the first non-zero $?. See L</result> to get the first $? >> 8
3576 value for a child process.
3578 To get the result of a particular child, do:
3580 $h->full_result( 0 ); # first child's $? >> 8
3581 $h->full_result( 1 ); # second child
3585 ($h->full_results)[0]
3586 ($h->full_results)[1]
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.
3594 goto &result if @_ > 1;
3597 my IPC::Run $self = shift;
3599 return undef unless @{$self->{KIDS}};
3600 for ( @{$self->{KIDS}} ) {
3601 return $_->{RESULT} if $_->{RESULT};
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.
3612 Throws an exception if the harness is not in a finished state.
3618 my IPC::Run $self = shift;
3620 croak "Harness not run" unless $self->{STATE} >= _finished;
3621 croak "Harness not finished running" unless $self->{STATE} == _finished;
3623 return map $_->{RESULT}, @{$self->{KIDS}};
3628 ## Filter Scaffolding
3631 '$filter_op', ## The op running a filter chain right now
3632 '$filter_num', ## Which filter is being run right now.
3636 ## A few filters and filter constructors
3647 These filters are used to modify input our output between a child
3648 process and a scalar or subroutine endpoint.
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
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
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.
3669 my $enable = @_ ? shift : 1;
3670 return bless sub { $enable }, "IPC::Run::binmode_pseudo_filter";
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.
3681 run \@cmd, '>', new_chunker, \&lines_handler;
3682 run \@cmd, '>', new_chunker( "\r\n" ), \&lines_handler;
3684 Because this uses $/ by default, you should always pass in a parameter
3685 if you are worried about other code (modules, etc) modifying $/.
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.
3690 As an example of how a filter like this can be written, here's a
3691 chunker that splits on newlines:
3694 my ( $in_ref, $out_ref ) = @_;
3696 return 0 if length $$out_ref;
3698 return input_avail && do {
3700 if ( $$in_ref =~ s/\A(.*?\n)// ) {
3704 my $hmm = get_more_input;
3705 unless ( defined $hmm ) {
3706 $$out_ref = $$in_ref;
3708 return length $$out_ref ? 1 : 0;
3710 return 0 if $hmm eq 0;
3717 sub new_chunker(;$) {
3719 $re = $/ if _empty $re;
3720 $re = quotemeta( $re ) unless ref $re eq 'Regexp';
3721 $re = qr/\A(.*?$re)/s;
3724 my ( $in_ref, $out_ref ) = @_;
3726 return 0 if length $$out_ref;
3728 return input_avail && do {
3730 if ( $$in_ref =~ s/$re// ) {
3734 my $hmm = get_more_input;
3735 unless ( defined $hmm ) {
3736 $$out_ref = $$in_ref;
3738 return length $$out_ref ? 1 : 0;
3740 return 0 if $hmm eq 0;
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":
3755 '<', new_appender( "\n" ), \&commands,
3758 Here's a typical filter sub that might be created by new_appender():
3760 sub newline_appender {
3761 my ( $in_ref, $out_ref ) = @_;
3763 return input_avail && do {
3764 $$out_ref = join( '', $$out_ref, $$in_ref, "\n" );
3772 sub new_appender($) {
3773 my ( $suffix ) = @_;
3774 croak "\$suffix undefined" unless defined $suffix;
3777 my ( $in_ref, $out_ref ) = @_;
3779 return input_avail && do {
3780 $$out_ref = join( '', $$out_ref, $$in_ref, $suffix );
3787 =item new_string_source
3789 TODO: Needs confirmation. Was previously undocumented. in this module.
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.
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.
3798 sub new_string_source {
3807 return ref $ref eq 'SCALAR'
3809 my ( $in_ref, $out_ref ) = @_;
3811 return defined $$ref
3814 my $r = length $$ref ? 1 : 0;
3821 my ( $in_ref, $out_ref ) = @_;
3825 my $s = shift @$ref;
3833 =item new_string_sink
3835 TODO: Needs confirmation. Was previously undocumented.
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.
3841 sub new_string_sink {
3842 my ( $string_ref ) = @_;
3845 my ( $in_ref, $out_ref ) = @_;
3847 return input_avail && do {
3848 $$string_ref .= $$in_ref;
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
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:
3867 # $h->timeout( $val );
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
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.
3884 #This sub does not check whether or not the timeout has expired already.
3886 #Returns the number of seconds set as the timeout (this does not change
3887 #as time passes, unless you call timeout( val ) again).
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
3898 # my IPC::Run $self = shift;
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];
3909 # elsif ( $self->{TIMEOUT} =~ /^(\d*)(?:\.(\d*))/ ) {
3910 # $self->{TIMEOUT} = $1 + 1;
3912 # $self->_calc_timeout_end if $self->{STATE} >= _started;
3915 # return $self->{TIMEOUT};
3919 #sub _calc_timeout_end {
3920 # my IPC::Run $self = shift;
3922 # $self->{TIMEOUT_END} = defined $self->{TIMEOUT}
3923 # ? time + $self->{TIMEOUT}
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};
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()
3941 This is shorthand for
3944 require IPC::Run::IO;
3946 ... IPC::Run::IO->new(...) ...
3951 require IPC::Run::IO;
3952 IPC::Run::IO->new( @_ );
3959 $h = start( \@cmd, \$in, \$out, $t = timer( 5 ) );
3961 pump $h until $out =~ /expected stuff/ || $t->is_expired;
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.
3967 See L</timeout> for building timers that throw exceptions on
3970 See L<IPC::Run::Timer/timer> for details.
3974 # Doing the prototype suppresses 'only used once' on older perls.
3976 *timer = \&IPC::Run::Timer::timer;
3982 $h = start( \@cmd, \$in, \$out, $t = timeout( 5 ) );
3984 pump $h until $out =~ /expected stuff/;
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:
3993 $t = timeout( 5, exception => 'slowpoke' ),
3996 or set the name used in debugging message and in the default exception
4001 timeout( 50, name => 'process timer' ),
4002 $stall_timer = timeout( 5, name => 'stall timer' ),
4005 pump $h until $out =~ /started/;
4008 $stall_timer->start;
4009 pump $h until $out =~ /command 1 finished/;
4012 $stall_timer->start;
4013 pump $h until $out =~ /command 2 finished/;
4015 $in = 'very slow command 3';
4016 $stall_timer->start( 10 );
4017 pump $h until $out =~ /command 3 finished/;
4019 $stall_timer->start( 5 );
4021 pump $h until $out =~ /command 4 finished/;
4023 $stall_timer->reset; # Prevent restarting or expirng
4026 See L</timer> for building non-fatal timers.
4028 See L<IPC::Run::Timer/timer> for details.
4032 # Doing the prototype suppresses 'only used once' on older perls.
4034 *timeout = \&IPC::Run::Timer::timeout;
4040 =head1 FILTER IMPLEMENTATION FUNCTIONS
4042 These functions are for use from within filters.
4048 Returns TRUE if input is available. If none is available, then
4049 &get_more_input is called and its result is returned.
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.
4055 C<input_avail> is usually used as part of a return expression:
4057 return input_avail && do {
4058 ## process the input just gotten
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
4067 my $got = input_avail;
4068 if ( ! defined $got ) {
4069 ## No more input ever, flush internal buffers to $out_ref
4071 return $got unless $got;
4072 ## Got some input, move as much as need be
4073 return 1 if $added_to_out_ref;
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;
4085 =item get_more_input
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.
4091 C<get_more_input> is usually used as part of a return expression,
4092 see L</input_avail> for more information.
4097 ## Filter implementation interface
4099 sub get_more_input() {
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]};
4122 These will be addressed as needed and as time allows.
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.
4129 $kid->abort(), $kid->kill(), $kid->signal( $num_or_name ).
4131 Write tests for /(full_)?results?/ subs.
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.
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().
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).
4147 Allow multiple harnesses to be combined as independent sets of processes
4148 in to one 'meta-harness'.
4150 Allow a harness to be passed in place of an \@cmd. This would allow
4151 multiple harnesses to be aggregated.
4153 Ability to add external file descriptors w/ filter chains and endpoints.
4155 Ability to add timeouts and timing generators (i.e. repeating timeouts).
4157 High resolution timeouts.
4159 =head1 Win32 LIMITATIONS
4163 =item Fails on Win9X
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.
4170 =item May deadlock on Win2K (but not WinNT4 or WinXPPro)
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.
4176 =item no support yet for <pty< and >pty>
4178 These are likely to be implemented as "<" and ">" with binmode on, not
4181 =item no support for file descriptors higher than 2 (stderr)
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).
4189 =item no support for subroutine subprocesses (CODE refs)
4191 Can't fork(), so the subroutines would have no context, and closures certainly
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.
4199 =item no support for init => sub {} routines.
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.
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).
4211 =item helper processes
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
4221 =item shutdown pause
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.
4229 binmode is not supported yet. The underpinnings are implemented, just ask
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).
4239 =item startup race conditions
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.
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.
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).
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).
4268 On Unix, requires a system that supports C<waitpid( $pid, WNOHANG )> so
4269 it can tell if a child process is still running.
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.
4277 use IPC::Run qw(run);
4282 return ['perl', '-e',
4283 '<STDIN>, print "\n" x '.$_[0].'; while(<STDIN>){last if /end/}'];
4287 #fcntl(W, F_SETFL, O_NONBLOCK);
4288 #while (syswrite(W, "\n", 1)) { $pipebuf++ };
4289 #print "pipe buffer size is $pipebuf\n";
4291 my $in = "\n" x ($pipebuf * 2) . "end\n";
4294 $SIG{ALRM} = sub { die "Never completed!\n" };
4296 print "reading from scalar via pipe...";
4298 run(makecmd($pipebuf * 2), '<', \$in, '>', \$out);
4302 print "reading from code via pipe... ";
4304 run(makecmd($pipebuf * 3), '<', sub { $t = $in; undef $in; $t}, '>', \$out);
4308 $pty = IO::Pty->new();
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";
4315 print "reading via pty... ";
4317 run(makecmd($ptybuf * 3), '<pty<', \$in, '>', \$out);
4321 No support for ';', '&&', '||', '{ ... }', etc: use perl's, since run()
4322 returns TRUE when the command exits with a 0 result code.
4324 Does not provide shell-like string interpolation.
4326 No support for C<cd>, C<setenv>, or C<export>: do these in an init() sub
4332 chdir $dir or die $!;
4337 Timeout calculation does not allow absolute times, or specification of
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.
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
4358 I goofed on the syntax: "<pipe" vs. "<pty<" and ">filename" are both
4365 =item Allow one harness to "adopt" another:
4367 $new_h = harness \@cmd2;
4368 $h->adopt( $new_h );
4370 =item Close all filehandles not explicitly marked to stay open.
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
4380 Well, select() and waitpid() badly needed wrapping, and open3() isn't
4381 open-minded enough for me.
4383 The shell-like API inspired by a message Russ Allbery sent to perl5-porters,
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:
4391 pipeopen (PIPE, [ qw/cat file/ ], '|', [ 'analyze', @args ], '>&3');
4393 Message ylln51p2b6.fsf@windlord.stanford.edu, on 2000/02/04.
4397 Bugs should always be submitted via the CPAN bug tracker
4399 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IPC-Run>
4401 For other issues, contact the maintainer (the first listed author)
4405 Adam Kennedy <adamk@cpan.org>
4407 Barrie Slaymaker <barries@slaysys.com>
4411 Some parts copyright 2008 - 2009 Adam Kennedy.
4413 Copyright 1999 Barrie Slaymaker.
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.