installer.pl

#!/usr/bin/env perl

# This chunk of stuff was generated by App::FatPacker. To find the original
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
BEGIN {
my %fatpacked;

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

$fatpacked{"IPC/Run/Debug.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN_DEBUG';
  package IPC::Run::Debug;
  
  =pod
  
  =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 compatibility:
  
     0  none         disabled (special, see below)
     1  basic        what's running
     2  data         what's being sent/received
     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
  
  ## 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 ();".
  
  use strict;
  use Exporter;
  use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS};
  
  BEGIN {
      $VERSION = '0.96';
      @ISA     = qw( Exporter );
      @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 ],
      );
  }
  
  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 ();
  
  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 & especially sys and kernel
        ## 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 its 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  && UNIVERSAL::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
  
  =pod
  
  =head1 AUTHOR
  
  Barrie Slaymaker <barries@slaysys.com>, with numerous suggestions by p5p.
  
  =cut
IPC_RUN_DEBUG

$fatpacked{"IPC/Run/IO.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN_IO';
  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, independent 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.
  
  =cut
  
  ## This class is also used internally by IPC::Run in a very intimate 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 IPC::Run::Debug;
  use IPC::Run qw( Win32_MODE );
  
  use vars qw{$VERSION};
  
  BEGIN {
      $VERSION = '0.96';
      if (Win32_MODE) {
          eval "use IPC::Run::Win32Helper; require IPC::Run::Win32IO; 1"
            or ( $@ && die )
            or die "$!";
      }
  }
  
  sub _empty($);
  *_empty = \&IPC::Run::_empty;
  
  =head1 SUBROUTINES
  
  =over 4
  
  =item new
  
  I think it takes >> or << along with some other data.
  
  TODO: Needs more thorough documentation. Patches welcome.
  
  =cut
  
  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' || UNIVERSAL::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 ( UNIVERSAL::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 ( UNIVERSAL::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 ( UNIVERSAL::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
  independent 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 UNIVERSAL::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};
  }
  
  =item poll
  
  TODO: Needs confirmation that this is correct. Was previously undocumented.
  
  I believe this is polling the IO for new input and then 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.
  
  =cut
  
  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 $redos = 0;
      my $r;
      {
          $@ = '';
          $r = eval { IPC::Run::get_more_input(); };
  
          # Detect Resource temporarily unavailable and re-try 200 times (2 seconds),  assuming select behaves (which it doesn't always? need ref)
          if ( ( $@ || '' ) =~ $IPC::Run::_EAGAIN && $redos++ < 200 ) {
              select( undef, undef, undef, 0.01 );
              redo;
          }
      }
      ( $IPC::Run::filter_op, $IPC::Run::filter_num ) = ( $saved_op, $saved_num );
      $self->{HARNESS} = undef;
      die "ack ", $@ if $@;
      return $r;
  }
  
  =back
  
  =head1 AUTHOR
  
  Barrie Slaymaker <barries@slaysys.com>
  
  =head1 TODO
  
  Implement bidirectionality.
  
  =cut
  
  1;
IPC_RUN_IO

$fatpacked{"IPC/Run/Timer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN_TIMER';
  package IPC::Run::Timer;
  
  =pod
  
  =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 respect 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 any kind of perl number,
  e.g. as integer or floating point seconds, optionally preceded by
  punctuation-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
     'inf'       the infinity perl special number (the timer never finishes)
  
  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 Exporter;
  use Scalar::Util ();
  use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS );
  
  BEGIN {
      $VERSION   = '0.96';
      @ISA       = qw( Exporter );
      @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 );
  }
  
  require IPC::Run;
  use IPC::Run::Debug;
  
  ##
  ## Some helpers
  ##
  my $resolution = 1;
  
  sub _parse_time {
      for ( $_[0] ) {
          my $val;
          if ( not defined $_ ) {
              $val = $_;
          }
          else {
              my @f = split( /:/, $_, -1 );
              if ( scalar @f > 4 ) {
                  croak "IPC::Run: expected <= 4 elements in time string '$_'";
              }
              for (@f) {
                  if ( not Scalar::Util::looks_like_number($_) ) {
                      croak "IPC::Run: non-numeric element '$_' in time string '$_'";
                  }
              }
              my ( $s, $m, $h, $d ) = reverse @f;
              $val = ( ( ( $d || 0 ) * 24 + ( $h || 0 ) ) * 60 + ( $m || 0 ) ) * 60 + ( $s || 0 );
          }
          return $val;
      }
  }
  
  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 eq 'exception' ) {
              $self->exception(shift);
          }
          elsif ( $arg eq 'name' ) {
              $self->name(shift);
          }
          elsif ( $arg eq 'debug' ) {
              $self->debug(shift);
          }
          else {
              $self->interval($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.
  
  =back
  
  =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};
  }
  
  1;
  
  =pod
  
  =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
