summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl.straw/lib/IPC
diff options
context:
space:
mode:
authorNorbert Preining <preining@logic.at>2010-03-01 01:54:19 +0000
committerNorbert Preining <preining@logic.at>2010-03-01 01:54:19 +0000
commit904fd0757fe037dbfbf156b31f72e5ff5c7cd796 (patch)
tree36f000ab754854574aad17c01d9cd9ac739f1053 /Master/tlpkg/tlperl.straw/lib/IPC
parent402bd194f686177d2dfca24f7c4766434c514141 (diff)
commit more files of the tlperl.straw dir, still not complete
git-svn-id: svn://tug.org/texlive/trunk@17244 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl.straw/lib/IPC')
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Cmd.pm1646
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Open2.pm121
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Open3.pm376
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Run3.pm850
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Run3/ProfArrayBuffer.pm86
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogReader.pm157
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogger.pm139
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Run3/ProfPP.pm156
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/Run3/ProfReporter.pm256
-rwxr-xr-xMaster/tlpkg/tlperl.straw/lib/IPC/System/Simple.pm1076
10 files changed, 4863 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Cmd.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Cmd.pm
new file mode 100755
index 00000000000..e60c93fda24
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Cmd.pm
@@ -0,0 +1,1646 @@
+package IPC::Cmd;
+
+use strict;
+
+BEGIN {
+
+ use constant IS_VMS => $^O eq 'VMS' ? 1 : 0;
+ use constant IS_WIN32 => $^O eq 'MSWin32' ? 1 : 0;
+ use constant IS_WIN98 => (IS_WIN32 and !Win32::IsWinNT()) ? 1 : 0;
+ use constant ALARM_CLASS => __PACKAGE__ . '::TimeOut';
+ use constant SPECIAL_CHARS => qw[< > | &];
+ use constant QUOTE => do { IS_WIN32 ? q["] : q['] };
+
+ use Exporter ();
+ use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG
+ $USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN
+ ];
+
+ $VERSION = '0.54';
+ $VERBOSE = 0;
+ $DEBUG = 0;
+ $WARN = 1;
+ $USE_IPC_RUN = IS_WIN32 && !IS_WIN98;
+ $USE_IPC_OPEN3 = not IS_VMS;
+
+ $CAN_USE_RUN_FORKED = 0;
+ eval {
+ require POSIX; POSIX->import();
+ require IPC::Open3; IPC::Open3->import();
+ require IO::Select; IO::Select->import();
+ require IO::Handle; IO::Handle->import();
+ require FileHandle; FileHandle->import();
+ require Socket; Socket->import();
+ require Time::HiRes; Time::HiRes->import();
+ };
+ $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32;
+
+ @ISA = qw[Exporter];
+ @EXPORT_OK = qw[can_run run run_forked QUOTE];
+}
+
+require Carp;
+use File::Spec;
+use Params::Check qw[check];
+use Text::ParseWords (); # import ONLY if needed!
+use Module::Load::Conditional qw[can_load];
+use Locale::Maketext::Simple Style => 'gettext';
+
+=pod
+
+=head1 NAME
+
+IPC::Cmd - finding and running system commands made easy
+
+=head1 SYNOPSIS
+
+ use IPC::Cmd qw[can_run run run_forked];
+
+ my $full_path = can_run('wget') or warn 'wget is not installed!';
+
+ ### commands can be arrayrefs or strings ###
+ my $cmd = "$full_path -b theregister.co.uk";
+ my $cmd = [$full_path, '-b', 'theregister.co.uk'];
+
+ ### in scalar context ###
+ my $buffer;
+ if( scalar run( command => $cmd,
+ verbose => 0,
+ buffer => \$buffer,
+ timeout => 20 )
+ ) {
+ print "fetched webpage successfully: $buffer\n";
+ }
+
+
+ ### in list context ###
+ my( $success, $error_code, $full_buf, $stdout_buf, $stderr_buf ) =
+ run( command => $cmd, verbose => 0 );
+
+ if( $success ) {
+ print "this is what the command printed:\n";
+ print join "", @$full_buf;
+ }
+
+ ### check for features
+ print "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3;
+ print "IPC::Run available: " . IPC::Cmd->can_use_ipc_run;
+ print "Can capture buffer: " . IPC::Cmd->can_capture_buffer;
+
+ ### don't have IPC::Cmd be verbose, ie don't print to stdout or
+ ### stderr when running commands -- default is '0'
+ $IPC::Cmd::VERBOSE = 0;
+
+
+=head1 DESCRIPTION
+
+IPC::Cmd allows you to run commands, interactively if desired,
+platform independent but have them still work.
+
+The C<can_run> function can tell you if a certain binary is installed
+and if so where, whereas the C<run> function can actually execute any
+of the commands you give it and give you a clear return value, as well
+as adhere to your verbosity settings.
+
+=head1 CLASS METHODS
+
+=head2 $ipc_run_version = IPC::Cmd->can_use_ipc_run( [VERBOSE] )
+
+Utility function that tells you if C<IPC::Run> is available.
+If the verbose flag is passed, it will print diagnostic messages
+if C<IPC::Run> can not be found or loaded.
+
+=cut
+
+
+sub can_use_ipc_run {
+ my $self = shift;
+ my $verbose = shift || 0;
+
+ ### ipc::run doesn't run on win98
+ return if IS_WIN98;
+
+ ### if we dont have ipc::run, we obviously can't use it.
+ return unless can_load(
+ modules => { 'IPC::Run' => '0.55' },
+ verbose => ($WARN && $verbose),
+ );
+
+ ### otherwise, we're good to go
+ return $IPC::Run::VERSION;
+}
+
+=head2 $ipc_open3_version = IPC::Cmd->can_use_ipc_open3( [VERBOSE] )
+
+Utility function that tells you if C<IPC::Open3> is available.
+If the verbose flag is passed, it will print diagnostic messages
+if C<IPC::Open3> can not be found or loaded.
+
+=cut
+
+
+sub can_use_ipc_open3 {
+ my $self = shift;
+ my $verbose = shift || 0;
+
+ ### ipc::open3 is not working on VMS becasue of a lack of fork.
+ ### XXX todo, win32 also does not have fork, so need to do more research.
+ return if IS_VMS;
+
+ ### ipc::open3 works on every non-VMS platform platform, but it can't
+ ### capture buffers on win32 :(
+ return unless can_load(
+ modules => { map {$_ => '0.0'} qw|IPC::Open3 IO::Select Symbol| },
+ verbose => ($WARN && $verbose),
+ );
+
+ return $IPC::Open3::VERSION;
+}
+
+=head2 $bool = IPC::Cmd->can_capture_buffer
+
+Utility function that tells you if C<IPC::Cmd> is capable of
+capturing buffers in it's current configuration.
+
+=cut
+
+sub can_capture_buffer {
+ my $self = shift;
+
+ return 1 if $USE_IPC_RUN && $self->can_use_ipc_run;
+ return 1 if $USE_IPC_OPEN3 && $self->can_use_ipc_open3 && !IS_WIN32;
+ return;
+}
+
+=head2 $bool = IPC::Cmd->can_use_run_forked
+
+Utility function that tells you if C<IPC::Cmd> is capable of
+providing C<run_forked> on the current platform.
+
+=head1 FUNCTIONS
+
+=head2 $path = can_run( PROGRAM );
+
+C<can_run> takes but a single argument: the name of a binary you wish
+to locate. C<can_run> works much like the unix binary C<which> or the bash
+command C<type>, which scans through your path, looking for the requested
+binary .
+
+Unlike C<which> and C<type>, this function is platform independent and
+will also work on, for example, Win32.
+
+It will return the full path to the binary you asked for if it was
+found, or C<undef> if it was not.
+
+=cut
+
+sub can_run {
+ my $command = shift;
+
+ # a lot of VMS executables have a symbol defined
+ # check those first
+ if ( $^O eq 'VMS' ) {
+ require VMS::DCLsym;
+ my $syms = VMS::DCLsym->new;
+ return $command if scalar $syms->getsym( uc $command );
+ }
+
+ require Config;
+ require File::Spec;
+ require ExtUtils::MakeMaker;
+
+ if( File::Spec->file_name_is_absolute($command) ) {
+ return MM->maybe_command($command);
+
+ } else {
+ for my $dir (
+ (split /\Q$Config::Config{path_sep}\E/, $ENV{PATH}),
+ File::Spec->curdir
+ ) {
+ my $abs = File::Spec->catfile($dir, $command);
+ return $abs if $abs = MM->maybe_command($abs);
+ }
+ }
+}
+
+=head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] );
+
+C<run> takes 4 arguments:
+
+=over 4
+
+=item command
+
+This is the command to execute. It may be either a string or an array
+reference.
+This is a required argument.
+
+See L<CAVEATS> for remarks on how commands are parsed and their
+limitations.
+
+=item verbose
+
+This controls whether all output of a command should also be printed
+to STDOUT/STDERR or should only be trapped in buffers (NOTE: buffers
+require C<IPC::Run> to be installed or your system able to work with
+C<IPC::Open3>).
+
+It will default to the global setting of C<$IPC::Cmd::VERBOSE>,
+which by default is 0.
+
+=item buffer
+
+This will hold all the output of a command. It needs to be a reference
+to a scalar.
+Note that this will hold both the STDOUT and STDERR messages, and you
+have no way of telling which is which.
+If you require this distinction, run the C<run> command in list context
+and inspect the individual buffers.
+
+Of course, this requires that the underlying call supports buffers. See
+the note on buffers right above.
+
+=item timeout
+
+Sets the maximum time the command is allowed to run before aborting,
+using the built-in C<alarm()> call. If the timeout is triggered, the
+C<errorcode> in the return value will be set to an object of the
+C<IPC::Cmd::TimeOut> class. See the C<errorcode> section below for
+details.
+
+Defaults to C<0>, meaning no timeout is set.
+
+=back
+
+C<run> will return a simple C<true> or C<false> when called in scalar
+context.
+In list context, you will be returned a list of the following items:
+
+=over 4
+
+=item success
+
+A simple boolean indicating if the command executed without errors or
+not.
+
+=item error message
+
+If the first element of the return value (success) was 0, then some
+error occurred. This second element is the error message the command
+you requested exited with, if available. This is generally a pretty
+printed value of C<$?> or C<$@>. See C<perldoc perlvar> for details on
+what they can contain.
+If the error was a timeout, the C<error message> will be prefixed with
+the string C<IPC::Cmd::TimeOut>, the timeout class.
+
+=item full_buffer
+
+This is an arrayreference containing all the output the command
+generated.
+Note that buffers are only available if you have C<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> if this is not the case.
+
+=item out_buffer
+
+This is an arrayreference containing all the output sent to STDOUT the
+command generated.
+Note that buffers are only available if you have C<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> if this is not the case.
+
+=item error_buffer
+
+This is an arrayreference containing all the output sent to STDERR the
+command generated.
+Note that buffers are only available if you have C<IPC::Run> installed,
+or if your system is able to work with C<IPC::Open3> -- See below).
+This element will be C<undef> if this is not the case.
+
+=back
+
+See the C<HOW IT WORKS> Section below to see how C<IPC::Cmd> decides
+what modules or function calls to use when issuing a command.
+
+=cut
+
+{ my @acc = qw[ok error _fds];
+
+ ### autogenerate accessors ###
+ for my $key ( @acc ) {
+ no strict 'refs';
+ *{__PACKAGE__."::$key"} = sub {
+ $_[0]->{$key} = $_[1] if @_ > 1;
+ return $_[0]->{$key};
+ }
+ }
+}
+
+sub can_use_run_forked {
+ return $CAN_USE_RUN_FORKED eq "1";
+}
+
+# give process a chance sending TERM,
+# waiting for a while (2 seconds)
+# and killing it with KILL
+sub kill_gently {
+ my ($pid) = @_;
+
+ kill(15, $pid);
+
+ my $wait_cycles = 0;
+ my $child_finished = 0;
+
+ while (!$child_finished && $wait_cycles < 8) {
+ my $waitpid = waitpid($pid, WNOHANG);
+ if ($waitpid eq -1) {
+ $child_finished = 1;
+ }
+
+ $wait_cycles = $wait_cycles + 1;
+ Time::HiRes::usleep(250000); # half a second
+ }
+}
+
+sub open3_run {
+ my ($cmd, $opts) = @_;
+
+ $opts = {} unless $opts;
+
+ my $child_in = FileHandle->new;
+ my $child_out = FileHandle->new;
+ my $child_err = FileHandle->new;
+ $child_out->autoflush(1);
+ $child_err->autoflush(1);
+
+ my $pid = open3($child_in, $child_out, $child_err, $cmd);
+
+ # push my child's pid to our parent
+ # so in case i am killed parent
+ # could stop my child (search for
+ # child_child_pid in parent code)
+ if ($opts->{'parent_info'}) {
+ my $ps = $opts->{'parent_info'};
+ print $ps "spawned $pid\n";
+ }
+
+ if ($child_in && $child_out->opened && $opts->{'child_stdin'}) {
+
+ # If the child process dies for any reason,
+ # the next write to CHLD_IN is likely to generate
+ # a SIGPIPE in the parent, which is fatal by default.
+ # So you may wish to handle this signal.
+ #
+ # from http://perldoc.perl.org/IPC/Open3.html,
+ # absolutely needed to catch piped commands errors.
+ #
+ local $SIG{'SIG_PIPE'} = sub { 1; };
+
+ print $child_in $opts->{'child_stdin'};
+ }
+ close($child_in);
+
+ my $child_output = {
+ 'out' => $child_out->fileno,
+ 'err' => $child_err->fileno,
+ $child_out->fileno => {
+ 'parent_socket' => $opts->{'parent_stdout'},
+ 'scalar_buffer' => "",
+ 'child_handle' => $child_out,
+ 'block_size' => ($child_out->stat)[11] || 1024,
+ },
+ $child_err->fileno => {
+ 'parent_socket' => $opts->{'parent_stderr'},
+ 'scalar_buffer' => "",
+ 'child_handle' => $child_err,
+ 'block_size' => ($child_err->stat)[11] || 1024,
+ },
+ };
+
+ my $select = IO::Select->new();
+ $select->add($child_out, $child_err);
+
+ # pass any signal to the child
+ # effectively creating process
+ # strongly attached to the child:
+ # it will terminate only after child
+ # has terminated (except for SIGKILL,
+ # which is specially handled)
+ foreach my $s (keys %SIG) {
+ my $sig_handler;
+ $sig_handler = sub {
+ kill("$s", $pid);
+ $SIG{$s} = $sig_handler;
+ };
+ $SIG{$s} = $sig_handler;
+ }
+
+ my $child_finished = 0;
+
+ my $got_sig_child = 0;
+ $SIG{'CHLD'} = sub { $got_sig_child = time(); };
+
+ while(!$child_finished && ($child_out->opened || $child_err->opened)) {
+
+ # parent was killed otherwise we would have got
+ # the same signal as parent and process it same way
+ if (getppid() eq "1") {
+ kill_gently($pid);
+ exit;
+ }
+
+ if ($got_sig_child) {
+ if (time() - $got_sig_child > 10) {
+ print STDERR "select->can_read did not return 0 for 10 seconds after SIG_CHLD, killing [$pid]\n";
+ kill (-9, $pid);
+ $child_finished = 1;
+ }
+ }
+
+ Time::HiRes::usleep(1);
+
+ foreach my $fd ($select->can_read(1/100)) {
+ my $str = $child_output->{$fd->fileno};
+ psSnake::die("child stream not found: $fd") unless $str;
+
+ my $data;
+ my $count = $fd->sysread($data, $str->{'block_size'});
+
+ if ($count) {
+ if ($str->{'parent_socket'}) {
+ my $ph = $str->{'parent_socket'};
+ print $ph $data;
+ }
+ else {
+ $str->{'scalar_buffer'} .= $data;
+ }
+ }
+ elsif ($count eq 0) {
+ $select->remove($fd);
+ $fd->close();
+ }
+ else {
+ psSnake::die("error during sysread: " . $!);
+ }
+ }
+ }
+
+ waitpid($pid, 0);
+
+ # i've successfully reaped my child,
+ # let my parent know this
+ if ($opts->{'parent_info'}) {
+ my $ps = $opts->{'parent_info'};
+ print $ps "reaped $pid\n";
+ }
+
+ my $real_exit = $?;
+ my $exit_value = $real_exit >> 8;
+ if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) {
+ return $exit_value;
+ }
+ else {
+ return {
+ 'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'},
+ 'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'},
+ 'exit_code' => $exit_value,
+ };
+ }
+}
+
+=head2 $hashref = run_forked( command => COMMAND, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} );
+
+C<run_forked> is used to execute some program,
+optionally feed it with some input, get its return code
+and output (both stdout and stderr into seperate buffers).
+In addition it allows to terminate the program
+which take too long to finish.
+
+The important and distinguishing feature of run_forked
+is execution timeout which at first seems to be
+quite a simple task but if you think
+that the program which you're spawning
+might spawn some children itself (which
+in their turn could do the same and so on)
+it turns out to be not a simple issue.
+
+C<run_forked> is designed to survive and
+successfully terminate almost any long running task,
+even a fork bomb in case your system has the resources
+to survive during given timeout.
+
+This is achieved by creating separate watchdog process
+which spawns the specified program in a separate
+process session and supervises it: optionally
+feeds it with input, stores its exit code,
+stdout and stderr, terminates it in case
+it runs longer than specified.
+
+Invocation requires the command to be executed and optionally a hashref of options:
+
+=over
+
+=item C<timeout>
+
+Specify in seconds how long the command may run for before it is killed with with SIG_KILL (9)
+which effectively terminates it and all of its children (direct or indirect).
+
+=item C<child_stdin>
+
+Specify some text that will be passed into C<STDIN> of the executed program.
+
+=item C<stdout_handler>
+
+You may provide a coderef of a subroutine that will be called a portion of data is received on
+stdout from the executing program.
+
+=item C<stderr_handler>
+
+You may provide a coderef of a subroutine that will be called a portion of data is received on
+stderr from the executing program.
+
+=back
+
+C<run_forked> will return a HASHREF with the following keys:
+
+=over
+
+=item C<exit_code>
+
+The exit code of the executed program.
+
+=item C<timeout>
+
+The number of seconds the program ran for before being terminated, or 0 if no timeout occurred.
+
+=item C<stdout>
+
+Holds the standard output of the executed command
+(or empty string if there were no stdout output; it's always defined!)
+
+=item C<stderr>
+
+Holds the standard error of the executed command
+(or empty string if there were no stderr output; it's always defined!)
+
+=item C<merged>
+
+Holds the standard output and error of the executed command merged into one stream
+(or empty string if there were no output at all; it's always defined!)
+
+=item C<err_msg>
+
+Holds some explanation in the case of an error.
+
+=back
+
+=cut
+
+sub run_forked {
+ ### container to store things in
+ my $self = bless {}, __PACKAGE__;
+
+ if (!can_use_run_forked()) {
+ Carp::carp("run_forked is not available: $CAN_USE_RUN_FORKED");
+ return;
+ }
+
+ my ($cmd, $opts) = @_;
+
+ if (!$cmd) {
+ Carp::carp("run_forked expects command to run");
+ return;
+ }
+
+ $opts = {} unless $opts;
+ $opts->{'timeout'} = 0 unless $opts->{'timeout'};
+
+ # sockets to pass child stdout to parent
+ my $child_stdout_socket;
+ my $parent_stdout_socket;
+
+ # sockets to pass child stderr to parent
+ my $child_stderr_socket;
+ my $parent_stderr_socket;
+
+ # sockets for child -> parent internal communication
+ my $child_info_socket;
+ my $parent_info_socket;
+
+ socketpair($child_stdout_socket, $parent_stdout_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
+ die ("socketpair: $!");
+ socketpair($child_stderr_socket, $parent_stderr_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
+ die ("socketpair: $!");
+ socketpair($child_info_socket, $parent_info_socket, AF_UNIX, SOCK_STREAM, PF_UNSPEC) ||
+ die ("socketpair: $!");
+
+ $child_stdout_socket->autoflush(1);
+ $parent_stdout_socket->autoflush(1);
+ $child_stderr_socket->autoflush(1);
+ $parent_stderr_socket->autoflush(1);
+ $child_info_socket->autoflush(1);
+ $parent_info_socket->autoflush(1);
+
+ my $start_time = time();
+
+ my $pid;
+ if ($pid = fork) {
+
+ # we are a parent
+ close($parent_stdout_socket);
+ close($parent_stderr_socket);
+ close($parent_info_socket);
+
+ my $child_timedout = 0;
+ my $flags;
+
+ # prepare sockets to read from child
+
+ $flags = 0;
+ fcntl($child_stdout_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
+ $flags |= O_NONBLOCK;
+ fcntl($child_stdout_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
+
+ $flags = 0;
+ fcntl($child_stderr_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
+ $flags |= O_NONBLOCK;
+ fcntl($child_stderr_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
+
+ $flags = 0;
+ fcntl($child_info_socket, F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
+ $flags |= O_NONBLOCK;
+ fcntl($child_info_socket, F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
+
+ # print "child $pid started\n";
+
+ my $child_finished = 0;
+ my $child_stdout = '';
+ my $child_stderr = '';
+ my $child_merged = '';
+ my $child_exit_code = 0;
+
+ my $got_sig_child = 0;
+ $SIG{'CHLD'} = sub { $got_sig_child = time(); };
+
+ my $child_child_pid;
+
+ while (!$child_finished) {
+ # user specified timeout
+ if ($opts->{'timeout'}) {
+ if (time() - $start_time > $opts->{'timeout'}) {
+ kill (-9, $pid);
+ $child_timedout = 1;
+ }
+ }
+
+ # give OS 10 seconds for correct return of waitpid,
+ # kill process after that and finish wait loop;
+ # shouldn't ever happen -- remove this code?
+ if ($got_sig_child) {
+ if (time() - $got_sig_child > 10) {
+ print STDERR "waitpid did not return -1 for 10 seconds after SIG_CHLD, killing [$pid]\n";
+ kill (-9, $pid);
+ $child_finished = 1;
+ }
+ }
+
+ my $waitpid = waitpid($pid, WNOHANG);
+
+ # child finished, catch it's exit status
+ if ($waitpid ne 0 && $waitpid ne -1) {
+ $child_exit_code = $? >> 8;
+ }
+
+ if ($waitpid eq -1) {
+ $child_finished = 1;
+ next;
+ }
+
+ # child -> parent simple internal communication protocol
+ while (my $l = <$child_info_socket>) {
+ if ($l =~ /^spawned ([0-9]+?)\n(.*?)/so) {
+ $child_child_pid = $1;
+ $l = $2;
+ }
+ if ($l =~ /^reaped ([0-9]+?)\n(.*?)/so) {
+ $child_child_pid = undef;
+ $l = $2;
+ }
+ }
+
+ while (my $l = <$child_stdout_socket>) {
+ $child_stdout .= $l;
+ $child_merged .= $l;
+
+ if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') {
+ $opts->{'stdout_handler'}->($l);
+ }
+ }
+ while (my $l = <$child_stderr_socket>) {
+ $child_stderr .= $l;
+ $child_merged .= $l;
+
+ if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') {
+ $opts->{'stderr_handler'}->($l);
+ }
+ }
+
+ Time::HiRes::usleep(1);
+ }
+
+ # $child_pid_pid is not defined in two cases:
+ # * when our child was killed before
+ # it had chance to tell us the pid
+ # of the child it spawned. we can do
+ # nothing in this case :(
+ # * our child successfully reaped its child,
+ # we have nothing left to do in this case
+ #
+ # defined $child_pid_pid means child's child
+ # has not died but nobody is waiting for it,
+ # killing it brutaly.
+ #
+ if ($child_child_pid) {
+ kill_gently($child_child_pid);
+ }
+
+ # print "child $pid finished\n";
+
+ close($child_stdout_socket);
+ close($child_stderr_socket);
+ close($child_info_socket);
+
+ my $o = {
+ 'stdout' => $child_stdout,
+ 'stderr' => $child_stderr,
+ 'merged' => $child_merged,
+ 'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
+ 'exit_code' => $child_exit_code,
+ };
+
+ my $err_msg = '';
+ if ($o->{'exit_code'}) {
+ $err_msg .= "exited with code [$o->{'exit_code'}]\n";
+ }
+ if ($o->{'timeout'}) {
+ $err_msg .= "ran more than [$o->{'timeout'}] seconds\n";
+ }
+ if ($o->{'stdout'}) {
+ $err_msg .= "stdout:\n" . $o->{'stdout'} . "\n";
+ }
+ if ($o->{'stderr'}) {
+ $err_msg .= "stderr:\n" . $o->{'stderr'} . "\n";
+ }
+ $o->{'err_msg'} = $err_msg;
+
+ return $o;
+ }
+ else {
+ die("cannot fork: $!") unless defined($pid);
+
+ # create new process session for open3 call,
+ # so we hopefully can kill all the subprocesses
+ # which might be spawned in it (except for those
+ # which do setsid theirselves -- can't do anything
+ # with those)
+
+ POSIX::setsid() || die("Error running setsid: " . $!);
+
+ close($child_stdout_socket);
+ close($child_stderr_socket);
+ close($child_info_socket);
+
+ my $child_exit_code = open3_run($cmd, {
+ 'parent_info' => $parent_info_socket,
+ 'parent_stdout' => $parent_stdout_socket,
+ 'parent_stderr' => $parent_stderr_socket,
+ 'child_stdin' => $opts->{'child_stdin'},
+ });
+
+ close($parent_stdout_socket);
+ close($parent_stderr_socket);
+ close($parent_info_socket);
+
+ exit $child_exit_code;
+ }
+}
+
+sub run {
+ ### container to store things in
+ my $self = bless {}, __PACKAGE__;
+
+ my %hash = @_;
+
+ ### if the user didn't provide a buffer, we'll store it here.
+ my $def_buf = '';
+
+ my($verbose,$cmd,$buffer,$timeout);
+ my $tmpl = {
+ verbose => { default => $VERBOSE, store => \$verbose },
+ buffer => { default => \$def_buf, store => \$buffer },
+ command => { required => 1, store => \$cmd,
+ allow => sub { !ref($_[0]) or ref($_[0]) eq 'ARRAY' },
+ },
+ timeout => { default => 0, store => \$timeout },
+ };
+
+ unless( check( $tmpl, \%hash, $VERBOSE ) ) {
+ Carp::carp( loc( "Could not validate input: %1",
+ Params::Check->last_error ) );
+ return;
+ };
+
+ $cmd = _quote_args_vms( $cmd ) if IS_VMS;
+
+ ### strip any empty elements from $cmd if present
+ $cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
+
+ my $pp_cmd = (ref $cmd ? "@$cmd" : $cmd);
+ print loc("Running [%1]...\n", $pp_cmd ) if $verbose;
+
+ ### did the user pass us a buffer to fill or not? if so, set this
+ ### flag so we know what is expected of us
+ ### XXX this is now being ignored. in the future, we could add diagnostic
+ ### messages based on this logic
+ #my $user_provided_buffer = $buffer == \$def_buf ? 0 : 1;
+
+ ### buffers that are to be captured
+ my( @buffer, @buff_err, @buff_out );
+
+ ### capture STDOUT
+ my $_out_handler = sub {
+ my $buf = shift;
+ return unless defined $buf;
+
+ print STDOUT $buf if $verbose;
+ push @buffer, $buf;
+ push @buff_out, $buf;
+ };
+
+ ### capture STDERR
+ my $_err_handler = sub {
+ my $buf = shift;
+ return unless defined $buf;
+
+ print STDERR $buf if $verbose;
+ push @buffer, $buf;
+ push @buff_err, $buf;
+ };
+
+
+ ### flag to indicate we have a buffer captured
+ my $have_buffer = $self->can_capture_buffer ? 1 : 0;
+
+ ### flag indicating if the subcall went ok
+ my $ok;
+
+ ### dont look at previous errors:
+ local $?;
+ local $@;
+ local $!;
+
+ ### we might be having a timeout set
+ eval {
+ local $SIG{ALRM} = sub { die bless sub {
+ ALARM_CLASS .
+ qq[: Command '$pp_cmd' aborted by alarm after $timeout seconds]
+ }, ALARM_CLASS } if $timeout;
+ alarm $timeout || 0;
+
+ ### IPC::Run is first choice if $USE_IPC_RUN is set.
+ if( $USE_IPC_RUN and $self->can_use_ipc_run( 1 ) ) {
+ ### ipc::run handlers needs the command as a string or an array ref
+
+ $self->_debug( "# Using IPC::Run. Have buffer: $have_buffer" )
+ if $DEBUG;
+
+ $ok = $self->_ipc_run( $cmd, $_out_handler, $_err_handler );
+
+ ### since IPC::Open3 works on all platforms, and just fails on
+ ### win32 for capturing buffers, do that ideally
+ } elsif ( $USE_IPC_OPEN3 and $self->can_use_ipc_open3( 1 ) ) {
+
+ $self->_debug("# Using IPC::Open3. Have buffer: $have_buffer")
+ if $DEBUG;
+
+ ### in case there are pipes in there;
+ ### IPC::Open3 will call exec and exec will do the right thing
+ $ok = $self->_open3_run(
+ $cmd, $_out_handler, $_err_handler, $verbose
+ );
+
+ ### if we are allowed to run verbose, just dispatch the system command
+ } else {
+ $self->_debug( "# Using system(). Have buffer: $have_buffer" )
+ if $DEBUG;
+ $ok = $self->_system_run( $cmd, $verbose );
+ }
+
+ alarm 0;
+ };
+
+ ### restore STDIN after duping, or STDIN will be closed for
+ ### this current perl process!
+ $self->__reopen_fds( @{ $self->_fds} ) if $self->_fds;
+
+ my $err;
+ unless( $ok ) {
+ ### alarm happened
+ if ( $@ and ref $@ and $@->isa( ALARM_CLASS ) ) {
+ $err = $@->(); # the error code is an expired alarm
+
+ ### another error happened, set by the dispatchub
+ } else {
+ $err = $self->error;
+ }
+ }
+
+ ### fill the buffer;
+ $$buffer = join '', @buffer if @buffer;
+
+ ### return a list of flags and buffers (if available) in list
+ ### context, or just a simple 'ok' in scalar
+ return wantarray
+ ? $have_buffer
+ ? ($ok, $err, \@buffer, \@buff_out, \@buff_err)
+ : ($ok, $err )
+ : $ok
+
+
+}
+
+sub _open3_run {
+ my $self = shift;
+ my $cmd = shift;
+ my $_out_handler = shift;
+ my $_err_handler = shift;
+ my $verbose = shift || 0;
+
+ ### Following code are adapted from Friar 'abstracts' in the
+ ### Perl Monastery (http://www.perlmonks.org/index.pl?node_id=151886).
+ ### XXX that code didn't work.
+ ### we now use the following code, thanks to theorbtwo
+
+ ### define them beforehand, so we always have defined FH's
+ ### to read from.
+ use Symbol;
+ my $kidout = Symbol::gensym();
+ my $kiderror = Symbol::gensym();
+
+ ### Dup the filehandle so we can pass 'our' STDIN to the
+ ### child process. This stops us from having to pump input
+ ### from ourselves to the childprocess. However, we will need
+ ### to revive the FH afterwards, as IPC::Open3 closes it.
+ ### We'll do the same for STDOUT and STDERR. It works without
+ ### duping them on non-unix derivatives, but not on win32.
+ my @fds_to_dup = ( IS_WIN32 && !$verbose
+ ? qw[STDIN STDOUT STDERR]
+ : qw[STDIN]
+ );
+ $self->_fds( \@fds_to_dup );
+ $self->__dup_fds( @fds_to_dup );
+
+ ### pipes have to come in a quoted string, and that clashes with
+ ### whitespace. This sub fixes up such commands so they run properly
+ $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
+
+ ### dont stringify @$cmd, so spaces in filenames/paths are
+ ### treated properly
+ my $pid = eval {
+ IPC::Open3::open3(
+ '<&STDIN',
+ (IS_WIN32 ? '>&STDOUT' : $kidout),
+ (IS_WIN32 ? '>&STDERR' : $kiderror),
+ ( ref $cmd ? @$cmd : $cmd ),
+ );
+ };
+
+ ### open3 error occurred
+ if( $@ and $@ =~ /^open3:/ ) {
+ $self->ok( 0 );
+ $self->error( $@ );
+ return;
+ };
+
+ ### use OUR stdin, not $kidin. Somehow,
+ ### we never get the input.. so jump through
+ ### some hoops to do it :(
+ my $selector = IO::Select->new(
+ (IS_WIN32 ? \*STDERR : $kiderror),
+ \*STDIN,
+ (IS_WIN32 ? \*STDOUT : $kidout)
+ );
+
+ STDOUT->autoflush(1); STDERR->autoflush(1); STDIN->autoflush(1);
+ $kidout->autoflush(1) if UNIVERSAL::can($kidout, 'autoflush');
+ $kiderror->autoflush(1) if UNIVERSAL::can($kiderror, 'autoflush');
+
+ ### add an epxlicit break statement
+ ### code courtesy of theorbtwo from #london.pm
+ my $stdout_done = 0;
+ my $stderr_done = 0;
+ OUTER: while ( my @ready = $selector->can_read ) {
+
+ for my $h ( @ready ) {
+ my $buf;
+
+ ### $len is the amount of bytes read
+ my $len = sysread( $h, $buf, 4096 ); # try to read 4096 bytes
+
+ ### see perldoc -f sysread: it returns undef on error,
+ ### so bail out.
+ if( not defined $len ) {
+ warn(loc("Error reading from process: %1", $!));
+ last OUTER;
+ }
+
+ ### check for $len. it may be 0, at which point we're
+ ### done reading, so don't try to process it.
+ ### if we would print anyway, we'd provide bogus information
+ $_out_handler->( "$buf" ) if $len && $h == $kidout;
+ $_err_handler->( "$buf" ) if $len && $h == $kiderror;
+
+ ### Wait till child process is done printing to both
+ ### stdout and stderr.
+ $stdout_done = 1 if $h == $kidout and $len == 0;
+ $stderr_done = 1 if $h == $kiderror and $len == 0;
+ last OUTER if ($stdout_done && $stderr_done);
+ }
+ }
+
+ waitpid $pid, 0; # wait for it to die
+
+ ### restore STDIN after duping, or STDIN will be closed for
+ ### this current perl process!
+ ### done in the parent call now
+ # $self->__reopen_fds( @fds_to_dup );
+
+ ### some error occurred
+ if( $? ) {
+ $self->error( $self->_pp_child_error( $cmd, $? ) );
+ $self->ok( 0 );
+ return;
+ } else {
+ return $self->ok( 1 );
+ }
+}
+
+### text::parsewords::shellwordss() uses unix semantics. that will break
+### on win32
+{ my $parse_sub = IS_WIN32
+ ? __PACKAGE__->can('_split_like_shell_win32')
+ : Text::ParseWords->can('shellwords');
+
+ sub _ipc_run {
+ my $self = shift;
+ my $cmd = shift;
+ my $_out_handler = shift;
+ my $_err_handler = shift;
+
+ STDOUT->autoflush(1); STDERR->autoflush(1);
+
+ ### a command like:
+ # [
+ # '/usr/bin/gzip',
+ # '-cdf',
+ # '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz',
+ # '|',
+ # '/usr/bin/tar',
+ # '-tf -'
+ # ]
+ ### needs to become:
+ # [
+ # ['/usr/bin/gzip', '-cdf',
+ # '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz']
+ # '|',
+ # ['/usr/bin/tar', '-tf -']
+ # ]
+
+
+ my @command;
+ my $special_chars;
+
+ my $re = do { my $x = join '', SPECIAL_CHARS; qr/([$x])/ };
+ if( ref $cmd ) {
+ my $aref = [];
+ for my $item (@$cmd) {
+ if( $item =~ $re ) {
+ push @command, $aref, $item;
+ $aref = [];
+ $special_chars .= $1;
+ } else {
+ push @$aref, $item;
+ }
+ }
+ push @command, $aref;
+ } else {
+ @command = map { if( $_ =~ $re ) {
+ $special_chars .= $1; $_;
+ } else {
+# [ split /\s+/ ]
+ [ map { m/[ ]/ ? qq{'$_'} : $_ } $parse_sub->($_) ]
+ }
+ } split( /\s*$re\s*/, $cmd );
+ }
+
+ ### if there's a pipe in the command, *STDIN needs to
+ ### be inserted *BEFORE* the pipe, to work on win32
+ ### this also works on *nix, so we should do it when possible
+ ### this should *also* work on multiple pipes in the command
+ ### if there's no pipe in the command, append STDIN to the back
+ ### of the command instead.
+ ### XXX seems IPC::Run works it out for itself if you just
+ ### dont pass STDIN at all.
+ # if( $special_chars and $special_chars =~ /\|/ ) {
+ # ### only add STDIN the first time..
+ # my $i;
+ # @command = map { ($_ eq '|' && not $i++)
+ # ? ( \*STDIN, $_ )
+ # : $_
+ # } @command;
+ # } else {
+ # push @command, \*STDIN;
+ # }
+
+ # \*STDIN is already included in the @command, see a few lines up
+ my $ok = eval { IPC::Run::run( @command,
+ fileno(STDOUT).'>',
+ $_out_handler,
+ fileno(STDERR).'>',
+ $_err_handler
+ )
+ };
+
+ ### all is well
+ if( $ok ) {
+ return $self->ok( $ok );
+
+ ### some error occurred
+ } else {
+ $self->ok( 0 );
+
+ ### if the eval fails due to an exception, deal with it
+ ### unless it's an alarm
+ if( $@ and not UNIVERSAL::isa( $@, ALARM_CLASS ) ) {
+ $self->error( $@ );
+
+ ### if it *is* an alarm, propagate
+ } elsif( $@ ) {
+ die $@;
+
+ ### some error in the sub command
+ } else {
+ $self->error( $self->_pp_child_error( $cmd, $? ) );
+ }
+
+ return;
+ }
+ }
+}
+
+sub _system_run {
+ my $self = shift;
+ my $cmd = shift;
+ my $verbose = shift || 0;
+
+ ### pipes have to come in a quoted string, and that clashes with
+ ### whitespace. This sub fixes up such commands so they run properly
+ $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
+
+ my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR];
+ $self->_fds( \@fds_to_dup );
+ $self->__dup_fds( @fds_to_dup );
+
+ ### system returns 'true' on failure -- the exit code of the cmd
+ $self->ok( 1 );
+ system( ref $cmd ? @$cmd : $cmd ) == 0 or do {
+ $self->error( $self->_pp_child_error( $cmd, $? ) );
+ $self->ok( 0 );
+ };
+
+ ### done in the parent call now
+ #$self->__reopen_fds( @fds_to_dup );
+
+ return unless $self->ok;
+ return $self->ok;
+}
+
+{ my %sc_lookup = map { $_ => $_ } SPECIAL_CHARS;
+
+
+ sub __fix_cmd_whitespace_and_special_chars {
+ my $self = shift;
+ my $cmd = shift;
+
+ ### command has a special char in it
+ if( ref $cmd and grep { $sc_lookup{$_} } @$cmd ) {
+
+ ### since we have special chars, we have to quote white space
+ ### this *may* conflict with the parsing :(
+ my $fixed;
+ my @cmd = map { / / ? do { $fixed++; QUOTE.$_.QUOTE } : $_ } @$cmd;
+
+ $self->_debug( "# Quoted $fixed arguments containing whitespace" )
+ if $DEBUG && $fixed;
+
+ ### stringify it, so the special char isn't escaped as argument
+ ### to the program
+ $cmd = join ' ', @cmd;
+ }
+
+ return $cmd;
+ }
+}
+
+### Command-line arguments (but not the command itself) must be quoted
+### to ensure case preservation. Borrowed from Module::Build with adaptations.
+### Patch for this supplied by Craig Berry, see RT #46288: [PATCH] Add argument
+### quoting for run() on VMS
+sub _quote_args_vms {
+ ### Returns a command string with proper quoting so that the subprocess
+ ### sees this same list of args, or if we get a single arg that is an
+ ### array reference, quote the elements of it (except for the first)
+ ### and return the reference.
+ my @args = @_;
+ my $got_arrayref = (scalar(@args) == 1
+ && UNIVERSAL::isa($args[0], 'ARRAY'))
+ ? 1
+ : 0;
+
+ @args = split(/\s+/, $args[0]) unless $got_arrayref || scalar(@args) > 1;
+
+ my $cmd = $got_arrayref ? shift @{$args[0]} : shift @args;
+
+ ### Do not quote qualifiers that begin with '/' or previously quoted args.
+ map { if (/^[^\/\"]/) {
+ $_ =~ s/\"/""/g; # escape C<"> by doubling
+ $_ = q(").$_.q(");
+ }
+ }
+ ($got_arrayref ? @{$args[0]}
+ : @args
+ );
+
+ $got_arrayref ? unshift(@{$args[0]}, $cmd) : unshift(@args, $cmd);
+
+ return $got_arrayref ? $args[0]
+ : join(' ', @args);
+}
+
+
+### XXX this is cribbed STRAIGHT from M::B 0.30 here:
+### http://search.cpan.org/src/KWILLIAMS/Module-Build-0.30/lib/Module/Build/Platform/Windows.pm:split_like_shell
+### XXX this *should* be integrated into text::parsewords
+sub _split_like_shell_win32 {
+ # As it turns out, Windows command-parsing is very different from
+ # Unix command-parsing. Double-quotes mean different things,
+ # backslashes don't necessarily mean escapes, and so on. So we
+ # can't use Text::ParseWords::shellwords() to break a command string
+ # into words. The algorithm below was bashed out by Randy and Ken
+ # (mostly Randy), and there are a lot of regression tests, so we
+ # should feel free to adjust if desired.
+
+ local $_ = shift;
+
+ my @argv;
+ return @argv unless defined() && length();
+
+ my $arg = '';
+ my( $i, $quote_mode ) = ( 0, 0 );
+
+ while ( $i < length() ) {
+
+ my $ch = substr( $_, $i , 1 );
+ my $next_ch = substr( $_, $i+1, 1 );
+
+ if ( $ch eq '\\' && $next_ch eq '"' ) {
+ $arg .= '"';
+ $i++;
+ } elsif ( $ch eq '\\' && $next_ch eq '\\' ) {
+ $arg .= '\\';
+ $i++;
+ } elsif ( $ch eq '"' && $next_ch eq '"' && $quote_mode ) {
+ $quote_mode = !$quote_mode;
+ $arg .= '"';
+ $i++;
+ } elsif ( $ch eq '"' && $next_ch eq '"' && !$quote_mode &&
+ ( $i + 2 == length() ||
+ substr( $_, $i + 2, 1 ) eq ' ' )
+ ) { # for cases like: a"" => [ 'a' ]
+ push( @argv, $arg );
+ $arg = '';
+ $i += 2;
+ } elsif ( $ch eq '"' ) {
+ $quote_mode = !$quote_mode;
+ } elsif ( $ch eq ' ' && !$quote_mode ) {
+ push( @argv, $arg ) if $arg;
+ $arg = '';
+ ++$i while substr( $_, $i + 1, 1 ) eq ' ';
+ } else {
+ $arg .= $ch;
+ }
+
+ $i++;
+ }
+
+ push( @argv, $arg ) if defined( $arg ) && length( $arg );
+ return @argv;
+}
+
+
+
+{ use File::Spec;
+ use Symbol;
+
+ my %Map = (
+ STDOUT => [qw|>&|, \*STDOUT, Symbol::gensym() ],
+ STDERR => [qw|>&|, \*STDERR, Symbol::gensym() ],
+ STDIN => [qw|<&|, \*STDIN, Symbol::gensym() ],
+ );
+
+ ### dups FDs and stores them in a cache
+ sub __dup_fds {
+ my $self = shift;
+ my @fds = @_;
+
+ __PACKAGE__->_debug( "# Closing the following fds: @fds" ) if $DEBUG;
+
+ for my $name ( @fds ) {
+ my($redir, $fh, $glob) = @{$Map{$name}} or (
+ Carp::carp(loc("No such FD: '%1'", $name)), next );
+
+ ### MUST use the 2-arg version of open for dup'ing for
+ ### 5.6.x compatibilty. 5.8.x can use 3-arg open
+ ### see perldoc5.6.2 -f open for details
+ open $glob, $redir . fileno($fh) or (
+ Carp::carp(loc("Could not dup '$name': %1", $!)),
+ return
+ );
+
+ ### we should re-open this filehandle right now, not
+ ### just dup it
+ ### Use 2-arg version of open, as 5.5.x doesn't support
+ ### 3-arg version =/
+ if( $redir eq '>&' ) {
+ open( $fh, '>' . File::Spec->devnull ) or (
+ Carp::carp(loc("Could not reopen '$name': %1", $!)),
+ return
+ );
+ }
+ }
+
+ return 1;
+ }
+
+ ### reopens FDs from the cache
+ sub __reopen_fds {
+ my $self = shift;
+ my @fds = @_;
+
+ __PACKAGE__->_debug( "# Reopening the following fds: @fds" ) if $DEBUG;
+
+ for my $name ( @fds ) {
+ my($redir, $fh, $glob) = @{$Map{$name}} or (
+ Carp::carp(loc("No such FD: '%1'", $name)), next );
+
+ ### MUST use the 2-arg version of open for dup'ing for
+ ### 5.6.x compatibilty. 5.8.x can use 3-arg open
+ ### see perldoc5.6.2 -f open for details
+ open( $fh, $redir . fileno($glob) ) or (
+ Carp::carp(loc("Could not restore '$name': %1", $!)),
+ return
+ );
+
+ ### close this FD, we're not using it anymore
+ close $glob;
+ }
+ return 1;
+
+ }
+}
+
+sub _debug {
+ my $self = shift;
+ my $msg = shift or return;
+ my $level = shift || 0;
+
+ local $Carp::CarpLevel += $level;
+ Carp::carp($msg);
+
+ return 1;
+}
+
+sub _pp_child_error {
+ my $self = shift;
+ my $cmd = shift or return;
+ my $ce = shift or return;
+ my $pp_cmd = ref $cmd ? "@$cmd" : $cmd;
+
+
+ my $str;
+ if( $ce == -1 ) {
+ ### Include $! in the error message, so that the user can
+ ### see 'No such file or directory' versus 'Permission denied'
+ ### versus 'Cannot fork' or whatever the cause was.
+ $str = "Failed to execute '$pp_cmd': $!";
+
+ } elsif ( $ce & 127 ) {
+ ### some signal
+ $str = loc( "'%1' died with signal %d, %s coredump\n",
+ $pp_cmd, ($ce & 127), ($ce & 128) ? 'with' : 'without');
+
+ } else {
+ ### Otherwise, the command run but gave error status.
+ $str = "'$pp_cmd' exited with value " . ($ce >> 8);
+ }
+
+ $self->_debug( "# Child error '$ce' translated to: $str" ) if $DEBUG;
+
+ return $str;
+}
+
+1;
+
+=head2 $q = QUOTE
+
+Returns the character used for quoting strings on this platform. This is
+usually a C<'> (single quote) on most systems, but some systems use different
+quotes. For example, C<Win32> uses C<"> (double quote).
+
+You can use it as follows:
+
+ use IPC::Cmd qw[run QUOTE];
+ my $cmd = q[echo ] . QUOTE . q[foo bar] . QUOTE;
+
+This makes sure that C<foo bar> is treated as a string, rather than two
+seperate arguments to the C<echo> function.
+
+__END__
+
+=head1 HOW IT WORKS
+
+C<run> will try to execute your command using the following logic:
+
+=over 4
+
+=item *
+
+If you have C<IPC::Run> installed, and the variable C<$IPC::Cmd::USE_IPC_RUN>
+is set to true (See the C<GLOBAL VARIABLES> Section) use that to execute
+the command. You will have the full output available in buffers, interactive commands are sure to work and you are guaranteed to have your verbosity
+settings honored cleanly.
+
+=item *
+
+Otherwise, if the variable C<$IPC::Cmd::USE_IPC_OPEN3> is set to true
+(See the C<GLOBAL VARIABLES> Section), try to execute the command using
+C<IPC::Open3>. Buffers will be available on all platforms except C<Win32>,
+interactive commands will still execute cleanly, and also your verbosity
+settings will be adhered to nicely;
+
+=item *
+
+Otherwise, if you have the verbose argument set to true, we fall back
+to a simple system() call. We cannot capture any buffers, but
+interactive commands will still work.
+
+=item *
+
+Otherwise we will try and temporarily redirect STDERR and STDOUT, do a
+system() call with your command and then re-open STDERR and STDOUT.
+This is the method of last resort and will still allow you to execute
+your commands cleanly. However, no buffers will be available.
+
+=back
+
+=head1 Global Variables
+
+The behaviour of IPC::Cmd can be altered by changing the following
+global variables:
+
+=head2 $IPC::Cmd::VERBOSE
+
+This controls whether IPC::Cmd will print any output from the
+commands to the screen or not. The default is 0;
+
+=head2 $IPC::Cmd::USE_IPC_RUN
+
+This variable controls whether IPC::Cmd will try to use L<IPC::Run>
+when available and suitable. Defaults to true if you are on C<Win32>.
+
+=head2 $IPC::Cmd::USE_IPC_OPEN3
+
+This variable controls whether IPC::Cmd will try to use L<IPC::Open3>
+when available and suitable. Defaults to true.
+
+=head2 $IPC::Cmd::WARN
+
+This variable controls whether run time warnings should be issued, like
+the failure to load an C<IPC::*> module you explicitly requested.
+
+Defaults to true. Turn this off at your own risk.
+
+=head1 Caveats
+
+=over 4
+
+=item Whitespace and IPC::Open3 / system()
+
+When using C<IPC::Open3> or C<system>, if you provide a string as the
+C<command> argument, it is assumed to be appropriately escaped. You can
+use the C<QUOTE> constant to use as a portable quote character (see above).
+However, if you provide and C<Array Reference>, special rules apply:
+
+If your command contains C<Special Characters> (< > | &), it will
+be internally stringified before executing the command, to avoid that these
+special characters are escaped and passed as arguments instead of retaining
+their special meaning.
+
+However, if the command contained arguments that contained whitespace,
+stringifying the command would loose the significance of the whitespace.
+Therefor, C<IPC::Cmd> will quote any arguments containing whitespace in your
+command if the command is passed as an arrayref and contains special characters.
+
+=item Whitespace and IPC::Run
+
+When using C<IPC::Run>, if you provide a string as the C<command> argument,
+the string will be split on whitespace to determine the individual elements
+of your command. Although this will usually just Do What You Mean, it may
+break if you have files or commands with whitespace in them.
+
+If you do not wish this to happen, you should provide an array
+reference, where all parts of your command are already separated out.
+Note however, if there's extra or spurious whitespace in these parts,
+the parser or underlying code may not interpret it correctly, and
+cause an error.
+
+Example:
+The following code
+
+ gzip -cdf foo.tar.gz | tar -xf -
+
+should either be passed as
+
+ "gzip -cdf foo.tar.gz | tar -xf -"
+
+or as
+
+ ['gzip', '-cdf', 'foo.tar.gz', '|', 'tar', '-xf', '-']
+
+But take care not to pass it as, for example
+
+ ['gzip -cdf foo.tar.gz', '|', 'tar -xf -']
+
+Since this will lead to issues as described above.
+
+
+=item IO Redirect
+
+Currently it is too complicated to parse your command for IO
+Redirections. For capturing STDOUT or STDERR there is a work around
+however, since you can just inspect your buffers for the contents.
+
+=item Interleaving STDOUT/STDERR
+
+Neither IPC::Run nor IPC::Open3 can interleave STDOUT and STDERR. For short
+bursts of output from a program, ie this sample:
+
+ for ( 1..4 ) {
+ $_ % 2 ? print STDOUT $_ : print STDERR $_;
+ }
+
+IPC::[Run|Open3] will first read all of STDOUT, then all of STDERR, meaning
+the output looks like 1 line on each, namely '13' on STDOUT and '24' on STDERR.
+
+It should have been 1, 2, 3, 4.
+
+This has been recorded in L<rt.cpan.org> as bug #37532: Unable to interleave
+STDOUT and STDERR
+
+=back
+
+=head1 See Also
+
+C<IPC::Run>, C<IPC::Open3>
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to James Mastros and Martijn van der Streek for their
+help in getting IPC::Open3 to behave nicely.
+
+Thanks to Petya Kohts for the C<run_forked> code.
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-ipc-cmd@rt.cpan.orgE<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Open2.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Open2.pm
new file mode 100755
index 00000000000..4fc016a821a
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Open2.pm
@@ -0,0 +1,121 @@
+package IPC::Open2;
+
+use strict;
+our ($VERSION, @ISA, @EXPORT);
+
+require 5.000;
+require Exporter;
+
+$VERSION = 1.03;
+@ISA = qw(Exporter);
+@EXPORT = qw(open2);
+
+=head1 NAME
+
+IPC::Open2, open2 - open a process for both reading and writing
+
+=head1 SYNOPSIS
+
+ use IPC::Open2;
+
+ $pid = open2(\*CHLD_OUT, \*CHLD_IN, 'some cmd and args');
+ # or without using the shell
+ $pid = open2(\*CHLD_OUT, \*CHLD_IN, 'some', 'cmd', 'and', 'args');
+
+ # or with handle autovivification
+ my($chld_out, $chld_in);
+ $pid = open2($chld_out, $chld_in, 'some cmd and args');
+ # or without using the shell
+ $pid = open2($chld_out, $chld_in, 'some', 'cmd', 'and', 'args');
+
+ waitpid( $pid, 0 );
+ my $child_exit_status = $? >> 8;
+
+=head1 DESCRIPTION
+
+The open2() function runs the given $cmd and connects $chld_out for
+reading and $chld_in for writing. It's what you think should work
+when you try
+
+ $pid = open(HANDLE, "|cmd args|");
+
+The write filehandle will have autoflush turned on.
+
+If $chld_out is a string (that is, a bareword filehandle rather than a glob
+or a reference) and it begins with C<< >& >>, then the child will send output
+directly to that file handle. If $chld_in is a string that begins with
+C<< <& >>, then $chld_in will be closed in the parent, and the child will
+read from it directly. In both cases, there will be a dup(2) instead of a
+pipe(2) made.
+
+If either reader or writer is the null string, this will be replaced
+by an autogenerated filehandle. If so, you must pass a valid lvalue
+in the parameter slot so it can be overwritten in the caller, or
+an exception will be raised.
+
+open2() returns the process ID of the child process. It doesn't return on
+failure: it just raises an exception matching C</^open2:/>. However,
+C<exec> failures in the child are not detected. You'll have to
+trap SIGPIPE yourself.
+
+open2() does not wait for and reap the child process after it exits.
+Except for short programs where it's acceptable to let the operating system
+take care of this, you need to do this yourself. This is normally as
+simple as calling C<waitpid $pid, 0> when you're done with the process.
+Failing to do this can result in an accumulation of defunct or "zombie"
+processes. See L<perlfunc/waitpid> for more information.
+
+This whole affair is quite dangerous, as you may block forever. It
+assumes it's going to talk to something like B<bc>, both writing
+to it and reading from it. This is presumably safe because you
+"know" that commands like B<bc> will read a line at a time and
+output a line at a time. Programs like B<sort> that read their
+entire input stream first, however, are quite apt to cause deadlock.
+
+The big problem with this approach is that if you don't have control
+over source code being run in the child process, you can't control
+what it does with pipe buffering. Thus you can't just open a pipe to
+C<cat -v> and continually read and write a line from it.
+
+The IO::Pty and Expect modules from CPAN can help with this, as they
+provide a real tty (well, a pseudo-tty, actually), which gets you
+back to line buffering in the invoked command again.
+
+=head1 WARNING
+
+The order of arguments differs from that of open3().
+
+=head1 SEE ALSO
+
+See L<IPC::Open3> for an alternative that handles STDERR as well. This
+function is really just a wrapper around open3().
+
+=cut
+
+# &open2: tom christiansen, <tchrist@convex.com>
+#
+# usage: $pid = open2('rdr', 'wtr', 'some cmd and args');
+# or $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
+#
+# spawn the given $cmd and connect $rdr for
+# reading and $wtr for writing. return pid
+# of child, or 0 on failure.
+#
+# WARNING: this is dangerous, as you may block forever
+# unless you are very careful.
+#
+# $wtr is left unbuffered.
+#
+# abort program if
+# rdr or wtr are null
+# a system call fails
+
+require IPC::Open3;
+
+sub open2 {
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+ return IPC::Open3::_open3('open2', scalar caller,
+ $_[1], $_[0], '>&STDERR', @_[2 .. $#_]);
+}
+
+1
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Open3.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Open3.pm
new file mode 100755
index 00000000000..815674b5d4f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Open3.pm
@@ -0,0 +1,376 @@
+package IPC::Open3;
+
+use strict;
+no strict 'refs'; # because users pass me bareword filehandles
+our ($VERSION, @ISA, @EXPORT);
+
+require Exporter;
+
+use Carp;
+use Symbol qw(gensym qualify);
+
+$VERSION = 1.04;
+@ISA = qw(Exporter);
+@EXPORT = qw(open3);
+
+=head1 NAME
+
+IPC::Open3, open3 - open a process for reading, writing, and error handling
+
+=head1 SYNOPSIS
+
+ $pid = open3(\*CHLD_IN, \*CHLD_OUT, \*CHLD_ERR,
+ 'some cmd and args', 'optarg', ...);
+
+ my($wtr, $rdr, $err);
+ use Symbol 'gensym'; $err = gensym;
+ $pid = open3($wtr, $rdr, $err,
+ 'some cmd and args', 'optarg', ...);
+
+ waitpid( $pid, 0 );
+ my $child_exit_status = $? >> 8;
+
+=head1 DESCRIPTION
+
+Extremely similar to open2(), open3() spawns the given $cmd and
+connects CHLD_OUT for reading from the child, CHLD_IN for writing to
+the child, and CHLD_ERR for errors. If CHLD_ERR is false, or the
+same file descriptor as CHLD_OUT, then STDOUT and STDERR of the child
+are on the same filehandle (this means that an autovivified lexical
+cannot be used for the STDERR filehandle, see SYNOPSIS). The CHLD_IN
+will have autoflush turned on.
+
+If CHLD_IN begins with C<< <& >>, then CHLD_IN will be closed in the
+parent, and the child will read from it directly. If CHLD_OUT or
+CHLD_ERR begins with C<< >& >>, then the child will send output
+directly to that filehandle. In both cases, there will be a dup(2)
+instead of a pipe(2) made.
+
+If either reader or writer is the null string, this will be replaced
+by an autogenerated filehandle. If so, you must pass a valid lvalue
+in the parameter slot so it can be overwritten in the caller, or
+an exception will be raised.
+
+The filehandles may also be integers, in which case they are understood
+as file descriptors.
+
+open3() returns the process ID of the child process. It doesn't return on
+failure: it just raises an exception matching C</^open3:/>. However,
+C<exec> failures in the child (such as no such file or permission denied),
+are just reported to CHLD_ERR, as it is not possible to trap them.
+
+If the child process dies for any reason, the next write to CHLD_IN is
+likely to generate a SIGPIPE in the parent, which is fatal by default.
+So you may wish to handle this signal.
+
+Note if you specify C<-> as the command, in an analogous fashion to
+C<open(FOO, "-|")> the child process will just be the forked Perl
+process rather than an external command. This feature isn't yet
+supported on Win32 platforms.
+
+open3() does not wait for and reap the child process after it exits.
+Except for short programs where it's acceptable to let the operating system
+take care of this, you need to do this yourself. This is normally as
+simple as calling C<waitpid $pid, 0> when you're done with the process.
+Failing to do this can result in an accumulation of defunct or "zombie"
+processes. See L<perlfunc/waitpid> for more information.
+
+If you try to read from the child's stdout writer and their stderr
+writer, you'll have problems with blocking, which means you'll want
+to use select() or the IO::Select, which means you'd best use
+sysread() instead of readline() for normal stuff.
+
+This is very dangerous, as you may block forever. It assumes it's
+going to talk to something like B<bc>, both writing to it and reading
+from it. This is presumably safe because you "know" that commands
+like B<bc> will read a line at a time and output a line at a time.
+Programs like B<sort> that read their entire input stream first,
+however, are quite apt to cause deadlock.
+
+The big problem with this approach is that if you don't have control
+over source code being run in the child process, you can't control
+what it does with pipe buffering. Thus you can't just open a pipe to
+C<cat -v> and continually read and write a line from it.
+
+=head1 See Also
+
+=over 4
+
+=item L<IPC::Open2>
+
+Like Open3 but without STDERR catpure.
+
+=item L<IPC::Run>
+
+This is a CPAN module that has better error handling and more facilities
+than Open3.
+
+=back
+
+=head1 WARNING
+
+The order of arguments differs from that of open2().
+
+=cut
+
+# &open3: Marc Horowitz <marc@mit.edu>
+# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
+# fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com>
+# ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career
+# fixed for autovivving FHs, tchrist again
+# allow fd numbers to be used, by Frank Tobin
+# allow '-' as command (c.f. open "-|"), by Adam Spiers <perl@adamspiers.org>
+#
+# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
+#
+# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
+#
+# spawn the given $cmd and connect rdr for
+# reading, wtr for writing, and err for errors.
+# if err is '', or the same as rdr, then stdout and
+# stderr of the child are on the same fh. returns pid
+# of child (or dies on failure).
+
+
+# if wtr begins with '<&', then wtr will be closed in the parent, and
+# the child will read from it directly. if rdr or err begins with
+# '>&', then the child will send output directly to that fd. In both
+# cases, there will be a dup() instead of a pipe() made.
+
+
+# WARNING: this is dangerous, as you may block forever
+# unless you are very careful.
+#
+# $wtr is left unbuffered.
+#
+# abort program if
+# rdr or wtr are null
+# a system call fails
+
+our $Me = 'open3 (bug)'; # you should never see this, it's always localized
+
+# Fatal.pm needs to be fixed WRT prototypes.
+
+sub xfork {
+ my $pid = fork;
+ defined $pid or croak "$Me: fork failed: $!";
+ return $pid;
+}
+
+sub xpipe {
+ pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!";
+}
+
+# I tried using a * prototype character for the filehandle but it still
+# disallows a bearword while compiling under strict subs.
+
+sub xopen {
+ open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!";
+}
+
+sub xclose {
+ close $_[0] or croak "$Me: close($_[0]) failed: $!";
+}
+
+sub fh_is_fd {
+ return $_[0] =~ /\A=?(\d+)\z/;
+}
+
+sub xfileno {
+ return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd
+ return fileno $_[0];
+}
+
+my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
+
+sub _open3 {
+ local $Me = shift;
+ my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
+ my($dup_wtr, $dup_rdr, $dup_err, $kidpid);
+
+ if (@cmd > 1 and $cmd[0] eq '-') {
+ croak "Arguments don't make sense when the command is '-'"
+ }
+
+ # simulate autovivification of filehandles because
+ # it's too ugly to use @_ throughout to make perl do it for us
+ # tchrist 5-Mar-00
+
+ unless (eval {
+ $dad_wtr = $_[1] = gensym unless defined $dad_wtr && length $dad_wtr;
+ $dad_rdr = $_[2] = gensym unless defined $dad_rdr && length $dad_rdr;
+ 1; })
+ {
+ # must strip crud for croak to add back, or looks ugly
+ $@ =~ s/(?<=value attempted) at .*//s;
+ croak "$Me: $@";
+ }
+
+ $dad_err ||= $dad_rdr;
+
+ $dup_wtr = ($dad_wtr =~ s/^[<>]&//);
+ $dup_rdr = ($dad_rdr =~ s/^[<>]&//);
+ $dup_err = ($dad_err =~ s/^[<>]&//);
+
+ # force unqualified filehandles into caller's package
+ $dad_wtr = qualify $dad_wtr, $package unless fh_is_fd($dad_wtr);
+ $dad_rdr = qualify $dad_rdr, $package unless fh_is_fd($dad_rdr);
+ $dad_err = qualify $dad_err, $package unless fh_is_fd($dad_err);
+
+ my $kid_rdr = gensym;
+ my $kid_wtr = gensym;
+ my $kid_err = gensym;
+
+ xpipe $kid_rdr, $dad_wtr if !$dup_wtr;
+ xpipe $dad_rdr, $kid_wtr if !$dup_rdr;
+ xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr;
+
+ $kidpid = $do_spawn ? -1 : xfork;
+ if ($kidpid == 0) { # Kid
+ # A tie in the parent should not be allowed to cause problems.
+ untie *STDIN;
+ untie *STDOUT;
+ # If she wants to dup the kid's stderr onto her stdout I need to
+ # save a copy of her stdout before I put something else there.
+ if ($dad_rdr ne $dad_err && $dup_err
+ && xfileno($dad_err) == fileno(STDOUT)) {
+ my $tmp = gensym;
+ xopen($tmp, ">&$dad_err");
+ $dad_err = $tmp;
+ }
+
+ if ($dup_wtr) {
+ xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr);
+ } else {
+ xclose $dad_wtr;
+ xopen \*STDIN, "<&=" . fileno $kid_rdr;
+ }
+ if ($dup_rdr) {
+ xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr);
+ } else {
+ xclose $dad_rdr;
+ xopen \*STDOUT, ">&=" . fileno $kid_wtr;
+ }
+ if ($dad_rdr ne $dad_err) {
+ if ($dup_err) {
+ # I have to use a fileno here because in this one case
+ # I'm doing a dup but the filehandle might be a reference
+ # (from the special case above).
+ xopen \*STDERR, ">&" . xfileno($dad_err)
+ if fileno(STDERR) != xfileno($dad_err);
+ } else {
+ xclose $dad_err;
+ xopen \*STDERR, ">&=" . fileno $kid_err;
+ }
+ } else {
+ xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
+ }
+ return 0 if ($cmd[0] eq '-');
+ local($")=(" ");
+ exec @cmd or do {
+ carp "$Me: exec of @cmd failed";
+ eval { require POSIX; POSIX::_exit(255); };
+ exit 255;
+ };
+ } elsif ($do_spawn) {
+ # All the bookkeeping of coincidence between handles is
+ # handled in spawn_with_handles.
+
+ my @close;
+ if ($dup_wtr) {
+ $kid_rdr = \*{$dad_wtr};
+ push @close, $kid_rdr;
+ } else {
+ push @close, \*{$dad_wtr}, $kid_rdr;
+ }
+ if ($dup_rdr) {
+ $kid_wtr = \*{$dad_rdr};
+ push @close, $kid_wtr;
+ } else {
+ push @close, \*{$dad_rdr}, $kid_wtr;
+ }
+ if ($dad_rdr ne $dad_err) {
+ if ($dup_err) {
+ $kid_err = \*{$dad_err};
+ push @close, $kid_err;
+ } else {
+ push @close, \*{$dad_err}, $kid_err;
+ }
+ } else {
+ $kid_err = $kid_wtr;
+ }
+ require IO::Pipe;
+ $kidpid = eval {
+ spawn_with_handles( [ { mode => 'r',
+ open_as => $kid_rdr,
+ handle => \*STDIN },
+ { mode => 'w',
+ open_as => $kid_wtr,
+ handle => \*STDOUT },
+ { mode => 'w',
+ open_as => $kid_err,
+ handle => \*STDERR },
+ ], \@close, @cmd);
+ };
+ die "$Me: $@" if $@;
+ }
+
+ xclose $kid_rdr if !$dup_wtr;
+ xclose $kid_wtr if !$dup_rdr;
+ xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err;
+ # If the write handle is a dup give it away entirely, close my copy
+ # of it.
+ xclose $dad_wtr if $dup_wtr;
+
+ select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
+ $kidpid;
+}
+
+sub open3 {
+ if (@_ < 4) {
+ local $" = ', ';
+ croak "open3(@_): not enough arguments";
+ }
+ return _open3 'open3', scalar caller, @_
+}
+
+sub spawn_with_handles {
+ my $fds = shift; # Fields: handle, mode, open_as
+ my $close_in_child = shift;
+ my ($fd, $pid, @saved_fh, $saved, %saved, @errs);
+ require Fcntl;
+
+ foreach $fd (@$fds) {
+ $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
+ $saved{fileno $fd->{handle}} = $fd->{tmp_copy};
+ }
+ foreach $fd (@$fds) {
+ bless $fd->{handle}, 'IO::Handle'
+ unless eval { $fd->{handle}->isa('IO::Handle') } ;
+ # If some of handles to redirect-to coincide with handles to
+ # redirect, we need to use saved variants:
+ $fd->{handle}->fdopen($saved{fileno $fd->{open_as}} || $fd->{open_as},
+ $fd->{mode});
+ }
+ unless ($^O eq 'MSWin32') {
+ # Stderr may be redirected below, so we save the err text:
+ foreach $fd (@$close_in_child) {
+ fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
+ unless $saved{fileno $fd}; # Do not close what we redirect!
+ }
+ }
+
+ unless (@errs) {
+ $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
+ push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0;
+ }
+
+ foreach $fd (@$fds) {
+ $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
+ $fd->{tmp_copy}->close or croak "Can't close: $!";
+ }
+ croak join "\n", @errs if @errs;
+ return $pid;
+}
+
+1; # so require is happy
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Run3.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Run3.pm
new file mode 100755
index 00000000000..008755112a6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Run3.pm
@@ -0,0 +1,850 @@
+package IPC::Run3;
+BEGIN { require 5.006_000; } # i.e. 5.6.0
+use strict;
+
+=head1 NAME
+
+IPC::Run3 - run a subprocess with input/ouput redirection
+
+=head1 VERSION
+
+version 0.043
+
+=cut
+
+our $VERSION = '0.043';
+
+=head1 SYNOPSIS
+
+ use IPC::Run3; # Exports run3() by default
+
+ run3 \@cmd, \$in, \$out, \$err;
+
+=head1 DESCRIPTION
+
+This module allows you to run a subprocess and redirect stdin, stdout,
+and/or stderr to files and perl data structures. It aims to satisfy 99% of the
+need for using C<system>, C<qx>, and C<open3>
+with a simple, extremely Perlish API.
+
+Speed, simplicity, and portability are paramount. (That's speed of Perl code;
+which is often much slower than the kind of buffered I/O that this module uses
+to spool input to and output from the child command.)
+
+=cut
+
+use Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT = qw( run3 );
+our %EXPORT_TAGS = ( all => \@EXPORT );
+
+use constant debugging => $ENV{IPCRUN3DEBUG} || $ENV{IPCRUNDEBUG} || 0;
+use constant profiling => $ENV{IPCRUN3PROFILE} || $ENV{IPCRUNPROFILE} || 0;
+use constant is_win32 => 0 <= index $^O, "Win32";
+
+BEGIN {
+ if ( is_win32 ) {
+ eval "use Win32 qw( GetOSName ); 1" or die $@;
+ }
+}
+
+#use constant is_win2k => is_win32 && GetOSName() =~ /Win2000/i;
+#use constant is_winXP => is_win32 && GetOSName() =~ /WinXP/i;
+
+use Carp qw( croak );
+use File::Temp qw( tempfile );
+use POSIX qw( dup dup2 );
+
+# We cache the handles of our temp files in order to
+# keep from having to incur the (largish) overhead of File::Temp
+my %fh_cache;
+my $fh_cache_pid = $$;
+
+my $profiler;
+
+sub _profiler { $profiler } # test suite access
+
+BEGIN {
+ if ( profiling ) {
+ eval "use Time::HiRes qw( gettimeofday ); 1" or die $@;
+ if ( $ENV{IPCRUN3PROFILE} =~ /\A\d+\z/ ) {
+ require IPC::Run3::ProfPP;
+ IPC::Run3::ProfPP->import;
+ $profiler = IPC::Run3::ProfPP->new(Level => $ENV{IPCRUN3PROFILE});
+ } else {
+ my ( $dest, undef, $class ) =
+ reverse split /(=)/, $ENV{IPCRUN3PROFILE}, 2;
+ $class = "IPC::Run3::ProfLogger"
+ unless defined $class && length $class;
+ if ( not eval "require $class" ) {
+ my $e = $@;
+ $class = "IPC::Run3::$class";
+ eval "require IPC::Run3::$class" or die $e;
+ }
+ $profiler = $class->new( Destination => $dest );
+ }
+ $profiler->app_call( [ $0, @ARGV ], scalar gettimeofday() );
+ }
+}
+
+
+END {
+ $profiler->app_exit( scalar gettimeofday() ) if profiling;
+}
+
+sub _binmode {
+ my ( $fh, $mode, $what ) = @_;
+ # if $mode is not given, then default to ":raw", except on Windows,
+ # where we default to ":crlf";
+ # otherwise if a proper layer string was given, use that,
+ # else use ":raw"
+ my $layer = !$mode
+ ? (is_win32 ? ":crlf" : ":raw")
+ : ($mode =~ /^:/ ? $mode : ":raw");
+ warn "binmode $what, $layer\n" if debugging >= 2;
+
+ binmode $fh, ":raw" unless $layer eq ":raw"; # remove all layers first
+ binmode $fh, $layer or croak "binmode $layer failed: $!";
+}
+
+sub _spool_data_to_child {
+ my ( $type, $source, $binmode_it ) = @_;
+
+ # If undef (not \undef) passed, they want the child to inherit
+ # the parent's STDIN.
+ return undef unless defined $source;
+
+ my $fh;
+ if ( ! $type ) {
+ open $fh, "<", $source or croak "$!: $source";
+ _binmode($fh, $binmode_it, "STDIN");
+ warn "run3(): feeding file '$source' to child STDIN\n"
+ if debugging >= 2;
+ } elsif ( $type eq "FH" ) {
+ $fh = $source;
+ warn "run3(): feeding filehandle '$source' to child STDIN\n"
+ if debugging >= 2;
+ } else {
+ $fh = $fh_cache{in} ||= tempfile;
+ truncate $fh, 0;
+ seek $fh, 0, 0;
+ _binmode($fh, $binmode_it, "STDIN");
+ my $seekit;
+ if ( $type eq "SCALAR" ) {
+
+ # When the run3()'s caller asks to feed an empty file
+ # to the child's stdin, we want to pass a live file
+ # descriptor to an empty file (like /dev/null) so that
+ # they don't get surprised by invalid fd errors and get
+ # normal EOF behaviors.
+ return $fh unless defined $$source; # \undef passed
+
+ warn "run3(): feeding SCALAR to child STDIN",
+ debugging >= 3
+ ? ( ": '", $$source, "' (", length $$source, " chars)" )
+ : (),
+ "\n"
+ if debugging >= 2;
+
+ $seekit = length $$source;
+ print $fh $$source or die "$! writing to temp file";
+
+ } elsif ( $type eq "ARRAY" ) {
+ warn "run3(): feeding ARRAY to child STDIN",
+ debugging >= 3 ? ( ": '", @$source, "'" ) : (),
+ "\n"
+ if debugging >= 2;
+
+ print $fh @$source or die "$! writing to temp file";
+ $seekit = grep length, @$source;
+ } elsif ( $type eq "CODE" ) {
+ warn "run3(): feeding output of CODE ref '$source' to child STDIN\n"
+ if debugging >= 2;
+ my $parms = []; # TODO: get these from $options
+ while (1) {
+ my $data = $source->( @$parms );
+ last unless defined $data;
+ print $fh $data or die "$! writing to temp file";
+ $seekit = length $data;
+ }
+ }
+
+ seek $fh, 0, 0 or croak "$! seeking on temp file for child's stdin"
+ if $seekit;
+ }
+
+ croak "run3() can't redirect $type to child stdin"
+ unless defined $fh;
+
+ return $fh;
+}
+
+sub _fh_for_child_output {
+ my ( $what, $type, $dest, $options ) = @_;
+
+ my $fh;
+ if ( $type eq "SCALAR" && $dest == \undef ) {
+ warn "run3(): redirecting child $what to oblivion\n"
+ if debugging >= 2;
+
+ $fh = $fh_cache{nul} ||= do {
+ open $fh, ">", File::Spec->devnull;
+ $fh;
+ };
+ } elsif ( $type eq "FH" ) {
+ $fh = $dest;
+ warn "run3(): redirecting $what to filehandle '$dest'\n"
+ if debugging >= 3;
+ } elsif ( !$type ) {
+ warn "run3(): feeding child $what to file '$dest'\n"
+ if debugging >= 2;
+
+ open $fh, $options->{"append_$what"} ? ">>" : ">", $dest
+ or croak "$!: $dest";
+ } else {
+ warn "run3(): capturing child $what\n"
+ if debugging >= 2;
+
+ $fh = $fh_cache{$what} ||= tempfile;
+ seek $fh, 0, 0;
+ truncate $fh, 0;
+ }
+
+ my $binmode_it = $options->{"binmode_$what"};
+ _binmode($fh, $binmode_it, uc $what);
+
+ return $fh;
+}
+
+sub _read_child_output_fh {
+ my ( $what, $type, $dest, $fh, $options ) = @_;
+
+ return if $type eq "SCALAR" && $dest == \undef;
+
+ seek $fh, 0, 0 or croak "$! seeking on temp file for child $what";
+
+ if ( $type eq "SCALAR" ) {
+ warn "run3(): reading child $what to SCALAR\n"
+ if debugging >= 3;
+
+ # two read()s are used instead of 1 so that the first will be
+ # logged even it reads 0 bytes; the second won't.
+ my $count = read $fh, $$dest, 10_000,
+ $options->{"append_$what"} ? length $$dest : 0;
+ while (1) {
+ croak "$! reading child $what from temp file"
+ unless defined $count;
+
+ last unless $count;
+
+ warn "run3(): read $count bytes from child $what",
+ debugging >= 3 ? ( ": '", substr( $$dest, -$count ), "'" ) : (),
+ "\n"
+ if debugging >= 2;
+
+ $count = read $fh, $$dest, 10_000, length $$dest;
+ }
+ } elsif ( $type eq "ARRAY" ) {
+ if ($options->{"append_$what"}) {
+ push @$dest, <$fh>;
+ } else {
+ @$dest = <$fh>;
+ }
+ if ( debugging >= 2 ) {
+ my $count = 0;
+ $count += length for @$dest;
+ warn
+ "run3(): read ",
+ scalar @$dest,
+ " records, $count bytes from child $what",
+ debugging >= 3 ? ( ": '", @$dest, "'" ) : (),
+ "\n";
+ }
+ } elsif ( $type eq "CODE" ) {
+ warn "run3(): capturing child $what to CODE ref\n"
+ if debugging >= 3;
+
+ local $_;
+ while ( <$fh> ) {
+ warn
+ "run3(): read ",
+ length,
+ " bytes from child $what",
+ debugging >= 3 ? ( ": '", $_, "'" ) : (),
+ "\n"
+ if debugging >= 2;
+
+ $dest->( $_ );
+ }
+ } else {
+ croak "run3() can't redirect child $what to a $type";
+ }
+
+}
+
+sub _type {
+ my ( $redir ) = @_;
+ return "FH" if eval { $redir->isa("IO::Handle") };
+ my $type = ref $redir;
+ return $type eq "GLOB" ? "FH" : $type;
+}
+
+sub _max_fd {
+ my $fd = dup(0);
+ POSIX::close $fd;
+ return $fd;
+}
+
+my $run_call_time;
+my $sys_call_time;
+my $sys_exit_time;
+
+sub run3 {
+ $run_call_time = gettimeofday() if profiling;
+
+ my $options = @_ && ref $_[-1] eq "HASH" ? pop : {};
+
+ my ( $cmd, $stdin, $stdout, $stderr ) = @_;
+
+ print STDERR "run3(): running ",
+ join( " ", map "'$_'", ref $cmd ? @$cmd : $cmd ),
+ "\n"
+ if debugging;
+
+ if ( ref $cmd ) {
+ croak "run3(): empty command" unless @$cmd;
+ croak "run3(): undefined command" unless defined $cmd->[0];
+ croak "run3(): command name ('')" unless length $cmd->[0];
+ } else {
+ croak "run3(): missing command" unless @_;
+ croak "run3(): undefined command" unless defined $cmd;
+ croak "run3(): command ('')" unless length $cmd;
+ }
+
+ foreach (qw/binmode_stdin binmode_stdout binmode_stderr/) {
+ if (my $mode = $options->{$_}) {
+ croak qq[option $_ must be a number or a proper layer string: "$mode"]
+ unless $mode =~ /^(:|\d+$)/;
+ }
+ }
+
+ my $in_type = _type $stdin;
+ my $out_type = _type $stdout;
+ my $err_type = _type $stderr;
+
+ if ($fh_cache_pid != $$) {
+ # fork detected, close all cached filehandles and clear the cache
+ close $_ foreach values %fh_cache;
+ %fh_cache = ();
+ $fh_cache_pid = $$;
+ }
+
+ # This routine procedes in stages so that a failure in an early
+ # stage prevents later stages from running, and thus from needing
+ # cleanup.
+
+ my $in_fh = _spool_data_to_child $in_type, $stdin,
+ $options->{binmode_stdin} if defined $stdin;
+
+ my $out_fh = _fh_for_child_output "stdout", $out_type, $stdout,
+ $options if defined $stdout;
+
+ my $tie_err_to_out =
+ defined $stderr && defined $stdout && $stderr eq $stdout;
+
+ my $err_fh = $tie_err_to_out
+ ? $out_fh
+ : _fh_for_child_output "stderr", $err_type, $stderr,
+ $options if defined $stderr;
+
+ # this should make perl close these on exceptions
+# local *STDIN_SAVE;
+ local *STDOUT_SAVE;
+ local *STDERR_SAVE;
+
+ my $saved_fd0 = dup( 0 ) if defined $in_fh;
+
+# open STDIN_SAVE, "<&STDIN"# or croak "run3(): $! saving STDIN"
+# if defined $in_fh;
+ open STDOUT_SAVE, ">&STDOUT" or croak "run3(): $! saving STDOUT"
+ if defined $out_fh;
+ open STDERR_SAVE, ">&STDERR" or croak "run3(): $! saving STDERR"
+ if defined $err_fh;
+
+ my $errno;
+ my $ok = eval {
+ # The open() call here seems to not force fd 0 in some cases;
+ # I ran in to trouble when using this in VCP, not sure why.
+ # the dup2() seems to work.
+ dup2( fileno $in_fh, 0 )
+# open STDIN, "<&=" . fileno $in_fh
+ or croak "run3(): $! redirecting STDIN"
+ if defined $in_fh;
+
+# close $in_fh or croak "$! closing STDIN temp file"
+# if ref $stdin;
+
+ open STDOUT, ">&" . fileno $out_fh
+ or croak "run3(): $! redirecting STDOUT"
+ if defined $out_fh;
+
+ open STDERR, ">&" . fileno $err_fh
+ or croak "run3(): $! redirecting STDERR"
+ if defined $err_fh;
+
+ $sys_call_time = gettimeofday() if profiling;
+
+ my $r = ref $cmd
+ ? system { $cmd->[0] }
+ is_win32
+ ? map {
+ # Probably need to offer a win32 escaping
+ # option, every command may be different.
+ ( my $s = $_ ) =~ s/"/"""/g;
+ $s = qq{"$s"};
+ $s;
+ } @$cmd
+ : @$cmd
+ : system $cmd;
+
+ $errno = $!; # save $!, because later failures will overwrite it
+ $sys_exit_time = gettimeofday() if profiling;
+ if ( debugging ) {
+ my $err_fh = defined $err_fh ? \*STDERR_SAVE : \*STDERR;
+ if ( defined $r && $r != -1 ) {
+ print $err_fh "run3(): \$? is $?\n";
+ } else {
+ print $err_fh "run3(): \$? is $?, \$! is $errno\n";
+ }
+ }
+
+ die $! if defined $r && $r == -1 && !$options->{return_if_system_error};
+
+ 1;
+ };
+ my $x = $@;
+
+ my @errs;
+
+ if ( defined $saved_fd0 ) {
+ dup2( $saved_fd0, 0 );
+ POSIX::close( $saved_fd0 );
+ }
+
+# open STDIN, "<&STDIN_SAVE"# or push @errs, "run3(): $! restoring STDIN"
+# if defined $in_fh;
+ open STDOUT, ">&STDOUT_SAVE" or push @errs, "run3(): $! restoring STDOUT"
+ if defined $out_fh;
+ open STDERR, ">&STDERR_SAVE" or push @errs, "run3(): $! restoring STDERR"
+ if defined $err_fh;
+
+ croak join ", ", @errs if @errs;
+
+ die $x unless $ok;
+
+ _read_child_output_fh "stdout", $out_type, $stdout, $out_fh, $options
+ if defined $out_fh && $out_type && $out_type ne "FH";
+ _read_child_output_fh "stderr", $err_type, $stderr, $err_fh, $options
+ if defined $err_fh && $err_type && $err_type ne "FH" && !$tie_err_to_out;
+ $profiler->run_exit(
+ $cmd,
+ $run_call_time,
+ $sys_call_time,
+ $sys_exit_time,
+ scalar gettimeofday()
+ ) if profiling;
+
+ $! = $errno; # restore $! from system()
+
+ return 1;
+}
+
+1;
+
+__END__
+
+=head2 C<< run3($cmd, $stdin, $stdout, $stderr, \%options) >>
+
+All parameters after C<$cmd> are optional.
+
+The parameters C<$stdin>, C<$stdout> and C<$stderr> indicate
+how the child's corresponding filehandle
+(C<STDIN>, C<STDOUT> and C<STDERR>, resp.) will be redirected.
+Because the redirects come last, this allows C<STDOUT> and C<STDERR> to default
+to the parent's by just not specifying them -- a common use case.
+
+C<run3> throws an exception if the wrapped C<system> call returned -1
+or anything went wrong with C<run3>'s processing of filehandles.
+Otherwise it returns true.
+It leaves C<$?> intact for inspection of exit and wait status.
+
+Note that a true return value from C<run3> doesn't mean that the command
+had a successful exit code. Hence you should always check C<$?>.
+
+See L</%options> for an option to handle the case of C<system>
+returning -1 yourself.
+
+=head3 C<$cmd>
+
+Usually C<$cmd> will be an ARRAY reference and the child is invoked via
+
+ system @$cmd;
+
+But C<$cmd> may also be a string in which case the child is invoked via
+
+ system $cmd;
+
+(cf. L<perlfunc/system> for the difference and the pitfalls of using
+the latter form).
+
+=head3 C<$stdin>, C<$stdout>, C<$stderr>
+
+The parameters C<$stdin>, C<$stdout> and C<$stderr>
+can take one of the following forms:
+
+=over 4
+
+=item C<undef> (or not specified at all)
+
+The child inherits the corresponding filehandle from the parent.
+
+ run3 \@cmd, $stdin; # child writes to same STDOUT and STDERR as parent
+ run3 \@cmd, undef, $stdout, $stderr; # child reads from same STDIN as parent
+
+=item C<\undef>
+
+The child's filehandle is redirected from or to the
+local equivalent of C</dev/null> (as returned by
+C<< File::Spec->devnull() >>).
+
+ run3 \@cmd, \undef, $stdout, $stderr; # child reads from /dev/null
+
+=item a simple scalar
+
+The parameter is taken to be the name of a file to read from
+or write to. In the latter case, the file will be opened via
+
+ open FH, ">", ...
+
+i.e. it is created if it doesn't exist and truncated otherwise.
+Note that the file is opened by the parent which will L<croak|Carp/croak>
+in case of failure.
+
+ run3 \@cmd, \undef, "out.txt"; # child writes to file "out.txt"
+
+=item a filehandle (either a reference to a GLOB or an C<IO::Handle>)
+
+The filehandle is inherited by the child.
+
+ open my $fh, ">", "out.txt";
+ print $fh "prologue\n";
+ ...
+ run3 \@cmd, \undef, $fh; # child writes to $fh
+ ...
+ print $fh "epilogue\n";
+ close $fh;
+
+=item a SCALAR reference
+
+The referenced scalar is treated as a string to be read from or
+written to. In the latter case, the previous content of the string
+is overwritten.
+
+ my $out;
+ run3 \@cmd, \undef, \$out; # child writes into string
+ run3 \@cmd, \<<EOF; # child reads from string (can use "here" notation)
+ Input
+ to
+ child
+ EOF
+
+=item an ARRAY reference
+
+For C<$stdin>, the elements of C<@$stdin> are simply spooled to the child.
+
+For C<$stdout> or C<$stderr>, the child's corresponding file descriptor
+is read line by line (as determined by the current setting of C<$/>)
+into C<@$stdout> or C<@$stderr>, resp. The previous content of the array
+is overwritten.
+
+ my @lines;
+ run3 \@cmd, \undef, \@lines; # child writes into array
+
+=item a CODE reference
+
+For C<$stdin>, C<&$stdin> will be called repeatedly (with no arguments) and
+the return values are spooled to the child. C<&$stdin> must signal the end of
+input by returning C<undef>.
+
+For C<$stdout> or C<$stderr>, the child's corresponding file descriptor
+is read line by line (as determined by the current setting of C<$/>)
+and C<&$stdout> or C<&$stderr>, resp., is called with the contents of the line.
+Note that there's no end-of-file indication.
+
+ my $i = 0;
+ sub producer {
+ return $i < 10 ? "line".$i++."\n" : undef;
+ }
+
+ run3 \@cmd, \&producer; # child reads 10 lines
+
+Note that this form of redirecting the child's I/O doesn't imply
+any form of concurrency between parent and child - run3()'s method of
+operation is the same no matter which form of redirection you specify.
+
+=back
+
+If the same value is passed for C<$stdout> and C<$stderr>, then the child
+will write both C<STDOUT> and C<STDERR> to the same filehandle.
+In general, this means that
+
+ run3 \@cmd, \undef, "foo.txt", "foo.txt";
+ run3 \@cmd, \undef, \$both, \$both;
+
+will DWIM and pass a single file handle to the child for both C<STDOUT> and
+C<STDERR>, collecting all into file "foo.txt" or C<$both>.
+
+=head3 C<\%options>
+
+The last parameter, C<\%options>, must be a hash reference if present.
+
+Currently the following
+keys are supported:
+
+=over 4
+
+=item C<binmode_stdin>, C<binmode_stdout>, C<binmode_stderr>
+
+The value must a "layer" as described in L<perlfunc/binmode>.
+If specified the corresponding
+parameter C<$stdin>, C<$stdout> or C<$stderr>, resp., operates
+with the given layer.
+
+For backward compatibility, a true value that doesn't start with ":"
+(e.g. a number) is interpreted as ":raw". If the value is false
+or not specified, the default is ":crlf" on Windows and ":raw" otherwise.
+
+Don't expect that values other than the built-in layers ":raw", ":crlf",
+and (on newer Perls) ":bytes", ":utf8", ":encoding(...)" will work.
+
+=item C<append_stdout>, C<append_stderr>
+
+If their value is true then the corresponding
+parameter C<$stdout> or C<$stderr>, resp., will append the child's output
+to the existing "contents" of the redirector. This only makes
+sense if the redirector is a simple scalar (the corresponding file
+is opened in append mode), a SCALAR reference (the output is
+appended to the previous contents of the string)
+or an ARRAY reference (the output is C<push>ed onto the
+previous contents of the array).
+
+=item C<return_if_system_error>
+
+If this is true C<run3> does B<not> throw an exception if C<system>
+returns -1 (cf. L<perlfunc/system> for possible
+failure scenarios.), but returns true instead.
+In this case C<$?> has the value -1 and C<$!>
+contains the errno of the failing C<system> call.
+
+=back
+
+=head1 HOW IT WORKS
+
+=over 4
+
+=item (1)
+
+For each redirector C<$stdin>, C<$stdout>, and C<$stderr>,
+C<run3()> furnishes a filehandle:
+
+=over 4
+
+=item *
+
+if the redirector already specifies a filehandle it just uses that
+
+=item *
+
+if the redirector specifies a filename, C<run3()> opens the file
+in the appropriate mode
+
+=item *
+
+in all other cases, C<run3()> opens a temporary file
+(using L<tempfile|Temp/tempfile>)
+
+=back
+
+=item (2)
+
+If C<run3()> opened a temporary file for C<$stdin> in step (1),
+it writes the data using the specified method (either
+from a string, an array or returnd by a function) to the temporary file and rewinds it.
+
+=item (3)
+
+C<run3()> saves the parent's C<STDIN>, C<STDOUT> and C<STDERR> by duplicating
+them to new filehandles. It duplicates the filehandles from step (1)
+to C<STDIN>, C<STDOUT> and C<STDERR>, resp.
+
+=item (4)
+
+C<run3()> runs the child by invoking L<system|perlfunc/system>
+with C<$cmd> as specified above.
+
+=item (5)
+
+C<run3()> restores the parent's C<STDIN>, C<STDOUT> and C<STDERR> saved in step (3).
+
+=item (6)
+
+If C<run3()> opened a temporary file for C<$stdout> or C<$stderr> in step (1),
+it rewinds it and reads back its contents using the specified method
+(either to a string, an array or by calling a function).
+
+=item (7)
+
+C<run3()> closes all filehandles that it opened explicitly in step (1).
+
+=back
+
+Note that when using temporary files, C<run3()> tries to amortize the overhead
+by reusing them (i.e. it keeps them open and rewinds and truncates them
+before the next operation).
+
+=head1 LIMITATIONS
+
+Often uses intermediate files (determined by File::Temp, and thus by the
+File::Spec defaults and the TMPDIR env. variable) for speed, portability and
+simplicity.
+
+Use extrem caution when using C<run3> in a threaded environment if
+concurrent calls of C<run3> are possible. Most likely, I/O from different
+invocations will get mixed up. The reason is that in most thread
+implementations all threads in a process share the same STDIN/STDOUT/STDERR.
+Known failures are Perl ithreads on Linux and Win32. Note that C<fork>
+on Win32 is emulated via Win32 threads and hence I/O mix up is possible
+between forked children here (C<run3> is "fork safe" on Unix, though).
+
+=head1 DEBUGGING
+
+To enable debugging use the IPCRUN3DEBUG environment variable to
+a non-zero integer value:
+
+ $ IPCRUN3DEBUG=1 myapp
+
+=head1 PROFILING
+
+To enable profiling, set IPCRUN3PROFILE to a number to enable emitting profile
+information to STDERR (1 to get timestamps, 2 to get a summary report at the
+END of the program, 3 to get mini reports after each run) or to a filename to
+emit raw data to a file for later analysis.
+
+=head1 COMPARISON
+
+Here's how it stacks up to existing APIs:
+
+=head2 compared to C<system()>, C<qx''>, C<open "...|">, C<open "|...">
+
+=over
+
+=item +
+
+redirects more than one file descriptor
+
+=item +
+
+returns TRUE on success, FALSE on failure
+
+=item +
+
+throws an error if problems occur in the parent process (or the pre-exec child)
+
+=item +
+
+allows a very perlish interface to Perl data structures and subroutines
+
+=item +
+
+allows 1 word invocations to avoid the shell easily:
+
+ run3 ["foo"]; # does not invoke shell
+
+=item -
+
+does not return the exit code, leaves it in $?
+
+=back
+
+=head2 compared to C<open2()>, C<open3()>
+
+=over
+
+=item +
+
+no lengthy, error prone polling/select loop needed
+
+=item +
+
+hides OS dependancies
+
+=item +
+
+allows SCALAR, ARRAY, and CODE references to source and sink I/O
+
+=item +
+
+I/O parameter order is like C<open3()> (not like C<open2()>).
+
+=item -
+
+does not allow interaction with the subprocess
+
+=back
+
+=head2 compared to L<IPC::Run::run()|IPC::Run/run>
+
+=over
+
+=item +
+
+smaller, lower overhead, simpler, more portable
+
+=item +
+
+no select() loop portability issues
+
+=item +
+
+does not fall prey to Perl closure leaks
+
+=item -
+
+does not allow interaction with the subprocess (which
+IPC::Run::run() allows by redirecting subroutines)
+
+=item -
+
+lacks many features of C<IPC::Run::run()> (filters, pipes,
+redirects, pty support)
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>C<barries@slaysys.com>E<gt>
+
+Ricardo SIGNES E<lt>C<rjbs@cpan.org>E<gt> performed some routine maintenance in
+2005, thanks to help from the following ticket and/or patch submitters: Jody
+Belka, Roderich Schupp, David Morel, and anonymous others.
+
+=cut
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfArrayBuffer.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfArrayBuffer.pm
new file mode 100755
index 00000000000..15c58ea0b20
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfArrayBuffer.pm
@@ -0,0 +1,86 @@
+package IPC::Run3::ProfArrayBuffer;
+
+$VERSION = 0.043;
+
+=head1 NAME
+
+IPC::Run3::ProfArrayBuffer - Store profile events in RAM in an array
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=cut
+
+use strict;
+
+=head1 METHODS
+
+=over
+
+=item C<< IPC::Run3::ProfArrayBuffer->new() >>
+
+=cut
+
+sub new {
+ my $class = ref $_[0] ? ref shift : shift;
+
+ my $self = bless { @_ }, $class;
+
+ $self->{Events} = [];
+
+ return $self;
+}
+
+=item C<< $buffer->app_call(@events) >>
+
+=item C<< $buffer->app_exit(@events) >>
+
+=item C<< $buffer->run_exit(@events) >>
+
+The three above methods push the given events onto the stack of recorded
+events.
+
+=cut
+
+for my $subname ( qw(app_call app_exit run_exit) ) {
+ no strict 'refs';
+ *{$subname} = sub {
+ push @{shift->{Events}}, [ $subname => @_ ];
+ };
+}
+
+=item get_events
+
+Returns a list of all the events. Each event is an ARRAY reference
+like:
+
+ [ "app_call", 1.1, ... ];
+
+=cut
+
+sub get_events {
+ my $self = shift;
+ @{$self->{Events}};
+}
+
+=back
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogReader.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogReader.pm
new file mode 100755
index 00000000000..987b3a24f50
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogReader.pm
@@ -0,0 +1,157 @@
+package IPC::Run3::ProfLogReader;
+
+$VERSION = 0.043;
+
+=head1 NAME
+
+IPC::Run3::ProfLogReader - read and process a ProfLogger file
+
+=head1 SYNOPSIS
+
+ use IPC::Run3::ProfLogReader;
+
+ my $reader = IPC::Run3::ProfLogReader->new; ## use "run3.out"
+ my $reader = IPC::Run3::ProfLogReader->new( Source => $fn );
+
+ my $profiler = IPC::Run3::ProfPP; ## For example
+ my $reader = IPC::Run3::ProfLogReader->new( ..., Handler => $p );
+
+ $reader->read;
+ $eaderr->read_all;
+
+=head1 DESCRIPTION
+
+Reads a log file. Use the filename "-" to read from STDIN.
+
+=cut
+
+use strict;
+
+=head1 METHODS
+
+=head2 C<< IPC::Run3::ProfLogReader->new( ... ) >>
+
+=cut
+
+sub new {
+ my $class = ref $_[0] ? ref shift : shift;
+ my $self = bless { @_ }, $class;
+
+ $self->{Source} = "run3.out"
+ unless defined $self->{Source} && length $self->{Source};
+
+ my $source = $self->{Source};
+
+ if ( ref $source eq "GLOB" || UNIVERSAL::isa( $source, "IO::Handle" ) ) {
+ $self->{FH} = $source;
+ }
+ elsif ( $source eq "-" ) {
+ $self->{FH} = \*STDIN;
+ }
+ else {
+ open PROFILE, "<$self->{Source}" or die "$!: $self->{Source}\n";
+ $self->{FH} = *PROFILE{IO};
+ }
+ return $self;
+}
+
+
+=head2 C<< $reader->set_handler( $handler ) >>
+
+=cut
+
+sub set_handler { $_[0]->{Handler} = $_[1] }
+
+=head2 C<< $reader->get_handler() >>
+
+=cut
+
+sub get_handler { $_[0]->{Handler} }
+
+=head2 C<< $reader->read() >>
+
+=cut
+
+sub read {
+ my $self = shift;
+
+ my $fh = $self->{FH};
+ my @ln = split / /, <$fh>;
+
+ return 0 unless @ln;
+ return 1 unless $self->{Handler};
+
+ chomp $ln[-1];
+
+ ## Ignore blank and comment lines.
+ return 1 if @ln == 1 && ! length $ln[0] || 0 == index $ln[0], "#";
+
+ if ( $ln[0] eq "\\app_call" ) {
+ shift @ln;
+ my @times = split /,/, pop @ln;
+ $self->{Handler}->app_call(
+ [
+ map {
+ s/\\\\/\\/g;
+ s/\\_/ /g;
+ $_;
+ } @ln
+ ],
+ @times
+ );
+ }
+ elsif ( $ln[0] eq "\\app_exit" ) {
+ shift @ln;
+ $self->{Handler}->app_exit( pop @ln, @ln );
+ }
+ else {
+ my @times = split /,/, pop @ln;
+ $self->{Handler}->run_exit(
+ [
+ map {
+ s/\\\\/\\/g;
+ s/\\_/ /g;
+ $_;
+ } @ln
+ ],
+ @times
+ );
+ }
+
+ return 1;
+}
+
+
+=head2 C<< $reader->read_all() >>
+
+This method reads until there is nothing left to read, and then returns true.
+
+=cut
+
+sub read_all {
+ my $self = shift;
+
+ 1 while $self->read;
+
+ return 1;
+}
+
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+ Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogger.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogger.pm
new file mode 100755
index 00000000000..8bbc06a61b6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfLogger.pm
@@ -0,0 +1,139 @@
+package IPC::Run3::ProfLogger;
+
+$VERSION = 0.043;
+
+=head1 NAME
+
+IPC::Run3::ProfLogger - write profiling data to a log file
+
+=head1 SYNOPSIS
+
+ use IPC::Run3::ProfLogger;
+
+ my $logger = IPC::Run3::ProfLogger->new; ## write to "run3.out"
+ my $logger = IPC::Run3::ProfLogger->new( Destination => $fn );
+
+ $logger->app_call( \@cmd, $time );
+
+ $logger->run_exit( \@cmd1, @times1 );
+ $logger->run_exit( \@cmd1, @times1 );
+
+ $logger->app_exit( $time );
+
+=head1 DESCRIPTION
+
+Used by IPC::Run3 to write a profiling log file. Does not
+generate reports or maintain statistics; its meant to have minimal
+overhead.
+
+Its API is compatible with a tiny subset of the other IPC::Run profiling
+classes.
+
+=cut
+
+use strict;
+
+=head1 METHODS
+
+=head2 C<< IPC::Run3::ProfLogger->new( ... ) >>
+
+=cut
+
+sub new {
+ my $class = ref $_[0] ? ref shift : shift;
+ my $self = bless { @_ }, $class;
+
+ $self->{Destination} = "run3.out"
+ unless defined $self->{Destination} && length $self->{Destination};
+
+ open PROFILE, ">$self->{Destination}"
+ or die "$!: $self->{Destination}\n";
+ binmode PROFILE;
+ $self->{FH} = *PROFILE{IO};
+
+ $self->{times} = [];
+ return $self;
+}
+
+=head2 C<< $logger->run_exit( ... ) >>
+
+=cut
+
+sub run_exit {
+ my $self = shift;
+ my $fh = $self->{FH};
+ print( $fh
+ join(
+ " ",
+ (
+ map {
+ my $s = $_;
+ $s =~ s/\\/\\\\/g;
+ $s =~ s/ /_/g;
+ $s;
+ } @{shift()}
+ ),
+ join(
+ ",",
+ @{$self->{times}},
+ @_,
+ ),
+ ),
+ "\n"
+ );
+}
+
+=head2 C<< $logger->app_exit( $arg ) >>
+
+=cut
+
+sub app_exit {
+ my $self = shift;
+ my $fh = $self->{FH};
+ print $fh "\\app_exit ", shift, "\n";
+}
+
+=head2 C<< $logger->app_call( $t, @args) >>
+
+=cut
+
+sub app_call {
+ my $self = shift;
+ my $fh = $self->{FH};
+ my $t = shift;
+ print( $fh
+ join(
+ " ",
+ "\\app_call",
+ (
+ map {
+ my $s = $_;
+ $s =~ s/\\\\/\\/g;
+ $s =~ s/ /\\_/g;
+ $s;
+ } @_
+ ),
+ $t,
+ ),
+ "\n"
+ );
+}
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfPP.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfPP.pm
new file mode 100755
index 00000000000..112c3a2e8d6
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfPP.pm
@@ -0,0 +1,156 @@
+package IPC::Run3::ProfPP;
+
+$VERSION = 0.043;
+
+=head1 NAME
+
+IPC::Run3::ProfPP - Generate reports from IPC::Run3 profiling data
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+Used by IPC::Run3 and/or run3profpp to print out profiling reports for
+human readers. Use other classes for extracting data in other ways.
+
+The output methods are plain text, override these (see the source for
+now) to provide other formats.
+
+This class generates reports on each run3_exit() and app_exit() call.
+
+=cut
+
+require IPC::Run3::ProfReporter;
+@ISA = qw( IPC::Run3::ProfReporter );
+
+use strict;
+use POSIX qw( floor );
+
+=head1 METHODS
+
+=head2 C<< IPC::Run3::ProfPP->new() >>
+
+Returns a new profile reporting object.
+
+=cut
+
+sub _emit { shift; warn @_ }
+
+sub _t {
+ sprintf "%10.6f secs", @_;
+}
+
+sub _r {
+ my ( $num, $denom ) = @_;
+ return () unless $denom;
+ sprintf "%10.6f", $num / $denom;
+}
+
+sub _pct {
+ my ( $num, $denom ) = @_;
+ return () unless $denom;
+ sprintf " (%3d%%)", floor( 100 * $num / $denom + 0.5 );
+}
+
+=head2 C<< $profpp->handle_app_call() >>
+
+=cut
+
+sub handle_app_call {
+ my $self = shift;
+ $self->_emit("IPC::Run3 parent: ",
+ join( " ", @{$self->get_app_cmd} ),
+ "\n",
+ );
+
+ $self->{NeedNL} = 1;
+}
+
+=head2 C<< $profpp->handle_app_exit() >>
+
+=cut
+
+sub handle_app_exit {
+ my $self = shift;
+
+ $self->_emit("\n") if $self->{NeedNL} && $self->{NeedNL} != 1;
+
+ $self->_emit( "IPC::Run3 total elapsed: ",
+ _t( $self->get_app_cumulative_time ),
+ "\n");
+ $self->_emit( "IPC::Run3 calls to run3(): ",
+ sprintf( "%10d", $self->get_run_count ),
+ "\n");
+ $self->_emit( "IPC::Run3 total spent in run3(): ",
+ _t( $self->get_run_cumulative_time ),
+ _pct( $self->get_run_cumulative_time, $self->get_app_cumulative_time ),
+ ", ",
+ _r( $self->get_run_cumulative_time, $self->get_run_count ),
+ " per call",
+ "\n");
+ my $exclusive =
+ $self->get_app_cumulative_time - $self->get_run_cumulative_time;
+ $self->_emit( "IPC::Run3 total spent not in run3(): ",
+ _t( $exclusive ),
+ _pct( $exclusive, $self->get_app_cumulative_time ),
+ "\n");
+ $self->_emit( "IPC::Run3 total spent in children: ",
+ _t( $self->get_sys_cumulative_time ),
+ _pct( $self->get_sys_cumulative_time, $self->get_app_cumulative_time ),
+ ", ",
+ _r( $self->get_sys_cumulative_time, $self->get_run_count ),
+ " per call",
+ "\n");
+ my $overhead =
+ $self->get_run_cumulative_time - $self->get_sys_cumulative_time;
+ $self->_emit( "IPC::Run3 total overhead: ",
+ _t( $overhead ),
+ _pct(
+ $overhead,
+ $self->get_sys_cumulative_time
+ ),
+ ", ",
+ _r( $overhead, $self->get_run_count ),
+ " per call",
+ "\n");
+}
+
+=head2 C<< $profpp->handle_run_exit() >>
+
+=cut
+
+sub handle_run_exit {
+ my $self = shift;
+ my $overhead = $self->get_run_time - $self->get_sys_time;
+
+ $self->_emit("\n") if $self->{NeedNL} && $self->{NeedNL} != 2;
+ $self->{NeedNL} = 3;
+
+ $self->_emit( "IPC::Run3 child: ",
+ join( " ", @{$self->get_run_cmd} ),
+ "\n");
+ $self->_emit( "IPC::Run3 run3() : ", _t( $self->get_run_time ), "\n",
+ "IPC::Run3 child : ", _t( $self->get_sys_time ), "\n",
+ "IPC::Run3 overhead: ", _t( $overhead ),
+ _pct( $overhead, $self->get_sys_time ),
+ "\n");
+}
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+ Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker E<lt>barries@slaysys.comE<gt>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfReporter.pm b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfReporter.pm
new file mode 100755
index 00000000000..2fa9060e1e4
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/Run3/ProfReporter.pm
@@ -0,0 +1,256 @@
+package IPC::Run3::ProfReporter;
+
+$VERSION = 0.043;
+
+=head1 NAME
+
+IPC::Run3::ProfReporter - base class for handling profiling data
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+See L<IPC::Run3::ProfPP|IPC::Run3::ProfPP> and for an example subclass.
+
+This class just notes and accumulates times; subclasses use methods like
+"handle_app_call", "handle_run_exit" and "handle_app_exit" to emit reports on
+it. The default methods for these handlers are noops.
+
+If run from the command line, a reporter will be created and run on
+each logfile given as a command line parameter or on run3.out if none
+are given.
+
+This allows reports to be run like:
+
+ perl -MIPC::Run3::ProfPP -e1
+ perl -MIPC::Run3::ProfPP -e1 foo.out bar.out
+
+Use "-" to read from STDIN (the log file format is meant to be moderately
+greppable):
+
+ grep "^cvs " run3.out perl -MIPC::Run3::ProfPP -e1 -
+
+Use --app to show only application level statistics (ie don't emit
+a report section for each command run).
+
+=cut
+
+use strict;
+
+my $loaded_by;
+
+sub import {
+ $loaded_by = shift;
+}
+
+END {
+ my @caller;
+ for ( my $i = 0;; ++$i ) {
+ my @c = caller $i;
+ last unless @c;
+ @caller = @c;
+ }
+
+ if ( $caller[0] eq "main"
+ && $caller[1] eq "-e"
+ ) {
+ require IPC::Run3::ProfLogReader;
+ require Getopt::Long;
+ my ( $app, $run );
+
+ Getopt::Long::GetOptions(
+ "app" => \$app,
+ "run" => \$run,
+ );
+
+ $app = 1, $run = 1 unless $app || $run;
+
+ for ( @ARGV ? @ARGV : "" ) {
+ my $r = IPC::Run3::ProfLogReader->new(
+ Source => $_,
+ Handler => $loaded_by->new(
+ Source => $_,
+ app_report => $app,
+ run_report => $run,
+ ),
+ );
+ $r->read_all;
+ }
+ }
+}
+
+=head1 METHODS
+
+=over
+
+=item C<< IPC::Run3::ProfReporter->new >>
+
+Returns a new profile reporting object.
+
+=cut
+
+sub new {
+ my $class = ref $_[0] ? ref shift : shift;
+ my $self = bless { @_ }, $class;
+ $self->{app_report} = 1, $self->{run_report} = 1
+ unless $self->{app_report} || $self->{run_report};
+
+ return $self;
+}
+
+=item C<< $reporter->handle_app_call( ... ) >>
+
+=item C<< $reporter->handle_app_exit( ... ) >>
+
+=item C<< $reporter->handle_run_exit( ... ) >>
+
+These methods are called by the handled events (see below).
+
+=cut
+
+sub handle_app_call {}
+sub handle_app_exit {}
+
+sub handle_run_exit {}
+
+=item C<< $reporter->app_call(\@cmd, $time) >>
+
+=item C<< $reporter->app_exit($time) >>
+
+=item C<< $reporter->run_exit(@times) >>
+
+ $self->app_call( $time );
+ my $time = $self->get_app_call_time;
+
+Sets the time (in floating point seconds) when the application, run3(),
+or system() was called or exited. If no time parameter is passed, uses
+IPC::Run3's time routine.
+
+Use get_...() to retrieve these values (and _accum values, too). This
+is a separate method to speed the execution time of the setters just a
+bit.
+
+=cut
+
+sub app_call {
+ my $self = shift;
+ ( $self->{app_cmd}, $self->{app_call_time} ) = @_;
+ $self->handle_app_call if $self->{app_report};
+}
+
+sub app_exit {
+ my $self = shift;
+ $self->{app_exit_time} = shift;
+ $self->handle_app_exit if $self->{app_report};
+}
+
+sub run_exit {
+ my $self = shift;
+ @{$self}{qw(
+ run_cmd run_call_time sys_call_time sys_exit_time run_exit_time
+ )} = @_;
+
+ ++$self->{run_count};
+ $self->{run_cumulative_time} += $self->get_run_time;
+ $self->{sys_cumulative_time} += $self->get_sys_time;
+ $self->handle_run_exit if $self->{run_report};
+}
+
+=item C<< $reporter->get_run_count() >>
+
+=item C<< $reporter->get_app_call_time() >>
+
+=item C<< $reporter->get_app_exit_time() >>
+
+=item C<< $reporter->get_app_cmd() >>
+
+=item C<< $reporter->get_app_time() >>
+
+=cut
+
+sub get_run_count { shift->{run_count} }
+sub get_app_call_time { shift->{app_call_time} }
+sub get_app_exit_time { shift->{app_exit_time} }
+sub get_app_cmd { shift->{app_cmd} }
+sub get_app_time {
+ my $self = shift;
+ $self->get_app_exit_time - $self->get_app_call_time;
+}
+
+=item C<< $reporter->get_app_cumulative_time() >>
+
+=cut
+
+sub get_app_cumulative_time {
+ my $self = shift;
+ $self->get_app_exit_time - $self->get_app_call_time;
+}
+
+=item C<< $reporter->get_run_call_time() >>
+
+=item C<< $reporter->get_run_exit_time() >>
+
+=item C<< $reporter->get_run_time() >>
+
+=cut
+
+sub get_run_call_time { shift->{run_call_time} }
+sub get_run_exit_time { shift->{run_exit_time} }
+sub get_run_time {
+ my $self = shift;
+ $self->get_run_exit_time - $self->get_run_call_time;
+}
+
+=item C<< $reporter->get_run_cumulative_time() >>
+
+=cut
+
+sub get_run_cumulative_time { shift->{run_cumulative_time} }
+
+=item C<< $reporter->get_sys_call_time() >>
+
+=item C<< $reporter->get_sys_exit_time() >>
+
+=item C<< $reporter->get_sys_time() >>
+
+=cut
+
+sub get_sys_call_time { shift->{sys_call_time} }
+sub get_sys_exit_time { shift->{sys_exit_time} }
+sub get_sys_time {
+ my $self = shift;
+ $self->get_sys_exit_time - $self->get_sys_call_time;
+}
+
+=item C<< $reporter->get_sys_cumulative_time() >>
+
+=cut
+
+sub get_sys_cumulative_time { shift->{sys_cumulative_time} }
+
+=item C<< $reporter->get_run_cmd() >>
+
+=cut
+
+sub get_run_cmd { shift->{run_cmd} }
+
+=back
+
+=head1 LIMITATIONS
+
+=head1 COPYRIGHT
+
+ Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
+
+=head1 LICENSE
+
+You may use this module under the terms of the BSD, Artistic, or GPL licenses,
+any version.
+
+=head1 AUTHOR
+
+Barrie Slaymaker <barries@slaysys.com>
+
+=cut
+
+1;
diff --git a/Master/tlpkg/tlperl.straw/lib/IPC/System/Simple.pm b/Master/tlpkg/tlperl.straw/lib/IPC/System/Simple.pm
new file mode 100755
index 00000000000..73172c5531f
--- /dev/null
+++ b/Master/tlpkg/tlperl.straw/lib/IPC/System/Simple.pm
@@ -0,0 +1,1076 @@
+package IPC::System::Simple;
+
+use 5.006;
+use strict;
+use warnings;
+use re 'taint';
+use Carp;
+use List::Util qw(first);
+use Scalar::Util qw(tainted);
+use Config;
+use constant WINDOWS => ($^O eq 'MSWin32');
+use constant VMS => ($^O eq 'VMS');
+
+BEGIN {
+
+ # It would be lovely to use the 'if' module here, but it didn't
+ # enter core until 5.6.2, and we want to keep 5.6.0 compatibility.
+
+
+ if (WINDOWS) {
+
+ ## no critic (ProhibitStringyEval)
+
+ eval q{
+ use Win32::Process qw(INFINITE NORMAL_PRIORITY_CLASS);
+ use File::Spec;
+ use Win32;
+
+ # This uses the same rules as the core win32.c/get_shell() call.
+
+ use constant WINDOWS_SHELL => eval { Win32::IsWinNT() }
+ ? [ qw(cmd.exe /x/d/c) ]
+ : [ qw(command.com /c) ];
+
+ # These are used when invoking _win32_capture
+ use constant NO_SHELL => 0;
+ use constant USE_SHELL => 1;
+
+ };
+
+ ## use critic
+
+ # Die nosily if any of the above broke.
+ die $@ if $@;
+ }
+}
+
+# Note that we don't use WIFSTOPPED because perl never uses
+# the WUNTRACED flag, and hence will never return early from
+# system() if the child processes is suspended with a SIGSTOP.
+
+use POSIX qw(WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
+
+use constant FAIL_START => q{"%s" failed to start: "%s"};
+use constant FAIL_PLUMBING => q{Error in IPC::System::Simple plumbing: "%s" - "%s"};
+use constant FAIL_CMD_BLANK => q{Entirely blank command passed: "%s"};
+use constant FAIL_INTERNAL => q{Internal error in IPC::System::Simple: "%s"};
+use constant FAIL_TAINT => q{%s called with tainted argument "%s"};
+use constant FAIL_TAINT_ENV => q{%s called with tainted environment $ENV{%s}};
+use constant FAIL_SIGNAL => q{"%s" died to signal "%s" (%d)%s};
+use constant FAIL_BADEXIT => q{"%s" unexpectedly returned exit value %d};
+
+use constant FAIL_UNDEF => q{%s called with undefined command};
+
+use constant FAIL_POSIX => q{IPC::System::Simple does not understand the POSIX error '%s'. Please check http://search.cpan.org/perldoc?IPC::System::Simple to see if there is an updated version. If not please report this as a bug to http://rt.cpan.org/Public/Bug/Report.html?Queue=IPC-System-Simple};
+
+# On Perl's older than 5.8.x we can't assume that there'll be a
+# $^{TAINT} for us to check, so we assume that our args may always
+# be tainted.
+use constant ASSUME_TAINTED => ($] < 5.008);
+
+use constant EXIT_ANY_CONST => -1; # Used internally
+use constant EXIT_ANY => [ EXIT_ANY_CONST ]; # Exported
+
+use constant UNDEFINED_POSIX_RE => qr{not (?:defined|a valid) POSIX macro|not implemented on this architecture};
+
+require Exporter;
+our @ISA = qw(Exporter);
+
+our @EXPORT_OK = qw(
+ capture capturex
+ run runx
+ system systemx
+ $EXITVAL EXIT_ANY
+);
+
+our $VERSION = '1.20';
+our $EXITVAL = -1;
+
+my @Signal_from_number = split(' ', $Config{sig_name});
+
+# Environment variables we don't want to see tainted.
+my @Check_tainted_env = qw(PATH IFS CDPATH ENV BASH_ENV);
+if (WINDOWS) {
+ push(@Check_tainted_env, 'PERL5SHELL');
+}
+if (VMS) {
+ push(@Check_tainted_env, 'DCL$PATH');
+}
+
+# Not all systems implment the WIFEXITED calls, but POSIX
+# will always export them (even if they're just stubs that
+# die with an error). Test for the presence of a working
+# WIFEXITED and friends, or define our own.
+
+eval { WIFEXITED(0); };
+
+if ($@ =~ UNDEFINED_POSIX_RE) {
+ no warnings 'redefine'; ## no critic
+ *WIFEXITED = sub { not $_[0] & 0xff };
+ *WEXITSTATUS = sub { $_[0] >> 8 };
+ *WIFSIGNALED = sub { $_[0] & 127 };
+ *WTERMSIG = sub { $_[0] & 127 };
+} elsif ($@) {
+ croak sprintf FAIL_POSIX, $@;
+}
+
+# None of the POSIX modules I've found define WCOREDUMP, although
+# many systems define it. Check the POSIX module in the hope that
+# it may actually be there.
+
+
+# TODO: Ideally, $NATIVE_WCOREDUMP should be a constant.
+
+my $NATIVE_WCOREDUMP;
+
+eval { POSIX::WCOREDUMP(1); };
+
+if ($@ =~ UNDEFINED_POSIX_RE) {
+ *WCOREDUMP = sub { $_[0] & 128 };
+ $NATIVE_WCOREDUMP = 0;
+} elsif ($@) {
+ croak sprintf FAIL_POSIX, $@;
+} else {
+ # POSIX actually has it defined! Huzzah!
+ *WCOREDUMP = \&POSIX::WCOREDUMP;
+ $NATIVE_WCOREDUMP = 1;
+}
+
+sub _native_wcoredump {
+ return $NATIVE_WCOREDUMP;
+}
+
+# system simply calls run
+
+*system = \&run;
+*systemx = \&runx;
+
+# run is our way of running a process with system() semantics
+
+sub run {
+
+ _check_taint(@_);
+
+ my ($valid_returns, $command, @args) = _process_args(@_);
+
+ # If we have arguments, we really want to call systemx,
+ # so we do so.
+
+ if (@args) {
+ return systemx($valid_returns, $command, @args);
+ }
+
+ # Without arguments, we're calling system, and checking
+ # the results.
+
+ # We're throwing our own exception on command not found, so
+ # we don't need a warning from Perl.
+
+ no warnings 'exec'; ## no critic
+ CORE::system($command,@args);
+
+ return _process_child_error($?,$command,$valid_returns);
+}
+
+# runx is just like system/run, but *never* invokes the shell.
+
+sub runx {
+ _check_taint(@_);
+
+ my ($valid_returns, $command, @args) = _process_args(@_);
+
+ if (WINDOWS) {
+ our $EXITVAL = -1;
+
+ my $pid = _spawn_or_die($command, "$command @args");
+
+ $pid->Wait(INFINITE); # Wait for process exit.
+ $pid->GetExitCode($EXITVAL);
+ return _check_exit($command,$EXITVAL,$valid_returns);
+ }
+
+ # If system() fails, we throw our own exception. We don't
+ # need to have perl complain about it too.
+
+ no warnings; ## no critic
+
+ CORE::system { $command } $command, @args;
+
+ return _process_child_error($?, $command, $valid_returns);
+}
+
+# capture is our way of running a process with backticks/qx semantics
+
+sub capture {
+ _check_taint(@_);
+
+ my ($valid_returns, $command, @args) = _process_args(@_);
+
+ if (@args) {
+ return capturex($valid_returns, $command, @args);
+ }
+
+ if (WINDOWS) {
+ # USE_SHELL really means "You may use the shell if you need it."
+ return _win32_capture(USE_SHELL, $valid_returns, $command, @args);
+ }
+
+ our $EXITVAL = -1;
+
+ my $wantarray = wantarray();
+
+ # We'll produce our own warnings on failure to execute.
+ no warnings 'exec'; ## no critic
+
+ if ($wantarray) {
+ my @results = qx($command);
+ _process_child_error($?,$command,$valid_returns);
+ return @results;
+ }
+
+ my $results = qx($command);
+ _process_child_error($?,$command,$valid_returns);
+ return $results;
+}
+
+# _win32_capture implements the capture and capurex commands on Win32.
+# We need to wrap the whole internals of this sub into
+# an if (WINDOWS) block to avoid it being compiled on non-Win32 systems.
+
+sub _win32_capture {
+ if (not WINDOWS) {
+ croak sprintf(FAIL_INTERNAL, "_win32_capture called when not under Win32");
+ } else {
+
+ my ($use_shell, $valid_returns, $command, @args) = @_;
+
+ my $wantarray = wantarray();
+
+ # Perl doesn't support multi-arg open under
+ # Windows. Perl also doesn't provide very good
+ # feedback when normal backtails fail, either;
+ # it returns exit status from the shell
+ # (which is indistinguishable from the command
+ # running and producing the same exit status).
+
+ # As such, we essentially have to write our own
+ # backticks.
+
+ # We start by dup'ing STDOUT.
+
+ open(my $saved_stdout, '>&', \*STDOUT) ## no critic
+ or croak sprintf(FAIL_PLUMBING, "Can't dup STDOUT", $!);
+
+ # We now open up a pipe that will allow us to
+ # communicate with the new process.
+
+ pipe(my ($read_fh, $write_fh))
+ or croak sprintf(FAIL_PLUMBING, "Can't create pipe", $!);
+
+ # Allow CRLF sequences to become "\n", since
+ # this is what Perl backticks do.
+
+ binmode($read_fh, ':crlf');
+
+ # Now we re-open our STDOUT to $write_fh...
+
+ open(STDOUT, '>&', $write_fh) ## no critic
+ or croak sprintf(FAIL_PLUMBING, "Can't redirect STDOUT", $!);
+
+ # If we have args, or we're told not to use the shell, then
+ # we treat $command as our shell. Otherwise we grub around
+ # in our command to look for a command to run.
+ #
+ # Note that we don't actually *use* the shell (although in
+ # a future version we might). Being told not to use the shell
+ # (capturex) means we treat our command as really being a command,
+ # and not a command line.
+
+ my $exe = @args ? $command :
+ (! $use_shell) ? $command :
+ $command =~ m{^"([^"]+)"}x ? $1 :
+ $command =~ m{(\S+) }x ? $1 :
+ croak sprintf(FAIL_CMD_BLANK, $command);
+
+ # And now we spawn our new process with inherited
+ # filehandles.
+
+ my $pid = _spawn_or_die($exe, "$command @args");
+
+ # Now restore our STDOUT.
+ open(STDOUT, '>&', $saved_stdout) ## no critic
+ or croak sprintf(FAIL_PLUMBING,"Can't restore STDOUT", $!);
+
+ # Clean-up the filehandles we no longer need...
+
+ close($write_fh)
+ or croak sprintf(FAIL_PLUMBING,q{Can't close write end of pipe}, $!);
+ close($saved_stdout)
+ or croak sprintf(FAIL_PLUMBING,q{Can't close saved STDOUT}, $!);
+
+ # Read the data from our child...
+
+ my (@results, $result);
+
+ if ($wantarray) {
+ @results = <$read_fh>;
+ } else {
+ $result = join("",<$read_fh>);
+ }
+
+ # Tidy up our windows process and we're done!
+
+ $pid->Wait(INFINITE); # Wait for process exit.
+ $pid->GetExitCode($EXITVAL);
+
+ _check_exit($command,$EXITVAL,$valid_returns);
+
+ return $wantarray ? @results : $result;
+
+ }
+}
+
+# capturex() is just like backticks/qx, but never invokes the shell.
+
+sub capturex {
+ _check_taint(@_);
+
+ my ($valid_returns, $command, @args) = _process_args(@_);
+
+ our $EXITVAL = -1;
+
+ my $wantarray = wantarray();
+
+ if (WINDOWS) {
+ return _win32_capture(NO_SHELL, $valid_returns, $command, @args);
+ }
+
+ # We can't use a multi-arg piped open here, since 5.6.x
+ # doesn't like them. Instead we emulate what 5.8.x does,
+ # which is to create a pipe(), set the close-on-exec flag
+ # on the child, and the fork/exec. If the exec fails, the
+ # child writes to the pipe. If the exec succeeds, then
+ # the pipe closes without data.
+
+ pipe(my ($read_fh, $write_fh))
+ or croak sprintf(FAIL_PLUMBING, "Can't create pipe", $!);
+
+ # This next line also does an implicit fork.
+ my $pid = open(my $pipe, '-|'); ## no critic
+
+ if (not defined $pid) {
+ croak sprintf(FAIL_START, $command, $!);
+ } elsif (not $pid) {
+ # Child process, execs command.
+
+ close($read_fh);
+
+ # TODO: 'no warnings exec' doesn't get rid
+ # of the 'unlikely to be reached' warnings.
+ # This is a bug in perl / perldiag / perllexwarn / warnings.
+
+ no warnings; ## no critic
+
+ CORE::exec { $command } $command, @args;
+
+ # Oh no, exec fails! Send the reason why to
+ # the parent.
+
+ print {$write_fh} int($!);
+ exit(-1);
+ }
+
+ {
+ # In parent process.
+
+ close($write_fh);
+
+ # Parent process, check for child error.
+ my $error = <$read_fh>;
+
+ # Tidy up our pipes.
+ close($read_fh);
+
+ # Check for error.
+ if ($error) {
+ # Setting $! to our child error number gives
+ # us nice looking strings when printed.
+ local $! = $error;
+ croak sprintf(FAIL_START, $command, $!);
+ }
+ }
+
+ # Parent process, we don't care about our pid, but we
+ # do go and read our pipe.
+
+ if ($wantarray) {
+ my @results = <$pipe>;
+ close($pipe);
+ _process_child_error($?,$command,$valid_returns);
+ return @results;
+ }
+
+ # NB: We don't check the return status on close(), since
+ # on failure it sets $?, which we then inspect for more
+ # useful information.
+
+ my $results = join("",<$pipe>);
+ close($pipe);
+ _process_child_error($?,$command,$valid_returns);
+
+ return $results;
+
+}
+
+# Tries really hard to spawn a process under Windows. Returns
+# the pid on success, or undef on error.
+
+sub _spawn_or_die {
+
+ # We need to wrap practically the entire sub in an
+ # if block to ensure it doesn't get compiled under non-Win32
+ # systems. Compiling on these systems would not only be a
+ # waste of time, but also results in complaints about
+ # the NORMAL_PRIORITY_CLASS constant.
+
+ if (not WINDOWS) {
+ croak sprintf(FAIL_INTERNAL, "_spawn_or_die called when not under Win32");
+ } else {
+ my ($orig_exe, $cmdline) = @_;
+ my $pid;
+
+ my $exe = $orig_exe;
+
+ # If our command doesn't have an extension, add one.
+ $exe .= $Config{_exe} if ($exe !~ m{\.});
+
+ Win32::Process::Create(
+ $pid, $exe, $cmdline, 1, NORMAL_PRIORITY_CLASS, "."
+ ) and return $pid;
+
+ my @path = split(/;/,$ENV{PATH});
+
+ foreach my $dir (@path) {
+ my $fullpath = File::Spec->catfile($dir,$exe);
+
+ # We're using -x here on the assumption that stat()
+ # is faster than spawn, so trying to spawn a process
+ # for each path element will be unacceptably
+ # inefficient.
+
+ if (-x $fullpath) {
+ Win32::Process::Create(
+ $pid, $fullpath, $cmdline, 1,
+ NORMAL_PRIORITY_CLASS, "."
+ ) and return $pid;
+ }
+ }
+
+ croak sprintf(FAIL_START, $orig_exe, $^E);
+ }
+}
+
+# Complain on tainted arguments or environment.
+# ASSUME_TAINTED is true for 5.6.x, since it's missing ${^TAINT}
+
+sub _check_taint {
+ return if not (ASSUME_TAINTED or ${^TAINT});
+ my $caller = (caller(1))[3];
+ foreach my $var (@_) {
+ if (tainted $var) {
+ croak sprintf(FAIL_TAINT, $caller, $var);
+ }
+ }
+ foreach my $var (@Check_tainted_env) {
+ if (tainted $ENV{$var} ) {
+ croak sprintf(FAIL_TAINT_ENV, $caller, $var);
+ }
+ }
+
+ return;
+
+}
+
+# This subroutine performs the difficult task of interpreting
+# $?. It's not intended to be called directly, as it will
+# croak on errors, and its implementation and interface may
+# change in the future.
+
+sub _process_child_error {
+ my ($child_error, $command, $valid_returns) = @_;
+
+ $EXITVAL = -1;
+
+ my $coredump = WCOREDUMP($child_error);
+
+ # There's a bug in perl 5.10.0 where if the system
+ # does not provide a native WCOREDUMP, then $? will
+ # never contain coredump information. This code
+ # checks to see if we have the bug, and works around
+ # it if needed.
+
+ if ($] >= 5.010 and not $NATIVE_WCOREDUMP) {
+ $coredump ||= WCOREDUMP( ${^CHILD_ERROR_NATIVE} );
+ }
+
+ if ($child_error == -1) {
+ croak sprintf(FAIL_START, $command, $!);
+
+ } elsif ( WIFEXITED( $child_error ) ) {
+ $EXITVAL = WEXITSTATUS( $child_error );
+
+ return _check_exit($command,$EXITVAL,$valid_returns);
+
+ } elsif ( WIFSIGNALED( $child_error ) ) {
+ my $signal_no = WTERMSIG( $child_error );
+ my $signal_name = $Signal_from_number[$signal_no] || "UNKNOWN";
+
+ croak sprintf FAIL_SIGNAL, $command, $signal_name, $signal_no, ($coredump ? " and dumped core" : "");
+
+
+ }
+
+ croak sprintf(FAIL_INTERNAL, qq{'$command' ran without exit value or signal});
+
+}
+
+# A simple subroutine for checking exit values. Results in better
+# assurance of consistent error messages, and better forward support
+# for new features in I::S::S.
+
+sub _check_exit {
+ my ($command, $exitval, $valid_returns) = @_;
+
+ # If we have a single-value list consisting of the EXIT_ANY
+ # value, then we're happy with whatever exit value we're given.
+ if (@$valid_returns == 1 and $valid_returns->[0] == EXIT_ANY_CONST) {
+ return $exitval;
+ }
+
+ if (not defined first { $_ == $exitval } @$valid_returns) {
+ croak sprintf FAIL_BADEXIT, $command, $exitval;
+ }
+ return $exitval;
+}
+
+
+# This subroutine simply determines a list of valid returns, the command
+# name, and any arguments that we need to pass to it.
+
+sub _process_args {
+ my $valid_returns = [ 0 ];
+ my $caller = (caller(1))[3];
+
+ if (not @_) {
+ croak "$caller called with no arguments";
+ }
+
+ if (ref $_[0] eq "ARRAY") {
+ $valid_returns = shift(@_);
+ }
+
+ if (not @_) {
+ croak "$caller called with no command";
+ }
+
+ my $command = shift(@_);
+
+ if (not defined $command) {
+ croak sprintf( FAIL_UNDEF, $caller );
+ }
+
+ return ($valid_returns,$command,@_);
+
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IPC::System::Simple - Run commands simply, with detailed diagnostics
+
+=head1 SYNOPSIS
+
+ use IPC::System::Simple qw(system systemx capture capturex);
+
+ system("some_command"); # Command succeeds or dies!
+
+ system("some_command",@args); # Succeeds or dies, avoids shell if @args
+
+ systemx("some_command",@args); # Succeeds or dies, NEVER uses the shell
+
+
+ # Capture the output of a command (just like backticks). Dies on error.
+ my $output = capture("some_command");
+
+ # Just like backticks in list context. Dies on error.
+ my @output = capture("some_command");
+
+ # As above, but avoids the shell if @args is non-empty
+ my $output = capture("some_command", @args);
+
+ # As above, but NEVER invokes the shell.
+ my $output = capturex("some_command", @args);
+ my @output = capturex("some_command", @args);
+
+=head1 DESCRIPTION
+
+Calling Perl's in-built C<system()> function is easy,
+determining if it was successful is I<hard>. Let's face it,
+C<$?> isn't the nicest variable in the world to play with, and
+even if you I<do> check it, producing a well-formatted error
+string takes a lot of work.
+
+C<IPC::System::Simple> takes the hard work out of calling
+external commands. In fact, if you want to be really lazy,
+you can just write:
+
+ use IPC::System::Simple qw(system);
+
+and all of your C<system> commands will either succeeed (run to
+completion and return a zero exit value), or die with rich diagnostic
+messages.
+
+The C<IPC::System::Simple> module also provides a simple replacement
+to Perl's backticks operator. Simply write:
+
+ use IPC::System::Simple qw(capture);
+
+and then use the L</capture()> command just like you'd use backticks.
+If there's an error, it will die with a detailed description of what
+went wrong. Better still, you can even use C<capturex()> to run the
+equivalent of backticks, but without the shell:
+
+ use IPC::System::Simple qw(capturex);
+
+ my $result = capturex($command, @args);
+
+If you want more power than the basic interface, including the
+ability to specify which exit values are acceptable, trap errors,
+or process diagnostics, then read on!
+
+=head1 ADVANCED SYNOPSIS
+
+ use IPC::System::Simple qw(
+ capture capturex system systemx run runx $EXITVAL EXIT_ANY
+ );
+
+ # Run a command, throwing exception on failure
+
+ run("some_command");
+
+ runx("some_command",@args); # Run a command, avoiding the shell
+
+ # Do the same thing, but with the drop-in system replacement.
+
+ system("some_command");
+
+ systemx("some_command", @args);
+
+ # Run a command which must return 0..5, avoid the shell, and get the
+ # exit value (we could also look at $EXITVAL)
+
+ my $exit_value = runx([0..5], "some_command", @args);
+
+ # The same, but any exit value will do.
+
+ my $exit_value = runx(EXIT_ANY, "some_command", @args);
+
+ # Capture output into $result and throw exception on failure
+
+ my $result = capture("some_command");
+
+ # Check exit value from captured command
+
+ print "some_command exited with status $EXITVAL\n";
+
+ # Captures into @lines, splitting on $/
+ my @lines = capture("some_command");
+
+ # Run a command which must return 0..5, capture the output into
+ # @lines, and avoid the shell.
+
+ my @lines = capturex([0..5], "some_command", @args);
+
+=head1 ADVANCED USAGE
+
+=head2 run() and system()
+
+C<IPC::System::Simple> provides a subroutine called
+C<run>, that executes a command using the same semantics is
+Perl's built-in C<system>:
+
+ use IPC::System::Simple qw(run);
+
+ run("cat *.txt"); # Execute command via the shell
+ run("cat","/etc/motd"); # Execute command without shell
+
+The primary difference between Perl's in-built system and
+the C<run> command is that C<run> will throw an exception on
+failure, and allows a list of acceptable exit values to be set.
+See L</Exit values> for further information.
+
+In fact, you can even have C<IPC::System::Simple> replace the
+default C<system> function for your package so it has the
+same behaviour:
+
+ use IPC::System::Simple qw(system);
+
+ system("cat *.txt"); # system now suceeds or dies!
+
+C<system> and C<run> are aliases to each other.
+
+See also L</runx(), systemx() and capturex()> for variants of
+C<system()> and C<run()> that never invoke the shell, even with
+a single argument.
+
+=head2 capture()
+
+A second subroutine, named C<capture> executes a command with
+the same semantics as Perl's built-in backticks (and C<qx()>):
+
+ use IPC::System::Simple qw(capture);
+
+ # Capture text while invoking the shell.
+ my $file = capture("cat /etc/motd");
+ my @lines = capture("cat /etc/passwd");
+
+However unlike regular backticks, which always use the shell, C<capture>
+will bypass the shell when called with multiple arguments:
+
+ # Capture text while avoiding the shell.
+ my $file = capture("cat", "/etc/motd");
+ my @lines = capture("cat", "/etc/passwd");
+
+See also L</runx(), systemx() and capturex()> for a variant of
+C<capture()> that never invokes the shell, even with a single
+argument.
+
+=head2 runx(), systemx() and capturex()
+
+The C<runx()>, C<systemx()> and C<capturex()> commands are identical
+to the multi-argument forms of C<run()>, C<system()> and C<capture()>
+respectively, but I<never> invoke the shell, even when called with a
+single argument. These forms are particularly useful when a command's
+argument list I<might> be empty, for example:
+
+ systemx($cmd, @args);
+
+The use of C<systemx()> here guarantees that the shell will I<never>
+be invoked, even if C<@args> is empty.
+
+=head2 Exception handling
+
+In the case where the command returns an unexpected status, both C<run> and
+C<capture> will throw an exception, which if not caught will terminate your
+program with an error.
+
+Capturing the exception is easy:
+
+ eval {
+ run("cat *.txt");
+ };
+
+ if ($@) {
+ print "Something went wrong - $@\n";
+ }
+
+See the diagnostics section below for more details.
+
+=head3 Exception cases
+
+C<IPC::System::Simple> considers the following to be unexpected,
+and worthy of exception:
+
+=over 4
+
+=item *
+
+Failing to start entirely (eg, command not found, permission denied).
+
+=item *
+
+Returning an exit value other than zero (but see below).
+
+=item *
+
+Being killed by a signal.
+
+=item *
+
+Being passed tainted data (in taint mode).
+
+=back
+
+=head2 Exit values
+
+Traditionally, system commands return a zero status for success and a
+non-zero status for failure. C<IPC::System::Simple> will default to throwing
+an exception if a non-zero exit value is returned.
+
+You may specify a range of values which are considered acceptable exit
+values by passing an I<array reference> as the first argument. The
+special constant C<EXIT_ANY> can be used to allow I<any> exit value
+to be returned.
+
+ use IPC::System::Simple qw(run system capture EXIT_ANY);
+
+ run( [0..5], "cat *.txt"); # Exit values 0-5 are OK
+
+ system( [0..5], "cat *.txt"); # This works the same way
+
+ my @lines = capture( EXIT_ANY, "cat *.txt"); # Any exit is fine.
+
+The C<run> and replacement C<system> subroutines returns the exit
+value of the process:
+
+ my $exit_value = run( [0..5], "cat *.txt");
+
+ # OR:
+
+ my $exit_value = system( [0..5] "cat *.txt");
+
+ print "Program exited with value $exit_value\n";
+
+=head3 $EXITVAL
+
+The exit value of any command exeucted by C<IPC::System::Simple>
+can always be retrieved from the C<$IPC::System::Simple::EXITVAL>
+variable:
+
+This is particularly useful when inspecting results from C<capture>,
+which returns the captured text from the command.
+
+ use IPC::System::Simple qw(capture $EXITVAL EXIT_ANY);
+
+ my @enemies_defeated = capture(EXIT_ANY, "defeat_evil", "/dev/mordor");
+
+ print "Program exited with value $EXITVAL\n";
+
+C<$EXITVAL> will be set to C<-1> if the command did not exit normally (eg,
+being terminated by a signal) or did not start. In this situation an
+exception will also be thrown.
+
+=head2 WINDOWS-SPECIFIC NOTES
+
+As of C<IPC::System::Simple> v0.06, the C<run> subroutine I<when
+called with multiple arguments> will make available the full 32-bit
+exit value on Win32 systems. This is different from the
+previous versions of C<IPC::System::Simple> and from Perl's
+in-build C<system()> function, which can only handle 8-bit return values.
+
+The C<capture> subroutine always returns the 32-bit exit value under
+Windows. The C<capture> subroutine also never uses the shell,
+even when passed a single argument.
+
+Versions of C<IPC::System::Simple> before v0.09 would not search
+the C<PATH> environment variable when the multi-argument form of
+C<run()> was called. Versions from v0.09 onwards correctly search
+the path provided the command is provided including the extension
+(eg, C<notepad.exe> rather than just C<notepad>, or C<gvim.bat> rather
+than just C<gvim>). If no extension is provided, C<.exe> is
+assumed.
+
+Signals are not supported on Windows systems. Sending a signal
+to a Windows process will usually cause it to exit with the signal
+number used.
+
+=head1 DIAGNOSTICS
+
+=over 4
+
+=item "%s" failed to start: "%s"
+
+The command specified did not even start. It may not exist, or
+you may not have permission to use it. The reason it could not
+start (as determined from C<$!>) will be provided.
+
+=item "%s" unexpectedly returned exit value %d
+
+The command ran successfully, but returned an exit value we did
+not expect. The value returned is reported.
+
+=item "%s" died to signal "%s" (%d) %s
+
+The command was killed by a signal. The name of the signal
+will be reported, or C<UNKNOWN> if it cannot be determined. The
+signal number is always reported. If we detected that the
+process dumped core, then the string C<and dumped core> is
+appeneded.
+
+=item IPC::System::Simple::%s called with no arguments
+
+You attempted to call C<run> or C<capture> but did not provide any
+arguments at all. At the very lease you need to supply a command
+to run.
+
+=item IPC::System::Simple::%s called with no command
+
+You called C<run> or C<capture> with a list of acceptable exit values,
+but no actual command.
+
+=item IPC::System::Simple::%s called with tainted argument "%s"
+
+You called C<run> or C<capture> with tainted (untrusted) arguments, which is
+almost certainly a bad idea. To untaint your arguments you'll need to pass
+your data through a regular expression and use the resulting match variables.
+See L<perlsec/Laundering and Detecting Tainted Data> for more information.
+
+=item IPC::System::Simple::%s called with tainted environment $ENV{%s}
+
+You called C<run> or C<capture> but part of your environment was tainted
+(untrusted). You should either delete the named environment
+variable before calling C<run>, or set it to an untainted value
+(usually one set inside your program). See
+L<perlsec/Cleaning Up Your Path> for more information.
+
+=item Error in IPC::System::Simple plumbing: "%s" - "%s"
+
+Implementing the C<capture> command involves dark and terrible magicks
+involving pipes, and one of them has sprung a leak. This could be due to a
+lack of file descriptors, although there are other possibilities.
+
+If you are able to reproduce this error, you are encouraged
+to submit a bug report according to the L</Reporting bugs> section below.
+
+=item Internal error in IPC::System::Simple: "%s"
+
+You've found a bug in C<IPC::System::Simple>. Please check to
+see if an updated version of C<IPC::System::Simple> is available.
+If not, please file a bug report according to the L</Reporting bugs> section
+below.
+
+=item IPC::System::Simple::%s called with undefined command
+
+You've passed the undefined value as a command to be executed.
+While this is a very Zen-like action, it's not supported by
+Perl's current implementation.
+
+=back
+
+=head1 DEPENDENCIES
+
+This module depends upon L<Win32::Process> when used on Win32
+system. C<Win32::Process> is bundled as a core module in ActivePerl 5.6
+and above.
+
+There are no non-core dependencies on non-Win32 systems.
+
+=head1 COMPARISON TO OTHER APIs
+
+Perl provides a range of in-built functions for handling external
+commands, and CPAN provides even more. The C<IPC::System::Simple>
+differentiates itself from other options by providing:
+
+=over 4
+
+=item Extremely detailed diagnostics
+
+The diagnostics produced by C<IPC::System::Simple> are designed
+to provide as much information as possible. Rather than requiring
+the developer to inspect C<$?>, C<IPC::System::Simple> does the
+hard work for you.
+
+If an odd exit status is provided, you're informed of what it is. If
+a signal kills your process, you are informed of both its name and
+number. If tainted data or environment prevents your command from
+running, you are informed of exactly which datais
+
+=item Exceptions on failure
+
+C<IPC::System::Simple> takes an agressive approach to error handling.
+Rather than allow commands to fail silently, exceptions are thrown
+when unexpected results are seen. This allows for easy development
+using a try/catch style, and avoids the possibility of accidently
+continuing after a failed command.
+
+=item Easy access to exit status
+
+The C<run>, C<system> and C<capture> commands all set C<$EXITVAL>,
+making it easy to determine the exit status of a command.
+Additionally, the C<system> and C<run> interfaces return the exit
+status.
+
+=item Consistent interfaces
+
+When called with multiple arguments, the C<run>, C<system> and
+C<capture> interfaces I<never> invoke the shell. This differs
+from the in-built Perl C<system> command which may invoke the
+shell under Windows when called with multiple arguments. It
+differs from the in-built Perl backticks operator which always
+invokes the shell.
+
+=back
+
+=head1 BUGS
+
+When C<system> is exported, the exotic form C<system { $cmd } @args>
+is not supported. Attemping to use the exotic form is a syntax
+error. This affects the calling package I<only>. Use C<CORE::system>
+if you need it, or consider using the L<autodie> module to replace
+C<system> with lexical scope.
+
+Core dumps are only checked for when a process dies due to a
+signal. It is not believed thare exist any systems where processes
+can dump core without dying to a signal.
+
+C<WIFSTOPPED> status is not checked, as perl never spawns processes
+with the C<WUNTRACED> option.
+
+Signals are not supported under Win32 systems, since they don't
+work at all like Unix signals. Win32 singals cause commands to
+exit with a given exit value, which this modules I<does> capture.
+
+Only 8-bit values are returned when C<run()> or C<system()>
+is called with a single value under Win32. Multi-argument calls
+to C<run()> and C<system()>, as well as the C<runx()> and
+C<systemx()> always return the 32-bit Windows return values.
+
+=head2 Reporting bugs
+
+Before reporting a bug, please check to ensure you are using the
+most recent version of C<IPC::System::Simple>. Your problem may
+have already been fixed in a new release.
+
+You can find the C<IPC::System::Simple> bug-tracker at
+L<http://rt.cpan.org/Public/Dist/Display.html?Name=IPC-System-Simple> .
+Please check to see if your bug has already been reported; if
+in doubt, report yours anyway.
+
+Submitting a patch and/or failing test case will greatly expediate
+the fixing of bugs.
+
+=head1 FEEDBACK
+
+If you find this module useful, please consider rating it on the
+CPAN Ratings service at
+L<http://cpanratings.perl.org/rate/?distribution=IPC-System-Simple> .
+
+The module author loves to hear how C<IPC::System::Simple> has made
+your life better (or worse). Feedback can be sent to
+E<lt>pjf@perltraining.com.auE<gt>.
+
+=head1 SEE ALSO
+
+L<autodie> uses C<IPC::System::Simple> to provide succeed-or-die
+replacements to C<system> (and other built-ins) with lexical scope.
+
+L<POSIX>, L<IPC::Run::Simple>, L<perlipc>, L<perlport>, L<IPC::Run>,
+L<IPC::Run3>, L<Win32::Process>
+
+=head1 AUTHOR
+
+Paul Fenwick E<lt>pjf@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2006-2008 by Paul Fenwick
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.6.0 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut