summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/IPC
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 12:20:49 +0000
commit316ee97c621496b0fe3267f57cce81bee44ca1e6 (patch)
treecb2cab1192b4f58a7971af19b213e980bceda4b4 /Master/tlpkg/tlperl/lib/IPC
parentcd0f87b5d39480d85ad9bd4ee37f520f75bed560 (diff)
Moving old tlperl prior to committing new one
git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/IPC')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IPC/Cmd.pm1646
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IPC/Open2.pm121
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IPC/Open3.pm376
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IPC/Run3.pm850
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IPC/Run3/ProfArrayBuffer.pm86
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IPC/Run3/ProfLogReader.pm157
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IPC/Run3/ProfLogger.pm139
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IPC/Run3/ProfPP.pm156
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IPC/Run3/ProfReporter.pm256
-rwxr-xr-xMaster/tlpkg/tlperl/lib/IPC/System/Simple.pm1076
10 files changed, 0 insertions, 4863 deletions
diff --git a/Master/tlpkg/tlperl/lib/IPC/Cmd.pm b/Master/tlpkg/tlperl/lib/IPC/Cmd.pm
deleted file mode 100755
index e60c93fda24..00000000000
--- a/Master/tlpkg/tlperl/lib/IPC/Cmd.pm
+++ /dev/null
@@ -1,1646 +0,0 @@
-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/lib/IPC/Open2.pm b/Master/tlpkg/tlperl/lib/IPC/Open2.pm
deleted file mode 100755
index 4fc016a821a..00000000000
--- a/Master/tlpkg/tlperl/lib/IPC/Open2.pm
+++ /dev/null
@@ -1,121 +0,0 @@
-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/lib/IPC/Open3.pm b/Master/tlpkg/tlperl/lib/IPC/Open3.pm
deleted file mode 100755
index 815674b5d4f..00000000000
--- a/Master/tlpkg/tlperl/lib/IPC/Open3.pm
+++ /dev/null
@@ -1,376 +0,0 @@
-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/lib/IPC/Run3.pm b/Master/tlpkg/tlperl/lib/IPC/Run3.pm
deleted file mode 100755
index 008755112a6..00000000000
--- a/Master/tlpkg/tlperl/lib/IPC/Run3.pm
+++ /dev/null
@@ -1,850 +0,0 @@
-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/lib/IPC/Run3/ProfArrayBuffer.pm b/Master/tlpkg/tlperl/lib/IPC/Run3/ProfArrayBuffer.pm
deleted file mode 100755
index 15c58ea0b20..00000000000
--- a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfArrayBuffer.pm
+++ /dev/null
@@ -1,86 +0,0 @@
-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/lib/IPC/Run3/ProfLogReader.pm b/Master/tlpkg/tlperl/lib/IPC/Run3/ProfLogReader.pm
deleted file mode 100755
index 987b3a24f50..00000000000
--- a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfLogReader.pm
+++ /dev/null
@@ -1,157 +0,0 @@
-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/lib/IPC/Run3/ProfLogger.pm b/Master/tlpkg/tlperl/lib/IPC/Run3/ProfLogger.pm
deleted file mode 100755
index 8bbc06a61b6..00000000000
--- a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfLogger.pm
+++ /dev/null
@@ -1,139 +0,0 @@
-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/lib/IPC/Run3/ProfPP.pm b/Master/tlpkg/tlperl/lib/IPC/Run3/ProfPP.pm
deleted file mode 100755
index 112c3a2e8d6..00000000000
--- a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfPP.pm
+++ /dev/null
@@ -1,156 +0,0 @@
-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/lib/IPC/Run3/ProfReporter.pm b/Master/tlpkg/tlperl/lib/IPC/Run3/ProfReporter.pm
deleted file mode 100755
index 2fa9060e1e4..00000000000
--- a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfReporter.pm
+++ /dev/null
@@ -1,256 +0,0 @@
-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/lib/IPC/System/Simple.pm b/Master/tlpkg/tlperl/lib/IPC/System/Simple.pm
deleted file mode 100755
index 73172c5531f..00000000000
--- a/Master/tlpkg/tlperl/lib/IPC/System/Simple.pm
+++ /dev/null
@@ -1,1076 +0,0 @@
-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