diff options
author | Rafael Garcia-Suarez <rgarciasuarez@gmail.com> | 2005-03-22 15:30:18 +0000 |
---|---|---|
committer | Rafael Garcia-Suarez <rgarciasuarez@gmail.com> | 2005-03-22 15:30:18 +0000 |
commit | 74969006268f55e199dd9a95a052217885269405 (patch) | |
tree | 2ca74c7bcb9e90059d01d18c0401b2bd0e8b6b8c | |
parent | 3ffe3ee448ef9bbf97ab82f8e68a3a749541b012 (diff) | |
download | perl-74969006268f55e199dd9a95a052217885269405.tar.gz |
Remove IPC::Run for 5.9.2
p4raw-id: //depot/perl@24071
-rw-r--r-- | MANIFEST | 22 | ||||
-rw-r--r-- | lib/IPC/Run.pm | 4476 | ||||
-rw-r--r-- | lib/IPC/Run/Debug.pm | 311 | ||||
-rw-r--r-- | lib/IPC/Run/IO.pm | 554 | ||||
-rw-r--r-- | lib/IPC/Run/Timer.pm | 688 | ||||
-rw-r--r-- | lib/IPC/Run/Win32Helper.pm | 481 | ||||
-rw-r--r-- | lib/IPC/Run/Win32IO.pm | 556 | ||||
-rw-r--r-- | lib/IPC/Run/Win32Pump.pm | 162 | ||||
-rw-r--r-- | lib/IPC/Run/t/adopt.t | 120 | ||||
-rw-r--r-- | lib/IPC/Run/t/binmode.t | 102 | ||||
-rw-r--r-- | lib/IPC/Run/t/bogus.t | 69 | ||||
-rw-r--r-- | lib/IPC/Run/t/filter.t | 120 | ||||
-rw-r--r-- | lib/IPC/Run/t/harness.t | 149 | ||||
-rw-r--r-- | lib/IPC/Run/t/io.t | 133 | ||||
-rw-r--r-- | lib/IPC/Run/t/kill_kill.t | 59 | ||||
-rw-r--r-- | lib/IPC/Run/t/parallel.t | 110 | ||||
-rw-r--r-- | lib/IPC/Run/t/pty.t | 275 | ||||
-rw-r--r-- | lib/IPC/Run/t/pump.t | 119 | ||||
-rw-r--r-- | lib/IPC/Run/t/run.t | 1080 | ||||
-rw-r--r-- | lib/IPC/Run/t/signal.t | 90 | ||||
-rw-r--r-- | lib/IPC/Run/t/timeout.t | 117 | ||||
-rw-r--r-- | lib/IPC/Run/t/timer.t | 150 | ||||
-rw-r--r-- | lib/IPC/Run/t/win32_compile.t | 92 |
23 files changed, 0 insertions, 10035 deletions
@@ -1479,28 +1479,6 @@ lib/IPC/Open2.pm Open a two-ended pipe lib/IPC/Open2.t See if IPC::Open2 works lib/IPC/Open3.pm Open a three-ended pipe! lib/IPC/Open3.t See if IPC::Open3 works -lib/IPC/Run/Debug.pm IPC::Run -lib/IPC/Run/IO.pm IPC::Run -lib/IPC/Run.pm IPC::Run -lib/IPC/Run/t/adopt.t IPC::Run -lib/IPC/Run/t/binmode.t IPC::Run -lib/IPC/Run/t/bogus.t IPC::Run -lib/IPC/Run/t/filter.t IPC::Run -lib/IPC/Run/t/harness.t IPC::Run -lib/IPC/Run/Timer.pm IPC::Run -lib/IPC/Run/t/io.t IPC::Run -lib/IPC/Run/t/kill_kill.t IPC::Run -lib/IPC/Run/t/parallel.t IPC::Run -lib/IPC/Run/t/pty.t IPC::Run -lib/IPC/Run/t/pump.t IPC::Run -lib/IPC/Run/t/run.t IPC::Run -lib/IPC/Run/t/signal.t IPC::Run -lib/IPC/Run/t/timeout.t IPC::Run -lib/IPC/Run/t/timer.t IPC::Run -lib/IPC/Run/t/win32_compile.t IPC::Run -lib/IPC/Run/Win32Helper.pm IPC::Run -lib/IPC/Run/Win32IO.pm IPC::Run -lib/IPC/Run/Win32Pump.pm IPC::Run lib/less.pm For "use less" lib/less.t See if less support works lib/lib_pm.PL For "use lib", produces lib/lib.pm diff --git a/lib/IPC/Run.pm b/lib/IPC/Run.pm deleted file mode 100644 index fd21836c97..0000000000 --- a/lib/IPC/Run.pm +++ /dev/null @@ -1,4476 +0,0 @@ -package IPC::Run ; -# -# Copyright (c) 1999 by Barrie Slaymaker, barries@slaysys.com -# -# You may distribute under the terms of either the GNU General Public -# License or the Artistic License, as specified in the README file. -# - -$VERSION = 0.80; - -=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 \@cmd, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?" - - # Can do I/O to sub refs and filenames, too: - run \@cmd, '<', "in.txt", \&out, \&err or die "cat: $?" - run \@cat, '<', "in.txt", '>>', "out.txt", '2>>', "err.txt" ; - - - # Redirecting using psuedo-terminals instad 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, - '>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 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 ocurred 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 desciptors 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 - -Psuedo-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 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 - -@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 () ;". - -my @FILTER_IMP = qw( input_avail get_more_input ) ; -my @FILTERS = qw( - new_appender - new_chunker - new_string_source - new_string_sink -) ; -my @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( filter_tests 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 () ; -use Symbol ; -use Carp ; -use File::Spec ; -use IO::Handle ; -require IPC::Run::IO ; -require IPC::Run::Timer ; -use UNIVERSAL qw( isa ) ; - -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() ; - -############################################################################### - -## -## 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 ; -} - -## -## 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 !~ /\..+$/ ) ## Only run if cmd_name has no extension? - ) { - for ( split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE" ) { - my $name = "$cmd_name$_"; - $cmd_name = $name, last if -f $name && -x _; - } - } - - 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] ; - no strict 'refs' ; - 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} = 1 ; - 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} = 1 ; - 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 beign a workaround, we don't want -# # old values of $! causing spurious strerr() -# # messages to appear in the "Can't exec" message -# undef $! ; - exec @_ ; -# } -# 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], 0644 ) ; - croak "$!: open( $_[0], ", sprintf( "0x%03x", $_[1] ), " )" unless defined $r ; - _debug "open( $_[0], ", sprintf( "0x%03x", $_[1] ), " ) = $r" - if _debugging_data ; - $fds{$r} = 1 ; - 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} = $fds{$w} = 1 ; - 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} = $fds{$pty->slave->fileno} = 1 ; - 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 $! != POSIX::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 ; -} - - -=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 propogating -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 ; -} - - -=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 ; -} - - -=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 sucessfully C<KILL> the -processes. - -The 30 seconds may be overriden 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 ; - - $self->signal( "TERM" ) ; - - my $quitting_time = time + $grace ; - my $delay = 0.01 ; - my $accum_delay ; - - my $have_killed_before ; - - while () { - ## delay first to yeild 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 ; -} - - -=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 outweight 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 ) { - @args = ( [ qw( command /c ), win32_parse_cmd_line $_[0] ] ) ; - } - else { - @args = ( [ qw( sh -c ), @_ ] ) ; - } - } - elsif ( @_ > 1 && ! grep ref $_, @_ ) { - @args = ( [ @_ ] ) ; - } - else { - @args = @_ ; - } - - 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 $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, - } ; - push @{$self->{KIDS}}, $cur_kid ; - $succinct = 1 ; - } - - elsif ( isa( $_, 'IPC::Run::IO' ) ) { - push @{$self->{IOS}}, $_ ; - $cur_kid = undef ; - $succinct = 1 ; - } - - elsif ( 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] && ! isa $args[1], "IPC::Run::Timer" ) - || isa $args[0], "IPC::Run::binmode_pseudo_filter" - ) - ) { - if ( 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' || 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] && ! isa $args[1], "IPC::Run::Timer" ) - || isa $args[0], "IPC::Run::binmode_pseudo_filter" - ) - ) { - if ( isa $args[0], "IPC::Run::binmode_pseudo_filter" ) { - $binmode = shift( @args )->() ; - } - else { - unshift @filters, shift @args ; - } - } - } - - $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 ( ( isa( $dest, 'GLOB' ) || 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 ; - unshift @{$cur_kid->{OPS}}, { - TYPE => 'close', - KFD => 0, - } ; - $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 ( isa( $source, 'GLOB' ) - || 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 ( 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 ( 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 ( 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 ( 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 ( 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 ( 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 ( 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 ( 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 ( 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 - $@ =~ /^Input\/output error: read/ || - ($@ =~ /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 ; - - my $c = _write( $pipe->{FD}, $$in_ref ) ; - substr( $$in_ref, 0, $c, '' ) ; - 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 ; - } - $self->{DEBUG_FD} = _dup $self->{DEBUG_FD} - if defined $self->{DEBUG_FD} && $self->{DEBUG_FD} == $fd2 ; - - _dup2_rudely( $fd1, $fd2 ) ; -} - -=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 - - 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 ) = @_ ; - - ## 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 probpogate. - my $s1 = gensym ; - my $s2 = gensym ; - - eval { - local $cur_self = $self ; - - _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. - my @needed = $self->{noinherit} ? () : ( 1, 1, 1 ) ; - $needed[ $self->{SYNC_WRITER_FD} ] = 1 ; - $needed[ $self->{DEBUG_FD} ] = 1 if defined $self->{DEBUG_FD} ; - - for ( @{$kid->{OPS}} ) { - $needed[ $_->{TFD} ] = 1 if defined $_->{TFD} ; - } - - ## 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. - my @closed ; - if ( %{$self->{PTYS}} ) { - ## Clean up the parent's fds. - for ( keys %{$self->{PTYS}} ) { - _debug "Cleaning up parent's ptty '$_'" if _debugging_details ; - my $slave = $self->{PTYS}->{$_}->slave ; - $closed[ $self->{PTYS}->{$_}->fileno ] = 1 ; - close $self->{PTYS}->{$_} ; - $self->{PTYS}->{$_} = $slave ; - } - - close_terminal ; - $closed[ $_ ] = 1 for ( 0..2 ) ; - } - - for my $sibling ( @{$self->{KIDS}} ) { - for ( @{$sibling->{OPS}} ) { - if ( $_->{TYPE} =~ /^.pty.$/ ) { - $_->{TFD} = $self->{PTYS}->{$_->{PTY_ID}}->fileno ; - $needed[$_->{TFD}] = 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 ; - for (keys %fds) { - if ( ! $closed[$_] && ! $needed[$_] ) { - _close( $_ ) ; - $closed[$_] = 1 ; - } - } - - ## Lazy closing is so the same fd (ie the same TFD value) can be dup2'ed on - ## several times. - my @lazy_close ; - for ( @{$kid->{OPS}} ) { - if ( defined $_->{TFD} ) { - unless ( $_->{TFD} == $_->{KFD} ) { - $self->_dup2_gently( $kid->{OPS}, $_->{TFD}, $_->{KFD} ) ; - push @lazy_close, $_->{TFD} ; - } - } - elsif ( $_->{TYPE} eq 'dup' ) { - $self->_dup2_gently( $kid->{OPS}, $_->{KFD1}, $_->{KFD2} ) - unless $_->{KFD1} == $_->{KFD2} ; - } - elsif ( $_->{TYPE} eq 'close' ) { - for ( $_->{KFD} ) { - if ( ! $closed[$_] ) { - _close( $_ ) ; - $closed[$_] = 1 ; - $_ = undef ; - } - } - } - elsif ( $_->{TYPE} eq 'init' ) { - $_->{SUB}->() ; - } - } - - for ( @lazy_close ) { - unless ( $closed[$_] ) { - _close( $_ ) ; - $closed[$_] = 1 ; - } - } - - 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 ; - } - - my @cmd = ( $kid->{PATH}, @{$kid->{VAL}}[1..$#{$kid->{VAL}}] ) ; - _debug 'execing ', join " ", map { /[\s"]/ ? "'$_'" : $_ } @cmd - if _debugging ; - - 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 ; -} - - -=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 && 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 ; local $| = 1 ; select $ofh; } - { my $ofh = select STDERR ; local $| = 1 ; 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 spawing 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 ; -} - - -sub adopt { - ## NOT FUNCTIONAL YET, NEED TO CLOSE FDS BETTER IN CHILDREN. SEE - ## t/adopt.t for a test suite. - 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 ( 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 occured 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} ; - - croak "$! in select" if $nfound < 0 and $! != POSIX::EINTR; - ## 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 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 beleive 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 ; -} - - -=item pump - - pump $h ; - $h->pump ; - -Pump accepts a single parameter harness. It blocks until it delivers some -input or recieves 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 a single harness as a parameter" - unless @_ == 1 && 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 ; -} - - -=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 ; -} - -=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}} ; -} - - -=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 beign 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} = $? ; - } - } - } -} - - -=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 ; -} - - -=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 result { - &_assert_finished ; - my IPC::Run $self = shift ; - - if ( @_ ) { - my ( $which ) = @_ ; - croak( - "Only ", - scalar( @{$self->{KIDS}} ), - " child processes, no process $which" - ) - unless $which >= 0 && $which <= $#{$self->{KIDS}} ; - return $self->{KIDS}->[$which]->{RESULT} >> 8 ; - } - else { - return undef unless @{$self->{KIDS}} ; - for ( @{$self->{KIDS}} ) { - return $_->{RESULT} >> 8 if $_->{RESULT} >> 8 ; - } - } -} - - -=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}} ; -} - - -=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 $? >> 8 - $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 { - goto &result if @_ > 1 ; - &_assert_finished ; - - my IPC::Run $self = shift ; - - return undef unless @{$self->{KIDS}} ; - for ( @{$self->{KIDS}} ) { - return $_->{RESULT} if $_->{RESULT} ; - } -} - - -=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 -## - -=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" ; -} - -=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 ; - } - } - } ; -} - - -=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 ; - } - } ; -} - - -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 ; - } -} - - -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 puctuation). 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} ; -#} - -=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( @_ ) ; -} - -=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 ; - - -=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 ; - - -=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 ; -} - - -=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 ; -} - - -## This is not needed by most users. Should really move to IPC::Run::TestUtils -#=item filter_tests -# -# my @tests = filter_tests( "foo", "in", "out", \&filter ) ; -# $_->() for ( @tests ) ; -# -#This creates a list of test subs that can be used to test most filters -#for basic functionality. The first parameter is the name of the -#filter to be tested, the second is sample input, the third is the -#test(s) to apply to the output(s), and the rest of the parameters are -#the filters to be linked and tested. -# -#If the filter chain is to be fed multiple inputs in sequence, the second -#parameter should be a reference to an array of thos inputs: -# -# my @tests = filter_tests( "foo", [qw(1 2 3)], "123", \&filter ) ; -# -#If the filter chain should produce a sequence of outputs, then the -#thrid parameter should be a reference to an array of those outputs: -# -# my @tests = filter_tests( -# "foo", -# "1\n\2\n", -# [ qr/^1$/, qr/^2$/ ], -# new_chunker -# ) ; -# -#See t/run.t and t/filter.t for an example of this in practice. -# -#=cut - -## -## Filter testing routines -## -sub filter_tests($;@) { - my ( $name, $in, $exp, @filters ) = @_ ; - - my @in = ref $in eq 'ARRAY' ? @$in : ( $in ) ; - my @exp = ref $exp eq 'ARRAY' ? @$exp : ( $exp ) ; - - require Test ; - *ok = \&Test::ok ; - - my IPC::Run::IO $op ; - my $output ; - my @input ; - my $in_count = 0 ; - - my @out ; - - my $h ; - - return ( - sub { - $h = harness() ; - $op = IPC::Run::IO->_new_internal( '<', 0, 0, 0, undef, - new_string_sink( \$output ), - @filters, - new_string_source( \@input ), - ) ; - $op->_init_filters ; - @input = () ; - $output = '' ; - ok( - ! defined $op->_do_filters( $h ), - 1, - "$name didn't pass undef (EOF) through" - ) ; - }, - - ## See if correctly does nothing on 0, (please try again) - sub { - $op->_init_filters ; - $output = '' ; - @input = ( '' ) ; - ok( - $op->_do_filters( $h ), - 0, - "$name didn't return 0 (please try again) when given a 0" - ) ; - }, - - sub { - @input = ( '' ) ; - ok( - $op->_do_filters( $h ), - 0, - "$name didn't return 0 (please try again) when given a second 0" - ) ; - }, - - sub { - for (1..100) { - last unless defined $op->_do_filters( $h ) ; - } - ok( - ! defined $op->_do_filters( $h ), - 1, - "$name didn't return undef (EOF) after two 0s and an undef" - ) ; - }, - - ## See if it can take @in and make @out - sub { - $op->_init_filters ; - $output = '' ; - @input = @in ; - while ( defined $op->_do_filters( $h ) && @input ) { - if ( length $output ) { - push @out, $output ; - $output = '' ; - } - } - if ( length $output ) { - push @out, $output ; - $output = '' ; - } - ok( - scalar @input, - 0, - "$name didn't consume it's input" - ) ; - }, - - sub { - for (1..100) { - last unless defined $op->_do_filters( $h ) ; - if ( length $output ) { - push @out, $output ; - $output = '' ; - } - } - ok( - ! defined $op->_do_filters( $h ), - 1, - "$name didn't return undef (EOF), tried 100 times" - ) ; - }, - - sub { - ok( - join( ', ', map "'$_'", @out ), - join( ', ', map "'$_'", @exp ), - $name - ) - }, - - sub { - ## Force the harness to be cleaned up. - $h = undef ; - ok( 1 ) ; - } - ) ; -} - - -=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 independant 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 mechnism. 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 chile 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 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 AUTHOR - -Barrie Slaymaker <barries@slaysys.com>, with numerous suggestions by p5p. - -=cut - -1 ; diff --git a/lib/IPC/Run/Debug.pm b/lib/IPC/Run/Debug.pm deleted file mode 100644 index 9b2c452801..0000000000 --- a/lib/IPC/Run/Debug.pm +++ /dev/null @@ -1,311 +0,0 @@ -package IPC::Run::Debug; - -=head1 NAME - -IPC::Run::Debug - debugging routines for IPC::Run - -=head1 SYNOPSIS - - ## - ## Environment variable usage - ## - ## To force debugging off and shave a bit of CPU and memory - ## by compile-time optimizing away all debugging code in IPC::Run - ## (debug => ...) options to IPC::Run will be ignored. - export IPCRUNDEBUG=none - - ## To force debugging on (levels are from 0..10) - export IPCRUNDEBUG=basic - - ## Leave unset or set to "" to compile in debugging support and - ## allow runtime control of it using the debug option. - -=head1 DESCRIPTION - -Controls IPC::Run debugging. Debugging levels are now set by using words, -but the numbers shown are still supported for backwards compatability: - - 0 none disabled (special, see below) - 1 basic what's running - 2 data what's being sent/recieved - 3 details what's going on in more detail - 4 gory way too much detail for most uses - 10 all use this when submitting bug reports - noopts optimizations forbidden due to inherited STDIN - -The C<none> level is special when the environment variable IPCRUNDEBUG -is set to this the first time IPC::Run::Debug is loaded: it prevents -the debugging code from being compiled in to the remaining IPC::Run modules, -saving a bit of cpu. - -To do this in a script, here's a way that allows it to be overridden: - - BEGIN { - unless ( defined $ENV{IPCRUNDEBUG} ) { - eval 'local $ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"' - or die $@; - } - } - -This should force IPC::Run to not be debuggable unless somebody sets -the IPCRUNDEBUG flag; modify this formula to grep @ARGV if need be: - - BEGIN { - unless ( grep /^--debug/, @ARGV ) { - eval 'local $ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"' - or die $@; - } - -Both of those are untested. - -=cut - -@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 () ;". - -@EXPORT = qw( - _debug - _debug_desc_fd - _debugging - _debugging_data - _debugging_details - _debugging_gory_details - _debugging_not_optimized - _set_child_debug_name -); - - -@EXPORT_OK = qw( - _debug_init - _debugging_level - _map_fds -); - -%EXPORT_TAGS = ( - default => \@EXPORT, - all => [ @EXPORT, @EXPORT_OK ], -); - -use strict ; -use Exporter ; - -my $disable_debugging = - defined $ENV{IPCRUNDEBUG} - && ( - ! $ENV{IPCRUNDEBUG} - || lc $ENV{IPCRUNDEBUG} eq "none" - ); - -eval( $disable_debugging ? <<'STUBS' : <<'SUBS' ) or die $@; -sub _map_fds() { "" } -sub _debug {} -sub _debug_desc_fd {} -sub _debug_init {} -sub _set_child_debug_name {} -sub _debugging() { 0 } -sub _debugging_level() { 0 } -sub _debugging_data() { 0 } -sub _debugging_details() { 0 } -sub _debugging_gory_details() { 0 } -sub _debugging_not_optimized() { 0 } - -1; -STUBS - -use POSIX; -use UNIVERSAL qw( isa ); - -sub _map_fds { - my $map = '' ; - my $digit = 0 ; - my $in_use ; - my $dummy ; - for my $fd (0..63) { - ## I'd like a quicker way (less user, cpu & expecially sys and kernal - ## calls) to detect open file descriptors. Let me know... - ## Hmmm, could do a 0 length read and check for bad file descriptor... - ## but that segfaults on Win32 - my $test_fd = POSIX::dup( $fd ) ; - $in_use = defined $test_fd ; - POSIX::close $test_fd if $in_use ; - $map .= $in_use ? $digit : '-'; - $digit = 0 if ++$digit > 9 ; - } - warn "No fds open???" unless $map =~ /\d/ ; - $map =~ s/(.{1,12})-*$/$1/ ; - return $map ; -} - -use vars qw( $parent_pid ) ; - -$parent_pid = $$ ; - -## TODO: move debugging to it's own module and make it compile-time -## optimizable. - -## Give kid process debugging nice names -my $debug_name ; - -sub _set_child_debug_name { - $debug_name = shift; -} - -## 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. -# -my %debug_levels = ( - none => 0, - basic => 1, - data => 2, - details => 3, - gore => 4, - gory_details => 4, - "gory details" => 4, - gory => 4, - gorydetails => 4, - all => 10, - notopt => 0, -); - -my $warned; - -sub _debugging_level() { - my $level = 0 ; - - $level = $IPC::Run::cur_self->{debug} || 0 - if $IPC::Run::cur_self - && ( $IPC::Run::cur_self->{debug} || 0 ) >= $level ; - - if ( defined $ENV{IPCRUNDEBUG} ) { - my $v = $ENV{IPCRUNDEBUG}; - $v = $debug_levels{lc $v} if $v =~ /[a-zA-Z]/; - unless ( defined $v ) { - $warned ||= warn "Unknown debug level $ENV{IPCRUNDEBUG}, assuming 'basic' (1)\n"; - $v = 1; - } - $level = $v if $v > $level ; - } - return $level ; -} - -sub _debugging_atleast($) { - my $min_level = shift || 1 ; - - my $level = _debugging_level ; - - return $level >= $min_level ? $level : 0 ; -} - -sub _debugging() { _debugging_atleast 1 } -sub _debugging_data() { _debugging_atleast 2 } -sub _debugging_details() { _debugging_atleast 3 } -sub _debugging_gory_details() { _debugging_atleast 4 } -sub _debugging_not_optimized() { ( $ENV{IPCRUNDEBUG} || "" ) eq "notopt" } - -sub _debug_init { - ## This routine is called only in spawned children to fake out the - ## debug routines so they'll emit debugging info. - $IPC::Run::cur_self = {} ; - ( $parent_pid, - $^T, - $IPC::Run::cur_self->{debug}, - $IPC::Run::cur_self->{DEBUG_FD}, - $debug_name - ) = @_ ; -} - - -sub _debug { -# return unless _debugging || _debugging_not_optimized ; - - my $fd = defined &IPC::Run::_debug_fd - ? IPC::Run::_debug_fd() - : fileno STDERR; - - my $s ; - my $debug_id ; - $debug_id = join( - " ", - join( - "", - defined $IPC::Run::cur_self ? "#$IPC::Run::cur_self->{ID}" : (), - "($$)", - ), - defined $debug_name && length $debug_name ? $debug_name : (), - ) ; - my $prefix = join( - "", - "IPC::Run", - sprintf( " %04d", time - $^T ), - ( _debugging_details ? ( " ", _map_fds ) : () ), - length $debug_id ? ( " [", $debug_id, "]" ) : (), - ": ", - ) ; - - my $msg = join( '', map defined $_ ? $_ : "<undef>", @_ ) ; - chomp $msg ; - $msg =~ s{^}{$prefix}gm ; - $msg .= "\n" ; - POSIX::write( $fd, $msg, length $msg ) ; -} - - -my @fd_descs = ( 'stdin', 'stdout', 'stderr' ) ; - -sub _debug_desc_fd { - return unless _debugging ; - my $text = shift ; - my $op = pop ; - my $kid = $_[0] ; - -Carp::carp join " ", caller(0), $text, $op if defined $op && isa( $op, "IO::Pty" ) ; - - _debug( - $text, - ' ', - ( defined $op->{FD} - ? $op->{FD} < 3 - ? ( $fd_descs[$op->{FD}] ) - : ( 'fd ', $op->{FD} ) - : $op->{FD} - ), - ( defined $op->{KFD} - ? ( - ' (kid', - ( defined $kid ? ( ' ', $kid->{NUM}, ) : () ), - "'s ", - ( $op->{KFD} < 3 - ? $fd_descs[$op->{KFD}] - : defined $kid - && defined $kid->{DEBUG_FD} - && $op->{KFD} == $kid->{DEBUG_FD} - ? ( 'debug (', $op->{KFD}, ')' ) - : ( 'fd ', $op->{KFD} ) - ), - ')', - ) - : () - ), - ) ; -} - -1; - -SUBS - -=head1 AUTHOR - -Barrie Slaymaker <barries@slaysys.com>, with numerous suggestions by p5p. - -=cut - -1 ; diff --git a/lib/IPC/Run/IO.pm b/lib/IPC/Run/IO.pm deleted file mode 100644 index a6ce1d990a..0000000000 --- a/lib/IPC/Run/IO.pm +++ /dev/null @@ -1,554 +0,0 @@ -package IPC::Run::IO ; - -=head1 NAME - - IPC::Run::IO -- I/O channels for IPC::Run. - -=head1 SYNOPSIS - -B<NOT IMPLEMENTED YET ON Win32! Win32 does not allow select() on -normal file descriptors; IPC::RUN::IO needs to use IPC::Run::Win32Helper -to do this.> - - use IPC::Run qw( io ) ; - - ## The sense of '>' and '<' is opposite of perl's open(), - ## but agrees with IPC::Run. - $io = io( "filename", '>', \$recv ) ; - $io = io( "filename", 'r', \$recv ) ; - - ## Append to $recv: - $io = io( "filename", '>>', \$recv ) ; - $io = io( "filename", 'ra', \$recv ) ; - - $io = io( "filename", '<', \$send ) ; - $io = io( "filename", 'w', \$send ) ; - - $io = io( "filename", '<<', \$send ) ; - $io = io( "filename", 'wa', \$send ) ; - - ## Handles / IO objects that the caller opens: - $io = io( \*HANDLE, '<', \$send ) ; - - $f = IO::Handle->new( ... ) ; # Any subclass of IO::Handle - $io = io( $f, '<', \$send ) ; - - require IPC::Run::IO ; - $io = IPC::Run::IO->new( ... ) ; - - ## Then run(), harness(), or start(): - run $io, ... ; - - ## You can, of course, use io() or IPC::Run::IO->new() as an - ## argument to run(), harness, or start(): - run io( ... ) ; - - -=head1 DESCRIPTION - -This class and module allows filehandles and filenames to be harnessed for -I/O when used IPC::Run, independant of anything else IPC::Run is doing -(except that errors & exceptions can affect all things that IPC::Run is -doing). - -=head1 SUBCLASSING - -INCOMPATIBLE CHANGE: due to the awkwardness introduced in ripping pseudohashes -out of Perl, this class I<no longer> uses the fields pragma. - -=head1 TODO - -Implement bidirectionality. - -=head1 AUTHOR - -Barrie Slaymaker <barries@slaysys.com> - -=cut ; - -## This class is also used internally by IPC::Run in a very initimate way, -## since this is a partial factoring of code from IPC::Run plus some code -## needed to do standalone channels. This factoring process will continue -## at some point. Don't know how far how fast. - -use strict ; -use Carp ; -use Fcntl ; -use Symbol ; -use UNIVERSAL qw( isa ) ; - -use IPC::Run::Debug; -use IPC::Run qw( Win32_MODE ); - -BEGIN { - if ( Win32_MODE ) { - eval "use IPC::Run::Win32Helper; require IPC::Run::Win32IO; 1" - or ( $@ && die ) or die "$!" ; - } -} - -sub _empty($) ; - -*_empty = \&IPC::Run::_empty ; - - -sub new { - my $class = shift ; - $class = ref $class || $class ; - - my ( $external, $type, $internal ) = ( shift, shift, pop ) ; - - croak "$class: '$_' is not a valid I/O operator" - unless $type =~ /^(?:<<?|>>?)$/ ; - - my IPC::Run::IO $self = $class->_new_internal( - $type, undef, undef, $internal, undef, @_ - ) ; - - if ( ! ref $external ) { - $self->{FILENAME} = $external ; - } - elsif ( ref eq 'GLOB' || isa( $external, 'IO::Handle' ) ) { - $self->{HANDLE} = $external ; - $self->{DONT_CLOSE} = 1 ; - } - else { - croak "$class: cannot accept " . ref( $external ) . " to do I/O with" ; - } - - return $self ; -} - - -## IPC::Run uses this ctor, since it preparses things and needs more -## smarts. -sub _new_internal { - my $class = shift ; - $class = ref $class || $class ; - - $class = "IPC::Run::Win32IO" - if Win32_MODE && $class eq "IPC::Run::IO"; - - my IPC::Run::IO $self ; - $self = bless {}, $class ; - - my ( $type, $kfd, $pty_id, $internal, $binmode, @filters ) = @_ ; - - # Older perls (<=5.00503, at least) don't do list assign to - # psuedo-hashes well. - $self->{TYPE} = $type ; - $self->{KFD} = $kfd ; - $self->{PTY_ID} = $pty_id ; - $self->binmode( $binmode ) ; - $self->{FILTERS} = [ @filters ] ; - - ## Add an adapter to the end of the filter chain (which is usually just the - ## read/writer sub pushed by IPC::Run) to the DEST or SOURCE, if need be. - if ( $self->op =~ />/ ) { - croak "'$_' missing a destination" if _empty $internal ; - $self->{DEST} = $internal ; - if ( isa( $self->{DEST}, 'CODE' ) ) { - ## Put a filter on the end of the filter chain to pass the - ## output on to the CODE ref. For SCALAR refs, the last - ## filter in the chain writes directly to the scalar itself. See - ## _init_filters(). For CODE refs, however, we need to adapt from - ## the SCALAR to calling the CODE. - unshift( - @{$self->{FILTERS}}, - sub { - my ( $in_ref ) = @_ ; - - return IPC::Run::input_avail() && do { - $self->{DEST}->( $$in_ref ) ; - $$in_ref = '' ; - 1 ; - } - } - ) ; - } - } - else { - croak "'$_' missing a source" if _empty $internal ; - $self->{SOURCE} = $internal ; - if ( isa( $internal, 'CODE' ) ) { - push( - @{$self->{FILTERS}}, - sub { - my ( $in_ref, $out_ref ) = @_ ; - return 0 if length $$out_ref ; - - return undef - if $self->{SOURCE_EMPTY} ; - - my $in = $internal->() ; - unless ( defined $in ) { - $self->{SOURCE_EMPTY} = 1 ; - return undef - } - return 0 unless length $in ; - $$out_ref = $in ; - - return 1 ; - } - ) ; - } - elsif ( isa( $internal, 'SCALAR' ) ) { - push( - @{$self->{FILTERS}}, - sub { - my ( $in_ref, $out_ref ) = @_ ; - return 0 if length $$out_ref ; - - ## pump() clears auto_close_ins, finish() sets it. - return $self->{HARNESS}->{auto_close_ins} ? undef : 0 - if IPC::Run::_empty ${$self->{SOURCE}} - || $self->{SOURCE_EMPTY} ; - - $$out_ref = $$internal ; - eval { $$internal = '' } - if $self->{HARNESS}->{clear_ins} ; - - $self->{SOURCE_EMPTY} = $self->{HARNESS}->{auto_close_ins} ; - - return 1 ; - } - ) ; - } - } - - return $self ; -} - - -=item filename - -Gets/sets the filename. Returns the value after the name change, if -any. - -=cut - -sub filename { - my IPC::Run::IO $self = shift ; - $self->{FILENAME} = shift if @_ ; - return $self->{FILENAME} ; -} - - -=item init - -Does initialization required before this can be run. This includes open()ing -the file, if necessary, and clearing the destination scalar if necessary. - -=cut - -sub init { - my IPC::Run::IO $self = shift ; - - $self->{SOURCE_EMPTY} = 0 ; - ${$self->{DEST}} = '' - if $self->mode =~ /r/ && ref $self->{DEST} eq 'SCALAR' ; - - $self->open if defined $self->filename ; - $self->{FD} = $self->fileno ; - - if ( ! $self->{FILTERS} ) { - $self->{FBUFS} = undef ; - } - else { - @{$self->{FBUFS}} = map { - my $s = "" ; - \$s ; - } ( @{$self->{FILTERS}}, '' ) ; - - $self->{FBUFS}->[0] = $self->{DEST} - if $self->{DEST} && ref $self->{DEST} eq 'SCALAR' ; - push @{$self->{FBUFS}}, $self->{SOURCE} ; - } - - return undef ; -} - - -=item open - -If a filename was passed in, opens it. Determines if the handle is open -via fileno(). Throws an exception on error. - -=cut - -my %open_flags = ( - '>' => O_RDONLY, - '>>' => O_RDONLY, - '<' => O_WRONLY | O_CREAT | O_TRUNC, - '<<' => O_WRONLY | O_CREAT | O_APPEND, -) ; - -sub open { - my IPC::Run::IO $self = shift ; - - croak "IPC::Run::IO: Can't open() a file with no name" - unless defined $self->{FILENAME} ; - $self->{HANDLE} = gensym unless $self->{HANDLE} ; - - _debug - "opening '", $self->filename, "' mode '", $self->mode, "'" - if _debugging_data ; - sysopen( - $self->{HANDLE}, - $self->filename, - $open_flags{$self->op}, - ) or croak - "IPC::Run::IO: $! opening '$self->{FILENAME}', mode '" . $self->mode . "'" ; - - return undef ; -} - - -=item open_pipe - -If this is a redirection IO object, this opens the pipe in a platform -independant manner. - -=cut - -sub _do_open { - my $self = shift; - my ( $child_debug_fd, $parent_handle ) = @_ ; - - - if ( $self->dir eq "<" ) { - ( $self->{TFD}, $self->{FD} ) = IPC::Run::_pipe_nb ; - if ( $parent_handle ) { - CORE::open $parent_handle, ">&=$self->{FD}" - or croak "$! duping write end of pipe for caller" ; - } - } - else { - ( $self->{FD}, $self->{TFD} ) = IPC::Run::_pipe ; - if ( $parent_handle ) { - CORE::open $parent_handle, "<&=$self->{FD}" - or croak "$! duping read end of pipe for caller" ; - } - } -} - -sub open_pipe { - my IPC::Run::IO $self = shift ; - - ## Hmmm, Maybe allow named pipes one day. But until then... - croak "IPC::Run::IO: Can't pipe() when a file name has been set" - if defined $self->{FILENAME} ; - - $self->_do_open( @_ ); - - ## return ( child_fd, parent_fd ) - return $self->dir eq "<" - ? ( $self->{TFD}, $self->{FD} ) - : ( $self->{FD}, $self->{TFD} ) ; -} - - -sub _cleanup { ## Called from Run.pm's _cleanup - my $self = shift; - undef $self->{FAKE_PIPE}; -} - - -=item close - -Closes the handle. Throws an exception on failure. - - -=cut - -sub close { - my IPC::Run::IO $self = shift ; - - if ( defined $self->{HANDLE} ) { - close $self->{HANDLE} - or croak( "IPC::Run::IO: $! closing " - . ( defined $self->{FILENAME} - ? "'$self->{FILENAME}'" - : "handle" - ) - ) ; - } - else { - IPC::Run::_close( $self->{FD} ) ; - } - - $self->{FD} = undef ; - - return undef ; -} - -=item fileno - -Returns the fileno of the handle. Throws an exception on failure. - - -=cut - -sub fileno { - my IPC::Run::IO $self = shift ; - - my $fd = fileno $self->{HANDLE} ; - croak( "IPC::Run::IO: $! " - . ( defined $self->{FILENAME} - ? "'$self->{FILENAME}'" - : "handle" - ) - ) unless defined $fd ; - - return $fd ; -} - -=item mode - -Returns the operator in terms of 'r', 'w', and 'a'. There is a state -'ra', unlike Perl's open(), which indicates that data read from the -handle or file will be appended to the output if the output is a scalar. -This is only meaningful if the output is a scalar, it has no effect if -the output is a subroutine. - -The redirection operators can be a little confusing, so here's a reference -table: - - > r Read from handle in to process - < w Write from process out to handle - >> ra Read from handle in to process, appending it to existing - data if the destination is a scalar. - << wa Write from process out to handle, appending to existing - data if IPC::Run::IO opened a named file. - -=cut - -sub mode { - my IPC::Run::IO $self = shift ; - - croak "IPC::Run::IO: unexpected arguments for mode(): @_" if @_ ; - - ## TODO: Optimize this - return ( $self->{TYPE} =~ /</ ? 'w' : 'r' ) . - ( $self->{TYPE} =~ /<<|>>/ ? 'a' : '' ) ; -} - - -=item op - -Returns the operation: '<', '>', '<<', '>>'. See L</mode> if you want -to spell these 'r', 'w', etc. - -=cut - -sub op { - my IPC::Run::IO $self = shift ; - - croak "IPC::Run::IO: unexpected arguments for op(): @_" if @_ ; - - return $self->{TYPE} ; -} - -=item binmode - -Sets/gets whether this pipe is in binmode or not. No effect off of Win32 -OSs, of course, and on Win32, no effect after the harness is start()ed. - -=cut - -sub binmode { - my IPC::Run::IO $self = shift ; - - $self->{BINMODE} = shift if @_ ; - - return $self->{BINMODE} ; -} - - -=item dir - -Returns the first character of $self->op. This is either "<" or ">". - -=cut - -sub dir { - my IPC::Run::IO $self = shift ; - - croak "IPC::Run::IO: unexpected arguments for dir(): @_" if @_ ; - - return substr $self->{TYPE}, 0, 1 ; -} - - -## -## Filter Scaffolding -## -#my $filter_op ; ## The op running a filter chain right now -#my $filter_num ; ## Which filter is being run right now. - -use vars ( -'$filter_op', ## The op running a filter chain right now -'$filter_num' ## Which filter is being run right now. -) ; - -sub _init_filters { - my IPC::Run::IO $self = shift ; - -confess "\$self not an IPC::Run::IO" unless isa( $self, "IPC::Run::IO" ) ; - $self->{FBUFS} = [] ; - - $self->{FBUFS}->[0] = $self->{DEST} - if $self->{DEST} && ref $self->{DEST} eq 'SCALAR' ; - - return unless $self->{FILTERS} && @{$self->{FILTERS}} ; - - push @{$self->{FBUFS}}, map { - my $s = "" ; - \$s ; - } ( @{$self->{FILTERS}}, '' ) ; - - push @{$self->{FBUFS}}, $self->{SOURCE} ; -} - - -sub poll { - my IPC::Run::IO $self = shift; - my ( $harness ) = @_; - - if ( defined $self->{FD} ) { - my $d = $self->dir; - if ( $d eq "<" ) { - if ( vec $harness->{WOUT}, $self->{FD}, 1 ) { - _debug_desc_fd( "filtering data to", $self ) - if _debugging_details ; - return $self->_do_filters( $harness ); - } - } - elsif ( $d eq ">" ) { - if ( vec $harness->{ROUT}, $self->{FD}, 1 ) { - _debug_desc_fd( "filtering data from", $self ) - if _debugging_details ; - return $self->_do_filters( $harness ); - } - } - } - return 0; -} - - -sub _do_filters { - my IPC::Run::IO $self = shift ; - - ( $self->{HARNESS} ) = @_ ; - - my ( $saved_op, $saved_num ) =($IPC::Run::filter_op,$IPC::Run::filter_num) ; - $IPC::Run::filter_op = $self ; - $IPC::Run::filter_num = -1 ; - my $r = eval { IPC::Run::get_more_input() ; } ; - ( $IPC::Run::filter_op, $IPC::Run::filter_num ) = ( $saved_op, $saved_num ) ; - $self->{HARNESS} = undef ; - die $@ if $@ ; - return $r ; -} - -1 ; diff --git a/lib/IPC/Run/Timer.pm b/lib/IPC/Run/Timer.pm deleted file mode 100644 index 82d418997d..0000000000 --- a/lib/IPC/Run/Timer.pm +++ /dev/null @@ -1,688 +0,0 @@ -package IPC::Run::Timer ; - -=head1 NAME - - IPC::Run::Timer -- Timer channels for IPC::Run. - -=head1 SYNOPSIS - - use IPC::Run qw( run timer timeout ) ; - ## or IPC::Run::Timer ( timer timeout ) ; - ## or IPC::Run::Timer ( :all ) ; - - ## A non-fatal timer: - $t = timer( 5 ) ; # or... - $t = IO::Run::Timer->new( 5 ) ; - run $t, ... ; - - ## A timeout (which is a timer that dies on expiry): - $t = timeout( 5 ) ; # or... - $t = IO::Run::Timer->new( 5, exception => "harness timed out" ) ; - -=head1 DESCRIPTION - -This class and module allows timers and timeouts to be created for use -by IPC::Run. A timer simply expires when it's time is up. A timeout -is a timer that throws an exception when it expires. - -Timeouts are usually a bit simpler to use than timers: they throw an -exception on expiration so you don't need to check them: - - ## Give @cmd 10 seconds to get started, then 5 seconds to respond - my $t = timeout( 10 ) ; - $h = start( - \@cmd, \$in, \$out, - $t, - ) ; - pump $h until $out =~ /prompt/ ; - - $in = "some stimulus" ; - $out = '' ; - $t->time( 5 ) - pump $h until $out =~ /expected response/ ; - -You do need to check timers: - - ## Give @cmd 10 seconds to get started, then 5 seconds to respond - my $t = timer( 10 ) ; - $h = start( - \@cmd, \$in, \$out, - $t, - ) ; - pump $h until $t->is_expired || $out =~ /prompt/ ; - - $in = "some stimulus" ; - $out = '' ; - $t->time( 5 ) - pump $h until $out =~ /expected response/ || $t->is_expired ; - -Timers and timeouts that are reset get started by start() and -pump(). Timers change state only in pump(). Since run() and -finish() both call pump(), they act like pump() with repect to -timers. - -Timers and timeouts have three states: reset, running, and expired. -Setting the timeout value resets the timer, as does calling -the reset() method. The start() method starts (or restarts) a -timer with the most recently set time value, no matter what state -it's in. - -=head2 Time values - -All time values are in seconds. Times may be specified as integer or -floating point seconds, optionally preceded by puncuation-separated -days, hours, and minutes.\ - -Examples: - - 1 1 second - 1.1 1.1 seconds - 60 60 seconds - 1:0 1 minute - 1:1 1 minute, 1 second - 1:90 2 minutes, 30 seconds - 1:2:3:4.5 1 day, 2 hours, 3 minutes, 4.5 seconds - -Absolute date/time strings are *not* accepted: year, month and -day-of-month parsing is not available (patches welcome :-). - -=head2 Interval fudging - -When calculating an end time from a start time and an interval, IPC::Run::Timer -instances add a little fudge factor. This is to ensure that no time will -expire before the interval is up. - -First a little background. Time is sampled in discrete increments. We'll -call the -exact moment that the reported time increments from one interval to the -next a tick, and the interval between ticks as the time period. Here's -a diagram of three ticks and the periods between them: - - - -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-... - ^ ^ ^ - |<--- period 0 ---->|<--- period 1 ---->| - | | | - tick 0 tick 1 tick 2 - -To see why the fudge factor is necessary, consider what would happen -when a timer with an interval of 1 second is started right at the end of -period 0: - - - -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-... - ^ ^ ^ ^ - | | | | - | | | | - tick 0 |tick 1 tick 2 - | - start $t - -Assuming that check() is called many times per period, then the timer -is likely to expire just after tick 1, since the time reported will have -lept from the value '0' to the value '1': - - -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-... - ^ ^ ^ ^ ^ - | | | | | - | | | | | - tick 0 |tick 1| tick 2 - | | - start $t | - | - check $t - -Adding a fudge of '1' in this example means that the timer is guaranteed -not to expire before tick 2. - -The fudge is not added to an interval of '0'. - -This means that intervals guarantee a minimum interval. Given that -the process running perl may be suspended for some period of time, or that -it gets busy doing something time-consuming, there are no other guarantees on -how long it will take a timer to expire. - -=head1 SUBCLASSING - -INCOMPATIBLE CHANGE: Due to the awkwardness introduced by ripping -pseudohashes out of Perl, this class I<no longer> uses the fields -pragma. - -=head1 FUNCTIONS & METHODS - -=over - -=cut ; - -use strict ; -use Carp ; -use Fcntl ; -use Symbol ; -use UNIVERSAL qw( isa ) ; -use Exporter ; -use vars qw( @EXPORT_OK %EXPORT_TAGS @ISA ) ; - -@EXPORT_OK = qw( - check - end_time - exception - expire - interval - is_expired - is_reset - is_running - name - reset - start - - timeout - timer -) ; - -%EXPORT_TAGS = ( 'all' => \@EXPORT_OK ) ; - -@ISA = qw( Exporter ) ; - -require IPC::Run ; -use IPC::Run::Debug ; - -## -## Some helpers -## -my $resolution = 1 ; - -sub _parse_time { - for ( $_[0] ) { - return $_ unless defined $_ ; - return $_ if /^\d*(?:\.\d*)?$/ ; - - my @f = reverse split( /[^\d\.]+/i ) ; - croak "IPC::Run: invalid time string '$_'" unless @f <= 4 ; - my ( $s, $m, $h, $d ) = @f ; - return - ( ( - ( $d || 0 ) * 24 - + ( $h || 0 ) ) * 60 - + ( $m || 0 ) ) * 60 - + ( $s || 0 ) ; - } -} - - -sub _calc_end_time { - my IPC::Run::Timer $self = shift ; - - my $interval = $self->interval ; - $interval += $resolution if $interval ; - - $self->end_time( $self->start_time + $interval ) ; -} - - -=item timer - -A constructor function (not method) of IPC::Run::Timer instances: - - $t = timer( 5 ) ; - $t = timer( 5, name => 'stall timer', debug => 1 ) ; - - $t = timer ; - $t->interval( 5 ) ; - - run ..., $t ; - run ..., $t = timer( 5 ) ; - -This convenience function is a shortened spelling of - - IPC::Run::Timer->new( ... ) ; - -. It returns a timer in the reset state with a given interval. - -If an exception is provided, it will be thrown when the timer notices that -it has expired (in check()). The name is for debugging usage, if you plan on -having multiple timers around. If no name is provided, a name like "timer #1" -will be provided. - -=cut - -sub timer { - return IPC::Run::Timer->new( @_ ) ; -} - - -=item timeout - -A constructor function (not method) of IPC::Run::Timer instances: - - $t = timeout( 5 ) ; - $t = timeout( 5, exception => "kablooey" ) ; - $t = timeout( 5, name => "stall", exception => "kablooey" ) ; - - $t = timeout ; - $t->interval( 5 ) ; - - run ..., $t ; - run ..., $t = timeout( 5 ) ; - -A This convenience function is a shortened spelling of - - IPC::Run::Timer->new( exception => "IPC::Run: timeout ...", ... ) ; - -. It returns a timer in the reset state that will throw an -exception when it expires. - -Takes the same parameters as L</timer>, any exception passed in overrides -the default exception. - -=cut - -sub timeout { - my $t = IPC::Run::Timer->new( @_ ) ; - $t->exception( "IPC::Run: timeout on " . $t->name ) - unless defined $t->exception ; - return $t ; -} - - -=item new - - IPC::Run::Timer->new() ; - IPC::Run::Timer->new( 5 ) ; - IPC::Run::Timer->new( 5, exception => 'kablooey' ) ; - -Constructor. See L</timer> for details. - -=cut - -my $timer_counter ; - - -sub new { - my $class = shift ; - $class = ref $class || $class ; - - my IPC::Run::Timer $self = bless {}, $class; - - $self->{STATE} = 0 ; - $self->{DEBUG} = 0 ; - $self->{NAME} = "timer #" . ++$timer_counter ; - - while ( @_ ) { - my $arg = shift ; - if ( $arg =~ /^(?:\d+[^\a\d]){0,3}\d*(?:\.\d*)?$/ ) { - $self->interval( $arg ) ; - } - elsif ( $arg eq 'exception' ) { - $self->exception( shift ) ; - } - elsif ( $arg eq 'name' ) { - $self->name( shift ) ; - } - elsif ( $arg eq 'debug' ) { - $self->debug( shift ) ; - } - else { - croak "IPC::Run: unexpected parameter '$arg'" ; - } - } - - _debug $self->name . ' constructed' - if $self->{DEBUG} || _debugging_details ; - - return $self ; -} - -=item check - - check $t ; - check $t, $now ; - $t->check ; - -Checks to see if a timer has expired since the last check. Has no effect -on non-running timers. This will throw an exception if one is defined. - -IPC::Run::pump() calls this routine for any timers in the harness. - -You may pass in a version of now, which is useful in case you have -it lying around or you want to check several timers with a consistent -concept of the current time. - -Returns the time left before end_time or 0 if end_time is no longer -in the future or the timer is not running -(unless, of course, check() expire()s the timer and this -results in an exception being thrown). - -Returns undef if the timer is not running on entry, 0 if check() expires it, -and the time left if it's left running. - -=cut - -sub check { - my IPC::Run::Timer $self = shift ; - return undef if ! $self->is_running ; - return 0 if $self->is_expired ; - - my ( $now ) = @_ ; - $now = _parse_time( $now ) ; - $now = time unless defined $now ; - - _debug( - "checking ", $self->name, " (end time ", $self->end_time, ") at ", $now - ) if $self->{DEBUG} || _debugging_details ; - - my $left = $self->end_time - $now ; - return $left if $left > 0 ; - - $self->expire ; - return 0 ; -} - - -=item debug - -Sets/gets the current setting of the debugging flag for this timer. This -has no effect if debugging is not enabled for the current harness. - -=cut - - -sub debug { - my IPC::Run::Timer $self = shift ; - $self->{DEBUG} = shift if @_ ; - return $self->{DEBUG} ; -} - - -=item end_time - - $et = $t->end_time ; - $et = end_time $t ; - - $t->end_time( time + 10 ) ; - -Returns the time when this timer will or did expire. Even if this time is -in the past, the timer may not be expired, since check() may not have been -called yet. - -Note that this end_time is not start_time($t) + interval($t), since some -small extra amount of time is added to make sure that the timer does not -expire before interval() elapses. If this were not so, then - -Changing end_time() while a timer is running will set the expiration time. -Changing it while it is expired has no affect, since reset()ing a timer always -clears the end_time(). - -=cut - - -sub end_time { - my IPC::Run::Timer $self = shift ; - if ( @_ ) { - $self->{END_TIME} = shift ; - _debug $self->name, ' end_time set to ', $self->{END_TIME} - if $self->{DEBUG} > 2 || _debugging_details ; - } - return $self->{END_TIME} ; -} - - -=item exception - - $x = $t->exception ; - $t->exception( $x ) ; - $t->exception( undef ) ; - -Sets/gets the exception to throw, if any. 'undef' means that no -exception will be thrown. Exception does not need to be a scalar: you -may ask that references be thrown. - -=cut - - -sub exception { - my IPC::Run::Timer $self = shift ; - if ( @_ ) { - $self->{EXCEPTION} = shift ; - _debug $self->name, ' exception set to ', $self->{EXCEPTION} - if $self->{DEBUG} || _debugging_details ; - } - return $self->{EXCEPTION} ; -} - - -=item interval - - $i = interval $t ; - $i = $t->interval ; - $t->interval( $i ) ; - -Sets the interval. Sets the end time based on the start_time() and the -interval (and a little fudge) if the timer is running. - -=cut - -sub interval { - my IPC::Run::Timer $self = shift ; - if ( @_ ) { - $self->{INTERVAL} = _parse_time( shift ) ; - _debug $self->name, ' interval set to ', $self->{INTERVAL} - if $self->{DEBUG} > 2 || _debugging_details ; - - $self->_calc_end_time if $self->state ; - } - return $self->{INTERVAL} ; -} - - -=item expire - - expire $t ; - $t->expire ; - -Sets the state to expired (undef). -Will throw an exception if one -is defined and the timer was not already expired. You can expire a -reset timer without starting it. - -=cut - - -sub expire { - my IPC::Run::Timer $self = shift ; - if ( defined $self->state ) { - _debug $self->name . ' expired' - if $self->{DEBUG} || _debugging ; - - $self->state( undef ) ; - croak $self->exception if $self->exception ; - } - return undef ; -} - - -=item is_running - -=cut - - -sub is_running { - my IPC::Run::Timer $self = shift ; - return $self->state ? 1 : 0 ; -} - - -=item is_reset - -=cut - -sub is_reset { - my IPC::Run::Timer $self = shift ; - return defined $self->state && $self->state == 0 ; -} - - -=item is_expired - -=cut - -sub is_expired { - my IPC::Run::Timer $self = shift ; - return ! defined $self->state ; -} - -=item name - -Sets/gets this timer's name. The name is only used for debugging -purposes so you can tell which freakin' timer is doing what. - -=cut - -sub name { - my IPC::Run::Timer $self = shift ; - - $self->{NAME} = shift if @_ ; - return defined $self->{NAME} - ? $self->{NAME} - : defined $self->{EXCEPTION} - ? 'timeout' - : 'timer' ; -} - - -=item reset - - reset $t ; - $t->reset ; - -Resets the timer to the non-running, non-expired state and clears -the end_time(). - -=cut - -sub reset { - my IPC::Run::Timer $self = shift ; - $self->state( 0 ) ; - $self->end_time( undef ) ; - _debug $self->name . ' reset' - if $self->{DEBUG} || _debugging ; - - return undef ; -} - - -=item start - - start $t ; - $t->start ; - start $t, $interval ; - start $t, $interval, $now ; - -Starts or restarts a timer. This always sets the start_time. It sets the -end_time based on the interval if the timer is running or if no end time -has been set. - -You may pass an optional interval or current time value. - -Not passing a defined interval causes the previous interval setting to be -re-used unless the timer is reset and an end_time has been set -(an exception is thrown if no interval has been set). - -Not passing a defined current time value causes the current time to be used. - -Passing a current time value is useful if you happen to have a time value -lying around or if you want to make sure that several timers are started -with the same concept of start time. You might even need to lie to an -IPC::Run::Timer, occasionally. - -=cut - -sub start { - my IPC::Run::Timer $self = shift ; - - my ( $interval, $now ) = map { _parse_time( $_ ) } @_ ; - $now = _parse_time( $now ) ; - $now = time unless defined $now ; - - $self->interval( $interval ) if defined $interval ; - - ## start()ing a running or expired timer clears the end_time, so that the - ## interval is used. So does specifying an interval. - $self->end_time( undef ) if ! $self->is_reset || $interval ; - - croak "IPC::Run: no timer interval or end_time defined for " . $self->name - unless defined $self->interval || defined $self->end_time ; - - $self->state( 1 ) ; - $self->start_time( $now ) ; - ## The "+ 1" is in case the START_TIME was sampled at the end of a - ## tick (which are one second long in this module). - $self->_calc_end_time - unless defined $self->end_time ; - - _debug( - $self->name, " started at ", $self->start_time, - ", with interval ", $self->interval, ", end_time ", $self->end_time - ) if $self->{DEBUG} || _debugging ; - return undef ; -} - - -=item start_time - -Sets/gets the start time, in seconds since the epoch. Setting this manually -is a bad idea, it's better to call L</start>() at the correct time. - -=cut - - -sub start_time { - my IPC::Run::Timer $self = shift ; - if ( @_ ) { - $self->{START_TIME} = _parse_time( shift ) ; - _debug $self->name, ' start_time set to ', $self->{START_TIME} - if $self->{DEBUG} > 2 || _debugging ; - } - - return $self->{START_TIME} ; -} - - -=item state - - $s = state $t ; - $t->state( $s ) ; - -Get/Set the current state. Only use this if you really need to transfer the -state to/from some variable. -Use L</expire>, L</start>, L</reset>, L</is_expired>, L</is_running>, -L</is_reset>. - -Note: Setting the state to 'undef' to expire a timer will not throw an -exception. - -=cut - -sub state { - my IPC::Run::Timer $self = shift ; - if ( @_ ) { - $self->{STATE} = shift ; - _debug $self->name, ' state set to ', $self->{STATE} - if $self->{DEBUG} > 2 || _debugging ; - } - return $self->{STATE} ; -} - - -=head1 TODO - -use Time::HiRes ; if it's present. - -Add detection and parsing of [[[HH:]MM:]SS formatted times and intervals. - -=head1 AUTHOR - -Barrie Slaymaker <barries@slaysys.com> - -=cut - -1 ; diff --git a/lib/IPC/Run/Win32Helper.pm b/lib/IPC/Run/Win32Helper.pm deleted file mode 100644 index 178dd58fe5..0000000000 --- a/lib/IPC/Run/Win32Helper.pm +++ /dev/null @@ -1,481 +0,0 @@ -package IPC::Run::Win32Helper ; - -=head1 NAME - -IPC::Run::Win32Helper - helper routines for IPC::Run on Win32 platforms. - -=head1 SYNOPSIS - -use IPC::Run::Win32Helper ; # Exports all by default - -=head1 DESCRIPTION - -IPC::Run needs to use sockets to redirect subprocess I/O so that the select() loop -will work on Win32. This seems to only work on WinNT and Win2K at this time, not -sure if it will ever work on Win95 or Win98. If you have experience in this area, please -contact me at barries@slaysys.com, thanks!. - -=cut - -@ISA = qw( Exporter ) ; - -@EXPORT = qw( - win32_spawn - win32_parse_cmd_line - _dont_inherit - _inherit -) ; - -use strict ; -use Carp ; -use IO::Handle ; -#use IPC::Open3 (); -require POSIX ; - -use Text::ParseWords ; -use Win32::Process ; -use IPC::Run::Debug; -## REMOVE OSFHandleOpen -use Win32API::File qw( - FdGetOsFHandle - SetHandleInformation - HANDLE_FLAG_INHERIT - INVALID_HANDLE_VALUE -) ; - -## Takes an fd or a GLOB ref, never never never a Win32 handle. -sub _dont_inherit { - for ( @_ ) { - next unless defined $_ ; - my $fd = $_ ; - $fd = fileno $fd if ref $fd ; - _debug "disabling inheritance of ", $fd if _debugging_details ; - my $osfh = FdGetOsFHandle $fd ; - croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE ; - - SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 0 ) ; - } -} - -sub _inherit { #### REMOVE - for ( @_ ) { #### REMOVE - next unless defined $_ ; #### REMOVE - my $fd = $_ ; #### REMOVE - $fd = fileno $fd if ref $fd ; #### REMOVE - _debug "enabling inheritance of ", $fd if _debugging_details ; #### REMOVE - my $osfh = FdGetOsFHandle $fd ; #### REMOVE - croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE ; #### REMOVE - #### REMOVE - SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 1 ) ; #### REMOVE - } #### REMOVE -} #### REMOVE - #### REMOVE -#sub _inherit { -# for ( @_ ) { -# next unless defined $_ ; -# my $osfh = GetOsFHandle $_ ; -# croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE ; -# SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT ) ; -# } -#} - -=head1 FUNCTIONS - -=over - -=cut - -=item optimize() - -Most common incantations of C<run()> (I<not> C<harness()>, C<start()>, -or C<finish()>) now use temporary files to redirect input and output -instead of pumper processes. - -Temporary files are used when sending to child processes if input is -taken from a scalar with no filter subroutines. This is the only time -we can assume that the parent is not interacting with the child's -redirected input as it runs. - -Temporary files are used when receiving from children when output is -to a scalar or subroutine with or without filters, but only if -the child in question closes its inputs or takes input from -unfiltered SCALARs or named files. Normally, a child inherits its STDIN -from its parent; to close it, use "0<&-" or the C<noinherit => 1> option. -If data is sent to the child from CODE refs, filehandles or from -scalars through filters than the child's outputs will not be optimized -because C<optimize()> assumes the parent is interacting with the child. -It is ok if the output is filtered or handled by a subroutine, however. - -This assumes that all named files are real files (as opposed to named -pipes) and won't change; and that a process is not communicating with -the child indirectly (through means not visible to IPC::Run). -These can be an invalid assumptions, but are the 99% case. -Write me if you need an option to enable or disable optimizations; I -suspect it will work like the C<binary()> modifier. - -To detect cases that you might want to optimize by closing inputs, try -setting the C<IPCRUNDEBUG> environment variable to the special C<notopt> -value: - - C:> set IPCRUNDEBUG=notopt - C:> my_app_that_uses_IPC_Run.pl - -=item optimizer() rationalizations - -Only for that limited case can we be sure that it's ok to batch all the -input in to a temporary file. If STDIN is from a SCALAR or from a named -file or filehandle (again, only in C<run()>), then outputs to CODE refs -are also assumed to be safe enough to batch through a temp file, -otherwise only outputs to SCALAR refs are batched. This can cause a bit -of grief if the parent process benefits from or relies on a bit of -"early returns" coming in before the child program exits. As long as -the output is redirected to a SCALAR ref, this will not be visible. -When output is redirected to a subroutine or (deprecated) filters, the -subroutine will not get any data until after the child process exits, -and it is likely to get bigger chunks of data at once. - -The reason for the optimization is that, without it, "pumper" processes -are used to overcome the inconsistancies of the Win32 API. We need to -use anonymous pipes to connect to the child processes' stdin, stdout, -and stderr, yet select() does not work on these. select() only works on -sockets on Win32. So for each redirected child handle, there is -normally a "pumper" process that connects to the parent using a -socket--so the parent can select() on that fd--and to the child on an -anonymous pipe--so the child can read/write a pipe. - -Using a socket to connect directly to the child (as at least one MSDN -article suggests) seems to cause the trailing output from most children -to be lost. I think this is because child processes rarely close their -stdout and stderr explicitly, and the winsock dll does not seem to flush -output when a process that uses it exits without explicitly closing -them. - -Because of these pumpers and the inherent slowness of Win32 -CreateProcess(), child processes with redirects are quite slow to -launch; so this routine looks for the very common case of -reading/writing to/from scalar references in a run() routine and -converts such reads and writes in to temporary file reads and writes. - -Such files are marked as FILE_ATTRIBUTE_TEMPORARY to increase speed and -as FILE_FLAG_DELETE_ON_CLOSE so it will be cleaned up when the child -process exits (for input files). The user's default permissions are -used for both the temporary files and the directory that contains them, -hope your Win32 permissions are secure enough for you. Files are -created with the Win32API::File defaults of -FILE_SHARE_READ|FILE_SHARE_WRITE. - -Setting the debug level to "details" or "gory" will give detailed -information about the optimization process; setting it to "basic" or -higher will tell whether or not a given call is optimized. Setting -it to "notopt" will highligh those calls that aren't optimized. - -=cut - -sub optimize { - my ( $h ) = @_; - - my @kids = @{$h->{KIDS}}; - - my $saw_pipe; - - my ( $ok_to_optimize_outputs, $veto_output_optimization ); - - for my $kid ( @kids ) { - ( $ok_to_optimize_outputs, $veto_output_optimization ) = () - unless $saw_pipe; - - _debug - "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over ok of non-SCALAR output optimization" - if _debugging_details && $ok_to_optimize_outputs; - _debug - "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over veto of non-SCALAR output optimization" - if _debugging_details && $veto_output_optimization; - - if ( $h->{noinherit} && ! $ok_to_optimize_outputs ) { - _debug - "Win32 optimizer: (kid $kid->{NUM}) STDIN not inherited from parent oking non-SCALAR output optimization" - if _debugging_details && $ok_to_optimize_outputs; - $ok_to_optimize_outputs = 1; - } - - for ( @{$kid->{OPS}} ) { - if ( substr( $_->{TYPE}, 0, 1 ) eq "<" ) { - if ( $_->{TYPE} eq "<" ) { - if ( @{$_->{FILTERS}} > 1 ) { - ## Can't assume that the filters are idempotent. - } - elsif ( ref $_->{SOURCE} eq "SCALAR" - || ref $_->{SOURCE} eq "GLOB" - || UNIVERSAL::isa( $_, "IO::Handle" ) - ) { - if ( $_->{KFD} == 0 ) { - _debug - "Win32 optimizer: (kid $kid->{NUM}) 0$_->{TYPE}", - ref $_->{SOURCE}, - ", ok to optimize outputs" - if _debugging_details; - $ok_to_optimize_outputs = 1; - } - $_->{SEND_THROUGH_TEMP_FILE} = 1; - next; - } - elsif ( ! ref $_->{SOURCE} && defined $_->{SOURCE} ) { - if ( $_->{KFD} == 0 ) { - _debug - "Win32 optimizer: (kid $kid->{NUM}) 0<$_->{SOURCE}, ok to optimize outputs", - if _debugging_details; - $ok_to_optimize_outputs = 1; - } - next; - } - } - _debug - "Win32 optimizer: (kid $kid->{NUM}) ", - $_->{KFD}, - $_->{TYPE}, - defined $_->{SOURCE} - ? ref $_->{SOURCE} ? ref $_->{SOURCE} - : $_->{SOURCE} - : defined $_->{FILENAME} - ? $_->{FILENAME} - : "", - @{$_->{FILTERS}} > 1 ? " with filters" : (), - ", VETOING output opt." - if _debugging_details || _debugging_not_optimized; - $veto_output_optimization = 1; - } - elsif ( $_->{TYPE} eq "close" && $_->{KFD} == 0 ) { - $ok_to_optimize_outputs = 1; - _debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&-, ok to optimize outputs" - if _debugging_details; - } - elsif ( $_->{TYPE} eq "dup" && $_->{KFD2} == 0 ) { - $veto_output_optimization = 1; - _debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&$_->{KFD2}, VETOING output opt." - if _debugging_details || _debugging_not_optimized; - } - elsif ( $_->{TYPE} eq "|" ) { - $saw_pipe = 1; - } - } - - if ( ! $ok_to_optimize_outputs && ! $veto_output_optimization ) { - _debug - "Win32 optimizer: (kid $kid->{NUM}) child STDIN not redirected, VETOING non-SCALAR output opt." - if _debugging_details || _debugging_not_optimized; - $veto_output_optimization = 1; - } - - if ( $ok_to_optimize_outputs && $veto_output_optimization ) { - $ok_to_optimize_outputs = 0; - _debug "Win32 optimizer: (kid $kid->{NUM}) non-SCALAR output optimizations VETOed" - if _debugging_details || _debugging_not_optimized; - } - - ## SOURCE/DEST ARRAY means it's a filter. - ## TODO: think about checking to see if the final input/output of - ## a filter chain (an ARRAY SOURCE or DEST) is a scalar...but - ## we may be deprecating filters. - - for ( @{$kid->{OPS}} ) { - if ( $_->{TYPE} eq ">" ) { - if ( ref $_->{DEST} eq "SCALAR" - || ( - ( @{$_->{FILTERS}} > 1 - || ref $_->{DEST} eq "CODE" - || ref $_->{DEST} eq "ARRAY" ## Filters? - ) - && ( $ok_to_optimize_outputs && ! $veto_output_optimization ) - ) - ) { - $_->{RECV_THROUGH_TEMP_FILE} = 1; - next; - } - _debug - "Win32 optimizer: NOT optimizing (kid $kid->{NUM}) ", - $_->{KFD}, - $_->{TYPE}, - defined $_->{DEST} - ? ref $_->{DEST} ? ref $_->{DEST} - : $_->{SOURCE} - : defined $_->{FILENAME} - ? $_->{FILENAME} - : "", - @{$_->{FILTERS}} ? " with filters" : (), - if _debugging_details; - } - } - } - -} - -=item win32_parse_cmd_line - - @words = win32_parse_cmd_line( q{foo bar 'baz baz' "bat bat"} ) ; - -returns 4 words. This parses like the bourne shell (see -the bit about shellwords() in L<Text::ParseWords>), assuming we're -trying to be a little cross-platform here. The only difference is -that "\" is *not* treated as an escape except when it precedes -punctuation, since it's used all over the place in DOS path specs. - -TODO: globbing? probably not (it's unDOSish). - -TODO: shebang emulation? Probably, but perhaps that should be part -of Run.pm so all spawned processes get the benefit. - -LIMITATIONS: shellwords dies silently on malformed input like - - a\" - -=cut - -sub win32_parse_cmd_line { - my $line = shift ; - $line =~ s{(\\[\w\s])}{\\$1}g ; - return shellwords $line ; -} - - -=item win32_spawn - -Spawns a child process, possibly with STDIN, STDOUT, and STDERR (file descriptors 0, 1, and 2, respectively) redirected. - -B<LIMITATIONS>. - -Cannot redirect higher file descriptors due to lack of support for this in the -Win32 environment. - -This can be worked around by marking a handle as inheritable in the -parent (or leaving it marked; this is the default in perl), obtaining it's -Win32 handle with C<Win32API::GetOSFHandle(FH)> or -C<Win32API::FdGetOsFHandle($fd)> and passing it to the child using the command -line, the environment, or any other IPC mechanism (it's a plain old integer). -The child can then use C<OsFHandleOpen()> or C<OsFHandleOpenFd()> and possibly -C<<open FOO ">&BAR">> or C<<open FOO ">&$fd>> as need be. Ach, the pain! - -Remember to check the Win32 handle against INVALID_HANDLE_VALUE. - -=cut - -sub _save { - my ( $saved, $saved_as, $fd ) = @_ ; - - ## We can only save aside the original fds once. - return if exists $saved->{$fd} ; - - my $saved_fd = IPC::Run::_dup( $fd ) ; - _dont_inherit $saved_fd ; - - $saved->{$fd} = $saved_fd ; - $saved_as->{$saved_fd} = $fd ; - - _dont_inherit $saved->{$fd} ; -} - -sub _dup2_gently { - my ( $saved, $saved_as, $fd1, $fd2 ) = @_ ; - _save $saved, $saved_as, $fd2 ; - - if ( exists $saved_as->{$fd2} ) { - ## The target fd is colliding with a saved-as fd, gotta bump - ## the saved-as fd to another fd. - my $orig_fd = delete $saved_as->{$fd2} ; - my $saved_fd = IPC::Run::_dup( $fd2 ) ; - _dont_inherit $saved_fd ; - - $saved->{$orig_fd} = $saved_fd ; - $saved_as->{$saved_fd} = $orig_fd ; - } - _debug "moving $fd1 to kid's $fd2" if _debugging_details ; - IPC::Run::_dup2_rudely( $fd1, $fd2 ) ; -} - -sub win32_spawn { - my ( $cmd, $ops) = @_ ; - - ## NOTE: The debug pipe write handle is passed to pump processes as STDOUT. - ## and is not to the "real" child process, since they would not know - ## what to do with it...unlike Unix, we have no code executing in the - ## child before the "real" child is exec()ed. - - my %saved ; ## Map of parent's orig fd -> saved fd - my %saved_as ; ## Map of parent's saved fd -> orig fd, used to - ## detect collisions between a KFD and the fd a - ## parent's fd happened to be saved to. - - for my $op ( @$ops ) { - _dont_inherit $op->{FD} if defined $op->{FD} ; - - if ( defined $op->{KFD} && $op->{KFD} > 2 ) { - ## TODO: Detect this in harness() - ## TODO: enable temporary redirections if ever necessary, not - ## sure why they would be... - ## 4>&1 1>/dev/null 1>&4 4>&- - croak "Can't redirect fd #", $op->{KFD}, " on Win32" ; - } - - ## This is very similar logic to IPC::Run::_do_kid_and_exit(). - if ( defined $op->{TFD} ) { - unless ( $op->{TFD} == $op->{KFD} ) { - _dup2_gently \%saved, \%saved_as, $op->{TFD}, $op->{KFD} ; - _dont_inherit $op->{TFD} ; - } - } - elsif ( $op->{TYPE} eq "dup" ) { - _dup2_gently \%saved, \%saved_as, $op->{KFD1}, $op->{KFD2} - unless $op->{KFD1} == $op->{KFD2} ; - } - elsif ( $op->{TYPE} eq "close" ) { - _save \%saved, \%saved_as, $op->{KFD} ; - IPC::Run::_close( $op->{KFD} ) ; - } - elsif ( $op->{TYPE} eq "init" ) { - ## TODO: detect this in harness() - croak "init subs not allowed on Win32" ; - } - } - - my $process ; - my $cmd_line = join " ", map { - ( my $s = $_ ) =~ s/"/"""/g; - $s = qq{"$s"} if /["\s]/; - $s ; - } @$cmd ; - - _debug "cmd line: ", $cmd_line - if _debugging; - - Win32::Process::Create( - $process, - $cmd->[0], - $cmd_line, - 1, ## Inherit handles - NORMAL_PRIORITY_CLASS, - ".", - ) or croak "$!: Win32::Process::Create()" ; - - for my $orig_fd ( keys %saved ) { - IPC::Run::_dup2_rudely( $saved{$orig_fd}, $orig_fd ) ; - IPC::Run::_close( $saved{$orig_fd} ) ; - } - - return ( $process->GetProcessID(), $process ) ; -} - - -=back - -=head1 AUTHOR - -Barries Slaymaker <barries@slaysys.com>. Funded by Perforce Software, Inc. - -=head1 COPYRIGHT - -Copyright 2001, Barrie Slaymaker, All Rights Reserved. - -You may use this under the terms of either the GPL 2.0 ir the Artistic License. - -=cut - -1 ; diff --git a/lib/IPC/Run/Win32IO.pm b/lib/IPC/Run/Win32IO.pm deleted file mode 100644 index 56d55cf621..0000000000 --- a/lib/IPC/Run/Win32IO.pm +++ /dev/null @@ -1,556 +0,0 @@ -package IPC::Run::Win32IO; - -=head1 NAME - -IPC::Run::Win32IO - helper routines for IPC::Run on Win32 platforms. - -=head1 SYNOPSIS - -use IPC::Run::Win32IO; # Exports all by default - -=head1 DESCRIPTION - -IPC::Run needs to use sockets to redirect subprocess I/O so that the select() -loop will work on Win32. This seems to only work on WinNT and Win2K at this -time, not sure if it will ever work on Win95 or Win98. If you have experience -in this area, please contact me at barries@slaysys.com, thanks!. - -=cut - -=head1 DESCRIPTION - -A specialized IO class used on Win32. - -=cut - -use strict ; -use Carp ; -use IO::Handle ; -use Socket ; -require POSIX ; - -use Socket qw( IPPROTO_TCP TCP_NODELAY ) ; -use Symbol ; -use Text::ParseWords ; -use Win32::Process ; -use IPC::Run::Debug qw( :default _debugging_level ); -use IPC::Run::Win32Helper qw( _inherit _dont_inherit ); -use Fcntl qw( O_TEXT O_RDONLY ); - -use base qw( IPC::Run::IO ); -my @cleanup_fields; -BEGIN { - ## These fields will be set to undef in _cleanup to close - ## the handles. - @cleanup_fields = ( - 'SEND_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize() - 'RECV_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize() - 'TEMP_FILE_NAME', ## The name of the temp file, needed for - ## error reporting / debugging only. - - 'PARENT_HANDLE', ## The handle of the socket for the parent - 'PUMP_SOCKET_HANDLE', ## The socket handle for the pump - 'PUMP_PIPE_HANDLE', ## The anon pipe handle for the pump - 'CHILD_HANDLE', ## The anon pipe handle for the child - - 'TEMP_FILE_HANDLE', ## The Win32 filehandle for the temp file - ); -} - -## REMOVE OSFHandleOpen -use Win32API::File qw( - GetOsFHandle - OsFHandleOpenFd - OsFHandleOpen - FdGetOsFHandle - SetHandleInformation - SetFilePointer - HANDLE_FLAG_INHERIT - INVALID_HANDLE_VALUE - - createFile - WriteFile - ReadFile - CloseHandle - - FILE_ATTRIBUTE_TEMPORARY - FILE_FLAG_DELETE_ON_CLOSE - FILE_FLAG_WRITE_THROUGH - - FILE_BEGIN -) ; - -# FILE_ATTRIBUTE_HIDDEN -# FILE_ATTRIBUTE_SYSTEM - - -BEGIN { - ## Force AUTOLOADED constants to be, well, constant by getting them - ## to AUTOLOAD before compilation continues. Sigh. - () = ( - SOL_SOCKET, - SO_REUSEADDR, - IPPROTO_TCP, - TCP_NODELAY, - HANDLE_FLAG_INHERIT, - INVALID_HANDLE_VALUE, - ); -} - - -use constant temp_file_flags => ( - FILE_ATTRIBUTE_TEMPORARY() | - FILE_FLAG_DELETE_ON_CLOSE() | - FILE_FLAG_WRITE_THROUGH() -); - -# FILE_ATTRIBUTE_HIDDEN() | -# FILE_ATTRIBUTE_SYSTEM() | -my $tmp_file_counter; -my $tmp_dir; - -sub _cleanup { - my IPC::Run::Win32IO $self = shift; - my ( $harness ) = @_; - - $self->_recv_through_temp_file( $harness ) - if $self->{RECV_THROUGH_TEMP_FILE}; - - CloseHandle( $self->{TEMP_FILE_HANDLE} ) - if defined $self->{TEMP_FILE_HANDLE}; - - $self->{$_} = undef for @cleanup_fields; -} - - -sub _create_temp_file { - my IPC::Run::Win32IO $self = shift; - - ## Create a hidden temp file that Win32 will delete when we close - ## it. - unless ( defined $tmp_dir ) { - $tmp_dir = File::Spec->catdir( - File::Spec->tmpdir, "IPC-Run.tmp" - ); - - ## Trust in the user's umask. - ## This could possibly be a security hole, perhaps - ## we should offer an option. Hmmmm, really, people coding - ## security conscious apps should audit this code and - ## tell me how to make it better. Nice cop-out :). - unless ( -d $tmp_dir ) { - mkdir $tmp_dir or croak "$!: $tmp_dir"; - } - } - - $self->{TEMP_FILE_NAME} = File::Spec->catfile( - ## File name is designed for easy sorting and not conflicting - ## with other processes. This should allow us to use "t"runcate - ## access in CreateFile in case something left some droppings - ## around (which should never happen because we specify - ## FLAG_DELETE_ON_CLOSE. - ## heh, belt and suspenders are better than bug reports; God forbid - ## that NT should ever crash before a temp file gets deleted! - $tmp_dir, sprintf "Win32io-%06d-%08d", $$, $tmp_file_counter++ - ); - - $self->{TEMP_FILE_HANDLE} = createFile( - $self->{TEMP_FILE_NAME}, - "trw", ## new, truncate, read, write - { - Flags => temp_file_flags, - }, - ) or croak "Can't create temporary file, $self->{TEMP_FILE_NAME}: $^E"; - - $self->{TFD} = OsFHandleOpenFd $self->{TEMP_FILE_HANDLE}, 0; - $self->{FD} = undef; - - _debug - "Win32 Optimizer: temp file (", - $self->{KFD}, - $self->{TYPE}, - $self->{TFD}, - ", fh ", - $self->{TEMP_FILE_HANDLE}, - "): ", - $self->{TEMP_FILE_NAME} - if _debugging_details; -} - - -sub _reset_temp_file_pointer { - my $self = shift; - SetFilePointer( $self->{TEMP_FILE_HANDLE}, 0, 0, FILE_BEGIN ) - or confess "$^E seeking on (fd $self->{TFD}) $self->{TEMP_FILE_NAME} for kid's fd $self->{KFD}"; -} - - -sub _send_through_temp_file { - my IPC::Run::Win32IO $self = shift; - - _debug - "Win32 optimizer: optimizing " - . " $self->{KFD} $self->{TYPE} temp file instead of ", - ref $self->{SOURCE} || $self->{SOURCE} - if _debugging_details; - - $self->_create_temp_file; - - if ( defined ${$self->{SOURCE}} ) { - my $bytes_written = 0; - my $data_ref; - if ( $self->binmode ) { - $data_ref = $self->{SOURCE}; - } - else { - my $data = ${$self->{SOURCE}}; # Ugh, a copy. - $data =~ s/(?<!\r)\n/\r\n/g; - $data_ref = \$data; - } - - WriteFile( - $self->{TEMP_FILE_HANDLE}, - $$data_ref, - 0, ## Write entire buffer - $bytes_written, - [], ## Not overlapped. - ) or croak - "$^E writing $self->{TEMP_FILE_NAME} for kid to read on fd $self->{KFD}"; - _debug - "Win32 optimizer: wrote $bytes_written to temp file $self->{TEMP_FILE_NAME}" - if _debugging_data; - - $self->_reset_temp_file_pointer; - - } - - - _debug "Win32 optimizer: kid to read $self->{KFD} from temp file on $self->{TFD}" - if _debugging_details; -} - - -sub _init_recv_through_temp_file { - my IPC::Run::Win32IO $self = shift; - - $self->_create_temp_file; -} - - -## TODO: USe the Win32 API in the select loop to see if the file has grown -## and read it incrementally if it has. -sub _recv_through_temp_file { - my IPC::Run::Win32IO $self = shift; - - ## This next line kicks in if the run() never got to initting things - ## and needs to clean up. - return undef unless defined $self->{TEMP_FILE_HANDLE}; - - push @{$self->{FILTERS}}, sub { - my ( undef, $out_ref ) = @_; - - return undef unless defined $self->{TEMP_FILE_HANDLE}; - - my $r; - my $s; - ReadFile( - $self->{TEMP_FILE_HANDLE}, - $s, - 999_999, ## Hmmm, should read the size. - $r, - [] - ) or croak "$^E reading from $self->{TEMP_FILE_NAME}"; - - _debug "ReadFile( $self->{TFD} ) = $r chars '$s'" if _debugging_data ; - - return undef unless $r; - - $s =~ s/\r\n/\n/g unless $self->binmode; - - my $pos = pos $$out_ref; - $$out_ref .= $s; - pos( $out_ref ) = $pos; - return 1; - }; - - my ( $harness ) = @_; - - $self->_reset_temp_file_pointer; - - 1 while $self->_do_filters( $harness ); - - pop @{$self->{FILTERS}}; - - IPC::Run::_close( $self->{TFD} ); -} - - -sub poll { - my IPC::Run::Win32IO $self = shift; - - return if $self->{SEND_THROUGH_TEMP_FILE} || $self->{RECV_THROUGH_TEMP_FILE}; - - return $self->SUPER::poll( @_ ); -} - - -## When threaded Perls get good enough, we should use threads here. -## The problem with threaded perls is that they dup() all sorts of -## filehandles and fds and don't allow sufficient control over -## closing off the ones we don't want. - -sub _spawn_pumper { - my ( $stdin, $stdout, $debug_fd, $binmode, $child_label, @opts ) = @_ ; - my ( $stdin_fd, $stdout_fd ) = ( fileno $stdin, fileno $stdout ) ; - - _debug "pumper stdin = ", $stdin_fd if _debugging_details; - _debug "pumper stdout = ", $stdout_fd if _debugging_details; - _inherit $stdin_fd, $stdout_fd, $debug_fd ; - my @I_options = map qq{"-I$_"}, @INC; - - my $cmd_line = join( " ", - qq{"$^X"}, - @I_options, - qw(-MIPC::Run::Win32Pump -e 1 ), -## I'm using this clunky way of passing filehandles to the child process -## in order to avoid some kind of premature closure of filehandles -## problem I was having with VCP's test suite when passing them -## via CreateProcess. All of the ## REMOVE code is stuff I'd like -## to be rid of and the ## ADD code is what I'd like to use. - FdGetOsFHandle( $stdin_fd ), ## REMOVE - FdGetOsFHandle( $stdout_fd ), ## REMOVE - FdGetOsFHandle( $debug_fd ), ## REMOVE - $binmode ? 1 : 0, - $$, $^T, _debugging_level, qq{"$child_label"}, - @opts - ) ; - -# open SAVEIN, "<&STDIN" or croak "$! saving STDIN" ; #### ADD -# open SAVEOUT, ">&STDOUT" or croak "$! saving STDOUT" ; #### ADD -# open SAVEERR, ">&STDERR" or croak "$! saving STDERR" ; #### ADD -# _dont_inherit \*SAVEIN ; #### ADD -# _dont_inherit \*SAVEOUT ; #### ADD -# _dont_inherit \*SAVEERR ; #### ADD -# open STDIN, "<&$stdin_fd" or croak "$! dup2()ing $stdin_fd (pumper's STDIN)" ; #### ADD -# open STDOUT, ">&$stdout_fd" or croak "$! dup2()ing $stdout_fd (pumper's STDOUT)" ; #### ADD -# open STDERR, ">&$debug_fd" or croak "$! dup2()ing $debug_fd (pumper's STDERR/debug_fd)" ; #### ADD - - _debug "pump cmd line: ", $cmd_line if _debugging_details; - - my $process ; - Win32::Process::Create( - $process, - $^X, - $cmd_line, - 1, ## Inherit handles - NORMAL_PRIORITY_CLASS, - ".", - ) or croak "$!: Win32::Process::Create()" ; - -# open STDIN, "<&SAVEIN" or croak "$! restoring STDIN" ; #### ADD -# open STDOUT, ">&SAVEOUT" or croak "$! restoring STDOUT" ; #### ADD -# open STDERR, ">&SAVEERR" or croak "$! restoring STDERR" ; #### ADD -# close SAVEIN or croak "$! closing SAVEIN" ; #### ADD -# close SAVEOUT or croak "$! closing SAVEOUT" ; #### ADD -# close SAVEERR or croak "$! closing SAVEERR" ; #### ADD - - close $stdin or croak "$! closing pumper's stdin in parent" ; - close $stdout or croak "$! closing pumper's stdout in parent" ; - # Don't close $debug_fd, we need it, as do other pumpers. - - # Pause a moment to allow the child to get up and running and emit - # debug messages. This does not always work. - # select undef, undef, undef, 1 if _debugging_details ; - - _debug "_spawn_pumper pid = ", $process->GetProcessID - if _debugging_data; -} - - -my $next_port = 2048 ; -my $loopback = inet_aton "127.0.0.1" ; -my $tcp_proto = getprotobyname('tcp'); -croak "$!: getprotobyname('tcp')" unless defined $tcp_proto ; - -sub _socket { - my ( $server ) = @_ ; - $server ||= gensym ; - my $client = gensym ; - - my $listener = gensym ; - socket $listener, PF_INET, SOCK_STREAM, $tcp_proto - or croak "$!: socket()"; - setsockopt $listener, SOL_SOCKET, SO_REUSEADDR, pack("l", 0) - or croak "$!: setsockopt()"; - - my $port ; - my @errors ; -PORT_FINDER_LOOP: - { - $port = $next_port ; - $next_port = 2048 if ++$next_port > 65_535 ; - unless ( bind $listener, sockaddr_in( $port, INADDR_ANY ) ) { - push @errors, "$! on port $port" ; - croak join "\n", @errors if @errors > 10 ; - goto PORT_FINDER_LOOP; - } - } - - _debug "win32 port = $port" if _debugging_details; - - listen $listener, my $queue_size = 1 - or croak "$!: listen()" ; - - { - socket $client, PF_INET, SOCK_STREAM, $tcp_proto - or croak "$!: socket()"; - - my $paddr = sockaddr_in($port, $loopback ); - - connect $client, $paddr - or croak "$!: connect()" ; - - croak "$!: accept" unless defined $paddr ; - - ## The windows "default" is SO_DONTLINGER, which should make - ## sure all socket data goes through. I have my doubts based - ## on experimentation, but nothing prompts me to set SO_LINGER - ## at this time... - setsockopt $client, IPPROTO_TCP, TCP_NODELAY, pack("l", 0) - or croak "$!: setsockopt()"; - } - - { - _debug "accept()ing on port $port" if _debugging_details; - my $paddr = accept( $server, $listener ) ; - croak "$!: accept()" unless defined $paddr ; - } - - _debug - "win32 _socket = ( ", fileno $server, ", ", fileno $client, " ) on port $port" - if _debugging_details; - return ( $server, $client ) ; -} - - -sub _open_socket_pipe { - my IPC::Run::Win32IO $self = shift; - my ( $debug_fd, $parent_handle ) = @_ ; - - my $is_send_to_child = $self->dir eq "<"; - - $self->{CHILD_HANDLE} = gensym; - $self->{PUMP_PIPE_HANDLE} = gensym; - - ( - $self->{PARENT_HANDLE}, - $self->{PUMP_SOCKET_HANDLE} - ) = _socket $parent_handle ; - - ## These binmodes seem to have no effect on Win2K, but just to be safe - ## I do them. - binmode $self->{PARENT_HANDLE} or die $!; - binmode $self->{PUMP_SOCKET_HANDLE} or die $!; - -_debug "PUMP_SOCKET_HANDLE = ", fileno $self->{PUMP_SOCKET_HANDLE} - if _debugging_details; -##my $buf ; -##$buf = "write on child end of " . fileno( $self->{WRITE_HANDLE} ) . "\n\n\n\n\n" ; -##POSIX::write(fileno $self->{WRITE_HANDLE}, $buf, length $buf) or warn "$! in syswrite" ; -##$buf = "write on parent end of " . fileno( $self->{CHILD_HANDLE} ) . "\r\n" ; -##POSIX::write(fileno $self->{CHILD_HANDLE},$buf, length $buf) or warn "$! in syswrite" ; -## $self->{CHILD_HANDLE}->autoflush( 1 ) ; -## $self->{WRITE_HANDLE}->autoflush( 1 ) ; - - ## Now fork off a data pump and arrange to return the correct fds. - if ( $is_send_to_child ) { - pipe $self->{CHILD_HANDLE}, $self->{PUMP_PIPE_HANDLE} - or croak "$! opening child pipe" ; -_debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE} - if _debugging_details; -_debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE} - if _debugging_details; - } - else { - pipe $self->{PUMP_PIPE_HANDLE}, $self->{CHILD_HANDLE} - or croak "$! opening child pipe" ; -_debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE} - if _debugging_details; -_debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE} - if _debugging_details; - } - - ## These binmodes seem to have no effect on Win2K, but just to be safe - ## I do them. - binmode $self->{CHILD_HANDLE}; - binmode $self->{PUMP_PIPE_HANDLE}; - - ## No child should ever see this. - _dont_inherit $self->{PARENT_HANDLE} ; - - ## We clear the inherit flag so these file descriptors are not inherited. - ## It'll be dup()ed on to STDIN/STDOUT/STDERR before CreateProcess is - ## called and *that* fd will be inheritable. - _dont_inherit $self->{PUMP_SOCKET_HANDLE} ; - _dont_inherit $self->{PUMP_PIPE_HANDLE} ; - _dont_inherit $self->{CHILD_HANDLE} ; - - ## Need to return $self so the HANDLEs don't get freed. - ## Return $self, $parent_fd, $child_fd - my ( $parent_fd, $child_fd ) = ( - fileno $self->{PARENT_HANDLE}, - fileno $self->{CHILD_HANDLE} - ) ; - - ## Both PUMP_..._HANDLEs will be closed, no need to worry about - ## inheritance. - _debug "binmode on" if _debugging_data && $self->binmode; - _spawn_pumper( - $is_send_to_child - ? ( $self->{PUMP_SOCKET_HANDLE}, $self->{PUMP_PIPE_HANDLE} ) - : ( $self->{PUMP_PIPE_HANDLE}, $self->{PUMP_SOCKET_HANDLE} ), - $debug_fd, - $self->binmode, - $child_fd . $self->dir . "pump" . $self->dir . $parent_fd, - ) ; - -{ -my $foo ; -confess "PARENT_HANDLE no longer open" - unless POSIX::read( $parent_fd, $foo, 0 ) ; -} - - _debug "win32_fake_pipe = ( $parent_fd, $child_fd )" - if _debugging_details; - - $self->{FD} = $parent_fd; - $self->{TFD} = $child_fd; -} - -sub _do_open { - my IPC::Run::Win32IO $self = shift; - - if ( $self->{SEND_THROUGH_TEMP_FILE} ) { - return $self->_send_through_temp_file( @_ ); - } - elsif ( $self->{RECV_THROUGH_TEMP_FILE} ) { - return $self->_init_recv_through_temp_file( @_ ); - } - else { - return $self->_open_socket_pipe( @_ ); - } -} - -=head1 AUTHOR - -Barries Slaymaker <barries@slaysys.com>. Funded by Perforce Software, Inc. - -=head1 COPYRIGHT - -Copyright 2001, Barrie Slaymaker, All Rights Reserved. - -You may use this under the terms of either the GPL 2.0 ir the Artistic License. - -=cut - -1; diff --git a/lib/IPC/Run/Win32Pump.pm b/lib/IPC/Run/Win32Pump.pm deleted file mode 100644 index 22adc2e8cc..0000000000 --- a/lib/IPC/Run/Win32Pump.pm +++ /dev/null @@ -1,162 +0,0 @@ -package IPC::Run::Win32Pump; - -=head1 NAME - -IPC::Run::Win32Pumper - helper processes to shovel data to/from parent, child - -=head1 SYNOPSIS - -Internal use only; see IPC::Run::Win32IO and best of luck to you. - -=head1 DESCRIPTION - -See L<IPC::Run::Win32Helper|IPC::Run::Win32Helper> for details. This -module is used in subprocesses that are spawned to shovel data to/from -parent processes from/to their child processes. Where possible, pumps -are optimized away. - -NOTE: This is not a real module: it's a script in module form, designed -to be run like - - $^X -MIPC::Run::Win32Pumper -e 1 ... - -It parses a bunch of command line parameters from IPC::Run::Win32IO. - -=cut - -use strict ; - -use Win32API::File qw( - OsFHandleOpen -) ; - - -my ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label ); -BEGIN { - ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label ) = @ARGV ; - ## Rather than letting IPC::Run::Debug export all-0 constants - ## when not debugging, we do it manually in order to not even - ## load IPC::Run::Debug. - if ( $debug ) { - eval "use IPC::Run::Debug qw( :default _debug_init ); 1;" - or die $@; - } - else { - eval <<STUBS_END or die $@; - sub _debug {} - sub _debug_init {} - sub _debugging() { 0 } - sub _debugging_data() { 0 } - sub _debugging_details() { 0 } - sub _debugging_gory_details() { 0 } - 1; -STUBS_END - } -} - -## For some reason these get created with binmode on. AAargh, gotta #### REMOVE -## do it by hand below. #### REMOVE -if ( $debug ) { #### REMOVE -close STDERR; #### REMOVE -OsFHandleOpen( \*STDERR, $debug_fh, "w" ) #### REMOVE - or print "$! opening STDERR as Win32 handle $debug_fh in pumper $$" ; #### REMOVE -} #### REMOVE -close STDIN; #### REMOVE -OsFHandleOpen( \*STDIN, $stdin_fh, "r" ) #### REMOVE -or die "$! opening STDIN as Win32 handle $stdin_fh in pumper $$" ; #### REMOVE -close STDOUT; #### REMOVE -OsFHandleOpen( \*STDOUT, $stdout_fh, "w" ) #### REMOVE -or die "$! opening STDOUT as Win32 handle $stdout_fh in pumper $$" ; #### REMOVE - -binmode STDIN; -binmode STDOUT; -$| = 1 ; -select STDERR ; $| = 1 ; select STDOUT ; - -$child_label ||= "pump" ; -_debug_init( -$parent_pid, -$parent_start_time, -$debug, -fileno STDERR, -$child_label, -) ; - -_debug "Entered" if _debugging_details ; - -# No need to close all fds; win32 doesn't seem to pass any on to us. -$| = 1 ; -my $buf ; -my $total_count = 0 ; -while (1) { -my $count = sysread STDIN, $buf, 10_000 ; -last unless $count ; -if ( _debugging_gory_details ) { - my $msg = "'$buf'" ; - substr( $msg, 100, -1 ) = '...' if length $msg > 100 ; - $msg =~ s/\n/\\n/g ; - $msg =~ s/\r/\\r/g ; - $msg =~ s/\t/\\t/g ; - $msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg ; - _debug sprintf( "%5d chars revc: ", $count ), $msg ; -} -$total_count += $count ; -$buf =~ s/\r//g unless $binmode; -if ( _debugging_gory_details ) { - my $msg = "'$buf'" ; - substr( $msg, 100, -1 ) = '...' if length $msg > 100 ; - $msg =~ s/\n/\\n/g ; - $msg =~ s/\r/\\r/g ; - $msg =~ s/\t/\\t/g ; - $msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg ; - _debug sprintf( "%5d chars sent: ", $count ), $msg ; -} -print $buf ; -} - -_debug "Exiting, transferred $total_count chars" if _debugging_details ; - -## Perform a graceful socket shutdown. Windows defaults to SO_DONTLINGER, -## which should cause a "graceful shutdown in the background" on sockets. -## but that's only true if the process closes the socket manually, it -## seems; if the process exits and lets the OS clean up, the OS is not -## so kind. STDOUT is not always a socket, of course, but it won't hurt -## to close a pipe and may even help. With a closed source OS, who -## can tell? -## -## In any case, this close() is one of the main reasons we have helper -## processes; if the OS closed socket fds gracefully when an app exits, -## we'd just redirect the client directly to what is now the pump end -## of the socket. As it is, however, we need to let the client play with -## pipes, which don't have the abort-on-app-exit behavior, and then -## adapt to the sockets in the helper processes to allow the parent to -## select. -## -## Possible alternatives / improvements: -## -## 1) use helper threads instead of processes. I don't trust perl's threads -## as of 5.005 or 5.6 enough (which may be myopic of me). -## -## 2) figure out if/how to get at WaitForMultipleObjects() with pipe -## handles. May be able to take the Win32 handle and pass it to -## Win32::Event::wait_any, dunno. -## -## 3) Use Inline::C or a hand-tooled XS module to do helper threads. -## This would be faster than #1, but would require a ppm distro. -## -close STDOUT ; -close STDERR ; - -=head1 AUTHOR - -Barries Slaymaker <barries@slaysys.com>. Funded by Perforce Software, Inc. - -=head1 COPYRIGHT - -Copyright 2001, Barrie Slaymaker, All Rights Reserved. - -You may use this under the terms of either the GPL 2.0 ir the Artistic License. - -=cut - -1 ; diff --git a/lib/IPC/Run/t/adopt.t b/lib/IPC/Run/t/adopt.t deleted file mode 100644 index 7458758581..0000000000 --- a/lib/IPC/Run/t/adopt.t +++ /dev/null @@ -1,120 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -adopt.t - Test suite for IPC::Run::adopt - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - - -use strict ; - -use Test ; - -use IPC::Run qw( start pump finish ) ; -use UNIVERSAL qw( isa ) ; - -## -## $^X is the path to the perl binary. This is used run all the subprocesses. -## -my @echoer = ( $^X, '-pe', 'BEGIN { $| = 1 }' ) ; - -my $h ; -my $in ; -my $out ; -my $fd_map ; - -my $h1 ; -my $in1 ; -my $out1 ; -my $fd_map1 ; - -sub map_fds() { &IPC::Run::_map_fds } - -my @tests = ( -## -## harness, pump, run -## -sub { - $in = 'SHOULD BE UNCHANGED' ; - $out = 'REPLACE ME' ; - $? = 99 ; - $fd_map = map_fds ; - $h = start( \@echoer, \$in, \$out ) ; - ok( isa( $h, 'IPC::Run' ) ) ; -}, -sub { ok( $?, 99 ) }, - -sub { ok( $in, 'SHOULD BE UNCHANGED' ) }, -sub { ok( $out, '' ) }, -sub { ok( $h->pumpable ) }, - -sub { - $in = '' ; - $? = 0 ; - pump_nb $h for ( 1..100 ) ; - ok( 1 ) ; -}, -sub { ok( $in, '' ) }, -sub { ok( $out, '' ) }, -sub { ok( $h->pumpable ) }, - -sub { - $in1 = 'SHOULD BE UNCHANGED' ; - $out1 = 'REPLACE ME' ; - $? = 99 ; - $fd_map1 = map_fds ; - $h1 = start( \@echoer, \$in1, \$out1 ) ; - ok( isa( $h1, 'IPC::Run' ) ) ; -}, -sub { ok( $?, 99 ) }, -sub { ok( $in1, 'SHOULD BE UNCHANGED' ) }, -sub { ok( $out1, '' ) }, -sub { ok( $h1->pumpable ) }, - - -sub { - $in = "hello\n" ; - $? = 0 ; - pump $h until $out =~ /hello/ ; - ok( 1 ) ; -}, -sub { ok( ! $? ) }, -sub { ok( $in, '' ) }, -sub { ok( $out, "hello\n" ) }, -sub { ok( $h->pumpable ) }, - -sub { - $in = "world\n" ; - $? = 0 ; - pump $h until $out =~ /world/ ; - ok( 1 ) ; -}, -sub { ok( ! $? ) }, -sub { ok( $in, '' ) }, -sub { ok( $out, "hello\nworld\n" ) }, -sub { ok( $h->pumpable ) }, - -sub { warn "hi" ;ok( $h->finish ) }, -sub { ok( ! $? ) }, -sub { ok( map_fds, $fd_map ) }, -sub { ok( $out, "hello\nworld\n" ) }, -sub { ok( ! $h->pumpable ) }, -) ; - -plan tests => scalar @tests ; - -skip "adopt not done yet", 1 for ( @tests ) ; -exit 0 ; - -$_->() for ( @tests ) ; diff --git a/lib/IPC/Run/t/binmode.t b/lib/IPC/Run/t/binmode.t deleted file mode 100644 index cbfca0fb4d..0000000000 --- a/lib/IPC/Run/t/binmode.t +++ /dev/null @@ -1,102 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -binary.t - Test suite for IPC::Run binary functionality - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - -## Handy to have when our output is intermingled with debugging output sent -## to the debugging fd. -$| = 1 ; -select STDERR ; $| = 1 ; select STDOUT ; - -use strict ; - -use Test ; - -use IPC::Run qw( harness run binary ) ; - -sub Win32_MODE() ; -*Win32_MODE = \&IPC::Run::Win32_MODE ; - -my $crlf_text = "Hello World\r\n" ; - -my $text = $crlf_text ; -$text =~ s/\r//g if Win32_MODE ; - -my $nl_text = $crlf_text ; -$nl_text =~ s/\r//g ; - -my @perl = ( $^X ) ; - -my $emitter_script = q{ binmode STDOUT ; print "Hello World\r\n" } ; -my @emitter = ( @perl, '-e', $emitter_script ) ; - -my $reporter_script = - q{ binmode STDIN ; $_ = join "", <>; s/([\000-\037])/sprintf "\\\\0x%02x", ord $1/ge; print } ; -my @reporter = ( @perl, '-e', $reporter_script ) ; - -my $in ; -my $out ; -my $err ; - -sub f($) { - my $s = shift ; - $s =~ s/([\000-\027])/sprintf "\\0x%02x", ord $1/ge ; - $s -} - -my @tests = ( -## Parsing tests -sub { ok eval { harness [], '>', binary, \$out } ? 1 : $@, 1 } , -sub { ok eval { harness [], '>', binary, "foo" } ? 1 : $@, 1 }, -sub { ok eval { harness [], '<', binary, \$in } ? 1 : $@, 1 }, -sub { ok eval { harness [], '<', binary, "foo" } ? 1 : $@, 1 }, - -## Testing from-kid now so we can use it to test stdin later -sub { ok run \@emitter, ">", \$out }, -sub { ok f $out, f $text, "no binary" }, - -sub { ok run \@emitter, ">", binary, \$out }, -sub { ok f $out, f $crlf_text, "out binary" }, - -sub { ok run \@emitter, ">", binary( 0 ), \$out }, -sub { ok f $out, f $text, "out binary 0" }, - -sub { ok run \@emitter, ">", binary( 1 ), \$out }, -sub { ok f $out, f $crlf_text, "out binary 1" }, - -## Test to-kid -sub { ok run \@reporter, "<", \$nl_text, ">", \$out }, -sub { ok $out, "Hello World" . ( Win32_MODE ? "\\0x0d" : "" ) . "\\0x0a", "reporter < \\n" }, - -sub { ok run \@reporter, "<", binary, \$nl_text, ">", \$out }, -sub { ok $out, "Hello World\\0x0a", "reporter < binary \\n" }, - -sub { ok run \@reporter, "<", binary, \$crlf_text, ">", \$out }, -sub { ok $out, "Hello World\\0x0d\\0x0a", "reporter < binary \\r\\n" }, - -sub { ok run \@reporter, "<", binary( 0 ), \$nl_text, ">", \$out }, -sub { ok $out, "Hello World" . ( Win32_MODE ? "\\0x0d" : "" ) . "\\0x0a", "reporter < binary(0) \\n" }, - -sub { ok run \@reporter, "<", binary( 1 ), \$nl_text, ">", \$out }, -sub { ok $out, "Hello World\\0x0a", "reporter < binary(1) \\n" }, - -sub { ok run \@reporter, "<", binary( 1 ), \$crlf_text, ">", \$out }, -sub { ok $out, "Hello World\\0x0d\\0x0a", "reporter < binary(1) \\r\\n" }, -) ; - -plan tests => scalar @tests ; - -$_->() for ( @tests ) ; diff --git a/lib/IPC/Run/t/bogus.t b/lib/IPC/Run/t/bogus.t deleted file mode 100644 index 176315b35a..0000000000 --- a/lib/IPC/Run/t/bogus.t +++ /dev/null @@ -1,69 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -bogus.t - test bogus file cases. - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - - -use strict ; - -use Test ; - -use IPC::Run qw( start ) ; -use UNIVERSAL qw( isa ) ; - -my $r ; - -sub Win32_MODE() ; -*Win32_MODE = \&IPC::Run::Win32_MODE ; - -## Win32 does not support a lot of things that Unix does. These -## skip_unless subs help that. -## -## TODO: There are also a few things that Win32 supports (passing Win32 OS -## handles) that we should test for, conversely. -sub skip_unless_exec(&) { - if ( Win32_MODE ) { - return sub { - skip "Can't really exec() $^O", 0 ; - } ; - } - shift ; -} - -my @tests = ( -sub { - ## Older Test.pm's don't grok qr// in $expected. - my $expected = 'file not found' ; - eval { start ["./bogus_really_bogus"] } ; - my $got = $@ =~ $expected ? $expected : $@ || "" ; - ok $got, $expected, "starting ./bogus_really_bogus" ; -}, - -skip_unless_exec { - ## Older Test.pm's don't grok qr// in $expected. - my $expected = 'exec failed' ; - my $h = eval { - start [$^X, "-e", 1], _simulate_exec_failure => 1 ; - } ; - my $got = $@ =~ $expected ? $expected : $@ || "" ; - ok $got, $expected, "starting $^X with simulated_exec_failure => 1" ; -}, - -) ; - -plan tests => scalar @tests ; - -$_->() for ( @tests ) ; diff --git a/lib/IPC/Run/t/filter.t b/lib/IPC/Run/t/filter.t deleted file mode 100644 index 90126df611..0000000000 --- a/lib/IPC/Run/t/filter.t +++ /dev/null @@ -1,120 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -filter.t - Test suite for IPC::Run filter scaffolding - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - -use strict ; - -use Test ; - -use IPC::Run qw( :filters :filter_imp filter_tests ) ; - -sub uc_filter { - my ( $in_ref, $out_ref ) = @_ ; - - return input_avail && do { - $$out_ref .= uc( $$in_ref ) ; - $$in_ref = '' ; - 1 ; - } -} - - -my $string ; - -sub string_source { - my ( $in_ref, $out_ref ) = @_ ; - return undef unless defined $string ; - $$out_ref .= $string ; - $string = undef ; - return 1 ; -} - - -my $accum ; - -sub accum { - my ( $in_ref, $out_ref ) = @_ ; - return input_avail && do { - $accum .= $$in_ref ; - $$in_ref = '' ; - 1 ; - } ; -} - - -my $op ; - -## "import" the things we're testing. -*_init_filters = \&IPC::Run::_init_filters ; -*_do_filters = \&IPC::Run::_do_filters ; - - -my @tests = ( - -filter_tests( "filter_tests", "hello world", "hello world" ), -filter_tests( "filter_tests []", [qq(hello world)], [qq(hello world)] ), -filter_tests( "filter_tests [] 2", [qw(hello world)], [qw(hello world)] ), - -filter_tests( "uc_filter", "hello world", "HELLO WORLD", \&uc_filter ), - -filter_tests( - "chunking_filter by lines 1", - "hello 1\nhello 2\nhello 3", - ["hello 1\n", "hello 2\n", "hello 3"], - new_chunker -), - -filter_tests( - "chunking_filter by lines 2", - "hello 1\nhello 2\nhello 3", - ["hello 1\n", "hello 2\n", "hello 3"], - new_chunker -), - -filter_tests( - "chunking_filter by lines 2", - [split( /(\s|\n)/, "hello 1\nhello 2\nhello 3" )], - ["hello 1\n", "hello 2\n", "hello 3"], - new_chunker -), - -filter_tests( - "chunking_filter by an odd separator", - "hello world", - "hello world", - new_chunker( 'odd separator' ) -), - -filter_tests( - "chunking_filter 2", - "hello world", - ['hello world' =~ m/(.)/g], - new_chunker( qr/./ ) -), - -filter_tests( - "appending_filter", - [qw( 1 2 3 )], - [qw( 1a 2a 3a )], - new_appender("a") -), -) ; - -plan tests => scalar @tests ; - -$_->() for ( @tests ) ; - diff --git a/lib/IPC/Run/t/harness.t b/lib/IPC/Run/t/harness.t deleted file mode 100644 index e42ee18ba6..0000000000 --- a/lib/IPC/Run/t/harness.t +++ /dev/null @@ -1,149 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -harness.t - Test suite for IPC::Run::harness - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - -use strict ; - -use Test ; - -use IPC::Run qw( harness ) ; - -my $f ; - -sub expand_test { - my ( $args, $expected ) = @_ ; - - my $h ; - my @out ; - my $i = 0 ; - return ( - sub { - $h = IPC::Run::harness( @$args ) ; - @out = @{$h->{KIDS}->[0]->{OPS}} ; - ok( - scalar( @out ), - scalar( @$expected ), - join( ' ', @$args ) - ) - }, - map { - my $j = $i++ ; - my $h = $_ ; - map { - my ( $key, $value ) = ( $_, $h->{$_} ) ; - sub { - my $got = $out[$j]->{$key} ; - $got = @$got if ref $got eq 'ARRAY' ; - $got = '<undef>' unless defined $got ; - ok( $got, $value, join( ' ', @$args ) . ": $j, $key" ) - } ; - } sort keys %$h ; - } @$expected - ) ; -} - - - -my @tests = ( - - expand_test( - [ ['a'], qw( <b < c 0<d 0< e 1<f 1< g) ], - [ - { TYPE => '<', SOURCE => 'b', KFD => 0, }, - { TYPE => '<', SOURCE => 'c', KFD => 0, }, - { TYPE => '<', SOURCE => 'd', KFD => 0, }, - { TYPE => '<', SOURCE => 'e', KFD => 0, }, - { TYPE => '<', SOURCE => 'f', KFD => 1, }, - { TYPE => '<', SOURCE => 'g', KFD => 1, }, - ] - ), - - expand_test( - [ ['a'], qw( >b > c 2>d 2> e >>f >> g 2>>h 2>> i) ], - [ - { TYPE => '>', DEST => 'b', KFD => 1, TRUNC => 1, }, - { TYPE => '>', DEST => 'c', KFD => 1, TRUNC => 1, }, - { TYPE => '>', DEST => 'd', KFD => 2, TRUNC => 1, }, - { TYPE => '>', DEST => 'e', KFD => 2, TRUNC => 1, }, - { TYPE => '>', DEST => 'f', KFD => 1, TRUNC => '', }, - { TYPE => '>', DEST => 'g', KFD => 1, TRUNC => '', }, - { TYPE => '>', DEST => 'h', KFD => 2, TRUNC => '', }, - { TYPE => '>', DEST => 'i', KFD => 2, TRUNC => '', }, - ] - ), - - expand_test( - [ ['a'], qw( >&b >& c &>d &> e ) ], - [ - { TYPE => '>', DEST => 'b', KFD => 1, TRUNC => 1, }, - { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, - { TYPE => '>', DEST => 'c', KFD => 1, TRUNC => 1, }, - { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, - { TYPE => '>', DEST => 'd', KFD => 1, TRUNC => 1, }, - { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, - { TYPE => '>', DEST => 'e', KFD => 1, TRUNC => 1, }, - { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, - ] - ), - - expand_test( - [ ['a'], - '>&', sub{}, sub{}, \$f, - '>', sub{}, sub{}, \$f, - '<', sub{}, sub{}, \$f, - ], - [ - { TYPE => '>', DEST => \$f, KFD => 1, TRUNC => 1, - FILTERS => 2 }, - { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, - { TYPE => '>', DEST => \$f, KFD => 1, TRUNC => 1, - FILTERS => 2 }, - { TYPE => '<', SOURCE => \$f, KFD => 0, - FILTERS => 3 }, - ] - ), - - expand_test( - [ ['a'], '<', \$f, '>', \$f ], - [ - { TYPE => '<', SOURCE => \$f, KFD => 0, }, - { TYPE => '>', DEST => \$f, KFD => 1, }, - ] - ), - - expand_test( - [ ['a'], '<pipe', \$f, '>pipe', \$f ], - [ - { TYPE => '<pipe', SOURCE => \$f, KFD => 0, }, - { TYPE => '>pipe', DEST => \$f, KFD => 1, }, - ] - ), - - expand_test( - [ ['a'], '<pipe', \$f, '>', \$f ], - [ - { TYPE => '<pipe', SOURCE => \$f, KFD => 0, }, - { TYPE => '>', DEST => \$f, KFD => 1, }, - ] - ), - -) ; - -plan tests => scalar @tests ; - -$_->() for ( @tests ) ; - diff --git a/lib/IPC/Run/t/io.t b/lib/IPC/Run/t/io.t deleted file mode 100644 index 56a5c6fbd9..0000000000 --- a/lib/IPC/Run/t/io.t +++ /dev/null @@ -1,133 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -io.t - Test suite excercising IPC::Run::IO with IPC::Run::run. - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - -use strict ; - -use Test ; - -use IPC::Run qw( :filters run io ) ; -use IPC::Run::Debug qw( _map_fds ); -use UNIVERSAL qw( isa ) ; - -sub skip_unless_select (&) { - if ( IPC::Run::Win32_MODE() ) { - return sub { - skip "$^O does not allow select() on non-sockets", 0 ; - } ; - } - shift ; -} - -my $text = "Hello World\n" ; - -my $emitter_script = qq{print '$text' ; print STDERR uc( '$text' )} ; -## -## $^X is the path to the perl binary. This is used run all the subprocesses. -## -my @perl = ( $^X ) ; -my @emitter = ( @perl, '-e', $emitter_script ) ; - -my $recv ; -my $send ; - -my $in_file = 'io.t.in' ; -my $out_file = 'io.t.out' ; -my $err_file = 'io.t.err' ; - -my $io ; -my $r ; - -my $fd_map ; - -## TODO: Test filters, etc. - -sub slurp($) { - my ( $f ) = @_ ; - open( S, "<$f" ) or return "$! '$f'" ; - my $r = join( '', <S> ) ; - close S or warn "$! closing '$f'"; - return $r ; -} - - -sub spit($$) { - my ( $f, $s ) = @_ ; - open( S, ">$f" ) or die "$! '$f'" ; - print S $s or die "$! '$f'" ; - close S or die "$! '$f'" ; -} - -sub wipe($) { - my ( $f ) = @_ ; - unlink $f or warn "$! unlinking '$f'" if -f $f ; -} - - - -my @tests = ( -## -## Parsing -## -sub { - $io = io( 'foo', '<', \$send ) ; - ok isa $io, 'IPC::Run::IO' ; -}, - -sub { ok( io( 'foo', '<', \$send )->mode, 'w' ) }, -sub { ok( io( 'foo', '<<', \$send )->mode, 'wa' ) }, -sub { ok( io( 'foo', '>', \$recv )->mode, 'r' ) }, -sub { ok( io( 'foo', '>>', \$recv )->mode, 'ra' ) }, - -## -## Input from a file -## -skip_unless_select { - spit $in_file, $text ; - $recv = 'REPLACE ME' ; - $fd_map = _map_fds ; - $r = run io( $in_file, '>', \$recv ) ; - wipe $in_file ; - ok( $r ) ; -}, -skip_unless_select { ok( ! $? ) }, -skip_unless_select { ok( _map_fds, $fd_map ) }, - -skip_unless_select { ok( $recv, $text ) }, - -## -## Output to a file -## -skip_unless_select { - wipe $out_file ; - $send = $text ; - $fd_map = _map_fds ; - $r = run io( $out_file, '<', \$send ) ; - $recv = slurp $out_file ; - wipe $out_file ; - ok( $r ) ; -}, -skip_unless_select { ok( ! $? ) }, -skip_unless_select { ok( _map_fds, $fd_map ) }, - -skip_unless_select { ok( $send, $text ) }, -skip_unless_select { ok( $recv, $text ) }, -) ; - -plan tests => scalar @tests ; - -$_->() for ( @tests ) ; diff --git a/lib/IPC/Run/t/kill_kill.t b/lib/IPC/Run/t/kill_kill.t deleted file mode 100644 index cec0f6a675..0000000000 --- a/lib/IPC/Run/t/kill_kill.t +++ /dev/null @@ -1,59 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -kill_kill.t - Test suite IPC::Run->kill_kill - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - - -use strict ; - -use Test ; - -use IPC::Run qw( start ) ; - -sub skip_unless_ignore_term(&) { - if ( IPC::Run::Win32_MODE() ) { - return sub { - skip "$^O does not support ignoring the TERM signal", 0 ; - } ; - } - shift ; -} - -my @quiter = ( $^X, '-e', 'sleep while 1' ) ; -my @zombie00 = ( $^X, '-e', '$SIG{TERM}=sub{};$|=1;print "running\n";sleep while 1'); - -my @tests = ( -sub { - my $h = start \@quiter ; - my $needed_kill = $h->kill_kill ; # grace => 2 ) ; - ok ! $needed_kill ; -}, - -skip_unless_ignore_term { - my $out ; - my $h = start \@zombie00, \undef, \$out ; - pump $h until $out =~ /running/ ; - my $needed_kill = $h->kill_kill( grace => 1 ) ; - ok $needed_kill ; -}, - -## not testing coredumps; some systems don't provide them. #' - -) ; - -plan tests => scalar @tests ; - -$_->() for ( @tests ) ; diff --git a/lib/IPC/Run/t/parallel.t b/lib/IPC/Run/t/parallel.t deleted file mode 100644 index d178247a84..0000000000 --- a/lib/IPC/Run/t/parallel.t +++ /dev/null @@ -1,110 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -parallel.t - Test suite for running multiple processes in parallel. - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - -## Handy to have when our output is intermingled with debugging output sent -## to the debugging fd. -$| = 1 ; -select STDERR ; $| = 1 ; select STDOUT ; - -use strict ; - -use Test ; - -use IPC::Run qw( start pump finish ) ; -use UNIVERSAL qw( isa ) ; - -sub Win32_MODE() ; -*Win32_MODE = \&IPC::Run::Win32_MODE ; - -## Win32 does not support a lot of things that Unix does. These -## skip_unless subs help that. -## -## TODO: There are also a few things that Win32 supports (passing Win32 OS -## handles) that we should test for, conversely. -sub skip_unless_subs(&) { - if ( Win32_MODE ) { - return sub { - skip "Can't spawn subroutines on $^O", 0 ; - } ; - } - shift ; -} - -my $text1 = "Hello world 1\n" ; -my $text2 = "Hello world 2\n" ; - -my @perl = ( $^X ) ; - -my @catter = ( @perl, '-pe1' ) ; - -sub slurp($) { - my ( $f ) = @_ ; - open( S, "<$f" ) or return "$! $f" ; - my $r = join( '', <S> ) ; - close S ; - return $r ; -} - - -sub spit($$) { - my ( $f, $s ) = @_ ; - open( S, ">$f" ) or die "$! $f" ; - print S $s or die "$! $f" ; - close S or die "$! $f" ; -} - -my ( $h1, $h2 ) ; -my ( $out1, $out2 ) ; - -my @tests = ( - -sub { - $h1 = start \@catter, "<", \$text1, ">", \$out1 ; - ok $h1 ; -}, - -sub { - $h2 = start \@catter, "<", \$text2, ">", \$out2 ; - ok $h2 ; -}, - -sub { - pump $h1 ; - ok 1 ; -}, - -sub { - pump $h2 ; - ok 1 ; -}, - -sub { - finish $h1 ; - ok 1 ; -}, - -sub { - finish $h2 ; - ok 1 ; -}, - -) ; - -plan tests => scalar @tests ; - -$_->() for ( @tests ) ; diff --git a/lib/IPC/Run/t/pty.t b/lib/IPC/Run/t/pty.t deleted file mode 100644 index 83ad5beca6..0000000000 --- a/lib/IPC/Run/t/pty.t +++ /dev/null @@ -1,275 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -pty.t - Test suite for IPC::Run's pty (psuedo-terminal) support - -=head1 DESCRIPTION - -This test suite starts off with a test that seems to cause a deadlock -on freebsd: \@cmd, '<pty<', ... '>', ..., '2>'... - -This seems to cause the child process entry in the process table to -hang around after the child exits. Both output pipes are closed, but -the PID is still valid so IPC::Run::finish() thinks it's still alive and -the whole shebang deadlocks waiting for the child to exit. - -This is a very rare corner condition, so I'm not patching in a fix yet. -One fix might be to hack IPC::Run to close the master pty when all outputs -from the child are closed. That's a hack, not sure what to do about it. - -This problem needs to be reproduced in a standalone script and investigated -further, but I have not the time. - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - - -use strict ; - -use Test ; - -use IPC::Run::Debug qw( _map_fds ); -use IPC::Run qw( start pump finish ) ; -use UNIVERSAL qw( isa ) ; - -select STDERR ; $| = 1 ; select STDOUT ; - -sub pty_warn { - warn "\nWARNING: $_[0].\nWARNING: '<pty<', '>pty>' $_[1] not work.\n\n"; -} - -if ( $^O !~ /Win32/ ) { -# my $min = 0.9 ; - for ( eval { require IO::Pty ; IO::Pty->VERSION } ) { - s/_//g if defined ; - if ( ! defined ) { - pty_warn "IO::Pty not found", "will" ; - } - elsif ( $_ == 0.02 ) { - pty_warn "IO::Pty v$_ has spurious warnings, try 0.9 or later", "may" - } - elsif ( $_ < 1.00 ) { - pty_warn "IO::Pty 1.00 is strongly recommended", "may" ; - } - } -} - - -my $echoer_script = <<TOHERE ; -\$| = 1 ; -\$s = select STDERR ; \$| = 1 ; select \$s ; -while (<>) { - print STDERR uc \$_ ; - print ; - last if /quit/ ; -} -TOHERE - -## -## $^X is the path to the perl binary. This is used run all the subprocesses. -## -my @echoer = ( $^X, '-e', $echoer_script ) ; - -my $in ; -my $out ; -my $err; - -my $h ; -my $r ; - -my $fd_map ; - -my $text = "hello world\n" ; - -## TODO: test lots of mixtures of pty's and pipes & files. Use run(). - -## Older Perls can't ok( a, qr// ), so I manually do that here. -my $exp ; - -my $platform_skip = $^O =~ /(?:aix|freebsd|openbsd)/ ? "$^O deadlocks on this test" : "" ; - -my @tests = ( -## -## stdin only -## -sub { - return skip $platform_skip, 1 if $platform_skip; - $out = 'REPLACE ME' ; - $? = 99 ; - $fd_map = _map_fds ; - $h = start \@echoer, '<pty<', \$in, '>', \$out, '2>', \$err ; - - $in = "hello\n" ; - $? = 0 ; - pump $h until $out =~ /hello/ && $err =~ /HELLO/ ; - ok( $out, "hello\n" ) ; -}, -sub { - return skip $platform_skip, 1 if $platform_skip; - $exp = qr/^HELLO\n(?!\n)$/ ; - $err =~ $exp ? ok( 1 ) : ok( $err, $exp ) ; -}, -sub { - return skip $platform_skip, 1 if $platform_skip; - ok( $in, '' ) -}, - -sub { - return skip $platform_skip, 1 if $platform_skip; - $in = "world\n" ; - $? = 0 ; - pump $h until $out =~ /world/ && $err =~ /WORLD/ ; - ok( $out, "hello\nworld\n" ) ; -}, -sub { - return skip $platform_skip, 1 if $platform_skip; - $exp = qr/^HELLO\nWORLD\n(?!\n)$/ ; - $err =~ $exp ? ok( 1 ) : ok( $err, $exp ) ; -}, -sub { - return skip $platform_skip, 1 if $platform_skip; - ok( $in, '' ) -}, - -sub { - return skip $platform_skip, 1 if $platform_skip; - $in = "quit\n" ; - ok( $h->finish ) ; -}, -sub { - return skip $platform_skip, 1 if $platform_skip; - ok( ! $? ) -}, -sub { - return skip $platform_skip, 1 if $platform_skip; - ok( _map_fds, $fd_map ) -}, - -## -## stdout, stderr -## -sub { - $out = 'REPLACE ME' ; - $? = 99 ; - $fd_map = _map_fds ; - $h = start \@echoer, \$in, '>pty>', \$out ; - $in = "hello\n" ; - $? = 0 ; - pump $h until $out =~ /hello/ ; - ## We assume that the slave's write()s are atomic - $exp = qr/^(?:hello\r?\n){2}(?!\n)$/i ; - $out =~ $exp ? ok( 1 ) : ok( $out, $exp ) ; -}, -sub { ok( $in, '' ) }, - -sub { - $in = "world\n" ; - $? = 0 ; - pump $h until $out =~ /world/ ; - $exp = qr/^(?:hello\r?\n){2}(?:world\r?\n){2}(?!\n)$/i ; - $out =~ $exp ? ok( 1 ) : ok( $out, $exp ) ; -}, -sub { ok( $in, '' ) }, - -sub { - $in = "quit\n" ; - ok( $h->finish ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -## -## stdout only -## -sub { - $out = 'REPLACE ME' ; - $? = 99 ; - $fd_map = _map_fds ; - $h = start \@echoer, \$in, '>pty>', \$out, '2>', \$err ; - $in = "hello\n" ; - $? = 0 ; - pump $h until $out =~ /hello/ && $err =~ /HELLO/ ; - $exp = qr/^hello\r?\n(?!\n)$/ ; - $out =~ $exp ? ok( 1 ) : ok( $out, $exp ) ; -}, -sub { - $exp = qr/^HELLO\n(?!\n)$/ ; - $err =~ $exp ? ok( 1 ) : ok( $err, $exp ) ; -}, -sub { ok( $in, '' ) }, - -sub { - $in = "world\n" ; - $? = 0 ; - pump $h until $out =~ /world/ && $err =~ /WORLD/ ; - $exp = qr/^hello\r?\nworld\r?\n(?!\n)$/ ; - $out =~ $exp ? ok( 1 ) : ok( $out, $exp ) ; -}, -sub { - $exp = qr/^HELLO\nWORLD\n(?!\n)$/ , - $err =~ $exp ? ok( 1 ) : ok( $err, $exp ) ; -}, -sub { ok( $in, '' ) }, - -sub { - $in = "quit\n" ; - ok( $h->finish ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -## -## stdin, stdout, stderr -## -sub { - $out = 'REPLACE ME' ; - $? = 99 ; - $fd_map = _map_fds ; - $h = start \@echoer, '<pty<', \$in, '>pty>', \$out ; - $in = "hello\n" ; - $? = 0 ; - pump $h until $out =~ /hello.*hello.*hello/is ; - ## We assume that the slave's write()s are atomic - $exp = qr/^(?:hello\r?\n){3}(?!\n)$/i ; - $out =~ $exp ? ok( 1 ) : ok( $out, $exp ) ; -}, -sub { ok( $in, '' ) }, - -sub { - $in = "world\n" ; - $? = 0 ; - pump $h until $out =~ /world.*world.*world/is ; - $exp = qr/^(?:hello\r?\n){3}(?:world\r?\n){3}(?!\n)$/i ; - $out =~ $exp ? ok( 1 ) : ok( $out, $exp ) ; -}, -sub { ok( $in, '' ) }, - -sub { - $in = "quit\n" ; - ok( $h->finish ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, -) ; - -plan tests => scalar @tests ; - -unless ( eval { require IO::Pty ; } ) { - skip( "skip: IO::Pty not found", 0 ) for @tests ; - exit ; -} - -print "# Using IO::Tty $IO::Tty::VERSION\n"; -print "# Using IO::Pty $IO::Pty::VERSION\n"; - -$_->() for ( @tests ) ; diff --git a/lib/IPC/Run/t/pump.t b/lib/IPC/Run/t/pump.t deleted file mode 100644 index 7878d786b2..0000000000 --- a/lib/IPC/Run/t/pump.t +++ /dev/null @@ -1,119 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -pump.t - Test suite for IPC::Run::run, etc. - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - -use strict ; - -use Test ; - -use IPC::Run::Debug qw( _map_fds ); -use IPC::Run qw( start pump finish timeout ) ; -use UNIVERSAL qw( isa ) ; - -## -## $^X is the path to the perl binary. This is used run all the subprocesses. -## -my @echoer = ( $^X, '-pe', 'BEGIN { $| = 1 }' ) ; - -my $in ; -my $out ; - -my $h ; - -my $fd_map ; - -my @tests = ( -## -## harness, pump, run -## -sub { - $in = 'SHOULD BE UNCHANGED' ; - $out = 'REPLACE ME' ; - $? = 99 ; - $fd_map = _map_fds ; - $h = start( \@echoer, \$in, \$out, timeout 5 ) ; - ok( isa( $h, 'IPC::Run' ) ) ; -}, -sub { ok( $?, 99 ) }, - -sub { ok( $in, 'SHOULD BE UNCHANGED' ) }, -sub { ok( $out, '' ) }, -sub { ok( $h->pumpable ) }, - -sub { - $in = '' ; - $? = 0 ; - pump_nb $h for ( 1..100 ) ; - ok( 1 ) ; -}, -sub { ok( $in, '' ) }, -sub { ok( $out, '' ) }, -sub { ok( $h->pumpable ) }, - -sub { - $in = "hello\n" ; - $? = 0 ; - pump $h until $out =~ /hello/ ; - ok( 1 ) ; -}, -sub { ok( ! $? ) }, -sub { ok( $in, '' ) }, -sub { ok( $out, "hello\n" ) }, -sub { ok( $h->pumpable ) }, - -sub { - $in = "world\n" ; - $? = 0 ; - pump $h until $out =~ /world/ ; - ok( 1 ) ; -}, -sub { ok( ! $? ) }, -sub { ok( $in, '' ) }, -sub { ok( $out, "hello\nworld\n" ) }, -sub { ok( $h->pumpable ) }, - -## Test \G pos() restoral -sub { - $in = "hello\n" ; - $out = "" ; - $? = 0 ; - pump $h until $out =~ /hello\n/g ; - ok( 1 ) ; -}, - -sub { - ok pos( $out ), 6, "pos\$out" ; -}, - -sub { - $in = "world\n" ; - $? = 0 ; - pump $h until $out =~ /\Gworld/gc ; - ok( 1 ) ; -}, - - -sub { ok( $h->finish ) }, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, -sub { ok( $out, "hello\nworld\n" ) }, -sub { ok( ! $h->pumpable ) }, -) ; - -plan tests => scalar @tests ; - -$_->() for ( @tests ) ; diff --git a/lib/IPC/Run/t/run.t b/lib/IPC/Run/t/run.t deleted file mode 100644 index 4f0206f487..0000000000 --- a/lib/IPC/Run/t/run.t +++ /dev/null @@ -1,1080 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -run.t - Test suite for IPC::Run::run, etc. - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - - -## Handy to have when our output is intermingled with debugging output sent -## to the debugging fd. -$| = 1 ; -select STDERR ; $| = 1 ; select STDOUT ; - -use strict ; - -use Test ; - -use IPC::Run::Debug qw( _map_fds ); -use IPC::Run qw( :filters :filter_imp start filter_tests Win32_MODE ) ; - -sub run { IPC::Run::run( ref $_[0] ? ( noinherit => 1 ) : (), @_ ) } - -use UNIVERSAL qw( isa ) ; - -## Test at least some of the win32 PATHEXT logic -my $perl = $^X; -$perl =~ s/\.\w+\z// if Win32_MODE; - -## Win32 does not support a lot of things that Unix does. These -## skip_unless subs help that. -## -## TODO: There are also a few things that Win32 supports (passing Win32 OS -## handles) that we should test for, conversely. -sub skip_unless_subs(&) { - if ( Win32_MODE ) { - return sub { - skip "Can't spawn subroutines on $^O", 0 ; - } ; - } - shift ; -} - -sub skip_unless_shell(&) { - if ( Win32_MODE ) { - return sub { - skip "$^O's shell returns 0 even if last command doesn't", 0 ; - } ; - } - shift ; -} - -sub skip_unless_high_fds(&) { - if ( Win32_MODE ) { - return sub { - skip "$^O does not allow redirection of file descriptors > 2", 0 ; - } ; - } - shift ; -} - - -sub _unlink { - my ( $f ) = @_; - my $tries; - while () { - return if unlink $f; - if ( $^O =~ /Win32/ && ++$tries <= 10 ) { - print STDOUT "# Waiting for Win32 to allow $f to be unlinked ($!)\n"; - select undef, undef, undef, 0.1; - next; - } - die "$! unlinking $f at ", join( ", line ", (caller)[1,2] ), "\n"; - } -} - - -my $text = "Hello World\n" ; - -my @perl = ( $perl ) ; -# When utf8 is turned on via environment variables, then uc will attempt to -# use utf8; as part of the swash initialisation. The tests here run a child -# perl and get it to uc() strings. So that child needs to know where utf8.pm -# is. -push @perl, q(-I../..) if $ENV{PERL_CORE}; - -my $emitter_script = - qq{print '$text' ; print STDERR uc( '$text' ) unless \@ARGV } ; -my @emitter = ( @perl, '-e', $emitter_script ) ; - -my $in ; -my $out ; -my $err ; - -my $in_file = 'run.t.in' ; -my $out_file = 'run.t.out' ; -my $err_file = 'run.t.err' ; - -my $h ; - -# initialized during the first test -my $fd_map; - -sub slurp($) { - my ( $f ) = @_ ; - open( S, "<$f" ) or return "$! $f" ; - my $r = join( '', <S> ) ; - close S or warn "$!: $f"; - select 0.1 if $^O =~ /Win32/; - return $r ; -} - - -sub spit($$) { - my ( $f, $s ) = @_ ; - open( S, ">$f" ) or die "$! $f" ; - print S $s or die "$! $f" ; - close S or die "$! $f" ; -} - -## -## A grossly inefficient filter to test filter -## chains. It's inefficient because we want to make sure that the -## filter chain flushing logic works. The inefficiency is that it -## doesn't process as much input as it could each call, so lots of calls -## are required. -## -sub alt_casing_filter { - my ( $in_ref, $out_ref ) = @_ ; - return input_avail && do { - $$out_ref .= lc( substr( $$in_ref, 0, 1, '' ) ) ; - 1 ; - } && ( - ! input_avail || do { - $$out_ref .= uc( substr( $$in_ref, 0, 1, '' ) ) ; - 1 ; - } - ) ; -} - - -sub case_inverting_filter { - my ( $in_ref, $out_ref ) = @_ ; - return input_avail && do { - $$in_ref =~ tr/a-zA-Z/A-Za-z/ ; - $$out_ref .= $$in_ref ; - $$in_ref = '' ; - 1 ; - } ; -} - - -sub eok { - my ( $got, $exp ) = ( shift, shift ); - $got =~ s/([\000-\037])/sprintf "\\0x%02x", ord $1/ge if defined $exp; - $exp =~ s/([\000-\037])/sprintf "\\0x%02x", ord $1/ge if defined $exp; - @_ = ( $got, $exp, @_ ); - goto &ok; -} - - -my $r ; - - -my @tests = ( - -sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds }, - -## -## Internal testing -## -filter_tests( - "alt_casing_filter", - "Hello World", - ["hElLo wOrLd" =~ m/(..?)/g], - \&alt_casing_filter -), - -sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds }, - -filter_tests( - "case_inverting_filter", - "Hello World", - "hELLO wORLD", - \&case_inverting_filter -), - -sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds }, - -## -## Calling the local system shell -## -sub { ok run qq{$perl -e exit} }, -sub { ok $?, 0 }, - -sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds }, - -skip_unless_shell { ok ! run qq{$perl -e 'exit(42)'} }, -skip_unless_shell { ok $? }, -skip_unless_shell { ok $? >> 8, 42 }, - -sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds }, - -## -## Simple commands, not executed via shell -## -sub { ok( run $perl, qw{-e exit} ) }, -sub { ok( $?, 0 ) }, - -sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds }, - -sub { ok( ! run $perl, qw{-e exit(42)} ) }, -sub { ok( $? ) }, -sub { ok $? >> 8, 42 }, - -sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds }, - -## -## A function -## -skip_unless_subs { ok run sub{} }, -skip_unless_subs { ok $?, 0 }, -skip_unless_subs { ok !run sub{ exit 42 } }, -skip_unless_subs { ok $? }, -skip_unless_subs { ok $? >> 8, 42 }, - -sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds }, - -## -## A function, and an init function -## -skip_unless_subs { - my $e = 0 ; - ok( - ! run( - sub{ exit($e) }, - init => sub { $e = 42 } - ) - ) ; -}, -skip_unless_subs { ok( $? ) }, - -sub { ok( _map_fds, $fd_map ) ; $fd_map = _map_fds }, - -## -## scalar ref I & O redirection using op tokens -## -sub { - $out = 'REPLACE ME' ; - $fd_map = _map_fds ; - $r = run [ @emitter, "nostderr" ], '>', \$out ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, -sub { eok( $out, $text ) }, - -sub { - $out = 'REPLACE ME' ; - $fd_map = _map_fds ; - $r = run [ @emitter, "nostderr" ], '<', \undef, '>', \$out ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, -sub { eok( $out, $text ) }, -sub { - $in = $emitter_script ; - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - $r = run \@perl, '<', \$in, '>', \$out, '2>', \$err, ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $in, $emitter_script ) }, -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, -## -## scalar ref I & O redirection, succinct mode. -## -sub { - $in = $emitter_script ; - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - $r = run \@perl, \$in, \$out, \$err ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $in, $emitter_script ) }, -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, - -## -## Long output, to test for blocking read. -## -## Assume pipe buffer length <= 10000, need to double that to assure enough -## chars to fill a buffer so. This test adapted from a test submitted by -## Borislav Deianov <borislav@ensim.com>. -sub { - $in = "-" x 20000 . "end\n" ; - $out = 'REPLACE ME' ; - $fd_map = _map_fds ; - $r = run [ $perl, qw{-e print"-"x20000;<STDIN>;} ], \$in, \$out ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { ok( length $out, 20000 ) }, -sub { ok( $out !~ /[^-]/ ) }, - - -## -## Long output run through twice -## -## Adapted from a stress test by Aaron Elkiss <aelkiss@wam.umd.edu> -## -sub { - $h = start [$perl, qw( -pe BEGIN{$|=1}1 )], \$in, \$out; - - $in = "\n"; - $out = ""; - pump $h until length $out; - ok $out eq "\n"; -}, - -sub { - my $long_string = "x" x 20000 . "DOC2\n"; - $in = $long_string; - $out = ""; - my $ok_1 = eval { - pump $h until $out =~ /DOC2/; - 1; - }; - my $x = $@; - my $ok_2 = eval { - finish $h; - 1; - }; - - $x = $@ if $ok_1 && ! $ok_2; - - if ( $ok_1 && $ok_2 ) { - ok $long_string eq $out; - } - else { - $x =~ s/(x+)/sprintf "...%d \"x\" chars...", length $1/e; - ok $x, ""; - } -}, - -## -## child function, scalar ref I & O redirection, succinct mode. -## -skip_unless_subs { - $in = $text ; - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - $r = run( - sub { while (<>) { print ; print STDERR uc( $_ ) } }, - \$in, \$out, \$err - ) ; - ok( $r ) ; -}, -skip_unless_subs { ok ! $? }, -skip_unless_subs { ok( _map_fds, $fd_map ) }, - -skip_unless_subs { eok( $in, $text ) }, -skip_unless_subs { eok( $out, $text ) }, -skip_unless_subs { eok( $err, uc( $text ) ) }, - -## -## here document as input -## -sub { - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - $r = run \@perl, \<<TOHERE, \$out, \$err ; -$emitter_script -TOHERE - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, - -## -## undef as input -## -sub { - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - $r = run \@perl, \undef, \$out, \$err ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $out, '' ) }, -sub { eok( $err, '' ) }, - -## -## filehandle input redirection -## -sub { - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - spit( $in_file, $emitter_script ) ; - open( F, "<$in_file" ) or die "$! $in_file" ; - $r = run \@perl, \*F, \$out, \$err ; - close F ; - unlink $in_file or warn "$! $in_file" ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, - -## -## input redirection via caller writing directly to a pipe -## -sub { - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - $h = start \@perl, '<pipe', \*IN, '>', \$out, '2>', \$err ; - ## Assume this won't block... - print IN $emitter_script ; - close IN or warn $! ; - $r = $h->finish ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, - -## -## filehandle input redirection, passed via *F{IO} -## -sub { - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - spit( $in_file, $emitter_script ) ; - open( F, "<$in_file" ) or die "$! $in_file" ; - $r = run \@perl, *F{IO}, \$out, \$err ; - close F ; - _unlink $in_file; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, - -## -## filehandle output redirection -## -sub { - $fd_map = _map_fds ; - open( OUT, ">$out_file" ) or die "$! $out_file" ; - open( ERR, ">$err_file" ) or die "$! $err_file" ; - print OUT "out: " ; - print ERR uc( "err: " ) ; - $r = run \@emitter, \undef, \*OUT, \*ERR ; - print OUT " more out data" ; - print ERR uc( " more err data" ) ; - close OUT ; - close ERR ; - $out = slurp( $out_file ) ; - $err = slurp( $err_file ) ; - _unlink $out_file; - _unlink $err_file; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $out, "out: $text more out data" ) }, -sub { eok( $err, uc( "err: $text more err data" ) ) }, - -## -## filehandle output redirection via a pipe that is returned to the caller -## -sub { - $fd_map = _map_fds ; - my $r = run \@emitter, \undef, '>pipe', \*OUT, '2>pipe', \*ERR ; - $out = '' ; - $err = '' ; - read OUT, $out, 10000 or warn $!; - read ERR, $err, 10000 or warn $!; - close OUT or warn $! ; - close ERR or warn $! ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, - -## -## sub I & O redirection -## -sub { - $in = $emitter_script ; - $out = undef ; - $err = undef ; - $fd_map = _map_fds ; - $r = run( - \@perl, - '<', sub { my $f = $in ; $in = undef ; return $f }, - '>', sub { $out .= shift }, - '2>', sub { $err .= shift }, - ) ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, - -## -## input redirection from a file -## -sub { - $out = undef ; - $err = undef ; - $fd_map = _map_fds ; - spit( $in_file, $emitter_script ) ; - $r = run( - \@perl, - "<$in_file", - '>', sub { $out .= shift }, - '2>', sub { $err .= shift }, - ) ; - _unlink $in_file; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, - -## -## reading input from a non standard fd -## -skip_unless_high_fds { - $out = undef ; - $err = undef ; - $fd_map = _map_fds ; - $r = run( - ## FreeBSD doesn't guarantee that fd 3 or 4 are available, so - ## don't assume, go for 5. - [ @perl, '-le', 'open( STDIN, "<&5" ) or die $! ; print <STDIN>' ], - "5<", \"Hello World", - '>', \$out, - '2>', \$err, - ) ; - ok( $r ) ; -}, -skip_unless_high_fds { ok( ! $? ) }, -skip_unless_high_fds { ok( _map_fds, $fd_map ) }, - -skip_unless_high_fds { eok( $out, $text ) }, -skip_unless_high_fds { eok( $err, '' ) }, - -## -## duping input descriptors and an input descriptor > 0 -## -skip_unless_high_fds { - $in = $emitter_script ; - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - $r = run( - \@perl, - '>', \$out, - '2>', \$err, - '3<', \$in, - '0<&3', - ) ; - ok( $r ) ; -}, -skip_unless_high_fds { ok( ! $? ) }, -skip_unless_high_fds { ok( _map_fds, $fd_map ) }, -skip_unless_high_fds { eok( $in, $emitter_script ) }, -skip_unless_high_fds { eok( $out, $text ) }, -skip_unless_high_fds { eok( $err, uc( $text ) ) }, - -## -## closing input descriptors -## -sub { - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - spit( $in_file, $emitter_script ) ; - $r = run( - [ @perl, '-e', '$l = readline *STDIN or die $! ; print $l' ], - '>', \$out, - '2>', \$err, - '<', $in_file, - '0<&-', - ) ; - _unlink $in_file; - ok( ! $r ) ; -}, -sub { ok( $? ) }, -sub { ok( _map_fds, $fd_map ) }, -sub { eok( $out, '' ) }, -#sub { ok( $err =~ /file descriptor/i ? "Bad file descriptor error" : $err, "Bad file descriptor error" ) }, -# XXX This should be use Errno; if $!{EBADF}. --rs -sub { ok( length $err ? "Bad file descriptor error" : $err, "Bad file descriptor error" ) }, - -## -## input redirection from a non-existent file -## -sub { - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - my $bad_file = "$in_file.nonexistant" ; - _unlink $bad_file if -e $bad_file; - eval { - $r = run \@perl, ">$out_file", "<$bad_file" ; - } ; - if ( $@ =~ /\Q$bad_file\E/ ) { - ok 1 ; - } - else { - ok $@, "qr/\Q$bad_file\E/" ; - } -}, -sub { ok( _map_fds, $fd_map ) }, - -## -## output redirection to a file w/ creation or truncation -## -sub { - $fd_map = _map_fds ; - _unlink $out_file if -x $out_file; - _unlink $err_file if -x $err_file; - $r = run( - \@emitter, - ">$out_file", - "2>$err_file", - ) ; - $out = slurp( $out_file ) ; - $err = slurp( $err_file ) ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, - -## -## output file redirection, w/ truncation -## -sub { - $fd_map = _map_fds ; - spit( $out_file, 'out: ' ) ; - spit( $err_file, 'ERR: ' ) ; - $r = run( - \@emitter, - ">$out_file", - "2>$err_file", - ) ; - $out = slurp( $out_file ) ; _unlink $out_file; - $err = slurp( $err_file ) ; _unlink $err_file; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, - -## -## output file redirection w/ append -## -sub { - spit( $out_file, 'out: ' ) ; - spit( $err_file, 'ERR: ' ) ; - $fd_map = _map_fds ; - $r = run( - \@emitter, - ">>$out_file", - "2>>$err_file", - ) ; - $out = slurp( $out_file ) ; - _unlink $out_file; - $err = slurp( $err_file ) ; - _unlink $err_file; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $out, "out: $text" ) }, -sub { eok( $err, uc( "err: $text" ) ) }, -## -## dup()ing output descriptors -## -sub { - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - $r = run \@emitter, '>', \$out, '2>', \$err, '2>&1' ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, -sub { $out =~ /(?:$text){2}/i ? ok 1 : ok $out, "qr/($text){2}/i" }, -sub { eok( $err, '' ) }, - -## -## stderr & stdout redirection to the same file via >&word -## -sub { - $fd_map = _map_fds ; - _unlink $out_file if -x $out_file; - $r = run \@emitter, ">&$out_file" ; - $out = slurp( $out_file ) ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { ok( $out =~ qr/(?:$text){2}/i ) }, - -## -## Non-zero exit value, command with args, no redirects. -## -sub { - $fd_map = _map_fds ; - $r = run [ @perl, '-e', 'exit(42)' ] ; - ok( !$r ) ; -}, -sub { ok( $?, 42 << 8 ) }, -sub { ok( _map_fds, $fd_map ) }, - -## -## Zero exit value, command with args, no redirects. -## -sub { - $fd_map = _map_fds ; - $r = run [ @perl, qw{ -e exit }] ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -## -## dup()ing output descriptors that collide. -## -## This test assumes that our caller doesn't leave a lot of fds opened, -## and assumes that $out_file will be opened on fd 3, 4 or 5. -## -skip_unless_high_fds { - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - _unlink $out_file if -x $out_file; - $fd_map = _map_fds ; - $r = run( - \@emitter, - "<", \"", - "3>&1", "4>&1", "5>&1", - ">$out_file", - '2>', \$err, - ) ; - $out = slurp( $out_file ) ; - _unlink $out_file; - ok( $r ) ; -}, -skip_unless_high_fds { ok( ! $? ) }, -skip_unless_high_fds { ok( _map_fds, $fd_map ) }, -skip_unless_high_fds { eok( $out, $text ) }, -skip_unless_high_fds { eok( $err, uc( $text ) ) }, - -## -## Pipelining -## -sub { - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - $r = run( - [ @perl, '-lane', 'print STDERR "1:$_" ; print uc($F[0])," ",$F[1]'], - \"Hello World", - '|',[ @perl, '-lane', 'print STDERR "2:$_" ; print $F[0]," ",lc($F[1])'], - \$out, - \$err, - ) ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, -sub { eok( $out, "HELLO world\n" ) }, -sub { eok( $err, "1:Hello World\n2:HELLO World\n" ) }, - -## -## Parallel (unpiplined) processes -## -sub { - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - $r = run( - [ @perl, '-lane', 'print STDERR "1:$_" ; print uc($F[0])," ",$F[1]' ], - \"Hello World", - '&', [ @perl, '-lane', 'print STDERR "2:$_" ; print $F[0]," ",lc( $F[1] )' ], - \"Hello World", - \$out, - \$err, - ) ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, -sub { ok( $out =~ qr/^(?:HELLO World\n|Hello world\n){2}$/s ) }, -sub { ok( $err =~ qr/^(?:[12]:Hello World.*){2}$/s ) }, - -## -## A few error cases... -## -sub { - eval { $r = run \@perl, '<', [], [] } ; - ok( $@ =~ qr/not allowed/ ) ; -}, - -sub { - eval { $r = run \@perl, '>', [], [] } ; - ok( $@ =~ qr/not allowed/ ) ; -}, - -( - map { - my $foo = $_ ; - sub { - eval { $r = run $foo, [] } ; - ok( $@ =~ qr/command/ ) ; - } - } qw( | & < > >& 1>&2 >file <file 2<&1 <&- 3<&- ) -), -sub { - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - eval { - $r = run( \@emitter, '>', \$out, '2>', \$err, - _simulate_fork_failure => 1 - ) ; - } ; - ok( $@ ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $out, '' ) }, -sub { eok( $err, '' ) }, - -sub { - $fd_map = _map_fds ; - eval { - $r = run \@perl, '<file', _simulate_open_failure => 1 ; - } ; - ok( $@ ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { - $fd_map = _map_fds ; - eval { - $r = run \@perl, '>file', _simulate_open_failure => 1 ; - } ; - ok( $@ ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -## -## harness, pump, run -## -sub { - $in = 'SHOULD BE UNCHANGED' ; - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $? = 99 ; - $fd_map = _map_fds ; - $h = start( - [ @perl, '-pe', 'BEGIN { $| = 1 } print STDERR uc($_)' ], - \$in, \$out, \$err, - ) ; - ok( isa( $h, 'IPC::Run' ) ) ; -}, -sub { ok( $?, 99 ) }, - -sub { eok( $in, 'SHOULD BE UNCHANGED' ) }, -sub { eok( $out, '' ) }, -sub { eok( $err, '' ) }, -sub { ok( $h->pumpable ) }, - -sub { - $in = '' ; - $? = 0 ; - pump_nb $h for ( 1..100 ) ; - ok( 1 ) ; -}, -sub { eok( $in, '' ) }, -sub { eok( $out, '' ) }, -sub { eok( $err, '' ) }, -sub { ok( $h->pumpable ) }, - -sub { - $in = $text ; - $? = 0 ; - pump $h until $out =~ /Hello World/ ; - ok( 1 ) ; -}, -sub { ok( ! $? ) }, -sub { eok( $in, '' ) }, -sub { eok( $out, $text ) }, -sub { ok( $h->pumpable ) }, - -sub { ok( $h->finish ) }, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, -sub { ok( ! $h->pumpable ) }, - -## -## start, run, run, run. See Tom run. A do-run-run, a-do-run-run. -## -sub { - $in = 'SHOULD BE UNCHANGED' ; - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - $h = start( - [ @perl, '-pe', 'binmode STDOUT ; binmode STDERR ; BEGIN { $| = 1 } print STDERR uc($_)' ], - \$in, \$out, \$err, - ) ; - ok( isa( $h, 'IPC::Run' ) ) ; -}, - -sub { eok( $in, 'SHOULD BE UNCHANGED' ) }, -sub { eok( $out, '' ) }, -sub { eok( $err, '' ) }, -sub { ok( $h->pumpable ) }, - -sub { - $in = $text ; - ok( $h->finish ) -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, -sub { eok( $in, '' ) }, -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, -sub { ok( ! $h->pumpable ) }, - -sub { - $in = $text ; - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - ok( $h->run ) -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, -sub { eok( $in, $text ) }, -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, -sub { ok( ! $h->pumpable ) }, - -sub { - $in = $text ; - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - ok( $h->run ) -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, -sub { eok( $in, $text ) }, -sub { eok( $out, $text ) }, -sub { eok( $err, uc( $text ) ) }, -sub { ok( ! $h->pumpable ) }, - -## -## Output filters -## -sub { - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - $r = run( - \@emitter, - '>', - \&alt_casing_filter, - \&case_inverting_filter, - \$out, - '2>', \$err, - ) ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $out, "HeLlO WoRlD\n" ) }, -sub { eok( $err, uc( $text ) ) }, - -## -## Input filters -## -sub { - $out = 'REPLACE ME' ; - $err = 'REPLACE ME' ; - $fd_map = _map_fds ; - $in = $text ; - $r = run( - [ @perl, '-pe', 'binmode STDOUT ; binmode STDERR ; print STDERR uc $_' ], - '0<', - \&case_inverting_filter, - \&alt_casing_filter, - \$in, - '1>', \$out, - '2>', \$err, - ) ; - ok( $r ) ; -}, -sub { ok( ! $? ) }, -sub { ok( _map_fds, $fd_map ) }, - -sub { eok( $in, $text ) }, -sub { eok( $out, "HeLlO WoRlD\n" ) }, -sub { eok( $err, uc( $text ) ) }, -) ; - -plan tests => scalar @tests, todo => [ 69 ] ; - -# Must do this this late as plan uses localtime, and localtime on darwin opens -# a file descriptor. Quite probably other operating systems do file descriptor -# things during the test setup. - -$fd_map = _map_fds ; - -$_->() for ( @tests ) ; diff --git a/lib/IPC/Run/t/signal.t b/lib/IPC/Run/t/signal.t deleted file mode 100644 index 399bd527e4..0000000000 --- a/lib/IPC/Run/t/signal.t +++ /dev/null @@ -1,90 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -signal.t - Test suite IPC::Run->signal - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - -use strict ; - -use Test ; - -use IPC::Run qw( :filters :filter_imp start run filter_tests ) ; -use UNIVERSAL qw( isa ) ; - -sub Win32_MODE() ; -*Win32_MODE = \&IPC::Run::Win32_MODE ; - -## Win32 does not support a lot of things that Unix does. These -## skip_unless subs help that. -## -## TODO: There are also a few things that Win32 supports (passing Win32 OS -## handles) that we should test for, conversely. -sub skip_unless_signals(&) { - if ( Win32_MODE ) { - return sub { - skip "$^O does not support signals", 0 ; - } ; - } - shift ; -} - -use IPC::Run qw( start ) ; - -my @receiver = ( - $^X, - '-e', - <<'END_RECEIVER', - my $which = " " ; - sub s{ $which = $_[0] } ; - $SIG{$_}=\&s for (qw(USR1 USR2)); - $| = 1 ; - print "Ok\n"; - for (1..10) { sleep 1 ; print $which, "\n" } -END_RECEIVER -) ; - -my $h ; -my $out ; - -my @tests = ( -skip_unless_signals { - $h = start \@receiver, \undef, \$out ; - pump $h until $out =~ /Ok/ ; - ok 1 ; -}, -skip_unless_signals { - $out = "" ; - $h->signal( "USR2" ) ; - pump $h ; - $h->signal( "USR1" ) ; - pump $h ; - $h->signal( "USR2" ) ; - pump $h ; - $h->signal( "USR1" ) ; - pump $h ; - ok $out, "USR2\nUSR1\nUSR2\nUSR1\n" ; -}, - -skip_unless_signals { - $h->signal( "TERM" ) ; - finish $h ; - ok( 1 ) ; -}, - -) ; - -plan tests => scalar @tests ; - -$_->() for ( @tests ) ; diff --git a/lib/IPC/Run/t/timeout.t b/lib/IPC/Run/t/timeout.t deleted file mode 100644 index 394f10998d..0000000000 --- a/lib/IPC/Run/t/timeout.t +++ /dev/null @@ -1,117 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -timeout.t - Test suite for IPC::Run timeouts - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - - -## Separate from run.t so run.t is not too slow. - -use strict ; - -use Test ; - -use IPC::Run qw( harness timeout ) ; -use UNIVERSAL qw( isa ) ; - -my $h ; -my $t ; -my $in ; -my $out ; -my $started ; - -my @tests = ( - -sub { - $h = harness( [ $^X ], \$in, \$out, $t = timeout( 1 ) ) ; - ok( isa( $h, 'IPC::Run' ) ) ; -}, -sub { ok( !! $t->is_reset ) }, -sub { ok( ! $t->is_running ) }, -sub { ok( ! $t->is_expired ) }, - -sub { - $started = time ; - $h->start ; - ok( 1 ) ; -}, -sub { ok( ! $t->is_reset ) }, -sub { ok( !! $t->is_running ) }, -sub { ok( ! $t->is_expired ) }, - -sub { - $in = '' ; - eval { $h->pump }; - # Older perls' Test.pms don't know what to do with qr//s - $@ =~ /IPC::Run: timeout/ ? ok( 1 ) : ok( $@, qr/IPC::Run: timeout/ ) ; -}, - -sub { - my $elapsed = time - $started ; - $elapsed >= 1 ? ok( 1 ) : ok( $elapsed, ">= 1" ) ; -}, - -sub { ok( $t->interval, 1 ) }, -sub { ok( ! $t->is_reset ) }, -sub { ok( ! $t->is_running ) }, -sub { ok( !! $t->is_expired ) }, - -## -## Starting from an expired state -## -sub { - $started = time ; - $h->start ; - ok( 1 ) ; -}, -sub { ok( ! $t->is_reset ) }, -sub { ok( !! $t->is_running ) }, -sub { ok( ! $t->is_expired ) }, -sub { - $in = '' ; - eval { $h->pump }; - $@ =~ /IPC::Run: timeout/ ? ok( 1 ) : ok( $@, qr/IPC::Run: timeout/ ) ; -}, -sub { ok( ! $t->is_reset ) }, -sub { ok( ! $t->is_running ) }, -sub { ok( !! $t->is_expired ) }, - -sub { - my $elapsed = time - $started ; - $elapsed >= 1 ? ok( 1 ) : ok( $elapsed, ">= 1" ) ; -}, - -sub { - $h = harness( [ $^X ], \$in, \$out, timeout( 1 ) ) ; - $started = time ; - $h->start ; - $in = '' ; - eval { $h->pump }; - $@ =~ /IPC::Run: timeout/ ? ok( 1 ) : ok( $@, qr/IPC::Run: timeout/ ) ; -}, - -sub { - my $elapsed = time - $started ; - $elapsed >= 1 ? ok( 1 ) : ok( $elapsed, ">= 1" ) ; -}, - -) ; - - - -plan tests => scalar @tests ; - -$_->() for ( @tests ) ; - diff --git a/lib/IPC/Run/t/timer.t b/lib/IPC/Run/t/timer.t deleted file mode 100644 index 85ab5cb65b..0000000000 --- a/lib/IPC/Run/t/timer.t +++ /dev/null @@ -1,150 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -timer.t - Test suite for IPC::Run::Timer - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - -use strict ; - -use Test ; - -use IPC::Run qw( run ) ; -use IPC::Run::Timer qw( :all ) ; -use UNIVERSAL qw( isa ) ; - -my $t ; -my $started ; - -my @tests = ( - -sub { - $t = timer( -# debug => 1, - 1, - ) ; - ok( ref $t, 'IPC::Run::Timer' ) ; -}, - -sub { ok( $t->interval, 1 ) }, - -sub { $t->interval( 0 ) ; ok( $t->interval, 0 ) }, -sub { $t->interval( 0.1 ) ; ok( $t->interval > 0 ) }, -sub { $t->interval( 1 ) ; ok( $t->interval >= 1 ) }, -sub { $t->interval( 30 ) ; ok( $t->interval >= 30 ) }, -sub { $t->interval( 30.1 ) ; ok( $t->interval > 30 ) }, -sub { $t->interval( 30.1 ) ; ok( $t->interval <= 31 ) }, - -sub { $t->interval( "1:0" ) ; ok( $t->interval, 60 ) }, -sub { $t->interval( "1:0:0" ) ; ok( $t->interval, 3600 ) }, -sub { $t->interval( "1:1:1" ) ; ok( $t->interval, 3661 ) }, -sub { $t->interval( "1:1:1.1" ) ; ok( $t->interval > 3661 ) }, -sub { $t->interval( "1:1:1.1" ) ; ok( $t->interval <= 3662 ) }, -sub { $t->interval( "1:1:1:1" ) ; ok( $t->interval, 90061 ) }, - -sub { - $t->reset ; - $t->interval( 5 ) ; - $t->start( 1, 0 ) ; - ok( ! $t->is_expired ) ; -}, -sub { ok( !! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, - -sub { ok( !! $t->check( 0 ) ) }, -sub { ok( ! $t->is_expired ) }, -sub { ok( !! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, -sub { ok( !! $t->check( 1 ) ) }, -sub { ok( ! $t->is_expired ) }, -sub { ok( !! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, -sub { ok( ! $t->check( 2 ) ) }, -sub { ok( !! $t->is_expired ) }, -sub { ok( ! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, -sub { ok( ! $t->check( 3 ) ) }, -sub { ok( !! $t->is_expired ) }, -sub { ok( ! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, - -## Restarting from the expired state. -sub { - $t->start( undef, 0 ) ; - ok( ! $t->is_expired ) ; -}, -sub { ok( !! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, - -sub { ok( !! $t->check( 0 ) ) }, -sub { ok( ! $t->is_expired ) }, -sub { ok( !! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, -sub { ok( !! $t->check( 1 ) ) }, -sub { ok( ! $t->is_expired ) }, -sub { ok( !! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, -sub { ok( ! $t->check( 2 ) ) }, -sub { ok( !! $t->is_expired ) }, -sub { ok( ! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, -sub { ok( ! $t->check( 3 ) ) }, -sub { ok( !! $t->is_expired ) }, -sub { ok( ! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, - -## Restarting while running -sub { - $t->start( 1, 0 ) ; - $t->start( undef, 0 ) ; - ok( ! $t->is_expired ) ; -}, -sub { ok( !! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, - -sub { ok( !! $t->check( 0 ) ) }, -sub { ok( ! $t->is_expired ) }, -sub { ok( !! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, -sub { ok( !! $t->check( 1 ) ) }, -sub { ok( ! $t->is_expired ) }, -sub { ok( !! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, -sub { ok( ! $t->check( 2 ) ) }, -sub { ok( !! $t->is_expired ) }, -sub { ok( ! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, -sub { ok( ! $t->check( 3 ) ) }, -sub { ok( !! $t->is_expired ) }, -sub { ok( ! $t->is_running ) }, -sub { ok( ! $t->is_reset ) }, - -sub { - my $got ; - eval { - $got = "timeout fired" ; - run [$^X, '-e', 'sleep 3'], timeout 1 ; - $got = "timeout didn't fire" ; - } ; - ok $got, "timeout fired", "timer firing in run()" ; -}, - -) ; - - - -plan tests => scalar @tests ; - -$_->() for ( @tests ) ; - diff --git a/lib/IPC/Run/t/win32_compile.t b/lib/IPC/Run/t/win32_compile.t deleted file mode 100644 index a71a377df8..0000000000 --- a/lib/IPC/Run/t/win32_compile.t +++ /dev/null @@ -1,92 +0,0 @@ -#!/usr/bin/perl -w - -=head1 NAME - -win32_compile.t - See if IPC::Run::Win32Helper compiles, even on Unix - -=cut - -BEGIN { - if( $ENV{PERL_CORE} ) { - use Cwd; - $^X = Cwd::abs_path($^X); - $^X = qq("$^X") if $^X =~ /\s/; - chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; - unshift @INC, 'lib', '../..'; - } -} - -use strict ; - -use Test ; - -BEGIN { - unless ( eval "require 5.006" ) { - ## NOTE: I'm working around this here because I don't want this - ## test to fail on non-Win32 systems with older Perls. Makefile.PL - ## does the require 5.6.0 to protect folks on Windows. - plan tests => 1; - skip "perl5.00503's Socket.pm does not export IPPROTO_TCP", 1, 1; - exit 0; - } - - - $INC{$_} = 1 for qw( Win32/Process.pm Win32API/File.pm ) ; - - package Win32API::File ; - - use vars qw( @ISA @EXPORT ) ; - - @ISA = qw( Exporter ) ; - @EXPORT = qw( - GetOsFHandle - OsFHandleOpen - OsFHandleOpenFd - FdGetOsFHandle - SetHandleInformation - SetFilePointer - - HANDLE_FLAG_INHERIT - INVALID_HANDLE_VALUE - - createFile - WriteFile - ReadFile - CloseHandle - - FILE_ATTRIBUTE_TEMPORARY - FILE_FLAG_DELETE_ON_CLOSE - FILE_FLAG_WRITE_THROUGH - - FILE_BEGIN - ) ; - - eval "sub $_ { 1 }" for @EXPORT ; - - use Exporter ; - - package Win32::Process ; - - use vars qw( @ISA @EXPORT ) ; - - @ISA = qw( Exporter ) ; - @EXPORT = qw( - NORMAL_PRIORITY_CLASS - ) ; - - eval "sub $_ {}" for @EXPORT ; - - use Exporter ; -} - -sub Socket::IPPROTO_TCP() { undef } - -package main ; - -use IPC::Run::Win32Helper ; -use IPC::Run::Win32IO ; - -plan tests => 1 ; - -ok 1 ; - |