IPC_RUN_TIMER

$fatpacked{"IPC/Run/Win32Helper.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN_WIN32HELPER';
  package IPC::Run::Win32Helper;
  
  =pod
  
  =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
  
  use strict;
  use Carp;
  use IO::Handle;
  use vars qw{ $VERSION @ISA @EXPORT };
  
  BEGIN {
      $VERSION = '0.96';
      @ISA     = qw( Exporter );
      @EXPORT  = qw(
        win32_spawn
        win32_parse_cmd_line
        _dont_inherit
        _inherit
      );
  }
  
  require POSIX;
  
  use Text::ParseWords;
  use Win32::Process;
  use IPC::Run::Debug;
  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 );
  #   }
  #}
  
  =pod
  
  =head1 FUNCTIONS
  
  =over
  
  =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 inconsistencies 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 highlight 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;
              }
          }
      }
  
  }
  
  =pod
  
  =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;
  }
  
  =pod
  
  =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 );
  }
  
  1;
  
  =pod
  
  =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 or the Artistic License.
  
  =cut
IPC_RUN_WIN32HELPER

$fatpacked{"IPC/Run/Win32IO.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN_WIN32IO';
  package IPC::Run::Win32IO;
  
  =pod
  
  =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!.
  
  =head1 DESCRIPTION
  
  A specialized IO class used on Win32.
  
  =cut
  
  use strict;
  use Carp;
  use IO::Handle;
  use Socket;
  require POSIX;
  
  use vars qw{$VERSION};
  
  BEGIN {
      $VERSION = '0.96';
  }
  
  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};
  
      close( $self->{CHILD_HANDLE} )
        if defined $self->{CHILD_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} );
  }
  
  =head1 SUBROUTINES
  
  =over
  
  =item poll
  
  Windows version of IPC::Run::IP::poll.
  
  =back
  
  =cut
  
  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 $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()";
  
      unless ( bind $listener, sockaddr_in( 0, $loopback ) ) {
          croak "Error binding: $!";
      }
  
      my ($port) = sockaddr_in( getsockname($listener) );
  
      _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(@_);
      }
  }
  
  1;
  
  =pod
  
  =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 or the Artistic License.
  
  =cut
IPC_RUN_WIN32IO

$fatpacked{"IPC/Run/Win32Pump.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IPC_RUN_WIN32PUMP';
  package IPC::Run::Win32Pump;
  
  =pod
  
  =head1 NAME
  
  IPC::Run::Win32Pump - 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 vars qw{$VERSION};
  
  BEGIN {
      $VERSION = '0.96';
  }
  
  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;
  
  1;
  
  =pod
  
  =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
IPC_RUN_WIN32PUMP

s/^  //mg for values %fatpacked;

my $class = 'FatPacked::'.(0+\%fatpacked);
no strict 'refs';
*{"${class}::files"} = sub { keys %{$_[0]} };

if ($] < 5.008) {
  *{"${class}::INC"} = sub {
    if (my $fat = $_[0]{$_[1]}) {
      my $pos = 0;
      my $last = length $fat;
      return (sub {
        return 0 if $pos == $last;
        my $next = (1 + index $fat, "\n", $pos) || $last;
        $_ .= substr $fat, $pos, $next - $pos;
        $pos = $next;
        return 1;
      });
    }
  };
}

else {
  *{"${class}::INC"} = sub {
    if (my $fat = $_[0]{$_[1]}) {
      open my $fh, '<', \$fat
        or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
      return $fh;
    }
    return;
  };
}

unshift @INC, bless \%fatpacked, $class;
  } # END OF FATPACK CODE

use 5.018;
use utf8;
use strict;
use warnings;

use Cwd qw/abs_path/;
use File::Path qw/make_path/;
use File::Copy;
use IPC::Run qw/run/;
use Term::ANSIColor qw/:constants/;

BEGIN {
    binmode STDOUT, ":encoding(utf-8)";
    binmode STDERR, ":encoding(utf-8)";
}

