3 # Copyright (c) 1999 by Barrie Slaymaker, barries@slaysys.com
5 # You may distribute under the terms of either the GNU General Public
6 # License or the Artistic License, as specified in the README file.
13 IPC::Run - system() and background procs w/ piping, redirs, ptys (Unix, Win32)
17 ## First,a command to run:
20 ## Using run() instead of system():
21 use IPC::Run qw( run timeout ) ;
23 run \@cmd, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?"
25 # Can do I/O to sub refs and filenames, too:
26 run \@cmd, '<', "in.txt", \&out, \&err or die "cat: $?"
27 run \@cat, '<', "in.txt", '>>', "out.txt", '2>>', "err.txt" ;
30 # Redirecting using psuedo-terminals instad of pipes.
31 run \@cat, '<pty<', \$in, '>pty>', \$out_and_err ;
33 ## Scripting subprocesses (like Expect):
35 use IPC::Run qw( start pump finish timeout ) ;
37 # Incrementally read from / write to scalars.
38 # $in is drained as it is fed to cat's stdin,
39 # $out accumulates cat's stdout
40 # $err accumulates cat's stderr
41 # $h is for "harness".
42 my $h = start \@cat, \$in, \$out, \$err, timeout( 10 ) ;
44 $in .= "some input\n" ;
45 pump $h until $out =~ /input\n/g ;
47 $in .= "some more input\n" ;
48 pump $h until $out =~ /\G.*more input\n/ ;
50 $in .= "some final input\n" ;
51 finish $h or die "cat returned $?" ;
54 print $out ; ## All of cat's output
56 # Piping between children
57 run \@cat, '|', \@gzip ;
59 # Multiple children simultaneously (run() blocks until all
60 # children exit, use start() for background execution):
61 run \@foo1, '&', \@foo2 ;
63 # Calling \&set_up_child in the child before it executes the
64 # command (only works on systems with true fork() & exec())
65 # exceptions thrown in set_up_child() will be propagated back
66 # to the parent and thrown from run().
67 run \@cat, \$in, \$out,
68 init => \&set_up_child ;
70 # Read from / write to file handles you open and close
71 open IN, '<in.txt' or die $! ;
72 open OUT, '>out.txt' or die $! ;
73 print OUT "preamble\n" ;
74 run \@cat, \*IN, \*OUT or die "cat returned $?" ;
75 print OUT "postamble\n" ;
79 # Create pipes for you to read / write (like IPC::Open2 & 3).
85 or die "cat returned $?" ;
86 print IN "some input\n" ;
91 # Mixing input and output modes
92 run \@cat, 'in.txt', \&catch_some_out, \*ERR_LOG ) ;
94 # Other redirection constructs
95 run \@cat, '>&', \$out_and_err ;
99 run \@cat, '3<', \$in3 ;
100 run \@cat, '4>', \$out4 ;
104 run \@cat, 'in.txt', debug => 1 ;
106 # Call this system's shell, returns TRUE on 0 exit code
107 # THIS IS THE OPPOSITE SENSE OF system()'s RETURN VALUE
108 run "cat a b c" or die "cat returned $?" ;
110 # Launch a sub process directly, no shell. Can't do redirection
111 # with this form, it's here to behave like system() with an
113 $r = run "cat a b c" ;
115 # Read from a file in to a scalar
116 run io( "filename", 'r', \$recv ) ;
117 run io( \*HANDLE, 'r', \$recv ) ;
121 IPC::Run allows you run and interact with child processes using files, pipes,
122 and pseudo-ttys. Both system()-style and scripted usages are supported and
123 may be mixed. Likewise, functional and OO API styles are both supported and
126 Various redirection operators reminiscent of those seen on common Unix and DOS
127 command lines are provided.
129 Before digging in to the details a few LIMITATIONS are important enough
130 to be mentioned right up front:
136 Win32 support is working but B<EXPERIMENTAL>, but does pass all relevant tests
137 on NT 4.0. See L</Win32 LIMITATIONS>.
141 If you need pty support, IPC::Run should work well enough most of the
142 time, but IO::Pty is being improved, and IPC::Run will be improved to
143 use IO::Pty's new features when it is release.
145 The basic problem is that the pty needs to initialize itself before the
146 parent writes to the master pty, or the data written gets lost. So
147 IPC::Run does a sleep(1) in the parent after forking to (hopefully) give
148 the child a chance to run. This is a kludge that works well on non
149 heavily loaded systems :(.
151 ptys are not supported yet under Win32, but will be emulated...
155 You may use the environment variable C<IPCRUNDEBUG> to see what's going on
158 $ IPCRUNDEBUG=basic myscript # prints minimal debugging
159 $ IPCRUNDEBUG=data myscript # prints all data reads/writes
160 $ IPCRUNDEBUG=details myscript # prints lots of low-level details
161 $ IPCRUNDEBUG=gory myscript # (Win32 only) prints data moving through
162 # the helper processes.
166 We now return you to your regularly scheduled documentation.
170 Child processes and I/O handles are gathered in to a harness, then
171 started and run until the processing is finished or aborted.
173 =head2 run() vs. start(); pump(); finish();
175 There are two modes you can run harnesses in: run() functions as an
176 enhanced system(), and start()/pump()/finish() allow for background
177 processes and scripted interactions with them.
179 When using run(), all data to be sent to the harness is set up in
180 advance (though one can feed subprocesses input from subroutine refs to
181 get around this limitation). The harness is run and all output is
182 collected from it, then any child processes are waited for:
184 run \@cmd, \<<IN, \$out ;
188 ## To precompile harnesses and run them later:
189 my $h = harness \@cmd, \<<IN, \$out ;
195 The background and scripting API is provided by start(), pump(), and
196 finish(): start() creates a harness if need be (by calling harness())
197 and launches any subprocesses, pump() allows you to poll them for
198 activity, and finish() then monitors the harnessed activities until they
201 ## Build the harness, open all pipes, and launch the subprocesses
202 my $h = start \@cat, \$in, \$out ;
203 $in = "first input\n" ;
205 ## Now do I/O. start() does no I/O.
206 pump $h while length $in ; ## Wait for all input to go
208 ## Now do some more I/O.
209 $in = "second input\n" ;
210 pump $h until $out =~ /second input/ ;
213 finish $h or die "cat returned $?" ;
215 You can optionally compile the harness with harness() prior to
216 start()ing or run()ing, and you may omit start() between harness() and
217 pump(). You might want to do these things if you compile your harnesses
220 =head2 Using regexps to match output
222 As shown in most of the scripting examples, the read-to-scalar facility
223 for gathering subcommand's output is often used with regular expressions
224 to detect stopping points. This is because subcommand output often
225 arrives in dribbles and drabs, often only a character or line at a time.
226 This output is input for the main program and piles up in variables like
227 the C<$out> and C<$err> in our examples.
229 Regular expressions can be used to wait for appropriate output in
230 several ways. The C<cat> example in the previous section demonstrates
231 how to pump() until some string appears in the output. Here's an
232 example that uses C<smb> to fetch files from a remote server:
234 $h = harness \@smbclient, \$in, \$out ;
237 $h->pump until $out =~ /^smb.*> \Z/m ;
238 die "error cding to /src:\n$out" if $out =~ "ERR" ;
242 $h->pump until $out =~ /^smb.*> \Z/m ;
243 die "error retrieving files:\n$out" if $out =~ "ERR" ;
248 Notice that we carefully clear $out after the first command/response
249 cycle? That's because IPC::Run does not delete $out when we continue,
250 and we don't want to trip over the old output in the second
251 command/response cycle.
253 Say you want to accumulate all the output in $out and analyze it
254 afterwards. Perl offers incremental regular expression matching using
255 the C<m//gc> and pattern matching idiom and the C<\G> assertion.
256 IPC::Run is careful not to disturb the current C<pos()> value for
257 scalars it appends data to, so we could modify the above so as not to
258 destroy $out by adding a couple of C</gc> modifiers. The C</g> keeps us
259 from tripping over the previous prompt and the C</c> keeps us from
260 resetting the prior match position if the expected prompt doesn't
261 materialize immediately:
263 $h = harness \@smbclient, \$in, \$out ;
266 $h->pump until $out =~ /^smb.*> \Z/mgc ;
267 die "error cding to /src:\n$out" if $out =~ "ERR" ;
270 $h->pump until $out =~ /^smb.*> \Z/mgc ;
271 die "error retrieving files:\n$out" if $out =~ "ERR" ;
278 When using this technique, you may want to preallocate $out to have
279 plenty of memory or you may find that the act of growing $out each time
280 new input arrives causes an C<O(length($out)^2)> slowdown as $out grows.
281 Say we expect no more than 10,000 characters of input at the most. To
282 preallocate memory to $out, do something like:
284 my $out = "x" x 10_000 ;
287 C<perl> will allocate at least 10,000 characters' worth of space, then
288 mark the $out as having 0 length without freeing all that yummy RAM.
290 =head2 Timeouts and Timers
292 More than likely, you don't want your subprocesses to run forever, and
293 sometimes it's nice to know that they're going a little slowly.
294 Timeouts throw exceptions after a some time has elapsed, timers merely
295 cause pump() to return after some time has elapsed. Neither is
296 reset/restarted automatically.
298 Timeout objects are created by calling timeout( $interval ) and passing
299 the result to run(), start() or harness(). The timeout period starts
300 ticking just after all the child processes have been fork()ed or
301 spawn()ed, and are polled for expiration in run(), pump() and finish().
302 If/when they expire, an exception is thrown. This is typically useful
303 to keep a subprocess from taking too long.
305 If a timeout occurs in run(), all child processes will be terminated and
306 all file/pipe/ptty descriptors opened by run() will be closed. File
307 descriptors opened by the parent process and passed in to run() are not
308 closed in this event.
310 If a timeout occurs in pump(), pump_nb(), or finish(), it's up to you to
311 decide whether to kill_kill() all the children or to implement some more
312 graceful fallback. No I/O will be closed in pump(), pump_nb() or
313 finish() by such an exception (though I/O is often closed down in those
314 routines during the natural course of events).
316 Often an exception is too harsh. timer( $interval ) creates timer
317 objects that merely prevent pump() from blocking forever. This can be
318 useful for detecting stalled I/O or printing a soothing message or "."
319 to pacify an anxious user.
321 Timeouts and timers can both be restarted at any time using the timer's
322 start() method (this is not the start() that launches subprocesses). To
323 restart a timer, you need to keep a reference to the timer:
325 ## Start with a nice long timeout to let smbclient connect. If
326 ## pump or finish take too long, an exception will be thrown.
330 $h = harness \@smbclient, \$in, \$out, \$err, ( my $t = timeout 30 ) ;
331 sleep 11 ; # No effect: timer not running yet
335 pump $h until ! length $in ;
338 ## Now use a short timeout, since this should be faster
340 pump $h until ! length $in ;
342 $t->start( 10 ) ; ## Give smbclient a little while to shut down.
346 my $x = $@ ; ## Preserve $@ in case another exception occurs
347 $h->kill_kill ; ## kill it gently, then brutally if need be, or just
348 ## brutally on Win32.
352 Timeouts and timers are I<not> checked once the subprocesses are shut
353 down; they will not expire in the interval between the last valid
354 process and when IPC::Run scoops up the processes' result codes, for
357 =head2 Spawning synchronization, child exception propagation
359 start() pauses the parent until the child executes the command or CODE
360 reference and propagates any exceptions thrown (including exec()
361 failure) back to the parent. This has several pleasant effects: any
362 exceptions thrown in the child, including exec() failure, come flying
363 out of start() or run() as though they had ocurred in the parent.
365 This includes exceptions your code thrown from init subs. In this
369 run \@cmd, init => sub { die "blast it! foiled again!" } ;
373 the exception "blast it! foiled again" will be thrown from the child
374 process (preventing the exec()) and printed by the parent.
378 run \@cmd1, "|", \@cmd2, "|", \@cmd3 ;
380 @cmd1 will be initted and exec()ed before @cmd2, and @cmd2 before @cmd3.
381 This can save time and prevent oddball errors emitted by later commands
382 when earlier commands fail to execute. Note that IPC::Run doesn't start
383 any commands unless it can find the executables referenced by all
384 commands. These executables must pass both the C<-f> and C<-x> tests
385 described in L<perlfunc>.
387 Another nice effect is that init() subs can take their time doing things
388 and there will be no problems caused by a parent continuing to execute
389 before a child's init() routine is complete. Say the init() routine
390 needs to open a socket or a temp file that the parent wants to connect
391 to; without this synchronization, the parent will need to implement a
392 retry loop to wait for the child to run, since often, the parent gets a
393 lot of things done before the child's first timeslice is allocated.
395 This is also quite necessary for pseudo-tty initialization, which needs
396 to take place before the parent writes to the child via pty. Writes
397 that occur before the pty is set up can get lost.
399 A final, minor, nicety is that debugging output from the child will be
400 emitted before the parent continues on, making for much clearer debugging
401 output in complex situations.
403 The only drawback I can conceive of is that the parent can't continue to
404 operate while the child is being initted. If this ever becomes a
405 problem in the field, we can implement an option to avoid this behavior,
406 but I don't expect it to.
408 B<Win32>: executing CODE references isn't supported on Win32, see
409 L</Win32 LIMITATIONS> for details.
413 run(), start(), and harness() can all take a harness specification
414 as input. A harness specification is either a single string to be passed
415 to the systems' shell:
417 run "echo 'hi there'" ;
419 or a list of commands, io operations, and/or timers/timeouts to execute.
420 Consecutive commands must be separated by a pipe operator '|' or an '&'.
421 External commands are passed in as array references, and, on systems
422 supporting fork(), Perl code may be passed in as subs:
425 run \@cmd1, '|', \@cmd2 ;
426 run \@cmd1, '&', \@cmd2 ;
428 run \&sub1, '|', \&sub2 ;
429 run \&sub1, '&', \&sub2 ;
431 '|' pipes the stdout of \@cmd1 the stdin of \@cmd2, just like a
432 shell pipe. '&' does not. Child processes to the right of a '&'
433 will have their stdin closed unless it's redirected-to.
435 L<IPC::Run::IO> objects may be passed in as well, whether or not
436 child processes are also specified:
438 run io( "infile", ">", \$in ), io( "outfile", "<", \$in ) ;
440 as can L<IPC::Run::Timer> objects:
442 run \@cmd, io( "outfile", "<", \$in ), timeout( 10 ) ;
444 Commands may be followed by scalar, sub, or i/o handle references for
446 child process input & output:
448 run \@cmd, \undef, \$out ;
449 run \@cmd, \$in, \$out ;
450 run \@cmd1, \&in, '|', \@cmd2, \*OUT ;
451 run \@cmd1, \*IN, '|', \@cmd2, \&out ;
453 This is known as succinct redirection syntax, since run(), start()
454 and harness(), figure out which file descriptor to redirect and how.
455 File descriptor 0 is presumed to be an input for
456 the child process, all others are outputs. The assumed file
457 descriptor always starts at 0, unless the command is being piped to,
458 in which case it starts at 1.
460 To be explicit about your redirects, or if you need to do more complex
461 things, there's also a redirection operator syntax:
463 run \@cmd, '<', \undef, '>', \$out ;
464 run \@cmd, '<', \undef, '>&', \$out_and_err ;
472 Operator syntax is required if you need to do something other than simple
473 redirection to/from scalars or subs, like duping or closing file descriptors
474 or redirecting to/from a named file. The operators are covered in detail
477 After each \@cmd (or \&foo), parsing begins in succinct mode and toggles to
478 operator syntax mode when an operator (ie plain scalar, not a ref) is seen.
480 operator syntax mode, parsing only reverts to succinct mode when a '|' or
483 In succinct mode, each parameter after the \@cmd specifies what to
484 do with the next highest file descriptor. These File descriptor start
485 with 0 (stdin) unless stdin is being piped to (C<'|', \@cmd>), in which
486 case they start with 1 (stdout). Currently, being on the left of
487 a pipe (C<\@cmd, \$out, \$err, '|'>) does I<not> cause stdout to be
488 skipped, though this may change since it's not as DWIMerly as it
489 could be. Only stdin is assumed to be an
490 input in succinct mode, all others are assumed to be outputs.
492 If no piping or redirection is specified for a child, it will inherit
493 the parent's open file handles as dictated by your system's
494 close-on-exec behavior and the $^F flag, except that processes after a
495 '&' will not inherit the parent's stdin. Also note that $^F does not
496 affect file desciptors obtained via POSIX, since it only applies to
497 full-fledged Perl file handles. Such processes will have their stdin
498 closed unless it has been redirected-to.
500 If you want to close a child processes stdin, you may do any of:
507 Redirection is done by placing redirection specifications immediately
508 after a command or child subroutine:
510 run \@cmd1, \$in, '|', \@cmd2, \$out ;
511 run \@cmd1, '<', \$in, '|', \@cmd2, '>', \$out ;
513 If you omit the redirection operators, descriptors are counted
514 starting at 0. Descriptor 0 is assumed to be input, all others
515 are outputs. A leading '|' consumes descriptor 0, so this
518 run \@cmd1, \$in, '|', \@cmd2, \$out ;
520 The parameter following a redirection operator can be a scalar ref,
521 a subroutine ref, a file name, an open filehandle, or a closed
524 If it's a scalar ref, the child reads input from or sends output to
527 $in = "Hello World.\n" ;
528 run \@cat, \$in, \$out ;
531 Scalars used in incremental (start()/pump()/finish()) applications are treated
532 as queues: input is removed from input scalers, resulting in them dwindling
533 to '', and output is appended to output scalars. This is not true of
534 harnesses run() in batch mode.
536 It's usually wise to append new input to be sent to the child to the input
537 queue, and you'll often want to zap output queues to '' before pumping.
539 $h = start \@cat, \$in ;
547 The final call to finish() must be there: it allows the child process(es)
548 to run to completion and waits for their exit values.
550 =head1 OBSTINATE CHILDREN
552 Interactive applications are usually optimized for human use. This
553 can help or hinder trying to interact with them through modules like
554 IPC::Run. Frequently, programs alter their behavior when they detect
555 that stdin, stdout, or stderr are not connected to a tty, assuming that
556 they are being run in batch mode. Whether this helps or hurts depends
557 on which optimizations change. And there's often no way of telling
558 what a program does in these areas other than trial and error and,
559 occasionally, reading the source. This includes different versions
560 and implementations of the same program.
562 All hope is not lost, however. Most programs behave in reasonably
563 tractable manners, once you figure out what it's trying to do.
565 Here are some of the issues you might need to be aware of.
571 fflush()ing stdout and stderr
573 This lets the user see stdout and stderr immediately. Many programs
574 undo this optimization if stdout is not a tty, making them harder to
575 manage by things like IPC::Run.
577 Many programs decline to fflush stdout or stderr if they do not
578 detect a tty there. Some ftp commands do this, for instance.
580 If this happens to you, look for a way to force interactive behavior,
581 like a command line switch or command. If you can't, you will
582 need to use a pseudo terminal ('<pty<' and '>pty>').
588 Interactive programs generally do not guarantee that output from user
589 commands won't contain a prompt string. For example, your shell prompt
590 might be a '$', and a file named '$' might be the only file in a directory
593 This can make it hard to guarantee that your output parser won't be fooled
594 into early termination of results.
596 To help work around this, you can see if the program can alter it's
597 prompt, and use something you feel is never going to occur in actual
600 You should also look for your prompt to be the only thing on a line:
602 pump $h until $out =~ /^<SILLYPROMPT>\s?\z/m ;
604 (use C<(?!\n)\Z> in place of C<\z> on older perls).
606 You can also take the approach that IPC::ChildSafe takes and emit a
607 command with known output after each 'real' command you issue, then
608 look for this known output. See new_appender() and new_chunker() for
609 filters that can help with this task.
611 If it's not convenient or possibly to alter a prompt or use a known
612 command/response pair, you might need to autodetect the prompt in case
613 the local version of the child program is different then the one
614 you tested with, or if the user has control over the look & feel of
619 Refusing to accept input unless stdin is a tty.
621 Some programs, for security reasons, will only accept certain types
622 of input from a tty. su, notable, will not prompt for a password unless
623 it's connected to a tty.
625 If this is your situation, use a pseudo terminal ('<pty<' and '>pty>').
629 Not prompting unless connected to a tty.
631 Some programs don't prompt unless stdin or stdout is a tty. See if you can
632 turn prompting back on. If not, see if you can come up with a command that
633 you can issue after every real command and look for it's output, as
634 IPC::ChildSafe does. There are two filters included with IPC::Run that
635 can help with doing this: appender and chunker (see new_appender() and
640 Different output format when not connected to a tty.
642 Some commands alter their formats to ease machine parsability when they
643 aren't connected to a pipe. This is actually good, but can be surprising.
647 =head1 PSEUDO TERMINALS
649 On systems providing pseudo terminals under /dev, IPC::Run can use IO::Pty
650 (available on CPAN) to provide a terminal environment to subprocesses.
651 This is necessary when the subprocess really wants to think it's connected
656 Psuedo-terminals are not pipes, though they are similar. Here are some
657 differences to watch out for.
663 Sending to stdin will cause an echo on stdout, which occurs before each
664 line is passed to the child program. There is currently no way to
665 disable this, although the child process can and should disable it for
666 things like passwords.
670 IPC::Run cannot close a pty until all output has been collected. This
671 means that it is not possible to send an EOF to stdin by half-closing
672 the pty, as we can when using a pipe to stdin.
674 This means that you need to send the child process an exit command or
675 signal, or run() / finish() will time out. Be careful not to expect a
676 prompt after sending the exit command.
678 =item Command line editing
680 Some subprocesses, notable shells that depend on the user's prompt
681 settings, will reissue the prompt plus the command line input so far
682 once for each character.
684 =item '>pty>' means '&>pty>', not '1>pty>'
686 The pseudo terminal redirects both stdout and stderr unless you specify
687 a file descriptor. If you want to grab stderr separately, do this:
689 start \@cmd, '<pty<', \$in, '>pty>', \$out, '2>', \$err ;
691 =item stdin, stdout, and stderr not inherited
693 Child processes harnessed to a pseudo terminal have their stdin, stdout,
694 and stderr completely closed before any redirection operators take
695 effect. This casts of the bonds of the controlling terminal. This is
696 not done when using pipes.
698 Right now, this affects all children in a harness that has a pty in use,
699 even if that pty would not affect a particular child. That's a bug and
700 will be fixed. Until it is, it's best not to mix-and-match children.
704 =head2 Redirection Operators
706 Operator SHNP Description
707 ======== ==== ===========
708 <, N< SHN Redirects input to a child's fd N (0 assumed)
710 >, N> SHN Redirects output from a child's fd N (1 assumed)
711 >>, N>> SHN Like '>', but appends to scalars or named files
712 >&, &> SHN Redirects stdout & stderr from a child process
714 <pty, N<pty S Like '<', but uses a pseudo-tty instead of a pipe
715 >pty, N>pty S Like '>', but uses a pseudo-tty instead of a pipe
717 N<&M Dups input fd N to input fd M
718 M>&N Dups output fd N to input fd M
721 <pipe, N<pipe P Pipe opens H for caller to read, write, close.
722 >pipe, N>pipe P Pipe opens H for caller to read, write, close.
724 'N' and 'M' are placeholders for integer file descriptor numbers. The
725 terms 'input' and 'output' are from the child process's perspective.
727 The SHNP field indicates what parameters an operator can take:
729 S: \$scalar or \&function references. Filters may be used with
730 these operators (and only these).
731 H: \*HANDLE or IO::Handle for caller to open, and close
733 P: \*HANDLE opened by IPC::Run as the parent end of a pipe, but read
734 and written to and closed by the caller (like IPC::Open3).
738 =item Redirecting input: [n]<, [n]<pipe
740 You can input the child reads on file descriptor number n to come from a
741 scalar variable, subroutine, file handle, or a named file. If stdin
742 is not redirected, the parent's stdin is inherited.
744 run \@cat, \undef ## Closes child's stdin immediately
745 or die "cat returned $?" ;
749 run \@cat, \<<TOHERE ;
753 run \@cat, \&input ; ## Calls &input, feeding data returned
754 ## to child's. Closes child's stdin
755 ## when undef is returned.
757 Redirecting from named files requires you to use the input
758 redirection operator:
760 run \@cat, '<.profile' ;
761 run \@cat, '<', '.profile' ;
767 The form used second example here is the safest,
768 since filenames like "0" and "&more\n" won't confuse &run:
770 You can't do either of
772 run \@a, *IN ; ## INVALID
773 run \@a, '<', *IN ; ## BUGGY: Reads file named like "*main::A"
775 because perl passes a scalar containing a string that
776 looks like "*main::A" to &run, and &run can't tell the difference
777 between that and a redirection operator or a file name. &run guarantees
778 that any scalar you pass after a redirection operator is a file name.
780 If your child process will take input from file descriptors other
781 than 0 (stdin), you can use a redirection operator with any of the
782 valid input forms (scalar ref, sub ref, etc.):
784 run \@cat, '3<', \$in3 ;
786 When redirecting input from a scalar ref, the scalar ref is
787 used as a queue. This allows you to use &harness and pump() to
788 feed incremental bits of input to a coprocess. See L</Coprocesses>
789 below for more information.
791 The <pipe operator opens the write half of a pipe on the filehandle
792 glob reference it takes as an argument:
794 $h = start \@cat, '<pipe', \*IN ;
795 print IN "hello world\n" ;
800 Unlike the other '<' operators, IPC::Run does nothing further with
801 it: you are responsible for it. The previous example is functionally
804 pipe( \*R, \*IN ) or die $! ;
805 $h = start \@cat, '<', \*IN ;
806 print IN "hello world\n" ;
811 This is like the behavior of IPC::Open2 and IPC::Open3.
813 B<Win32>: The handle returned is actually a socket handle, so you can
816 =item Redirecting output: [n]>, [n]>>, [n]>&[m], [n]>pipe
818 You can redirect any output the child emits
819 to a scalar variable, subroutine, file handle, or file name. You
820 can have &run truncate or append to named files or scalars. If
821 you are redirecting stdin as well, or if the command is on the
822 receiving end of a pipeline ('|'), you can omit the redirection
826 run \@ls, \undef, \$out
827 or die "ls returned $?" ;
829 run \@ls, \undef, \&out ; ## Calls &out each time some output
830 ## is received from the child's
831 ## when undef is returned.
833 run \@ls, \undef, '2>ls.err' ;
834 run \@ls, '2>', 'ls.err' ;
836 The two parameter form guarantees that the filename
837 will not be interpreted as a redirection operator:
839 run \@ls, '>', "&more" ;
840 run \@ls, '2>', ">foo\n" ;
842 You can pass file handles you've opened for writing:
844 open( *OUT, ">out.txt" ) ;
845 open( *ERR, ">err.txt" ) ;
846 run \@cat, \*OUT, \*ERR ;
848 Passing a scalar reference and a code reference requires a little
849 more work, but allows you to capture all of the output in a scalar
850 or each piece of output by a callback:
852 These two do the same things:
854 run( [ 'ls' ], '2>', sub { $err_out .= $_[0] } ) ;
856 does the same basic thing as:
858 run( [ 'ls' ], '2>', \$err_out ) ;
860 The subroutine will be called each time some data is read from the child.
862 The >pipe operator is different in concept than the other '>' operators,
863 although it's syntax is similar:
865 $h = start \@cat, $in, '>pipe', \*OUT, '2>pipe', \*ERR ;
866 $in = "hello world\n" ;
873 causes two pipe to be created, with one end attached to cat's stdout
874 and stderr, respectively, and the other left open on OUT and ERR, so
875 that the script can manually
876 read(), select(), etc. on them. This is like
877 the behavior of IPC::Open2 and IPC::Open3.
879 B<Win32>: The handle returned is actually a socket handle, so you can
882 =item Duplicating output descriptors: >&m, n>&m
884 This duplicates output descriptor number n (default is 1 if n is omitted)
885 from descriptor number m.
887 =item Duplicating input descriptors: <&m, n<&m
889 This duplicates input descriptor number n (default is 0 if n is omitted)
890 from descriptor number m
892 =item Closing descriptors: <&-, 3<&-
894 This closes descriptor number n (default is 0 if n is omitted). The
895 following commands are equivalent:
899 run \@cmd, '<in.txt', '<&-' ;
903 run \@cmd, \$in, '<&-' ; ## SIGPIPE recipe.
905 is dangerous: the parent will get a SIGPIPE if $in is not empty.
907 =item Redirecting both stdout and stderr: &>, >&, &>pipe, >pipe&
909 The following pairs of commands are equivalent:
911 run \@cmd, '>&', \$out ; run \@cmd, '>', \$out, '2>&1' ;
912 run \@cmd, '>&', 'out.txt' ; run \@cmd, '>', 'out.txt', '2>&1' ;
916 File descriptor numbers are not permitted to the left or the right of
917 these operators, and the '&' may occur on either end of the operator.
919 The '&>pipe' and '>pipe&' variants behave like the '>pipe' operator, except
920 that both stdout and stderr write to the created pipe.
922 =item Redirection Filters
924 Both input redirections and output redirections that use scalars or
925 subs as endpoints may have an arbitrary number of filter subs placed
926 between them and the child process. This is useful if you want to
927 receive output in chunks, or if you want to massage each chunk of
928 data sent to the child. To use this feature, you must use operator
933 '<', \&in_filter_2, \&in_filter_1, $in,
934 '>', \&out_filter_1, \&in_filter_2, $out,
937 This capability is not provided for IO handles or named files.
939 Two filters are provided by IPC::Run: appender and chunker. Because
940 these may take an argument, you need to use the constructor functions
941 new_appender() and new_chunker() rather than using \& syntax:
945 '<', new_appender( "\n" ), $in,
946 '>', new_chunker, $out,
951 =head2 Just doing I/O
953 If you just want to do I/O to a handle or file you open yourself, you
954 may specify a filehandle or filename instead of a command in the harness
957 run io( "filename", '>', \$recv ) ;
959 $h = start io( $io, '>', \$recv ) ;
961 $h = harness \@cmd, '&', io( "file", '<', \$send ) ;
965 Options are passed in as name/value pairs:
967 run \@cat, \$in, debug => 1 ;
969 If you pass the debug option, you may want to pass it in first, so you
970 can see what parsing is going on:
972 run debug => 1, \@cat, \$in ;
978 Enables debugging output in parent and child. Debugging info is emitted
979 to the STDERR that was present when IPC::Run was first C<use()>ed (it's
980 C<dup()>ed out of the way so that it can be redirected in children without
981 having debugging output emitted on it).
987 harness() and start() return a reference to an IPC::Run harness. This is
988 blessed in to the IPC::Run package, so you may make later calls to
989 functions as members if you like:
991 $h = harness( ... ) ;
1000 Of course, using method call syntax lets you deal with any IPC::Run
1001 subclasses that might crop up, but don't hold your breath waiting for
1004 run() and finish() return TRUE when all subcommands exit with a 0 result
1005 code. B<This is the opposite of perl's system() command>.
1007 All routines raise exceptions (via die()) when error conditions are
1008 recognized. A non-zero command result is not treated as an error
1009 condition, since some commands are tests whose results are reported
1010 in their exit codes.
1018 @ISA = qw( Exporter ) ;
1020 ## We use @EXPORT for the end user's convenience: there's only one function
1021 ## exported, it's homonymous with the module, it's an unusual name, and
1022 ## it can be suppressed by "use IPC::Run () ;".
1024 my @FILTER_IMP = qw( input_avail get_more_input ) ;
1033 harness start pump pumpable finish
1034 signal kill_kill reap_nb
1040 @EXPORT_OK = ( @API, @FILTER_IMP, @FILTERS, qw( filter_tests Win32_MODE ) ) ;
1042 'filter_imp' => \@FILTER_IMP,
1043 'all' => \@EXPORT_OK,
1044 'filters' => \@FILTERS,
1050 use IPC::Run::Debug;
1058 require IPC::Run::IO ;
1059 require IPC::Run::Timer ;
1060 use UNIVERSAL qw( isa ) ;
1062 use constant Win32_MODE => $^O =~ /os2|Win32/i ;
1066 eval "use IPC::Run::Win32Helper; 1;"
1067 or ( $@ && die ) or die "$!" ;
1070 eval "use File::Basename; 1;" or die $! ;
1076 sub get_more_input() ;
1078 ###############################################################################
1081 ## State machine states, set in $self->{STATE}
1083 ## These must be in ascending order numerically
1087 sub _finished() {2} ## _finished behave almost exactly like _harnessed
1091 ## Which fds have been opened in the parent. This may have extra fds, since
1092 ## we aren't all that rigorous about closing these off, but that's ok. This
1093 ## is used on Unixish OSs to close all fds in the child that aren't needed
1094 ## by that particular child.
1097 ## There's a bit of hackery going on here.
1099 ## We want to have any code anywhere be able to emit
1100 ## debugging statements without knowing what harness the code is
1101 ## being called in/from, since we'd need to pass a harness around to
1104 ## Thus, $cur_self was born.
1106 use vars qw( $cur_self ) ;
1109 return fileno STDERR unless defined $cur_self ;
1111 if ( _debugging && ! defined $cur_self->{DEBUG_FD} ) {
1112 my $fd = select STDERR ; $| = 1 ; select $fd ;
1113 $cur_self->{DEBUG_FD} = POSIX::dup fileno STDERR ;
1114 _debug( "debugging fd is $cur_self->{DEBUG_FD}\n" )
1115 if _debugging_details ;
1118 return fileno STDERR unless defined $cur_self->{DEBUG_FD} ;
1120 return $cur_self->{DEBUG_FD}
1124 ## We absolutely do not want to do anything else here. We are likely
1125 ## to be in a child process and we don't want to do things like kill_kill
1126 ## ourself or cause other destruction.
1127 my IPC::Run $self = shift ;
1128 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD} ;
1129 $self->{DEBUG_FD} = undef ;
1133 ## Support routines (NOT METHODS)
1138 my ( $cmd_name ) = @_ ;
1139 if ( File::Spec->file_name_is_absolute( $cmd_name ) && -x $cmd_name) {
1140 _debug "'", $cmd_name, "' is absolute"
1141 if _debugging_details ;
1156 && ( $cmd_name =~ /$dirsep/ )
1157 && ( $cmd_name !~ /\..+$/ ) ## Only run if cmd_name has no extension?
1159 for ( split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE" ) {
1160 my $name = "$cmd_name$_";
1161 $cmd_name = $name, last if -f $name && -x _;
1165 if ( $cmd_name =~ /($dirsep)/ ) {
1166 _debug "'$cmd_name' contains '$1'" if _debugging;
1167 croak "file not found: $cmd_name" unless -e $cmd_name ;
1168 croak "not a file: $cmd_name" unless -f $cmd_name ;
1169 croak "permission denied: $cmd_name" unless -x $cmd_name ;
1173 if ( exists $cmd_cache{$cmd_name} ) {
1174 _debug "'$cmd_name' found in cache: '$cmd_cache{$cmd_name}'"
1176 return $cmd_cache{$cmd_name} if -x $cmd_cache{$cmd_name} ;
1177 _debug "'$cmd_cache{$cmd_name}' no longer executable, searching..."
1179 delete $cmd_cache{$cmd_name} ;
1184 ## This next bit is Unix/Win32 specific, unfortunately.
1185 ## There's been some conversation about extending File::Spec to provide
1186 ## a universal interface to PATH, but I haven't seen it yet.
1187 my $re = Win32_MODE ? qr/;/ : qr/:/ ;
1190 for ( split( $re, $ENV{PATH}, -1 ) ) {
1191 $_ = "." unless length $_ ;
1192 push @searched_in, $_ ;
1194 my $prospect = File::Spec->catfile( $_, $cmd_name ) ;
1198 ( Win32_MODE && ! ( -f $prospect && -x _ ) )
1199 ? map "$prospect$_", split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE"
1202 for my $found ( @prospects ) {
1203 if ( -f $found && -x _ ) {
1204 $cmd_cache{$cmd_name} = $found ;
1210 if ( exists $cmd_cache{$cmd_name} ) {
1211 _debug "'", $cmd_name, "' added to cache: '", $cmd_cache{$cmd_name}, "'"
1212 if _debugging_details ;
1213 return $cmd_cache{$cmd_name} ;
1216 croak "Command '$cmd_name' not found in " . join( ", ", @searched_in ) ;
1220 sub _empty($) { ! ( defined $_[0] && length $_[0] ) }
1222 ## 'safe' versions of otherwise fun things to do. See also IPC::Run::Win32Helper.
1224 confess 'undef' unless defined $_[0] ;
1226 my $fd = $_[0] =~ /^\d+$/ ? $_[0] : fileno $_[0] ;
1227 my $r = POSIX::close $fd ;
1228 $r = $r ? '' : " ERROR $!" ;
1230 _debug "close( $fd ) = " . ( $r || 0 ) if _debugging_details ;
1234 confess 'undef' unless defined $_[0] ;
1235 my $r = POSIX::dup( $_[0] ) ;
1236 croak "$!: dup( $_[0] )" unless defined $r ;
1237 $r = 0 if $r eq '0 but true' ;
1238 _debug "dup( $_[0] ) = $r" if _debugging_details ;
1245 confess 'undef' unless defined $_[0] && defined $_[1] ;
1246 my $r = POSIX::dup2( $_[0], $_[1] ) ;
1247 croak "$!: dup2( $_[0], $_[1] )" unless defined $r ;
1248 $r = 0 if $r eq '0 but true' ;
1249 _debug "dup2( $_[0], $_[1] ) = $r" if _debugging_details ;
1255 confess 'undef passed' if grep !defined, @_ ;
1256 # exec @_ or croak "$!: exec( " . join( ', ', @_ ) . " )" ;
1257 _debug 'exec()ing ', join " ", map "'$_'", @_ if _debugging_details ;
1260 ## Commented out since we don't call this on Win32.
1261 # # This works around the bug where 5.6.1 complains
1262 # # "Can't exec ...: No error" after an exec on NT, where
1263 # # exec() is simulated and actually returns in Perl's C
1264 # # code, though Perl's &exec does not...
1265 # no warnings "exec" ;
1267 # # Just in case the no warnings workaround
1268 # # stops beign a workaround, we don't want
1269 # # old values of $! causing spurious strerr()
1270 # # messages to appear in the "Can't exec" message
1274 # croak "$!: exec( " . join( ', ', map "'$_'", @_ ) . " )" ;
1275 ## Fall through so $! can be reported to parent.
1280 confess 'undef' unless defined $_[0] && defined $_[1] ;
1281 _debug sprintf( "O_RDONLY=0x%02x ", O_RDONLY ),
1282 sprintf( "O_WRONLY=0x%02x ", O_WRONLY ),
1283 sprintf( "O_RDWR=0x%02x ", O_RDWR ),
1284 sprintf( "O_TRUNC=0x%02x ", O_TRUNC),
1285 sprintf( "O_CREAT=0x%02x ", O_CREAT),
1286 sprintf( "O_APPEND=0x%02x ", O_APPEND),
1287 if _debugging_details ;
1288 my $r = POSIX::open( $_[0], $_[1], 0644 ) ;
1289 croak "$!: open( $_[0], ", sprintf( "0x%03x", $_[1] ), " )" unless defined $r ;
1290 _debug "open( $_[0], ", sprintf( "0x%03x", $_[1] ), " ) = $r"
1291 if _debugging_data ;
1297 ## Normal, blocking write for pipes that we read and the child writes,
1298 ## since most children expect writes to stdout to block rather than
1299 ## do a partial write.
1300 my ( $r, $w ) = POSIX::pipe ;
1301 croak "$!: pipe()" unless defined $r ;
1302 _debug "pipe() = ( $r, $w ) " if _debugging_details ;
1303 $fds{$r} = $fds{$w} = 1 ;
1308 ## For pipes that we write, unblock the write side, so we can fill a buffer
1309 ## and continue to select().
1310 ## Contributed by Borislav Deianov <borislav@ensim.com>, with minor
1311 ## bugfix on fcntl result by me.
1313 my $f = pipe( R, W ) ;
1314 croak "$!: pipe()" unless defined $f ;
1315 my ( $r, $w ) = ( fileno R, fileno W ) ;
1316 _debug "pipe_nb pipe() = ( $r, $w )" if _debugging_details ;
1317 unless ( Win32_MODE ) {
1318 ## POSIX::fcntl doesn't take fd numbers, so gotta use Perl's and
1319 ## then _dup the originals (which get closed on leaving this block)
1320 my $fres = fcntl( W, &F_SETFL, O_WRONLY | O_NONBLOCK );
1321 croak "$!: fcntl( $w, F_SETFL, O_NONBLOCK )" unless $fres ;
1322 _debug "fcntl( $w, F_SETFL, O_NONBLOCK )" if _debugging_details ;
1324 ( $r, $w ) = ( _dup( $r ), _dup( $w ) ) ;
1325 _debug "pipe_nb() = ( $r, $w )" if _debugging_details ;
1331 my $pty = IO::Pty->new() ;
1332 croak "$!: pty ()" unless $pty ;
1334 $pty->blocking( 0 ) or croak "$!: pty->blocking ( 0 )" ;
1335 _debug "pty() = ( ", $pty->fileno, ", ", $pty->slave->fileno, " )"
1336 if _debugging_details ;
1337 $fds{$pty->fileno} = $fds{$pty->slave->fileno} = 1 ;
1343 confess 'undef' unless defined $_[0] ;
1345 my $r = POSIX::read( $_[0], $s, 10_000 ) ;
1346 croak "$!: read( $_[0] )" if not($r) and $! != POSIX::EINTR;
1348 _debug "read( $_[0] ) = $r chars '$s'" if _debugging_data ;
1353 ## A METHOD, not a function.
1355 my IPC::Run $self = shift ;
1358 _debug "opening sync pipe ", $kid->{PID} if _debugging_details ;
1359 my $sync_reader_fd ;
1360 ( $sync_reader_fd, $self->{SYNC_WRITER_FD} ) = _pipe ;
1361 $kid->{PID} = fork() ;
1362 croak "$! during fork" unless defined $kid->{PID} ;
1364 unless ( $kid->{PID} ) {
1365 ## _do_kid_and_exit closes sync_reader_fd since it closes all unwanted and
1367 $self->_do_kid_and_exit( $kid ) ;
1369 _debug "fork() = ", $kid->{PID} if _debugging_details ;
1371 ## Wait for kid to get to it's exec() and see if it fails.
1372 _close $self->{SYNC_WRITER_FD} ;
1373 my $sync_pulse = _read $sync_reader_fd ;
1374 _close $sync_reader_fd ;
1376 if ( ! defined $sync_pulse || length $sync_pulse ) {
1377 if ( waitpid( $kid->{PID}, 0 ) >= 0 ) {
1378 $kid->{RESULT} = $? ;
1381 $kid->{RESULT} = -1 ;
1384 "error reading synchronization pipe for $kid->{NUM}, pid $kid->{PID}"
1385 unless length $sync_pulse ;
1388 return $kid->{PID} ;
1390 ## Wait for pty to get set up. This is a hack until we get synchronous
1392 if ( keys %{$self->{PTYS}} && $IO::Pty::VERSION < 0.9 ) {
1393 _debug "sleeping to give pty a chance to init, will fix when newer IO::Pty arrives." ;
1400 confess 'undef' unless defined $_[0] && defined $_[1] ;
1401 my $r = POSIX::write( $_[0], $_[1], length $_[1] ) ;
1402 croak "$!: write( $_[0], '$_[1]' )" unless $r ;
1403 _debug "write( $_[0], '$_[1]' ) = $r" if _debugging_data ;
1410 Run takes a harness or harness specification and runs it, pumping
1411 all input to the child(ren), closing the input pipes when no more
1412 input is available, collecting all output that arrives, until the
1413 pipes delivering output are closed, then waiting for the children to
1414 exit and reaping their result codes.
1416 You may think of C<run( ... )> as being like
1418 start( ... )->finish() ;
1420 , though there is one subtle difference: run() does not
1421 set \$input_scalars to '' like finish() does. If an exception is thrown
1422 from run(), all children will be killed off "gently", and then "annihilated"
1423 if they do not go gently (in to that dark night. sorry).
1425 If any exceptions are thrown, this does a L</kill_kill> before propogating
1430 use vars qw( $in_run ); ## No, not Enron ;)
1433 local $in_run = 1; ## Allow run()-only optimizations.
1434 my IPC::Run $self = start( @_ );
1436 $self->{clear_ins} = 0 ;
1450 ## To send it a specific signal by name ("USR1"):
1452 $h->signal ( "USR1" ) ;
1454 If $signal is provided and defined, sends a signal to all child processes. Try
1455 not to send numeric signals, use C<"KILL"> instead of C<9>, for instance.
1456 Numeric signals aren't portable.
1458 Throws an exception if $signal is undef.
1460 This will I<not> clean up the harness, C<finish> it if you kill it.
1462 Normally TERM kills a process gracefully (this is what the command line utility
1463 C<kill> does by default), INT is sent by one of the keys C<^C>, C<Backspace> or
1464 C<E<lt>DelE<gt>>, and C<QUIT> is used to kill a process and make it coredump.
1466 The C<HUP> signal is often used to get a process to "restart", rereading
1467 config files, and C<USR1> and C<USR2> for really application-specific things.
1469 Often, running C<kill -l> (that's a lower case "L") on the command line will
1470 list the signals present on your operating system.
1472 B<WARNING>: The signal subsystem is not at all portable. We *may* offer
1473 to simulate C<TERM> and C<KILL> on some operating systems, submit code
1474 to me if you want this.
1476 B<WARNING 2>: Up to and including perl v5.6.1, doing almost anything in a
1477 signal handler could be dangerous. The most safe code avoids all
1478 mallocs and system calls, usually by preallocating a flag before
1479 entering the signal handler, altering the flag's value in the
1480 handler, and responding to the changed value in the main system:
1483 sub usr1_handler { ++$got_signal }
1485 $SIG{USR1} = \&usr1_handler ;
1486 while () { sleep 1 ; print "GOT IT" while $got_usr1-- ; }
1488 Even this approach is perilous if ++ and -- aren't atomic on your system
1489 (I've never heard of this on any modern CPU large enough to run perl).
1494 my IPC::Run $self = shift ;
1496 local $cur_self = $self ;
1498 $self->_kill_kill_kill_pussycat_kill unless @_ ;
1500 Carp::cluck "Ignoring extra parameters passed to kill()" if @_ > 1 ;
1502 my ( $signal ) = @_ ;
1503 croak "Undefined signal passed to signal" unless defined $signal ;
1504 for ( grep $_->{PID} && ! defined $_->{RESULT}, @{$self->{KIDS}} ) {
1505 _debug "sending $signal to $_->{PID}"
1507 kill $signal, $_->{PID}
1508 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 ;
1613 Takes a harness specification and returns a harness. This harness is
1614 blessed in to IPC::Run, allowing you to use method call syntax for
1615 run(), start(), et al if you like.
1617 harness() is provided so that you can pre-build harnesses if you
1618 would like to, but it's not required..
1620 You may proceed to run(), start() or pump() after calling harness() (pump()
1621 calls start() if need be). Alternatively, you may pass your
1622 harness specification to run() or start() and let them harness() for
1623 you. You can't pass harness specifications to pump(), though.
1628 ## Notes: I've avoided handling a scalar that doesn't look like an
1629 ## opcode as a here document or as a filename, though I could DWIM
1630 ## those. I'm not sure that the advantages outweight the danger when
1631 ## the DWIMer guesses wrong.
1633 ## TODO: allow user to spec default shell. Hmm, globally, in the
1634 ## lexical scope hash, or per instance? 'Course they can do that
1635 ## now by using a [...] to hold the command.
1637 my $harness_id = 0 ;
1640 if ( @_ && ref $_[-1] eq 'HASH' ) {
1642 require Data::Dumper ;
1643 carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper( $options ) ;
1646 # local $IPC::Run::debug = $options->{debug}
1647 # if $options && defined $options->{debug} ;
1651 if ( @_ == 1 && ! ref $_[0] ) {
1653 @args = ( [ qw( command /c ), win32_parse_cmd_line $_[0] ] ) ;
1656 @args = ( [ qw( sh -c ), @_ ] ) ;
1659 elsif ( @_ > 1 && ! grep ref $_, @_ ) {
1660 @args = ( [ @_ ] ) ;
1666 my @errs ; # Accum errors, emit them when done.
1668 my $succinct ; # set if no redir ops are required yet. Cleared
1671 my $cur_kid ; # references kid or handle being parsed
1673 my $assumed_fd = 0 ; # fd to assume in succinct mode (no redir ops)
1674 my $handle_num = 0 ; # 1... is which handle we're parsing
1676 my IPC::Run $self = bless {}, __PACKAGE__;
1678 local $cur_self = $self ;
1680 $self->{ID} = ++$harness_id ;
1682 $self->{KIDS} = [] ;
1683 $self->{PIPES} = [] ;
1684 $self->{PTYS} = {} ;
1685 $self->{STATE} = _newed ;
1688 $self->{$_} = $options->{$_}
1689 for keys %$options ;
1692 _debug "****** harnessing *****" if _debugging;
1696 my $arg_count = @args ;
1697 while ( @args ) { for ( shift @args ) {
1704 ? ( '[ ', join( ', ', map "'$_'", @$_ ), ' ]' )
1708 : join( '', "'", substr( $_, 0, 10 ), "...'" )
1715 if ( ref eq 'ARRAY' || ( ! $cur_kid && ref eq 'CODE' ) ) {
1716 croak "Process control symbol ('|', '&') missing" if $cur_kid ;
1717 croak "Can't spawn a subroutine on Win32"
1718 if Win32_MODE && ref eq "CODE" ;
1722 NUM => @{$self->{KIDS}} + 1,
1727 push @{$self->{KIDS}}, $cur_kid ;
1731 elsif ( isa( $_, 'IPC::Run::IO' ) ) {
1732 push @{$self->{IOS}}, $_ ;
1737 elsif ( isa( $_, 'IPC::Run::Timer' ) ) {
1738 push @{$self->{TIMERS}}, $_ ;
1743 elsif ( /^(\d*)>&(\d+)$/ ) {
1744 croak "No command before '$_'" unless $cur_kid ;
1745 push @{$cur_kid->{OPS}}, {
1748 KFD2 => length $1 ? $1 : 1,
1750 _debug "redirect operators now required" if _debugging_details ;
1751 $succinct = ! $first_parse ;
1754 elsif ( /^(\d*)<&(\d+)$/ ) {
1755 croak "No command before '$_'" unless $cur_kid ;
1756 push @{$cur_kid->{OPS}}, {
1759 KFD2 => length $1 ? $1 : 0,
1761 $succinct = ! $first_parse ;
1764 elsif ( /^(\d*)<&-$/ ) {
1765 croak "No command before '$_'" unless $cur_kid ;
1766 push @{$cur_kid->{OPS}}, {
1768 KFD => length $1 ? $1 : 0,
1770 $succinct = ! $first_parse ;
1774 /^(\d*) (<pipe)() () () $/x
1775 || /^(\d*) (<pty) ((?:\s+\S+)?) (<) () $/x
1776 || /^(\d*) (<) () () (.*)$/x
1778 croak "No command before '$_'" unless $cur_kid ;
1780 $succinct = ! $first_parse ;
1782 my $type = $2 . $4 ;
1784 my $kfd = length $1 ? $1 : 0 ;
1787 if ( $type eq '<pty<' ) {
1788 $pty_id = length $3 ? $3 : '0' ;
1789 ## do the require here to cause early error reporting
1791 ## Just flag the pyt's existence for now. It'll be
1792 ## converted to a real IO::Pty by _open_pipes.
1793 $self->{PTYS}->{$pty_id} = undef ;
1801 unless ( length $source ) {
1802 if ( ! $succinct ) {
1805 ( ref $args[1] && ! isa $args[1], "IPC::Run::Timer" )
1806 || isa $args[0], "IPC::Run::binmode_pseudo_filter"
1809 if ( isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
1810 $binmode = shift( @args )->() ;
1813 push @filters, shift @args
1817 $source = shift @args ;
1818 croak "'$_' missing a source" if _empty $source ;
1821 'Kid ', $cur_kid->{NUM}, "'s input fd ", $kfd,
1822 ' has ', scalar( @filters ), ' filters.'
1823 ) if _debugging_details && @filters ;
1826 my IPC::Run::IO $pipe = IPC::Run::IO->_new_internal(
1827 $type, $kfd, $pty_id, $source, $binmode, @filters
1830 if ( ( ref $source eq 'GLOB' || isa $source, 'IO::Handle' )
1831 && $type !~ /^<p(ty<|ipe)$/
1833 _debug "setting DONT_CLOSE" if _debugging_details ;
1834 $pipe->{DONT_CLOSE} = 1 ; ## this FD is not closed by us.
1835 _dont_inherit( $source ) if Win32_MODE ;
1838 push @{$cur_kid->{OPS}}, $pipe ;
1841 elsif ( /^() (>>?) (&) () (.*)$/x
1842 || /^() (&) (>pipe) () () $/x
1843 || /^() (>pipe)(&) () () $/x
1844 || /^(\d*)() (>pipe) () () $/x
1845 || /^() (&) (>pty) ( \w*)> () $/x
1846 ## TODO: || /^() (>pty) (\d*)> (&) () $/x
1847 || /^(\d*)() (>pty) ( \w*)> () $/x
1848 || /^() (&) (>>?) () (.*)$/x
1849 || /^(\d*)() (>>?) () (.*)$/x
1851 croak "No command before '$_'" unless $cur_kid ;
1853 $succinct = ! $first_parse ;
1856 $2 eq '>pipe' || $3 eq '>pipe'
1858 : $2 eq '>pty' || $3 eq '>pty'
1862 my $kfd = length $1 ? $1 : 1 ;
1863 my $trunc = ! ( $2 eq '>>' || $3 eq '>>' ) ;
1865 $2 eq '>pty' || $3 eq '>pty'
1866 ? length $4 ? $4 : 0
1873 || ( ! length $1 && substr( $type, 0, 4 ) eq '>pty' ) ;
1878 unless ( length $dest ) {
1879 if ( ! $succinct ) {
1880 ## unshift...shift: '>' filters source...sink left...right
1883 ( ref $args[1] && ! isa $args[1], "IPC::Run::Timer" )
1884 || isa $args[0], "IPC::Run::binmode_pseudo_filter"
1887 if ( isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
1888 $binmode = shift( @args )->() ;
1891 unshift @filters, shift @args ;
1896 $dest = shift @args ;
1899 'Kid ', $cur_kid->{NUM}, "'s output fd ", $kfd,
1900 ' has ', scalar( @filters ), ' filters.'
1901 ) if _debugging_details && @filters ;
1903 if ( $type eq '>pty>' ) {
1904 ## do the require here to cause early error reporting
1906 ## Just flag the pyt's existence for now. _open_pipes()
1907 ## will new an IO::Pty for each key.
1908 $self->{PTYS}->{$pty_id} = undef ;
1912 croak "'$_' missing a destination" if _empty $dest ;
1913 my $pipe = IPC::Run::IO->_new_internal(
1914 $type, $kfd, $pty_id, $dest, $binmode, @filters
1916 $pipe->{TRUNC} = $trunc ;
1918 if ( ( isa( $dest, 'GLOB' ) || isa( $dest, 'IO::Handle' ) )
1919 && $type !~ /^>(pty>|pipe)$/
1921 _debug "setting DONT_CLOSE" if _debugging_details ;
1922 $pipe->{DONT_CLOSE} = 1 ; ## this FD is not closed by us.
1924 push @{$cur_kid->{OPS}}, $pipe ;
1925 push @{$cur_kid->{OPS}}, {
1932 elsif ( $_ eq "|" ) {
1933 croak "No command before '$_'" unless $cur_kid ;
1934 unshift @{$cur_kid->{OPS}}, {
1943 elsif ( $_ eq "&" ) {
1944 croak "No command before '$_'" unless $cur_kid ;
1945 unshift @{$cur_kid->{OPS}}, {
1954 elsif ( $_ eq 'init' ) {
1955 croak "No command before '$_'" unless $cur_kid ;
1956 push @{$cur_kid->{OPS}}, {
1962 elsif ( ! ref $_ ) {
1963 $self->{$_} = shift @args;
1966 elsif ( $_ eq 'init' ) {
1967 croak "No command before '$_'" unless $cur_kid ;
1968 push @{$cur_kid->{OPS}}, {
1974 elsif ( $succinct && $first_parse ) {
1975 ## It's not an opcode, and no explicit opcodes have been
1976 ## seen yet, so assume it's a file name.
1978 if ( ! $assumed_fd ) {
1979 $_ = "$assumed_fd<",
1982 $_ = "$assumed_fd>",
1984 _debug "assuming '", $_, "'" if _debugging_details ;
1994 ( ref() ? $_ : 'scalar' ),
1995 ' in harness() parameter ',
2002 _debug 'caught ', $@ if _debugging;
2006 die join( '', @errs ) if @errs ;
2009 $self->{STATE} = _harnessed ;
2010 # $self->timeout( $options->{timeout} ) if exists $options->{timeout} ;
2016 my IPC::Run $self = shift ;
2022 ## When a pipe character is seen, a pipe is created. $pipe_read_fd holds
2023 ## the dangling read end of the pipe until we get to the next process.
2026 ## Output descriptors for the last command are shared by all children.
2027 ## @output_fds_accum accumulates the current set of output fds.
2028 my @output_fds_accum ;
2030 for ( sort keys %{$self->{PTYS}} ) {
2031 _debug "opening pty '", $_, "'" if _debugging_details ;
2033 $self->{PTYS}->{$_} = $pty ;
2036 for ( @{$self->{IOS}} ) {
2037 eval { $_->init ; } ;
2040 _debug 'caught ', $@ if _debugging;
2043 push @close_on_fail, $_ ;
2047 ## Loop through the kids and their OPS, interpreting any that require
2048 ## parent-side actions.
2049 for my $kid ( @{$self->{KIDS}} ) {
2050 unless ( ref $kid->{VAL} eq 'CODE' ) {
2051 $kid->{PATH} = _search_path $kid->{VAL}->[0] ;
2053 if ( defined $pipe_read_fd ) {
2054 _debug "placing write end of pipe on kid $kid->{NUM}'s stdin"
2055 if _debugging_details ;
2056 unshift @{$kid->{OPS}}, {
2057 TYPE => 'PIPE', ## Prevent next loop from triggering on this
2059 TFD => $pipe_read_fd,
2061 $pipe_read_fd = undef ;
2063 @output_fds_accum = () ;
2064 for my $op ( @{$kid->{OPS}} ) {
2065 # next if $op->{IS_DEBUG} ;
2067 if ( $op->{TYPE} eq '<' ) {
2068 my $source = $op->{SOURCE};
2069 if ( ! ref $source ) {
2071 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2072 " from '" . $source, "' (read only)"
2073 ) if _debugging_details ;
2074 croak "simulated open failure"
2075 if $self->{_simulate_open_failure} ;
2076 $op->{TFD} = _sysopen( $source, O_RDONLY ) ;
2077 push @close_on_fail, $op->{TFD} ;
2079 elsif ( isa( $source, 'GLOB' )
2080 || isa( $source, 'IO::Handle' )
2083 "Unopened filehandle in input redirect for $op->{KFD}"
2084 unless defined fileno $source ;
2085 $op->{TFD} = fileno $source ;
2087 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2088 " from fd ", $op->{TFD}
2089 ) if _debugging_details ;
2091 elsif ( isa( $source, 'SCALAR' ) ) {
2093 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2095 ) if _debugging_details ;
2097 $op->open_pipe( $self->_debug_fd ) ;
2098 push @close_on_fail, $op->{KFD}, $op->{FD} ;
2101 $op->{KIN_REF} = \$s ;
2103 elsif ( isa( $source, 'CODE' ) ) {
2105 'kid ', $kid->{NUM}, ' to read ', $op->{KFD}, ' from CODE'
2106 ) if _debugging_details ;
2108 $op->open_pipe( $self->_debug_fd ) ;
2109 push @close_on_fail, $op->{KFD}, $op->{FD} ;
2112 $op->{KIN_REF} = \$s ;
2118 . "' not allowed as a source for input redirection"
2121 $op->_init_filters ;
2123 elsif ( $op->{TYPE} eq '<pipe' ) {
2125 'kid to read ', $op->{KFD},
2126 ' from a pipe IPC::Run opens and returns',
2127 ) if _debugging_details ;
2129 my ( $r, $w ) = $op->open_pipe( $self->_debug_fd, $op->{SOURCE} ) ;
2130 _debug "caller will write to ", fileno $op->{SOURCE}
2131 if _debugging_details;
2134 $op->{FD} = undef ; # we don't manage this fd
2135 $op->_init_filters ;
2137 elsif ( $op->{TYPE} eq '<pty<' ) {
2139 'kid to read ', $op->{KFD}, " from pty '", $op->{PTY_ID}, "'",
2140 ) if _debugging_details ;
2142 for my $source ( $op->{SOURCE} ) {
2143 if ( isa( $source, 'SCALAR' ) ) {
2145 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2146 " from SCALAR via pty '", $op->{PTY_ID}, "'"
2147 ) if _debugging_details ;
2150 $op->{KIN_REF} = \$s ;
2152 elsif ( isa( $source, 'CODE' ) ) {
2154 "kid ", $kid->{NUM}, " to read ", $op->{KFD},
2155 " from CODE via pty '", $op->{PTY_ID}, "'"
2156 ) if _debugging_details ;
2158 $op->{KIN_REF} = \$s ;
2164 . "' not allowed as a source for '<pty<' redirection"
2168 $op->{FD} = $self->{PTYS}->{$op->{PTY_ID}}->fileno ;
2169 $op->{TFD} = undef ; # The fd isn't known until after fork().
2170 $op->_init_filters ;
2172 elsif ( $op->{TYPE} eq '>' ) {
2173 ## N> output redirection.
2174 my $dest = $op->{DEST} ;
2175 if ( ! ref $dest ) {
2177 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2178 " to '", $dest, "' (write only, create, ",
2179 ( $op->{TRUNC} ? 'truncate' : 'append' ),
2181 ) if _debugging_details ;
2182 croak "simulated open failure"
2183 if $self->{_simulate_open_failure} ;
2184 $op->{TFD} = _sysopen(
2188 | ( $op->{TRUNC} ? O_TRUNC : O_APPEND )
2192 ## I have no idea why this is needed to make the current
2193 ## file position survive the gyrations TFD must go
2195 POSIX::lseek( $op->{TFD}, 0, POSIX::SEEK_END() ) ;
2197 push @close_on_fail, $op->{TFD} ;
2199 elsif ( isa( $dest, 'GLOB' ) ) {
2201 "Unopened filehandle in output redirect, command $kid->{NUM}"
2202 ) unless defined fileno $dest ;
2203 ## Turn on autoflush, mostly just to flush out
2205 my $old_fh = select( $dest ) ; $| = 1 ; select( $old_fh ) ;
2206 $op->{TFD} = fileno $dest ;
2208 'kid to write ', $op->{KFD}, ' to handle ', $op->{TFD}
2209 ) if _debugging_details ;
2211 elsif ( isa( $dest, 'SCALAR' ) ) {
2213 "kid ", $kid->{NUM}, " to write $op->{KFD} to SCALAR"
2214 ) if _debugging_details ;
2216 $op->open_pipe( $self->_debug_fd ) ;
2217 push @close_on_fail, $op->{FD}, $op->{TFD} ;
2218 $$dest = '' if $op->{TRUNC} ;
2220 elsif ( isa( $dest, 'CODE' ) ) {
2222 "kid $kid->{NUM} to write $op->{KFD} to CODE"
2223 ) if _debugging_details ;
2225 $op->open_pipe( $self->_debug_fd ) ;
2226 push @close_on_fail, $op->{FD}, $op->{TFD} ;
2232 . "' not allowed as a sink for output redirection"
2235 $output_fds_accum[$op->{KFD}] = $op ;
2236 $op->_init_filters ;
2239 elsif ( $op->{TYPE} eq '>pipe' ) {
2240 ## N> output redirection to a pipe we open, but don't select()
2243 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2244 ' to a pipe IPC::Run opens and returns'
2245 ) if _debugging_details ;
2247 my ( $r, $w ) = $op->open_pipe( $self->_debug_fd, $op->{DEST} ) ;
2248 _debug "caller will read from ", fileno $op->{DEST}
2249 if _debugging_details ;
2252 $op->{FD} = undef ; # we don't manage this fd
2253 $op->_init_filters ;
2255 $output_fds_accum[$op->{KFD}] = $op ;
2257 elsif ( $op->{TYPE} eq '>pty>' ) {
2258 my $dest = $op->{DEST} ;
2259 if ( isa( $dest, 'SCALAR' ) ) {
2261 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2262 " to SCALAR via pty '", $op->{PTY_ID}, "'"
2263 ) if _debugging_details ;
2265 $$dest = '' if $op->{TRUNC} ;
2267 elsif ( isa( $dest, 'CODE' ) ) {
2269 "kid ", $kid->{NUM}, " to write ", $op->{KFD},
2270 " to CODE via pty '", $op->{PTY_ID}, "'"
2271 ) if _debugging_details ;
2277 . "' not allowed as a sink for output redirection"
2281 $op->{FD} = $self->{PTYS}->{$op->{PTY_ID}}->fileno ;
2282 $op->{TFD} = undef ; # The fd isn't known until after fork().
2283 $output_fds_accum[$op->{KFD}] = $op ;
2284 $op->_init_filters ;
2286 elsif ( $op->{TYPE} eq '|' ) {
2288 "pipelining $kid->{NUM} and "
2289 . ( $kid->{NUM} + 1 )
2290 ) if _debugging_details ;
2291 ( $pipe_read_fd, $op->{TFD} ) = _pipe ;
2293 _dont_inherit( $pipe_read_fd ) ;
2294 _dont_inherit( $op->{TFD} ) ;
2296 @output_fds_accum = () ;
2298 elsif ( $op->{TYPE} eq '&' ) {
2299 @output_fds_accum = () ;
2300 } # end if $op->{TYPE} tree
2305 _debug 'caught ', $@ if _debugging;
2311 for ( @close_on_fail ) {
2315 for ( keys %{$self->{PTYS}} ) {
2316 next unless $self->{PTYS}->{$_} ;
2317 close $self->{PTYS}->{$_} ;
2318 $self->{PTYS}->{$_} = undef ;
2320 die join( '', @errs )
2323 ## give all but the last child all of the output file descriptors
2324 ## These will be reopened (and thus rendered useless) if the child
2325 ## dup2s on to these descriptors, since we unshift these. This way
2326 ## each process emits output to the same file descriptors that the
2327 ## last child will write to. This is probably not quite correct,
2328 ## since each child should write to the file descriptors inherited
2330 ## TODO: fix the inheritance of output file descriptors.
2331 ## NOTE: This sharing of OPS among kids means that we can't easily put
2332 ## a kid number in each OPS structure to ping the kid when all ops
2333 ## have closed (when $self->{PIPES} has emptied). This means that we
2334 ## need to scan the KIDS whenever @{$self->{PIPES}} is empty to see
2335 ## if there any of them are still alive.
2336 for ( my $num = 0 ; $num < $#{$self->{KIDS}} ; ++$num ) {
2337 for ( reverse @output_fds_accum ) {
2338 next unless defined $_ ;
2340 'kid ', $self->{KIDS}->[$num]->{NUM}, ' also to write ', $_->{KFD},
2341 ' to ', ref $_->{DEST}
2342 ) if _debugging_details ;
2343 unshift @{$self->{KIDS}->[$num]->{OPS}}, $_ ;
2347 ## Open the debug pipe if we need it
2348 ## Create the list of PIPES we need to scan and the bit vectors needed by
2349 ## select(). Do this first so that _cleanup can _clobber() them if an
2350 ## exception occurs.
2351 @{$self->{PIPES}} = () ;
2355 ## PIN is a vec()tor that indicates who's paused.
2357 for my $kid ( @{$self->{KIDS}} ) {
2358 for ( @{$kid->{OPS}} ) {
2359 if ( defined $_->{FD} ) {
2361 'kid ', $kid->{NUM}, '[', $kid->{PID}, "]'s ", $_->{KFD},
2363 ) if _debugging_details ;
2364 vec( $self->{ $_->{TYPE} =~ /^</ ? 'WIN' : 'RIN' }, $_->{FD}, 1 ) = 1 ;
2365 # vec( $self->{EIN}, $_->{FD}, 1 ) = 1 ;
2366 push @{$self->{PIPES}}, $_ ;
2371 for my $io ( @{$self->{IOS}} ) {
2372 my $fd = $io->fileno ;
2373 vec( $self->{RIN}, $fd, 1 ) = 1 if $io->mode =~ /r/ ;
2374 vec( $self->{WIN}, $fd, 1 ) = 1 if $io->mode =~ /w/ ;
2375 # vec( $self->{EIN}, $fd, 1 ) = 1 ;
2376 push @{$self->{PIPES}}, $io ;
2379 ## Put filters on the end of the filter chains to read & write the pipes.
2380 ## Clear pipe states
2381 for my $pipe ( @{$self->{PIPES}} ) {
2382 $pipe->{SOURCE_EMPTY} = 0 ;
2383 $pipe->{PAUSED} = 0 ;
2384 if ( $pipe->{TYPE} =~ /^>/ ) {
2385 my $pipe_reader = sub {
2386 my ( undef, $out_ref ) = @_ ;
2388 return undef unless defined $pipe->{FD} ;
2389 return 0 unless vec( $self->{ROUT}, $pipe->{FD}, 1 ) ;
2391 vec( $self->{ROUT}, $pipe->{FD}, 1 ) = 0 ;
2393 _debug_desc_fd( 'reading from', $pipe ) if _debugging_details ;
2394 my $in = eval { _read( $pipe->{FD} ) } ;
2397 ## IO::Pty throws the Input/output error if the kid dies.
2398 ## read() throws the bad file descriptor message if the
2399 ## kid dies on Win32.
2401 $@ =~ /^Input\/output error: read/ ||
2402 ($@ =~ /input or output/ && $^O =~ /aix/)
2403 || ( Win32_MODE && $@ =~ /Bad file descriptor/ ) ;
2406 unless ( length $in ) {
2407 $self->_clobber( $pipe ) ;
2411 ## Protect the position so /.../g matches may be used.
2412 my $pos = pos $$out_ref ;
2414 pos( $$out_ref ) = $pos ;
2417 ## Input filters are the last filters
2418 push @{$pipe->{FILTERS}}, $pipe_reader ;
2419 push @{$self->{TEMP_FILTERS}}, $pipe_reader ;
2422 my $pipe_writer = sub {
2423 my ( $in_ref, $out_ref ) = @_ ;
2424 return undef unless defined $pipe->{FD} ;
2426 unless vec( $self->{WOUT}, $pipe->{FD}, 1 )
2427 || $pipe->{PAUSED} ;
2429 vec( $self->{WOUT}, $pipe->{FD}, 1 ) = 0 ;
2431 if ( ! length $$in_ref ) {
2432 if ( ! defined get_more_input ) {
2433 $self->_clobber( $pipe ) ;
2438 unless ( length $$in_ref ) {
2439 unless ( $pipe->{PAUSED} ) {
2440 _debug_desc_fd( 'pausing', $pipe ) if _debugging_details ;
2441 vec( $self->{WIN}, $pipe->{FD}, 1 ) = 0 ;
2442 # vec( $self->{EIN}, $pipe->{FD}, 1 ) = 0 ;
2443 vec( $self->{PIN}, $pipe->{FD}, 1 ) = 1 ;
2444 $pipe->{PAUSED} = 1 ;
2448 _debug_desc_fd( 'writing to', $pipe ) if _debugging_details ;
2450 my $c = _write( $pipe->{FD}, $$in_ref ) ;
2451 substr( $$in_ref, 0, $c, '' ) ;
2454 ## Output filters are the first filters
2455 unshift @{$pipe->{FILTERS}}, $pipe_writer ;
2456 push @{$self->{TEMP_FILTERS}}, $pipe_writer ;
2463 ## A METHOD, NOT A FUNCTION, NEEDS $self!
2464 my IPC::Run $self = shift ;
2465 my ( $files, $fd1, $fd2 ) = @_ ;
2466 ## Moves TFDs that are using the destination fd out of the
2467 ## way before calling _dup2
2469 next unless defined $_->{TFD} ;
2470 $_->{TFD} = _dup( $_->{TFD} ) if $_->{TFD} == $fd2 ;
2472 $self->{DEBUG_FD} = _dup $self->{DEBUG_FD}
2473 if defined $self->{DEBUG_FD} && $self->{DEBUG_FD} == $fd2 ;
2475 _dup2_rudely( $fd1, $fd2 ) ;
2478 =item close_terminal
2480 This is used as (or in) an init sub to cast off the bonds of a controlling
2481 terminal. It must precede all other redirection ops that affect
2482 STDIN, STDOUT, or STDERR to be guaranteed effective.
2487 sub close_terminal {
2488 ## Cast of the bonds of a controlling terminal
2490 POSIX::setsid() || croak "POSIX::setsid() failed" ;
2491 _debug "closing stdin, out, err"
2492 if _debugging_details ;
2499 sub _do_kid_and_exit {
2500 my IPC::Run $self = shift ;
2503 ## For unknown reasons, placing these two statements in the eval{}
2504 ## causes the eval {} to not catch errors after they are executed in
2505 ## perl 5.6.0, godforsaken version that it is...not sure about 5.6.1.
2506 ## Part of this could be that these symbols get destructed when
2507 ## exiting the eval, and that destruction might be what's (wrongly)
2508 ## confusing the eval{}, allowing the exception to probpogate.
2513 local $cur_self = $self ;
2515 _set_child_debug_name( ref $kid->{VAL} eq "CODE"
2517 : basename( $kid->{VAL}->[0] )
2520 ## close parent FD's first so they're out of the way.
2521 ## Don't close STDIN, STDOUT, STDERR: they should be inherited or
2522 ## overwritten below.
2523 my @needed = $self->{noinherit} ? () : ( 1, 1, 1 ) ;
2524 $needed[ $self->{SYNC_WRITER_FD} ] = 1 ;
2525 $needed[ $self->{DEBUG_FD} ] = 1 if defined $self->{DEBUG_FD} ;
2527 for ( @{$kid->{OPS}} ) {
2528 $needed[ $_->{TFD} ] = 1 if defined $_->{TFD} ;
2531 ## TODO: use the forthcoming IO::Pty to close the terminal and
2532 ## make the first pty for this child the controlling terminal.
2533 ## This will also make it so that pty-laden kids don't cause
2534 ## other kids to lose stdin/stdout/stderr.
2536 if ( %{$self->{PTYS}} ) {
2537 ## Clean up the parent's fds.
2538 for ( keys %{$self->{PTYS}} ) {
2539 _debug "Cleaning up parent's ptty '$_'" if _debugging_details ;
2540 my $slave = $self->{PTYS}->{$_}->slave ;
2541 $closed[ $self->{PTYS}->{$_}->fileno ] = 1 ;
2542 close $self->{PTYS}->{$_} ;
2543 $self->{PTYS}->{$_} = $slave ;
2547 $closed[ $_ ] = 1 for ( 0..2 ) ;
2550 for my $sibling ( @{$self->{KIDS}} ) {
2551 for ( @{$sibling->{OPS}} ) {
2552 if ( $_->{TYPE} =~ /^.pty.$/ ) {
2553 $_->{TFD} = $self->{PTYS}->{$_->{PTY_ID}}->fileno ;
2554 $needed[$_->{TFD}] = 1 ;
2557 # for ( $_->{FD}, ( $sibling != $kid ? $_->{TFD} : () ) ) {
2558 # if ( defined $_ && ! $closed[$_] && ! $needed[$_] ) {
2567 ## This is crude: we have no way of keeping track of browsing all open
2568 ## fds, so we scan to a fairly high fd.
2569 _debug "open fds: ", join " ", keys %fds if _debugging_details ;
2571 if ( ! $closed[$_] && ! $needed[$_] ) {
2577 ## Lazy closing is so the same fd (ie the same TFD value) can be dup2'ed on
2580 for ( @{$kid->{OPS}} ) {
2581 if ( defined $_->{TFD} ) {
2582 unless ( $_->{TFD} == $_->{KFD} ) {
2583 $self->_dup2_gently( $kid->{OPS}, $_->{TFD}, $_->{KFD} ) ;
2584 push @lazy_close, $_->{TFD} ;
2587 elsif ( $_->{TYPE} eq 'dup' ) {
2588 $self->_dup2_gently( $kid->{OPS}, $_->{KFD1}, $_->{KFD2} )
2589 unless $_->{KFD1} == $_->{KFD2} ;
2591 elsif ( $_->{TYPE} eq 'close' ) {
2593 if ( ! $closed[$_] ) {
2600 elsif ( $_->{TYPE} eq 'init' ) {
2605 for ( @lazy_close ) {
2606 unless ( $closed[$_] ) {
2612 if ( ref $kid->{VAL} ne 'CODE' ) {
2613 open $s1, ">&=$self->{SYNC_WRITER_FD}"
2614 or croak "$! setting filehandle to fd SYNC_WRITER_FD" ;
2615 fcntl $s1, F_SETFD, 1 ;
2617 if ( defined $self->{DEBUG_FD} ) {
2618 open $s2, ">&=$self->{DEBUG_FD}"
2619 or croak "$! setting filehandle to fd DEBUG_FD" ;
2620 fcntl $s2, F_SETFD, 1 ;
2623 my @cmd = ( $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] ) ;
2624 _debug 'execing ', join " ", map { /[\s"]/ ? "'$_'" : $_ } @cmd
2627 die "exec failed: simulating exec() failure"
2628 if $self->{_simulate_exec_failure} ;
2630 _exec $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] ;
2632 croak "exec failed: $!" ;
2636 _write $self->{SYNC_WRITER_FD}, $@ ;
2641 ## We must be executing code in the child, otherwise exec() would have
2642 ## prevented us from being here.
2643 _close $self->{SYNC_WRITER_FD} ;
2644 _debug 'calling fork()ed CODE ref' if _debugging;
2645 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD} ;
2646 ## TODO: Overload CORE::GLOBAL::exit...
2649 ## There are bugs in perl closures up to and including 5.6.1
2650 ## that may keep this next line from having any effect, and it
2651 ## won't have any effect if our caller has kept a copy of it, but
2652 ## this may cause the closure to be cleaned up. Maybe.
2653 $kid->{VAL} = undef ;
2655 ## Use POSIX::exit to avoid global destruction, since this might
2656 ## cause DESTROY() to be called on objects created in the parent
2657 ## and thus cause double cleanup. For instance, if DESTROY() unlinks
2658 ## a file in the child, we don't want the parent to suddenly miss
2667 \@cmd, \$in, \$out, ...,
2668 timeout( 30, name => "process timeout" ),
2669 $stall_timeout = timeout( 10, name => "stall timeout" ),
2672 $h = start \@cmd, '<', \$in, '|', \@cmd2, ... ;
2674 start() accepts a harness or harness specification and returns a harness
2675 after building all of the pipes and launching (via fork()/exec(), or, maybe
2676 someday, spawn()) all the child processes. It does not send or receive any
2677 data on the pipes, see pump() and finish() for that.
2679 You may call harness() and then pass it's result to start() if you like,
2680 but you only need to if it helps you structure or tune your application.
2681 If you do call harness(), you may skip start() and proceed directly to
2684 start() also starts all timers in the harness. See L<IPC::Run::Timer>
2685 for more information.
2687 start() flushes STDOUT and STDERR to help you avoid duplicate output.
2688 It has no way of asking Perl to flush all your open filehandles, so
2689 you are going to need to flush any others you have open. Sorry.
2691 Here's how if you don't want to alter the state of $| for your
2694 $ofh = select HANDLE ; $of = $| ; $| = 1 ; $| = $of ; select $ofh;
2696 If you don't mind leaving output unbuffered on HANDLE, you can do
2697 the slightly shorter
2699 $ofh = select HANDLE ; $| = 1 ; select $ofh;
2701 Or, you can use IO::Handle's flush() method:
2706 Perl needs the equivalent of C's fflush( (FILE *)NULL ).
2711 # $SIG{__DIE__} = sub { my $s = shift ; Carp::cluck $s ; die $s } ;
2713 if ( @_ && ref $_[-1] eq 'HASH' ) {
2715 require Data::Dumper ;
2716 carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper( $options ) ;
2720 if ( @_ == 1 && isa( $_[0], __PACKAGE__ ) ) {
2722 $self->{$_} = $options->{$_} for keys %$options ;
2725 $self = harness( @_, $options ? $options : () ) ;
2728 local $cur_self = $self ;
2730 $self->kill_kill if $self->{STATE} == _started ;
2732 _debug "** starting" if _debugging;
2734 $_->{RESULT} = undef for @{$self->{KIDS}} ;
2736 ## Assume we're not being called from &run. It will correct our
2737 ## assumption if need be. This affects whether &_select_loop clears
2738 ## input queues to '' when they're empty.
2739 $self->{clear_ins} = 1 ;
2741 IPC::Run::Win32Helper::optimize $self
2742 if Win32_MODE && $in_run;
2746 for ( @{$self->{TIMERS}} ) {
2747 eval { $_->start } ;
2750 _debug 'caught ', $@ if _debugging;
2754 eval { $self->_open_pipes } ;
2757 _debug 'caught ', $@ if _debugging;
2761 ## This is a bit of a hack, we should do it for all open filehandles.
2762 ## Since there's no way I know of to enumerate open filehandles, we
2763 ## autoflush STDOUT and STDERR. This is done so that the children don't
2764 ## inherit output buffers chock full o' redundant data. It's really
2765 ## confusing to track that down.
2766 { my $ofh = select STDOUT ; local $| = 1 ; select $ofh; }
2767 { my $ofh = select STDERR ; local $| = 1 ; select $ofh; }
2768 for my $kid ( @{$self->{KIDS}} ) {
2769 $kid->{RESULT} = undef ;
2771 ref( $kid->{VAL} ) eq "CODE"
2775 join( " ", map /[^\w.-]/ ? "'$_'" : $_, @{$kid->{VAL}} ),
2777 ) if _debugging_details ;
2779 croak "simulated failure of fork"
2780 if $self->{_simulate_fork_failure} ;
2781 unless ( Win32_MODE ) {
2782 $self->_spawn( $kid ) ;
2785 ## TODO: Test and debug spawing code. Someday.
2792 ( $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] )
2796 ## The external kid wouldn't know what to do with it anyway.
2797 ## This is only used by the "helper" pump processes on Win32.
2798 _dont_inherit( $self->{DEBUG_FD} ) ;
2799 ( $kid->{PID}, $kid->{PROCESS} ) =
2800 IPC::Run::Win32Helper::win32_spawn(
2801 [ $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] ],
2804 _debug "spawn() = ", $kid->{PID} if _debugging;
2809 _debug 'caught ', $@ if _debugging;
2814 ## Close all those temporary filehandles that the kids needed.
2815 for my $pty ( values %{$self->{PTYS}} ) {
2820 for my $kid ( @{$self->{KIDS}} ) {
2821 for ( @{$kid->{OPS}} ) {
2822 my $close_it = eval {
2824 && ! $_->{DONT_CLOSE}
2825 && ! $closed[$_->{TFD}]
2826 && ( ! Win32_MODE || ! $_->{RECV_THROUGH_TEMP_FILE} ) ## Win32 hack
2830 _debug 'caught ', $@ if _debugging;
2832 if ( $close_it || $@ ) {
2834 _close( $_->{TFD} ) ;
2835 $closed[$_->{TFD}] = 1 ;
2840 _debug 'caught ', $@ if _debugging;
2845 confess "gak!" unless defined $self->{PIPES} ;
2848 eval { $self->_cleanup } ;
2850 die join( '', @errs ) ;
2853 $self->{STATE} = _started ;
2859 ## NOT FUNCTIONAL YET, NEED TO CLOSE FDS BETTER IN CHILDREN. SEE
2860 ## t/adopt.t for a test suite.
2861 my IPC::Run $self = shift ;
2863 for my $adoptee ( @_ ) {
2864 push @{$self->{IOS}}, @{$adoptee->{IOS}} ;
2865 ## NEED TO RENUMBER THE KIDS!!
2866 push @{$self->{KIDS}}, @{$adoptee->{KIDS}} ;
2867 push @{$self->{PIPES}}, @{$adoptee->{PIPES}} ;
2868 $self->{PTYS}->{$_} = $adoptee->{PTYS}->{$_}
2869 for keys %{$adoptee->{PYTS}} ;
2870 push @{$self->{TIMERS}}, @{$adoptee->{TIMERS}} ;
2871 $adoptee->{STATE} = _finished ;
2877 my IPC::Run $self = shift ;
2879 _debug_desc_fd( "closing", $file ) if _debugging_details ;
2880 my $doomed = $file->{FD} ;
2881 my $dir = $file->{TYPE} =~ /^</ ? 'WIN' : 'RIN' ;
2882 vec( $self->{$dir}, $doomed, 1 ) = 0 ;
2883 # vec( $self->{EIN}, $doomed, 1 ) = 0 ;
2884 vec( $self->{PIN}, $doomed, 1 ) = 0 ;
2885 if ( $file->{TYPE} =~ /^(.)pty.$/ ) {
2887 ## Only close output ptys. This is so that ptys as inputs are
2888 ## never autoclosed, which would risk losing data that was
2889 ## in the slave->parent queue.
2890 _debug_desc_fd "closing pty", $file if _debugging_details ;
2891 close $self->{PTYS}->{$file->{PTY_ID}}
2892 if defined $self->{PTYS}->{$file->{PTY_ID}} ;
2893 $self->{PTYS}->{$file->{PTY_ID}} = undef ;
2896 elsif ( isa( $file, 'IPC::Run::IO' ) ) {
2897 $file->close unless $file->{DONT_CLOSE} ;
2903 @{$self->{PIPES}} = grep
2904 defined $_->{FD} && ( $_->{TYPE} ne $file->{TYPE} || $_->{FD} ne $doomed),
2907 $file->{FD} = undef ;
2911 my IPC::Run $self = shift ;
2915 my $not_forever = 0.01 ;
2918 while ( $self->pumpable ) {
2919 if ( $io_occurred && $self->{break_on_io} ) {
2920 _debug "exiting _select(): io occured and break_on_io set"
2921 if _debugging_details ;
2925 my $timeout = $self->{non_blocking} ? 0 : undef ;
2927 if ( @{$self->{TIMERS}} ) {
2930 for ( @{$self->{TIMERS}} ) {
2931 next unless $_->is_running ;
2932 $time_left = $_->check( $now ) ;
2933 ## Return when a timer expires
2934 return if defined $time_left && ! $time_left ;
2935 $timeout = $time_left
2936 if ! defined $timeout || $time_left < $timeout ;
2941 ## See if we can unpause any input channels
2945 for my $file ( @{$self->{PIPES}} ) {
2946 next unless $file->{PAUSED} && $file->{TYPE} =~ /^</ ;
2948 _debug_desc_fd( "checking for more input", $file ) if _debugging_details ;
2950 1 while $did = $file->_do_filters( $self ) ;
2951 if ( defined $file->{FD} && ! defined( $did ) || $did ) {
2952 _debug_desc_fd( "unpausing", $file ) if _debugging_details ;
2953 $file->{PAUSED} = 0 ;
2954 vec( $self->{WIN}, $file->{FD}, 1 ) = 1 ;
2955 # vec( $self->{EIN}, $file->{FD}, 1 ) = 1 ;
2956 vec( $self->{PIN}, $file->{FD}, 1 ) = 0 ;
2959 ## This gets incremented occasionally when the IO channel
2960 ## was actually closed. That's a bug, but it seems mostly
2961 ## harmless: it causes us to exit if break_on_io, or to set
2962 ## the timeout to not be forever. I need to fix it, though.
2967 if ( _debugging_details ) {
2972 $out = 'r' if vec( $self->{RIN}, $_, 1 ) ;
2973 $out = $out ? 'b' : 'w' if vec( $self->{WIN}, $_, 1 ) ;
2974 $out = 'p' if ! $out && vec( $self->{PIN}, $_, 1 ) ;
2975 $out = $out ? uc( $out ) : 'x' if vec( $self->{EIN}, $_, 1 ) ;
2976 $out = '-' unless $out ;
2980 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/ ;
2981 _debug 'fds for select: ', $map if _debugging_details ;
2984 ## _do_filters may have closed our last fd, and we need to see if
2985 ## we have I/O, or are just waiting for children to exit.
2986 my $p = $self->pumpable;
2988 if ( $p > 0 && ( ! defined $timeout || $timeout > 0.1 ) ) {
2989 ## No I/O will wake the select loop up, but we have children
2990 ## lingering, so we need to poll them with a short timeout.
2991 ## Otherwise, assume more input will be coming.
2992 $timeout = $not_forever ;
2994 $not_forever = 0.5 if $not_forever >= 0.5 ;
2997 ## Make sure we don't block forever in select() because inputs are
2999 if ( ! defined $timeout && ! ( @{$self->{PIPES}} - $paused ) ) {
3000 ## Need to return if we're in pump and all input is paused, or
3001 ## we'll loop until all inputs are unpaused, which is darn near
3002 ## forever. And a day.
3003 if ( $self->{break_on_io} ) {
3004 _debug "exiting _select(): no I/O to do and timeout=forever"
3009 ## Otherwise, assume more input will be coming.
3010 $timeout = $not_forever ;
3012 $not_forever = 0.5 if $not_forever >= 0.5 ;
3015 _debug 'timeout=', defined $timeout ? $timeout : 'forever'
3016 if _debugging_details ;
3019 unless ( Win32_MODE ) {
3021 $self->{ROUT} = $self->{RIN},
3022 $self->{WOUT} = $self->{WIN},
3023 $self->{EOUT} = $self->{EIN},
3028 my @in = map $self->{$_}, qw( RIN WIN EIN ) ;
3029 ## Win32's select() on Win32 seems to die if passed vectors of
3030 ## all 0's. Need to report this when I get back online.
3032 $_ = undef unless index( ( unpack "b*", $_ ), 1 ) >= 0 ;
3036 $self->{ROUT} = $in[0],
3037 $self->{WOUT} = $in[1],
3038 $self->{EOUT} = $in[2],
3042 for ( $self->{ROUT}, $self->{WOUT}, $self->{EOUT} ) {
3043 $_ = "" unless defined $_ ;
3046 last if ! $nfound && $self->{non_blocking} ;
3048 croak "$! in select" if $nfound < 0 and $! != POSIX::EINTR;
3049 ## TODO: Analyze the EINTR failure mode and see if this patch
3050 ## is adequate and optimal.
3051 ## TODO: Add an EINTR test to the test suite.
3053 if ( _debugging_details ) {
3058 $out = 'r' if vec( $self->{ROUT}, $_, 1 ) ;
3059 $out = $out ? 'b' : 'w' if vec( $self->{WOUT}, $_, 1 ) ;
3060 $out = $out ? uc( $out ) : 'x' if vec( $self->{EOUT}, $_, 1 ) ;
3061 $out = '-' unless $out ;
3065 $map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/ ;
3066 _debug "selected ", $map ;
3069 ## Need to copy since _clobber alters @{$self->{PIPES}}.
3070 ## TODO: Rethink _clobber(). Rethink $file->{PAUSED}, too.
3071 my @pipes = @{$self->{PIPES}} ;
3072 $io_occurred = $_->poll( $self ) ? 1 : $io_occurred for @pipes;
3074 # for my $pipe ( @pipes ) {
3075 # ## Pipes can be shared among kids. If another kid closes the
3076 # ## pipe, then it's {FD} will be undef. Also, on Win32, pipes can
3077 # ## be optimized to be files, in which case the FD is left undef
3078 # ## so we don't try to select() on it.
3079 # if ( $pipe->{TYPE} =~ /^>/
3080 # && defined $pipe->{FD}
3081 # && vec( $self->{ROUT}, $pipe->{FD}, 1 )
3083 # _debug_desc_fd( "filtering data from", $pipe ) if _debugging_details ;
3084 #confess "phooey" unless isa( $pipe, "IPC::Run::IO" ) ;
3085 # $io_occurred = 1 if $pipe->_do_filters( $self ) ;
3087 # next FILE unless defined $pipe->{FD} ;
3090 # ## On Win32, pipes to the child can be optimized to be files
3091 # ## and FD left undefined so we won't select on it.
3092 # if ( $pipe->{TYPE} =~ /^</
3093 # && defined $pipe->{FD}
3094 # && vec( $self->{WOUT}, $pipe->{FD}, 1 )
3096 # _debug_desc_fd( "filtering data to", $pipe ) if _debugging_details ;
3097 # $io_occurred = 1 if $pipe->_do_filters( $self ) ;
3099 # next FILE unless defined $pipe->{FD} ;
3102 # if ( defined $pipe->{FD} && vec( $self->{EOUT}, $pipe->{FD}, 1 ) ) {
3103 # ## BSD seems to sometimes raise the exceptional condition flag
3104 # ## when a pipe is closed before we read it's last data. This
3105 # ## causes spurious warnings and generally renders the exception
3106 # ## mechanism useless for our purposes. The exception
3107 # ## flag semantics are too variable (they're device driver
3108 # ## specific) for me to easily map to any automatic action like
3109 # ## warning or croaking (try running v0.42 if you don't beleive me
3111 # warn "Exception on descriptor $pipe->{FD}" ;
3121 my IPC::Run $self = shift ;
3122 _debug "cleaning up" if _debugging_details ;
3124 for ( values %{$self->{PTYS}} ) {
3125 next unless ref $_ ;
3127 _debug "closing slave fd ", fileno $_->slave if _debugging_data;
3130 carp $@ . " while closing ptys" if $@ ;
3132 _debug "closing master fd ", fileno $_ if _debugging_data;
3135 carp $@ . " closing ptys" if $@ ;
3138 _debug "cleaning up pipes" if _debugging_details ;
3139 ## _clobber modifies PIPES
3140 $self->_clobber( $self->{PIPES}->[0] ) while @{$self->{PIPES}} ;
3142 for my $kid ( @{$self->{KIDS}} ) {
3143 _debug "cleaning up kid ", $kid->{NUM} if _debugging_details ;
3144 if ( ! length $kid->{PID} ) {
3145 _debug 'never ran child ', $kid->{NUM}, ", can't reap"
3147 for my $op ( @{$kid->{OPS}} ) {
3148 _close( $op->{TFD} )
3149 if defined $op->{TFD} && ! defined $op->{TEMP_FILE_HANDLE};
3152 elsif ( ! defined $kid->{RESULT} ) {
3153 _debug 'reaping child ', $kid->{NUM}, ' (pid ', $kid->{PID}, ')'
3155 my $pid = waitpid $kid->{PID}, 0 ;
3156 $kid->{RESULT} = $? ;
3157 _debug 'reaped ', $pid, ', $?=', $kid->{RESULT}
3161 # if ( defined $kid->{DEBUG_FD} ) {
3163 # @{$kid->{OPS}} = grep
3164 # ! defined $_->{KFD} || $_->{KFD} != $kid->{DEBUG_FD},
3166 # $kid->{DEBUG_FD} = undef ;
3169 _debug "cleaning up filters" if _debugging_details ;
3170 for my $op ( @{$kid->{OPS}} ) {
3171 @{$op->{FILTERS}} = grep {
3173 ! grep $filter == $_, @{$self->{TEMP_FILTERS}} ;
3174 } @{$op->{FILTERS}} ;
3177 for my $op ( @{$kid->{OPS}} ) {
3178 $op->_cleanup( $self ) if UNIVERSAL::isa( $op, "IPC::Run::IO" );
3181 $self->{STATE} = _finished ;
3182 @{$self->{TEMP_FILTERS}} = () ;
3183 _debug "done cleaning up" if _debugging_details ;
3185 POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD} ;
3186 $self->{DEBUG_FD} = undef ;
3195 Pump accepts a single parameter harness. It blocks until it delivers some
3196 input or recieves some output. It returns TRUE if there is still input or
3197 output to be done, FALSE otherwise.
3199 pump() will automatically call start() if need be, so you may call harness()
3200 then proceed to pump() if that helps you structure your application.
3202 If pump() is called after all harnessed activities have completed, a "process
3203 ended prematurely" exception to be thrown. This allows for simple scripting
3204 of external applications without having to add lots of error handling code at
3205 each step of the script:
3207 $h = harness \@smbclient, \$in, \$out, $err ;
3210 $h->pump until $out =~ /^smb.*> \Z/m ;
3211 die "error cding to /foo:\n$out" if $out =~ "ERR" ;
3215 $h->pump until $out =~ /^smb.*> \Z/m ;
3216 die "error retrieving files:\n$out" if $out =~ "ERR" ;
3226 die "pump() takes only a a single harness as a parameter"
3227 unless @_ == 1 && isa( $_[0], __PACKAGE__ ) ;
3229 my IPC::Run $self = shift ;
3231 local $cur_self = $self ;
3237 $self->start if $self->{STATE} < _started ;
3238 croak "process ended prematurely" unless $self->pumpable ;
3240 $self->{auto_close_ins} = 0 ;
3241 $self->{break_on_io} = 1 ;
3242 $self->_select_loop ;
3243 return $self->pumpable ;
3247 # _debug $x if _debugging && $x ;
3248 # eval { $self->_cleanup } ;
3261 "pump() non-blocking", pumps if anything's ready to be pumped, returns
3262 immediately otherwise. This is useful if you're doing some long-running
3263 task in the foreground, but don't want to starve any child processes.
3268 my IPC::Run $self = shift ;
3270 $self->{non_blocking} = 1 ;
3271 my $r = eval { $self->pump } ;
3272 $self->{non_blocking} = 0 ;
3279 Returns TRUE if calling pump() won't throw an immediate "process ended
3280 prematurely" exception. This means that there are open I/O channels or
3281 active processes. May yield the parent processes' time slice for 0.01
3282 second if all pipes are to the child and all are paused. In this case
3283 we can't tell if the child is dead, so we yield the processor and
3284 then attempt to reap the child in a nonblocking way.
3288 ## Undocumented feature (don't depend on it outside this module):
3289 ## returns -1 if we have I/O channels open, or >0 if no I/O channels
3290 ## open, but we have kids running. This allows the select loop
3291 ## to poll for child exit.
3293 my IPC::Run $self = shift ;
3295 ## There's a catch-22 we can get in to if there is only one pipe left
3296 ## open to the child and it's paused (ie the SCALAR it's tied to
3297 ## is ''). It's paused, so we're not select()ing on it, so we don't
3298 ## check it to see if the child attached to it is alive and it stays
3299 ## in @{$self->{PIPES}} forever. So, if all pipes are paused, see if
3300 ## we can reap the child.
3301 return -1 if grep !$_->{PAUSED}, @{$self->{PIPES}};
3303 ## See if the child is dead.
3305 return 0 unless $self->_running_kids;
3307 ## If we reap_nb and it's not dead yet, yield to it to see if it
3310 ## A better solution would be to unpause all the pipes, but I tried that
3311 ## and it never errored on linux. Sigh.
3312 select undef, undef, undef, 0.0001;
3316 return 0 unless $self->_running_kids;
3318 return -1; ## There are pipes waiting
3323 my IPC::Run $self = shift ;
3325 defined $_->{PID} && ! defined $_->{RESULT},
3332 Attempts to reap child processes, but does not block.
3334 Does not currently take any parameters, one day it will allow specific
3335 children to be reaped.
3337 Only call this from a signal handler if your C<perl> is recent enough
3338 to have safe signal handling (5.6.1 did not, IIRC, but it was beign discussed
3339 on perl5-porters). Calling this (or doing any significant work) in a signal
3340 handler on older C<perl>s is asking for seg faults.
3344 my $still_runnings ;
3347 my IPC::Run $self = shift ;
3349 local $cur_self = $self ;
3351 ## No more pipes, look to see if all the kids yet live, reaping those
3352 ## that haven't. I'd use $SIG{CHLD}/$SIG{CLD}, but that's broken
3353 ## on older (SYSV) platforms and perhaps less portable than waitpid().
3354 ## This could be slow with a lot of kids, but that's rare and, well,
3355 ## a lot of kids is slow in the first place.
3356 ## Oh, and this keeps us from reaping other children the process
3357 ## may have spawned.
3358 for my $kid ( @{$self->{KIDS}} ) {
3360 next if ! defined $kid->{PROCESS} || defined $kid->{RESULT} ;
3361 unless ( $kid->{PROCESS}->Wait( 0 ) ) {
3362 _debug "kid $kid->{NUM} ($kid->{PID}) still running"
3363 if _debugging_details;
3367 _debug "kid $kid->{NUM} ($kid->{PID}) exited"
3370 $kid->{PROCESS}->GetExitCode( $kid->{RESULT} )
3371 or croak "$! while GetExitCode()ing for Win32 process" ;
3373 unless ( defined $kid->{RESULT} ) {
3374 $kid->{RESULT} = "0 but true" ;
3375 $? = $kid->{RESULT} = 0x0F ;
3378 $? = $kid->{RESULT} << 8 ;
3382 next if ! defined $kid->{PID} || defined $kid->{RESULT} ;
3383 my $pid = waitpid $kid->{PID}, POSIX::WNOHANG() ;
3385 _debug "$kid->{NUM} ($kid->{PID}) still running"
3386 if _debugging_details;
3391 _debug "No such process: $kid->{PID}\n" if _debugging ;
3392 $kid->{RESULT} = "unknown result, unknown PID" ;
3395 _debug "kid $kid->{NUM} ($kid->{PID}) exited"
3398 confess "waitpid returned the wrong PID: $pid instead of $kid->{PID}"
3399 unless $pid = $kid->{PID} ;
3400 _debug "$kid->{PID} returned $?\n" if _debugging ;
3401 $kid->{RESULT} = $? ;
3410 This must be called after the last start() or pump() call for a harness,
3411 or your system will accumulate defunct processes and you may "leak"
3414 finish() returns TRUE if all children returned 0 (and were not signaled and did
3415 not coredump, ie ! $?), and FALSE otherwise (this is like run(), and the
3416 opposite of system()).
3418 Once a harness has been finished, it may be run() or start()ed again,
3419 including by pump()s auto-start.
3421 If this throws an exception rather than a normal exit, the harness may
3422 be left in an unstable state, it's best to kill the harness to get rid
3423 of all the child processes, etc.
3425 Specifically, if a timeout expires in finish(), finish() will not
3426 kill all the children. Call C<<$h->kill_kill>> in this case if you care.
3427 This differs from the behavior of L</run>.
3433 my IPC::Run $self = shift ;
3434 my $options = @_ && ref $_[-1] eq 'HASH' ? pop : {} ;
3436 local $cur_self = $self ;
3438 _debug "** finishing" if _debugging;
3440 $self->{non_blocking} = 0 ;
3441 $self->{auto_close_ins} = 1 ;
3442 $self->{break_on_io} = 0 ;
3443 # We don't alter $self->{clear_ins}, start() and run() control it.
3445 while ( $self->pumpable ) {
3446 $self->_select_loop( $options ) ;
3450 return ! $self->full_result ;
3458 Returns the first non-zero result code (ie $? >> 8). See L</full_result> to
3459 get the $? value for a child process.
3461 To get the result of a particular child, do:
3463 $h->result( 0 ) ; # first child's $? >> 8
3464 $h->result( 1 ) ; # second child
3471 Returns undef if no child processes were spawned and no child number was
3472 specified. Throws an exception if an out-of-range child number is passed.
3476 sub _assert_finished {
3477 my IPC::Run $self = $_[0] ;
3479 croak "Harness not run" unless $self->{STATE} >= _finished ;
3480 croak "Harness not finished running" unless $self->{STATE} == _finished ;
3486 my IPC::Run $self = shift ;
3489 my ( $which ) = @_ ;
3492 scalar( @{$self->{KIDS}} ),
3493 " child processes, no process $which"
3495 unless $which >= 0 && $which <= $#{$self->{KIDS}} ;
3496 return $self->{KIDS}->[$which]->{RESULT} >> 8 ;
3499 return undef unless @{$self->{KIDS}} ;
3500 for ( @{$self->{KIDS}} ) {
3501 return $_->{RESULT} >> 8 if $_->{RESULT} >> 8 ;
3509 Returns a list of child exit values. See L</full_results> if you want to
3510 know if a signal killed the child.
3512 Throws an exception if the harness is not in a finished state.
3518 my IPC::Run $self = shift ;
3520 # we add 0 here to stop warnings associated with "unknown result, unknown PID"
3521 return map { (0+$_->{RESULT}) >> 8 } @{$self->{KIDS}} ;
3529 Returns the first non-zero $?. See L</result> to get the first $? >> 8
3530 value for a child process.
3532 To get the result of a particular child, do:
3534 $h->full_result( 0 ) ; # first child's $? >> 8
3535 $h->full_result( 1 ) ; # second child
3539 ($h->full_results)[0]
3540 ($h->full_results)[1]
3542 Returns undef if no child processes were spawned and no child number was
3543 specified. Throws an exception if an out-of-range child number is passed.
3548 goto &result if @_ > 1 ;
3551 my IPC::Run $self = shift ;
3553 return undef unless @{$self->{KIDS}} ;
3554 for ( @{$self->{KIDS}} ) {
3555 return $_->{RESULT} if $_->{RESULT} ;
3562 Returns a list of child exit values as returned by C<wait>. See L</results>
3563 if you don't care about coredumps or signals.
3565 Throws an exception if the harness is not in a finished state.
3571 my IPC::Run $self = shift ;
3573 croak "Harness not run" unless $self->{STATE} >= _finished ;
3574 croak "Harness not finished running" unless $self->{STATE} == _finished ;
3576 return map $_->{RESULT}, @{$self->{KIDS}} ;
3581 ## Filter Scaffolding
3584 '$filter_op', ## The op running a filter chain right now
3585 '$filter_num', ## Which filter is being run right now.
3589 ## A few filters and filter constructors
3596 These filters are used to modify input our output between a child
3597 process and a scalar or subroutine endpoint.
3603 run \@cmd, ">", binary, \$out ;
3604 run \@cmd, ">", binary, \$out ; ## Any TRUE value to enable
3605 run \@cmd, ">", binary 0, \$out ; ## Any FALSE value to disable
3607 This is a constructor for a "binmode" "filter" that tells IPC::Run to keep
3608 the carriage returns that would ordinarily be edited out for you (binmode
3609 is usually off). This is not a real filter, but an option masquerading as
3612 It's not named "binmode" because you're likely to want to call Perl's binmode
3613 in programs that are piping binary data around.
3618 my $enable = @_ ? shift : 1 ;
3619 return bless sub { $enable }, "IPC::Run::binmode_pseudo_filter" ;
3624 This breaks a stream of data in to chunks, based on an optional
3625 scalar or regular expression parameter. The default is the Perl
3626 input record separator in $/, which is a newline be default.
3628 run \@cmd, '>', new_chunker, \&lines_handler ;
3629 run \@cmd, '>', new_chunker( "\r\n" ), \&lines_handler ;
3631 Because this uses $/ by default, you should always pass in a parameter
3632 if you are worried about other code (modules, etc) modifying $/.
3634 If this filter is last in a filter chain that dumps in to a scalar,
3635 the scalar must be set to '' before a new chunk will be written to it.
3637 As an example of how a filter like this can be written, here's a
3638 chunker that splits on newlines:
3641 my ( $in_ref, $out_ref ) = @_ ;
3643 return 0 if length $$out_ref ;
3645 return input_avail && do {
3647 if ( $$in_ref =~ s/\A(.*?\n)// ) {
3651 my $hmm = get_more_input ;
3652 unless ( defined $hmm ) {
3653 $$out_ref = $$in_ref ;
3655 return length $$out_ref ? 1 : 0 ;
3657 return 0 if $hmm eq 0 ;
3664 sub new_chunker(;$) {
3666 $re = $/ if _empty $re ;
3667 $re = quotemeta( $re ) unless ref $re eq 'Regexp' ;
3668 $re = qr/\A(.*?$re)/s ;
3671 my ( $in_ref, $out_ref ) = @_ ;
3673 return 0 if length $$out_ref ;
3675 return input_avail && do {
3677 if ( $$in_ref =~ s/$re// ) {
3681 my $hmm = get_more_input ;
3682 unless ( defined $hmm ) {
3683 $$out_ref = $$in_ref ;
3685 return length $$out_ref ? 1 : 0 ;
3687 return 0 if $hmm eq 0 ;
3696 This appends a fixed string to each chunk of data read from the source
3697 scalar or sub. This might be useful if you're writing commands to a
3698 child process that always must end in a fixed string, like "\n":
3701 '<', new_appender( "\n" ), \&commands,
3704 Here's a typical filter sub that might be created by new_appender():
3706 sub newline_appender {
3707 my ( $in_ref, $out_ref ) = @_ ;
3709 return input_avail && do {
3710 $$out_ref = join( '', $$out_ref, $$in_ref, "\n" ) ;
3718 sub new_appender($) {
3719 my ( $suffix ) = @_ ;
3720 croak "\$suffix undefined" unless defined $suffix ;
3723 my ( $in_ref, $out_ref ) = @_ ;
3725 return input_avail && do {
3726 $$out_ref = join( '', $$out_ref, $$in_ref, $suffix ) ;
3734 sub new_string_source {
3743 return ref $ref eq 'SCALAR'
3745 my ( $in_ref, $out_ref ) = @_ ;
3747 return defined $$ref
3749 $$out_ref .= $$ref ;
3750 my $r = length $$ref ? 1 : 0 ;
3757 my ( $in_ref, $out_ref ) = @_ ;
3761 my $s = shift @$ref ;
3770 sub new_string_sink {
3771 my ( $string_ref ) = @_ ;
3774 my ( $in_ref, $out_ref ) = @_ ;
3776 return input_avail && do {
3777 $$string_ref .= $$in_ref ;
3787 #This function defines a time interval, starting from when start() is
3788 #called, or when timeout() is called. If all processes have not finished
3789 #by the end of the timeout period, then a "process timed out" exception
3792 #The time interval may be passed in seconds, or as an end time in
3793 #"HH:MM:SS" format (any non-digit other than '.' may be used as
3794 #spacing and puctuation). This is probably best shown by example:
3796 # $h->timeout( $val ) ;
3799 # ======================== =====================================
3800 # undef Timeout timer disabled
3801 # '' Almost immediate timeout
3802 # 0 Almost immediate timeout
3803 # 0.000001 timeout > 0.0000001 seconds
3804 # 30 timeout > 30 seconds
3805 # 30.0000001 timeout > 30 seconds
3806 # 10:30 timeout > 10 minutes, 30 seconds
3808 #Timeouts are currently evaluated with a 1 second resolution, though
3809 #this may change in the future. This means that setting
3810 #timeout($h,1) will cause a pokey child to be aborted sometime after
3811 #one second has elapsed and typically before two seconds have elapsed.
3813 #This sub does not check whether or not the timeout has expired already.
3815 #Returns the number of seconds set as the timeout (this does not change
3816 #as time passes, unless you call timeout( val ) again).
3818 #The timeout does not include the time needed to fork() or spawn()
3819 #the child processes, though some setup time for the child processes can
3820 #included. It also does not include the length of time it takes for
3821 #the children to exit after they've closed all their pipes to the
3827 # my IPC::Run $self = shift ;
3830 # ( $self->{TIMEOUT} ) = @_ ;
3831 # $self->{TIMEOUT_END} = undef ;
3832 # if ( defined $self->{TIMEOUT} ) {
3833 # if ( $self->{TIMEOUT} =~ /[^\d.]/ ) {
3834 # my @f = split( /[^\d\.]+/i, $self->{TIMEOUT} ) ;
3835 # unshift @f, 0 while @f < 3 ;
3836 # $self->{TIMEOUT} = (($f[0]*60)+$f[1])*60+$f[2] ;
3838 # elsif ( $self->{TIMEOUT} =~ /^(\d*)(?:\.(\d*))/ ) {
3839 # $self->{TIMEOUT} = $1 + 1 ;
3841 # $self->_calc_timeout_end if $self->{STATE} >= _started ;
3844 # return $self->{TIMEOUT} ;
3848 #sub _calc_timeout_end {
3849 # my IPC::Run $self = shift ;
3851 # $self->{TIMEOUT_END} = defined $self->{TIMEOUT}
3852 # ? time + $self->{TIMEOUT}
3855 # ## We add a second because we might be at the very end of the current
3856 # ## second, and we want to guarantee that we don't have a timeout even
3857 # ## one second less then the timeout period.
3858 # ++$self->{TIMEOUT_END} if $self->{TIMEOUT} ;
3863 Takes a filename or filehandle, a redirection operator, optional filters,
3864 and a source or destination (depends on the redirection operator). Returns
3865 an IPC::Run::IO object suitable for harness()ing (including via start()
3868 This is shorthand for
3871 require IPC::Run::IO ;
3873 ... IPC::Run::IO->new(...) ...
3878 require IPC::Run::IO ;
3879 IPC::Run::IO->new( @_ ) ;
3884 $h = start( \@cmd, \$in, \$out, $t = timer( 5 ) ) ;
3886 pump $h until $out =~ /expected stuff/ || $t->is_expired ;
3888 Instantiates a non-fatal timer. pump() returns once each time a timer
3889 expires. Has no direct effect on run(), but you can pass a subroutine
3890 to fire when the timer expires.
3892 See L</timeout> for building timers that throw exceptions on
3895 See L<IPC::Run::Timer/timer> for details.
3899 # Doing the prototype suppresses 'only used once' on older perls.
3901 *timer = \&IPC::Run::Timer::timer ;
3906 $h = start( \@cmd, \$in, \$out, $t = timeout( 5 ) ) ;
3908 pump $h until $out =~ /expected stuff/ ;
3910 Instantiates a timer that throws an exception when it expires.
3911 If you don't provide an exception, a default exception that matches
3912 /^IPC::Run: .*timed out/ is thrown by default. You can pass in your own
3913 exception scalar or reference:
3917 $t = timeout( 5, exception => 'slowpoke' ),
3920 or set the name used in debugging message and in the default exception
3925 timeout( 50, name => 'process timer' ),
3926 $stall_timer = timeout( 5, name => 'stall timer' ),
3929 pump $h until $out =~ /started/ ;
3932 $stall_timer->start ;
3933 pump $h until $out =~ /command 1 finished/ ;
3936 $stall_timer->start ;
3937 pump $h until $out =~ /command 2 finished/ ;
3939 $in = 'very slow command 3' ;
3940 $stall_timer->start( 10 ) ;
3941 pump $h until $out =~ /command 3 finished/ ;
3943 $stall_timer->start( 5 ) ;
3945 pump $h until $out =~ /command 4 finished/ ;
3947 $stall_timer->reset; # Prevent restarting or expirng
3950 See L</timer> for building non-fatal timers.
3952 See L<IPC::Run::Timer/timer> for details.
3956 # Doing the prototype suppresses 'only used once' on older perls.
3958 *timeout = \&IPC::Run::Timer::timeout ;
3963 =head1 FILTER IMPLEMENTATION FUNCTIONS
3965 These functions are for use from within filters.
3971 Returns TRUE if input is available. If none is available, then
3972 &get_more_input is called and its result is returned.
3974 This is usually used in preference to &get_more_input so that the
3975 calling filter removes all data from the $in_ref before more data
3976 gets read in to $in_ref.
3978 C<input_avail> is usually used as part of a return expression:
3980 return input_avail && do {
3981 ## process the input just gotten
3985 This technique allows input_avail to return the undef or 0 that a
3986 filter normally returns when there's no input to process. If a filter
3987 stores intermediate values, however, it will need to react to an
3990 my $got = input_avail ;
3991 if ( ! defined $got ) {
3992 ## No more input ever, flush internal buffers to $out_ref
3994 return $got unless $got ;
3995 ## Got some input, move as much as need be
3996 return 1 if $added_to_out_ref ;
4001 confess "Undefined FBUF ref for $filter_num+1"
4002 unless defined $filter_op->{FBUFS}->[$filter_num+1] ;
4003 length ${$filter_op->{FBUFS}->[$filter_num+1]} || get_more_input ;
4007 =item get_more_input
4009 This is used to fetch more input in to the input variable. It returns
4010 undef if there will never be any more input, 0 if there is none now,
4011 but there might be in the future, and TRUE if more input was gotten.
4013 C<get_more_input> is usually used as part of a return expression,
4014 see L</input_avail> for more information.
4019 ## Filter implementation interface
4021 sub get_more_input() {
4024 confess "get_more_input() called and no more filters in chain"
4025 unless defined $filter_op->{FILTERS}->[$filter_num] ;
4026 $filter_op->{FILTERS}->[$filter_num]->(
4027 $filter_op->{FBUFS}->[$filter_num+1],
4028 $filter_op->{FBUFS}->[$filter_num],
4029 ) ; # if defined ${$filter_op->{FBUFS}->[$filter_num+1]} ;
4037 ## This is not needed by most users. Should really move to IPC::Run::TestUtils
4040 # my @tests = filter_tests( "foo", "in", "out", \&filter ) ;
4041 # $_->() for ( @tests ) ;
4043 #This creates a list of test subs that can be used to test most filters
4044 #for basic functionality. The first parameter is the name of the
4045 #filter to be tested, the second is sample input, the third is the
4046 #test(s) to apply to the output(s), and the rest of the parameters are
4047 #the filters to be linked and tested.
4049 #If the filter chain is to be fed multiple inputs in sequence, the second
4050 #parameter should be a reference to an array of thos inputs:
4052 # my @tests = filter_tests( "foo", [qw(1 2 3)], "123", \&filter ) ;
4054 #If the filter chain should produce a sequence of outputs, then the
4055 #thrid parameter should be a reference to an array of those outputs:
4057 # my @tests = filter_tests(
4060 # [ qr/^1$/, qr/^2$/ ],
4064 #See t/run.t and t/filter.t for an example of this in practice.
4069 ## Filter testing routines
4071 sub filter_tests($;@) {
4072 my ( $name, $in, $exp, @filters ) = @_ ;
4074 my @in = ref $in eq 'ARRAY' ? @$in : ( $in ) ;
4075 my @exp = ref $exp eq 'ARRAY' ? @$exp : ( $exp ) ;
4080 my IPC::Run::IO $op ;
4092 $op = IPC::Run::IO->_new_internal( '<', 0, 0, 0, undef,
4093 new_string_sink( \$output ),
4095 new_string_source( \@input ),
4097 $op->_init_filters ;
4101 ! defined $op->_do_filters( $h ),
4103 "$name didn't pass undef (EOF) through"
4107 ## See if correctly does nothing on 0, (please try again)
4109 $op->_init_filters ;
4113 $op->_do_filters( $h ),
4115 "$name didn't return 0 (please try again) when given a 0"
4122 $op->_do_filters( $h ),
4124 "$name didn't return 0 (please try again) when given a second 0"
4130 last unless defined $op->_do_filters( $h ) ;
4133 ! defined $op->_do_filters( $h ),
4135 "$name didn't return undef (EOF) after two 0s and an undef"
4139 ## See if it can take @in and make @out
4141 $op->_init_filters ;
4144 while ( defined $op->_do_filters( $h ) && @input ) {
4145 if ( length $output ) {
4146 push @out, $output ;
4150 if ( length $output ) {
4151 push @out, $output ;
4157 "$name didn't consume it's input"
4163 last unless defined $op->_do_filters( $h ) ;
4164 if ( length $output ) {
4165 push @out, $output ;
4170 ! defined $op->_do_filters( $h ),
4172 "$name didn't return undef (EOF), tried 100 times"
4178 join( ', ', map "'$_'", @out ),
4179 join( ', ', map "'$_'", @exp ),
4185 ## Force the harness to be cleaned up.
4197 These will be addressed as needed and as time allows.
4201 Expose a list of child process objects. When I do this,
4202 each child process is likely to be blessed into IPC::Run::Proc.
4204 $kid->abort(), $kid->kill(), $kid->signal( $num_or_name ).
4206 Write tests for /(full_)?results?/ subs.
4208 Currently, pump() and run() only work on systems where select() works on the
4209 filehandles returned by pipe(). This does *not* include ActiveState on Win32,
4210 although it does work on cygwin under Win32 (thought the tests whine a bit).
4211 I'd like to rectify that, suggestions and patches welcome.
4213 Likewise start() only fully works on fork()/exec() machines (well, just
4214 fork() if you only ever pass perl subs as subprocesses). There's
4215 some scaffolding for calling Open3::spawn_with_handles(), but that's
4216 untested, and not that useful with limited select().
4218 Support for C<\@sub_cmd> as an argument to a command which
4219 gets replaced with /dev/fd or the name of a temporary file containing foo's
4220 output. This is like <(sub_cmd ...) found in bash and csh (IIRC).
4222 Allow multiple harnesses to be combined as independant sets of processes
4223 in to one 'meta-harness'.
4225 Allow a harness to be passed in place of an \@cmd. This would allow
4226 multiple harnesses to be aggregated.
4228 Ability to add external file descriptors w/ filter chains and endpoints.
4230 Ability to add timeouts and timing generators (i.e. repeating timeouts).
4232 High resolution timeouts.
4234 =head1 Win32 LIMITATIONS
4238 =item Fails on Win9X
4240 If you want Win9X support, you'll have to debug it or fund me because I
4241 don't use that system any more. The Win32 subsysem has been extended to
4242 use temporary files in simple run() invocations and these may actually
4243 work on Win9X too, but I don't have time to work on it.
4245 =item May deadlock on Win2K (but not WinNT4 or WinXPPro)
4247 Spawning more than one subprocess on Win2K causes a deadlock I haven't
4248 figured out yet, but simple uses of run() often work. Passes all tests
4249 on WinXPPro and WinNT.
4251 =item no support yet for <pty< and >pty>
4253 These are likely to be implemented as "<" and ">" with binmode on, not
4256 =item no support for file descriptors higher than 2 (stderr)
4258 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
4259 get the integer handle and pass it to the child process using the command
4260 line, environment, stdin, intermediary file, or other IPC mechnism. Then
4261 use that handle in the child (Win32API.pm provides ways to reconstitute
4262 Perl file handles from Win32 file handles).
4264 =item no support for subroutine subprocesses (CODE refs)
4266 Can't fork(), so the subroutines would have no context, and closures certainly
4269 Perhaps with Win32 fork() emulation, this can be supported in a limited
4270 fashion, but there are other very serious problems with that: all parent
4271 fds get dup()ed in to the thread emulating the forked process, and that
4272 keeps the parent from being able to close all of the appropriate fds.
4274 =item no support for init => sub {} routines.
4276 Win32 processes are created from scratch, there is no way to do an init
4277 routine that will affect the running child. Some limited support might
4278 be implemented one day, do chdir() and %ENV changes can be made.
4282 Win32 does not fully support signals. signal() is likely to cause errors
4283 unless sending a signal that Perl emulates, and C<kill_kill()> is immediately
4284 fatal (there is no grace period).
4286 =item helper processes
4288 IPC::Run uses helper processes, one per redirected file, to adapt between the
4289 anonymous pipe connected to the child and the TCP socket connected to the
4290 parent. This is a waste of resources and will change in the future to either
4291 use threads (instead of helper processes) or a WaitForMultipleObjects call
4292 (instead of select). Please contact me if you can help with the
4293 WaitForMultipleObjects() approach; I haven't figured out how to get at it
4296 =item shutdown pause
4298 There seems to be a pause of up to 1 second between when a child program exits
4299 and the corresponding sockets indicate that they are closed in the parent.
4304 binmode is not supported yet. The underpinnings are implemented, just ask
4309 IPC::Run::IO objects can be used on Unix to read or write arbitrary files. On
4310 Win32, they will need to use the same helper processes to adapt from
4311 non-select()able filehandles to select()able ones (or perhaps
4312 WaitForMultipleObjects() will work with them, not sure).
4314 =item startup race conditions
4316 There seems to be an occasional race condition between child process startup
4317 and pipe closings. It seems like if the child is not fully created by the time
4318 CreateProcess returns and we close the TCP socket being handed to it, the
4319 parent socket can also get closed. This is seen with the Win32 pumper
4320 applications, not the "real" child process being spawned.
4322 I assume this is because the kernel hasn't gotten around to incrementing the
4323 reference count on the child's end (since the child was slow in starting), so
4324 the parent's closing of the child end causes the socket to be closed, thus
4325 closing the parent socket.
4327 Being a race condition, it's hard to reproduce, but I encountered it while
4328 testing this code on a drive share to a samba box. In this case, it takes
4329 t/run.t a long time to spawn it's chile processes (the parent hangs in the
4330 first select for several seconds until the child emits any debugging output).
4332 I have not seen it on local drives, and can't reproduce it at will,
4333 unfortunately. The symptom is a "bad file descriptor in select()" error, and,
4334 by turning on debugging, it's possible to see that select() is being called on
4335 a no longer open file descriptor that was returned from the _socket() routine
4336 in Win32Helper. There's a new confess() that checks for this ("PARENT_HANDLE
4337 no longer open"), but I haven't been able to reproduce it (typically).
4343 On Unix, requires a system that supports C<waitpid( $pid, WNOHANG )> so
4344 it can tell if a child process is still running.
4346 PTYs don't seem to be non-blocking on some versions of Solaris. Here's a
4347 test script contributed by Borislav Deianov <borislav@ensim.com> to see
4348 if you have the problem. If it dies, you have the problem.
4352 use IPC::Run qw(run);
4357 return ['perl', '-e',
4358 '<STDIN>, print "\n" x '.$_[0].'; while(<STDIN>){last if /end/}'];
4362 #fcntl(W, F_SETFL, O_NONBLOCK);
4363 #while (syswrite(W, "\n", 1)) { $pipebuf++ };
4364 #print "pipe buffer size is $pipebuf\n";
4366 my $in = "\n" x ($pipebuf * 2) . "end\n";
4369 $SIG{ALRM} = sub { die "Never completed!\n" } ;
4371 print "reading from scalar via pipe...";
4373 run(makecmd($pipebuf * 2), '<', \$in, '>', \$out);
4377 print "reading from code via pipe... ";
4379 run(makecmd($pipebuf * 3), '<', sub { $t = $in; undef $in; $t}, '>', \$out);
4383 $pty = IO::Pty->new();
4385 $slave = $pty->slave();
4386 while ($pty->syswrite("\n", 1)) { $ptybuf++ };
4387 print "pty buffer size is $ptybuf\n";
4388 $in = "\n" x ($ptybuf * 3) . "end\n";
4390 print "reading via pty... ";
4392 run(makecmd($ptybuf * 3), '<pty<', \$in, '>', \$out);
4396 No support for ';', '&&', '||', '{ ... }', etc: use perl's, since run()
4397 returns TRUE when the command exits with a 0 result code.
4399 Does not provide shell-like string interpolation.
4401 No support for C<cd>, C<setenv>, or C<export>: do these in an init() sub
4407 chdir $dir or die $! ;
4412 Timeout calculation does not allow absolute times, or specification of
4415 B<WARNING:> Function coprocesses (C<run \&foo, ...>) suffer from two
4416 limitations. The first is that it is difficult to close all filehandles the
4417 child inherits from the parent, since there is no way to scan all open
4418 FILEHANDLEs in Perl and it both painful and a bit dangerous to close all open
4419 file descriptors with C<POSIX::close()>. Painful because we can't tell which
4420 fds are open at the POSIX level, either, so we'd have to scan all possible fds
4421 and close any that we don't want open (normally C<exec()> closes any
4422 non-inheritable but we don't C<exec()> for &sub processes.
4424 The second problem is that Perl's DESTROY subs and other on-exit cleanup gets
4425 run in the child process. If objects are instantiated in the parent before the
4426 child is forked, the the DESTROY will get run once in the parent and once in
4427 the child. When coprocess subs exit, POSIX::exit is called to work around this,
4428 but it means that objects that are still referred to at that time are not
4429 cleaned up. So setting package vars or closure vars to point to objects that
4430 rely on DESTROY to affect things outside the process (files, etc), will
4433 I goofed on the syntax: "<pipe" vs. "<pty<" and ">filename" are both
4440 =item Allow one harness to "adopt" another:
4442 $new_h = harness \@cmd2 ;
4443 $h->adopt( $new_h ) ;
4445 =item Close all filehandles not explicitly marked to stay open.
4447 The problem with this one is that there's no good way to scan all open
4448 FILEHANDLEs in Perl, yet you don't want child processes inheriting handles
4455 Well, select() and waitpid() badly needed wrapping, and open3() isn't
4456 open-minded enough for me.
4458 The shell-like API inspired by a message Russ Allbery sent to perl5-porters,
4461 I've thought for some time that it would be
4462 nice to have a module that could handle full Bourne shell pipe syntax
4463 internally, with fork and exec, without ever invoking a shell. Something
4464 that you could give things like:
4466 pipeopen (PIPE, [ qw/cat file/ ], '|', [ 'analyze', @args ], '>&3');
4468 Message ylln51p2b6.fsf@windlord.stanford.edu, on 2000/02/04.
4472 Barrie Slaymaker <barries@slaysys.com>, with numerous suggestions by p5p.