summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/IPC
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /systems/texlive/tlnet/tlpkg/tlperl/lib/IPC
Initial commit
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/IPC')
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/IPC/Cmd.pm2180
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/IPC/Open2.pm120
-rw-r--r--systems/texlive/tlnet/tlpkg/tlperl/lib/IPC/Open3.pm433
3 files changed, 2733 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IPC/Cmd.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IPC/Cmd.pm
new file mode 100644
index 0000000000..a42c21b84e
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IPC/Cmd.pm
@@ -0,0 +1,2180 @@
+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
+ $INSTANCES $ALLOW_NULL_ARGS
+ $HAVE_MONOTONIC
+ ];
+
+ $VERSION = '1.00';
+ $VERBOSE = 0;
+ $DEBUG = 0;
+ $WARN = 1;
+ $USE_IPC_RUN = IS_WIN32 && !IS_WIN98;
+ $USE_IPC_OPEN3 = not IS_VMS;
+ $ALLOW_NULL_ARGS = 0;
+
+ $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;
+ require Time::HiRes; Time::HiRes->import();
+ require Win32 if IS_WIN32;
+ };
+ $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32;
+
+ eval {
+ my $wait_start_time = Time::HiRes::clock_gettime(&Time::HiRes::CLOCK_MONOTONIC);
+ };
+ if ($@) {
+ $HAVE_MONOTONIC = 0;
+ }
+ else {
+ $HAVE_MONOTONIC = 1;
+ }
+
+ @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';
+
+local $Module::Load::Conditional::FORCE_SAFE_INC = 1;
+
+=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_message, $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;
+ }
+
+ ### run_forked example ###
+ my $result = run_forked("$full_path -q -O - theregister.co.uk", {'timeout' => 20});
+ if ($result->{'exit_code'} eq 0 && !$result->{'timeout'}) {
+ print "this is what wget returned:\n";
+ print $result->{'stdout'};
+ }
+
+ ### 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 platform independently,
+interactively if desired, 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 C<verbose> flag is passed, it will print diagnostic messages
+if L<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 don't 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 because of a lack of fork.
+ return if IS_VMS;
+
+ ### IPC::Open3 works on every non-VMS 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;
+ 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 only one 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.
+
+If called in a scalar context it will return the full path to the binary
+you asked for if it was found, or C<undef> if it was not.
+
+If called in a list context and the global variable C<$INSTANCES> is a true
+value, it will return a list of the full paths to instances
+of the binary where found in C<PATH>, or an empty list if it was not found.
+
+=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 File::Spec;
+ require ExtUtils::MakeMaker;
+
+ my @possibles;
+
+ if( File::Spec->file_name_is_absolute($command) ) {
+ return MM->maybe_command($command);
+
+ } else {
+ for my $dir (
+ File::Spec->path,
+ ( IS_WIN32 ? File::Spec->curdir : () )
+ ) {
+ next if ! $dir || ! -d $dir;
+ my $abs = File::Spec->catfile( IS_WIN32 ? Win32::GetShortPathName( $dir ) : $dir, $command);
+ push @possibles, $abs if $abs = MM->maybe_command($abs);
+ }
+ }
+ return @possibles if wantarray and $INSTANCES;
+ return shift @possibles;
+}
+
+=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 L<IPC::Run> to be installed, or your system able to work with
+L<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 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 L<"error message"> 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 (C<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 array reference containing all the output the command
+generated.
+Note that buffers are only available if you have L<IPC::Run> installed,
+or if your system is able to work with L<IPC::Open3> -- see below).
+Otherwise, this element will be C<undef>.
+
+=item out_buffer
+
+This is an array reference containing all the output sent to STDOUT the
+command generated. The notes from L<"full_buffer"> apply.
+
+=item error_buffer
+
+This is an arrayreference containing all the output sent to STDERR the
+command generated. The notes from L<"full_buffer"> apply.
+
+
+=back
+
+See the L<"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";
+}
+
+sub get_monotonic_time {
+ if ($HAVE_MONOTONIC) {
+ return Time::HiRes::clock_gettime(&Time::HiRes::CLOCK_MONOTONIC);
+ }
+ else {
+ return time();
+ }
+}
+
+sub adjust_monotonic_start_time {
+ my ($ref_vars, $now, $previous) = @_;
+
+ # workaround only for those systems which don't have
+ # Time::HiRes::CLOCK_MONOTONIC (Mac OSX in particular)
+ return if $HAVE_MONOTONIC;
+
+ # don't have previous monotonic value (only happens once
+ # in the beginning of the program execution)
+ return unless $previous;
+
+ my $time_diff = $now - $previous;
+
+ # adjust previously saved time with the skew value which is
+ # either negative when clock moved back or more than 5 seconds --
+ # assuming that event loop does happen more often than once
+ # per five seconds, which might not be always true (!) but
+ # hopefully that's ok, because it's just a workaround
+ if ($time_diff > 5 || $time_diff < 0) {
+ foreach my $ref_var (@{$ref_vars}) {
+ if (defined($$ref_var)) {
+ $$ref_var = $$ref_var + $time_diff;
+ }
+ }
+ }
+}
+
+sub uninstall_signals {
+ return unless defined($IPC::Cmd::{'__old_signals'});
+
+ foreach my $sig_name (keys %{$IPC::Cmd::{'__old_signals'}}) {
+ $SIG{$sig_name} = $IPC::Cmd::{'__old_signals'}->{$sig_name};
+ }
+}
+
+# incompatible with POSIX::SigAction
+#
+sub install_layered_signal {
+ my ($s, $handler_code) = @_;
+
+ my %available_signals = map {$_ => 1} keys %SIG;
+
+ Carp::confess("install_layered_signal got nonexistent signal name [$s]")
+ unless defined($available_signals{$s});
+ Carp::confess("install_layered_signal expects coderef")
+ if !ref($handler_code) || ref($handler_code) ne 'CODE';
+
+ $IPC::Cmd::{'__old_signals'} = {}
+ unless defined($IPC::Cmd::{'__old_signals'});
+ $IPC::Cmd::{'__old_signals'}->{$s} = $SIG{$s};
+
+ my $previous_handler = $SIG{$s};
+
+ my $sig_handler = sub {
+ my ($called_sig_name, @sig_param) = @_;
+
+ # $s is a closure referring to real signal name
+ # for which this handler is being installed.
+ # it is used to distinguish between
+ # real signal handlers and aliased signal handlers
+ my $signal_name = $s;
+
+ # $called_sig_name is a signal name which
+ # was passed to this signal handler;
+ # it doesn't equal $signal_name in case
+ # some signal handlers in %SIG point
+ # to other signal handler (CHLD and CLD,
+ # ABRT and IOT)
+ #
+ # initial signal handler for aliased signal
+ # calls some other signal handler which
+ # should not execute the same handler_code again
+ if ($called_sig_name eq $signal_name) {
+ $handler_code->($signal_name);
+ }
+
+ # run original signal handler if any (including aliased)
+ #
+ if (ref($previous_handler)) {
+ $previous_handler->($called_sig_name, @sig_param);
+ }
+ };
+
+ $SIG{$s} = $sig_handler;
+}
+
+# give process a chance sending TERM,
+# waiting for a while (2 seconds)
+# and killing it with KILL
+sub kill_gently {
+ my ($pid, $opts) = @_;
+
+ require POSIX;
+
+ $opts = {} unless $opts;
+ $opts->{'wait_time'} = 2 unless defined($opts->{'wait_time'});
+ $opts->{'first_kill_type'} = 'just_process' unless $opts->{'first_kill_type'};
+ $opts->{'final_kill_type'} = 'just_process' unless $opts->{'final_kill_type'};
+
+ if ($opts->{'first_kill_type'} eq 'just_process') {
+ kill(15, $pid);
+ }
+ elsif ($opts->{'first_kill_type'} eq 'process_group') {
+ kill(-15, $pid);
+ }
+
+ my $do_wait = 1;
+ my $child_finished = 0;
+
+ my $wait_start_time = get_monotonic_time();
+ my $now;
+ my $previous_monotonic_value;
+
+ while ($do_wait) {
+ $previous_monotonic_value = $now;
+ $now = get_monotonic_time();
+
+ adjust_monotonic_start_time([\$wait_start_time], $now, $previous_monotonic_value);
+
+ if ($now > $wait_start_time + $opts->{'wait_time'}) {
+ $do_wait = 0;
+ next;
+ }
+
+ my $waitpid = waitpid($pid, POSIX::WNOHANG);
+
+ if ($waitpid eq -1) {
+ $child_finished = 1;
+ $do_wait = 0;
+ next;
+ }
+
+ Time::HiRes::usleep(250000); # quarter of a second
+ }
+
+ if (!$child_finished) {
+ if ($opts->{'final_kill_type'} eq 'just_process') {
+ kill(9, $pid);
+ }
+ elsif ($opts->{'final_kill_type'} eq 'process_group') {
+ kill(-9, $pid);
+ }
+ }
+}
+
+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);
+ Time::HiRes::usleep(1);
+
+ # 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{'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)
+ SIGNAL: foreach my $s (keys %SIG) {
+ next SIGNAL if $s eq '__WARN__' or $s eq '__DIE__'; # Skip and don't clobber __DIE__ & __WARN__
+ my $sig_handler;
+ $sig_handler = sub {
+ kill("$s", $pid);
+ $SIG{$s} = $sig_handler;
+ };
+ $SIG{$s} = $sig_handler;
+ }
+
+ my $child_finished = 0;
+
+ my $real_exit;
+ my $exit_value;
+
+ while(!$child_finished) {
+
+ # parent was killed otherwise we would have got
+ # the same signal as parent and process it same way
+ if (getppid() eq "1") {
+
+ # end my process group with all the children
+ # (i am the process group leader, so my pid
+ # equals to the process group id)
+ #
+ # same thing which is done
+ # with $opts->{'clean_up_children'}
+ # in run_forked
+ #
+ kill(-9, $$);
+
+ POSIX::_exit 1;
+ }
+
+ my $waitpid = waitpid($pid, POSIX::WNOHANG);
+
+ # child finished, catch it's exit status
+ if ($waitpid ne 0 && $waitpid ne -1) {
+ $real_exit = $?;
+ $exit_value = $? >> 8;
+ }
+
+ if ($waitpid eq -1) {
+ $child_finished = 1;
+ }
+
+
+ my $ready_fds = [];
+ push @{$ready_fds}, $select->can_read(1/100);
+
+ READY_FDS: while (scalar(@{$ready_fds})) {
+ my $fd = shift @{$ready_fds};
+ $ready_fds = [grep {$_ ne $fd} @{$ready_fds}];
+
+ my $str = $child_output->{$fd->fileno};
+ Carp::confess("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 {
+ Carp::confess("error during sysread: " . $!);
+ }
+
+ push @{$ready_fds}, $select->can_read(1/100) if $child_finished;
+ }
+
+ Time::HiRes::usleep(1);
+ }
+
+ # since we've successfully reaped the child,
+ # let our parent know about this.
+ #
+ if ($opts->{'parent_info'}) {
+ my $ps = $opts->{'parent_info'};
+
+ # child was killed, inform parent
+ if ($real_exit & 127) {
+ print $ps "$pid killed with " . ($real_exit & 127) . "\n";
+ }
+
+ print $ps "reaped $pid\n";
+ }
+
+ 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, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} );
+
+C<run_forked> is used to execute some program or a coderef,
+optionally feed it with some input, get its return code
+and output (both stdout and stderr into separate buffers).
+In addition, it allows to terminate the program
+if it takes 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 or a coderef and optionally a hashref of options:
+
+=over
+
+=item C<timeout>
+
+Specify in seconds how long to run the command before it is killed 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 the C<STDIN> of the executed program.
+
+=item C<stdout_handler>
+
+Coderef of a subroutine to call when a portion of data is received on
+STDOUT from the executing program.
+
+=item C<stderr_handler>
+
+Coderef of a subroutine to call when a portion of data is received on
+STDERR from the executing program.
+
+=item C<wait_loop_callback>
+
+Coderef of a subroutine to call inside of the main waiting loop
+(while C<run_forked> waits for the external to finish or fail).
+It is useful to stop running external process before it ends
+by itself, e.g.
+
+ my $r = run_forked("some external command", {
+ 'wait_loop_callback' => sub {
+ if (condition) {
+ kill(1, $$);
+ }
+ },
+ 'terminate_on_signal' => 'HUP',
+ });
+
+Combined with C<stdout_handler> and C<stderr_handler> allows terminating
+external command based on its output. Could also be used as a timer
+without engaging with L<alarm> (signals).
+
+Remember that this code could be called every millisecond (depending
+on the output which external command generates), so try to make it
+as lightweight as possible.
+
+=item C<discard_output>
+
+Discards the buffering of the standard output and standard errors for return by run_forked().
+With this option you have to use the std*_handlers to read what the command outputs.
+Useful for commands that send a lot of output.
+
+=item C<terminate_on_parent_sudden_death>
+
+Enable this option if you wish all spawned processes to be killed if the initially spawned
+process (the parent) is killed or dies without waiting for child processes.
+
+=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 was no STDOUT output or if C<discard_output> was used; it's always defined!)
+
+=item C<stderr>
+
+Holds the standard error of the executed command (or empty string if
+there was no STDERR output or if C<discard_output> was used; 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 was no output at all or if C<discard_output> was used; 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;
+ }
+
+ require POSIX;
+
+ my ($cmd, $opts) = @_;
+ if (ref($cmd) eq 'ARRAY') {
+ $cmd = join(" ", @{$cmd});
+ }
+
+ if (!$cmd) {
+ Carp::carp("run_forked expects command to run");
+ return;
+ }
+
+ $opts = {} unless $opts;
+ $opts->{'timeout'} = 0 unless $opts->{'timeout'};
+ $opts->{'terminate_wait_time'} = 2 unless defined($opts->{'terminate_wait_time'});
+
+ # turned on by default
+ $opts->{'clean_up_children'} = 1 unless defined($opts->{'clean_up_children'});
+
+ # 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, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
+ Carp::confess ("socketpair: $!");
+ socketpair($child_stderr_socket, $parent_stderr_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
+ Carp::confess ("socketpair: $!");
+ socketpair($child_info_socket, $parent_info_socket, &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC) ||
+ Carp::confess ("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 = get_monotonic_time();
+
+ my $pid;
+ if ($pid = fork) {
+
+ # we are a parent
+ close($parent_stdout_socket);
+ close($parent_stderr_socket);
+ close($parent_info_socket);
+
+ my $flags;
+
+ # prepare sockets to read from child
+
+ $flags = fcntl($child_stdout_socket, POSIX::F_GETFL, 0) || Carp::confess "can't fnctl F_GETFL: $!";
+ $flags |= POSIX::O_NONBLOCK;
+ fcntl($child_stdout_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
+
+ $flags = fcntl($child_stderr_socket, POSIX::F_GETFL, 0) || Carp::confess "can't fnctl F_GETFL: $!";
+ $flags |= POSIX::O_NONBLOCK;
+ fcntl($child_stderr_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
+
+ $flags = fcntl($child_info_socket, POSIX::F_GETFL, 0) || Carp::confess "can't fnctl F_GETFL: $!";
+ $flags |= POSIX::O_NONBLOCK;
+ fcntl($child_info_socket, POSIX::F_SETFL, $flags) || Carp::confess "can't fnctl F_SETFL: $!";
+
+ # print "child $pid started\n";
+
+ my $child_output = {
+ $child_stdout_socket->fileno => {
+ 'scalar_buffer' => "",
+ 'child_handle' => $child_stdout_socket,
+ 'block_size' => ($child_stdout_socket->stat)[11] || 1024,
+ 'protocol' => 'stdout',
+ },
+ $child_stderr_socket->fileno => {
+ 'scalar_buffer' => "",
+ 'child_handle' => $child_stderr_socket,
+ 'block_size' => ($child_stderr_socket->stat)[11] || 1024,
+ 'protocol' => 'stderr',
+ },
+ $child_info_socket->fileno => {
+ 'scalar_buffer' => "",
+ 'child_handle' => $child_info_socket,
+ 'block_size' => ($child_info_socket->stat)[11] || 1024,
+ 'protocol' => 'info',
+ },
+ };
+
+ my $select = IO::Select->new();
+ $select->add($child_stdout_socket, $child_stderr_socket, $child_info_socket);
+
+ my $child_timedout = 0;
+ my $child_finished = 0;
+ my $child_stdout = '';
+ my $child_stderr = '';
+ my $child_merged = '';
+ my $child_exit_code = 0;
+ my $child_killed_by_signal = 0;
+ my $parent_died = 0;
+
+ my $last_parent_check = 0;
+ my $got_sig_child = 0;
+ my $got_sig_quit = 0;
+ my $orig_sig_child = $SIG{'CHLD'};
+
+ $SIG{'CHLD'} = sub { $got_sig_child = get_monotonic_time(); };
+
+ if ($opts->{'terminate_on_signal'}) {
+ install_layered_signal($opts->{'terminate_on_signal'}, sub { $got_sig_quit = time(); });
+ }
+
+ my $child_child_pid;
+ my $now;
+ my $previous_monotonic_value;
+
+ while (!$child_finished) {
+ $previous_monotonic_value = $now;
+ $now = get_monotonic_time();
+
+ adjust_monotonic_start_time([\$start_time, \$last_parent_check, \$got_sig_child], $now, $previous_monotonic_value);
+
+ if ($opts->{'terminate_on_parent_sudden_death'}) {
+ # check for parent once each five seconds
+ if ($now > $last_parent_check + 5) {
+ if (getppid() eq "1") {
+ kill_gently ($pid, {
+ 'first_kill_type' => 'process_group',
+ 'final_kill_type' => 'process_group',
+ 'wait_time' => $opts->{'terminate_wait_time'}
+ });
+ $parent_died = 1;
+ }
+
+ $last_parent_check = $now;
+ }
+ }
+
+ # user specified timeout
+ if ($opts->{'timeout'}) {
+ if ($now > $start_time + $opts->{'timeout'}) {
+ kill_gently ($pid, {
+ 'first_kill_type' => 'process_group',
+ 'final_kill_type' => 'process_group',
+ 'wait_time' => $opts->{'terminate_wait_time'}
+ });
+ $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 ($now > $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;
+ }
+ }
+
+ if ($got_sig_quit) {
+ kill_gently ($pid, {
+ 'first_kill_type' => 'process_group',
+ 'final_kill_type' => 'process_group',
+ 'wait_time' => $opts->{'terminate_wait_time'}
+ });
+ $child_finished = 1;
+ }
+
+ my $waitpid = waitpid($pid, POSIX::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;
+ }
+
+ my $ready_fds = [];
+ push @{$ready_fds}, $select->can_read(1/100);
+
+ READY_FDS: while (scalar(@{$ready_fds})) {
+ my $fd = shift @{$ready_fds};
+ $ready_fds = [grep {$_ ne $fd} @{$ready_fds}];
+
+ my $str = $child_output->{$fd->fileno};
+ Carp::confess("child stream not found: $fd") unless $str;
+
+ my $data = "";
+ my $count = $fd->sysread($data, $str->{'block_size'});
+
+ if ($count) {
+ # extract all the available lines and store the rest in temporary buffer
+ if ($data =~ /(.+\n)([^\n]*)/so) {
+ $data = $str->{'scalar_buffer'} . $1;
+ $str->{'scalar_buffer'} = $2 || "";
+ }
+ else {
+ $str->{'scalar_buffer'} .= $data;
+ $data = "";
+ }
+ }
+ elsif ($count eq 0) {
+ $select->remove($fd);
+ $fd->close();
+ if ($str->{'scalar_buffer'}) {
+ $data = $str->{'scalar_buffer'} . "\n";
+ }
+ }
+ else {
+ Carp::confess("error during sysread on [$fd]: " . $!);
+ }
+
+ # $data contains only full lines (or last line if it was unfinished read
+ # or now new-line in the output of the child); dat is processed
+ # according to the "protocol" of socket
+ if ($str->{'protocol'} eq 'info') {
+ if ($data =~ /^spawned ([0-9]+?)\n(.*?)/so) {
+ $child_child_pid = $1;
+ $data = $2;
+ }
+ if ($data =~ /^reaped ([0-9]+?)\n(.*?)/so) {
+ $child_child_pid = undef;
+ $data = $2;
+ }
+ if ($data =~ /^[\d]+ killed with ([0-9]+?)\n(.*?)/so) {
+ $child_killed_by_signal = $1;
+ $data = $2;
+ }
+
+ # we don't expect any other data in info socket, so it's
+ # some strange violation of protocol, better know about this
+ if ($data) {
+ Carp::confess("info protocol violation: [$data]");
+ }
+ }
+ if ($str->{'protocol'} eq 'stdout') {
+ if (!$opts->{'discard_output'}) {
+ $child_stdout .= $data;
+ $child_merged .= $data;
+ }
+
+ if ($opts->{'stdout_handler'} && ref($opts->{'stdout_handler'}) eq 'CODE') {
+ $opts->{'stdout_handler'}->($data);
+ }
+ }
+ if ($str->{'protocol'} eq 'stderr') {
+ if (!$opts->{'discard_output'}) {
+ $child_stderr .= $data;
+ $child_merged .= $data;
+ }
+
+ if ($opts->{'stderr_handler'} && ref($opts->{'stderr_handler'}) eq 'CODE') {
+ $opts->{'stderr_handler'}->($data);
+ }
+ }
+
+ # process may finish (waitpid returns -1) before
+ # we've read all of its output because of buffering;
+ # so try to read all the way it is possible to read
+ # in such case - this shouldn't be too much (unless
+ # the buffer size is HUGE -- should introduce
+ # another counter in such case, maybe later)
+ #
+ push @{$ready_fds}, $select->can_read(1/100) if $child_finished;
+ }
+
+ if ($opts->{'wait_loop_callback'} && ref($opts->{'wait_loop_callback'}) eq 'CODE') {
+ $opts->{'wait_loop_callback'}->();
+ }
+
+ 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 brutally.
+ #
+ if ($child_child_pid) {
+ kill_gently($child_child_pid);
+ }
+
+ # in case there are forks in child which
+ # do not forward or process signals (TERM) correctly
+ # kill whole child process group, effectively trying
+ # not to return with some children or their parts still running
+ #
+ # to be more accurate -- we need to be sure
+ # that this is process group created by our child
+ # (and not some other process group with the same pgid,
+ # created just after death of our child) -- fortunately
+ # this might happen only when process group ids
+ # are reused quickly (there are lots of processes
+ # spawning new process groups for example)
+ #
+ if ($opts->{'clean_up_children'}) {
+ kill(-9, $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,
+ 'parent_died' => $parent_died,
+ 'killed_by_signal' => $child_killed_by_signal,
+ 'child_pgid' => $pid,
+ 'cmd' => $cmd,
+ };
+
+ 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->{'parent_died'}) {
+ $err_msg .= "parent died\n";
+ }
+ if ($o->{'stdout'} && !$opts->{'non_empty_stdout_ok'}) {
+ $err_msg .= "stdout:\n" . $o->{'stdout'} . "\n";
+ }
+ if ($o->{'stderr'}) {
+ $err_msg .= "stderr:\n" . $o->{'stderr'} . "\n";
+ }
+ if ($o->{'killed_by_signal'}) {
+ $err_msg .= "killed by signal [" . $o->{'killed_by_signal'} . "]\n";
+ }
+ $o->{'err_msg'} = $err_msg;
+
+ if ($orig_sig_child) {
+ $SIG{'CHLD'} = $orig_sig_child;
+ }
+ else {
+ delete($SIG{'CHLD'});
+ }
+
+ uninstall_signals();
+
+ return $o;
+ }
+ else {
+ Carp::confess("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() || Carp::confess("Error running setsid: " . $!);
+
+ if ($opts->{'child_BEGIN'} && ref($opts->{'child_BEGIN'}) eq 'CODE') {
+ $opts->{'child_BEGIN'}->();
+ }
+
+ close($child_stdout_socket);
+ close($child_stderr_socket);
+ close($child_info_socket);
+
+ my $child_exit_code;
+
+ # allow both external programs
+ # and internal perl calls
+ if (!ref($cmd)) {
+ $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'},
+ });
+ }
+ elsif (ref($cmd) eq 'CODE') {
+ # reopen STDOUT and STDERR for child code:
+ # https://rt.cpan.org/Ticket/Display.html?id=85912
+ open STDOUT, '>&', $parent_stdout_socket || Carp::confess("Unable to reopen STDOUT: $!\n");
+ open STDERR, '>&', $parent_stderr_socket || Carp::confess("Unable to reopen STDERR: $!\n");
+
+ $child_exit_code = $cmd->({
+ 'opts' => $opts,
+ 'parent_info' => $parent_info_socket,
+ 'parent_stdout' => $parent_stdout_socket,
+ 'parent_stderr' => $parent_stderr_socket,
+ 'child_stdin' => $opts->{'child_stdin'},
+ });
+ }
+ else {
+ print $parent_stderr_socket "Invalid command reference: " . ref($cmd) . "\n";
+ $child_exit_code = 1;
+ }
+
+ close($parent_stdout_socket);
+ close($parent_stderr_socket);
+ close($parent_info_socket);
+
+ if ($opts->{'child_END'} && ref($opts->{'child_END'}) eq 'CODE') {
+ $opts->{'child_END'}->();
+ }
+
+ $| = 1;
+ POSIX::_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
+ if ( $ALLOW_NULL_ARGS ) {
+ $cmd = [ grep { defined } @$cmd ] if ref $cmd;
+ }
+ else {
+ $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;
+
+ ### don't 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( !IS_WIN32 and $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
+
+ my $method = IS_WIN32 ? '_open3_run_win32' : '_open3_run';
+
+ $ok = $self->$method(
+ $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_win32 {
+ my $self = shift;
+ my $cmd = shift;
+ my $outhand = shift;
+ my $errhand = shift;
+
+ require Socket;
+
+ my $pipe = sub {
+ socketpair($_[0], $_[1], &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC)
+ or return undef;
+ shutdown($_[0], 1); # No more writing for reader
+ shutdown($_[1], 0); # No more reading for writer
+ return 1;
+ };
+
+ my $open3 = sub {
+ local (*TO_CHLD_R, *TO_CHLD_W);
+ local (*FR_CHLD_R, *FR_CHLD_W);
+ local (*FR_CHLD_ERR_R, *FR_CHLD_ERR_W);
+
+ $pipe->(*TO_CHLD_R, *TO_CHLD_W ) or die $^E;
+ $pipe->(*FR_CHLD_R, *FR_CHLD_W ) or die $^E;
+ $pipe->(*FR_CHLD_ERR_R, *FR_CHLD_ERR_W) or die $^E;
+
+ my $pid = IPC::Open3::open3('>&TO_CHLD_R', '<&FR_CHLD_W', '<&FR_CHLD_ERR_W', @_);
+
+ return ( $pid, *TO_CHLD_W, *FR_CHLD_R, *FR_CHLD_ERR_R );
+ };
+
+ $cmd = [ grep { defined && length } @$cmd ] if ref $cmd;
+ $cmd = $self->__fix_cmd_whitespace_and_special_chars( $cmd );
+
+ my ($pid, $to_chld, $fr_chld, $fr_chld_err) =
+ $open3->( ( ref $cmd ? @$cmd : $cmd ) );
+
+ my $in_sel = IO::Select->new();
+ my $out_sel = IO::Select->new();
+
+ my %objs;
+
+ $objs{ fileno( $fr_chld ) } = $outhand;
+ $objs{ fileno( $fr_chld_err ) } = $errhand;
+ $in_sel->add( $fr_chld );
+ $in_sel->add( $fr_chld_err );
+
+ close($to_chld);
+
+ while ($in_sel->count() + $out_sel->count()) {
+ my ($ins, $outs) = IO::Select::select($in_sel, $out_sel, undef);
+
+ for my $fh (@$ins) {
+ my $obj = $objs{ fileno($fh) };
+ my $buf;
+ my $bytes_read = sysread($fh, $buf, 64*1024 ); #, length($buf));
+ if (!$bytes_read) {
+ $in_sel->remove($fh);
+ }
+ else {
+ $obj->( "$buf" );
+ }
+ }
+
+ for my $fh (@$outs) {
+ }
+ }
+
+ waitpid($pid, 0);
+
+ ### some error occurred
+ if( $? ) {
+ $self->error( $self->_pp_child_error( $cmd, $? ) );
+ $self->ok( 0 );
+ return;
+ } else {
+ return $self->ok( 1 );
+ }
+}
+
+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 );
+
+ ### don't 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 explicit 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::shellwords() 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
+ ### don't 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 defined( $arg ) && length( $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 compatibility. 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 compatibility. 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 %2, %3 coredump",
+ $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;
+
+__END__
+
+=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
+separate arguments to the C<echo> function.
+
+=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 L<"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 L<"Global Variables"> section), try to execute the command using
+L<IPC::Open3>. Buffers will be available on all platforms,
+interactive commands will still execute cleanly, and also your verbosity
+settings will be adhered to nicely;
+
+=item *
+
+Otherwise, if you have the C<verbose> argument set to true, we fall back
+to a simple C<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
+C<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.
+
+=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.
+
+=head2 $IPC::Cmd::INSTANCES
+
+This variable controls whether C<can_run> will return all instances of
+the binary it finds in the C<PATH> when called in a list context.
+
+Defaults to false, set to true to enable the described behaviour.
+
+=head2 $IPC::Cmd::ALLOW_NULL_ARGS
+
+This variable controls whether C<run> will remove any empty/null arguments
+it finds in command arguments.
+
+Defaults to false, so it will remove null arguments. Set to true to allow
+them.
+
+=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 an array reference, special rules apply:
+
+If your command contains B<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 lose the significance of the whitespace.
+Therefore, 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 are extra or spurious whitespaces 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, e.g. 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 '13' on STDOUT and '24' on STDERR, instead of
+
+ 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
+
+L<IPC::Run>, L<IPC::Open3>
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to James Mastros and Martijn van der Streek for their
+help in getting L<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
+
+Original author: Jos Boumans E<lt>kane@cpan.orgE<gt>.
+Current maintainer: Chris Williams E<lt>bingos@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/systems/texlive/tlnet/tlpkg/tlperl/lib/IPC/Open2.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IPC/Open2.pm
new file mode 100644
index 0000000000..9e27144571
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IPC/Open2.pm
@@ -0,0 +1,120 @@
+package IPC::Open2;
+
+use strict;
+our ($VERSION, @ISA, @EXPORT);
+
+require 5.000;
+require Exporter;
+
+$VERSION = 1.04;
+@ISA = qw(Exporter);
+@EXPORT = qw(open2);
+
+=head1 NAME
+
+IPC::Open2 - open a process for both reading and writing using open2()
+
+=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', $_[1], $_[0], '>&STDERR', @_[2 .. $#_]);
+}
+
+1
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/IPC/Open3.pm b/systems/texlive/tlnet/tlpkg/tlperl/lib/IPC/Open3.pm
new file mode 100644
index 0000000000..e5924a30a6
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/IPC/Open3.pm
@@ -0,0 +1,433 @@
+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.20';
+@ISA = qw(Exporter);
+@EXPORT = qw(open3);
+
+=head1 NAME
+
+IPC::Open3 - open a process for reading, writing, and error handling using open3()
+
+=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 under Windows and OS/2, 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 capture.
+
+=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>
+#
+# 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 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 bareword while compiling under strict subs.
+
+sub xopen {
+ open $_[0], $_[1], @_[2..$#_] and return;
+ local $" = ', ';
+ carp "$Me: open(@_) failed: $!";
+}
+
+sub xclose {
+ $_[0] =~ /\A=?(\d+)\z/
+ ? do { my $fh; open($fh, $_[1] . '&=' . $1) and close($fh); }
+ : close $_[0]
+ or croak "$Me: close($_[0]) failed: $!";
+}
+
+sub xfileno {
+ return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd
+ return fileno $_[0];
+}
+
+use constant FORCE_DEBUG_SPAWN => 0;
+use constant DO_SPAWN => $^O eq 'os2' || $^O eq 'MSWin32' || FORCE_DEBUG_SPAWN;
+
+sub _open3 {
+ local $Me = shift;
+
+ # simulate autovivification of filehandles because
+ # it's too ugly to use @_ throughout to make perl do it for us
+ # tchrist 5-Mar-00
+
+ # Historically, open3(undef...) has silently worked, so keep
+ # it working.
+ splice @_, 0, 1, undef if \$_[0] == \undef;
+ splice @_, 1, 1, undef if \$_[1] == \undef;
+ unless (eval {
+ $_[0] = gensym unless defined $_[0] && length $_[0];
+ $_[1] = gensym unless defined $_[1] && length $_[1];
+ 1; })
+ {
+ # must strip crud for croak to add back, or looks ugly
+ $@ =~ s/(?<=value attempted) at .*//s;
+ croak "$Me: $@";
+ }
+
+ my @handles = ({ mode => '<', handle => \*STDIN },
+ { mode => '>', handle => \*STDOUT },
+ { mode => '>', handle => \*STDERR },
+ );
+
+ foreach (@handles) {
+ $_->{parent} = shift;
+ $_->{open_as} = gensym;
+ }
+
+ if (@_ > 1 and $_[0] eq '-') {
+ croak "Arguments don't make sense when the command is '-'"
+ }
+
+ $handles[2]{parent} ||= $handles[1]{parent};
+ $handles[2]{dup_of_out} = $handles[1]{parent} eq $handles[2]{parent};
+
+ my $package;
+ foreach (@handles) {
+ $_->{dup} = ($_->{parent} =~ s/^[<>]&//);
+
+ if ($_->{parent} !~ /\A=?(\d+)\z/) {
+ # force unqualified filehandles into caller's package
+ $package //= caller 1;
+ $_->{parent} = qualify $_->{parent}, $package;
+ }
+
+ next if $_->{dup} or $_->{dup_of_out};
+ if ($_->{mode} eq '<') {
+ xpipe $_->{open_as}, $_->{parent};
+ } else {
+ xpipe $_->{parent}, $_->{open_as};
+ }
+ }
+
+ my $kidpid;
+ if (!DO_SPAWN) {
+ # Used to communicate exec failures.
+ xpipe my $stat_r, my $stat_w;
+
+ $kidpid = fork;
+ croak "$Me: fork failed: $!" unless defined $kidpid;
+ if ($kidpid == 0) { # Kid
+ eval {
+ # A tie in the parent should not be allowed to cause problems.
+ untie *STDIN;
+ untie *STDOUT;
+ untie *STDERR;
+
+ close $stat_r;
+ require Fcntl;
+ my $flags = fcntl $stat_w, &Fcntl::F_GETFD, 0;
+ croak "$Me: fcntl failed: $!" unless $flags;
+ fcntl $stat_w, &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC
+ or croak "$Me: fcntl failed: $!";
+
+ # 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 (!$handles[2]{dup_of_out} && $handles[2]{dup}
+ && xfileno($handles[2]{parent}) == fileno \*STDOUT) {
+ my $tmp = gensym;
+ xopen($tmp, '>&', $handles[2]{parent});
+ $handles[2]{parent} = $tmp;
+ }
+
+ foreach (@handles) {
+ if ($_->{dup_of_out}) {
+ xopen \*STDERR, ">&STDOUT"
+ if defined fileno STDERR && fileno STDERR != fileno STDOUT;
+ } elsif ($_->{dup}) {
+ xopen $_->{handle}, $_->{mode} . '&', $_->{parent}
+ if fileno $_->{handle} != xfileno($_->{parent});
+ } else {
+ xclose $_->{parent}, $_->{mode};
+ xopen $_->{handle}, $_->{mode} . '&=',
+ fileno $_->{open_as};
+ }
+ }
+ return 1 if ($_[0] eq '-');
+ exec @_ or do {
+ local($")=(" ");
+ croak "$Me: exec of @_ failed: $!";
+ };
+ } and do {
+ close $stat_w;
+ return 0;
+ };
+
+ my $bang = 0+$!;
+ my $err = $@;
+ utf8::encode $err if $] >= 5.008;
+ print $stat_w pack('IIa*', $bang, length($err), $err);
+ close $stat_w;
+
+ eval { require POSIX; POSIX::_exit(255); };
+ exit 255;
+ }
+ else { # Parent
+ close $stat_w;
+ my $to_read = length(pack('I', 0)) * 2;
+ my $bytes_read = read($stat_r, my $buf = '', $to_read);
+ if ($bytes_read) {
+ (my $bang, $to_read) = unpack('II', $buf);
+ read($stat_r, my $err = '', $to_read);
+ waitpid $kidpid, 0; # Reap child which should have exited
+ if ($err) {
+ utf8::decode $err if $] >= 5.008;
+ } else {
+ $err = "$Me: " . ($! = $bang);
+ }
+ $! = $bang;
+ die($err);
+ }
+ }
+ }
+ else { # DO_SPAWN
+ # All the bookkeeping of coincidence between handles is
+ # handled in spawn_with_handles.
+
+ my @close;
+
+ foreach (@handles) {
+ if ($_->{dup_of_out}) {
+ $_->{open_as} = $handles[1]{open_as};
+ } elsif ($_->{dup}) {
+ $_->{open_as} = $_->{parent} =~ /\A[0-9]+\z/
+ ? $_->{parent} : \*{$_->{parent}};
+ push @close, $_->{open_as};
+ } else {
+ push @close, \*{$_->{parent}}, $_->{open_as};
+ }
+ }
+ require IO::Pipe;
+ $kidpid = eval {
+ spawn_with_handles(\@handles, \@close, @_);
+ };
+ die "$Me: $@" if $@;
+ }
+
+ foreach (@handles) {
+ next if $_->{dup} or $_->{dup_of_out};
+ xclose $_->{open_as}, $_->{mode};
+ }
+
+ # If the write handle is a dup give it away entirely, close my copy
+ # of it.
+ xclose $handles[0]{parent}, $handles[0]{mode} if $handles[0]{dup};
+
+ select((select($handles[0]{parent}), $| = 1)[0]); # unbuffer pipe
+ $kidpid;
+}
+
+sub open3 {
+ if (@_ < 4) {
+ local $" = ', ';
+ croak "open3(@_): not enough arguments";
+ }
+ return _open3 'open3', @_
+}
+
+sub spawn_with_handles {
+ my $fds = shift; # Fields: handle, mode, open_as
+ my $close_in_child = shift;
+ my ($fd, %saved, @errs);
+
+ foreach $fd (@$fds) {
+ $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode});
+ $saved{fileno $fd->{handle}} = $fd->{tmp_copy} if $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:
+ my $open_as = $fd->{open_as};
+ my $fileno = fileno($open_as);
+ $fd->{handle}->fdopen(defined($fileno)
+ ? $saved{$fileno} || $open_as
+ : $open_as,
+ $fd->{mode});
+ }
+ unless ($^O eq 'MSWin32') {
+ require Fcntl;
+ # Stderr may be redirected below, so we save the err text:
+ foreach $fd (@$close_in_child) {
+ next unless fileno $fd;
+ fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!"
+ unless $saved{fileno $fd}; # Do not close what we redirect!
+ }
+ }
+
+ my $pid;
+ unless (@errs) {
+ if (FORCE_DEBUG_SPAWN) {
+ pipe my $r, my $w or die "Pipe failed: $!";
+ $pid = fork;
+ die "Fork failed: $!" unless defined $pid;
+ if (!$pid) {
+ { no warnings; exec @_ }
+ print $w 0 + $!;
+ close $w;
+ require POSIX;
+ POSIX::_exit(255);
+ }
+ close $w;
+ my $bad = <$r>;
+ if (defined $bad) {
+ $! = $bad;
+ undef $pid;
+ }
+ } else {
+ $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
+ }
+ if($@) {
+ push @errs, "IO::Pipe: Can't spawn-NOWAIT: $@";
+ } elsif(!$pid || $pid < 0) {
+ push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!";
+ }
+ }
+
+ # Do this in reverse, so that STDERR is restored first:
+ foreach $fd (reverse @$fds) {
+ $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode});
+ }
+ foreach (values %saved) {
+ $_->close or croak "Can't close: $!";
+ }
+ croak join "\n", @errs if @errs;
+ return $pid;
+}
+
+1; # so require is happy