my %DEP_RESOLVED = ();

sub DEP_REQUIREMENTS () { qw/git wget zsh vim/;  }
sub DEP_OPTIONAL     () { qw/ffmpeg xwininfo tmux/; }

sub MSG_E($)  { sprintf("[%s오류%s] %s\n", BRIGHT_RED,    RESET, shift); }
sub MSG_W($)  { sprintf("[%s경고%s] %s\n", BRIGHT_YELLOW, RESET, shift); }
sub MSG_I($)  { sprintf("[%s알림%s] %s\n", BRIGHT_BLUE,   RESET, shift); }
sub MSG_O($)  { sprintf("[%s OK %s] %s\n", BRIGHT_GREEN,  RESET, shift); }
sub PROMPT($) { sprintf("\n%s==>%s %s%s\n", BRIGHT_BLUE, BRIGHT_WHITE, shift, RESET); }

sub which {
    my ($command, $is_required) = @_;
    my $result = run ['/usr/bin/which', $command], '>', \my $path, '2>', \my $stderr;
    chomp $path;

    if ($result) {
        warn MSG_O("$command 를 찾았습니다: $path");
        return $path; 
    } else {
        if ($is_required) {
            die MSG_E("$command 가 설치되어 있지 않습니다. 더 이상 진행할 수 없습니다.");
        }
        warn MSG_W("$command 가 설치되어 있지 않습니다. 일부 기능이 동작하지 않을 수 있습니다.");
    }
}

sub check_dependencies {
    say PROMPT("의존성을 검사합니다");
    $DEP_RESOLVED{$_} = which($_, 1) for DEP_REQUIREMENTS;
    $DEP_RESOLVED{$_} = which($_, 0) for DEP_OPTIONAL;
    say "";
}

sub install {
    my ($method, $description, $source, $destination, $filename) = @_;

    my $resolved_source = abs_path($source);
    my $resolved_destination = $destination . '/' . $filename;

    say PROMPT($description . '을 설치합니다');
    warn MSG_I(sprintf(
        "파일을 다음 위치로 %s합니다.\n\t%s => %s",
        ($method eq 'copy') ? '복사' : '링크',
        $resolved_source,
        $resolved_destination
    ));

    unless (-d $destination) {
        warn MSG_W(sprintf(
            "%s 디렉토리가 없습니다. 새로 만듭니다.",
            $destination
        ));
        make_path($destination);
    }

    if (-e $resolved_destination) {
        warn MSG_W(sprintf(
            "%s가 이미 존재합니다. 이 파일은 %s.old로 이름이 변경됩니다.",
            $resolved_destination, $filename
        ));
        rename($resolved_destination, $resolved_destination . '.old');
    }

    if ($method eq 'copy') {
        copy($resolved_source, $resolved_destination);
    } elsif ($method eq 'link') {
        symlink($resolved_source, $resolved_destination);
    }
}

sub install_exec {
    my ($description, $commands) = @_;
    say PROMPT('다음 작업을 실행합니다: '. $description);

    for my $command (@$commands) {
        warn MSG_I(sprintf(
            "명령 실행: %s",
            join($", (@$command))
        ));
        system(@$command);
    }

    if ($? != 0) {
        warn MSG_W("명령이 정상적으로 종료되지 않았을 수도 있습니다. (retval = $?)");
    }
}

say "cheeseskel installer";
say "====================";

check_dependencies();
install('copy', 'zshrc 설정 파일', './zsh/zshrc.sample', $ENV{HOME}, '.zshrc');
install('link', 'vimrc 설정 파일', './vim/vimrc', $ENV{HOME}, '.vimrc');
install_exec('dein.vim 설치', [
    ['wget', '-O', '/tmp/dein-installer.sh', 'https://raw.githubusercontent.com/Shougo/dein.vim/master/bin/installer.sh'],
    ['sh', '/tmp/dein-installer.sh', $ENV{HOME} . '/.vim/bundles']
]);
install('copy', 'fontconfig 설정 파일', './fontconfig/fonts.conf', $ENV{HOME} . '/.config/fontconfig', 'fonts.conf');
install_exec('zsh로 기본 쉘 변경', [
    ['chsh', '-s', $DEP_RESOLVED{zsh}]
]) if -e $DEP_RESOLVED{zsh};

say "설치가 잘 끝났습니다.";