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