4417 lines
144 KiB
Perl
4417 lines
144 KiB
Perl
package IPC::Run;
|
|
use bytes;
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
IPC::Run - system() and background procs w/ piping, redirs, ptys (Unix, Win32)
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
## First,a command to run:
|
|
my @cat = qw( cat );
|
|
|
|
## Using run() instead of system():
|
|
use IPC::Run qw( run timeout );
|
|
|
|
run \@cat, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?";
|
|
|
|
# Can do I/O to sub refs and filenames, too:
|
|
run \@cat, '<', "in.txt", \&out, \&err or die "cat: $?";
|
|
run \@cat, '<', "in.txt", '>>', "out.txt", '2>>', "err.txt";
|
|
|
|
|
|
# Redirecting using pseudo-terminals instead of pipes.
|
|
run \@cat, '<pty<', \$in, '>pty>', \$out_and_err;
|
|
|
|
## Scripting subprocesses (like Expect):
|
|
|
|
use IPC::Run qw( start pump finish timeout );
|
|
|
|
# Incrementally read from / write to scalars.
|
|
# $in is drained as it is fed to cat's stdin,
|
|
# $out accumulates cat's stdout
|
|
# $err accumulates cat's stderr
|
|
# $h is for "harness".
|
|
my $h = start \@cat, \$in, \$out, \$err, timeout( 10 );
|
|
|
|
$in .= "some input\n";
|
|
pump $h until $out =~ /input\n/g;
|
|
|
|
$in .= "some more input\n";
|
|
pump $h until $out =~ /\G.*more input\n/;
|
|
|
|
$in .= "some final input\n";
|
|
finish $h or die "cat returned $?";
|
|
|
|
warn $err if $err;
|
|
print $out; ## All of cat's output
|
|
|
|
# Piping between children
|
|
run \@cat, '|', \@gzip;
|
|
|
|
# Multiple children simultaneously (run() blocks until all
|
|
# children exit, use start() for background execution):
|
|
run \@foo1, '&', \@foo2;
|
|
|
|
# Calling \&set_up_child in the child before it executes the
|
|
# command (only works on systems with true fork() & exec())
|
|
# exceptions thrown in set_up_child() will be propagated back
|
|
# to the parent and thrown from run().
|
|
run \@cat, \$in, \$out,
|
|
init => \&set_up_child;
|
|
|
|
# Read from / write to file handles you open and close
|
|
open IN, '<in.txt' or die $!;
|
|
open OUT, '>out.txt' or die $!;
|
|
print OUT "preamble\n";
|
|
run \@cat, \*IN, \*OUT or die "cat returned $?";
|
|
print OUT "postamble\n";
|
|
close IN;
|
|
close OUT;
|
|
|
|
# Create pipes for you to read / write (like IPC::Open2 & 3).
|
|
$h = start
|
|
\@cat,
|
|
'<pipe', \*IN, # may also be a lexical filehandle e.g. \my $infh
|
|
'>pipe', \*OUT,
|
|
'2>pipe', \*ERR
|
|
or die "cat returned $?";
|
|
print IN "some input\n";
|
|
close IN;
|
|
print <OUT>, <ERR>;
|
|
finish $h;
|
|
|
|
# Mixing input and output modes
|
|
run \@cat, 'in.txt', \&catch_some_out, \*ERR_LOG;
|
|
|
|
# Other redirection constructs
|
|
run \@cat, '>&', \$out_and_err;
|
|
run \@cat, '2>&1';
|
|
run \@cat, '0<&3';
|
|
run \@cat, '<&-';
|
|
run \@cat, '3<', \$in3;
|
|
run \@cat, '4>', \$out4;
|
|
# etc.
|
|
|
|
# Passing options:
|
|
run \@cat, 'in.txt', debug => 1;
|
|
|
|
# Call this system's shell, returns TRUE on 0 exit code
|
|
# THIS IS THE OPPOSITE SENSE OF system()'s RETURN VALUE
|
|
run "cat a b c" or die "cat returned $?";
|
|
|
|
# Launch a sub process directly, no shell. Can't do redirection
|
|
# with this form, it's here to behave like system() with an
|
|
# inverted result.
|
|
$r = run "cat a b c";
|
|
|
|
# Read from a file in to a scalar
|
|
run io( "filename", 'r', \$recv );
|
|
run io( \*HANDLE, 'r', \$recv );
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
IPC::Run allows you to run and interact with child processes using files, pipes,
|
|
and pseudo-ttys. Both system()-style and scripted usages are supported and
|
|
may be mixed. Likewise, functional and OO API styles are both supported and
|
|
may be mixed.
|
|
|
|
Various redirection operators reminiscent of those seen on common Unix and DOS
|
|
command lines are provided.
|
|
|
|
Before digging in to the details a few LIMITATIONS are important enough
|
|
to be mentioned right up front:
|
|
|
|
=over
|
|
|
|
=item Win32 Support
|
|
|
|
Win32 support is working but B<EXPERIMENTAL>, but does pass all relevant tests
|
|
on NT 4.0. See L</Win32 LIMITATIONS>.
|
|
|
|
=item pty Support
|
|
|
|
If you need pty support, IPC::Run should work well enough most of the
|
|
time, but IO::Pty is being improved, and IPC::Run will be improved to
|
|
use IO::Pty's new features when it is release.
|
|
|
|
The basic problem is that the pty needs to initialize itself before the
|
|
parent writes to the master pty, or the data written gets lost. So
|
|
IPC::Run does a sleep(1) in the parent after forking to (hopefully) give
|
|
the child a chance to run. This is a kludge that works well on non
|
|
heavily loaded systems :(.
|
|
|
|
ptys are not supported yet under Win32, but will be emulated...
|
|
|
|
=item Debugging Tip
|
|
|
|
You may use the environment variable C<IPCRUNDEBUG> to see what's going on
|
|
under the hood:
|
|
|
|
$ IPCRUNDEBUG=basic myscript # prints minimal debugging
|
|
$ IPCRUNDEBUG=data myscript # prints all data reads/writes
|
|
$ IPCRUNDEBUG=details myscript # prints lots of low-level details
|
|
$ IPCRUNDEBUG=gory myscript # (Win32 only) prints data moving through
|
|
# the helper processes.
|
|
|
|
=back
|
|
|
|
We now return you to your regularly scheduled documentation.
|
|
|
|
=head2 Harnesses
|
|
|
|
Child processes and I/O handles are gathered in to a harness, then
|
|
started and run until the processing is finished or aborted.
|
|
|
|
=head2 run() vs. start(); pump(); finish();
|
|
|
|
There are two modes you can run harnesses in: run() functions as an
|
|
enhanced system(), and start()/pump()/finish() allow for background
|
|
processes and scripted interactions with them.
|
|
|
|
When using run(), all data to be sent to the harness is set up in
|
|
advance (though one can feed subprocesses input from subroutine refs to
|
|
get around this limitation). The harness is run and all output is
|
|
collected from it, then any child processes are waited for:
|
|
|
|
run \@cmd, \<<IN, \$out;
|
|
blah
|
|
IN
|
|
|
|
## To precompile harnesses and run them later:
|
|
my $h = harness \@cmd, \<<IN, \$out;
|
|
blah
|
|
IN
|
|
|
|
run $h;
|
|
|
|
The background and scripting API is provided by start(), pump(), and
|
|
finish(): start() creates a harness if need be (by calling harness())
|
|
and launches any subprocesses, pump() allows you to poll them for
|
|
activity, and finish() then monitors the harnessed activities until they
|
|
complete.
|
|
|
|
## Build the harness, open all pipes, and launch the subprocesses
|
|
my $h = start \@cat, \$in, \$out;
|
|
$in = "first input\n";
|
|
|
|
## Now do I/O. start() does no I/O.
|
|
pump $h while length $in; ## Wait for all input to go
|
|
|
|
## Now do some more I/O.
|
|
$in = "second input\n";
|
|
pump $h until $out =~ /second input/;
|
|
|
|
## Clean up
|
|
finish $h or die "cat returned $?";
|
|
|
|
You can optionally compile the harness with harness() prior to
|
|
start()ing or run()ing, and you may omit start() between harness() and
|
|
pump(). You might want to do these things if you compile your harnesses
|
|
ahead of time.
|
|
|
|
=head2 Using regexps to match output
|
|
|
|
As shown in most of the scripting examples, the read-to-scalar facility
|
|
for gathering subcommand's output is often used with regular expressions
|
|
to detect stopping points. This is because subcommand output often
|
|
arrives in dribbles and drabs, often only a character or line at a time.
|
|
This output is input for the main program and piles up in variables like
|
|
the C<$out> and C<$err> in our examples.
|
|
|
|
Regular expressions can be used to wait for appropriate output in
|
|
several ways. The C<cat> example in the previous section demonstrates
|
|
how to pump() until some string appears in the output. Here's an
|
|
example that uses C<smb> to fetch files from a remote server:
|
|
|
|
$h = harness \@smbclient, \$in, \$out;
|
|
|
|
$in = "cd /src\n";
|
|
$h->pump until $out =~ /^smb.*> \Z/m;
|
|
die "error cding to /src:\n$out" if $out =~ "ERR";
|
|
$out = '';
|
|
|
|
$in = "mget *\n";
|
|
$h->pump until $out =~ /^smb.*> \Z/m;
|
|
die "error retrieving files:\n$out" if $out =~ "ERR";
|
|
|
|
$in = "quit\n";
|
|
$h->finish;
|
|
|
|
Notice that we carefully clear $out after the first command/response
|
|
cycle? That's because IPC::Run does not delete $out when we continue,
|
|
and we don't want to trip over the old output in the second
|
|
command/response cycle.
|
|
|
|
Say you want to accumulate all the output in $out and analyze it
|
|
afterwards. Perl offers incremental regular expression matching using
|
|
the C<m//gc> and pattern matching idiom and the C<\G> assertion.
|
|
IPC::Run is careful not to disturb the current C<pos()> value for
|
|
scalars it appends data to, so we could modify the above so as not to
|
|
destroy $out by adding a couple of C</gc> modifiers. The C</g> keeps us
|
|
from tripping over the previous prompt and the C</c> keeps us from
|
|
resetting the prior match position if the expected prompt doesn't
|
|
materialize immediately:
|
|
|
|
$h = harness \@smbclient, \$in, \$out;
|
|
|
|
$in = "cd /src\n";
|
|
$h->pump until $out =~ /^smb.*> \Z/mgc;
|
|
die "error cding to /src:\n$out" if $out =~ "ERR";
|
|
|
|
$in = "mget *\n";
|
|
$h->pump until $out =~ /^smb.*> \Z/mgc;
|
|
die "error retrieving files:\n$out" if $out =~ "ERR";
|
|
|
|
$in = "quit\n";
|
|
$h->finish;
|
|
|
|
analyze( $out );
|
|
|
|
When using this technique, you may want to preallocate $out to have
|
|
plenty of memory or you may find that the act of growing $out each time
|
|
new input arrives causes an C<O(length($out)^2)> slowdown as $out grows.
|
|
Say we expect no more than 10,000 characters of input at the most. To
|
|
preallocate memory to $out, do something like:
|
|
|
|
my $out = "x" x 10_000;
|
|
$out = "";
|
|
|
|
C<perl> will allocate at least 10,000 characters' worth of space, then
|
|
mark the $out as having 0 length without freeing all that yummy RAM.
|
|
|
|
=head2 Timeouts and Timers
|
|
|
|
More than likely, you don't want your subprocesses to run forever, and
|
|
sometimes it's nice to know that they're going a little slowly.
|
|
Timeouts throw exceptions after a some time has elapsed, timers merely
|
|
cause pump() to return after some time has elapsed. Neither is
|
|
reset/restarted automatically.
|
|
|
|
Timeout objects are created by calling timeout( $interval ) and passing
|
|
the result to run(), start() or harness(). The timeout period starts
|
|
ticking just after all the child processes have been fork()ed or
|
|
spawn()ed, and are polled for expiration in run(), pump() and finish().
|
|
If/when they expire, an exception is thrown. This is typically useful
|
|
to keep a subprocess from taking too long.
|
|
|
|
If a timeout occurs in run(), all child processes will be terminated and
|
|
all file/pipe/ptty descriptors opened by run() will be closed. File
|
|
descriptors opened by the parent process and passed in to run() are not
|
|
closed in this event.
|
|
|
|
If a timeout occurs in pump(), pump_nb(), or finish(), it's up to you to
|
|
decide whether to kill_kill() all the children or to implement some more
|
|
graceful fallback. No I/O will be closed in pump(), pump_nb() or
|
|
finish() by such an exception (though I/O is often closed down in those
|
|
routines during the natural course of events).
|
|
|
|
Often an exception is too harsh. timer( $interval ) creates timer
|
|
objects that merely prevent pump() from blocking forever. This can be
|
|
useful for detecting stalled I/O or printing a soothing message or "."
|
|
to pacify an anxious user.
|
|
|
|
Timeouts and timers can both be restarted at any time using the timer's
|
|
start() method (this is not the start() that launches subprocesses). To
|
|
restart a timer, you need to keep a reference to the timer:
|
|
|
|
## Start with a nice long timeout to let smbclient connect. If
|
|
## pump or finish take too long, an exception will be thrown.
|
|
|
|
my $h;
|
|
eval {
|
|
$h = harness \@smbclient, \$in, \$out, \$err, ( my $t = timeout 30 );
|
|
sleep 11; # No effect: timer not running yet
|
|
|
|
start $h;
|
|
$in = "cd /src\n";
|
|
pump $h until ! length $in;
|
|
|
|
$in = "ls\n";
|
|
## Now use a short timeout, since this should be faster
|
|
$t->start( 5 );
|
|
pump $h until ! length $in;
|
|
|
|
$t->start( 10 ); ## Give smbclient a little while to shut down.
|
|
$h->finish;
|
|
};
|
|
if ( $@ ) {
|
|
my $x = $@; ## Preserve $@ in case another exception occurs
|
|
$h->kill_kill; ## kill it gently, then brutally if need be, or just
|
|
## brutally on Win32.
|
|
die $x;
|
|
}
|
|
|
|
Timeouts and timers are I<not> checked once the subprocesses are shut
|
|
down; they will not expire in the interval between the last valid
|
|
process and when IPC::Run scoops up the processes' result codes, for
|
|
instance.
|
|
|
|
=head2 Spawning synchronization, child exception propagation
|
|
|
|
start() pauses the parent until the child executes the command or CODE
|
|
reference and propagates any exceptions thrown (including exec()
|
|
failure) back to the parent. This has several pleasant effects: any
|
|
exceptions thrown in the child, including exec() failure, come flying
|
|
out of start() or run() as though they had occurred in the parent.
|
|
|
|
This includes exceptions your code thrown from init subs. In this
|
|
example:
|
|
|
|
eval {
|
|
run \@cmd, init => sub { die "blast it! foiled again!" };
|
|
};
|
|
print $@;
|
|
|
|
the exception "blast it! foiled again" will be thrown from the child
|
|
process (preventing the exec()) and printed by the parent.
|
|
|
|
In situations like
|
|
|
|
run \@cmd1, "|", \@cmd2, "|", \@cmd3;
|
|
|
|
@cmd1 will be initted and exec()ed before @cmd2, and @cmd2 before @cmd3.
|
|
This can save time and prevent oddball errors emitted by later commands
|
|
when earlier commands fail to execute. Note that IPC::Run doesn't start
|
|
any commands unless it can find the executables referenced by all
|
|
commands. These executables must pass both the C<-f> and C<-x> tests
|
|
described in L<perlfunc>.
|
|
|
|
Another nice effect is that init() subs can take their time doing things
|
|
and there will be no problems caused by a parent continuing to execute
|
|
before a child's init() routine is complete. Say the init() routine
|
|
needs to open a socket or a temp file that the parent wants to connect
|
|
to; without this synchronization, the parent will need to implement a
|
|
retry loop to wait for the child to run, since often, the parent gets a
|
|
lot of things done before the child's first timeslice is allocated.
|
|
|
|
This is also quite necessary for pseudo-tty initialization, which needs
|
|
to take place before the parent writes to the child via pty. Writes
|
|
that occur before the pty is set up can get lost.
|
|
|
|
A final, minor, nicety is that debugging output from the child will be
|
|
emitted before the parent continues on, making for much clearer debugging
|
|
output in complex situations.
|
|
|
|
The only drawback I can conceive of is that the parent can't continue to
|
|
operate while the child is being initted. If this ever becomes a
|
|
problem in the field, we can implement an option to avoid this behavior,
|
|
but I don't expect it to.
|
|
|
|
B<Win32>: executing CODE references isn't supported on Win32, see
|
|
L</Win32 LIMITATIONS> for details.
|
|
|
|
=head2 Syntax
|
|
|
|
run(), start(), and harness() can all take a harness specification
|
|
as input. A harness specification is either a single string to be passed
|
|
to the systems' shell:
|
|
|
|
run "echo 'hi there'";
|
|
|
|
or a list of commands, io operations, and/or timers/timeouts to execute.
|
|
Consecutive commands must be separated by a pipe operator '|' or an '&'.
|
|
External commands are passed in as array references, and, on systems
|
|
supporting fork(), Perl code may be passed in as subs:
|
|
|
|
run \@cmd;
|
|
run \@cmd1, '|', \@cmd2;
|
|
run \@cmd1, '&', \@cmd2;
|
|
run \&sub1;
|
|
run \&sub1, '|', \&sub2;
|
|
run \&sub1, '&', \&sub2;
|
|
|
|
'|' pipes the stdout of \@cmd1 the stdin of \@cmd2, just like a
|
|
shell pipe. '&' does not. Child processes to the right of a '&'
|
|
will have their stdin closed unless it's redirected-to.
|
|
|
|
L<IPC::Run::IO> objects may be passed in as well, whether or not
|
|
child processes are also specified:
|
|
|
|
run io( "infile", ">", \$in ), io( "outfile", "<", \$in );
|
|
|
|
as can L<IPC::Run::Timer> objects:
|
|
|
|
run \@cmd, io( "outfile", "<", \$in ), timeout( 10 );
|
|
|
|
Commands may be followed by scalar, sub, or i/o handle references for
|
|
redirecting
|
|
child process input & output:
|
|
|
|
run \@cmd, \undef, \$out;
|
|
run \@cmd, \$in, \$out;
|
|
run \@cmd1, \&in, '|', \@cmd2, \*OUT;
|
|
run \@cmd1, \*IN, '|', \@cmd2, \&out;
|
|
|
|
This is known as succinct redirection syntax, since run(), start()
|
|
and harness(), figure out which file descriptor to redirect and how.
|
|
File descriptor 0 is presumed to be an input for
|
|
the child process, all others are outputs. The assumed file
|
|
descriptor always starts at 0, unless the command is being piped to,
|
|
in which case it starts at 1.
|
|
|
|
To be explicit about your redirects, or if you need to do more complex
|
|
things, there's also a redirection operator syntax:
|
|
|
|
run \@cmd, '<', \undef, '>', \$out;
|
|
run \@cmd, '<', \undef, '>&', \$out_and_err;
|
|
run(
|
|
\@cmd1,
|
|
'<', \$in,
|
|
'|', \@cmd2,
|
|
\$out
|
|
);
|
|
|
|
Operator syntax is required if you need to do something other than simple
|
|
redirection to/from scalars or subs, like duping or closing file descriptors
|
|
or redirecting to/from a named file. The operators are covered in detail
|
|
below.
|
|
|
|
After each \@cmd (or \&foo), parsing begins in succinct mode and toggles to
|
|
operator syntax mode when an operator (ie plain scalar, not a ref) is seen.
|
|
Once in
|
|
operator syntax mode, parsing only reverts to succinct mode when a '|' or
|
|
'&' is seen.
|
|
|
|
In succinct mode, each parameter after the \@cmd specifies what to
|
|
do with the next highest file descriptor. These File descriptor start
|
|
with 0 (stdin) unless stdin is being piped to (C<'|', \@cmd>), in which
|
|
case they start with 1 (stdout). Currently, being on the left of
|
|
a pipe (C<\@cmd, \$out, \$err, '|'>) does I<not> cause stdout to be
|
|
skipped, though this may change since it's not as DWIMerly as it
|
|
could be. Only stdin is assumed to be an
|
|
input in succinct mode, all others are assumed to be outputs.
|
|
|
|
If no piping or redirection is specified for a child, it will inherit
|
|
the parent's open file handles as dictated by your system's
|
|
close-on-exec behavior and the $^F flag, except that processes after a
|
|
'&' will not inherit the parent's stdin. Also note that $^F does not
|
|
affect file descriptors obtained via POSIX, since it only applies to
|
|
full-fledged Perl file handles. Such processes will have their stdin
|
|
closed unless it has been redirected-to.
|
|
|
|
If you want to close a child processes stdin, you may do any of:
|
|
|
|
run \@cmd, \undef;
|
|
run \@cmd, \"";
|
|
run \@cmd, '<&-';
|
|
run \@cmd, '0<&-';
|
|
|
|
Redirection is done by placing redirection specifications immediately
|
|
after a command or child subroutine:
|
|
|
|
run \@cmd1, \$in, '|', \@cmd2, \$out;
|
|
run \@cmd1, '<', \$in, '|', \@cmd2, '>', \$out;
|
|
|
|
If you omit the redirection operators, descriptors are counted
|
|
starting at 0. Descriptor 0 is assumed to be input, all others
|
|
are outputs. A leading '|' consumes descriptor 0, so this
|
|
works as expected.
|
|
|
|
run \@cmd1, \$in, '|', \@cmd2, \$out;
|
|
|
|
The parameter following a redirection operator can be a scalar ref,
|
|
a subroutine ref, a file name, an open filehandle, or a closed
|
|
filehandle.
|
|
|
|
If it's a scalar ref, the child reads input from or sends output to
|
|
that variable:
|
|
|
|
$in = "Hello World.\n";
|
|
run \@cat, \$in, \$out;
|
|
print $out;
|
|
|
|
Scalars used in incremental (start()/pump()/finish()) applications are treated
|
|
as queues: input is removed from input scalers, resulting in them dwindling
|
|
to '', and output is appended to output scalars. This is not true of
|
|
harnesses run() in batch mode.
|
|
|
|
It's usually wise to append new input to be sent to the child to the input
|
|
queue, and you'll often want to zap output queues to '' before pumping.
|
|
|
|
$h = start \@cat, \$in;
|
|
$in = "line 1\n";
|
|
pump $h;
|
|
$in .= "line 2\n";
|
|
pump $h;
|
|
$in .= "line 3\n";
|
|
finish $h;
|
|
|
|
The final call to finish() must be there: it allows the child process(es)
|
|
to run to completion and waits for their exit values.
|
|
|
|
=head1 OBSTINATE CHILDREN
|
|
|
|
Interactive applications are usually optimized for human use. This
|
|
can help or hinder trying to interact with them through modules like
|
|
IPC::Run. Frequently, programs alter their behavior when they detect
|
|
that stdin, stdout, or stderr are not connected to a tty, assuming that
|
|
they are being run in batch mode. Whether this helps or hurts depends
|
|
on which optimizations change. And there's often no way of telling
|
|
what a program does in these areas other than trial and error and
|
|
occasionally, reading the source. This includes different versions
|
|
and implementations of the same program.
|
|
|
|
All hope is not lost, however. Most programs behave in reasonably
|
|
tractable manners, once you figure out what it's trying to do.
|
|
|
|
Here are some of the issues you might need to be aware of.
|
|
|
|
=over
|
|
|
|
=item *
|
|
|
|
fflush()ing stdout and stderr
|
|
|
|
This lets the user see stdout and stderr immediately. Many programs
|
|
undo this optimization if stdout is not a tty, making them harder to
|
|
manage by things like IPC::Run.
|
|
|
|
Many programs decline to fflush stdout or stderr if they do not
|
|
detect a tty there. Some ftp commands do this, for instance.
|
|
|
|
If this happens to you, look for a way to force interactive behavior,
|
|
like a command line switch or command. If you can't, you will
|
|
need to use a pseudo terminal ('<pty<' and '>pty>').
|
|
|
|
=item *
|
|
|
|
false prompts
|
|
|
|
Interactive programs generally do not guarantee that output from user
|
|
commands won't contain a prompt string. For example, your shell prompt
|
|
might be a '$', and a file named '$' might be the only file in a directory
|
|
listing.
|
|
|
|
This can make it hard to guarantee that your output parser won't be fooled
|
|
into early termination of results.
|
|
|
|
To help work around this, you can see if the program can alter it's
|
|
prompt, and use something you feel is never going to occur in actual
|
|
practice.
|
|
|
|
You should also look for your prompt to be the only thing on a line:
|
|
|
|
pump $h until $out =~ /^<SILLYPROMPT>\s?\z/m;
|
|
|
|
(use C<(?!\n)\Z> in place of C<\z> on older perls).
|
|
|
|
You can also take the approach that IPC::ChildSafe takes and emit a
|
|
command with known output after each 'real' command you issue, then
|
|
look for this known output. See new_appender() and new_chunker() for
|
|
filters that can help with this task.
|
|
|
|
If it's not convenient or possibly to alter a prompt or use a known
|
|
command/response pair, you might need to autodetect the prompt in case
|
|
the local version of the child program is different then the one
|
|
you tested with, or if the user has control over the look & feel of
|
|
the prompt.
|
|
|
|
=item *
|
|
|
|
Refusing to accept input unless stdin is a tty.
|
|
|
|
Some programs, for security reasons, will only accept certain types
|
|
of input from a tty. su, notable, will not prompt for a password unless
|
|
it's connected to a tty.
|
|
|
|
If this is your situation, use a pseudo terminal ('<pty<' and '>pty>').
|
|
|
|
=item *
|
|
|
|
Not prompting unless connected to a tty.
|
|
|
|
Some programs don't prompt unless stdin or stdout is a tty. See if you can
|
|
turn prompting back on. If not, see if you can come up with a command that
|
|
you can issue after every real command and look for it's output, as
|
|
IPC::ChildSafe does. There are two filters included with IPC::Run that
|
|
can help with doing this: appender and chunker (see new_appender() and
|
|
new_chunker()).
|
|
|
|
=item *
|
|
|
|
Different output format when not connected to a tty.
|
|
|
|
Some commands alter their formats to ease machine parsability when they
|
|
aren't connected to a pipe. This is actually good, but can be surprising.
|
|
|
|
=back
|
|
|
|
=head1 PSEUDO TERMINALS
|
|
|
|
On systems providing pseudo terminals under /dev, IPC::Run can use IO::Pty
|
|
(available on CPAN) to provide a terminal environment to subprocesses.
|
|
This is necessary when the subprocess really wants to think it's connected
|
|
to a real terminal.
|
|
|
|
=head2 CAVEATS
|
|
|
|
Pseudo-terminals are not pipes, though they are similar. Here are some
|
|
differences to watch out for.
|
|
|
|
=over
|
|
|
|
=item Echoing
|
|
|
|
Sending to stdin will cause an echo on stdout, which occurs before each
|
|
line is passed to the child program. There is currently no way to
|
|
disable this, although the child process can and should disable it for
|
|
things like passwords.
|
|
|
|
=item Shutdown
|
|
|
|
IPC::Run cannot close a pty until all output has been collected. This
|
|
means that it is not possible to send an EOF to stdin by half-closing
|
|
the pty, as we can when using a pipe to stdin.
|
|
|
|
This means that you need to send the child process an exit command or
|
|
signal, or run() / finish() will time out. Be careful not to expect a
|
|
prompt after sending the exit command.
|
|
|
|
=item Command line editing
|
|
|
|
Some subprocesses, notable shells that depend on the user's prompt
|
|
settings, will reissue the prompt plus the command line input so far
|
|
once for each character.
|
|
|
|
=item '>pty>' means '&>pty>', not '1>pty>'
|
|
|
|
The pseudo terminal redirects both stdout and stderr unless you specify
|
|
a file descriptor. If you want to grab stderr separately, do this:
|
|
|
|
start \@cmd, '<pty<', \$in, '>pty>', \$out, '2>', \$err;
|
|
|
|
=item stdin, stdout, and stderr not inherited
|
|
|
|
Child processes harnessed to a pseudo terminal have their stdin, stdout,
|
|
and stderr completely closed before any redirection operators take
|
|
effect. This casts of the bonds of the controlling terminal. This is
|
|
not done when using pipes.
|
|
|
|
Right now, this affects all children in a harness that has a pty in use,
|
|
even if that pty would not affect a particular child. That's a bug and
|
|
will be fixed. Until it is, it's best not to mix-and-match children.
|
|
|
|
=back
|
|
|
|
=head2 Redirection Operators
|
|
|
|
Operator SHNP Description
|
|
======== ==== ===========
|
|
<, N< SHN Redirects input to a child's fd N (0 assumed)
|
|
|
|
>, N> SHN Redirects output from a child's fd N (1 assumed)
|
|
>>, N>> SHN Like '>', but appends to scalars or named files
|
|
>&, &> SHN Redirects stdout & stderr from a child process
|
|
|
|
<pty, N<pty S Like '<', but uses a pseudo-tty instead of a pipe
|
|
>pty, N>pty S Like '>', but uses a pseudo-tty instead of a pipe
|
|
|
|
N<&M Dups input fd N to input fd M
|
|
M>&N Dups output fd N to input fd M
|
|
N<&- Closes fd N
|
|
|
|
<pipe, N<pipe P Pipe opens H for caller to read, write, close.
|
|
>pipe, N>pipe P Pipe opens H for caller to read, write, close.
|
|
|
|
'N' and 'M' are placeholders for integer file descriptor numbers. The
|
|
terms 'input' and 'output' are from the child process's perspective.
|
|
|
|
The SHNP field indicates what parameters an operator can take:
|
|
|
|
S: \$scalar or \&function references. Filters may be used with
|
|
these operators (and only these).
|
|
H: \*HANDLE or IO::Handle for caller to open, and close
|
|
N: "file name".
|
|
P: \*HANDLE or lexical filehandle opened by IPC::Run as the parent end of a pipe, but read
|
|
and written to and closed by the caller (like IPC::Open3).
|
|
|
|
=over
|
|
|
|
=item Redirecting input: [n]<, [n]<pipe
|
|
|
|
You can input the child reads on file descriptor number n to come from a
|
|
scalar variable, subroutine, file handle, or a named file. If stdin
|
|
is not redirected, the parent's stdin is inherited.
|
|
|
|
run \@cat, \undef ## Closes child's stdin immediately
|
|
or die "cat returned $?";
|
|
|
|
run \@cat, \$in;
|
|
|
|
run \@cat, \<<TOHERE;
|
|
blah
|
|
TOHERE
|
|
|
|
run \@cat, \&input; ## Calls &input, feeding data returned
|
|
## to child's. Closes child's stdin
|
|
## when undef is returned.
|
|
|
|
Redirecting from named files requires you to use the input
|
|
redirection operator:
|
|
|
|
run \@cat, '<.profile';
|
|
run \@cat, '<', '.profile';
|
|
|
|
open IN, "<foo";
|
|
run \@cat, \*IN;
|
|
run \@cat, *IN{IO};
|
|
|
|
The form used second example here is the safest,
|
|
since filenames like "0" and "&more\n" won't confuse &run:
|
|
|
|
You can't do either of
|
|
|
|
run \@a, *IN; ## INVALID
|
|
run \@a, '<', *IN; ## BUGGY: Reads file named like "*main::A"
|
|
|
|
because perl passes a scalar containing a string that
|
|
looks like "*main::A" to &run, and &run can't tell the difference
|
|
between that and a redirection operator or a file name. &run guarantees
|
|
that any scalar you pass after a redirection operator is a file name.
|
|
|
|
If your child process will take input from file descriptors other
|
|
than 0 (stdin), you can use a redirection operator with any of the
|
|
valid input forms (scalar ref, sub ref, etc.):
|
|
|
|
run \@cat, '3<', \$in3;
|
|
|
|
When redirecting input from a scalar ref, the scalar ref is
|
|
used as a queue. This allows you to use &harness and pump() to
|
|
feed incremental bits of input to a coprocess. See L</Coprocesses>
|
|
below for more information.
|
|
|
|
The <pipe operator opens the write half of a pipe on the filehandle
|
|
glob reference it takes as an argument:
|
|
|
|
$h = start \@cat, '<pipe', \*IN;
|
|
print IN "hello world\n";
|
|
pump $h;
|
|
close IN;
|
|
finish $h;
|
|
|
|
Unlike the other '<' operators, IPC::Run does nothing further with
|
|
it: you are responsible for it. The previous example is functionally
|
|
equivalent to:
|
|
|
|
pipe( \*R, \*IN ) or die $!;
|
|
$h = start \@cat, '<', \*IN;
|
|
print IN "hello world\n";
|
|
pump $h;
|
|
close IN;
|
|
finish $h;
|
|
|
|
This is like the behavior of IPC::Open2 and IPC::Open3.
|
|
|
|
B<Win32>: The handle returned is actually a socket handle, so you can
|
|
use select() on it.
|
|
|
|
=item Redirecting output: [n]>, [n]>>, [n]>&[m], [n]>pipe
|
|
|
|
You can redirect any output the child emits
|
|
to a scalar variable, subroutine, file handle, or file name. You
|
|
can have &run truncate or append to named files or scalars. If
|
|
you are redirecting stdin as well, or if the command is on the
|
|
receiving end of a pipeline ('|'), you can omit the redirection
|
|
operator:
|
|
|
|
@ls = ( 'ls' );
|
|
run \@ls, \undef, \$out
|
|
or die "ls returned $?";
|
|
|
|
run \@ls, \undef, \&out; ## Calls &out each time some output
|
|
## is received from the child's
|
|
## when undef is returned.
|
|
|
|
run \@ls, \undef, '2>ls.err';
|
|
run \@ls, '2>', 'ls.err';
|
|
|
|
The two parameter form guarantees that the filename
|
|
will not be interpreted as a redirection operator:
|
|
|
|
run \@ls, '>', "&more";
|
|
run \@ls, '2>', ">foo\n";
|
|
|
|
You can pass file handles you've opened for writing:
|
|
|
|
open( *OUT, ">out.txt" );
|
|
open( *ERR, ">err.txt" );
|
|
run \@cat, \*OUT, \*ERR;
|
|
|
|
Passing a scalar reference and a code reference requires a little
|
|
more work, but allows you to capture all of the output in a scalar
|
|
or each piece of output by a callback:
|
|
|
|
These two do the same things:
|
|
|
|
run( [ 'ls' ], '2>', sub { $err_out .= $_[0] } );
|
|
|
|
does the same basic thing as:
|
|
|
|
run( [ 'ls' ], '2>', \$err_out );
|
|
|
|
The subroutine will be called each time some data is read from the child.
|
|
|
|
The >pipe operator is different in concept than the other '>' operators,
|
|
although it's syntax is similar:
|
|
|
|
$h = start \@cat, $in, '>pipe', \*OUT, '2>pipe', \*ERR;
|
|
$in = "hello world\n";
|
|
finish $h;
|
|
print <OUT>;
|
|
print <ERR>;
|
|
close OUT;
|
|
close ERR;
|
|
|
|
causes two pipe to be created, with one end attached to cat's stdout
|
|
and stderr, respectively, and the other left open on OUT and ERR, so
|
|
that the script can manually
|
|
read(), select(), etc. on them. This is like
|
|
the behavior of IPC::Open2 and IPC::Open3.
|
|
|
|
B<Win32>: The handle returned is actually a socket handle, so you can
|
|
use select() on it.
|
|
|
|
=item Duplicating output descriptors: >&m, n>&m
|
|
|
|
This duplicates output descriptor number n (default is 1 if n is omitted)
|
|
from descriptor number m.
|
|
|
|
=item Duplicating input descriptors: <&m, n<&m
|
|
|
|
This duplicates input descriptor number n (default is 0 if n is omitted)
|
|
from descriptor number m
|
|
|
|
=item Closing descriptors: <&-, 3<&-
|
|
|
|
This closes descriptor number n (default is 0 if n is omitted). The
|
|
following commands are equivalent:
|
|
|
|
run \@cmd, \undef;
|
|
run \@cmd, '<&-';
|
|
run \@cmd, '<in.txt', '<&-';
|
|
|
|
Doing
|
|
|
|
run \@cmd, \$in, '<&-'; ## SIGPIPE recipe.
|
|
|
|
is dangerous: the parent will get a SIGPIPE if $in is not empty.
|
|
|
|
=item Redirecting both stdout and stderr: &>, >&, &>pipe, >pipe&
|
|
|
|
The following pairs of commands are equivalent:
|
|
|
|
run \@cmd, '>&', \$out; run \@cmd, '>', \$out, '2>&1';
|
|
run \@cmd, '>&', 'out.txt'; run \@cmd, '>', 'out.txt', '2>&1';
|
|
|
|
etc.
|
|
|
|
File descriptor numbers are not permitted to the left or the right of
|
|
these operators, and the '&' may occur on either end of the operator.
|
|
|
|
The '&>pipe' and '>pipe&' variants behave like the '>pipe' operator, except
|
|
that both stdout and stderr write to the created pipe.
|
|
|
|
=item Redirection Filters
|
|
|
|
Both input redirections and output redirections that use scalars or
|
|
subs as endpoints may have an arbitrary number of filter subs placed
|
|
between them and the child process. This is useful if you want to
|
|
receive output in chunks, or if you want to massage each chunk of
|
|
data sent to the child. To use this feature, you must use operator
|
|
syntax:
|
|
|
|
run(
|
|
\@cmd
|
|
'<', \&in_filter_2, \&in_filter_1, $in,
|
|
'>', \&out_filter_1, \&in_filter_2, $out,
|
|
);
|
|
|
|
This capability is not provided for IO handles or named files.
|
|
|
|
Two filters are provided by IPC::Run: appender and chunker. Because
|
|
these may take an argument, you need to use the constructor functions
|
|
new_appender() and new_chunker() rather than using \& syntax:
|
|
|
|
run(
|
|
\@cmd
|
|
'<', new_appender( "\n" ), $in,
|
|
'>', new_chunker, $out,
|
|
);
|
|
|
|
=back
|
|
|
|
=head2 Just doing I/O
|
|
|
|
If you just want to do I/O to a handle or file you open yourself, you
|
|
may specify a filehandle or filename instead of a command in the harness
|
|
specification:
|
|
|
|
run io( "filename", '>', \$recv );
|
|
|
|
$h = start io( $io, '>', \$recv );
|
|
|
|
$h = harness \@cmd, '&', io( "file", '<', \$send );
|
|
|
|
=head2 Options
|
|
|
|
Options are passed in as name/value pairs:
|
|
|
|
run \@cat, \$in, debug => 1;
|
|
|
|
If you pass the debug option, you may want to pass it in first, so you
|
|
can see what parsing is going on:
|
|
|
|
run debug => 1, \@cat, \$in;
|
|
|
|
=over
|
|
|
|
=item debug
|
|
|
|
Enables debugging output in parent and child. Debugging info is emitted
|
|
to the STDERR that was present when IPC::Run was first C<use()>ed (it's
|
|
C<dup()>ed out of the way so that it can be redirected in children without
|
|
having debugging output emitted on it).
|
|
|
|
=back
|
|
|
|
=head1 RETURN VALUES
|
|
|
|
harness() and start() return a reference to an IPC::Run harness. This is
|
|
blessed in to the IPC::Run package, so you may make later calls to
|
|
functions as members if you like:
|
|
|
|
$h = harness( ... );
|
|
$h->start;
|
|
$h->pump;
|
|
$h->finish;
|
|
|
|
$h = start( .... );
|
|
$h->pump;
|
|
...
|
|
|
|
Of course, using method call syntax lets you deal with any IPC::Run
|
|
subclasses that might crop up, but don't hold your breath waiting for
|
|
any.
|
|
|
|
run() and finish() return TRUE when all subcommands exit with a 0 result
|
|
code. B<This is the opposite of perl's system() command>.
|
|
|
|
All routines raise exceptions (via die()) when error conditions are
|
|
recognized. A non-zero command result is not treated as an error
|
|
condition, since some commands are tests whose results are reported
|
|
in their exit codes.
|
|
|
|
=head1 ROUTINES
|
|
|
|
=over
|
|
|
|
=cut
|
|
|
|
use strict;
|
|
use Exporter ();
|
|
use vars qw{$VERSION @ISA @FILTER_IMP @FILTERS @API @EXPORT_OK %EXPORT_TAGS};
|
|
|
|
BEGIN {
|
|
$VERSION = '20200505.0';
|
|
@ISA = qw{ Exporter };
|
|
|
|
## We use @EXPORT for the end user's convenience: there's only one function
|
|
## exported, it's homonymous with the module, it's an unusual name, and
|
|
## it can be suppressed by "use IPC::Run ();".
|
|
@FILTER_IMP = qw( input_avail get_more_input );
|
|
@FILTERS = qw(
|
|
new_appender
|
|
new_chunker
|
|
new_string_source
|
|
new_string_sink
|
|
);
|
|
@API = qw(
|
|
run
|
|
harness start pump pumpable finish
|
|
signal kill_kill reap_nb
|
|
io timer timeout
|
|
close_terminal
|
|
binary
|
|
);
|
|
@EXPORT_OK = ( @API, @FILTER_IMP, @FILTERS, qw( Win32_MODE ) );
|
|
%EXPORT_TAGS = (
|
|
'filter_imp' => \@FILTER_IMP,
|
|
'all' => \@EXPORT_OK,
|
|
'filters' => \@FILTERS,
|
|
'api' => \@API,
|
|
);
|
|
|
|
}
|
|
|
|
use strict;
|
|
use IPC::Run::Debug;
|
|
use Exporter;
|
|
use Fcntl;
|
|
use POSIX ();
|
|
|
|
BEGIN {
|
|
if ( $] < 5.008 ) { require Symbol; }
|
|
}
|
|
use Carp;
|
|
use File::Spec ();
|
|
use IO::Handle;
|
|
require IPC::Run::IO;
|
|
require IPC::Run::Timer;
|
|
|
|
use constant Win32_MODE => $^O =~ /os2|Win32/i;
|
|
|
|
BEGIN {
|
|
if (Win32_MODE) {
|
|
eval "use IPC::Run::Win32Helper; 1;"
|
|
or ( $@ && die )
|
|
or die "$!";
|
|
}
|
|
else {
|
|
eval "use File::Basename; 1;" or die $!;
|
|
}
|
|
}
|
|
|
|
sub input_avail();
|
|
sub get_more_input();
|
|
|
|
###############################################################################
|
|
|
|
##
|
|
## Error constants, not too locale-dependent
|
|
use vars qw( $_EIO $_EAGAIN );
|
|
use Errno qw( EIO EAGAIN );
|
|
|
|
BEGIN {
|
|
local $!;
|
|
$! = EIO;
|
|
$_EIO = qr/^$!/;
|
|
$! = EAGAIN;
|
|
$_EAGAIN = qr/^$!/;
|
|
}
|
|
|
|
##
|
|
## State machine states, set in $self->{STATE}
|
|
##
|
|
## These must be in ascending order numerically
|
|
##
|
|
sub _newed() { 0 }
|
|
sub _harnessed() { 1 }
|
|
sub _finished() { 2 } ## _finished behave almost exactly like _harnessed
|
|
sub _started() { 3 }
|
|
|
|
##
|
|
## Which fds have been opened in the parent. This may have extra fds, since
|
|
## we aren't all that rigorous about closing these off, but that's ok. This
|
|
## is used on Unixish OSs to close all fds in the child that aren't needed
|
|
## by that particular child.
|
|
my %fds;
|
|
|
|
## There's a bit of hackery going on here.
|
|
##
|
|
## We want to have any code anywhere be able to emit
|
|
## debugging statements without knowing what harness the code is
|
|
## being called in/from, since we'd need to pass a harness around to
|
|
## everything.
|
|
##
|
|
## Thus, $cur_self was born.
|
|
|
|
use vars qw( $cur_self );
|
|
|
|
sub _debug_fd {
|
|
return fileno STDERR unless defined $cur_self;
|
|
|
|
if ( _debugging && !defined $cur_self->{DEBUG_FD} ) {
|
|
my $fd = select STDERR;
|
|
$| = 1;
|
|
select $fd;
|
|
$cur_self->{DEBUG_FD} = POSIX::dup fileno STDERR;
|
|
_debug("debugging fd is $cur_self->{DEBUG_FD}\n")
|
|
if _debugging_details;
|
|
}
|
|
|
|
return fileno STDERR unless defined $cur_self->{DEBUG_FD};
|
|
|
|
return $cur_self->{DEBUG_FD};
|
|
}
|
|
|
|
sub DESTROY {
|
|
## We absolutely do not want to do anything else here. We are likely
|
|
## to be in a child process and we don't want to do things like kill_kill
|
|
## ourself or cause other destruction.
|
|
my IPC::Run $self = shift;
|
|
POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD};
|
|
$self->{DEBUG_FD} = undef;
|
|
|
|
for my $kid ( @{$self->{KIDS}} ) {
|
|
for my $op ( @{$kid->{OPS}} ) {
|
|
delete $op->{FILTERS};
|
|
}
|
|
}
|
|
}
|
|
|
|
##
|
|
## Support routines (NOT METHODS)
|
|
##
|
|
my %cmd_cache;
|
|
|
|
sub _search_path {
|
|
my ($cmd_name) = @_;
|
|
if ( File::Spec->file_name_is_absolute($cmd_name) && -x $cmd_name ) {
|
|
_debug "'", $cmd_name, "' is absolute"
|
|
if _debugging_details;
|
|
return $cmd_name;
|
|
}
|
|
|
|
my $dirsep = (
|
|
Win32_MODE ? '[/\\\\]'
|
|
: $^O =~ /MacOS/ ? ':'
|
|
: $^O =~ /VMS/ ? '[\[\]]'
|
|
: '/'
|
|
);
|
|
|
|
if ( Win32_MODE
|
|
&& ( $cmd_name =~ /$dirsep/ )
|
|
&& ( $cmd_name !~ m!\.[^\\/\.]+$! ) ) {
|
|
|
|
_debug "no extension(.exe), checking ENV{PATHEXT}" if _debugging;
|
|
for ( split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE" ) {
|
|
my $name = "$cmd_name$_";
|
|
$cmd_name = $name, last if -f $name && -x _;
|
|
}
|
|
_debug "cmd_name is now '$cmd_name'" if _debugging;
|
|
}
|
|
|
|
if ( $cmd_name =~ /($dirsep)/ ) {
|
|
_debug "'$cmd_name' contains '$1'" if _debugging;
|
|
croak "file not found: $cmd_name" unless -e $cmd_name;
|
|
croak "not a file: $cmd_name" unless -f $cmd_name;
|
|
croak "permission denied: $cmd_name" unless -x $cmd_name;
|
|
return $cmd_name;
|
|
}
|
|
|
|
if ( exists $cmd_cache{$cmd_name} ) {
|
|
_debug "'$cmd_name' found in cache: '$cmd_cache{$cmd_name}'"
|
|
if _debugging;
|
|
return $cmd_cache{$cmd_name} if -x $cmd_cache{$cmd_name};
|
|
_debug "'$cmd_cache{$cmd_name}' no longer executable, searching..."
|
|
if _debugging;
|
|
delete $cmd_cache{$cmd_name};
|
|
}
|
|
|
|
my @searched_in;
|
|
|
|
## This next bit is Unix/Win32 specific, unfortunately.
|
|
## There's been some conversation about extending File::Spec to provide
|
|
## a universal interface to PATH, but I haven't seen it yet.
|
|
my $re = Win32_MODE ? qr/;/ : qr/:/;
|
|
|
|
LOOP:
|
|
for ( split( $re, $ENV{PATH} || '', -1 ) ) {
|
|
$_ = "." unless length $_;
|
|
push @searched_in, $_;
|
|
|
|
my $prospect = File::Spec->catfile( $_, $cmd_name );
|
|
my @prospects;
|
|
|
|
@prospects =
|
|
( Win32_MODE && !( -f $prospect && -x _ ) )
|
|
? map "$prospect$_", split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE"
|
|
: ($prospect);
|
|
|
|
for my $found (@prospects) {
|
|
if ( -f $found && -x _ ) {
|
|
$cmd_cache{$cmd_name} = $found;
|
|
last LOOP;
|
|
}
|
|
}
|
|
}
|
|
|
|
if ( exists $cmd_cache{$cmd_name} ) {
|
|
_debug "'", $cmd_name, "' added to cache: '", $cmd_cache{$cmd_name}, "'"
|
|
if _debugging_details;
|
|
return $cmd_cache{$cmd_name};
|
|
}
|
|
|
|
croak "Command '$cmd_name' not found in " . join( ", ", @searched_in );
|
|
}
|
|
|
|
sub _empty($) { !( defined $_[0] && length $_[0] ) }
|
|
|
|
## 'safe' versions of otherwise fun things to do. See also IPC::Run::Win32Helper.
|
|
sub _close {
|
|
confess 'undef' unless defined $_[0];
|
|
my $fd = $_[0] =~ /^\d+$/ ? $_[0] : fileno $_[0];
|
|
my $r = POSIX::close $fd;
|
|
$r = $r ? '' : " ERROR $!";
|
|
delete $fds{$fd};
|
|
_debug "close( $fd ) = " . ( $r || 0 ) if _debugging_details;
|
|
}
|
|
|
|
sub _dup {
|
|
confess 'undef' unless defined $_[0];
|
|
my $r = POSIX::dup( $_[0] );
|
|
croak "$!: dup( $_[0] )" unless defined $r;
|
|
$r = 0 if $r eq '0 but true';
|
|
_debug "dup( $_[0] ) = $r" if _debugging_details;
|
|
$fds{$r} = {};
|
|
return $r;
|
|
}
|
|
|
|
sub _dup2_rudely {
|
|
confess 'undef' unless defined $_[0] && defined $_[1];
|
|
my $r = POSIX::dup2( $_[0], $_[1] );
|
|
croak "$!: dup2( $_[0], $_[1] )" unless defined $r;
|
|
$r = 0 if $r eq '0 but true';
|
|
_debug "dup2( $_[0], $_[1] ) = $r" if _debugging_details;
|
|
$fds{$r} = {};
|
|
return $r;
|
|
}
|
|
|
|
sub _exec {
|
|
confess 'undef passed' if grep !defined, @_;
|
|
|
|
# exec @_ or croak "$!: exec( " . join( ', ', @_ ) . " )";
|
|
_debug 'exec()ing ', join " ", map "'$_'", @_ if _debugging_details;
|
|
|
|
# {
|
|
## Commented out since we don't call this on Win32.
|
|
# # This works around the bug where 5.6.1 complains
|
|
# # "Can't exec ...: No error" after an exec on NT, where
|
|
# # exec() is simulated and actually returns in Perl's C
|
|
# # code, though Perl's &exec does not...
|
|
# no warnings "exec";
|
|
#
|
|
# # Just in case the no warnings workaround
|
|
# # stops being a workaround, we don't want
|
|
# # old values of $! causing spurious strerr()
|
|
# # messages to appear in the "Can't exec" message
|
|
# undef $!;
|
|
exec { $_[0] } @_;
|
|
|
|
# }
|
|
# croak "$!: exec( " . join( ', ', map "'$_'", @_ ) . " )";
|
|
## Fall through so $! can be reported to parent.
|
|
}
|
|
|
|
sub _sysopen {
|
|
confess 'undef' unless defined $_[0] && defined $_[1];
|
|
_debug sprintf( "O_RDONLY=0x%02x ", O_RDONLY ),
|
|
sprintf( "O_WRONLY=0x%02x ", O_WRONLY ),
|
|
sprintf( "O_RDWR=0x%02x ", O_RDWR ),
|
|
sprintf( "O_TRUNC=0x%02x ", O_TRUNC ),
|
|
sprintf( "O_CREAT=0x%02x ", O_CREAT ),
|
|
sprintf( "O_APPEND=0x%02x ", O_APPEND ),
|
|
if _debugging_details;
|
|
my $r = POSIX::open( $_[0], $_[1], 0666 );
|
|
croak "$!: open( $_[0], ", sprintf( "0x%03x", $_[1] ), " )" unless defined $r;
|
|
_debug "open( $_[0], ", sprintf( "0x%03x", $_[1] ), " ) = $r"
|
|
if _debugging_data;
|
|
$fds{$r} = {};
|
|
return $r;
|
|
}
|
|
|
|
sub _pipe {
|
|
## Normal, blocking write for pipes that we read and the child writes,
|
|
## since most children expect writes to stdout to block rather than
|
|
## do a partial write.
|
|
my ( $r, $w ) = POSIX::pipe;
|
|
croak "$!: pipe()" unless defined $r;
|
|
_debug "pipe() = ( $r, $w ) " if _debugging_details;
|
|
@fds{$r, $w} = ( {}, {} );
|
|
return ( $r, $w );
|
|
}
|
|
|
|
sub _pipe_nb {
|
|
## For pipes that we write, unblock the write side, so we can fill a buffer
|
|
## and continue to select().
|
|
## Contributed by Borislav Deianov <borislav@ensim.com>, with minor
|
|
## bugfix on fcntl result by me.
|
|
local ( *R, *W );
|
|
my $f = pipe( R, W );
|
|
croak "$!: pipe()" unless defined $f;
|
|
my ( $r, $w ) = ( fileno R, fileno W );
|
|
_debug "pipe_nb pipe() = ( $r, $w )" if _debugging_details;
|
|
unless (Win32_MODE) {
|
|
## POSIX::fcntl doesn't take fd numbers, so gotta use Perl's and
|
|
## then _dup the originals (which get closed on leaving this block)
|
|
my $fres = fcntl( W, &F_SETFL, O_WRONLY | O_NONBLOCK );
|
|
croak "$!: fcntl( $w, F_SETFL, O_NONBLOCK )" unless $fres;
|
|
_debug "fcntl( $w, F_SETFL, O_NONBLOCK )" if _debugging_details;
|
|
}
|
|
( $r, $w ) = ( _dup($r), _dup($w) );
|
|
_debug "pipe_nb() = ( $r, $w )" if _debugging_details;
|
|
return ( $r, $w );
|
|
}
|
|
|
|
sub _pty {
|
|
require IO::Pty;
|
|
my $pty = IO::Pty->new();
|
|
croak "$!: pty ()" unless $pty;
|
|
$pty->autoflush();
|
|
$pty->blocking(0) or croak "$!: pty->blocking ( 0 )";
|
|
_debug "pty() = ( ", $pty->fileno, ", ", $pty->slave->fileno, " )"
|
|
if _debugging_details;
|
|
@fds{ $pty->fileno, $pty->slave->fileno } = ( {}, {} );
|
|
return $pty;
|
|
}
|
|
|
|
sub _read {
|
|
confess 'undef' unless defined $_[0];
|
|
my $s = '';
|
|
my $r = POSIX::read( $_[0], $s, 10_000 );
|
|
croak "$!: read( $_[0] )" if not($r) and !$!{EINTR};
|
|
$r ||= 0;
|
|
_debug "read( $_[0] ) = $r chars '$s'" if _debugging_data;
|
|
return $s;
|
|
}
|
|
|
|
## A METHOD, not a function.
|
|
sub _spawn {
|
|
my IPC::Run $self = shift;
|
|
my ($kid) = @_;
|
|
|
|
_debug "opening sync pipe ", $kid->{PID} if _debugging_details;
|
|
my $sync_reader_fd;
|
|
( $sync_reader_fd, $self->{SYNC_WRITER_FD} ) = _pipe;
|
|
$kid->{PID} = fork();
|
|
croak "$! during fork" unless defined $kid->{PID};
|
|
|
|
unless ( $kid->{PID} ) {
|
|
## _do_kid_and_exit closes sync_reader_fd since it closes all unwanted and
|
|
## unloved fds.
|
|
$self->_do_kid_and_exit($kid);
|
|
}
|
|
_debug "fork() = ", $kid->{PID} if _debugging_details;
|
|
|
|
## Wait for kid to get to it's exec() and see if it fails.
|
|
_close $self->{SYNC_WRITER_FD};
|
|
my $sync_pulse = _read $sync_reader_fd;
|
|
_close $sync_reader_fd;
|
|
|
|
if ( !defined $sync_pulse || length $sync_pulse ) {
|
|
if ( waitpid( $kid->{PID}, 0 ) >= 0 ) {
|
|
$kid->{RESULT} = $?;
|
|
}
|
|
else {
|
|
$kid->{RESULT} = -1;
|
|
}
|
|
$sync_pulse = "error reading synchronization pipe for $kid->{NUM}, pid $kid->{PID}"
|
|
unless length $sync_pulse;
|
|
croak $sync_pulse;
|
|
}
|
|
return $kid->{PID};
|
|
|
|
## Wait for pty to get set up. This is a hack until we get synchronous
|
|
## selects.
|
|
if ( keys %{ $self->{PTYS} } && $IO::Pty::VERSION < 0.9 ) {
|
|
_debug "sleeping to give pty a chance to init, will fix when newer IO::Pty arrives.";
|
|
sleep 1;
|
|
}
|
|
}
|
|
|
|
sub _write {
|
|
confess 'undef' unless defined $_[0] && defined $_[1];
|
|
my $r = POSIX::write( $_[0], $_[1], length $_[1] );
|
|
croak "$!: write( $_[0], '$_[1]' )" unless $r;
|
|
_debug "write( $_[0], '$_[1]' ) = $r" if _debugging_data;
|
|
return $r;
|
|
}
|
|
|
|
=pod
|
|
|
|
=over
|
|
|
|
=item run
|
|
|
|
Run takes a harness or harness specification and runs it, pumping
|
|
all input to the child(ren), closing the input pipes when no more
|
|
input is available, collecting all output that arrives, until the
|
|
pipes delivering output are closed, then waiting for the children to
|
|
exit and reaping their result codes.
|
|
|
|
You may think of C<run( ... )> as being like
|
|
|
|
start( ... )->finish();
|
|
|
|
, though there is one subtle difference: run() does not
|
|
set \$input_scalars to '' like finish() does. If an exception is thrown
|
|
from run(), all children will be killed off "gently", and then "annihilated"
|
|
if they do not go gently (in to that dark night. sorry).
|
|
|
|
If any exceptions are thrown, this does a L</kill_kill> before propagating
|
|
them.
|
|
|
|
=cut
|
|
|
|
use vars qw( $in_run ); ## No, not Enron;)
|
|
|
|
sub run {
|
|
local $in_run = 1; ## Allow run()-only optimizations.
|
|
my IPC::Run $self = start(@_);
|
|
my $r = eval {
|
|
$self->{clear_ins} = 0;
|
|
$self->finish;
|
|
};
|
|
if ($@) {
|
|
my $x = $@;
|
|
$self->kill_kill;
|
|
die $x;
|
|
}
|
|
return $r;
|
|
}
|
|
|
|
=pod
|
|
|
|
=item signal
|
|
|
|
## To send it a specific signal by name ("USR1"):
|
|
signal $h, "USR1";
|
|
$h->signal ( "USR1" );
|
|
|
|
If $signal is provided and defined, sends a signal to all child processes. Try
|
|
not to send numeric signals, use C<"KILL"> instead of C<9>, for instance.
|
|
Numeric signals aren't portable.
|
|
|
|
Throws an exception if $signal is undef.
|
|
|
|
This will I<not> clean up the harness, C<finish> it if you kill it.
|
|
|
|
Normally TERM kills a process gracefully (this is what the command line utility
|
|
C<kill> does by default), INT is sent by one of the keys C<^C>, C<Backspace> or
|
|
C<E<lt>DelE<gt>>, and C<QUIT> is used to kill a process and make it coredump.
|
|
|
|
The C<HUP> signal is often used to get a process to "restart", rereading
|
|
config files, and C<USR1> and C<USR2> for really application-specific things.
|
|
|
|
Often, running C<kill -l> (that's a lower case "L") on the command line will
|
|
list the signals present on your operating system.
|
|
|
|
B<WARNING>: The signal subsystem is not at all portable. We *may* offer
|
|
to simulate C<TERM> and C<KILL> on some operating systems, submit code
|
|
to me if you want this.
|
|
|
|
B<WARNING 2>: Up to and including perl v5.6.1, doing almost anything in a
|
|
signal handler could be dangerous. The most safe code avoids all
|
|
mallocs and system calls, usually by preallocating a flag before
|
|
entering the signal handler, altering the flag's value in the
|
|
handler, and responding to the changed value in the main system:
|
|
|
|
my $got_usr1 = 0;
|
|
sub usr1_handler { ++$got_signal }
|
|
|
|
$SIG{USR1} = \&usr1_handler;
|
|
while () { sleep 1; print "GOT IT" while $got_usr1--; }
|
|
|
|
Even this approach is perilous if ++ and -- aren't atomic on your system
|
|
(I've never heard of this on any modern CPU large enough to run perl).
|
|
|
|
=cut
|
|
|
|
sub signal {
|
|
my IPC::Run $self = shift;
|
|
|
|
local $cur_self = $self;
|
|
|
|
$self->_kill_kill_kill_pussycat_kill unless @_;
|
|
|
|
Carp::cluck "Ignoring extra parameters passed to kill()" if @_ > 1;
|
|
|
|
my ($signal) = @_;
|
|
croak "Undefined signal passed to signal" unless defined $signal;
|
|
for ( grep $_->{PID} && !defined $_->{RESULT}, @{ $self->{KIDS} } ) {
|
|
_debug "sending $signal to $_->{PID}"
|
|
if _debugging;
|
|
kill $signal, $_->{PID}
|
|
or _debugging && _debug "$! sending $signal to $_->{PID}";
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
=pod
|
|
|
|
=item kill_kill
|
|
|
|
## To kill off a process:
|
|
$h->kill_kill;
|
|
kill_kill $h;
|
|
|
|
## To specify the grace period other than 30 seconds:
|
|
kill_kill $h, grace => 5;
|
|
|
|
## To send QUIT instead of KILL if a process refuses to die:
|
|
kill_kill $h, coup_d_grace => "QUIT";
|
|
|
|
Sends a C<TERM>, waits for all children to exit for up to 30 seconds, then
|
|
sends a C<KILL> to any that survived the C<TERM>.
|
|
|
|
Will wait for up to 30 more seconds for the OS to successfully C<KILL> the
|
|
processes.
|
|
|
|
The 30 seconds may be overridden by setting the C<grace> option, this
|
|
overrides both timers.
|
|
|
|
The harness is then cleaned up.
|
|
|
|
The doubled name indicates that this function may kill again and avoids
|
|
colliding with the core Perl C<kill> function.
|
|
|
|
Returns a 1 if the C<TERM> was sufficient, or a 0 if C<KILL> was
|
|
required. Throws an exception if C<KILL> did not permit the children
|
|
to be reaped.
|
|
|
|
B<NOTE>: The grace period is actually up to 1 second longer than that
|
|
given. This is because the granularity of C<time> is 1 second. Let me
|
|
know if you need finer granularity, we can leverage Time::HiRes here.
|
|
|
|
B<Win32>: Win32 does not know how to send real signals, so C<TERM> is
|
|
a full-force kill on Win32. Thus all talk of grace periods, etc. do
|
|
not apply to Win32.
|
|
|
|
=cut
|
|
|
|
sub kill_kill {
|
|
my IPC::Run $self = shift;
|
|
|
|
my %options = @_;
|
|
my $grace = $options{grace};
|
|
$grace = 30 unless defined $grace;
|
|
++$grace; ## Make grace time a _minimum_
|
|
|
|
my $coup_d_grace = $options{coup_d_grace};
|
|
$coup_d_grace = "KILL" unless defined $coup_d_grace;
|
|
|
|
delete $options{$_} for qw( grace coup_d_grace );
|
|
Carp::cluck "Ignoring unknown options for kill_kill: ",
|
|
join " ", keys %options
|
|
if keys %options;
|
|
|
|
if (Win32_MODE) {
|
|
# immediate brutal death for Win32
|
|
# TERM has unfortunate side-effects
|
|
$self->signal("KILL")
|
|
}
|
|
else {
|
|
$self->signal("TERM");
|
|
}
|
|
|
|
my $quitting_time = time + $grace;
|
|
my $delay = 0.01;
|
|
my $accum_delay;
|
|
|
|
my $have_killed_before;
|
|
|
|
while () {
|
|
## delay first to yield to other processes
|
|
select undef, undef, undef, $delay;
|
|
$accum_delay += $delay;
|
|
|
|
$self->reap_nb;
|
|
last unless $self->_running_kids;
|
|
|
|
if ( $accum_delay >= $grace * 0.8 ) {
|
|
## No point in checking until delay has grown some.
|
|
if ( time >= $quitting_time ) {
|
|
if ( !$have_killed_before ) {
|
|
$self->signal($coup_d_grace);
|
|
$have_killed_before = 1;
|
|
$quitting_time += $grace;
|
|
$delay = 0.01;
|
|
$accum_delay = 0;
|
|
next;
|
|
}
|
|
croak "Unable to reap all children, even after KILLing them";
|
|
}
|
|
}
|
|
|
|
$delay *= 2;
|
|
$delay = 0.5 if $delay >= 0.5;
|
|
}
|
|
|
|
$self->_cleanup;
|
|
return $have_killed_before;
|
|
}
|
|
|
|
=pod
|
|
|
|
=item harness
|
|
|
|
Takes a harness specification and returns a harness. This harness is
|
|
blessed in to IPC::Run, allowing you to use method call syntax for
|
|
run(), start(), et al if you like.
|
|
|
|
harness() is provided so that you can pre-build harnesses if you
|
|
would like to, but it's not required..
|
|
|
|
You may proceed to run(), start() or pump() after calling harness() (pump()
|
|
calls start() if need be). Alternatively, you may pass your
|
|
harness specification to run() or start() and let them harness() for
|
|
you. You can't pass harness specifications to pump(), though.
|
|
|
|
=cut
|
|
|
|
##
|
|
## Notes: I've avoided handling a scalar that doesn't look like an
|
|
## opcode as a here document or as a filename, though I could DWIM
|
|
## those. I'm not sure that the advantages outweigh the danger when
|
|
## the DWIMer guesses wrong.
|
|
##
|
|
## TODO: allow user to spec default shell. Hmm, globally, in the
|
|
## lexical scope hash, or per instance? 'Course they can do that
|
|
## now by using a [...] to hold the command.
|
|
##
|
|
my $harness_id = 0;
|
|
|
|
sub harness {
|
|
my $options;
|
|
if ( @_ && ref $_[-1] eq 'HASH' ) {
|
|
$options = pop;
|
|
require Data::Dumper;
|
|
carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper($options);
|
|
}
|
|
|
|
# local $IPC::Run::debug = $options->{debug}
|
|
# if $options && defined $options->{debug};
|
|
|
|
my @args;
|
|
if ( @_ == 1 && !ref $_[0] ) {
|
|
if (Win32_MODE) {
|
|
my $command = $ENV{ComSpec} || 'cmd';
|
|
@args = ( [ $command, '/c', win32_parse_cmd_line $_[0] ] );
|
|
}
|
|
else {
|
|
@args = ( [ qw( sh -c ), @_ ] );
|
|
}
|
|
}
|
|
elsif ( @_ > 1 && !grep ref $_, @_ ) {
|
|
@args = ( [@_] );
|
|
}
|
|
else {
|
|
@args = map { !defined $_ ? bless(\$_, 'IPC::Run::Undef') : $_ } @_;
|
|
}
|
|
|
|
my @errs; # Accum errors, emit them when done.
|
|
|
|
my $succinct; # set if no redir ops are required yet. Cleared
|
|
# if an op is seen.
|
|
|
|
my $cur_kid; # references kid or handle being parsed
|
|
my $next_kid_close_stdin = 0;
|
|
|
|
my $assumed_fd = 0; # fd to assume in succinct mode (no redir ops)
|
|
my $handle_num = 0; # 1... is which handle we're parsing
|
|
|
|
my IPC::Run $self = bless {}, __PACKAGE__;
|
|
|
|
local $cur_self = $self;
|
|
|
|
$self->{ID} = ++$harness_id;
|
|
$self->{IOS} = [];
|
|
$self->{KIDS} = [];
|
|
$self->{PIPES} = [];
|
|
$self->{PTYS} = {};
|
|
$self->{STATE} = _newed;
|
|
|
|
if ($options) {
|
|
$self->{$_} = $options->{$_} for keys %$options;
|
|
}
|
|
|
|
_debug "****** harnessing *****" if _debugging;
|
|
|
|
my $first_parse;
|
|
local $_;
|
|
my $arg_count = @args;
|
|
while (@args) {
|
|
for ( shift @args ) {
|
|
eval {
|
|
$first_parse = 1;
|
|
_debug(
|
|
"parsing ",
|
|
defined $_
|
|
? ref $_ eq 'ARRAY'
|
|
? ( '[ ', join( ', ', map "'$_'", @$_ ), ' ]' )
|
|
: (
|
|
ref $_
|
|
|| (
|
|
length $_ < 50
|
|
? "'$_'"
|
|
: join( '', "'", substr( $_, 0, 10 ), "...'" )
|
|
)
|
|
)
|
|
: '<undef>'
|
|
) if _debugging;
|
|
|
|
REPARSE:
|
|
if ( ref eq 'ARRAY' || ( !$cur_kid && ref eq 'CODE' ) ) {
|
|
croak "Process control symbol ('|', '&') missing" if $cur_kid;
|
|
croak "Can't spawn a subroutine on Win32"
|
|
if Win32_MODE && ref eq "CODE";
|
|
$cur_kid = {
|
|
TYPE => 'cmd',
|
|
VAL => $_,
|
|
NUM => @{ $self->{KIDS} } + 1,
|
|
OPS => [],
|
|
PID => '',
|
|
RESULT => undef,
|
|
};
|
|
|
|
unshift @{ $cur_kid->{OPS} }, {
|
|
TYPE => 'close',
|
|
KFD => 0,
|
|
} if $next_kid_close_stdin;
|
|
$next_kid_close_stdin = 0;
|
|
|
|
push @{ $self->{KIDS} }, $cur_kid;
|
|
$succinct = 1;
|
|
}
|
|
|
|
elsif ( UNIVERSAL::isa( $_, 'IPC::Run::IO' ) ) {
|
|
push @{ $self->{IOS} }, $_;
|
|
$cur_kid = undef;
|
|
$succinct = 1;
|
|
}
|
|
|
|
elsif ( UNIVERSAL::isa( $_, 'IPC::Run::Timer' ) ) {
|
|
push @{ $self->{TIMERS} }, $_;
|
|
$cur_kid = undef;
|
|
$succinct = 1;
|
|
}
|
|
|
|
elsif (/^(\d*)>&(\d+)$/) {
|
|
croak "No command before '$_'" unless $cur_kid;
|
|
push @{ $cur_kid->{OPS} }, {
|
|
TYPE => 'dup',
|
|
KFD1 => $2,
|
|
KFD2 => length $1 ? $1 : 1,
|
|
};
|
|
_debug "redirect operators now required" if _debugging_details;
|
|
$succinct = !$first_parse;
|
|
}
|
|
|
|
elsif (/^(\d*)<&(\d+)$/) {
|
|
croak "No command before '$_'" unless $cur_kid;
|
|
push @{ $cur_kid->{OPS} }, {
|
|
TYPE => 'dup',
|
|
KFD1 => $2,
|
|
KFD2 => length $1 ? $1 : 0,
|
|
};
|
|
$succinct = !$first_parse;
|
|
}
|
|
|
|
elsif (/^(\d*)<&-$/) {
|
|
croak "No command before '$_'" unless $cur_kid;
|
|
push @{ $cur_kid->{OPS} }, {
|
|
TYPE => 'close',
|
|
KFD => length $1 ? $1 : 0,
|
|
};
|
|
$succinct = !$first_parse;
|
|
}
|
|
|
|
elsif (/^(\d*) (<pipe)() () () $/x
|
|
|| /^(\d*) (<pty) ((?:\s+\S+)?) (<) () $/x
|
|
|| /^(\d*) (<) () () (.*)$/x ) {
|
|
croak "No command before '$_'" unless $cur_kid;
|
|
|
|
$succinct = !$first_parse;
|
|
|
|
my $type = $2 . $4;
|
|
|
|
my $kfd = length $1 ? $1 : 0;
|
|
|
|
my $pty_id;
|
|
if ( $type eq '<pty<' ) {
|
|
$pty_id = length $3 ? $3 : '0';
|
|
## do the require here to cause early error reporting
|
|
require IO::Pty;
|
|
## Just flag the pyt's existence for now. It'll be
|
|
## converted to a real IO::Pty by _open_pipes.
|
|
$self->{PTYS}->{$pty_id} = undef;
|
|
}
|
|
|
|
my $source = $5;
|
|
|
|
my @filters;
|
|
my $binmode;
|
|
|
|
unless ( length $source ) {
|
|
if ( !$succinct ) {
|
|
while ( @args > 1
|
|
&& ( ( ref $args[1] && !UNIVERSAL::isa $args[1], "IPC::Run::Timer" ) || UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) ) {
|
|
if ( UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
|
|
$binmode = shift(@args)->();
|
|
}
|
|
else {
|
|
push @filters, shift @args;
|
|
}
|
|
}
|
|
}
|
|
$source = shift @args;
|
|
croak "'$_' missing a source" if _empty $source;
|
|
|
|
_debug(
|
|
'Kid ', $cur_kid->{NUM}, "'s input fd ", $kfd,
|
|
' has ', scalar(@filters), ' filters.'
|
|
) if _debugging_details && @filters;
|
|
}
|
|
|
|
my IPC::Run::IO $pipe = IPC::Run::IO->_new_internal( $type, $kfd, $pty_id, $source, $binmode, @filters );
|
|
|
|
if ( ( ref $source eq 'GLOB' || UNIVERSAL::isa $source, 'IO::Handle' )
|
|
&& $type !~ /^<p(ty<|ipe)$/ ) {
|
|
_debug "setting DONT_CLOSE" if _debugging_details;
|
|
$pipe->{DONT_CLOSE} = 1; ## this FD is not closed by us.
|
|
_dont_inherit($source) if Win32_MODE;
|
|
}
|
|
|
|
push @{ $cur_kid->{OPS} }, $pipe;
|
|
}
|
|
|
|
elsif (
|
|
/^() (>>?) (&) () (.*)$/x
|
|
|| /^() (&) (>pipe) () () $/x
|
|
|| /^() (>pipe)(&) () () $/x
|
|
|| /^(\d*)() (>pipe) () () $/x
|
|
|| /^() (&) (>pty) ( \w*)> () $/x
|
|
## TODO: || /^() (>pty) (\d*)> (&) () $/x
|
|
|| /^(\d*)() (>pty) ( \w*)> () $/x
|
|
|| /^() (&) (>>?) () (.*)$/x || /^(\d*)() (>>?) () (.*)$/x
|
|
) {
|
|
croak "No command before '$_'" unless $cur_kid;
|
|
|
|
$succinct = !$first_parse;
|
|
|
|
my $type = (
|
|
$2 eq '>pipe' || $3 eq '>pipe' ? '>pipe'
|
|
: $2 eq '>pty' || $3 eq '>pty' ? '>pty>'
|
|
: '>'
|
|
);
|
|
my $kfd = length $1 ? $1 : 1;
|
|
my $trunc = !( $2 eq '>>' || $3 eq '>>' );
|
|
my $pty_id = (
|
|
$2 eq '>pty' || $3 eq '>pty'
|
|
? length $4
|
|
? $4
|
|
: 0
|
|
: undef
|
|
);
|
|
|
|
my $stderr_too =
|
|
$2 eq '&'
|
|
|| $3 eq '&'
|
|
|| ( !length $1 && substr( $type, 0, 4 ) eq '>pty' );
|
|
|
|
my $dest = $5;
|
|
my @filters;
|
|
my $binmode = 0;
|
|
unless ( length $dest ) {
|
|
if ( !$succinct ) {
|
|
## unshift...shift: '>' filters source...sink left...right
|
|
while ( @args > 1
|
|
&& ( ( ref $args[1] && !UNIVERSAL::isa $args[1], "IPC::Run::Timer" ) || UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) ) {
|
|
if ( UNIVERSAL::isa $args[0], "IPC::Run::binmode_pseudo_filter" ) {
|
|
$binmode = shift(@args)->();
|
|
}
|
|
else {
|
|
unshift @filters, shift @args;
|
|
}
|
|
}
|
|
}
|
|
|
|
if ( @args && ref $args[0] eq 'IPC::Run::Undef' ) {
|
|
require Symbol;
|
|
${ $args[0] } = $dest = Symbol::gensym();
|
|
shift @args;
|
|
}
|
|
else {
|
|
$dest = shift @args;
|
|
}
|
|
|
|
_debug(
|
|
'Kid ', $cur_kid->{NUM}, "'s output fd ", $kfd,
|
|
' has ', scalar(@filters), ' filters.'
|
|
) if _debugging_details && @filters;
|
|
|
|
if ( $type eq '>pty>' ) {
|
|
## do the require here to cause early error reporting
|
|
require IO::Pty;
|
|
## Just flag the pyt's existence for now. _open_pipes()
|
|
## will new an IO::Pty for each key.
|
|
$self->{PTYS}->{$pty_id} = undef;
|
|
}
|
|
}
|
|
|
|
croak "'$_' missing a destination" if _empty $dest;
|
|
my $pipe = IPC::Run::IO->_new_internal( $type, $kfd, $pty_id, $dest, $binmode, @filters );
|
|
$pipe->{TRUNC} = $trunc;
|
|
|
|
if ( ( UNIVERSAL::isa( $dest, 'GLOB' ) || UNIVERSAL::isa( $dest, 'IO::Handle' ) )
|
|
&& $type !~ /^>(pty>|pipe)$/ ) {
|
|
_debug "setting DONT_CLOSE" if _debugging_details;
|
|
$pipe->{DONT_CLOSE} = 1; ## this FD is not closed by us.
|
|
}
|
|
push @{ $cur_kid->{OPS} }, $pipe;
|
|
push @{ $cur_kid->{OPS} }, {
|
|
TYPE => 'dup',
|
|
KFD1 => 1,
|
|
KFD2 => 2,
|
|
} if $stderr_too;
|
|
}
|
|
|
|
elsif ( $_ eq "|" ) {
|
|
croak "No command before '$_'" unless $cur_kid;
|
|
unshift @{ $cur_kid->{OPS} }, {
|
|
TYPE => '|',
|
|
KFD => 1,
|
|
};
|
|
$succinct = 1;
|
|
$assumed_fd = 1;
|
|
$cur_kid = undef;
|
|
}
|
|
|
|
elsif ( $_ eq "&" ) {
|
|
croak "No command before '$_'" unless $cur_kid;
|
|
$next_kid_close_stdin = 1;
|
|
$succinct = 1;
|
|
$assumed_fd = 0;
|
|
$cur_kid = undef;
|
|
}
|
|
|
|
elsif ( $_ eq 'init' ) {
|
|
croak "No command before '$_'" unless $cur_kid;
|
|
push @{ $cur_kid->{OPS} }, {
|
|
TYPE => 'init',
|
|
SUB => shift @args,
|
|
};
|
|
}
|
|
|
|
elsif ( !ref $_ ) {
|
|
$self->{$_} = shift @args;
|
|
}
|
|
|
|
elsif ( $_ eq 'init' ) {
|
|
croak "No command before '$_'" unless $cur_kid;
|
|
push @{ $cur_kid->{OPS} }, {
|
|
TYPE => 'init',
|
|
SUB => shift @args,
|
|
};
|
|
}
|
|
|
|
elsif ( $succinct && $first_parse ) {
|
|
## It's not an opcode, and no explicit opcodes have been
|
|
## seen yet, so assume it's a file name.
|
|
unshift @args, $_;
|
|
if ( !$assumed_fd ) {
|
|
$_ = "$assumed_fd<",
|
|
}
|
|
else {
|
|
$_ = "$assumed_fd>",
|
|
}
|
|
_debug "assuming '", $_, "'" if _debugging_details;
|
|
++$assumed_fd;
|
|
$first_parse = 0;
|
|
goto REPARSE;
|
|
}
|
|
|
|
else {
|
|
croak join(
|
|
'',
|
|
'Unexpected ',
|
|
( ref() ? $_ : 'scalar' ),
|
|
' in harness() parameter ',
|
|
$arg_count - @args
|
|
);
|
|
}
|
|
};
|
|
if ($@) {
|
|
push @errs, $@;
|
|
_debug 'caught ', $@ if _debugging;
|
|
}
|
|
}
|
|
}
|
|
|
|
die join( '', @errs ) if @errs;
|
|
|
|
$self->{STATE} = _harnessed;
|
|
|
|
# $self->timeout( $options->{timeout} ) if exists $options->{timeout};
|
|
return $self;
|
|
}
|
|
|
|
sub _open_pipes {
|
|
my IPC::Run $self = shift;
|
|
|
|
my @errs;
|
|
|
|
my @close_on_fail;
|
|
|
|
## When a pipe character is seen, a pipe is created. $pipe_read_fd holds
|
|
## the dangling read end of the pipe until we get to the next process.
|
|
my $pipe_read_fd;
|
|
|
|
## Output descriptors for the last command are shared by all children.
|
|
## @output_fds_accum accumulates the current set of output fds.
|
|
my @output_fds_accum;
|
|
|
|
for ( sort keys %{ $self->{PTYS} } ) {
|
|
_debug "opening pty '", $_, "'" if _debugging_details;
|
|
my $pty = _pty;
|
|
$self->{PTYS}->{$_} = $pty;
|
|
}
|
|
|
|
for ( @{ $self->{IOS} } ) {
|
|
eval { $_->init; };
|
|
if ($@) {
|
|
push @errs, $@;
|
|
_debug 'caught ', $@ if _debugging;
|
|
}
|
|
else {
|
|
push @close_on_fail, $_;
|
|
}
|
|
}
|
|
|
|
## Loop through the kids and their OPS, interpreting any that require
|
|
## parent-side actions.
|
|
for my $kid ( @{ $self->{KIDS} } ) {
|
|
unless ( ref $kid->{VAL} eq 'CODE' ) {
|
|
$kid->{PATH} = _search_path $kid->{VAL}->[0];
|
|
}
|
|
if ( defined $pipe_read_fd ) {
|
|
_debug "placing write end of pipe on kid $kid->{NUM}'s stdin"
|
|
if _debugging_details;
|
|
unshift @{ $kid->{OPS} }, {
|
|
TYPE => 'PIPE', ## Prevent next loop from triggering on this
|
|
KFD => 0,
|
|
TFD => $pipe_read_fd,
|
|
};
|
|
$pipe_read_fd = undef;
|
|
}
|
|
@output_fds_accum = ();
|
|
for my $op ( @{ $kid->{OPS} } ) {
|
|
|
|
# next if $op->{IS_DEBUG};
|
|
my $ok = eval {
|
|
if ( $op->{TYPE} eq '<' ) {
|
|
my $source = $op->{SOURCE};
|
|
if ( !ref $source ) {
|
|
_debug(
|
|
"kid ", $kid->{NUM}, " to read ", $op->{KFD},
|
|
" from '" . $source, "' (read only)"
|
|
) if _debugging_details;
|
|
croak "simulated open failure"
|
|
if $self->{_simulate_open_failure};
|
|
$op->{TFD} = _sysopen( $source, O_RDONLY );
|
|
push @close_on_fail, $op->{TFD};
|
|
}
|
|
elsif (UNIVERSAL::isa( $source, 'GLOB' )
|
|
|| UNIVERSAL::isa( $source, 'IO::Handle' ) ) {
|
|
croak "Unopened filehandle in input redirect for $op->{KFD}"
|
|
unless defined fileno $source;
|
|
$op->{TFD} = fileno $source;
|
|
_debug(
|
|
"kid ", $kid->{NUM}, " to read ", $op->{KFD},
|
|
" from fd ", $op->{TFD}
|
|
) if _debugging_details;
|
|
}
|
|
elsif ( UNIVERSAL::isa( $source, 'SCALAR' ) ) {
|
|
_debug(
|
|
"kid ", $kid->{NUM}, " to read ", $op->{KFD},
|
|
" from SCALAR"
|
|
) if _debugging_details;
|
|
|
|
$op->open_pipe( $self->_debug_fd );
|
|
push @close_on_fail, $op->{KFD}, $op->{FD};
|
|
|
|
my $s = '';
|
|
$op->{KIN_REF} = \$s;
|
|
}
|
|
elsif ( UNIVERSAL::isa( $source, 'CODE' ) ) {
|
|
_debug( 'kid ', $kid->{NUM}, ' to read ', $op->{KFD}, ' from CODE' ) if _debugging_details;
|
|
|
|
$op->open_pipe( $self->_debug_fd );
|
|
push @close_on_fail, $op->{KFD}, $op->{FD};
|
|
|
|
my $s = '';
|
|
$op->{KIN_REF} = \$s;
|
|
}
|
|
else {
|
|
croak( "'" . ref($source) . "' not allowed as a source for input redirection" );
|
|
}
|
|
$op->_init_filters;
|
|
}
|
|
elsif ( $op->{TYPE} eq '<pipe' ) {
|
|
_debug(
|
|
'kid to read ', $op->{KFD},
|
|
' from a pipe IPC::Run opens and returns',
|
|
) if _debugging_details;
|
|
|
|
my ( $r, $w ) = $op->open_pipe( $self->_debug_fd, $op->{SOURCE} );
|
|
_debug "caller will write to ", fileno $op->{SOURCE}
|
|
if _debugging_details;
|
|
|
|
$op->{TFD} = $r;
|
|
$op->{FD} = undef; # we don't manage this fd
|
|
$op->_init_filters;
|
|
}
|
|
elsif ( $op->{TYPE} eq '<pty<' ) {
|
|
_debug(
|
|
'kid to read ', $op->{KFD}, " from pty '", $op->{PTY_ID}, "'",
|
|
) if _debugging_details;
|
|
|
|
for my $source ( $op->{SOURCE} ) {
|
|
if ( UNIVERSAL::isa( $source, 'SCALAR' ) ) {
|
|
_debug(
|
|
"kid ", $kid->{NUM}, " to read ", $op->{KFD},
|
|
" from SCALAR via pty '", $op->{PTY_ID}, "'"
|
|
) if _debugging_details;
|
|
|
|
my $s = '';
|
|
$op->{KIN_REF} = \$s;
|
|
}
|
|
elsif ( UNIVERSAL::isa( $source, 'CODE' ) ) {
|
|
_debug(
|
|
"kid ", $kid->{NUM}, " to read ", $op->{KFD},
|
|
" from CODE via pty '", $op->{PTY_ID}, "'"
|
|
) if _debugging_details;
|
|
my $s = '';
|
|
$op->{KIN_REF} = \$s;
|
|
}
|
|
else {
|
|
croak( "'" . ref($source) . "' not allowed as a source for '<pty<' redirection" );
|
|
}
|
|
}
|
|
$op->{FD} = $self->{PTYS}->{ $op->{PTY_ID} }->fileno;
|
|
$op->{TFD} = undef; # The fd isn't known until after fork().
|
|
$op->_init_filters;
|
|
}
|
|
elsif ( $op->{TYPE} eq '>' ) {
|
|
## N> output redirection.
|
|
my $dest = $op->{DEST};
|
|
if ( !ref $dest ) {
|
|
_debug(
|
|
"kid ", $kid->{NUM}, " to write ", $op->{KFD},
|
|
" to '", $dest, "' (write only, create, ",
|
|
( $op->{TRUNC} ? 'truncate' : 'append' ),
|
|
")"
|
|
) if _debugging_details;
|
|
croak "simulated open failure"
|
|
if $self->{_simulate_open_failure};
|
|
$op->{TFD} = _sysopen(
|
|
$dest,
|
|
( O_WRONLY | O_CREAT | ( $op->{TRUNC} ? O_TRUNC : O_APPEND ) )
|
|
);
|
|
if (Win32_MODE) {
|
|
## I have no idea why this is needed to make the current
|
|
## file position survive the gyrations TFD must go
|
|
## through...
|
|
POSIX::lseek( $op->{TFD}, 0, POSIX::SEEK_END() );
|
|
}
|
|
push @close_on_fail, $op->{TFD};
|
|
}
|
|
elsif ( UNIVERSAL::isa( $dest, 'GLOB' ) ) {
|
|
croak("Unopened filehandle in output redirect, command $kid->{NUM}") unless defined fileno $dest;
|
|
## Turn on autoflush, mostly just to flush out
|
|
## existing output.
|
|
my $old_fh = select($dest);
|
|
$| = 1;
|
|
select($old_fh);
|
|
$op->{TFD} = fileno $dest;
|
|
_debug( 'kid to write ', $op->{KFD}, ' to handle ', $op->{TFD} ) if _debugging_details;
|
|
}
|
|
elsif ( UNIVERSAL::isa( $dest, 'SCALAR' ) ) {
|
|
_debug( "kid ", $kid->{NUM}, " to write $op->{KFD} to SCALAR" ) if _debugging_details;
|
|
|
|
$op->open_pipe( $self->_debug_fd );
|
|
push @close_on_fail, $op->{FD}, $op->{TFD};
|
|
$$dest = '' if $op->{TRUNC};
|
|
}
|
|
elsif ( UNIVERSAL::isa( $dest, 'CODE' ) ) {
|
|
_debug("kid $kid->{NUM} to write $op->{KFD} to CODE") if _debugging_details;
|
|
|
|
$op->open_pipe( $self->_debug_fd );
|
|
push @close_on_fail, $op->{FD}, $op->{TFD};
|
|
}
|
|
else {
|
|
croak( "'" . ref($dest) . "' not allowed as a sink for output redirection" );
|
|
}
|
|
$output_fds_accum[ $op->{KFD} ] = $op;
|
|
$op->_init_filters;
|
|
}
|
|
|
|
elsif ( $op->{TYPE} eq '>pipe' ) {
|
|
## N> output redirection to a pipe we open, but don't select()
|
|
## on.
|
|
_debug(
|
|
"kid ", $kid->{NUM}, " to write ", $op->{KFD},
|
|
' to a pipe IPC::Run opens and returns'
|
|
) if _debugging_details;
|
|
|
|
my ( $r, $w ) = $op->open_pipe( $self->_debug_fd, $op->{DEST} );
|
|
_debug "caller will read from ", fileno $op->{DEST}
|
|
if _debugging_details;
|
|
|
|
$op->{TFD} = $w;
|
|
$op->{FD} = undef; # we don't manage this fd
|
|
$op->_init_filters;
|
|
|
|
$output_fds_accum[ $op->{KFD} ] = $op;
|
|
}
|
|
elsif ( $op->{TYPE} eq '>pty>' ) {
|
|
my $dest = $op->{DEST};
|
|
if ( UNIVERSAL::isa( $dest, 'SCALAR' ) ) {
|
|
_debug(
|
|
"kid ", $kid->{NUM}, " to write ", $op->{KFD},
|
|
" to SCALAR via pty '", $op->{PTY_ID}, "'"
|
|
) if _debugging_details;
|
|
|
|
$$dest = '' if $op->{TRUNC};
|
|
}
|
|
elsif ( UNIVERSAL::isa( $dest, 'CODE' ) ) {
|
|
_debug(
|
|
"kid ", $kid->{NUM}, " to write ", $op->{KFD},
|
|
" to CODE via pty '", $op->{PTY_ID}, "'"
|
|
) if _debugging_details;
|
|
}
|
|
else {
|
|
croak( "'" . ref($dest) . "' not allowed as a sink for output redirection" );
|
|
}
|
|
|
|
$op->{FD} = $self->{PTYS}->{ $op->{PTY_ID} }->fileno;
|
|
$op->{TFD} = undef; # The fd isn't known until after fork().
|
|
$output_fds_accum[ $op->{KFD} ] = $op;
|
|
$op->_init_filters;
|
|
}
|
|
elsif ( $op->{TYPE} eq '|' ) {
|
|
_debug( "pipelining $kid->{NUM} and " . ( $kid->{NUM} + 1 ) ) if _debugging_details;
|
|
( $pipe_read_fd, $op->{TFD} ) = _pipe;
|
|
if (Win32_MODE) {
|
|
_dont_inherit($pipe_read_fd);
|
|
_dont_inherit( $op->{TFD} );
|
|
}
|
|
@output_fds_accum = ();
|
|
}
|
|
elsif ( $op->{TYPE} eq '&' ) {
|
|
@output_fds_accum = ();
|
|
} # end if $op->{TYPE} tree
|
|
1;
|
|
}; # end eval
|
|
unless ($ok) {
|
|
push @errs, $@;
|
|
_debug 'caught ', $@ if _debugging;
|
|
}
|
|
} # end for ( OPS }
|
|
}
|
|
|
|
if (@errs) {
|
|
for (@close_on_fail) {
|
|
_close($_);
|
|
$_ = undef;
|
|
}
|
|
for ( keys %{ $self->{PTYS} } ) {
|
|
next unless $self->{PTYS}->{$_};
|
|
close $self->{PTYS}->{$_};
|
|
$self->{PTYS}->{$_} = undef;
|
|
}
|
|
die join( '', @errs );
|
|
}
|
|
|
|
## give all but the last child all of the output file descriptors
|
|
## These will be reopened (and thus rendered useless) if the child
|
|
## dup2s on to these descriptors, since we unshift these. This way
|
|
## each process emits output to the same file descriptors that the
|
|
## last child will write to. This is probably not quite correct,
|
|
## since each child should write to the file descriptors inherited
|
|
## from the parent.
|
|
## TODO: fix the inheritance of output file descriptors.
|
|
## NOTE: This sharing of OPS among kids means that we can't easily put
|
|
## a kid number in each OPS structure to ping the kid when all ops
|
|
## have closed (when $self->{PIPES} has emptied). This means that we
|
|
## need to scan the KIDS whenever @{$self->{PIPES}} is empty to see
|
|
## if there any of them are still alive.
|
|
for ( my $num = 0; $num < $#{ $self->{KIDS} }; ++$num ) {
|
|
for ( reverse @output_fds_accum ) {
|
|
next unless defined $_;
|
|
_debug(
|
|
'kid ', $self->{KIDS}->[$num]->{NUM}, ' also to write ', $_->{KFD},
|
|
' to ', ref $_->{DEST}
|
|
) if _debugging_details;
|
|
unshift @{ $self->{KIDS}->[$num]->{OPS} }, $_;
|
|
}
|
|
}
|
|
|
|
## Open the debug pipe if we need it
|
|
## Create the list of PIPES we need to scan and the bit vectors needed by
|
|
## select(). Do this first so that _cleanup can _clobber() them if an
|
|
## exception occurs.
|
|
@{ $self->{PIPES} } = ();
|
|
$self->{RIN} = '';
|
|
$self->{WIN} = '';
|
|
$self->{EIN} = '';
|
|
## PIN is a vec()tor that indicates who's paused.
|
|
$self->{PIN} = '';
|
|
for my $kid ( @{ $self->{KIDS} } ) {
|
|
for ( @{ $kid->{OPS} } ) {
|
|
if ( defined $_->{FD} ) {
|
|
_debug(
|
|
'kid ', $kid->{NUM}, '[', $kid->{PID}, "]'s ", $_->{KFD},
|
|
' is my ', $_->{FD}
|
|
) if _debugging_details;
|
|
vec( $self->{ $_->{TYPE} =~ /^</ ? 'WIN' : 'RIN' }, $_->{FD}, 1 ) = 1;
|
|
|
|
# vec( $self->{EIN}, $_->{FD}, 1 ) = 1;
|
|
push @{ $self->{PIPES} }, $_;
|
|
}
|
|
}
|
|
}
|
|
|
|
for my $io ( @{ $self->{IOS} } ) {
|
|
my $fd = $io->fileno;
|
|
vec( $self->{RIN}, $fd, 1 ) = 1 if $io->mode =~ /r/;
|
|
vec( $self->{WIN}, $fd, 1 ) = 1 if $io->mode =~ /w/;
|
|
|
|
# vec( $self->{EIN}, $fd, 1 ) = 1;
|
|
push @{ $self->{PIPES} }, $io;
|
|
}
|
|
|
|
## Put filters on the end of the filter chains to read & write the pipes.
|
|
## Clear pipe states
|
|
for my $pipe ( @{ $self->{PIPES} } ) {
|
|
$pipe->{SOURCE_EMPTY} = 0;
|
|
$pipe->{PAUSED} = 0;
|
|
if ( $pipe->{TYPE} =~ /^>/ ) {
|
|
my $pipe_reader = sub {
|
|
my ( undef, $out_ref ) = @_;
|
|
|
|
return undef unless defined $pipe->{FD};
|
|
return 0 unless vec( $self->{ROUT}, $pipe->{FD}, 1 );
|
|
|
|
vec( $self->{ROUT}, $pipe->{FD}, 1 ) = 0;
|
|
|
|
_debug_desc_fd( 'reading from', $pipe ) if _debugging_details;
|
|
my $in = eval { _read( $pipe->{FD} ) };
|
|
if ($@) {
|
|
$in = '';
|
|
## IO::Pty throws the Input/output error if the kid dies.
|
|
## read() throws the bad file descriptor message if the
|
|
## kid dies on Win32.
|
|
die $@
|
|
unless $@ =~ $_EIO
|
|
|| ( $@ =~ /input or output/ && $^O =~ /aix/ )
|
|
|| ( Win32_MODE && $@ =~ /Bad file descriptor/ );
|
|
}
|
|
|
|
unless ( length $in ) {
|
|
$self->_clobber($pipe);
|
|
return undef;
|
|
}
|
|
|
|
## Protect the position so /.../g matches may be used.
|
|
my $pos = pos $$out_ref;
|
|
$$out_ref .= $in;
|
|
pos($$out_ref) = $pos;
|
|
return 1;
|
|
};
|
|
## Input filters are the last filters
|
|
push @{ $pipe->{FILTERS} }, $pipe_reader;
|
|
push @{ $self->{TEMP_FILTERS} }, $pipe_reader;
|
|
}
|
|
else {
|
|
my $pipe_writer = sub {
|
|
my ( $in_ref, $out_ref ) = @_;
|
|
return undef unless defined $pipe->{FD};
|
|
return 0
|
|
unless vec( $self->{WOUT}, $pipe->{FD}, 1 )
|
|
|| $pipe->{PAUSED};
|
|
|
|
vec( $self->{WOUT}, $pipe->{FD}, 1 ) = 0;
|
|
|
|
if ( !length $$in_ref ) {
|
|
if ( !defined get_more_input ) {
|
|
$self->_clobber($pipe);
|
|
return undef;
|
|
}
|
|
}
|
|
|
|
unless ( length $$in_ref ) {
|
|
unless ( $pipe->{PAUSED} ) {
|
|
_debug_desc_fd( 'pausing', $pipe ) if _debugging_details;
|
|
vec( $self->{WIN}, $pipe->{FD}, 1 ) = 0;
|
|
|
|
# vec( $self->{EIN}, $pipe->{FD}, 1 ) = 0;
|
|
vec( $self->{PIN}, $pipe->{FD}, 1 ) = 1;
|
|
$pipe->{PAUSED} = 1;
|
|
}
|
|
return 0;
|
|
}
|
|
_debug_desc_fd( 'writing to', $pipe ) if _debugging_details;
|
|
|
|
if ( length $$in_ref && $$in_ref ) {
|
|
my $c = _write( $pipe->{FD}, $$in_ref );
|
|
substr( $$in_ref, 0, $c, '' );
|
|
}
|
|
else {
|
|
$self->_clobber($pipe);
|
|
return undef;
|
|
}
|
|
|
|
return 1;
|
|
};
|
|
## Output filters are the first filters
|
|
unshift @{ $pipe->{FILTERS} }, $pipe_writer;
|
|
push @{ $self->{TEMP_FILTERS} }, $pipe_writer;
|
|
}
|
|
}
|
|
}
|
|
|
|
sub _dup2_gently {
|
|
## A METHOD, NOT A FUNCTION, NEEDS $self!
|
|
my IPC::Run $self = shift;
|
|
my ( $files, $fd1, $fd2 ) = @_;
|
|
## Moves TFDs that are using the destination fd out of the
|
|
## way before calling _dup2
|
|
for (@$files) {
|
|
next unless defined $_->{TFD};
|
|
$_->{TFD} = _dup( $_->{TFD} ) if $_->{TFD} == $fd2;
|
|
}
|
|
if ( defined $self->{DEBUG_FD} && $self->{DEBUG_FD} == $fd2 ) {
|
|
$self->{DEBUG_FD} = _dup $self->{DEBUG_FD};
|
|
$fds{$self->{DEBUG_FD}}{needed} = 1;
|
|
}
|
|
_dup2_rudely( $fd1, $fd2 );
|
|
}
|
|
|
|
=pod
|
|
|
|
=item close_terminal
|
|
|
|
This is used as (or in) an init sub to cast off the bonds of a controlling
|
|
terminal. It must precede all other redirection ops that affect
|
|
STDIN, STDOUT, or STDERR to be guaranteed effective.
|
|
|
|
=cut
|
|
|
|
sub close_terminal {
|
|
## Cast of the bonds of a controlling terminal
|
|
|
|
# Just in case the parent (I'm talking to you FCGI) had these tied.
|
|
untie *STDIN;
|
|
untie *STDOUT;
|
|
untie *STDERR;
|
|
|
|
POSIX::setsid() || croak "POSIX::setsid() failed";
|
|
_debug "closing stdin, out, err"
|
|
if _debugging_details;
|
|
close STDIN;
|
|
close STDERR;
|
|
close STDOUT;
|
|
}
|
|
|
|
sub _do_kid_and_exit {
|
|
my IPC::Run $self = shift;
|
|
my ($kid) = @_;
|
|
|
|
my ( $s1, $s2 );
|
|
if ( $] < 5.008 ) {
|
|
## For unknown reasons, placing these two statements in the eval{}
|
|
## causes the eval {} to not catch errors after they are executed in
|
|
## perl 5.6.0, godforsaken version that it is...not sure about 5.6.1.
|
|
## Part of this could be that these symbols get destructed when
|
|
## exiting the eval, and that destruction might be what's (wrongly)
|
|
## confusing the eval{}, allowing the exception to propagate.
|
|
$s1 = Symbol::gensym();
|
|
$s2 = Symbol::gensym();
|
|
}
|
|
|
|
eval {
|
|
local $cur_self = $self;
|
|
|
|
if (_debugging) {
|
|
_set_child_debug_name(
|
|
ref $kid->{VAL} eq "CODE"
|
|
? "CODE"
|
|
: basename( $kid->{VAL}->[0] )
|
|
);
|
|
}
|
|
|
|
## close parent FD's first so they're out of the way.
|
|
## Don't close STDIN, STDOUT, STDERR: they should be inherited or
|
|
## overwritten below.
|
|
do { $_->{needed} = 1 for @fds{0..2} }
|
|
unless $self->{noinherit};
|
|
|
|
$fds{$self->{SYNC_WRITER_FD}}{needed} = 1;
|
|
$fds{$self->{DEBUG_FD}}{needed} = 1 if defined $self->{DEBUG_FD};
|
|
|
|
$fds{$_->{TFD}}{needed} = 1
|
|
foreach grep { defined $_->{TFD} } @{$kid->{OPS} };
|
|
|
|
|
|
## TODO: use the forthcoming IO::Pty to close the terminal and
|
|
## make the first pty for this child the controlling terminal.
|
|
## This will also make it so that pty-laden kids don't cause
|
|
## other kids to lose stdin/stdout/stderr.
|
|
|
|
if ( %{ $self->{PTYS} } ) {
|
|
## Clean up the parent's fds.
|
|
for ( keys %{ $self->{PTYS} } ) {
|
|
_debug "Cleaning up parent's ptty '$_'" if _debugging_details;
|
|
$self->{PTYS}->{$_}->make_slave_controlling_terminal;
|
|
my $slave = $self->{PTYS}->{$_}->slave;
|
|
delete $fds{$self->{PTYS}->{$_}->fileno};
|
|
close $self->{PTYS}->{$_};
|
|
$self->{PTYS}->{$_} = $slave;
|
|
}
|
|
|
|
close_terminal;
|
|
delete @fds{0..2};
|
|
}
|
|
|
|
for my $sibling ( @{ $self->{KIDS} } ) {
|
|
for ( @{ $sibling->{OPS} } ) {
|
|
if ( $_->{TYPE} =~ /^.pty.$/ ) {
|
|
$_->{TFD} = $self->{PTYS}->{ $_->{PTY_ID} }->fileno;
|
|
$fds{$_->{TFD}}{needed} = 1;
|
|
}
|
|
|
|
# for ( $_->{FD}, ( $sibling != $kid ? $_->{TFD} : () ) ) {
|
|
# if ( defined $_ && ! $closed[$_] && ! $needed[$_] ) {
|
|
# _close( $_ );
|
|
# $closed[$_] = 1;
|
|
# $_ = undef;
|
|
# }
|
|
# }
|
|
}
|
|
}
|
|
|
|
## This is crude: we have no way of keeping track of browsing all open
|
|
## fds, so we scan to a fairly high fd.
|
|
_debug "open fds: ", join " ", keys %fds if _debugging_details;
|
|
|
|
_close( $_ ) foreach grep { ! $fds{$_}{needed} } keys %fds;
|
|
|
|
for ( @{ $kid->{OPS} } ) {
|
|
if ( defined $_->{TFD} ) {
|
|
|
|
# we're always creating KFD
|
|
$fds{$_->{KFD}}{needed} = 1;
|
|
|
|
unless ( $_->{TFD} == $_->{KFD} ) {
|
|
$self->_dup2_gently( $kid->{OPS}, $_->{TFD}, $_->{KFD} );
|
|
$fds{$_->{TFD}}{lazy_close} = 1;
|
|
} else {
|
|
my $fd = _dup($_->{TFD});
|
|
$self->_dup2_gently( $kid->{OPS}, $fd, $_->{KFD} );
|
|
_close($fd);
|
|
}
|
|
}
|
|
elsif ( $_->{TYPE} eq 'dup' ) {
|
|
$self->_dup2_gently( $kid->{OPS}, $_->{KFD1}, $_->{KFD2} )
|
|
unless $_->{KFD1} == $_->{KFD2};
|
|
$fds{$_->{KFD2}}{needed} = 1;
|
|
}
|
|
elsif ( $_->{TYPE} eq 'close' ) {
|
|
for ( $_->{KFD} ) {
|
|
if ( $fds{$_} ) {
|
|
_close($_);
|
|
$_ = undef;
|
|
}
|
|
}
|
|
}
|
|
elsif ( $_->{TYPE} eq 'init' ) {
|
|
$_->{SUB}->();
|
|
}
|
|
}
|
|
|
|
_close( $_ ) foreach grep { $fds{$_}{lazy_close} } keys %fds;
|
|
|
|
if ( ref $kid->{VAL} ne 'CODE' ) {
|
|
open $s1, ">&=$self->{SYNC_WRITER_FD}"
|
|
or croak "$! setting filehandle to fd SYNC_WRITER_FD";
|
|
fcntl $s1, F_SETFD, 1;
|
|
|
|
if ( defined $self->{DEBUG_FD} ) {
|
|
open $s2, ">&=$self->{DEBUG_FD}"
|
|
or croak "$! setting filehandle to fd DEBUG_FD";
|
|
fcntl $s2, F_SETFD, 1;
|
|
}
|
|
|
|
if (_debugging) {
|
|
my @cmd = ( $kid->{PATH}, @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ] );
|
|
_debug 'execing ', join " ", map { /[\s\"]/ ? "'$_'" : $_ } @cmd;
|
|
}
|
|
|
|
die "exec failed: simulating exec() failure"
|
|
if $self->{_simulate_exec_failure};
|
|
|
|
_exec $kid->{PATH}, @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ];
|
|
|
|
croak "exec failed: $!";
|
|
}
|
|
};
|
|
if ($@) {
|
|
_write $self->{SYNC_WRITER_FD}, $@;
|
|
## Avoid DESTROY.
|
|
POSIX::_exit(1);
|
|
}
|
|
|
|
## We must be executing code in the child, otherwise exec() would have
|
|
## prevented us from being here.
|
|
_close $self->{SYNC_WRITER_FD};
|
|
_debug 'calling fork()ed CODE ref' if _debugging;
|
|
POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD};
|
|
## TODO: Overload CORE::GLOBAL::exit...
|
|
$kid->{VAL}->();
|
|
|
|
## There are bugs in perl closures up to and including 5.6.1
|
|
## that may keep this next line from having any effect, and it
|
|
## won't have any effect if our caller has kept a copy of it, but
|
|
## this may cause the closure to be cleaned up. Maybe.
|
|
$kid->{VAL} = undef;
|
|
|
|
## Use POSIX::_exit to avoid global destruction, since this might
|
|
## cause DESTROY() to be called on objects created in the parent
|
|
## and thus cause double cleanup. For instance, if DESTROY() unlinks
|
|
## a file in the child, we don't want the parent to suddenly miss
|
|
## it.
|
|
POSIX::_exit(0);
|
|
}
|
|
|
|
=pod
|
|
|
|
=item start
|
|
|
|
$h = start(
|
|
\@cmd, \$in, \$out, ...,
|
|
timeout( 30, name => "process timeout" ),
|
|
$stall_timeout = timeout( 10, name => "stall timeout" ),
|
|
);
|
|
|
|
$h = start \@cmd, '<', \$in, '|', \@cmd2, ...;
|
|
|
|
start() accepts a harness or harness specification and returns a harness
|
|
after building all of the pipes and launching (via fork()/exec(), or, maybe
|
|
someday, spawn()) all the child processes. It does not send or receive any
|
|
data on the pipes, see pump() and finish() for that.
|
|
|
|
You may call harness() and then pass it's result to start() if you like,
|
|
but you only need to if it helps you structure or tune your application.
|
|
If you do call harness(), you may skip start() and proceed directly to
|
|
pump.
|
|
|
|
start() also starts all timers in the harness. See L<IPC::Run::Timer>
|
|
for more information.
|
|
|
|
start() flushes STDOUT and STDERR to help you avoid duplicate output.
|
|
It has no way of asking Perl to flush all your open filehandles, so
|
|
you are going to need to flush any others you have open. Sorry.
|
|
|
|
Here's how if you don't want to alter the state of $| for your
|
|
filehandle:
|
|
|
|
$ofh = select HANDLE; $of = $|; $| = 1; $| = $of; select $ofh;
|
|
|
|
If you don't mind leaving output unbuffered on HANDLE, you can do
|
|
the slightly shorter
|
|
|
|
$ofh = select HANDLE; $| = 1; select $ofh;
|
|
|
|
Or, you can use IO::Handle's flush() method:
|
|
|
|
use IO::Handle;
|
|
flush HANDLE;
|
|
|
|
Perl needs the equivalent of C's fflush( (FILE *)NULL ).
|
|
|
|
=cut
|
|
|
|
sub start {
|
|
|
|
# $SIG{__DIE__} = sub { my $s = shift; Carp::cluck $s; die $s };
|
|
my $options;
|
|
if ( @_ && ref $_[-1] eq 'HASH' ) {
|
|
$options = pop;
|
|
require Data::Dumper;
|
|
carp "Passing in options as a hash is deprecated:\n", Data::Dumper::Dumper($options);
|
|
}
|
|
|
|
my IPC::Run $self;
|
|
if ( @_ == 1 && UNIVERSAL::isa( $_[0], __PACKAGE__ ) ) {
|
|
$self = shift;
|
|
$self->{$_} = $options->{$_} for keys %$options;
|
|
}
|
|
else {
|
|
$self = harness( @_, $options ? $options : () );
|
|
}
|
|
|
|
local $cur_self = $self;
|
|
|
|
$self->kill_kill if $self->{STATE} == _started;
|
|
|
|
_debug "** starting" if _debugging;
|
|
|
|
$_->{RESULT} = undef for @{ $self->{KIDS} };
|
|
|
|
## Assume we're not being called from &run. It will correct our
|
|
## assumption if need be. This affects whether &_select_loop clears
|
|
## input queues to '' when they're empty.
|
|
$self->{clear_ins} = 1;
|
|
|
|
IPC::Run::Win32Helper::optimize $self
|
|
if Win32_MODE && $in_run;
|
|
|
|
my @errs;
|
|
|
|
for ( @{ $self->{TIMERS} } ) {
|
|
eval { $_->start };
|
|
if ($@) {
|
|
push @errs, $@;
|
|
_debug 'caught ', $@ if _debugging;
|
|
}
|
|
}
|
|
|
|
eval { $self->_open_pipes };
|
|
if ($@) {
|
|
push @errs, $@;
|
|
_debug 'caught ', $@ if _debugging;
|
|
}
|
|
|
|
if ( !@errs ) {
|
|
## This is a bit of a hack, we should do it for all open filehandles.
|
|
## Since there's no way I know of to enumerate open filehandles, we
|
|
## autoflush STDOUT and STDERR. This is done so that the children don't
|
|
## inherit output buffers chock full o' redundant data. It's really
|
|
## confusing to track that down.
|
|
{ my $ofh = select STDOUT; my $of = $|; $| = 1; $| = $of; select $ofh; }
|
|
{ my $ofh = select STDERR; my $of = $|; $| = 1; $| = $of; select $ofh; }
|
|
for my $kid ( @{ $self->{KIDS} } ) {
|
|
$kid->{RESULT} = undef;
|
|
_debug "child: ",
|
|
ref( $kid->{VAL} ) eq "CODE"
|
|
? "CODE ref"
|
|
: (
|
|
"`",
|
|
join( " ", map /[^\w.-]/ ? "'$_'" : $_, @{ $kid->{VAL} } ),
|
|
"`"
|
|
) if _debugging_details;
|
|
eval {
|
|
croak "simulated failure of fork"
|
|
if $self->{_simulate_fork_failure};
|
|
unless (Win32_MODE) {
|
|
$self->_spawn($kid);
|
|
}
|
|
else {
|
|
## TODO: Test and debug spawning code. Someday.
|
|
_debug(
|
|
'spawning ',
|
|
join(
|
|
' ',
|
|
map( "'$_'",
|
|
( $kid->{PATH}, @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ] ) )
|
|
)
|
|
) if _debugging;
|
|
## The external kid wouldn't know what to do with it anyway.
|
|
## This is only used by the "helper" pump processes on Win32.
|
|
_dont_inherit( $self->{DEBUG_FD} );
|
|
( $kid->{PID}, $kid->{PROCESS} ) = IPC::Run::Win32Helper::win32_spawn(
|
|
[ $kid->{PATH}, @{ $kid->{VAL} }[ 1 .. $#{ $kid->{VAL} } ] ],
|
|
$kid->{OPS},
|
|
);
|
|
_debug "spawn() = ", $kid->{PID} if _debugging;
|
|
}
|
|
};
|
|
if ($@) {
|
|
push @errs, $@;
|
|
_debug 'caught ', $@ if _debugging;
|
|
}
|
|
}
|
|
}
|
|
|
|
## Close all those temporary filehandles that the kids needed.
|
|
for my $pty ( values %{ $self->{PTYS} } ) {
|
|
close $pty->slave;
|
|
}
|
|
|
|
my @closed;
|
|
for my $kid ( @{ $self->{KIDS} } ) {
|
|
for ( @{ $kid->{OPS} } ) {
|
|
my $close_it = eval {
|
|
defined $_->{TFD}
|
|
&& !$_->{DONT_CLOSE}
|
|
&& !$closed[ $_->{TFD} ]
|
|
&& ( !Win32_MODE || !$_->{RECV_THROUGH_TEMP_FILE} ) ## Win32 hack
|
|
};
|
|
if ($@) {
|
|
push @errs, $@;
|
|
_debug 'caught ', $@ if _debugging;
|
|
}
|
|
if ( $close_it || $@ ) {
|
|
eval {
|
|
_close( $_->{TFD} );
|
|
$closed[ $_->{TFD} ] = 1;
|
|
$_->{TFD} = undef;
|
|
};
|
|
if ($@) {
|
|
push @errs, $@;
|
|
_debug 'caught ', $@ if _debugging;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
confess "gak!" unless defined $self->{PIPES};
|
|
|
|
if (@errs) {
|
|
eval { $self->_cleanup };
|
|
warn $@ if $@;
|
|
die join( '', @errs );
|
|
}
|
|
|
|
$self->{STATE} = _started;
|
|
return $self;
|
|
}
|
|
|
|
=item adopt
|
|
|
|
Experimental feature. NOT FUNCTIONAL YET, NEED TO CLOSE FDS BETTER IN CHILDREN. SEE t/adopt.t for a test suite.
|
|
|
|
=cut
|
|
|
|
sub adopt {
|
|
my IPC::Run $self = shift;
|
|
|
|
for my $adoptee (@_) {
|
|
push @{ $self->{IOS} }, @{ $adoptee->{IOS} };
|
|
## NEED TO RENUMBER THE KIDS!!
|
|
push @{ $self->{KIDS} }, @{ $adoptee->{KIDS} };
|
|
push @{ $self->{PIPES} }, @{ $adoptee->{PIPES} };
|
|
$self->{PTYS}->{$_} = $adoptee->{PTYS}->{$_} for keys %{ $adoptee->{PYTS} };
|
|
push @{ $self->{TIMERS} }, @{ $adoptee->{TIMERS} };
|
|
$adoptee->{STATE} = _finished;
|
|
}
|
|
}
|
|
|
|
sub _clobber {
|
|
my IPC::Run $self = shift;
|
|
my ($file) = @_;
|
|
_debug_desc_fd( "closing", $file ) if _debugging_details;
|
|
my $doomed = $file->{FD};
|
|
my $dir = $file->{TYPE} =~ /^</ ? 'WIN' : 'RIN';
|
|
vec( $self->{$dir}, $doomed, 1 ) = 0;
|
|
|
|
# vec( $self->{EIN}, $doomed, 1 ) = 0;
|
|
vec( $self->{PIN}, $doomed, 1 ) = 0;
|
|
if ( $file->{TYPE} =~ /^(.)pty.$/ ) {
|
|
if ( $1 eq '>' ) {
|
|
## Only close output ptys. This is so that ptys as inputs are
|
|
## never autoclosed, which would risk losing data that was
|
|
## in the slave->parent queue.
|
|
_debug_desc_fd "closing pty", $file if _debugging_details;
|
|
close $self->{PTYS}->{ $file->{PTY_ID} }
|
|
if defined $self->{PTYS}->{ $file->{PTY_ID} };
|
|
$self->{PTYS}->{ $file->{PTY_ID} } = undef;
|
|
}
|
|
}
|
|
elsif ( UNIVERSAL::isa( $file, 'IPC::Run::IO' ) ) {
|
|
$file->close unless $file->{DONT_CLOSE};
|
|
}
|
|
else {
|
|
_close($doomed);
|
|
}
|
|
|
|
@{ $self->{PIPES} } = grep
|
|
defined $_->{FD} && ( $_->{TYPE} ne $file->{TYPE} || $_->{FD} ne $doomed ),
|
|
@{ $self->{PIPES} };
|
|
|
|
$file->{FD} = undef;
|
|
}
|
|
|
|
sub _select_loop {
|
|
my IPC::Run $self = shift;
|
|
|
|
my $io_occurred;
|
|
|
|
my $not_forever = 0.01;
|
|
|
|
SELECT:
|
|
while ( $self->pumpable ) {
|
|
if ( $io_occurred && $self->{break_on_io} ) {
|
|
_debug "exiting _select(): io occurred and break_on_io set"
|
|
if _debugging_details;
|
|
last;
|
|
}
|
|
|
|
my $timeout = $self->{non_blocking} ? 0 : undef;
|
|
|
|
if ( @{ $self->{TIMERS} } ) {
|
|
my $now = time;
|
|
my $time_left;
|
|
for ( @{ $self->{TIMERS} } ) {
|
|
next unless $_->is_running;
|
|
$time_left = $_->check($now);
|
|
## Return when a timer expires
|
|
return if defined $time_left && !$time_left;
|
|
$timeout = $time_left
|
|
if !defined $timeout || $time_left < $timeout;
|
|
}
|
|
}
|
|
|
|
##
|
|
## See if we can unpause any input channels
|
|
##
|
|
my $paused = 0;
|
|
|
|
for my $file ( @{ $self->{PIPES} } ) {
|
|
next unless $file->{PAUSED} && $file->{TYPE} =~ /^</;
|
|
|
|
_debug_desc_fd( "checking for more input", $file ) if _debugging_details;
|
|
my $did;
|
|
1 while $did = $file->_do_filters($self);
|
|
if ( defined $file->{FD} && !defined($did) || $did ) {
|
|
_debug_desc_fd( "unpausing", $file ) if _debugging_details;
|
|
$file->{PAUSED} = 0;
|
|
vec( $self->{WIN}, $file->{FD}, 1 ) = 1;
|
|
|
|
# vec( $self->{EIN}, $file->{FD}, 1 ) = 1;
|
|
vec( $self->{PIN}, $file->{FD}, 1 ) = 0;
|
|
}
|
|
else {
|
|
## This gets incremented occasionally when the IO channel
|
|
## was actually closed. That's a bug, but it seems mostly
|
|
## harmless: it causes us to exit if break_on_io, or to set
|
|
## the timeout to not be forever. I need to fix it, though.
|
|
++$paused;
|
|
}
|
|
}
|
|
|
|
if (_debugging_details) {
|
|
my $map = join(
|
|
'',
|
|
map {
|
|
my $out;
|
|
$out = 'r' if vec( $self->{RIN}, $_, 1 );
|
|
$out = $out ? 'b' : 'w' if vec( $self->{WIN}, $_, 1 );
|
|
$out = 'p' if !$out && vec( $self->{PIN}, $_, 1 );
|
|
$out = $out ? uc($out) : 'x' if vec( $self->{EIN}, $_, 1 );
|
|
$out = '-' unless $out;
|
|
$out;
|
|
} ( 0 .. 1024 )
|
|
);
|
|
$map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/;
|
|
_debug 'fds for select: ', $map if _debugging_details;
|
|
}
|
|
|
|
## _do_filters may have closed our last fd, and we need to see if
|
|
## we have I/O, or are just waiting for children to exit.
|
|
my $p = $self->pumpable;
|
|
last unless $p;
|
|
if ( $p != 0 && ( !defined $timeout || $timeout > 0.1 ) ) {
|
|
## No I/O will wake the select loop up, but we have children
|
|
## lingering, so we need to poll them with a short timeout.
|
|
## Otherwise, assume more input will be coming.
|
|
$timeout = $not_forever;
|
|
$not_forever *= 2;
|
|
$not_forever = 0.5 if $not_forever >= 0.5;
|
|
}
|
|
|
|
## Make sure we don't block forever in select() because inputs are
|
|
## paused.
|
|
if ( !defined $timeout && !( @{ $self->{PIPES} } - $paused ) ) {
|
|
## Need to return if we're in pump and all input is paused, or
|
|
## we'll loop until all inputs are unpaused, which is darn near
|
|
## forever. And a day.
|
|
if ( $self->{break_on_io} ) {
|
|
_debug "exiting _select(): no I/O to do and timeout=forever"
|
|
if _debugging;
|
|
last;
|
|
}
|
|
|
|
## Otherwise, assume more input will be coming.
|
|
$timeout = $not_forever;
|
|
$not_forever *= 2;
|
|
$not_forever = 0.5 if $not_forever >= 0.5;
|
|
}
|
|
|
|
_debug 'timeout=', defined $timeout ? $timeout : 'forever'
|
|
if _debugging_details;
|
|
|
|
my $nfound;
|
|
unless (Win32_MODE) {
|
|
$nfound = select(
|
|
$self->{ROUT} = $self->{RIN},
|
|
$self->{WOUT} = $self->{WIN},
|
|
$self->{EOUT} = $self->{EIN},
|
|
$timeout
|
|
);
|
|
}
|
|
else {
|
|
my @in = map $self->{$_}, qw( RIN WIN EIN );
|
|
## Win32's select() on Win32 seems to die if passed vectors of
|
|
## all 0's. Need to report this when I get back online.
|
|
for (@in) {
|
|
$_ = undef unless index( ( unpack "b*", $_ ), 1 ) >= 0;
|
|
}
|
|
|
|
$nfound = select(
|
|
$self->{ROUT} = $in[0],
|
|
$self->{WOUT} = $in[1],
|
|
$self->{EOUT} = $in[2],
|
|
$timeout
|
|
);
|
|
|
|
for ( $self->{ROUT}, $self->{WOUT}, $self->{EOUT} ) {
|
|
$_ = "" unless defined $_;
|
|
}
|
|
}
|
|
last if !$nfound && $self->{non_blocking};
|
|
|
|
if ( $nfound < 0 ) {
|
|
if ( $!{EINTR} ) {
|
|
|
|
# Caught a signal before any FD went ready. Ensure that
|
|
# the bit fields reflect "no FDs ready".
|
|
$self->{ROUT} = $self->{WOUT} = $self->{EOUT} = '';
|
|
$nfound = 0;
|
|
}
|
|
else {
|
|
croak "$! in select";
|
|
}
|
|
}
|
|
## TODO: Analyze the EINTR failure mode and see if this patch
|
|
## is adequate and optimal.
|
|
## TODO: Add an EINTR test to the test suite.
|
|
|
|
if (_debugging_details) {
|
|
my $map = join(
|
|
'',
|
|
map {
|
|
my $out;
|
|
$out = 'r' if vec( $self->{ROUT}, $_, 1 );
|
|
$out = $out ? 'b' : 'w' if vec( $self->{WOUT}, $_, 1 );
|
|
$out = $out ? uc($out) : 'x' if vec( $self->{EOUT}, $_, 1 );
|
|
$out = '-' unless $out;
|
|
$out;
|
|
} ( 0 .. 128 )
|
|
);
|
|
$map =~ s/((?:[a-zA-Z-]|\([^\)]*\)){12,}?)-*$/$1/;
|
|
_debug "selected ", $map;
|
|
}
|
|
|
|
## Need to copy since _clobber alters @{$self->{PIPES}}.
|
|
## TODO: Rethink _clobber(). Rethink $file->{PAUSED}, too.
|
|
my @pipes = @{ $self->{PIPES} };
|
|
$io_occurred = $_->poll($self) ? 1 : $io_occurred for @pipes;
|
|
|
|
# FILE:
|
|
# for my $pipe ( @pipes ) {
|
|
# ## Pipes can be shared among kids. If another kid closes the
|
|
# ## pipe, then it's {FD} will be undef. Also, on Win32, pipes can
|
|
# ## be optimized to be files, in which case the FD is left undef
|
|
# ## so we don't try to select() on it.
|
|
# if ( $pipe->{TYPE} =~ /^>/
|
|
# && defined $pipe->{FD}
|
|
# && vec( $self->{ROUT}, $pipe->{FD}, 1 )
|
|
# ) {
|
|
# _debug_desc_fd( "filtering data from", $pipe ) if _debugging_details;
|
|
#confess "phooey" unless UNIVERSAL::isa( $pipe, "IPC::Run::IO" );
|
|
# $io_occurred = 1 if $pipe->_do_filters( $self );
|
|
#
|
|
# next FILE unless defined $pipe->{FD};
|
|
# }
|
|
#
|
|
# ## On Win32, pipes to the child can be optimized to be files
|
|
# ## and FD left undefined so we won't select on it.
|
|
# if ( $pipe->{TYPE} =~ /^</
|
|
# && defined $pipe->{FD}
|
|
# && vec( $self->{WOUT}, $pipe->{FD}, 1 )
|
|
# ) {
|
|
# _debug_desc_fd( "filtering data to", $pipe ) if _debugging_details;
|
|
# $io_occurred = 1 if $pipe->_do_filters( $self );
|
|
#
|
|
# next FILE unless defined $pipe->{FD};
|
|
# }
|
|
#
|
|
# if ( defined $pipe->{FD} && vec( $self->{EOUT}, $pipe->{FD}, 1 ) ) {
|
|
# ## BSD seems to sometimes raise the exceptional condition flag
|
|
# ## when a pipe is closed before we read it's last data. This
|
|
# ## causes spurious warnings and generally renders the exception
|
|
# ## mechanism useless for our purposes. The exception
|
|
# ## flag semantics are too variable (they're device driver
|
|
# ## specific) for me to easily map to any automatic action like
|
|
# ## warning or croaking (try running v0.42 if you don't believe me
|
|
# ## :-).
|
|
# warn "Exception on descriptor $pipe->{FD}";
|
|
# }
|
|
# }
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub _cleanup {
|
|
my IPC::Run $self = shift;
|
|
_debug "cleaning up" if _debugging_details;
|
|
|
|
for ( values %{ $self->{PTYS} } ) {
|
|
next unless ref $_;
|
|
eval {
|
|
_debug "closing slave fd ", fileno $_->slave if _debugging_data;
|
|
close $_->slave;
|
|
};
|
|
carp $@ . " while closing ptys" if $@;
|
|
eval {
|
|
_debug "closing master fd ", fileno $_ if _debugging_data;
|
|
close $_;
|
|
};
|
|
carp $@ . " closing ptys" if $@;
|
|
}
|
|
|
|
_debug "cleaning up pipes" if _debugging_details;
|
|
## _clobber modifies PIPES
|
|
$self->_clobber( $self->{PIPES}->[0] ) while @{ $self->{PIPES} };
|
|
|
|
for my $kid ( @{ $self->{KIDS} } ) {
|
|
_debug "cleaning up kid ", $kid->{NUM} if _debugging_details;
|
|
if ( !length $kid->{PID} ) {
|
|
_debug 'never ran child ', $kid->{NUM}, ", can't reap"
|
|
if _debugging;
|
|
for my $op ( @{ $kid->{OPS} } ) {
|
|
_close( $op->{TFD} )
|
|
if defined $op->{TFD} && !defined $op->{TEMP_FILE_HANDLE};
|
|
}
|
|
}
|
|
elsif ( !defined $kid->{RESULT} ) {
|
|
_debug 'reaping child ', $kid->{NUM}, ' (pid ', $kid->{PID}, ')'
|
|
if _debugging;
|
|
my $pid = waitpid $kid->{PID}, 0;
|
|
$kid->{RESULT} = $?;
|
|
_debug 'reaped ', $pid, ', $?=', $kid->{RESULT}
|
|
if _debugging;
|
|
}
|
|
|
|
# if ( defined $kid->{DEBUG_FD} ) {
|
|
# die;
|
|
# @{$kid->{OPS}} = grep
|
|
# ! defined $_->{KFD} || $_->{KFD} != $kid->{DEBUG_FD},
|
|
# @{$kid->{OPS}};
|
|
# $kid->{DEBUG_FD} = undef;
|
|
# }
|
|
|
|
_debug "cleaning up filters" if _debugging_details;
|
|
for my $op ( @{ $kid->{OPS} } ) {
|
|
@{ $op->{FILTERS} } = grep {
|
|
my $filter = $_;
|
|
!grep $filter == $_, @{ $self->{TEMP_FILTERS} };
|
|
} @{ $op->{FILTERS} };
|
|
}
|
|
|
|
for my $op ( @{ $kid->{OPS} } ) {
|
|
$op->_cleanup($self) if UNIVERSAL::isa( $op, "IPC::Run::IO" );
|
|
}
|
|
}
|
|
$self->{STATE} = _finished;
|
|
@{ $self->{TEMP_FILTERS} } = ();
|
|
_debug "done cleaning up" if _debugging_details;
|
|
|
|
POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD};
|
|
$self->{DEBUG_FD} = undef;
|
|
}
|
|
|
|
=pod
|
|
|
|
=item pump
|
|
|
|
pump $h;
|
|
$h->pump;
|
|
|
|
Pump accepts a single parameter harness. It blocks until it delivers some
|
|
input or receives some output. It returns TRUE if there is still input or
|
|
output to be done, FALSE otherwise.
|
|
|
|
pump() will automatically call start() if need be, so you may call harness()
|
|
then proceed to pump() if that helps you structure your application.
|
|
|
|
If pump() is called after all harnessed activities have completed, a "process
|
|
ended prematurely" exception to be thrown. This allows for simple scripting
|
|
of external applications without having to add lots of error handling code at
|
|
each step of the script:
|
|
|
|
$h = harness \@smbclient, \$in, \$out, $err;
|
|
|
|
$in = "cd /foo\n";
|
|
$h->pump until $out =~ /^smb.*> \Z/m;
|
|
die "error cding to /foo:\n$out" if $out =~ "ERR";
|
|
$out = '';
|
|
|
|
$in = "mget *\n";
|
|
$h->pump until $out =~ /^smb.*> \Z/m;
|
|
die "error retrieving files:\n$out" if $out =~ "ERR";
|
|
|
|
$h->finish;
|
|
|
|
warn $err if $err;
|
|
|
|
=cut
|
|
|
|
sub pump {
|
|
die "pump() takes only a single harness as a parameter"
|
|
unless @_ == 1 && UNIVERSAL::isa( $_[0], __PACKAGE__ );
|
|
|
|
my IPC::Run $self = shift;
|
|
|
|
local $cur_self = $self;
|
|
|
|
_debug "** pumping"
|
|
if _debugging;
|
|
|
|
# my $r = eval {
|
|
$self->start if $self->{STATE} < _started;
|
|
croak "process ended prematurely" unless $self->pumpable;
|
|
|
|
$self->{auto_close_ins} = 0;
|
|
$self->{break_on_io} = 1;
|
|
$self->_select_loop;
|
|
return $self->pumpable;
|
|
|
|
# };
|
|
# if ( $@ ) {
|
|
# my $x = $@;
|
|
# _debug $x if _debugging && $x;
|
|
# eval { $self->_cleanup };
|
|
# warn $@ if $@;
|
|
# die $x;
|
|
# }
|
|
# return $r;
|
|
}
|
|
|
|
=pod
|
|
|
|
=item pump_nb
|
|
|
|
pump_nb $h;
|
|
$h->pump_nb;
|
|
|
|
"pump() non-blocking", pumps if anything's ready to be pumped, returns
|
|
immediately otherwise. This is useful if you're doing some long-running
|
|
task in the foreground, but don't want to starve any child processes.
|
|
|
|
=cut
|
|
|
|
sub pump_nb {
|
|
my IPC::Run $self = shift;
|
|
|
|
$self->{non_blocking} = 1;
|
|
my $r = eval { $self->pump };
|
|
$self->{non_blocking} = 0;
|
|
die $@ if $@;
|
|
return $r;
|
|
}
|
|
|
|
=pod
|
|
|
|
=item pumpable
|
|
|
|
Returns TRUE if calling pump() won't throw an immediate "process ended
|
|
prematurely" exception. This means that there are open I/O channels or
|
|
active processes. May yield the parent processes' time slice for 0.01
|
|
second if all pipes are to the child and all are paused. In this case
|
|
we can't tell if the child is dead, so we yield the processor and
|
|
then attempt to reap the child in a nonblocking way.
|
|
|
|
=cut
|
|
|
|
## Undocumented feature (don't depend on it outside this module):
|
|
## returns -1 if we have I/O channels open, or >0 if no I/O channels
|
|
## open, but we have kids running. This allows the select loop
|
|
## to poll for child exit.
|
|
sub pumpable {
|
|
my IPC::Run $self = shift;
|
|
|
|
## There's a catch-22 we can get in to if there is only one pipe left
|
|
## open to the child and it's paused (ie the SCALAR it's tied to
|
|
## is ''). It's paused, so we're not select()ing on it, so we don't
|
|
## check it to see if the child attached to it is alive and it stays
|
|
## in @{$self->{PIPES}} forever. So, if all pipes are paused, see if
|
|
## we can reap the child.
|
|
return -1 if grep !$_->{PAUSED}, @{ $self->{PIPES} };
|
|
|
|
## See if the child is dead.
|
|
$self->reap_nb;
|
|
return 0 unless $self->_running_kids;
|
|
|
|
## If we reap_nb and it's not dead yet, yield to it to see if it
|
|
## exits.
|
|
##
|
|
## A better solution would be to unpause all the pipes, but I tried that
|
|
## and it never errored on linux. Sigh.
|
|
select undef, undef, undef, 0.0001;
|
|
|
|
## try again
|
|
$self->reap_nb;
|
|
return 0 unless $self->_running_kids;
|
|
|
|
return -1; ## There are pipes waiting
|
|
}
|
|
|
|
sub _running_kids {
|
|
my IPC::Run $self = shift;
|
|
return grep
|
|
defined $_->{PID} && !defined $_->{RESULT},
|
|
@{ $self->{KIDS} };
|
|
}
|
|
|
|
=pod
|
|
|
|
=item reap_nb
|
|
|
|
Attempts to reap child processes, but does not block.
|
|
|
|
Does not currently take any parameters, one day it will allow specific
|
|
children to be reaped.
|
|
|
|
Only call this from a signal handler if your C<perl> is recent enough
|
|
to have safe signal handling (5.6.1 did not, IIRC, but it was being discussed
|
|
on perl5-porters). Calling this (or doing any significant work) in a signal
|
|
handler on older C<perl>s is asking for seg faults.
|
|
|
|
=cut
|
|
|
|
my $still_runnings;
|
|
|
|
sub reap_nb {
|
|
my IPC::Run $self = shift;
|
|
|
|
local $cur_self = $self;
|
|
|
|
## No more pipes, look to see if all the kids yet live, reaping those
|
|
## that haven't. I'd use $SIG{CHLD}/$SIG{CLD}, but that's broken
|
|
## on older (SYSV) platforms and perhaps less portable than waitpid().
|
|
## This could be slow with a lot of kids, but that's rare and, well,
|
|
## a lot of kids is slow in the first place.
|
|
## Oh, and this keeps us from reaping other children the process
|
|
## may have spawned.
|
|
for my $kid ( @{ $self->{KIDS} } ) {
|
|
if (Win32_MODE) {
|
|
next if !defined $kid->{PROCESS} || defined $kid->{RESULT};
|
|
unless ( $kid->{PROCESS}->Wait(0) ) {
|
|
_debug "kid $kid->{NUM} ($kid->{PID}) still running"
|
|
if _debugging_details;
|
|
next;
|
|
}
|
|
|
|
_debug "kid $kid->{NUM} ($kid->{PID}) exited"
|
|
if _debugging;
|
|
|
|
$kid->{PROCESS}->GetExitCode( $kid->{RESULT} )
|
|
or croak "$! while GetExitCode()ing for Win32 process";
|
|
|
|
unless ( defined $kid->{RESULT} ) {
|
|
$kid->{RESULT} = "0 but true";
|
|
$? = $kid->{RESULT} = 0x0F;
|
|
}
|
|
else {
|
|
$? = $kid->{RESULT} << 8;
|
|
}
|
|
}
|
|
else {
|
|
next if !defined $kid->{PID} || defined $kid->{RESULT};
|
|
my $pid = waitpid $kid->{PID}, POSIX::WNOHANG();
|
|
unless ($pid) {
|
|
_debug "$kid->{NUM} ($kid->{PID}) still running"
|
|
if _debugging_details;
|
|
next;
|
|
}
|
|
|
|
if ( $pid < 0 ) {
|
|
_debug "No such process: $kid->{PID}\n" if _debugging;
|
|
$kid->{RESULT} = "unknown result, unknown PID";
|
|
}
|
|
else {
|
|
_debug "kid $kid->{NUM} ($kid->{PID}) exited"
|
|
if _debugging;
|
|
|
|
confess "waitpid returned the wrong PID: $pid instead of $kid->{PID}"
|
|
unless $pid == $kid->{PID};
|
|
_debug "$kid->{PID} returned $?\n" if _debugging;
|
|
$kid->{RESULT} = $?;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
=item finish
|
|
|
|
This must be called after the last start() or pump() call for a harness,
|
|
or your system will accumulate defunct processes and you may "leak"
|
|
file descriptors.
|
|
|
|
finish() returns TRUE if all children returned 0 (and were not signaled and did
|
|
not coredump, ie ! $?), and FALSE otherwise (this is like run(), and the
|
|
opposite of system()).
|
|
|
|
Once a harness has been finished, it may be run() or start()ed again,
|
|
including by pump()s auto-start.
|
|
|
|
If this throws an exception rather than a normal exit, the harness may
|
|
be left in an unstable state, it's best to kill the harness to get rid
|
|
of all the child processes, etc.
|
|
|
|
Specifically, if a timeout expires in finish(), finish() will not
|
|
kill all the children. Call C<<$h->kill_kill>> in this case if you care.
|
|
This differs from the behavior of L</run>.
|
|
|
|
=cut
|
|
|
|
sub finish {
|
|
my IPC::Run $self = shift;
|
|
my $options = @_ && ref $_[-1] eq 'HASH' ? pop : {};
|
|
|
|
local $cur_self = $self;
|
|
|
|
_debug "** finishing" if _debugging;
|
|
|
|
$self->{non_blocking} = 0;
|
|
$self->{auto_close_ins} = 1;
|
|
$self->{break_on_io} = 0;
|
|
|
|
# We don't alter $self->{clear_ins}, start() and run() control it.
|
|
|
|
while ( $self->pumpable ) {
|
|
$self->_select_loop($options);
|
|
}
|
|
$self->_cleanup;
|
|
|
|
return !$self->full_result;
|
|
}
|
|
|
|
=pod
|
|
|
|
=item result
|
|
|
|
$h->result;
|
|
|
|
Returns the first non-zero result code (ie $? >> 8). See L</full_result> to
|
|
get the $? value for a child process.
|
|
|
|
To get the result of a particular child, do:
|
|
|
|
$h->result( 0 ); # first child's $? >> 8
|
|
$h->result( 1 ); # second child
|
|
|
|
or
|
|
|
|
($h->results)[0]
|
|
($h->results)[1]
|
|
|
|
Returns undef if no child processes were spawned and no child number was
|
|
specified. Throws an exception if an out-of-range child number is passed.
|
|
|
|
=cut
|
|
|
|
sub _assert_finished {
|
|
my IPC::Run $self = $_[0];
|
|
|
|
croak "Harness not run" unless $self->{STATE} >= _finished;
|
|
croak "Harness not finished running" unless $self->{STATE} == _finished;
|
|
}
|
|
|
|
sub _child_result {
|
|
my IPC::Run $self = shift;
|
|
|
|
my ($which) = @_;
|
|
croak(
|
|
"Only ",
|
|
scalar( @{ $self->{KIDS} } ),
|
|
" child processes, no process $which"
|
|
) unless $which >= 0 && $which <= $#{ $self->{KIDS} };
|
|
return $self->{KIDS}->[$which]->{RESULT};
|
|
}
|
|
|
|
sub result {
|
|
&_assert_finished;
|
|
my IPC::Run $self = shift;
|
|
|
|
if (@_) {
|
|
my ($which) = @_;
|
|
return $self->_child_result($which) >> 8;
|
|
}
|
|
else {
|
|
return undef unless @{ $self->{KIDS} };
|
|
for ( @{ $self->{KIDS} } ) {
|
|
return $_->{RESULT} >> 8 if $_->{RESULT} >> 8;
|
|
}
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
=item results
|
|
|
|
Returns a list of child exit values. See L</full_results> if you want to
|
|
know if a signal killed the child.
|
|
|
|
Throws an exception if the harness is not in a finished state.
|
|
|
|
=cut
|
|
|
|
sub results {
|
|
&_assert_finished;
|
|
my IPC::Run $self = shift;
|
|
|
|
# we add 0 here to stop warnings associated with "unknown result, unknown PID"
|
|
return map { ( 0 + $_->{RESULT} ) >> 8 } @{ $self->{KIDS} };
|
|
}
|
|
|
|
=pod
|
|
|
|
=item full_result
|
|
|
|
$h->full_result;
|
|
|
|
Returns the first non-zero $?. See L</result> to get the first $? >> 8
|
|
value for a child process.
|
|
|
|
To get the result of a particular child, do:
|
|
|
|
$h->full_result( 0 ); # first child's $?
|
|
$h->full_result( 1 ); # second child
|
|
|
|
or
|
|
|
|
($h->full_results)[0]
|
|
($h->full_results)[1]
|
|
|
|
Returns undef if no child processes were spawned and no child number was
|
|
specified. Throws an exception if an out-of-range child number is passed.
|
|
|
|
=cut
|
|
|
|
sub full_result {
|
|
&_assert_finished;
|
|
|
|
my IPC::Run $self = shift;
|
|
|
|
if (@_) {
|
|
my ($which) = @_;
|
|
return $self->_child_result($which);
|
|
}
|
|
else {
|
|
return undef unless @{ $self->{KIDS} };
|
|
for ( @{ $self->{KIDS} } ) {
|
|
return $_->{RESULT} if $_->{RESULT};
|
|
}
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
=item full_results
|
|
|
|
Returns a list of child exit values as returned by C<wait>. See L</results>
|
|
if you don't care about coredumps or signals.
|
|
|
|
Throws an exception if the harness is not in a finished state.
|
|
|
|
=cut
|
|
|
|
sub full_results {
|
|
&_assert_finished;
|
|
my IPC::Run $self = shift;
|
|
|
|
croak "Harness not run" unless $self->{STATE} >= _finished;
|
|
croak "Harness not finished running" unless $self->{STATE} == _finished;
|
|
|
|
return map $_->{RESULT}, @{ $self->{KIDS} };
|
|
}
|
|
|
|
##
|
|
## Filter Scaffolding
|
|
##
|
|
use vars (
|
|
'$filter_op', ## The op running a filter chain right now
|
|
'$filter_num', ## Which filter is being run right now.
|
|
);
|
|
|
|
##
|
|
## A few filters and filter constructors
|
|
##
|
|
|
|
=pod
|
|
|
|
=back
|
|
|
|
=back
|
|
|
|
=head1 FILTERS
|
|
|
|
These filters are used to modify input our output between a child
|
|
process and a scalar or subroutine endpoint.
|
|
|
|
=over
|
|
|
|
=item binary
|
|
|
|
run \@cmd, ">", binary, \$out;
|
|
run \@cmd, ">", binary, \$out; ## Any TRUE value to enable
|
|
run \@cmd, ">", binary 0, \$out; ## Any FALSE value to disable
|
|
|
|
This is a constructor for a "binmode" "filter" that tells IPC::Run to keep
|
|
the carriage returns that would ordinarily be edited out for you (binmode
|
|
is usually off). This is not a real filter, but an option masquerading as
|
|
a filter.
|
|
|
|
It's not named "binmode" because you're likely to want to call Perl's binmode
|
|
in programs that are piping binary data around.
|
|
|
|
=cut
|
|
|
|
sub binary(;$) {
|
|
my $enable = @_ ? shift : 1;
|
|
return bless sub { $enable }, "IPC::Run::binmode_pseudo_filter";
|
|
}
|
|
|
|
=pod
|
|
|
|
=item new_chunker
|
|
|
|
This breaks a stream of data in to chunks, based on an optional
|
|
scalar or regular expression parameter. The default is the Perl
|
|
input record separator in $/, which is a newline be default.
|
|
|
|
run \@cmd, '>', new_chunker, \&lines_handler;
|
|
run \@cmd, '>', new_chunker( "\r\n" ), \&lines_handler;
|
|
|
|
Because this uses $/ by default, you should always pass in a parameter
|
|
if you are worried about other code (modules, etc) modifying $/.
|
|
|
|
If this filter is last in a filter chain that dumps in to a scalar,
|
|
the scalar must be set to '' before a new chunk will be written to it.
|
|
|
|
As an example of how a filter like this can be written, here's a
|
|
chunker that splits on newlines:
|
|
|
|
sub line_splitter {
|
|
my ( $in_ref, $out_ref ) = @_;
|
|
|
|
return 0 if length $$out_ref;
|
|
|
|
return input_avail && do {
|
|
while (1) {
|
|
if ( $$in_ref =~ s/\A(.*?\n)// ) {
|
|
$$out_ref .= $1;
|
|
return 1;
|
|
}
|
|
my $hmm = get_more_input;
|
|
unless ( defined $hmm ) {
|
|
$$out_ref = $$in_ref;
|
|
$$in_ref = '';
|
|
return length $$out_ref ? 1 : 0;
|
|
}
|
|
return 0 if $hmm eq 0;
|
|
}
|
|
}
|
|
};
|
|
|
|
=cut
|
|
|
|
sub new_chunker(;$) {
|
|
my ($re) = @_;
|
|
$re = $/ if _empty $re;
|
|
$re = quotemeta($re) unless ref $re eq 'Regexp';
|
|
$re = qr/\A(.*?$re)/s;
|
|
|
|
return sub {
|
|
my ( $in_ref, $out_ref ) = @_;
|
|
|
|
return 0 if length $$out_ref;
|
|
|
|
return input_avail && do {
|
|
while (1) {
|
|
if ( $$in_ref =~ s/$re// ) {
|
|
$$out_ref .= $1;
|
|
return 1;
|
|
}
|
|
my $hmm = get_more_input;
|
|
unless ( defined $hmm ) {
|
|
$$out_ref = $$in_ref;
|
|
$$in_ref = '';
|
|
return length $$out_ref ? 1 : 0;
|
|
}
|
|
return 0 if $hmm eq 0;
|
|
}
|
|
}
|
|
};
|
|
}
|
|
|
|
=pod
|
|
|
|
=item new_appender
|
|
|
|
This appends a fixed string to each chunk of data read from the source
|
|
scalar or sub. This might be useful if you're writing commands to a
|
|
child process that always must end in a fixed string, like "\n":
|
|
|
|
run( \@cmd,
|
|
'<', new_appender( "\n" ), \&commands,
|
|
);
|
|
|
|
Here's a typical filter sub that might be created by new_appender():
|
|
|
|
sub newline_appender {
|
|
my ( $in_ref, $out_ref ) = @_;
|
|
|
|
return input_avail && do {
|
|
$$out_ref = join( '', $$out_ref, $$in_ref, "\n" );
|
|
$$in_ref = '';
|
|
1;
|
|
}
|
|
};
|
|
|
|
=cut
|
|
|
|
sub new_appender($) {
|
|
my ($suffix) = @_;
|
|
croak "\$suffix undefined" unless defined $suffix;
|
|
|
|
return sub {
|
|
my ( $in_ref, $out_ref ) = @_;
|
|
|
|
return input_avail && do {
|
|
$$out_ref = join( '', $$out_ref, $$in_ref, $suffix );
|
|
$$in_ref = '';
|
|
1;
|
|
}
|
|
};
|
|
}
|
|
|
|
=item new_string_source
|
|
|
|
TODO: Needs confirmation. Was previously undocumented. in this module.
|
|
|
|
This is a filter which is exportable. Returns a sub which appends the data passed in to the output buffer and returns 1 if data was appended. 0 if it was an empty string and undef if no data was passed.
|
|
|
|
NOTE: Any additional variables passed to new_string_source will be passed to the sub every time it's called and appended to the output.
|
|
|
|
=cut
|
|
|
|
sub new_string_source {
|
|
my $ref;
|
|
if ( @_ > 1 ) {
|
|
$ref = [@_],
|
|
}
|
|
else {
|
|
$ref = shift;
|
|
}
|
|
|
|
return ref $ref eq 'SCALAR'
|
|
? sub {
|
|
my ( $in_ref, $out_ref ) = @_;
|
|
|
|
return defined $$ref
|
|
? do {
|
|
$$out_ref .= $$ref;
|
|
my $r = length $$ref ? 1 : 0;
|
|
$$ref = undef;
|
|
$r;
|
|
}
|
|
: undef;
|
|
}
|
|
: sub {
|
|
my ( $in_ref, $out_ref ) = @_;
|
|
|
|
return @$ref
|
|
? do {
|
|
my $s = shift @$ref;
|
|
$$out_ref .= $s;
|
|
length $s ? 1 : 0;
|
|
}
|
|
: undef;
|
|
}
|
|
}
|
|
|
|
=item new_string_sink
|
|
|
|
TODO: Needs confirmation. Was previously undocumented.
|
|
|
|
This is a filter which is exportable. Returns a sub which pops the data out of the input stream and pushes it onto the string.
|
|
|
|
=cut
|
|
|
|
sub new_string_sink {
|
|
my ($string_ref) = @_;
|
|
|
|
return sub {
|
|
my ( $in_ref, $out_ref ) = @_;
|
|
|
|
return input_avail && do {
|
|
$$string_ref .= $$in_ref;
|
|
$$in_ref = '';
|
|
1;
|
|
}
|
|
};
|
|
}
|
|
|
|
#=item timeout
|
|
#
|
|
#This function defines a time interval, starting from when start() is
|
|
#called, or when timeout() is called. If all processes have not finished
|
|
#by the end of the timeout period, then a "process timed out" exception
|
|
#is thrown.
|
|
#
|
|
#The time interval may be passed in seconds, or as an end time in
|
|
#"HH:MM:SS" format (any non-digit other than '.' may be used as
|
|
#spacing and punctuation). This is probably best shown by example:
|
|
#
|
|
# $h->timeout( $val );
|
|
#
|
|
# $val Effect
|
|
# ======================== =====================================
|
|
# undef Timeout timer disabled
|
|
# '' Almost immediate timeout
|
|
# 0 Almost immediate timeout
|
|
# 0.000001 timeout > 0.0000001 seconds
|
|
# 30 timeout > 30 seconds
|
|
# 30.0000001 timeout > 30 seconds
|
|
# 10:30 timeout > 10 minutes, 30 seconds
|
|
#
|
|
#Timeouts are currently evaluated with a 1 second resolution, though
|
|
#this may change in the future. This means that setting
|
|
#timeout($h,1) will cause a pokey child to be aborted sometime after
|
|
#one second has elapsed and typically before two seconds have elapsed.
|
|
#
|
|
#This sub does not check whether or not the timeout has expired already.
|
|
#
|
|
#Returns the number of seconds set as the timeout (this does not change
|
|
#as time passes, unless you call timeout( val ) again).
|
|
#
|
|
#The timeout does not include the time needed to fork() or spawn()
|
|
#the child processes, though some setup time for the child processes can
|
|
#included. It also does not include the length of time it takes for
|
|
#the children to exit after they've closed all their pipes to the
|
|
#parent process.
|
|
#
|
|
#=cut
|
|
#
|
|
#sub timeout {
|
|
# my IPC::Run $self = shift;
|
|
#
|
|
# if ( @_ ) {
|
|
# ( $self->{TIMEOUT} ) = @_;
|
|
# $self->{TIMEOUT_END} = undef;
|
|
# if ( defined $self->{TIMEOUT} ) {
|
|
# if ( $self->{TIMEOUT} =~ /[^\d.]/ ) {
|
|
# my @f = split( /[^\d\.]+/i, $self->{TIMEOUT} );
|
|
# unshift @f, 0 while @f < 3;
|
|
# $self->{TIMEOUT} = (($f[0]*60)+$f[1])*60+$f[2];
|
|
# }
|
|
# elsif ( $self->{TIMEOUT} =~ /^(\d*)(?:\.(\d*))/ ) {
|
|
# $self->{TIMEOUT} = $1 + 1;
|
|
# }
|
|
# $self->_calc_timeout_end if $self->{STATE} >= _started;
|
|
# }
|
|
# }
|
|
# return $self->{TIMEOUT};
|
|
#}
|
|
#
|
|
#
|
|
#sub _calc_timeout_end {
|
|
# my IPC::Run $self = shift;
|
|
#
|
|
# $self->{TIMEOUT_END} = defined $self->{TIMEOUT}
|
|
# ? time + $self->{TIMEOUT}
|
|
# : undef;
|
|
#
|
|
# ## We add a second because we might be at the very end of the current
|
|
# ## second, and we want to guarantee that we don't have a timeout even
|
|
# ## one second less then the timeout period.
|
|
# ++$self->{TIMEOUT_END} if $self->{TIMEOUT};
|
|
#}
|
|
|
|
=pod
|
|
|
|
=item io
|
|
|
|
Takes a filename or filehandle, a redirection operator, optional filters,
|
|
and a source or destination (depends on the redirection operator). Returns
|
|
an IPC::Run::IO object suitable for harness()ing (including via start()
|
|
or run()).
|
|
|
|
This is shorthand for
|
|
|
|
|
|
require IPC::Run::IO;
|
|
|
|
... IPC::Run::IO->new(...) ...
|
|
|
|
=cut
|
|
|
|
sub io {
|
|
require IPC::Run::IO;
|
|
IPC::Run::IO->new(@_);
|
|
}
|
|
|
|
=pod
|
|
|
|
=item timer
|
|
|
|
$h = start( \@cmd, \$in, \$out, $t = timer( 5 ) );
|
|
|
|
pump $h until $out =~ /expected stuff/ || $t->is_expired;
|
|
|
|
Instantiates a non-fatal timer. pump() returns once each time a timer
|
|
expires. Has no direct effect on run(), but you can pass a subroutine
|
|
to fire when the timer expires.
|
|
|
|
See L</timeout> for building timers that throw exceptions on
|
|
expiration.
|
|
|
|
See L<IPC::Run::Timer/timer> for details.
|
|
|
|
=cut
|
|
|
|
# Doing the prototype suppresses 'only used once' on older perls.
|
|
sub timer;
|
|
*timer = \&IPC::Run::Timer::timer;
|
|
|
|
=pod
|
|
|
|
=item timeout
|
|
|
|
$h = start( \@cmd, \$in, \$out, $t = timeout( 5 ) );
|
|
|
|
pump $h until $out =~ /expected stuff/;
|
|
|
|
Instantiates a timer that throws an exception when it expires.
|
|
If you don't provide an exception, a default exception that matches
|
|
/^IPC::Run: .*timed out/ is thrown by default. You can pass in your own
|
|
exception scalar or reference:
|
|
|
|
$h = start(
|
|
\@cmd, \$in, \$out,
|
|
$t = timeout( 5, exception => 'slowpoke' ),
|
|
);
|
|
|
|
or set the name used in debugging message and in the default exception
|
|
string:
|
|
|
|
$h = start(
|
|
\@cmd, \$in, \$out,
|
|
timeout( 50, name => 'process timer' ),
|
|
$stall_timer = timeout( 5, name => 'stall timer' ),
|
|
);
|
|
|
|
pump $h until $out =~ /started/;
|
|
|
|
$in = 'command 1';
|
|
$stall_timer->start;
|
|
pump $h until $out =~ /command 1 finished/;
|
|
|
|
$in = 'command 2';
|
|
$stall_timer->start;
|
|
pump $h until $out =~ /command 2 finished/;
|
|
|
|
$in = 'very slow command 3';
|
|
$stall_timer->start( 10 );
|
|
pump $h until $out =~ /command 3 finished/;
|
|
|
|
$stall_timer->start( 5 );
|
|
$in = 'command 4';
|
|
pump $h until $out =~ /command 4 finished/;
|
|
|
|
$stall_timer->reset; # Prevent restarting or expirng
|
|
finish $h;
|
|
|
|
See L</timer> for building non-fatal timers.
|
|
|
|
See L<IPC::Run::Timer/timer> for details.
|
|
|
|
=cut
|
|
|
|
# Doing the prototype suppresses 'only used once' on older perls.
|
|
sub timeout;
|
|
*timeout = \&IPC::Run::Timer::timeout;
|
|
|
|
=pod
|
|
|
|
=back
|
|
|
|
=head1 FILTER IMPLEMENTATION FUNCTIONS
|
|
|
|
These functions are for use from within filters.
|
|
|
|
=over
|
|
|
|
=item input_avail
|
|
|
|
Returns TRUE if input is available. If none is available, then
|
|
&get_more_input is called and its result is returned.
|
|
|
|
This is usually used in preference to &get_more_input so that the
|
|
calling filter removes all data from the $in_ref before more data
|
|
gets read in to $in_ref.
|
|
|
|
C<input_avail> is usually used as part of a return expression:
|
|
|
|
return input_avail && do {
|
|
## process the input just gotten
|
|
1;
|
|
};
|
|
|
|
This technique allows input_avail to return the undef or 0 that a
|
|
filter normally returns when there's no input to process. If a filter
|
|
stores intermediate values, however, it will need to react to an
|
|
undef:
|
|
|
|
my $got = input_avail;
|
|
if ( ! defined $got ) {
|
|
## No more input ever, flush internal buffers to $out_ref
|
|
}
|
|
return $got unless $got;
|
|
## Got some input, move as much as need be
|
|
return 1 if $added_to_out_ref;
|
|
|
|
=cut
|
|
|
|
sub input_avail() {
|
|
confess "Undefined FBUF ref for $filter_num+1"
|
|
unless defined $filter_op->{FBUFS}->[ $filter_num + 1 ];
|
|
length ${ $filter_op->{FBUFS}->[ $filter_num + 1 ] } || get_more_input;
|
|
}
|
|
|
|
=pod
|
|
|
|
=item get_more_input
|
|
|
|
This is used to fetch more input in to the input variable. It returns
|
|
undef if there will never be any more input, 0 if there is none now,
|
|
but there might be in the future, and TRUE if more input was gotten.
|
|
|
|
C<get_more_input> is usually used as part of a return expression,
|
|
see L</input_avail> for more information.
|
|
|
|
=cut
|
|
|
|
##
|
|
## Filter implementation interface
|
|
##
|
|
sub get_more_input() {
|
|
++$filter_num;
|
|
my $r = eval {
|
|
confess "get_more_input() called and no more filters in chain"
|
|
unless defined $filter_op->{FILTERS}->[$filter_num];
|
|
$filter_op->{FILTERS}->[$filter_num]->(
|
|
$filter_op->{FBUFS}->[ $filter_num + 1 ],
|
|
$filter_op->{FBUFS}->[$filter_num],
|
|
); # if defined ${$filter_op->{FBUFS}->[$filter_num+1]};
|
|
};
|
|
--$filter_num;
|
|
die $@ if $@;
|
|
return $r;
|
|
}
|
|
|
|
1;
|
|
|
|
=pod
|
|
|
|
=back
|
|
|
|
=head1 TODO
|
|
|
|
These will be addressed as needed and as time allows.
|
|
|
|
Stall timeout.
|
|
|
|
Expose a list of child process objects. When I do this,
|
|
each child process is likely to be blessed into IPC::Run::Proc.
|
|
|
|
$kid->abort(), $kid->kill(), $kid->signal( $num_or_name ).
|
|
|
|
Write tests for /(full_)?results?/ subs.
|
|
|
|
Currently, pump() and run() only work on systems where select() works on the
|
|
filehandles returned by pipe(). This does *not* include ActiveState on Win32,
|
|
although it does work on cygwin under Win32 (thought the tests whine a bit).
|
|
I'd like to rectify that, suggestions and patches welcome.
|
|
|
|
Likewise start() only fully works on fork()/exec() machines (well, just
|
|
fork() if you only ever pass perl subs as subprocesses). There's
|
|
some scaffolding for calling Open3::spawn_with_handles(), but that's
|
|
untested, and not that useful with limited select().
|
|
|
|
Support for C<\@sub_cmd> as an argument to a command which
|
|
gets replaced with /dev/fd or the name of a temporary file containing foo's
|
|
output. This is like <(sub_cmd ...) found in bash and csh (IIRC).
|
|
|
|
Allow multiple harnesses to be combined as independent sets of processes
|
|
in to one 'meta-harness'.
|
|
|
|
Allow a harness to be passed in place of an \@cmd. This would allow
|
|
multiple harnesses to be aggregated.
|
|
|
|
Ability to add external file descriptors w/ filter chains and endpoints.
|
|
|
|
Ability to add timeouts and timing generators (i.e. repeating timeouts).
|
|
|
|
High resolution timeouts.
|
|
|
|
=head1 Win32 LIMITATIONS
|
|
|
|
=over
|
|
|
|
=item Fails on Win9X
|
|
|
|
If you want Win9X support, you'll have to debug it or fund me because I
|
|
don't use that system any more. The Win32 subsysem has been extended to
|
|
use temporary files in simple run() invocations and these may actually
|
|
work on Win9X too, but I don't have time to work on it.
|
|
|
|
=item May deadlock on Win2K (but not WinNT4 or WinXPPro)
|
|
|
|
Spawning more than one subprocess on Win2K causes a deadlock I haven't
|
|
figured out yet, but simple uses of run() often work. Passes all tests
|
|
on WinXPPro and WinNT.
|
|
|
|
=item no support yet for <pty< and >pty>
|
|
|
|
These are likely to be implemented as "<" and ">" with binmode on, not
|
|
sure.
|
|
|
|
=item no support for file descriptors higher than 2 (stderr)
|
|
|
|
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
|
|
get the integer handle and pass it to the child process using the command
|
|
line, environment, stdin, intermediary file, or other IPC mechanism. Then
|
|
use that handle in the child (Win32API.pm provides ways to reconstitute
|
|
Perl file handles from Win32 file handles).
|
|
|
|
=item no support for subroutine subprocesses (CODE refs)
|
|
|
|
Can't fork(), so the subroutines would have no context, and closures certainly
|
|
have no meaning
|
|
|
|
Perhaps with Win32 fork() emulation, this can be supported in a limited
|
|
fashion, but there are other very serious problems with that: all parent
|
|
fds get dup()ed in to the thread emulating the forked process, and that
|
|
keeps the parent from being able to close all of the appropriate fds.
|
|
|
|
=item no support for init => sub {} routines.
|
|
|
|
Win32 processes are created from scratch, there is no way to do an init
|
|
routine that will affect the running child. Some limited support might
|
|
be implemented one day, do chdir() and %ENV changes can be made.
|
|
|
|
=item signals
|
|
|
|
Win32 does not fully support signals. signal() is likely to cause errors
|
|
unless sending a signal that Perl emulates, and C<kill_kill()> is immediately
|
|
fatal (there is no grace period).
|
|
|
|
=item helper processes
|
|
|
|
IPC::Run uses helper processes, one per redirected file, to adapt between the
|
|
anonymous pipe connected to the child and the TCP socket connected to the
|
|
parent. This is a waste of resources and will change in the future to either
|
|
use threads (instead of helper processes) or a WaitForMultipleObjects call
|
|
(instead of select). Please contact me if you can help with the
|
|
WaitForMultipleObjects() approach; I haven't figured out how to get at it
|
|
without C code.
|
|
|
|
=item shutdown pause
|
|
|
|
There seems to be a pause of up to 1 second between when a child program exits
|
|
and the corresponding sockets indicate that they are closed in the parent.
|
|
Not sure why.
|
|
|
|
=item binmode
|
|
|
|
binmode is not supported yet. The underpinnings are implemented, just ask
|
|
if you need it.
|
|
|
|
=item IPC::Run::IO
|
|
|
|
IPC::Run::IO objects can be used on Unix to read or write arbitrary files. On
|
|
Win32, they will need to use the same helper processes to adapt from
|
|
non-select()able filehandles to select()able ones (or perhaps
|
|
WaitForMultipleObjects() will work with them, not sure).
|
|
|
|
=item startup race conditions
|
|
|
|
There seems to be an occasional race condition between child process startup
|
|
and pipe closings. It seems like if the child is not fully created by the time
|
|
CreateProcess returns and we close the TCP socket being handed to it, the
|
|
parent socket can also get closed. This is seen with the Win32 pumper
|
|
applications, not the "real" child process being spawned.
|
|
|
|
I assume this is because the kernel hasn't gotten around to incrementing the
|
|
reference count on the child's end (since the child was slow in starting), so
|
|
the parent's closing of the child end causes the socket to be closed, thus
|
|
closing the parent socket.
|
|
|
|
Being a race condition, it's hard to reproduce, but I encountered it while
|
|
testing this code on a drive share to a samba box. In this case, it takes
|
|
t/run.t a long time to spawn it's child processes (the parent hangs in the
|
|
first select for several seconds until the child emits any debugging output).
|
|
|
|
I have not seen it on local drives, and can't reproduce it at will,
|
|
unfortunately. The symptom is a "bad file descriptor in select()" error, and,
|
|
by turning on debugging, it's possible to see that select() is being called on
|
|
a no longer open file descriptor that was returned from the _socket() routine
|
|
in Win32Helper. There's a new confess() that checks for this ("PARENT_HANDLE
|
|
no longer open"), but I haven't been able to reproduce it (typically).
|
|
|
|
=back
|
|
|
|
=head1 LIMITATIONS
|
|
|
|
On Unix, requires a system that supports C<waitpid( $pid, WNOHANG )> so
|
|
it can tell if a child process is still running.
|
|
|
|
PTYs don't seem to be non-blocking on some versions of Solaris. Here's a
|
|
test script contributed by Borislav Deianov <borislav@ensim.com> to see
|
|
if you have the problem. If it dies, you have the problem.
|
|
|
|
#!/usr/bin/perl
|
|
|
|
use IPC::Run qw(run);
|
|
use Fcntl;
|
|
use IO::Pty;
|
|
|
|
sub makecmd {
|
|
return ['perl', '-e',
|
|
'<STDIN>, print "\n" x '.$_[0].'; while(<STDIN>){last if /end/}'];
|
|
}
|
|
|
|
#pipe R, W;
|
|
#fcntl(W, F_SETFL, O_NONBLOCK);
|
|
#while (syswrite(W, "\n", 1)) { $pipebuf++ };
|
|
#print "pipe buffer size is $pipebuf\n";
|
|
my $pipebuf=4096;
|
|
my $in = "\n" x ($pipebuf * 2) . "end\n";
|
|
my $out;
|
|
|
|
$SIG{ALRM} = sub { die "Never completed!\n" };
|
|
|
|
print "reading from scalar via pipe...";
|
|
alarm( 2 );
|
|
run(makecmd($pipebuf * 2), '<', \$in, '>', \$out);
|
|
alarm( 0 );
|
|
print "done\n";
|
|
|
|
print "reading from code via pipe... ";
|
|
alarm( 2 );
|
|
run(makecmd($pipebuf * 3), '<', sub { $t = $in; undef $in; $t}, '>', \$out);
|
|
alarm( 0 );
|
|
print "done\n";
|
|
|
|
$pty = IO::Pty->new();
|
|
$pty->blocking(0);
|
|
$slave = $pty->slave();
|
|
while ($pty->syswrite("\n", 1)) { $ptybuf++ };
|
|
print "pty buffer size is $ptybuf\n";
|
|
$in = "\n" x ($ptybuf * 3) . "end\n";
|
|
|
|
print "reading via pty... ";
|
|
alarm( 2 );
|
|
run(makecmd($ptybuf * 3), '<pty<', \$in, '>', \$out);
|
|
alarm(0);
|
|
print "done\n";
|
|
|
|
No support for ';', '&&', '||', '{ ... }', etc: use perl's, since run()
|
|
returns TRUE when the command exits with a 0 result code.
|
|
|
|
Does not provide shell-like string interpolation.
|
|
|
|
No support for C<cd>, C<setenv>, or C<export>: do these in an init() sub
|
|
|
|
run(
|
|
\cmd,
|
|
...
|
|
init => sub {
|
|
chdir $dir or die $!;
|
|
$ENV{FOO}='BAR'
|
|
}
|
|
);
|
|
|
|
Timeout calculation does not allow absolute times, or specification of
|
|
days, months, etc.
|
|
|
|
B<WARNING:> Function coprocesses (C<run \&foo, ...>) suffer from two
|
|
limitations. The first is that it is difficult to close all filehandles the
|
|
child inherits from the parent, since there is no way to scan all open
|
|
FILEHANDLEs in Perl and it both painful and a bit dangerous to close all open
|
|
file descriptors with C<POSIX::close()>. Painful because we can't tell which
|
|
fds are open at the POSIX level, either, so we'd have to scan all possible fds
|
|
and close any that we don't want open (normally C<exec()> closes any
|
|
non-inheritable but we don't C<exec()> for &sub processes.
|
|
|
|
The second problem is that Perl's DESTROY subs and other on-exit cleanup gets
|
|
run in the child process. If objects are instantiated in the parent before the
|
|
child is forked, the DESTROY will get run once in the parent and once in
|
|
the child. When coprocess subs exit, POSIX::_exit is called to work around this,
|
|
but it means that objects that are still referred to at that time are not
|
|
cleaned up. So setting package vars or closure vars to point to objects that
|
|
rely on DESTROY to affect things outside the process (files, etc), will
|
|
lead to bugs.
|
|
|
|
I goofed on the syntax: "<pipe" vs. "<pty<" and ">filename" are both
|
|
oddities.
|
|
|
|
=head1 TODO
|
|
|
|
=over
|
|
|
|
=item Allow one harness to "adopt" another:
|
|
|
|
$new_h = harness \@cmd2;
|
|
$h->adopt( $new_h );
|
|
|
|
=item Close all filehandles not explicitly marked to stay open.
|
|
|
|
The problem with this one is that there's no good way to scan all open
|
|
FILEHANDLEs in Perl, yet you don't want child processes inheriting handles
|
|
willy-nilly.
|
|
|
|
=back
|
|
|
|
=head1 INSPIRATION
|
|
|
|
Well, select() and waitpid() badly needed wrapping, and open3() isn't
|
|
open-minded enough for me.
|
|
|
|
The shell-like API inspired by a message Russ Allbery sent to perl5-porters,
|
|
which included:
|
|
|
|
I've thought for some time that it would be
|
|
nice to have a module that could handle full Bourne shell pipe syntax
|
|
internally, with fork and exec, without ever invoking a shell. Something
|
|
that you could give things like:
|
|
|
|
pipeopen (PIPE, [ qw/cat file/ ], '|', [ 'analyze', @args ], '>&3');
|
|
|
|
Message ylln51p2b6.fsf@windlord.stanford.edu, on 2000/02/04.
|
|
|
|
=head1 SUPPORT
|
|
|
|
Bugs should always be submitted via the GitHub bug tracker
|
|
|
|
L<https://github.com/toddr/IPC-Run/issues>
|
|
|
|
=head1 AUTHORS
|
|
|
|
Adam Kennedy <adamk@cpan.org>
|
|
|
|
Barrie Slaymaker <barries@slaysys.com>
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Some parts copyright 2008 - 2009 Adam Kennedy.
|
|
|
|
Copyright 1999 Barrie Slaymaker.
|
|
|
|
You may distribute under the terms of either the GNU General Public
|
|
License or the Artistic License, as specified in the README file.
|
|
|
|
=cut
|