7 IPC::Run - system() and background procs w/ piping, redirs, ptys (Unix, Win32)
11 ## First,a command to run:
14 ## Using run() instead of system():
15 use IPC::Run qw( run timeout );
17 run \@cmd, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?"
19 # Can do I/O to sub refs and filenames, too:
20 run \@cmd, '<', "in.txt", \&out, \&err or die "cat: $?"
21 run \@cat, '<', "in.txt", '>>', "out.txt", '2>>', "err.txt";
24 # Redirecting using psuedo-terminals instad of pipes.
25 run \@cat, '<pty<', \$in, '>pty>', \$out_and_err;
27 ## Scripting subprocesses (like Expect):
29 use IPC::Run qw( start pump finish timeout );
31 # Incrementally read from / write to scalars.
32 # $in is drained as it is fed to cat's stdin,
33 # $out accumulates cat's stdout
34 # $err accumulates cat's stderr
35 # $h is for "harness".
36 my $h = start \@cat, \$in, \$out, \$err, timeout( 10 );
38 $in .= "some input\n";
39 pump $h until $out =~ /input\n/g;
41 $in .= "some more input\n";
42 pump $h until $out =~ /\G.*more input\n/;
44 $in .= "some final input\n";
45 finish $h or die "cat returned $?";
48 print $out; ## All of cat's output
50 # Piping between children
51 run \@cat, '|', \@gzip;
53 # Multiple children simultaneously (run() blocks until all
54 # children exit, use start() for background execution):
55 run \@foo1, '&', \@foo2;
57 # Calling \&set_up_child in the child before it executes the
58 # command (only works on systems with true fork() & exec())
59 # exceptions thrown in set_up_child() will be propagated back
60 # to the parent and thrown from run().
61 run \@cat, \$in, \$out,
62 init => \&set_up_child;
64 # Read from / write to file handles you open and close
65 open IN, '<in.txt' or die $!;
66 open OUT, '>out.txt' or die $!;
67 print OUT "preamble\n";
68 run \@cat, \*IN, \*OUT or die "cat returned $?";
69 print OUT "postamble\n";
73 # Create pipes for you to read / write (like IPC::Open2 & 3).
79 or die "cat returned $?";
80 print IN "some input\n";
85 # Mixing input and output modes
86 run \@cat, 'in.txt', \&catch_some_out, \*ERR_LOG );
88 # Other redirection constructs
89 run \@cat, '>&', \$out_and_err;
93 run \@cat, '3<', \$in3;
94 run \@cat, '4>', \$out4;
98 run \@cat, 'in.txt', debug => 1;
100 # Call this system's shell, returns TRUE on 0 exit code
101 # THIS IS THE OPPOSITE SENSE OF system()'s RETURN VALUE
102 run "cat a b c" or die "cat returned $?";
104 # Launch a sub process directly, no shell. Can't do redirection
105 # with this form, it's here to behave like system() with an
107 $r = run "cat a b c";
109 # Read from a file in to a scalar
110 run io( "filename", 'r', \$recv );
111 run io( \*HANDLE, 'r', \$recv );
115 IPC::Run allows you run and interact with child processes using files, pipes,
116 and pseudo-ttys. Both system()-style and scripted usages are supported and
117 may be mixed. Likewise, functional and OO API styles are both supported and
120 Various redirection operators reminiscent of those seen on common Unix and DOS
121 command lines are provided.
123 Before digging in to the details a few LIMITATIONS are important enough
124 to be mentioned right up front:
130 Win32 support is working but B<EXPERIMENTAL>, but does pass all relevant tests
131 on NT 4.0. See L</Win32 LIMITATIONS>.
135 If you need pty support, IPC::Run should work well enough most of the
136 time, but IO::Pty is being improved, and IPC::Run will be improved to
137 use IO::Pty's new features when it is release.
139 The basic problem is that the pty needs to initialize itself before the
140 parent writes to the master pty, or the data written gets lost. So
141 IPC::Run does a sleep(1) in the parent after forking to (hopefully) give
142 the child a chance to run. This is a kludge that works well on non
143 heavily loaded systems :(.
145 ptys are not supported yet under Win32, but will be emulated...
149 You may use the environment variable C<IPCRUNDEBUG> to see what's going on
152 $ IPCRUNDEBUG=basic myscript # prints minimal debugging
153 $ IPCRUNDEBUG=data myscript # prints all data reads/writes
154 $ IPCRUNDEBUG=details myscript # prints lots of low-level details
155 $ IPCRUNDEBUG=gory myscript # (Win32 only) prints data moving through
156 # the helper processes.
160 We now return you to your regularly scheduled documentation.
164 Child processes and I/O handles are gathered in to a harness, then
165 started and run until the processing is finished or aborted.
167 =head2 run() vs. start(); pump(); finish();
169 There are two modes you can run harnesses in: run() functions as an
170 enhanced system(), and start()/pump()/finish() allow for background
171 processes and scripted interactions with them.
173 When using run(), all data to be sent to the harness is set up in
174 advance (though one can feed subprocesses input from subroutine refs to
175 get around this limitation). The harness is run and all output is
176 collected from it, then any child processes are waited for:
178 run \@cmd, \<<IN, \$out;
182 ## To precompile harnesses and run them later:
183 my $h = harness \@cmd, \<<IN, \$out;
189 The background and scripting API is provided by start(), pump(), and
190 finish(): start() creates a harness if need be (by calling harness())
191 and launches any subprocesses, pump() allows you to poll them for
192 activity, and finish() then monitors the harnessed activities until they
195 ## Build the harness, open all pipes, and launch the subprocesses
196 my $h = start \@cat, \$in, \$out;
197 $in = "first input\n";
199 ## Now do I/O. start() does no I/O.
200 pump $h while length $in; ## Wait for all input to go
202 ## Now do some more I/O.
203 $in = "second input\n";
204 pump $h until $out =~ /second input/;
207 finish $h or die "cat returned $?";
209 You can optionally compile the harness with harness() prior to
210 start()ing or run()ing, and you may omit start() between harness() and
211 pump(). You might want to do these things if you compile your harnesses
214 =head2 Using regexps to match output
216 As shown in most of the scripting examples, the read-to-scalar facility
217 for gathering subcommand's output is often used with regular expressions
218 to detect stopping points. This is because subcommand output often
219 arrives in dribbles and drabs, often only a character or line at a time.
220 This output is input for the main program and piles up in variables like
221 the C<$out> and C<$err> in our examples.
223 Regular expressions can be used to wait for appropriate output in
224 several ways. The C<cat> example in the previous section demonstrates
225 how to pump() until some string appears in the output. Here's an
226 example that uses C<smb> to fetch files from a remote server:
228 $h = harness \@smbclient, \$in, \$out;
231 $h->pump until $out =~ /^smb.*> \Z/m;
232 die "error cding to /src:\n$out" if $out =~ "ERR";
236 $h->pump until $out =~ /^smb.*> \Z/m;
237 die "error retrieving files:\n$out" if $out =~ "ERR";
242 Notice that we carefully clear $out after the first command/response
243 cycle? That's because IPC::Run does not delete $out when we continue,
244 and we don't want to trip over the old output in the second
245 command/response cycle.
247 Say you want to accumulate all the output in $out and analyze it
248 afterwards. Perl offers incremental regular expression matching using
249 the C<m//gc> and pattern matching idiom and the C<\G> assertion.
250 IPC::Run is careful not to disturb the current C<pos()> value for
251 scalars it appends data to, so we could modify the above so as not to
252 destroy $out by adding a couple of C</gc> modifiers. The C</g> keeps us
253 from tripping over the previous prompt and the C</c> keeps us from
254 resetting the prior match position if the expected prompt doesn't
255 materialize immediately:
257 $h = harness \@smbclient, \$in, \$out;
260 $h->pump until $out =~ /^smb.*> \Z/mgc;
261 die "error cding to /src:\n$out" if $out =~ "ERR";
264 $h->pump until $out =~ /^smb.*> \Z/mgc;
265 die "error retrieving files:\n$out" if $out =~ "ERR";
272 When using this technique, you may want to preallocate $out to have
273 plenty of memory or you may find that the act of growing $out each time
274 new input arrives causes an C<O(length($out)^2)> slowdown as $out grows.
275 Say we expect no more than 10,000 characters of input at the most. To
276 preallocate memory to $out, do something like:
278 my $out = "x" x 10_000;
281 C<perl> will allocate at least 10,000 characters' worth of space, then
282 mark the $out as having 0 length without freeing all that yummy RAM.
284 =head2 Timeouts and Timers
286 More than likely, you don't want your subprocesses to run forever, and
287 sometimes it's nice to know that they're going a little slowly.
288 Timeouts throw exceptions after a some time has elapsed, timers merely
289 cause pump() to return after some time has elapsed. Neither is
290 reset/restarted automatically.
292 Timeout objects are created by calling timeout( $interval ) and passing
293 the result to run(), start() or harness(). The timeout period starts
294 ticking just after all the child processes have been fork()ed or
295 spawn()ed, and are polled for expiration in run(), pump() and finish().
296 If/when they expire, an exception is thrown. This is typically useful
297 to keep a subprocess from taking too long.
299 If a timeout occurs in run(), all child processes will be terminated and
300 all file/pipe/ptty descriptors opened by run() will be closed. File
301 descriptors opened by the parent process and passed in to run() are not
302 closed in this event.
304 If a timeout occurs in pump(), pump_nb(), or finish(), it's up to you to
305 decide whether to kill_kill() all the children or to implement some more
306 graceful fallback. No I/O will be closed in pump(), pump_nb() or
307 finish() by such an exception (though I/O is often closed down in those
308 routines during the natural course of events).
310 Often an exception is too harsh. timer( $interval ) creates timer
311 objects that merely prevent pump() from blocking forever. This can be
312 useful for detecting stalled I/O or printing a soothing message or "."
313 to pacify an anxious user.
315 Timeouts and timers can both be restarted at any time using the timer's
316 start() method (this is not the start() that launches subprocesses). To
317 restart a timer, you need to keep a reference to the timer:
319 ## Start with a nice long timeout to let smbclient connect. If
320 ## pump or finish take too long, an exception will be thrown.
324 $h = harness \@smbclient, \$in, \$out, \$err, ( my $t = timeout 30 );
325 sleep 11; # No effect: timer not running yet
329 pump $h until ! length $in;
332 ## Now use a short timeout, since this should be faster
334 pump $h until ! length $in;
336 $t->start( 10 ); ## Give smbclient a little while to shut down.
340 my $x = $@; ## Preserve $@ in case another exception occurs
341 $h->kill_kill; ## kill it gently, then brutally if need be, or just
342 ## brutally on Win32.
346 Timeouts and timers are I<not> checked once the subprocesses are shut
347 down; they will not expire in the interval between the last valid
348 process and when IPC::Run scoops up the processes' result codes, for
351 =head2 Spawning synchronization, child exception propagation
353 start() pauses the parent until the child executes the command or CODE
354 reference and propagates any exceptions thrown (including exec()
355 failure) back to the parent. This has several pleasant effects: any
356 exceptions thrown in the child, including exec() failure, come flying
357 out of start() or run() as though they had ocurred in the parent.
359 This includes exceptions your code thrown from init subs. In this
363 run \@cmd, init => sub { die "blast it! foiled again!" };
367 the exception "blast it! foiled again" will be thrown from the child
368 process (preventing the exec()) and printed by the parent.
372 run \@cmd1, "|", \@cmd2, "|", \@cmd3;
374 @cmd1 will be initted and exec()ed before @cmd2, and @cmd2 before @cmd3.
375 This can save time and prevent oddball errors emitted by later commands
376 when earlier commands fail to execute. Note that IPC::Run doesn't start
377 any commands unless it can find the executables referenced by all
378 commands. These executables must pass both the C<-f> and C<-x> tests
379 described in L<perlfunc>.
381 Another nice effect is that init() subs can take their time doing things
382 and there will be no problems caused by a parent continuing to execute
383 before a child's init() routine is complete. Say the init() routine
384 needs to open a socket or a temp file that the parent wants to connect
385 to; without this synchronization, the parent will need to implement a
386 retry loop to wait for the child to run, since often, the parent gets a
387 lot of things done before the child's first timeslice is allocated.
389 This is also quite necessary for pseudo-tty initialization, which needs
390 to take place before the parent writes to the child via pty. Writes
391 that occur before the pty is set up can get lost.
393 A final, minor, nicety is that debugging output from the child will be
394 emitted before the parent continues on, making for much clearer debugging
395 output in complex situations.
397 The only drawback I can conceive of is that the parent can't continue to
398 operate while the child is being initted. If this ever becomes a
399 problem in the field, we can implement an option to avoid this behavior,
400 but I don't expect it to.
402 B<Win32>: executing CODE references isn't supported on Win32, see
403 L</Win32 LIMITATIONS> for details.
407 run(), start(), and harness() can all take a harness specification
408 as input. A harness specification is either a single string to be passed
409 to the systems' shell:
411 run "echo 'hi there'";
413 or a list of commands, io operations, and/or timers/timeouts to execute.
414 Consecutive commands must be separated by a pipe operator '|' or an '&'.
415 External commands are passed in as array references, and, on systems
416 supporting fork(), Perl code may be passed in as subs:
419 run \@cmd1, '|', \@cmd2;
420 run \@cmd1, '&', \@cmd2;
422 run \&sub1, '|', \&sub2;
423 run \&sub1, '&', \&sub2;
425 '|' pipes the stdout of \@cmd1 the stdin of \@cmd2, just like a
426 shell pipe. '&' does not. Child processes to the right of a '&'
427 will have their stdin closed unless it's redirected-to.
429 L<IPC::Run::IO> objects may be passed in as well, whether or not
430 child processes are also specified:
432 run io( "infile", ">", \$in ), io( "outfile", "<", \$in );
434 as can L<IPC::Run::Timer> objects:
436 run \@cmd, io( "outfile", "<", \$in ), timeout( 10 );
438 Commands may be followed by scalar, sub, or i/o handle references for
440 child process input & output:
442 run \@cmd, \undef, \$out;
443 run \@cmd, \$in, \$out;
444 run \@cmd1, \&in, '|', \@cmd2, \*OUT;
445 run \@cmd1, \*IN, '|', \@cmd2, \&out;
447 This is known as succinct redirection syntax, since run(), start()
448 and harness(), figure out which file descriptor to redirect and how.
449 File descriptor 0 is presumed to be an input for
450 the child process, all others are outputs. The assumed file
451 descriptor always starts at 0, unless the command is being piped to,
452 in which case it starts at 1.
454 To be explicit about your redirects, or if you need to do more complex
455 things, there's also a redirection operator syntax:
457 run \@cmd, '<', \undef, '>', \$out;
458 run \@cmd, '<', \undef, '>&', \$out_and_err;
466 Operator syntax is required if you need to do something other than simple
467 redirection to/from scalars or subs, like duping or closing file descriptors
468 or redirecting to/from a named file. The operators are covered in detail
471 After each \@cmd (or \&foo), parsing begins in succinct mode and toggles to
472 operator syntax mode when an operator (ie plain scalar, not a ref) is seen.
474 operator syntax mode, parsing only reverts to succinct mode when a '|' or
477 In succinct mode, each parameter after the \@cmd specifies what to
478 do with the next highest file descriptor. These File descriptor start
479 with 0 (stdin) unless stdin is being piped to (C<'|', \@cmd>), in which
480 case they start with 1 (stdout). Currently, being on the left of
481 a pipe (C<\@cmd, \$out, \$err, '|'>) does I<not> cause stdout to be
482 skipped, though this may change since it's not as DWIMerly as it
483 could be. Only stdin is assumed to be an
484 input in succinct mode, all others are assumed to be outputs.
486 If no piping or redirection is specified for a child, it will inherit
487 the parent's open file handles as dictated by your system's
488 close-on-exec behavior and the $^F flag, except that processes after a
489 '&' will not inherit the parent's stdin. Also note that $^F does not
490 affect file desciptors obtained via POSIX, since it only applies to
491 full-fledged Perl file handles. Such processes will have their stdin
492 closed unless it has been redirected-to.
494 If you want to close a child processes stdin, you may do any of:
501 Redirection is done by placing redirection specifications immediately
502 after a command or child subroutine:
504 run \@cmd1, \$in, '|', \@cmd2, \$out;
505 run \@cmd1, '<', \$in, '|', \@cmd2, '>', \$out;
507 If you omit the redirection operators, descriptors are counted
508 starting at 0. Descriptor 0 is assumed to be input, all others
509 are outputs. A leading '|' consumes descriptor 0, so this
512 run \@cmd1, \$in, '|', \@cmd2, \$out;
514 The parameter following a redirection operator can be a scalar ref,
515 a subroutine ref, a file name, an open filehandle, or a closed
518 If it's a scalar ref, the child reads input from or sends output to
521 $in = "Hello World.\n";
522 run \@cat, \$in, \$out;
525 Scalars used in incremental (start()/pump()/finish()) applications are treated
526 as queues: input is removed from input scalers, resulting in them dwindling
527 to '', and output is appended to output scalars. This is not true of
528 harnesses run() in batch mode.
530 It's usually wise to append new input to be sent to the child to the input
531 queue, and you'll often want to zap output queues to '' before pumping.
533 $h = start \@cat, \$in;
541 The final call to finish() must be there: it allows the child process(es)
542 to run to completion and waits for their exit values.
544 =head1 OBSTINATE CHILDREN
546 Interactive applications are usually optimized for human use. This
547 can help or hinder trying to interact with them through modules like
548 IPC::Run. Frequently, programs alter their behavior when they detect
549 that stdin, stdout, or stderr are not connected to a tty, assuming that
550 they are being run in batch mode. Whether this helps or hurts depends
551 on which optimizations change. And there's often no way of telling
552 what a program does in these areas other than trial and error and,
553 occasionally, reading the source. This includes different versions
554 and implementations of the same program.
556 All hope is not lost, however. Most programs behave in reasonably
557 tractable manners, once you figure out what it's trying to do.
559 Here are some of the issues you might need to be aware of.
565 fflush()ing stdout and stderr
567 This lets the user see stdout and stderr immediately. Many programs
568 undo this optimization if stdout is not a tty, making them harder to
569 manage by things like IPC::Run.
571 Many programs decline to fflush stdout or stderr if they do not
572 detect a tty there. Some ftp commands do this, for instance.
574 If this happens to you, look for a way to force interactive behavior,
575 like a command line switch or command. If you can't, you will
576 need to use a pseudo terminal ('<pty<' and '>pty>').
582 Interactive programs generally do not guarantee that output from user
583 commands won't contain a prompt string. For example, your shell prompt
584 might be a '$', and a file named '$' might be the only file in a directory
587 This can make it hard to guarantee that your output parser won't be fooled
588 into early termination of results.
590 To help work around this, you can see if the program can alter it's
591 prompt, and use something you feel is never going to occur in actual
594 You should also look for your prompt to be the only thing on a line:
596 pump $h until $out =~ /^<SILLYPROMPT>\s?\z/m;
598 (use C<(?!\n)\Z> in place of C<\z> on older perls).
600 You can also take the approach that IPC::ChildSafe takes and emit a
601 command with known output after each 'real' command you issue, then
602 look for this known output. See new_appender() and new_chunker() for
603 filters that can help with this task.
605 If it's not convenient or possibly to alter a prompt or use a known
606 command/response pair, you might need to autodetect the prompt in case
607 the local version of the child program is different then the one
608 you tested with, or if the user has control over the look & feel of
613 Refusing to accept input unless stdin is a tty.
615 Some programs, for security reasons, will only accept certain types
616 of input from a tty. su, notable, will not prompt for a password unless
617 it's connected to a tty.
619 If this is your situation, use a pseudo terminal ('<pty<' and '>pty>').
623 Not prompting unless connected to a tty.
625 Some programs don't prompt unless stdin or stdout is a tty. See if you can
626 turn prompting back on. If not, see if you can come up with a command that
627 you can issue after every real command and look for it's output, as
628 IPC::ChildSafe does. There are two filters included with IPC::Run that
629 can help with doing this: appender and chunker (see new_appender() and
634 Different output format when not connected to a tty.
636 Some commands alter their formats to ease machine parsability when they
637 aren't connected to a pipe. This is actually good, but can be surprising.
641 =head1 PSEUDO TERMINALS
643 On systems providing pseudo terminals under /dev, IPC::Run can use IO::Pty
644 (available on CPAN) to provide a terminal environment to subprocesses.
645 This is necessary when the subprocess really wants to think it's connected
650 Psuedo-terminals are not pipes, though they are similar. Here are some
651 differences to watch out for.
657 Sending to stdin will cause an echo on stdout, which occurs before each
658 line is passed to the child program. There is currently no way to
659 disable this, although the child process can and should disable it for
660 things like passwords.
664 IPC::Run cannot close a pty until all output has been collected. This
665 means that it is not possible to send an EOF to stdin by half-closing
666 the pty, as we can when using a pipe to stdin.
668 This means that you need to send the child process an exit command or
669 signal, or run() / finish() will time out. Be careful not to expect a
670 prompt after sending the exit command.
672 =item Command line editing
674 Some subprocesses, notable shells that depend on the user's prompt
675 settings, will reissue the prompt plus the command line input so far
676 once for each character.
678 =item '>pty>' means '&>pty>', not '1>pty>'
680 The pseudo terminal redirects both stdout and stderr unless you specify
681 a file descriptor. If you want to grab stderr separately, do this:
683 start \@cmd, '<pty<', \$in, '>pty>', \$out, '2>', \$err;
685 =item stdin, stdout, and stderr not inherited
687 Child processes harnessed to a pseudo terminal have their stdin, stdout,
688 and stderr completely closed before any redirection operators take
689 effect. This casts of the bonds of the controlling terminal. This is
690 not done when using pipes.
692 Right now, this affects all children in a harness that has a pty in use,
693 even if that pty would not affect a particular child. That's a bug and
694 will be fixed. Until it is, it's best not to mix-and-match children.
698 =head2 Redirection Operators
700 Operator SHNP Description
701 ======== ==== ===========
702 <, N< SHN Redirects input to a child's fd N (0 assumed)
704 >, N> SHN Redirects output from a child's fd N (1 assumed)
705 >>, N>> SHN Like '>', but appends to scalars or named files
706 >&, &> SHN Redirects stdout & stderr from a child process
708 <pty, N<pty S Like '<', but uses a pseudo-tty instead of a pipe
709 >pty, N>pty S Like '>', but uses a pseudo-tty instead of a pipe
711 N<&M Dups input fd N to input fd M
712 M>&N Dups output fd N to input fd M
715 <pipe, N<pipe P Pipe opens H for caller to read, write, close.
716 >pipe, N>pipe P Pipe opens H for caller to read, write, close.
718 'N' and 'M' are placeholders for integer file descriptor numbers. The
719 terms 'input' and 'output' are from the child process's perspective.
721 The SHNP field indicates what parameters an operator can take:
723 S: \$scalar or \&function references. Filters may be used with
724 these operators (and only these).
725 H: \*HANDLE or IO::Handle for caller to open, and close
727 P: \*HANDLE opened by IPC::Run as the parent end of a pipe, but read
728 and written to and closed by the caller (like IPC::Open3).
732 =item Redirecting input: [n]<, [n]<pipe
734 You can input the child reads on file descriptor number n to come from a
735 scalar variable, subroutine, file handle, or a named file. If stdin
736 is not redirected, the parent's stdin is inherited.
738 run \@cat, \undef ## Closes child's stdin immediately
739 or die "cat returned $?";
743 run \@cat, \<<TOHERE;
747 run \@cat, \&input; ## Calls &input, feeding data returned
748 ## to child's. Closes child's stdin
749 ## when undef is returned.
751 Redirecting from named files requires you to use the input
752 redirection operator:
754 run \@cat, '<.profile';
755 run \@cat, '<', '.profile';
761 The form used second example here is the safest,
762 since filenames like "0" and "&more\n" won't confuse &run:
764 You can't do either of
766 run \@a, *IN; ## INVALID
767 run \@a, '<', *IN; ## BUGGY: Reads file named like "*main::A"
769 because perl passes a scalar containing a string that
770 looks like "*main::A" to &run, and &run can't tell the difference
771 between that and a redirection operator or a file name. &run guarantees
772 that any scalar you pass after a redirection operator is a file name.
774 If your child process will take input from file descriptors other
775 than 0 (stdin), you can use a redirection operator with any of the
776 valid input forms (scalar ref, sub ref, etc.):
778 run \@cat, '3<', \$in3;
780 When redirecting input from a scalar ref, the scalar ref is
781 used as a queue. This allows you to use &harness and pump() to
782 feed incremental bits of input to a coprocess. See L</Coprocesses>
783 below for more information.
785 The <pipe operator opens the write half of a pipe on the filehandle
786 glob reference it takes as an argument:
788 $h = start \@cat, '<pipe', \*IN;
789 print IN "hello world\n";
794 Unlike the other '<' operators, IPC::Run does nothing further with
795 it: you are responsible for it. The previous example is functionally
798 pipe( \*R, \*IN ) or die $!;
799 $h = start \@cat, '<', \*IN;
800 print IN "hello world\n";
805 This is like the behavior of IPC::Open2 and IPC::Open3.
807 B<Win32>: The handle returned is actually a socket handle, so you can
810 =item Redirecting output: [n]>, [n]>>, [n]>&[m], [n]>pipe
812 You can redirect any output the child emits
813 to a scalar variable, subroutine, file handle, or file name. You
814 can have &run truncate or append to named files or scalars. If
815 you are redirecting stdin as well, or if the command is on the
816 receiving end of a pipeline ('|'), you can omit the redirection
820 run \@ls, \undef, \$out
821 or die "ls returned $?";
823 run \@ls, \undef, \&out; ## Calls &out each time some output
824 ## is received from the child's
825 ## when undef is returned.
827 run \@ls, \undef, '2>ls.err';
828 run \@ls, '2>', 'ls.err';
830 The two parameter form guarantees that the filename
831 will not be interpreted as a redirection operator:
833 run \@ls, '>', "&more";
834 run \@ls, '2>', ">foo\n";
836 You can pass file handles you've opened for writing:
838 open( *OUT, ">out.txt" );
839 open( *ERR, ">err.txt" );
840 run \@cat, \*OUT, \*ERR;
842 Passing a scalar reference and a code reference requires a little
843 more work, but allows you to capture all of the output in a scalar
844 or each piece of output by a callback:
846 These two do the same things:
848 run( [ 'ls' ], '2>', sub { $err_out .= $_[0] } );
850 does the same basic thing as:
852 run( [ 'ls' ], '2>', \$err_out );
854 The subroutine will be called each time some data is read from the child.
856 The >pipe operator is different in concept than the other '>' operators,
857 although it's syntax is similar:
859 $h = start \@cat, $in, '>pipe', \*OUT, '2>pipe', \*ERR;
860 $in = "hello world\n";
867 causes two pipe to be created, with one end attached to cat's stdout
868 and stderr, respectively, and the other left open on OUT and ERR, so
869 that the script can manually
870 read(), select(), etc. on them. This is like
871 the behavior of IPC::Open2 and IPC::Open3.
873 B<Win32>: The handle returned is actually a socket handle, so you can
876 =item Duplicating output descriptors: >&m, n>&m
878 This duplicates output descriptor number n (default is 1 if n is omitted)
879 from descriptor number m.
881 =item Duplicating input descriptors: <&m, n<&m
883 This duplicates input descriptor number n (default is 0 if n is omitted)
884 from descriptor number m
886 =item Closing descriptors: <&-, 3<&-
888 This closes descriptor number n (default is 0 if n is omitted). The
889 following commands are equivalent:
893 run \@cmd, '<in.txt', '<&-';
897 run \@cmd, \$in, '<&-'; ## SIGPIPE recipe.
899 is dangerous: the parent will get a SIGPIPE if $in is not empty.
901 =item Redirecting both stdout and stderr: &>, >&, &>pipe, >pipe&
903 The following pairs of commands are equivalent:
905 run \@cmd, '>&', \$out; run \@cmd, '>', \$out, '2>&1';
906 run \@cmd, '>&', 'out.txt'; run \@cmd, '>', 'out.txt', '2>&1';
910 File descriptor numbers are not permitted to the left or the right of
911 these operators, and the '&' may occur on either end of the operator.
913 The '&>pipe' and '>pipe&' variants behave like the '>pipe' operator, except
914 that both stdout and stderr write to the created pipe.
916 =item Redirection Filters
918 Both input redirections and output redirections that use scalars or
919 subs as endpoints may have an arbitrary number of filter subs placed
920 between them and the child process. This is useful if you want to
921 receive output in chunks, or if you want to massage each chunk of
922 data sent to the child. To use this feature, you must use operator
927 '<', \&in_filter_2, \&in_filter_1, $in,
928 '>', \&out_filter_1, \&in_filter_2, $out,
931 This capability is not provided for IO handles or named files.
933 Two filters are provided by IPC::Run: appender and chunker. Because
934 these may take an argument, you need to use the constructor functions
935 new_appender() and new_chunker() rather than using \& syntax:
939 '<', new_appender( "\n" ), $in,
940 '>', new_chunker, $out,
945 =head2 Just doing I/O
947 If you just want to do I/O to a handle or file you open yourself, you
948 may specify a filehandle or filename instead of a command in the harness
951 run io( "filename", '>', \$recv );
953 $h = start io( $io, '>', \$recv );
955 $h = harness \@cmd, '&', io( "file", '<', \$send );
959 Options are passed in as name/value pairs:
961 run \@cat, \$in, debug => 1;
963 If you pass the debug option, you may want to pass it in first, so you
964 can see what parsing is going on:
966 run debug => 1, \@cat, \$in;
972 Enables debugging output in parent and child. Debugging info is emitted
973 to the STDERR that was present when IPC::Run was first C<use()>ed (it's
974 C<dup()>ed out of the way so that it can be redirected in children without
975 having debugging output emitted on it).
981 harness() and start() return a reference to an IPC::Run harness. This is
982 blessed in to the IPC::Run package, so you may make later calls to
983 functions as members if you like:
994 Of course, using method call syntax lets you deal with any IPC::Run
995 subclasses that might crop up, but don't hold your breath waiting for
998 run() and finish() return TRUE when all subcommands exit with a 0 result
999 code. B<This is the opposite of perl's system() command>.
1001 All routines raise exceptions (via die()) when error conditions are
1002 recognized. A non-zero command result is not treated as an error
1003 condition, since some commands are tests whose results are reported
1004 in their exit codes.
1012 use vars qw{$VERSION @ISA @FILTER_IMP @FILTERS @API @EXPORT_OK %EXPORT_TAGS};
1015 @ISA = qw{ Exporter };
1017 ## We use @EXPORT for the end user's convenience: there's only one function
1018 ## exported, it's homonymous with the module, it's an unusual name, and
1019 ## it can be suppressed by "use IPC::Run ();".
1020 @FILTER_IMP = qw( input_avail get_more_input );
1029 harness start pump pumpable finish
1030 signal kill_kill reap_nb
1035 @EXPORT_OK = ( @API, @FILTER_IMP, @FILTERS, qw( Win32_MODE ) );
1037 'filter_imp' => \@FILTER_IMP,
1038 'all' => \@EXPORT_OK,
1039 'filters' => \@FILTERS,
1046 use IPC::Run::Debug;
1054 require IPC::Run::IO;
1055 require IPC::Run::Timer;
1058 use constant Win32_MODE => $^O =~ /os2|Win32/i;
1062 eval "use IPC::Run::Win32Helper; 1;"
1063 or ( $@ && die ) or die "$!";
1066 eval "use File::Basename; 1;" or die $!;
1071 sub get_more_input();
1073 ###############################################################################
1076 ## State machine states, set in $self->{STATE}
1078 ## These must be in ascending order numerically
1082 sub _finished() {2} ## _finished behave almost exactly like _harnessed
1086 ## Which fds have been opened in the parent. This may have extra fds, since
1087 ## we aren't all that rigorous about closing these off, but that's ok. This
1088 ## is used on Unixish OSs to close all fds in the child that aren't needed
1089 ## by that particular child.
1092 ## There's a bit of hackery going on here.
1094 ## We want to have any code anywhere be able to emit
1095 ## debugging statements without knowing what harness the code is
1096 ## being called in/from, since we'd need to pass a harness around to
1099 ## Thus, $cur_self was born.
1101 use vars qw( $cur_self );
1104 return fileno STDERR unless defined $cur_self;
1106 if ( _debugging && ! defined $cur_self->{DEBUG_FD} ) {
1107 my $fd = select STDERR; $| = 1; select $fd;
1108 $cur_self->{DEBUG_FD} = POSIX::dup fileno STDERR;
1109 _debug( "debugging fd is $cur_self->{DEBUG_FD}\n" )
1110 if _debugging_details;
1113 return fileno STDERR unless defined $cur_self->{DEBUG_FD};
1115 return $cur_self->{DEBUG_FD}
1119 ## We absolutely do not want to do anything else here. We are likely
1120 ## to be in a child process and we don't want to do things like kill_kill
1121 ## ourself or cause other destruction.
1122 my IPC::Run $self = shift;
1123 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD};
1124 $self->{DEBUG_FD} = undef;
1128 ## Support routines (NOT METHODS)
1133 my ( $cmd_name ) = @_;
1134 if ( File::Spec->file_name_is_absolute( $cmd_name ) && -x $cmd_name) {
1135 _debug "'", $cmd_name, "' is absolute"
1136 if _debugging_details;
1151 && ( $cmd_name =~ /$dirsep/ )
1152 && ( $cmd_name !~ /\..+$/ ) ## Only run if cmd_name has no extension?
1154 for ( split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE" ) {
1155 my $name = "$cmd_name$_";
1156 $cmd_name = $name, last if -f $name && -x _;
1160 if ( $cmd_name =~ /($dirsep)/ ) {
1161 _debug "'$cmd_name' contains '$1'" if _debugging;
1162 croak "file not found: $cmd_name" unless -e $cmd_name;
1163 croak "not a file: $cmd_name" unless -f $cmd_name;
1164 croak "permission denied: $cmd_name" unless -x $cmd_name;
1168 if ( exists $cmd_cache{$cmd_name} ) {
1169 _debug "'$cmd_name' found in cache: '$cmd_cache{$cmd_name}'"
1171 return $cmd_cache{$cmd_name} if -x $cmd_cache{$cmd_name};
1172 _debug "'$cmd_cache{$cmd_name}' no longer executable, searching..."
1174 delete $cmd_cache{$cmd_name};
1179 ## This next bit is Unix/Win32 specific, unfortunately.
1180 ## There's been some conversation about extending File::Spec to provide
1181 ## a universal interface to PATH, but I haven't seen it yet.
1182 my $re = Win32_MODE ? qr/;/ : qr/:/;
1185 for ( split( $re, $ENV{PATH}, -1 ) ) {
1186 $_ = "." unless length $_;
1187 push @searched_in, $_;
1189 my $prospect = File::Spec->catfile( $_, $cmd_name );
1193 ( Win32_MODE && ! ( -f $prospect && -x _ ) )
1194 ? map "$prospect$_", split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE"
1197 for my $found ( @prospects ) {
1198 if ( -f $found && -x _ ) {
1199 $cmd_cache{$cmd_name} = $found;
1205 if ( exists $cmd_cache{$cmd_name} ) {
1206 _debug "'", $cmd_name, "' added to cache: '", $cmd_cache{$cmd_name}, "'"
1207 if _debugging_details;
1208 return $cmd_cache{$cmd_name};
1211 croak "Command '$cmd_name' not found in " . join( ", ", @searched_in );
1215 sub _empty($) { ! ( defined $_[0] && length $_[0] ) }
1217 ## 'safe' versions of otherwise fun things to do. See also IPC::Run::Win32Helper.
1219 confess 'undef' unless defined $_[0];
1221 my $fd = $_[0] =~ /^\d+$/ ? $_[0] : fileno $_[0];
1222 my $r = POSIX::close $fd;
1223 $r = $r ? '' : " ERROR $!";
1225 _debug "close( $fd ) = " . ( $r || 0 ) if _debugging_details;
1229 confess 'undef' unless defined $_[0];
1230 my $r = POSIX::dup( $_[0] );
1231 croak "$!: dup( $_[0] )" unless defined $r;
1232 $r = 0 if $r eq '0 but true';
1233 _debug "dup( $_[0] ) = $r" if _debugging_details;
1240 confess 'undef' unless defined $_[0] && defined $_[1];
1241 my $r = POSIX::dup2( $_[0], $_[1] );
1242 croak "$!: dup2( $_[0], $_[1] )" unless defined $r;
1243 $r = 0 if $r eq '0 but true';
1244 _debug "dup2( $_[0], $_[1] ) = $r" if _debugging_details;
1250 confess 'undef passed' if grep !defined, @_;
1251 # exec @_ or croak "$!: exec( " . join( ', ', @_ ) . " )";
1252 _debug 'exec()ing ', join " ", map "'$_'", @_ if _debugging_details;
1255 ## Commented out since we don't call this on Win32.
1256 # # This works around the bug where 5.6.1 complains
1257 # # "Can't exec ...: No error" after an exec on NT, where
1258 # # exec() is simulated and actually returns in Perl's C
1259 # # code, though Perl's &exec does not...
1260 # no warnings "exec";
1262 # # Just in case the no warnings workaround
1263 # # stops beign a workaround, we don't want
1264 # # old values of $! causing spurious strerr()
1265 # # messages to appear in the "Can't exec" message
1269 # croak "$!: exec( " . join( ', ', map "'$_'", @_ ) . " )";
1270 ## Fall through so $! can be reported to parent.
1275 confess 'undef' unless defined $_[0] && defined $_[1];
1276 _debug sprintf( "O_RDONLY=0x%02x ", O_RDONLY ),
1277 sprintf( "O_WRONLY=0x%02x ", O_WRONLY ),
1278 sprintf( "O_RDWR=0x%02x ", O_RDWR ),
1279 sprintf( "O_TRUNC=0x%02x ", O_TRUNC),
1280 sprintf( "O_CREAT=0x%02x ", O_CREAT),
1281 sprintf( "O_APPEND=0x%02x ", O_APPEND),
1282 if _debugging_details;
1283 my $r = POSIX::open( $_[0], $_[1], 0644 );
1284 croak "$!: open( $_[0], ", sprintf( "0x%03x", $_[1] ), " )" unless defined $r;
1285 _debug "open( $_[0], ", sprintf( "0x%03x", $_[1] ), " ) = $r"
1292 ## Normal, blocking write for pipes that we read and the child writes,
1293 ## since most children expect writes to stdout to block rather than
1294 ## do a partial write.
1295 my ( $r, $w ) = POSIX::pipe;
1296 croak "$!: pipe()" unless defined $r;
1297 _debug "pipe() = ( $r, $w ) " if _debugging_details;
1298 $fds{$r} = $fds{$w} = 1;
1303 ## For pipes that we write, unblock the write side, so we can fill a buffer
1304 ## and continue to select().
1305 ## Contributed by Borislav Deianov <borislav@ensim.com>, with minor
1306 ## bugfix on fcntl result by me.
1308 my $f = pipe( R, W );
1309 croak "$!: pipe()" unless defined $f;
1310 my ( $r, $w ) = ( fileno R, fileno W );
1311 _debug "pipe_nb pipe() = ( $r, $w )" if _debugging_details;
1312 unless ( Win32_MODE ) {
1313 ## POSIX::fcntl doesn't take fd numbers, so gotta use Perl's and
1314 ## then _dup the originals (which get closed on leaving this block)
1315 my $fres = fcntl( W, &F_SETFL, O_WRONLY | O_NONBLOCK );
1316 croak "$!: fcntl( $w, F_SETFL, O_NONBLOCK )" unless $fres;
1317 _debug "fcntl( $w, F_SETFL, O_NONBLOCK )" if _debugging_details;
1319 ( $r, $w ) = ( _dup( $r ), _dup( $w ) );
1320 _debug "pipe_nb() = ( $r, $w )" if _debugging_details;
1326 my $pty = IO::Pty->new();
1327 croak "$!: pty ()" unless $pty;
1329 $pty->blocking( 0 ) or croak "$!: pty->blocking ( 0 )";
1330 _debug "pty() = ( ", $pty->fileno, ", ", $pty->slave->fileno, " )"
1331 if _debugging_details;
1332 $fds{$pty->fileno} = $fds{$pty->slave->fileno} = 1;
1338 confess 'undef' unless defined $_[0];
1340 my $r = POSIX::read( $_[0], $s, 10_000 );
1341 croak "$!: read( $_[0] )" if not($r) and $! != POSIX::EINTR;
1343 _debug "read( $_[0] ) = $r chars '$s'" if _debugging_data;
1348 ## A METHOD, not a function.
1350 my IPC::Run $self = shift;
1353 _debug "opening sync pipe ", $kid->{PID} if _debugging_details;
1355 ( $sync_reader_fd, $self->{SYNC_WRITER_FD} ) = _pipe;
1356 $kid->{PID} = fork();
1357 croak "$! during fork" unless defined $kid->{PID};
1359 unless ( $kid->{PID} ) {
1360 ## _do_kid_and_exit closes sync_reader_fd since it closes all unwanted and
1362 $self->_do_kid_and_exit( $kid );
1364 _debug "fork() = ", $kid->{PID} if _debugging_details;
1366 ## Wait for kid to get to it's exec() and see if it fails.
1367 _close $self->{SYNC_WRITER_FD};
1368 my $sync_pulse = _read $sync_reader_fd;
1369 _close $sync_reader_fd;
1371 if ( ! defined $sync_pulse || length $sync_pulse ) {
1372 if ( waitpid( $kid->{PID}, 0 ) >= 0 ) {
1373 $kid->{RESULT} = $?;
1376 $kid->{RESULT} = -1;
1379 "error reading synchronization pipe for $kid->{NUM}, pid $kid->{PID}"
1380 unless length $sync_pulse;
1385 ## Wait for pty to get set up. This is a hack until we get synchronous
1387 if ( keys %{$self->{PTYS}} && $IO::Pty::VERSION < 0.9 ) {
1388 _debug "sleeping to give pty a chance to init, will fix when newer IO::Pty arrives.";
1395 confess 'undef' unless defined $_[0] && defined $_[1];
1396 my $r = POSIX::write( $_[0], $_[1], length $_[1] );
1397 croak "$!: write( $_[0], '$_[1]' )" unless $r;
1398 _debug "write( $_[0], '$_[1]' ) = $r" if _debugging_data;
1408 Run takes a harness or harness specification and runs it, pumping
1409 all input to the child(ren), closing the input pipes when no more
1410 input is available, collecting all output that arrives, until the
1411 pipes delivering output are closed, then waiting for the children to
1412 exit and reaping their result codes.
1414 You may think of C<run( ... )> as being like
1416 start( ... )->finish();
1418 , though there is one subtle difference: run() does not
1419 set \$input_scalars to '' like finish() does. If an exception is thrown
1420 from run(), all children will be killed off "gently", and then "annihilated"
1421 if they do not go gently (in to that dark night. sorry).
1423 If any exceptions are thrown, this does a L</kill_kill> before propogating
1428 use vars qw( $in_run ); ## No, not Enron;)
1431 local $in_run = 1; ## Allow run()-only optimizations.
1432 my IPC::Run $self = start( @_ );
1434 $self->{clear_ins} = 0;
1449 ## To send it a specific signal by name ("USR1"):
1451 $h->signal ( "USR1" );
1453 If $signal is provided and defined, sends a signal to all child processes. Try
1454 not to send numeric signals, use C<"KILL"> instead of C<9>, for instance.
1455 Numeric signals aren't portable.
1457 Throws an exception if $signal is undef.
1459 This will I<not> clean up the harness, C<finish> it if you kill it.
1461 Normally TERM kills a process gracefully (this is what the command line utility
1462 C<kill> does by default), INT is sent by one of the keys C<^C>, C<Backspace> or
1463 C<E<lt>DelE<gt>>, and C<QUIT> is used to kill a process and make it coredump.
1465 The C<HUP> signal is often used to get a process to "restart", rereading
1466 config files, and C<USR1> and C<USR2> for really application-specific things.
1468 Often, running C<kill -l> (that's a lower case "L") on the command line will
1469 list the signals present on your operating system.
1471 B<WARNING>: The signal subsystem is not at all portable. We *may* offer
1472 to simulate C<TERM> and C<KILL> on some operating systems, submit code
1473 to me if you want this.
1475 B<WARNING 2>: Up to and including perl v5.6.1, doing almost anything in a
1476 signal handler could be dangerous. The most safe code avoids all
1477 mallocs and system calls, usually by preallocating a flag before
1478 entering the signal handler, altering the flag's value in the
1479 handler, and responding to the changed value in the main system:
1482 sub usr1_handler { ++$got_signal }
1484 $SIG{USR1} = \&usr1_handler;
1485 while () { sleep 1; print "GOT IT" while $got_usr1--; }
1487 Even this approach is perilous if ++ and -- aren't atomic on your system
1488 (I've never heard of this on any modern CPU large enough to run perl).
1493 my IPC::Run $self = shift;
1495 local $cur_self = $self;
1497 $self->_kill_kill_kill_pussycat_kill unless @_;
1499 Carp::cluck "Ignoring extra parameters passed to kill()" if @_ > 1;
1501 my ( $signal ) = @_;
1502 croak "Undefined signal passed to signal" unless defined $signal;
1503 for ( grep $_->{PID} && ! defined $_->{RESULT}, @{$self->{KIDS}} ) {
1504 _debug "sending $signal to $_->{PID}"
1506 kill $signal, $_->{PID}
1507 or _debugging && _debug "$! sending $signal to $_->{PID}";
1517 ## To kill off a process:
1521 ## To specify the grace period other than 30 seconds:
1522 kill_kill $h, grace => 5;
1524 ## To send QUIT instead of KILL if a process refuses to die:
1525 kill_kill $h, coup_d_grace => "QUIT";
1527 Sends a C<TERM>, waits for all children to exit for up to 30 seconds, then
1528 sends a C<KILL> to any that survived the C<TERM>.
1530 Will wait for up to 30 more seconds for the OS to sucessfully C<KILL> the
1533 The 30 seconds may be overriden by setting the C<grace> option, this
1534 overrides both timers.
1536 The harness is then cleaned up.
1538 The doubled name indicates that this function may kill again and avoids
1539 colliding with the core Perl C<kill> function.
1541 Returns a 1 if the C<TERM> was sufficient, or a 0 if C<KILL> was
1542 required. Throws an exception if C<KILL> did not permit the children
1545 B<NOTE>: The grace period is actually up to 1 second longer than that
1546 given. This is because the granularity of C<time> is 1 second. Let me
1547 know if you need finer granularity, we can leverage Time::HiRes here.
1549 B<Win32>: Win32 does not know how to send real signals, so C<TERM> is
1550 a full-force kill on Win32. Thus all talk of grace periods, etc. do
1556 my IPC::Run $self = shift;
1559 my $grace = $options{grace};
1560 $grace = 30 unless defined $grace;
1561 ++$grace; ## Make grace time a _minimum_
1563 my $coup_d_grace = $options{coup_d_grace};
1564 $coup_d_grace = "KILL" unless defined $coup_d_grace;
1566 delete $options{$_} for qw( grace coup_d_grace );
1567 Carp::cluck "Ignoring unknown options for kill_kill: ",
1568 join " ",keys %options
1571 $self->signal( "TERM" );
1573 my $quitting_time = time + $grace;
1577 my $have_killed_before;
1580 ## delay first to yeild to other processes
1581 select undef, undef, undef, $delay;
1582 $accum_delay += $delay;
1585 last unless $self->_running_kids;
1587 if ( $accum_delay >= $grace*0.8 ) {
1588 ## No point in checking until delay has grown some.
1589 if ( time >= $quitting_time ) {
1590 if ( ! $have_killed_before ) {
1591 $self->signal( $coup_d_grace );
1592 $have_killed_before = 1;
1593 $quitting_time += $grace;
1598 croak "Unable to reap all children, even after KILLing them"
1603 $delay = 0.5 if $delay >= 0.5;
1607 return $have_killed_before;
1614 Takes a harness specification and returns a harness. This harness is
1615 blessed in to IPC::Run, allowing you to use method call syntax for
1616 run(), start(), et al if you like.
1618 harness() is provided so that you can pre-build harnesses if you
1619 would like to, but it's not required..
1621 You may proceed to run(), start() or pump() after calling harness() (pump()
1622 calls start() if need be). Alternatively, you may pass your
1623 harness specification to run() or start() and let them harness() for
1624 you. You can't pass harness specifications to pump(), though.
1629 ## Notes: I've avoided handling a scalar that doesn't look like an
1630 ## opcode as a here document or as a filename, though I could DWIM
1631 ## those. I'm not sure that the advantages outweight the danger when
1632 ## the DWIMer guesses wrong.
1634 ## TODO: allow user to spec default shell. Hmm, globally, in the
1635 ## lexical scope hash, or per instance? 'Course they can do that
1636 ## now by using a [...] to hold the command.
1641 if ( @_ && ref $_[-1] eq 'HASH' ) {
1643 require Data::Dumper;
1644 carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper( $options );
1647 # local $IPC::Run::debug = $options->{debug}
1648 # if $options && defined $options->{debug};
1651 if ( @_ == 1 && ! ref $_[0] ) {
1653 my $command = $ENV{ComSpec} || 'cmd';
1654 @args = ( [ $command, '/c', win32_parse_cmd_line $_[0] ] );
1657 @args = ( [ qw( sh -c ), @_ ] );
1660 elsif ( @_ > 1 && ! grep ref $_, @_ ) {
1667 my @errs; # Accum errors, emit them when done.
1669 my $succinct; # set if no redir ops are required yet. Cleared
1672 my $cur_kid; # references kid or handle being parsed
1674 my $assumed_fd = 0; # fd to assume in succinct mode (no redir ops)
1675 my $handle_num = 0; # 1... is which handle we're parsing
1677 my IPC::Run $self = bless {}, __PACKAGE__;
1679 local $cur_self = $self;
1681 $self->{ID} = ++$harness_id;
1684 $self->{PIPES} = [];
1686 $self->{STATE} = _newed;
1689 $self->{$_} = $options->{$_}
1693 _debug "****** harnessing *****" if _debugging;
1697 my $arg_count = @args;
1698 while ( @args ) { for ( shift @args ) {
1705 ? ( '[ ', join( ', ', map "'$_'", @$_ ), ' ]' )
1709 : join( '', "'", substr( $_, 0, 10 ), "...'" )
1716 if ( ref eq 'ARRAY' || ( ! $cur_kid && ref eq 'CODE' ) ) {
1717 croak "Process control symbol ('|', '&') missing" if $cur_kid;
1718 croak "Can't spawn a subroutine on Win32"
1719 if Win32_MODE && ref eq "CODE";
1723 NUM => @{$self->{KIDS}} + 1,
1728 push @{$self->{KIDS}}, $cur_kid;
1732 elsif ( UNIVERSAL::isa( $_, 'IPC::Run::IO' ) ) {
1733 push @{$self->{IOS}}, $_;
1738 elsif ( UNIVERSAL::isa( $_, 'IPC::Run::Timer' ) ) {
1739 push @{$self->{TIMERS}}, $_;
1744 elsif ( /^(\d*)>&(\d+)$/ ) {
1745 croak "No command before '$_'" unless $cur_kid;
1746 push @{$cur_kid->{OPS}}, {
1749 KFD2 => length $1 ? $1 : 1,
1751 _debug "redirect operators now required" if _debugging_details;
1752 $succinct = ! $first_parse;
1755 elsif ( /^(\d*)<&(\d+)$/ ) {
1756 croak "No command before '$_'" unless $cur_kid;
1757 push @{$cur_kid->{OPS}}, {
1760 KFD2 => length $1 ? $1 : 0,
1762 $succinct = ! $first_parse;
1765 elsif ( /^(\d*)<&-$/ ) {
1766 croak "No command before '$_'" unless $cur_kid;
1767 push @{$cur_kid->{OPS}}, {
1769 KFD => length $1 ? $1 : 0,
1771 $succinct = ! $first_parse;
1775 /^(\d*) (<pipe)() () () $/x
1776 || /^(\d*) (<pty) ((?:\s+\S+)?) (<) () $/x
1777 || /^(\d*) (<) () () (.*)$/x
1779 croak "No command before '$_'" unless $cur_kid;
1781 $succinct = ! $first_parse;
1785 my $kfd = length $1 ? $1 : 0;
1788 if ( $type eq '<pty<' ) {
1789 $pty_id = length $3 ? $3 : '0';
1790 ## do the require here to cause early error reporting
1792 ## Just flag the pyt's existence for now. It'll be
1793 ## converted to a real IO::Pty by _open_pipes.
1794 $self->{PTYS}->{$pty_id} = undef;
1802 unless ( length $source ) {
1803 if ( ! $succinct ) {
1806 ( ref $args[1] && ! UNIVERSAL::isa $args[1], "IPC::Run::Timer" )
1807 || UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter"
1810 if ( UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
1811 $binmode = shift( @args )->();
1814 push @filters, shift @args
1818 $source = shift @args;
1819 croak "'$_' missing a source" if _empty $source;
1822 'Kid ', $cur_kid->{NUM}, "'s input fd ", $kfd,
1823 ' has ', scalar( @filters ), ' filters.'
1824 ) if _debugging_details && @filters;
1827 my IPC::Run::IO $pipe = IPC::Run::IO->_new_internal(
1828 $type, $kfd, $pty_id, $source, $binmode, @filters
1831 if ( ( ref $source eq 'GLOB' || UNIVERSAL::isa $source, 'IO::Handle' )
1832 && $type !~ /^<p(ty<|ipe)$/
1834 _debug "setting DONT_CLOSE" if _debugging_details;
1835 $pipe->{DONT_CLOSE} = 1; ## this FD is not closed by us.
1836 _dont_inherit( $source ) if Win32_MODE;
1839 push @{$cur_kid->{OPS}}, $pipe;
1842 elsif ( /^() (>>?) (&) () (.*)$/x
1843 || /^() (&) (>pipe) () () $/x
1844 || /^() (>pipe)(&) () () $/x
1845 || /^(\d*)() (>pipe) () () $/x
1846 || /^() (&) (>pty) ( \w*)> () $/x
1847 ## TODO: || /^() (>pty) (\d*)> (&) () $/x
1848 || /^(\d*)() (>pty) ( \w*)> () $/x
1849 || /^() (&) (>>?) () (.*)$/x
1850 || /^(\d*)() (>>?) () (.*)$/x
1852 croak "No command before '$_'" unless $cur_kid;
1854 $succinct = ! $first_parse;
1857 $2 eq '>pipe' || $3 eq '>pipe'
1859 : $2 eq '>pty' || $3 eq '>pty'
1863 my $kfd = length $1 ? $1 : 1;
1864 my $trunc = ! ( $2 eq '>>' || $3 eq '>>' );
1866 $2 eq '>pty' || $3 eq '>pty'
1867 ? length $4 ? $4 : 0
1874 || ( ! length $1 && substr( $type, 0, 4 ) eq '>pty' );
1879 unless ( length $dest ) {
1880 if ( ! $succinct ) {
1881 ## unshift...shift: '>' filters source...sink left...right
1884 ( ref $args[1] && ! UNIVERSAL::isa $args[1], "IPC::Run::Timer" )
1885 || UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter"
1888 if ( UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
1889 $binmode = shift( @args )->();
1892 unshift @filters, shift @args;
1897 $dest = shift @args;
1900 'Kid ', $cur_kid->{NUM}, "'s output fd ", $kfd,
1901 ' has ', scalar( @filters ), ' filters.'
1902 ) if _debugging_details && @filters;
1904 if ( $type eq '>pty>' ) {
1905 ## do the require here to cause early error reporting
1907 ## Just flag the pyt's existence for now. _open_pipes()
1908 ## will new an IO::Pty for each key.
1909 $self->{PTYS}->{$pty_id} = undef;
1913 croak "'$_' missing a destination" if _empty $dest;
1914 my $pipe = IPC::Run::IO->_new_internal(
1915 $type, $kfd, $pty_id, $dest, $binmode, @filters
1917 $pipe->{TRUNC} = $trunc;
1919 if ( ( UNIVERSAL::isa( $dest, 'GLOB' ) || UNIVERSAL::isa( $dest, 'IO::Handle' ) )
1920 && $type !~ /^>(pty>|pipe)$/
1922 _debug "setting DONT_CLOSE" if _debugging_details;
1923 $pipe->{DONT_CLOSE} = 1; ## this FD is not closed by us.
1925 push @{$cur_kid->{OPS}}, $pipe;
1926 push @{$cur_kid->{OPS}}, {
1933 elsif ( $_ eq "|" ) {
1934 croak "No command before '$_'" unless $cur_kid;
1935 unshift @{$cur_kid->{OPS}}, {
1944 elsif ( $_ eq "&" ) {
1945 croak "No command before '$_'" unless $cur_kid;
1946 unshift @{$cur_kid->{OPS}}, {
1955 elsif ( $_ eq 'init' ) {
1956 croak "No command before '$_'" unless $cur_kid;
1957 push @{$cur_kid->{OPS}}, {
1963 elsif ( ! ref $_ ) {
1964 $self->{$_} = shift @args;
1967 elsif ( $_ eq 'init' ) {
1968 croak "No command before '$_'" unless $cur_kid;
1969 push @{$cur_kid->{OPS}}, {
1975 elsif ( $succinct && $first_parse ) {
1976 ## It's not an opcode, and no explicit opcodes have been
1977 ## seen yet, so assume it's a file name.
1979 if ( ! $assumed_fd ) {
1980 $_ = "$assumed_fd<",
1983 $_ = "$assumed_fd>",
1985 _debug "assuming '", $_, "'" if _debugging_details;
1995 ( ref() ? $_ : 'scalar' ),
1996 ' in harness() parameter ',
2003 _debug 'caught ', $@ if _debugging;
2007 die join( '', @errs ) if @errs;
2010 $self->{STATE} = _harnessed;
2011 # $self->timeout( $options->{timeout} ) if exists $options->{timeout};
2017 my IPC::Run $self = shift;
2023 ## When a pipe character is seen, a pipe is created. $pipe_read_fd holds
2024 ## the dangling read end of the pipe until we get to the next process.
2027 ## Output descriptors for the last command are shared by all children.
2028 ## @output_fds_accum accumulates the current set of output fds.
2029 my @output_fds_accum;
2031 for ( sort keys %{$self->{PTYS}} ) {
2032 _debug "opening pty '", $_, "'" if _debugging_details;
2034 $self->{PTYS}->{$_} = $pty;
2037 for ( @{$self->{IOS}} ) {
2041 _debug 'caught ', $@ if _debugging;
2044 push @close_on_fail, $_;
2048 ## Loop through the kids and their OPS, interpreting any that require
2049 ## parent-side actions.
2050 for my $kid ( @{$self->{KIDS}} ) {
2051 unless ( ref $kid->{VAL} eq 'CODE' ) {
2052 $kid->{PATH} = _search_path $kid->{VAL}->[0];
2054 if ( defined $pipe_read_fd ) {
2055 _debug "placing write end of pipe on kid $kid->{NUM}'s stdin"
2056 if _debugging_details;
2057 unshift @{$kid->{OPS}}, {
2058 TYPE => 'PIPE', ## Prevent next loop from triggering on this
2060 TFD => $pipe_read_fd,
2062 $pipe_read_fd = undef;
2064 @output_fds_accum = ();
2065 for my $op ( @{$kid->{OPS}} ) {
2066 # next if $op->{IS_DEBUG};
2068 if ( $op->{TYPE} eq '<' ) {
2069 my $source = $op->{SOURCE};
2070 if ( ! ref $source ) {
2072 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2073 " from '" . $source, "' (read only)"
2074 ) if _debugging_details;
2075 croak "simulated open failure"
2076 if $self->{_simulate_open_failure};
2077 $op->{TFD} = _sysopen( $source, O_RDONLY );
2078 push @close_on_fail, $op->{TFD};
2080 elsif ( UNIVERSAL::isa( $source, 'GLOB' )
2081 || UNIVERSAL::isa( $source, 'IO::Handle' )
2084 "Unopened filehandle in input redirect for $op->{KFD}"
2085 unless defined fileno $source;
2086 $op->{TFD} = fileno $source;
2088 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2089 " from fd ", $op->{TFD}
2090 ) if _debugging_details;
2092 elsif ( UNIVERSAL::isa( $source, 'SCALAR' ) ) {
2094 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2096 ) if _debugging_details;
2098 $op->open_pipe( $self->_debug_fd );
2099 push @close_on_fail, $op->{KFD}, $op->{FD};
2102 $op->{KIN_REF} = \$s;
2104 elsif ( UNIVERSAL::isa( $source, 'CODE' ) ) {
2106 'kid ', $kid->{NUM}, ' to read ', $op->{KFD}, ' from CODE'
2107 ) if _debugging_details;
2109 $op->open_pipe( $self->_debug_fd );
2110 push @close_on_fail, $op->{KFD}, $op->{FD};
2113 $op->{KIN_REF} = \$s;
2119 . "' not allowed as a source for input redirection"
2124 elsif ( $op->{TYPE} eq '<pipe' ) {
2126 'kid to read ', $op->{KFD},
2127 ' from a pipe IPC::Run opens and returns',
2128 ) if _debugging_details;
2130 my ( $r, $w ) = $op->open_pipe( $self->_debug_fd, $op->{SOURCE} );
2131 _debug "caller will write to ", fileno $op->{SOURCE}
2132 if _debugging_details;
2135 $op->{FD} = undef; # we don't manage this fd
2138 elsif ( $op->{TYPE} eq '<pty<' ) {
2140 'kid to read ', $op->{KFD}, " from pty '", $op->{PTY_ID}, "'",
2141 ) if _debugging_details;
2143 for my $source ( $op->{SOURCE} ) {
2144 if ( UNIVERSAL::isa( $source, 'SCALAR' ) ) {
2146 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2147 " from SCALAR via pty '", $op->{PTY_ID}, "'"
2148 ) if _debugging_details;
2151 $op->{KIN_REF} = \$s;
2153 elsif ( UNIVERSAL::isa( $source, 'CODE' ) ) {
2155 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2156 " from CODE via pty '", $op->{PTY_ID}, "'"
2157 ) if _debugging_details;
2159 $op->{KIN_REF} = \$s;
2165 . "' not allowed as a source for '<pty<' redirection"
2169 $op->{FD} = $self->{PTYS}->{$op->{PTY_ID}}->fileno;
2170 $op->{TFD} = undef; # The fd isn't known until after fork().
2173 elsif ( $op->{TYPE} eq '>' ) {
2174 ## N> output redirection.
2175 my $dest = $op->{DEST};
2176 if ( ! ref $dest ) {
2178 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2179 " to '", $dest, "' (write only, create, ",
2180 ( $op->{TRUNC} ? 'truncate' : 'append' ),
2182 ) if _debugging_details;
2183 croak "simulated open failure"
2184 if $self->{_simulate_open_failure};
2185 $op->{TFD} = _sysopen(
2189 | ( $op->{TRUNC} ? O_TRUNC : O_APPEND )
2193 ## I have no idea why this is needed to make the current
2194 ## file position survive the gyrations TFD must go
2196 POSIX::lseek( $op->{TFD}, 0, POSIX::SEEK_END() );
2198 push @close_on_fail, $op->{TFD};
2200 elsif ( UNIVERSAL::isa( $dest, 'GLOB' ) ) {
2202 "Unopened filehandle in output redirect, command $kid->{NUM}"
2203 ) unless defined fileno $dest;
2204 ## Turn on autoflush, mostly just to flush out
2206 my $old_fh = select( $dest ); $| = 1; select( $old_fh );
2207 $op->{TFD} = fileno $dest;
2209 'kid to write ', $op->{KFD}, ' to handle ', $op->{TFD}
2210 ) if _debugging_details;
2212 elsif ( UNIVERSAL::isa( $dest, 'SCALAR' ) ) {
2214 "kid ", $kid->{NUM}, " to write $op->{KFD} to SCALAR"
2215 ) if _debugging_details;
2217 $op->open_pipe( $self->_debug_fd );
2218 push @close_on_fail, $op->{FD}, $op->{TFD};
2219 $$dest = '' if $op->{TRUNC};
2221 elsif ( UNIVERSAL::isa( $dest, 'CODE' ) ) {
2223 "kid $kid->{NUM} to write $op->{KFD} to CODE"
2224 ) if _debugging_details;
2226 $op->open_pipe( $self->_debug_fd );
2227 push @close_on_fail, $op->{FD}, $op->{TFD};
2233 . "' not allowed as a sink for output redirection"
2236 $output_fds_accum[$op->{KFD}] = $op;
2240 elsif ( $op->{TYPE} eq '>pipe' ) {
2241 ## N> output redirection to a pipe we open, but don't select()
2244 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2245 ' to a pipe IPC::Run opens and returns'
2246 ) if _debugging_details;
2248 my ( $r, $w ) = $op->open_pipe( $self->_debug_fd, $op->{DEST} );
2249 _debug "caller will read from ", fileno $op->{DEST}
2250 if _debugging_details;
2253 $op->{FD} = undef; # we don't manage this fd
2256 $output_fds_accum[$op->{KFD}] = $op;
2258 elsif ( $op->{TYPE} eq '>pty>' ) {
2259 my $dest = $op->{DEST};
2260 if ( UNIVERSAL::isa( $dest, 'SCALAR' ) ) {
2262 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2263 " to SCALAR via pty '", $op->{PTY_ID}, "'"
2264 ) if _debugging_details;
2266 $$dest = '' if $op->{TRUNC};
2268 elsif ( UNIVERSAL::isa( $dest, 'CODE' ) ) {
2270 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2271 " to CODE via pty '", $op->{PTY_ID}, "'"
2272 ) if _debugging_details;
2278 . "' not allowed as a sink for output redirection"
2282 $op->{FD} = $self->{PTYS}->{$op->{PTY_ID}}->fileno;
2283 $op->{TFD} = undef; # The fd isn't known until after fork().
2284 $output_fds_accum[$op->{KFD}] = $op;
2287 elsif ( $op->{TYPE} eq '|' ) {
2289 "pipelining $kid->{NUM} and "
2290 . ( $kid->{NUM} + 1 )
2291 ) if _debugging_details;
2292 ( $pipe_read_fd, $op->{TFD} ) = _pipe;
2294 _dont_inherit( $pipe_read_fd );
2295 _dont_inherit( $op->{TFD} );
2297 @output_fds_accum = ();
2299 elsif ( $op->{TYPE} eq '&' ) {
2300 @output_fds_accum = ();
2301 } # end if $op->{TYPE} tree
2306 _debug 'caught ', $@ if _debugging;
2312 for ( @close_on_fail ) {
2316 for ( keys %{$self->{PTYS}} ) {
2317 next unless $self->{PTYS}->{$_};
2318 close $self->{PTYS}->{$_};
2319 $self->{PTYS}->{$_} = undef;
2321 die join( '', @errs )
2324 ## give all but the last child all of the output file descriptors
2325 ## These will be reopened (and thus rendered useless) if the child
2326 ## dup2s on to these descriptors, since we unshift these. This way
2327 ## each process emits output to the same file descriptors that the
2328 ## last child will write to. This is probably not quite correct,
2329 ## since each child should write to the file descriptors inherited
2331 ## TODO: fix the inheritance of output file descriptors.
2332 ## NOTE: This sharing of OPS among kids means that we can't easily put
2333 ## a kid number in each OPS structure to ping the kid when all ops
2334 ## have closed (when $self->{PIPES} has emptied). This means that we
2335 ## need to scan the KIDS whenever @{$self->{PIPES}} is empty to see
2336 ## if there any of them are still alive.
2337 for ( my $num = 0; $num < $#{$self->{KIDS}}; ++$num ) {
2338 for ( reverse @output_fds_accum ) {
2339 next unless defined $_;
2341 'kid ', $self->{KIDS}->[$num]->{NUM}, ' also to write ', $_->{KFD},
2342 ' to ', ref $_->{DEST}
2343 ) if _debugging_details;
2344 unshift @{$self->{KIDS}->[$num]->{OPS}}, $_;
2348 ## Open the debug pipe if we need it
2349 ## Create the list of PIPES we need to scan and the bit vectors needed by
2350 ## select(). Do this first so that _cleanup can _clobber() them if an
2351 ## exception occurs.
2352 @{$self->{PIPES}} = ();
2356 ## PIN is a vec()tor that indicates who's paused.
2358 for my $kid ( @{$self->{KIDS}} ) {
2359 for ( @{$kid->{OPS}} ) {
2360 if ( defined $_->{FD} ) {
2362 'kid ', $kid->{NUM}, '[', $kid->{PID}, "]'s ", $_->{KFD},
2364 ) if _debugging_details;
2365 vec( $self->{ $_->{TYPE} =~ /^</ ? 'WIN' : 'RIN' }, $_->{FD}, 1 ) = 1;
2366 # vec( $self->{EIN}, $_->{FD}, 1 ) = 1;
2367 push @{$self->{PIPES}}, $_;
2372 for my $io ( @{$self->{IOS}} ) {
2373 my $fd = $io->fileno;
2374 vec( $self->{RIN}, $fd, 1 ) = 1 if $io->mode =~ /r/;
2375 vec( $self->{WIN}, $fd, 1 ) = 1 if $io->mode =~ /w/;
2376 # vec( $self->{EIN}, $fd, 1 ) = 1;
2377 push @{$self->{PIPES}}, $io;
2380 ## Put filters on the end of the filter chains to read & write the pipes.
2381 ## Clear pipe states
2382 for my $pipe ( @{$self->{PIPES}} ) {
2383 $pipe->{SOURCE_EMPTY} = 0;
2384 $pipe->{PAUSED} = 0;
2385 if ( $pipe->{TYPE} =~ /^>/ ) {
2386 my $pipe_reader = sub {
2387 my ( undef, $out_ref ) = @_;
2389 return undef unless defined $pipe->{FD};
2390 return 0 unless vec( $self->{ROUT}, $pipe->{FD}, 1 );
2392 vec( $self->{ROUT}, $pipe->{FD}, 1 ) = 0;
2394 _debug_desc_fd( 'reading from', $pipe ) if _debugging_details;
2395 my $in = eval { _read( $pipe->{FD} ) };
2398 ## IO::Pty throws the Input/output error if the kid dies.
2399 ## read() throws the bad file descriptor message if the
2400 ## kid dies on Win32.
2402 $@ =~ /^Input\/output error: read/ ||
2403 ($@ =~ /input or output/ && $^O =~ /aix/)
2404 || ( Win32_MODE && $@ =~ /Bad file descriptor/ );
2407 unless ( length $in ) {
2408 $self->_clobber( $pipe );
2412 ## Protect the position so /.../g matches may be used.
2413 my $pos = pos $$out_ref;
2415 pos( $$out_ref ) = $pos;
2418 ## Input filters are the last filters
2419 push @{$pipe->{FILTERS}}, $pipe_reader;
2420 push @{$self->{TEMP_FILTERS}}, $pipe_reader;
2423 my $pipe_writer = sub {
2424 my ( $in_ref, $out_ref ) = @_;
2425 return undef unless defined $pipe->{FD};
2427 unless vec( $self->{WOUT}, $pipe->{FD}, 1 )
2430 vec( $self->{WOUT}, $pipe->{FD}, 1 ) = 0;
2432 if ( ! length $$in_ref ) {
2433 if ( ! defined get_more_input ) {
2434 $self->_clobber( $pipe );
2439 unless ( length $$in_ref ) {
2440 unless ( $pipe->{PAUSED} ) {
2441 _debug_desc_fd( 'pausing', $pipe ) if _debugging_details;
2442 vec( $self->{WIN}, $pipe->{FD}, 1 ) = 0;
2443 # vec( $self->{EIN}, $pipe->{FD}, 1 ) = 0;
2444 vec( $self->{PIN}, $pipe->{FD}, 1 ) = 1;
2445 $pipe->{PAUSED} = 1;
2449 _debug_desc_fd( 'writing to', $pipe ) if _debugging_details;
2451 my $c = _write( $pipe->{FD}, $$in_ref );
2452 substr( $$in_ref, 0, $c, '' );
2455 ## Output filters are the first filters
2456 unshift @{$pipe->{FILTERS}}, $pipe_writer;
2457 push @{$self->{TEMP_FILTERS}}, $pipe_writer;
2464 ## A METHOD, NOT A FUNCTION, NEEDS $self!
2465 my IPC::Run $self = shift;
2466 my ( $files, $fd1, $fd2 ) = @_;
2467 ## Moves TFDs that are using the destination fd out of the
2468 ## way before calling _dup2
2470 next unless defined $_->{TFD};
2471 $_->{TFD} = _dup( $_->{TFD} ) if $_->{TFD} == $fd2;
2473 $self->{DEBUG_FD} = _dup $self->{DEBUG_FD}
2474 if defined $self->{DEBUG_FD} && $self->{DEBUG_FD} == $fd2;
2476 _dup2_rudely( $fd1, $fd2 );
2481 =item close_terminal
2483 This is used as (or in) an init sub to cast off the bonds of a controlling
2484 terminal. It must precede all other redirection ops that affect
2485 STDIN, STDOUT, or STDERR to be guaranteed effective.
2490 sub close_terminal {
2491 ## Cast of the bonds of a controlling terminal
2493 POSIX::setsid() || croak "POSIX::setsid() failed";
2494 _debug "closing stdin, out, err"
2495 if _debugging_details;
2502 sub _do_kid_and_exit {
2503 my IPC::Run $self = shift;
2506 ## For unknown reasons, placing these two statements in the eval{}
2507 ## causes the eval {} to not catch errors after they are executed in
2508 ## perl 5.6.0, godforsaken version that it is...not sure about 5.6.1.
2509 ## Part of this could be that these symbols get destructed when
2510 ## exiting the eval, and that destruction might be what's (wrongly)
2511 ## confusing the eval{}, allowing the exception to probpogate.
2516 local $cur_self = $self;
2518 _set_child_debug_name( ref $kid->{VAL} eq "CODE"
2520 : basename( $kid->{VAL}->[0] )
2523 ## close parent FD's first so they're out of the way.
2524 ## Don't close STDIN, STDOUT, STDERR: they should be inherited or
2525 ## overwritten below.
2526 my @needed = $self->{noinherit} ? () : ( 1, 1, 1 );
2527 $needed[ $self->{SYNC_WRITER_FD} ] = 1;
2528 $needed[ $self->{DEBUG_FD} ] = 1 if defined $self->{DEBUG_FD};
2530 for ( @{$kid->{OPS}} ) {
2531 $needed[ $_->{TFD} ] = 1 if defined $_->{TFD};
2534 ## TODO: use the forthcoming IO::Pty to close the terminal and
2535 ## make the first pty for this child the controlling terminal.
2536 ## This will also make it so that pty-laden kids don't cause
2537 ## other kids to lose stdin/stdout/stderr.
2539 if ( %{$self->{PTYS}} ) {
2540 ## Clean up the parent's fds.
2541 for ( keys %{$self->{PTYS}} ) {
2542 _debug "Cleaning up parent's ptty '$_'" if _debugging_details;
2543 my $slave = $self->{PTYS}->{$_}->slave;
2544 $closed[ $self->{PTYS}->{$_}->fileno ] = 1;
2545 close $self->{PTYS}->{$_};
2546 $self->{PTYS}->{$_} = $slave;
2550 $closed[ $_ ] = 1 for ( 0..2 );
2553 for my $sibling ( @{$self->{KIDS}} ) {
2554 for ( @{$sibling->{OPS}} ) {
2555 if ( $_->{TYPE} =~ /^.pty.$/ ) {
2556 $_->{TFD} = $self->{PTYS}->{$_->{PTY_ID}}->fileno;
2557 $needed[$_->{TFD}] = 1;
2560 # for ( $_->{FD}, ( $sibling != $kid ? $_->{TFD} : () ) ) {
2561 # if ( defined $_ && ! $closed[$_] && ! $needed[$_] ) {
2570 ## This is crude: we have no way of keeping track of browsing all open
2571 ## fds, so we scan to a fairly high fd.
2572 _debug "open fds: ", join " ", keys %fds if _debugging_details;
2574 if ( ! $closed[$_] && ! $needed[$_] ) {
2580 ## Lazy closing is so the same fd (ie the same TFD value) can be dup2'ed on
2583 for ( @{$kid->{OPS}} ) {
2584 if ( defined $_->{TFD} ) {
2585 unless ( $_->{TFD} == $_->{KFD} ) {
2586 $self->_dup2_gently( $kid->{OPS}, $_->{TFD}, $_->{KFD} );
2587 push @lazy_close, $_->{TFD};
2590 elsif ( $_->{TYPE} eq 'dup' ) {
2591 $self->_dup2_gently( $kid->{OPS}, $_->{KFD1}, $_->{KFD2} )
2592 unless $_->{KFD1} == $_->{KFD2};
2594 elsif ( $_->{TYPE} eq 'close' ) {
2596 if ( ! $closed[$_] ) {
2603 elsif ( $_->{TYPE} eq 'init' ) {
2608 for ( @lazy_close ) {
2609 unless ( $closed[$_] ) {
2615 if ( ref $kid->{VAL} ne 'CODE' ) {
2616 open $s1, ">&=$self->{SYNC_WRITER_FD}"
2617 or croak "$! setting filehandle to fd SYNC_WRITER_FD";
2618 fcntl $s1, F_SETFD, 1;
2620 if ( defined $self->{DEBUG_FD} ) {
2621 open $s2, ">&=$self->{DEBUG_FD}"
2622 or croak "$! setting filehandle to fd DEBUG_FD";
2623 fcntl $s2, F_SETFD, 1;
2626 my @cmd = ( $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] );
2627 _debug 'execing ', join " ", map { /[\s\"]/ ? "'$_'" : $_ } @cmd
2630 die "exec failed: simulating exec() failure"
2631 if $self->{_simulate_exec_failure};
2633 _exec $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}];
2635 croak "exec failed: $!";
2639 _write $self->{SYNC_WRITER_FD}, $@;
2644 ## We must be executing code in the child, otherwise exec() would have
2645 ## prevented us from being here.
2646 _close $self->{SYNC_WRITER_FD};
2647 _debug 'calling fork()ed CODE ref' if _debugging;
2648 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD};
2649 ## TODO: Overload CORE::GLOBAL::exit...
2652 ## There are bugs in perl closures up to and including 5.6.1
2653 ## that may keep this next line from having any effect, and it
2654 ## won't have any effect if our caller has kept a copy of it, but
2655 ## this may cause the closure to be cleaned up. Maybe.
2656 $kid->{VAL} = undef;
2658 ## Use POSIX::exit to avoid global destruction, since this might
2659 ## cause DESTROY() to be called on objects created in the parent
2660 ## and thus cause double cleanup. For instance, if DESTROY() unlinks
2661 ## a file in the child, we don't want the parent to suddenly miss
2671 \@cmd, \$in, \$out, ...,
2672 timeout( 30, name => "process timeout" ),
2673 $stall_timeout = timeout( 10, name => "stall timeout" ),
2676 $h = start \@cmd, '<', \$in, '|', \@cmd2, ...;
2678 start() accepts a harness or harness specification and returns a harness
2679 after building all of the pipes and launching (via fork()/exec(), or, maybe
2680 someday, spawn()) all the child processes. It does not send or receive any
2681 data on the pipes, see pump() and finish() for that.
2683 You may call harness() and then pass it's result to start() if you like,
2684 but you only need to if it helps you structure or tune your application.
2685 If you do call harness(), you may skip start() and proceed directly to
2688 start() also starts all timers in the harness. See L<IPC::Run::Timer>
2689 for more information.
2691 start() flushes STDOUT and STDERR to help you avoid duplicate output.
2692 It has no way of asking Perl to flush all your open filehandles, so
2693 you are going to need to flush any others you have open. Sorry.
2695 Here's how if you don't want to alter the state of $| for your
2698 $ofh = select HANDLE; $of = $|; $| = 1; $| = $of; select $ofh;
2700 If you don't mind leaving output unbuffered on HANDLE, you can do
2701 the slightly shorter
2703 $ofh = select HANDLE; $| = 1; select $ofh;
2705 Or, you can use IO::Handle's flush() method:
2710 Perl needs the equivalent of C's fflush( (FILE *)NULL ).
2715 # $SIG{__DIE__} = sub { my $s = shift; Carp::cluck $s; die $s };
2717 if ( @_ && ref $_[-1] eq 'HASH' ) {
2719 require Data::Dumper;
2720 carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper( $options );
2724 if ( @_ == 1 && UNIVERSAL::isa( $_[0], __PACKAGE__ ) ) {
2726 $self->{$_} = $options->{$_} for keys %$options;
2729 $self = harness( @_, $options ? $options : () );
2732 local $cur_self = $self;
2734 $self->kill_kill if $self->{STATE} == _started;
2736 _debug "** starting" if _debugging;
2738 $_->{RESULT} = undef for @{$self->{KIDS}};
2740 ## Assume we're not being called from &run. It will correct our
2741 ## assumption if need be. This affects whether &_select_loop clears
2742 ## input queues to '' when they're empty.
2743 $self->{clear_ins} = 1;
2745 IPC::Run::Win32Helper::optimize $self
2746 if Win32_MODE && $in_run;
2750 for ( @{$self->{TIMERS}} ) {
2754 _debug 'caught ', $@ if _debugging;
2758 eval { $self->_open_pipes };
2761 _debug 'caught ', $@ if _debugging;
2765 ## This is a bit of a hack, we should do it for all open filehandles.
2766 ## Since there's no way I know of to enumerate open filehandles, we
2767 ## autoflush STDOUT and STDERR. This is done so that the children don't
2768 ## inherit output buffers chock full o' redundant data. It's really
2769 ## confusing to track that down.
2770 { my $ofh = select STDOUT; local $| = 1; select $ofh; }
2771 { my $ofh = select STDERR; local $| = 1; select $ofh; }
2772 for my $kid ( @{$self->{KIDS}} ) {
2773 $kid->{RESULT} = undef;
2775 ref( $kid->{VAL} ) eq "CODE"
2779 join( " ", map /[^\w.-]/ ? "'$_'" : $_, @{$kid->{VAL}} ),
2781 ) if _debugging_details;
2783 croak "simulated failure of fork"
2784 if $self->{_simulate_fork_failure};
2785 unless ( Win32_MODE ) {
2786 $self->_spawn( $kid );
2789 ## TODO: Test and debug spawing code. Someday.
2796 ( $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] )
2800 ## The external kid wouldn't know what to do with it anyway.
2801 ## This is only used by the "helper" pump processes on Win32.
2802 _dont_inherit( $self->{DEBUG_FD} );
2803 ( $kid->{PID}, $kid->{PROCESS} ) =
2804 IPC::Run::Win32Helper::win32_spawn(
2805 [ $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] ],
2808 _debug "spawn() = ", $kid->{PID} if _debugging;
2813 _debug 'caught ', $@ if _debugging;
2818 ## Close all those temporary filehandles that the kids needed.
2819 for my $pty ( values %{$self->{PTYS}} ) {
2824 for my $kid ( @{$self->{KIDS}} ) {
2825 for ( @{$kid->{OPS}} ) {
2826 my $close_it = eval {
2828 && ! $_->{DONT_CLOSE}
2829 && ! $closed[$_->{TFD}]
2830 && ( ! Win32_MODE || ! $_->{RECV_THROUGH_TEMP_FILE} ) ## Win32 hack
2834 _debug 'caught ', $@ if _debugging;
2836 if ( $close_it || $@ ) {
2838 _close( $_->{TFD} );
2839 $closed[$_->{TFD}] = 1;
2844 _debug 'caught ', $@ if _debugging;
2849 confess "gak!" unless defined $self->{PIPES};
2852 eval { $self->_cleanup };
2854 die join( '', @errs );
2857 $self->{STATE} = _started;
2863 ## NOT FUNCTIONAL YET, NEED TO CLOSE FDS BETTER IN CHILDREN. SEE
2864 ## t/adopt.t for a test suite.
2865 my IPC::Run $self = shift;
2867 for my $adoptee ( @_ ) {
2868 push @{$self->{IOS}}, @{$adoptee->{IOS}};
2869 ## NEED TO RENUMBER THE KIDS!!
2870 push @{$self->{KIDS}}, @{$adoptee->{KIDS}};
2871 push @{$self->{PIPES}}, @{$adoptee->{PIPES}};
2872 $self->{PTYS}->{$_} = $adoptee->{PTYS}->{$_}
2873 for keys %{$adoptee->{PYTS}};
2874 push @{$self->{TIMERS}}, @{$adoptee->{TIMERS}};
2875 $adoptee->{STATE} = _finished;
2881 my IPC::Run $self = shift;
2883 _debug_desc_fd( "closing", $file ) if _debugging_details;
2884 my $doomed = $file->{FD};
2885 my $dir = $file->{TYPE} =~ /^</ ? 'WIN' : 'RIN';
2886 vec( $self->{$dir}, $doomed, 1 ) = 0;
2887 # vec( $self->{EIN}, $doomed, 1 ) = 0;
2888 vec( $self->{PIN}, $doomed, 1 ) = 0;
2889 if ( $file->{TYPE} =~ /^(.)pty.$/ ) {
2891 ## Only close output ptys. This is so that ptys as inputs are
2892 ## never autoclosed, which would risk losing data that was
2893 ## in the slave->parent queue.
2894 _debug_desc_fd "closing pty", $file if _debugging_details;
2895 close $self->{PTYS}->{$file->{PTY_ID}}
2896 if defined $self->{PTYS}->{$file->{PTY_ID}};
2897 $self->{PTYS}->{$file->{PTY_ID}} = undef;
2900 elsif ( UNIVERSAL::isa( $file, 'IPC::Run::IO' ) ) {
2901 $file->close unless $file->{DONT_CLOSE};
2907 @{$self->{PIPES}} = grep
2908 defined $_->{FD} && ( $_->{TYPE} ne $file->{TYPE} || $_->{FD} ne $doomed),
2911 $file->{FD} = undef;
2915 my IPC::Run $self = shift;
2919 my $not_forever = 0.01;
2922 while ( $self->pumpable ) {
2923 if ( $io_occurred && $self->{break_on_io} ) {
2924 _debug "exiting _select(): io occured and break_on_io set"
2925 if _debugging_details;
2929 my $timeout = $self->{non_blocking} ? 0 : undef;
2931 if ( @{$self->{TIMERS}} ) {
2934 for ( @{$self->{TIMERS}} ) {
2935 next unless $_->is_running;
2936 $time_left = $_->check( $now );
2937 ## Return when a timer expires
2938 return if defined $time_left && ! $time_left;
2939 $timeout = $time_left
2940 if ! defined $timeout || $time_left < $timeout;
2945 ## See if we can unpause any input channels
2949 for my $file ( @{$self->{PIPES}} ) {
2950 next unless $file->{PAUSED} && $file->{TYPE} =~ /^</;
2952 _debug_desc_fd( "checking for more input", $file ) if _debugging_details;
2954 1 while $did = $file->_do_filters( $self );
2955 if ( defined $file->{FD} && ! defined( $did ) || $did ) {
2956 _debug_desc_fd( "unpausing", $file ) if _debugging_details;
2957 $file->{PAUSED} = 0;
2958 vec( $self->{WIN}, $file->{FD}, 1 ) = 1;
2959 # vec( $self->{EIN}, $file->{FD}, 1 ) = 1;
2960 vec( $self->{PIN}, $file->{FD}, 1 ) = 0;
2963 ## This gets incremented occasionally when the IO channel
2964 ## was actually closed. That's a bug, but it seems mostly
2965 ## harmless: it causes us to exit if break_on_io, or to set
2966 ## the timeout to not be forever. I need to fix it, though.
2971 if ( _debugging_details ) {
2976 $out = 'r' if vec( $self->{RIN}, $_, 1 );
2977 $out = $out ? 'b' : 'w' if vec( $self->{WIN}, $_, 1 );
2978 $out = 'p' if ! $out && vec( $self->{PIN}, $_, 1 );
2979 $out = $out ? uc( $out ) : 'x' if vec( $self->{EIN}, $_, 1 );
2980 $out = '-' unless $out;
2984 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/;
2985 _debug 'fds for select: ', $map if _debugging_details;
2988 ## _do_filters may have closed our last fd, and we need to see if
2989 ## we have I/O, or are just waiting for children to exit.
2990 my $p = $self->pumpable;
2992 if ( $p > 0 && ( ! defined $timeout || $timeout > 0.1 ) ) {
2993 ## No I/O will wake the select loop up, but we have children
2994 ## lingering, so we need to poll them with a short timeout.
2995 ## Otherwise, assume more input will be coming.
2996 $timeout = $not_forever;
2998 $not_forever = 0.5 if $not_forever >= 0.5;
3001 ## Make sure we don't block forever in select() because inputs are
3003 if ( ! defined $timeout && ! ( @{$self->{PIPES}} - $paused ) ) {
3004 ## Need to return if we're in pump and all input is paused, or
3005 ## we'll loop until all inputs are unpaused, which is darn near
3006 ## forever. And a day.
3007 if ( $self->{break_on_io} ) {
3008 _debug "exiting _select(): no I/O to do and timeout=forever"
3013 ## Otherwise, assume more input will be coming.
3014 $timeout = $not_forever;
3016 $not_forever = 0.5 if $not_forever >= 0.5;
3019 _debug 'timeout=', defined $timeout ? $timeout : 'forever'
3020 if _debugging_details;
3023 unless ( Win32_MODE ) {
3025 $self->{ROUT} = $self->{RIN},
3026 $self->{WOUT} = $self->{WIN},
3027 $self->{EOUT} = $self->{EIN},
3032 my @in = map $self->{$_}, qw( RIN WIN EIN );
3033 ## Win32's select() on Win32 seems to die if passed vectors of
3034 ## all 0's. Need to report this when I get back online.
3036 $_ = undef unless index( ( unpack "b*", $_ ), 1 ) >= 0;
3040 $self->{ROUT} = $in[0],
3041 $self->{WOUT} = $in[1],
3042 $self->{EOUT} = $in[2],
3046 for ( $self->{ROUT}, $self->{WOUT}, $self->{EOUT} ) {
3047 $_ = "" unless defined $_;
3050 last if ! $nfound && $self->{non_blocking};
3052 croak "$! in select" if $nfound < 0 and $! != POSIX::EINTR;
3053 ## TODO: Analyze the EINTR failure mode and see if this patch
3054 ## is adequate and optimal.
3055 ## TODO: Add an EINTR test to the test suite.
3057 if ( _debugging_details ) {
3062 $out = 'r' if vec( $self->{ROUT}, $_, 1 );
3063 $out = $out ? 'b' : 'w' if vec( $self->{WOUT}, $_, 1 );
3064 $out = $out ? uc( $out ) : 'x' if vec( $self->{EOUT}, $_, 1 );
3065 $out = '-' unless $out;
3069 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/;
3070 _debug "selected ", $map;
3073 ## Need to copy since _clobber alters @{$self->{PIPES}}.
3074 ## TODO: Rethink _clobber(). Rethink $file->{PAUSED}, too.
3075 my @pipes = @{$self->{PIPES}};
3076 $io_occurred = $_->poll( $self ) ? 1 : $io_occurred for @pipes;
3078 # for my $pipe ( @pipes ) {
3079 # ## Pipes can be shared among kids. If another kid closes the
3080 # ## pipe, then it's {FD} will be undef. Also, on Win32, pipes can
3081 # ## be optimized to be files, in which case the FD is left undef
3082 # ## so we don't try to select() on it.
3083 # if ( $pipe->{TYPE} =~ /^>/
3084 # && defined $pipe->{FD}
3085 # && vec( $self->{ROUT}, $pipe->{FD}, 1 )
3087 # _debug_desc_fd( "filtering data from", $pipe ) if _debugging_details;
3088 #confess "phooey" unless UNIVERSAL::isa( $pipe, "IPC::Run::IO" );
3089 # $io_occurred = 1 if $pipe->_do_filters( $self );
3091 # next FILE unless defined $pipe->{FD};
3094 # ## On Win32, pipes to the child can be optimized to be files
3095 # ## and FD left undefined so we won't select on it.
3096 # if ( $pipe->{TYPE} =~ /^</
3097 # && defined $pipe->{FD}
3098 # && vec( $self->{WOUT}, $pipe->{FD}, 1 )
3100 # _debug_desc_fd( "filtering data to", $pipe ) if _debugging_details;
3101 # $io_occurred = 1 if $pipe->_do_filters( $self );
3103 # next FILE unless defined $pipe->{FD};
3106 # if ( defined $pipe->{FD} && vec( $self->{EOUT}, $pipe->{FD}, 1 ) ) {
3107 # ## BSD seems to sometimes raise the exceptional condition flag
3108 # ## when a pipe is closed before we read it's last data. This
3109 # ## causes spurious warnings and generally renders the exception
3110 # ## mechanism useless for our purposes. The exception
3111 # ## flag semantics are too variable (they're device driver
3112 # ## specific) for me to easily map to any automatic action like
3113 # ## warning or croaking (try running v0.42 if you don't beleive me
3115 # warn "Exception on descriptor $pipe->{FD}";
3125 my IPC::Run $self = shift;
3126 _debug "cleaning up" if _debugging_details;
3128 for ( values %{$self->{PTYS}} ) {
3131 _debug "closing slave fd ", fileno $_->slave if _debugging_data;
3134 carp $@ . " while closing ptys" if $@;
3136 _debug "closing master fd ", fileno $_ if _debugging_data;
3139 carp $@ . " closing ptys" if $@;
3142 _debug "cleaning up pipes" if _debugging_details;
3143 ## _clobber modifies PIPES
3144 $self->_clobber( $self->{PIPES}->[0] ) while @{$self->{PIPES}};
3146 for my $kid ( @{$self->{KIDS}} ) {
3147 _debug "cleaning up kid ", $kid->{NUM} if _debugging_details;
3148 if ( ! length $kid->{PID} ) {
3149 _debug 'never ran child ', $kid->{NUM}, ", can't reap"
3151 for my $op ( @{$kid->{OPS}} ) {
3152 _close( $op->{TFD} )
3153 if defined $op->{TFD} && ! defined $op->{TEMP_FILE_HANDLE};
3156 elsif ( ! defined $kid->{RESULT} ) {
3157 _debug 'reaping child ', $kid->{NUM}, ' (pid ', $kid->{PID}, ')'
3159 my $pid = waitpid $kid->{PID}, 0;
3160 $kid->{RESULT} = $?;
3161 _debug 'reaped ', $pid, ', $?=', $kid->{RESULT}
3165 # if ( defined $kid->{DEBUG_FD} ) {
3167 # @{$kid->{OPS}} = grep
3168 # ! defined $_->{KFD} || $_->{KFD} != $kid->{DEBUG_FD},
3170 # $kid->{DEBUG_FD} = undef;
3173 _debug "cleaning up filters" if _debugging_details;
3174 for my $op ( @{$kid->{OPS}} ) {
3175 @{$op->{FILTERS}} = grep {
3177 ! grep $filter == $_, @{$self->{TEMP_FILTERS}};
3178 } @{$op->{FILTERS}};
3181 for my $op ( @{$kid->{OPS}} ) {
3182 $op->_cleanup( $self ) if UNIVERSAL::isa( $op, "IPC::Run::IO" );
3185 $self->{STATE} = _finished;
3186 @{$self->{TEMP_FILTERS}} = ();
3187 _debug "done cleaning up" if _debugging_details;
3189 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD};
3190 $self->{DEBUG_FD} = undef;
3200 Pump accepts a single parameter harness. It blocks until it delivers some
3201 input or recieves some output. It returns TRUE if there is still input or
3202 output to be done, FALSE otherwise.
3204 pump() will automatically call start() if need be, so you may call harness()
3205 then proceed to pump() if that helps you structure your application.
3207 If pump() is called after all harnessed activities have completed, a "process
3208 ended prematurely" exception to be thrown. This allows for simple scripting
3209 of external applications without having to add lots of error handling code at
3210 each step of the script:
3212 $h = harness \@smbclient, \$in, \$out, $err;
3215 $h->pump until $out =~ /^smb.*> \Z/m;
3216 die "error cding to /foo:\n$out" if $out =~ "ERR";
3220 $h->pump until $out =~ /^smb.*> \Z/m;
3221 die "error retrieving files:\n$out" if $out =~ "ERR";
3230 die "pump() takes only a a single harness as a parameter"
3231 unless @_ == 1 && UNIVERSAL::isa( $_[0], __PACKAGE__ );
3233 my IPC::Run $self = shift;
3235 local $cur_self = $self;
3241 $self->start if $self->{STATE} < _started;
3242 croak "process ended prematurely" unless $self->pumpable;
3244 $self->{auto_close_ins} = 0;
3245 $self->{break_on_io} = 1;
3246 $self->_select_loop;
3247 return $self->pumpable;
3251 # _debug $x if _debugging && $x;
3252 # eval { $self->_cleanup };
3266 "pump() non-blocking", pumps if anything's ready to be pumped, returns
3267 immediately otherwise. This is useful if you're doing some long-running
3268 task in the foreground, but don't want to starve any child processes.
3273 my IPC::Run $self = shift;
3275 $self->{non_blocking} = 1;
3276 my $r = eval { $self->pump };
3277 $self->{non_blocking} = 0;
3286 Returns TRUE if calling pump() won't throw an immediate "process ended
3287 prematurely" exception. This means that there are open I/O channels or
3288 active processes. May yield the parent processes' time slice for 0.01
3289 second if all pipes are to the child and all are paused. In this case
3290 we can't tell if the child is dead, so we yield the processor and
3291 then attempt to reap the child in a nonblocking way.
3295 ## Undocumented feature (don't depend on it outside this module):
3296 ## returns -1 if we have I/O channels open, or >0 if no I/O channels
3297 ## open, but we have kids running. This allows the select loop
3298 ## to poll for child exit.
3300 my IPC::Run $self = shift;
3302 ## There's a catch-22 we can get in to if there is only one pipe left
3303 ## open to the child and it's paused (ie the SCALAR it's tied to
3304 ## is ''). It's paused, so we're not select()ing on it, so we don't
3305 ## check it to see if the child attached to it is alive and it stays
3306 ## in @{$self->{PIPES}} forever. So, if all pipes are paused, see if
3307 ## we can reap the child.
3308 return -1 if grep !$_->{PAUSED}, @{$self->{PIPES}};
3310 ## See if the child is dead.
3312 return 0 unless $self->_running_kids;
3314 ## If we reap_nb and it's not dead yet, yield to it to see if it
3317 ## A better solution would be to unpause all the pipes, but I tried that
3318 ## and it never errored on linux. Sigh.
3319 select undef, undef, undef, 0.0001;
3323 return 0 unless $self->_running_kids;
3325 return -1; ## There are pipes waiting
3330 my IPC::Run $self = shift;
3332 defined $_->{PID} && ! defined $_->{RESULT},
3340 Attempts to reap child processes, but does not block.
3342 Does not currently take any parameters, one day it will allow specific
3343 children to be reaped.
3345 Only call this from a signal handler if your C<perl> is recent enough
3346 to have safe signal handling (5.6.1 did not, IIRC, but it was beign discussed
3347 on perl5-porters). Calling this (or doing any significant work) in a signal
3348 handler on older C<perl>s is asking for seg faults.
3355 my IPC::Run $self = shift;
3357 local $cur_self = $self;
3359 ## No more pipes, look to see if all the kids yet live, reaping those
3360 ## that haven't. I'd use $SIG{CHLD}/$SIG{CLD}, but that's broken
3361 ## on older (SYSV) platforms and perhaps less portable than waitpid().
3362 ## This could be slow with a lot of kids, but that's rare and, well,
3363 ## a lot of kids is slow in the first place.
3364 ## Oh, and this keeps us from reaping other children the process
3365 ## may have spawned.
3366 for my $kid ( @{$self->{KIDS}} ) {
3368 next if ! defined $kid->{PROCESS} || defined $kid->{RESULT};
3369 unless ( $kid->{PROCESS}->Wait( 0 ) ) {
3370 _debug "kid $kid->{NUM} ($kid->{PID}) still running"
3371 if _debugging_details;
3375 _debug "kid $kid->{NUM} ($kid->{PID}) exited"
3378 $kid->{PROCESS}->GetExitCode( $kid->{RESULT} )
3379 or croak "$! while GetExitCode()ing for Win32 process";
3381 unless ( defined $kid->{RESULT} ) {
3382 $kid->{RESULT} = "0 but true";
3383 $? = $kid->{RESULT} = 0x0F;
3386 $? = $kid->{RESULT} << 8;
3390 next if ! defined $kid->{PID} || defined $kid->{RESULT};
3391 my $pid = waitpid $kid->{PID}, POSIX::WNOHANG();
3393 _debug "$kid->{NUM} ($kid->{PID}) still running"
3394 if _debugging_details;
3399 _debug "No such process: $kid->{PID}\n" if _debugging;
3400 $kid->{RESULT} = "unknown result, unknown PID";
3403 _debug "kid $kid->{NUM} ($kid->{PID}) exited"
3406 confess "waitpid returned the wrong PID: $pid instead of $kid->{PID}"
3407 unless $pid = $kid->{PID};
3408 _debug "$kid->{PID} returned $?\n" if _debugging;
3409 $kid->{RESULT} = $?;
3419 This must be called after the last start() or pump() call for a harness,
3420 or your system will accumulate defunct processes and you may "leak"
3423 finish() returns TRUE if all children returned 0 (and were not signaled and did
3424 not coredump, ie ! $?), and FALSE otherwise (this is like run(), and the
3425 opposite of system()).
3427 Once a harness has been finished, it may be run() or start()ed again,
3428 including by pump()s auto-start.
3430 If this throws an exception rather than a normal exit, the harness may
3431 be left in an unstable state, it's best to kill the harness to get rid
3432 of all the child processes, etc.
3434 Specifically, if a timeout expires in finish(), finish() will not
3435 kill all the children. Call C<<$h->kill_kill>> in this case if you care.
3436 This differs from the behavior of L</run>.
3441 my IPC::Run $self = shift;
3442 my $options = @_ && ref $_[-1] eq 'HASH' ? pop : {};
3444 local $cur_self = $self;
3446 _debug "** finishing" if _debugging;
3448 $self->{non_blocking} = 0;
3449 $self->{auto_close_ins} = 1;
3450 $self->{break_on_io} = 0;
3451 # We don't alter $self->{clear_ins}, start() and run() control it.
3453 while ( $self->pumpable ) {
3454 $self->_select_loop( $options );
3458 return ! $self->full_result;
3467 Returns the first non-zero result code (ie $? >> 8). See L</full_result> to
3468 get the $? value for a child process.
3470 To get the result of a particular child, do:
3472 $h->result( 0 ); # first child's $? >> 8
3473 $h->result( 1 ); # second child
3480 Returns undef if no child processes were spawned and no child number was
3481 specified. Throws an exception if an out-of-range child number is passed.
3485 sub _assert_finished {
3486 my IPC::Run $self = $_[0];
3488 croak "Harness not run" unless $self->{STATE} >= _finished;
3489 croak "Harness not finished running" unless $self->{STATE} == _finished;
3495 my IPC::Run $self = shift;
3501 scalar( @{$self->{KIDS}} ),
3502 " child processes, no process $which"
3504 unless $which >= 0 && $which <= $#{$self->{KIDS}};
3505 return $self->{KIDS}->[$which]->{RESULT} >> 8;
3508 return undef unless @{$self->{KIDS}};
3509 for ( @{$self->{KIDS}} ) {
3510 return $_->{RESULT} >> 8 if $_->{RESULT} >> 8;
3519 Returns a list of child exit values. See L</full_results> if you want to
3520 know if a signal killed the child.
3522 Throws an exception if the harness is not in a finished state.
3528 my IPC::Run $self = shift;
3530 # we add 0 here to stop warnings associated with "unknown result, unknown PID"
3531 return map { (0+$_->{RESULT}) >> 8 } @{$self->{KIDS}};
3540 Returns the first non-zero $?. See L</result> to get the first $? >> 8
3541 value for a child process.
3543 To get the result of a particular child, do:
3545 $h->full_result( 0 ); # first child's $? >> 8
3546 $h->full_result( 1 ); # second child
3550 ($h->full_results)[0]
3551 ($h->full_results)[1]
3553 Returns undef if no child processes were spawned and no child number was
3554 specified. Throws an exception if an out-of-range child number is passed.
3559 goto &result if @_ > 1;
3562 my IPC::Run $self = shift;
3564 return undef unless @{$self->{KIDS}};
3565 for ( @{$self->{KIDS}} ) {
3566 return $_->{RESULT} if $_->{RESULT};
3574 Returns a list of child exit values as returned by C<wait>. See L</results>
3575 if you don't care about coredumps or signals.
3577 Throws an exception if the harness is not in a finished state.
3583 my IPC::Run $self = shift;
3585 croak "Harness not run" unless $self->{STATE} >= _finished;
3586 croak "Harness not finished running" unless $self->{STATE} == _finished;
3588 return map $_->{RESULT}, @{$self->{KIDS}};
3593 ## Filter Scaffolding
3596 '$filter_op', ## The op running a filter chain right now
3597 '$filter_num', ## Which filter is being run right now.
3601 ## A few filters and filter constructors
3610 These filters are used to modify input our output between a child
3611 process and a scalar or subroutine endpoint.
3617 run \@cmd, ">", binary, \$out;
3618 run \@cmd, ">", binary, \$out; ## Any TRUE value to enable
3619 run \@cmd, ">", binary 0, \$out; ## Any FALSE value to disable
3621 This is a constructor for a "binmode" "filter" that tells IPC::Run to keep
3622 the carriage returns that would ordinarily be edited out for you (binmode
3623 is usually off). This is not a real filter, but an option masquerading as
3626 It's not named "binmode" because you're likely to want to call Perl's binmode
3627 in programs that are piping binary data around.
3632 my $enable = @_ ? shift : 1;
3633 return bless sub { $enable }, "IPC::Run::binmode_pseudo_filter";
3640 This breaks a stream of data in to chunks, based on an optional
3641 scalar or regular expression parameter. The default is the Perl
3642 input record separator in $/, which is a newline be default.
3644 run \@cmd, '>', new_chunker, \&lines_handler;
3645 run \@cmd, '>', new_chunker( "\r\n" ), \&lines_handler;
3647 Because this uses $/ by default, you should always pass in a parameter
3648 if you are worried about other code (modules, etc) modifying $/.
3650 If this filter is last in a filter chain that dumps in to a scalar,
3651 the scalar must be set to '' before a new chunk will be written to it.
3653 As an example of how a filter like this can be written, here's a
3654 chunker that splits on newlines:
3657 my ( $in_ref, $out_ref ) = @_;
3659 return 0 if length $$out_ref;
3661 return input_avail && do {
3663 if ( $$in_ref =~ s/\A(.*?\n)// ) {
3667 my $hmm = get_more_input;
3668 unless ( defined $hmm ) {
3669 $$out_ref = $$in_ref;
3671 return length $$out_ref ? 1 : 0;
3673 return 0 if $hmm eq 0;
3680 sub new_chunker(;$) {
3682 $re = $/ if _empty $re;
3683 $re = quotemeta( $re ) unless ref $re eq 'Regexp';
3684 $re = qr/\A(.*?$re)/s;
3687 my ( $in_ref, $out_ref ) = @_;
3689 return 0 if length $$out_ref;
3691 return input_avail && do {
3693 if ( $$in_ref =~ s/$re// ) {
3697 my $hmm = get_more_input;
3698 unless ( defined $hmm ) {
3699 $$out_ref = $$in_ref;
3701 return length $$out_ref ? 1 : 0;
3703 return 0 if $hmm eq 0;
3713 This appends a fixed string to each chunk of data read from the source
3714 scalar or sub. This might be useful if you're writing commands to a
3715 child process that always must end in a fixed string, like "\n":
3718 '<', new_appender( "\n" ), \&commands,
3721 Here's a typical filter sub that might be created by new_appender():
3723 sub newline_appender {
3724 my ( $in_ref, $out_ref ) = @_;
3726 return input_avail && do {
3727 $$out_ref = join( '', $$out_ref, $$in_ref, "\n" );
3735 sub new_appender($) {
3736 my ( $suffix ) = @_;
3737 croak "\$suffix undefined" unless defined $suffix;
3740 my ( $in_ref, $out_ref ) = @_;
3742 return input_avail && do {
3743 $$out_ref = join( '', $$out_ref, $$in_ref, $suffix );
3751 sub new_string_source {
3760 return ref $ref eq 'SCALAR'
3762 my ( $in_ref, $out_ref ) = @_;
3764 return defined $$ref
3767 my $r = length $$ref ? 1 : 0;
3774 my ( $in_ref, $out_ref ) = @_;
3778 my $s = shift @$ref;
3787 sub new_string_sink {
3788 my ( $string_ref ) = @_;
3791 my ( $in_ref, $out_ref ) = @_;
3793 return input_avail && do {
3794 $$string_ref .= $$in_ref;
3804 #This function defines a time interval, starting from when start() is
3805 #called, or when timeout() is called. If all processes have not finished
3806 #by the end of the timeout period, then a "process timed out" exception
3809 #The time interval may be passed in seconds, or as an end time in
3810 #"HH:MM:SS" format (any non-digit other than '.' may be used as
3811 #spacing and puctuation). This is probably best shown by example:
3813 # $h->timeout( $val );
3816 # ======================== =====================================
3817 # undef Timeout timer disabled
3818 # '' Almost immediate timeout
3819 # 0 Almost immediate timeout
3820 # 0.000001 timeout > 0.0000001 seconds
3821 # 30 timeout > 30 seconds
3822 # 30.0000001 timeout > 30 seconds
3823 # 10:30 timeout > 10 minutes, 30 seconds
3825 #Timeouts are currently evaluated with a 1 second resolution, though
3826 #this may change in the future. This means that setting
3827 #timeout($h,1) will cause a pokey child to be aborted sometime after
3828 #one second has elapsed and typically before two seconds have elapsed.
3830 #This sub does not check whether or not the timeout has expired already.
3832 #Returns the number of seconds set as the timeout (this does not change
3833 #as time passes, unless you call timeout( val ) again).
3835 #The timeout does not include the time needed to fork() or spawn()
3836 #the child processes, though some setup time for the child processes can
3837 #included. It also does not include the length of time it takes for
3838 #the children to exit after they've closed all their pipes to the
3844 # my IPC::Run $self = shift;
3847 # ( $self->{TIMEOUT} ) = @_;
3848 # $self->{TIMEOUT_END} = undef;
3849 # if ( defined $self->{TIMEOUT} ) {
3850 # if ( $self->{TIMEOUT} =~ /[^\d.]/ ) {
3851 # my @f = split( /[^\d\.]+/i, $self->{TIMEOUT} );
3852 # unshift @f, 0 while @f < 3;
3853 # $self->{TIMEOUT} = (($f[0]*60)+$f[1])*60+$f[2];
3855 # elsif ( $self->{TIMEOUT} =~ /^(\d*)(?:\.(\d*))/ ) {
3856 # $self->{TIMEOUT} = $1 + 1;
3858 # $self->_calc_timeout_end if $self->{STATE} >= _started;
3861 # return $self->{TIMEOUT};
3865 #sub _calc_timeout_end {
3866 # my IPC::Run $self = shift;
3868 # $self->{TIMEOUT_END} = defined $self->{TIMEOUT}
3869 # ? time + $self->{TIMEOUT}
3872 # ## We add a second because we might be at the very end of the current
3873 # ## second, and we want to guarantee that we don't have a timeout even
3874 # ## one second less then the timeout period.
3875 # ++$self->{TIMEOUT_END} if $self->{TIMEOUT};
3882 Takes a filename or filehandle, a redirection operator, optional filters,
3883 and a source or destination (depends on the redirection operator). Returns
3884 an IPC::Run::IO object suitable for harness()ing (including via start()
3887 This is shorthand for
3890 require IPC::Run::IO;
3892 ... IPC::Run::IO->new(...) ...
3897 require IPC::Run::IO;
3898 IPC::Run::IO->new( @_ );
3905 $h = start( \@cmd, \$in, \$out, $t = timer( 5 ) );
3907 pump $h until $out =~ /expected stuff/ || $t->is_expired;
3909 Instantiates a non-fatal timer. pump() returns once each time a timer
3910 expires. Has no direct effect on run(), but you can pass a subroutine
3911 to fire when the timer expires.
3913 See L</timeout> for building timers that throw exceptions on
3916 See L<IPC::Run::Timer/timer> for details.
3920 # Doing the prototype suppresses 'only used once' on older perls.
3922 *timer = \&IPC::Run::Timer::timer;
3928 $h = start( \@cmd, \$in, \$out, $t = timeout( 5 ) );
3930 pump $h until $out =~ /expected stuff/;
3932 Instantiates a timer that throws an exception when it expires.
3933 If you don't provide an exception, a default exception that matches
3934 /^IPC::Run: .*timed out/ is thrown by default. You can pass in your own
3935 exception scalar or reference:
3939 $t = timeout( 5, exception => 'slowpoke' ),
3942 or set the name used in debugging message and in the default exception
3947 timeout( 50, name => 'process timer' ),
3948 $stall_timer = timeout( 5, name => 'stall timer' ),
3951 pump $h until $out =~ /started/;
3954 $stall_timer->start;
3955 pump $h until $out =~ /command 1 finished/;
3958 $stall_timer->start;
3959 pump $h until $out =~ /command 2 finished/;
3961 $in = 'very slow command 3';
3962 $stall_timer->start( 10 );
3963 pump $h until $out =~ /command 3 finished/;
3965 $stall_timer->start( 5 );
3967 pump $h until $out =~ /command 4 finished/;
3969 $stall_timer->reset; # Prevent restarting or expirng
3972 See L</timer> for building non-fatal timers.
3974 See L<IPC::Run::Timer/timer> for details.
3978 # Doing the prototype suppresses 'only used once' on older perls.
3980 *timeout = \&IPC::Run::Timer::timeout;
3986 =head1 FILTER IMPLEMENTATION FUNCTIONS
3988 These functions are for use from within filters.
3994 Returns TRUE if input is available. If none is available, then
3995 &get_more_input is called and its result is returned.
3997 This is usually used in preference to &get_more_input so that the
3998 calling filter removes all data from the $in_ref before more data
3999 gets read in to $in_ref.
4001 C<input_avail> is usually used as part of a return expression:
4003 return input_avail && do {
4004 ## process the input just gotten
4008 This technique allows input_avail to return the undef or 0 that a
4009 filter normally returns when there's no input to process. If a filter
4010 stores intermediate values, however, it will need to react to an
4013 my $got = input_avail;
4014 if ( ! defined $got ) {
4015 ## No more input ever, flush internal buffers to $out_ref
4017 return $got unless $got;
4018 ## Got some input, move as much as need be
4019 return 1 if $added_to_out_ref;
4024 confess "Undefined FBUF ref for $filter_num+1"
4025 unless defined $filter_op->{FBUFS}->[$filter_num+1];
4026 length ${$filter_op->{FBUFS}->[$filter_num+1]} || get_more_input;
4031 =item get_more_input
4033 This is used to fetch more input in to the input variable. It returns
4034 undef if there will never be any more input, 0 if there is none now,
4035 but there might be in the future, and TRUE if more input was gotten.
4037 C<get_more_input> is usually used as part of a return expression,
4038 see L</input_avail> for more information.
4043 ## Filter implementation interface
4045 sub get_more_input() {
4048 confess "get_more_input() called and no more filters in chain"
4049 unless defined $filter_op->{FILTERS}->[$filter_num];
4050 $filter_op->{FILTERS}->[$filter_num]->(
4051 $filter_op->{FBUFS}->[$filter_num+1],
4052 $filter_op->{FBUFS}->[$filter_num],
4053 ); # if defined ${$filter_op->{FBUFS}->[$filter_num+1]};
4068 These will be addressed as needed and as time allows.
4072 Expose a list of child process objects. When I do this,
4073 each child process is likely to be blessed into IPC::Run::Proc.
4075 $kid->abort(), $kid->kill(), $kid->signal( $num_or_name ).
4077 Write tests for /(full_)?results?/ subs.
4079 Currently, pump() and run() only work on systems where select() works on the
4080 filehandles returned by pipe(). This does *not* include ActiveState on Win32,
4081 although it does work on cygwin under Win32 (thought the tests whine a bit).
4082 I'd like to rectify that, suggestions and patches welcome.
4084 Likewise start() only fully works on fork()/exec() machines (well, just
4085 fork() if you only ever pass perl subs as subprocesses). There's
4086 some scaffolding for calling Open3::spawn_with_handles(), but that's
4087 untested, and not that useful with limited select().
4089 Support for C<\@sub_cmd> as an argument to a command which
4090 gets replaced with /dev/fd or the name of a temporary file containing foo's
4091 output. This is like <(sub_cmd ...) found in bash and csh (IIRC).
4093 Allow multiple harnesses to be combined as independant sets of processes
4094 in to one 'meta-harness'.
4096 Allow a harness to be passed in place of an \@cmd. This would allow
4097 multiple harnesses to be aggregated.
4099 Ability to add external file descriptors w/ filter chains and endpoints.
4101 Ability to add timeouts and timing generators (i.e. repeating timeouts).
4103 High resolution timeouts.
4105 =head1 Win32 LIMITATIONS
4109 =item Fails on Win9X
4111 If you want Win9X support, you'll have to debug it or fund me because I
4112 don't use that system any more. The Win32 subsysem has been extended to
4113 use temporary files in simple run() invocations and these may actually
4114 work on Win9X too, but I don't have time to work on it.
4116 =item May deadlock on Win2K (but not WinNT4 or WinXPPro)
4118 Spawning more than one subprocess on Win2K causes a deadlock I haven't
4119 figured out yet, but simple uses of run() often work. Passes all tests
4120 on WinXPPro and WinNT.
4122 =item no support yet for <pty< and >pty>
4124 These are likely to be implemented as "<" and ">" with binmode on, not
4127 =item no support for file descriptors higher than 2 (stderr)
4129 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
4130 get the integer handle and pass it to the child process using the command
4131 line, environment, stdin, intermediary file, or other IPC mechnism. Then
4132 use that handle in the child (Win32API.pm provides ways to reconstitute
4133 Perl file handles from Win32 file handles).
4135 =item no support for subroutine subprocesses (CODE refs)
4137 Can't fork(), so the subroutines would have no context, and closures certainly
4140 Perhaps with Win32 fork() emulation, this can be supported in a limited
4141 fashion, but there are other very serious problems with that: all parent
4142 fds get dup()ed in to the thread emulating the forked process, and that
4143 keeps the parent from being able to close all of the appropriate fds.
4145 =item no support for init => sub {} routines.
4147 Win32 processes are created from scratch, there is no way to do an init
4148 routine that will affect the running child. Some limited support might
4149 be implemented one day, do chdir() and %ENV changes can be made.
4153 Win32 does not fully support signals. signal() is likely to cause errors
4154 unless sending a signal that Perl emulates, and C<kill_kill()> is immediately
4155 fatal (there is no grace period).
4157 =item helper processes
4159 IPC::Run uses helper processes, one per redirected file, to adapt between the
4160 anonymous pipe connected to the child and the TCP socket connected to the
4161 parent. This is a waste of resources and will change in the future to either
4162 use threads (instead of helper processes) or a WaitForMultipleObjects call
4163 (instead of select). Please contact me if you can help with the
4164 WaitForMultipleObjects() approach; I haven't figured out how to get at it
4167 =item shutdown pause
4169 There seems to be a pause of up to 1 second between when a child program exits
4170 and the corresponding sockets indicate that they are closed in the parent.
4175 binmode is not supported yet. The underpinnings are implemented, just ask
4180 IPC::Run::IO objects can be used on Unix to read or write arbitrary files. On
4181 Win32, they will need to use the same helper processes to adapt from
4182 non-select()able filehandles to select()able ones (or perhaps
4183 WaitForMultipleObjects() will work with them, not sure).
4185 =item startup race conditions
4187 There seems to be an occasional race condition between child process startup
4188 and pipe closings. It seems like if the child is not fully created by the time
4189 CreateProcess returns and we close the TCP socket being handed to it, the
4190 parent socket can also get closed. This is seen with the Win32 pumper
4191 applications, not the "real" child process being spawned.
4193 I assume this is because the kernel hasn't gotten around to incrementing the
4194 reference count on the child's end (since the child was slow in starting), so
4195 the parent's closing of the child end causes the socket to be closed, thus
4196 closing the parent socket.
4198 Being a race condition, it's hard to reproduce, but I encountered it while
4199 testing this code on a drive share to a samba box. In this case, it takes
4200 t/run.t a long time to spawn it's chile processes (the parent hangs in the
4201 first select for several seconds until the child emits any debugging output).
4203 I have not seen it on local drives, and can't reproduce it at will,
4204 unfortunately. The symptom is a "bad file descriptor in select()" error, and,
4205 by turning on debugging, it's possible to see that select() is being called on
4206 a no longer open file descriptor that was returned from the _socket() routine
4207 in Win32Helper. There's a new confess() that checks for this ("PARENT_HANDLE
4208 no longer open"), but I haven't been able to reproduce it (typically).
4214 On Unix, requires a system that supports C<waitpid( $pid, WNOHANG )> so
4215 it can tell if a child process is still running.
4217 PTYs don't seem to be non-blocking on some versions of Solaris. Here's a
4218 test script contributed by Borislav Deianov <borislav@ensim.com> to see
4219 if you have the problem. If it dies, you have the problem.
4223 use IPC::Run qw(run);
4228 return ['perl', '-e',
4229 '<STDIN>, print "\n" x '.$_[0].'; while(<STDIN>){last if /end/}'];
4233 #fcntl(W, F_SETFL, O_NONBLOCK);
4234 #while (syswrite(W, "\n", 1)) { $pipebuf++ };
4235 #print "pipe buffer size is $pipebuf\n";
4237 my $in = "\n" x ($pipebuf * 2) . "end\n";
4240 $SIG{ALRM} = sub { die "Never completed!\n" };
4242 print "reading from scalar via pipe...";
4244 run(makecmd($pipebuf * 2), '<', \$in, '>', \$out);
4248 print "reading from code via pipe... ";
4250 run(makecmd($pipebuf * 3), '<', sub { $t = $in; undef $in; $t}, '>', \$out);
4254 $pty = IO::Pty->new();
4256 $slave = $pty->slave();
4257 while ($pty->syswrite("\n", 1)) { $ptybuf++ };
4258 print "pty buffer size is $ptybuf\n";
4259 $in = "\n" x ($ptybuf * 3) . "end\n";
4261 print "reading via pty... ";
4263 run(makecmd($ptybuf * 3), '<pty<', \$in, '>', \$out);
4267 No support for ';', '&&', '||', '{ ... }', etc: use perl's, since run()
4268 returns TRUE when the command exits with a 0 result code.
4270 Does not provide shell-like string interpolation.
4272 No support for C<cd>, C<setenv>, or C<export>: do these in an init() sub
4278 chdir $dir or die $!;
4283 Timeout calculation does not allow absolute times, or specification of
4286 B<WARNING:> Function coprocesses (C<run \&foo, ...>) suffer from two
4287 limitations. The first is that it is difficult to close all filehandles the
4288 child inherits from the parent, since there is no way to scan all open
4289 FILEHANDLEs in Perl and it both painful and a bit dangerous to close all open
4290 file descriptors with C<POSIX::close()>. Painful because we can't tell which
4291 fds are open at the POSIX level, either, so we'd have to scan all possible fds
4292 and close any that we don't want open (normally C<exec()> closes any
4293 non-inheritable but we don't C<exec()> for &sub processes.
4295 The second problem is that Perl's DESTROY subs and other on-exit cleanup gets
4296 run in the child process. If objects are instantiated in the parent before the
4297 child is forked, the the DESTROY will get run once in the parent and once in
4298 the child. When coprocess subs exit, POSIX::exit is called to work around this,
4299 but it means that objects that are still referred to at that time are not
4300 cleaned up. So setting package vars or closure vars to point to objects that
4301 rely on DESTROY to affect things outside the process (files, etc), will
4304 I goofed on the syntax: "<pipe" vs. "<pty<" and ">filename" are both
4311 =item Allow one harness to "adopt" another:
4313 $new_h = harness \@cmd2;
4314 $h->adopt( $new_h );
4316 =item Close all filehandles not explicitly marked to stay open.
4318 The problem with this one is that there's no good way to scan all open
4319 FILEHANDLEs in Perl, yet you don't want child processes inheriting handles
4326 Well, select() and waitpid() badly needed wrapping, and open3() isn't
4327 open-minded enough for me.
4329 The shell-like API inspired by a message Russ Allbery sent to perl5-porters,
4332 I've thought for some time that it would be
4333 nice to have a module that could handle full Bourne shell pipe syntax
4334 internally, with fork and exec, without ever invoking a shell. Something
4335 that you could give things like:
4337 pipeopen (PIPE, [ qw/cat file/ ], '|', [ 'analyze', @args ], '>&3');
4339 Message ylln51p2b6.fsf@windlord.stanford.edu, on 2000/02/04.
4343 Bugs should always be submitted via the CPAN bug tracker
4345 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IPC-Run>
4347 For other issues, contact the maintainer (the first listed author)
4351 Adam Kennedy <adamk@cpan.org>
4353 Barrie Slaymaker <barries@slaysys.com>
4357 Some parts copyright 2008 - 2009 Adam Kennedy.
4359 Copyright 1999 Barrie Slaymaker.
4361 You may distribute under the terms of either the GNU General Public
4362 License or the Artistic License, as specified in the README file.