From 316ee97c621496b0fe3267f57cce81bee44ca1e6 Mon Sep 17 00:00:00 2001 From: Siep Kroonenberg Date: Thu, 17 Feb 2011 12:20:49 +0000 Subject: Moving old tlperl prior to committing new one git-svn-id: svn://tug.org/texlive/trunk@21422 c570f23f-e606-0410-a88d-b1316a301751 --- Master/tlpkg/tlperl/lib/IPC/Cmd.pm | 1646 -------------------- Master/tlpkg/tlperl/lib/IPC/Open2.pm | 121 -- Master/tlpkg/tlperl/lib/IPC/Open3.pm | 376 ----- Master/tlpkg/tlperl/lib/IPC/Run3.pm | 850 ---------- .../tlpkg/tlperl/lib/IPC/Run3/ProfArrayBuffer.pm | 86 - Master/tlpkg/tlperl/lib/IPC/Run3/ProfLogReader.pm | 157 -- Master/tlpkg/tlperl/lib/IPC/Run3/ProfLogger.pm | 139 -- Master/tlpkg/tlperl/lib/IPC/Run3/ProfPP.pm | 156 -- Master/tlpkg/tlperl/lib/IPC/Run3/ProfReporter.pm | 256 --- Master/tlpkg/tlperl/lib/IPC/System/Simple.pm | 1076 ------------- 10 files changed, 4863 deletions(-) delete mode 100755 Master/tlpkg/tlperl/lib/IPC/Cmd.pm delete mode 100755 Master/tlpkg/tlperl/lib/IPC/Open2.pm delete mode 100755 Master/tlpkg/tlperl/lib/IPC/Open3.pm delete mode 100755 Master/tlpkg/tlperl/lib/IPC/Run3.pm delete mode 100755 Master/tlpkg/tlperl/lib/IPC/Run3/ProfArrayBuffer.pm delete mode 100755 Master/tlpkg/tlperl/lib/IPC/Run3/ProfLogReader.pm delete mode 100755 Master/tlpkg/tlperl/lib/IPC/Run3/ProfLogger.pm delete mode 100755 Master/tlpkg/tlperl/lib/IPC/Run3/ProfPP.pm delete mode 100755 Master/tlpkg/tlperl/lib/IPC/Run3/ProfReporter.pm delete mode 100755 Master/tlpkg/tlperl/lib/IPC/System/Simple.pm (limited to 'Master/tlpkg/tlperl/lib/IPC') diff --git a/Master/tlpkg/tlperl/lib/IPC/Cmd.pm b/Master/tlpkg/tlperl/lib/IPC/Cmd.pm deleted file mode 100755 index e60c93fda24..00000000000 --- a/Master/tlpkg/tlperl/lib/IPC/Cmd.pm +++ /dev/null @@ -1,1646 +0,0 @@ -package IPC::Cmd; - -use strict; - -BEGIN { - - use constant IS_VMS => $^O eq 'VMS' ? 1 : 0; - use constant IS_WIN32 => $^O eq 'MSWin32' ? 1 : 0; - use constant IS_WIN98 => (IS_WIN32 and !Win32::IsWinNT()) ? 1 : 0; - use constant ALARM_CLASS => __PACKAGE__ . '::TimeOut'; - use constant SPECIAL_CHARS => qw[< > | &]; - use constant QUOTE => do { IS_WIN32 ? q["] : q['] }; - - use Exporter (); - use vars qw[ @ISA $VERSION @EXPORT_OK $VERBOSE $DEBUG - $USE_IPC_RUN $USE_IPC_OPEN3 $CAN_USE_RUN_FORKED $WARN - ]; - - $VERSION = '0.54'; - $VERBOSE = 0; - $DEBUG = 0; - $WARN = 1; - $USE_IPC_RUN = IS_WIN32 && !IS_WIN98; - $USE_IPC_OPEN3 = not IS_VMS; - - $CAN_USE_RUN_FORKED = 0; - eval { - require POSIX; POSIX->import(); - require IPC::Open3; IPC::Open3->import(); - require IO::Select; IO::Select->import(); - require IO::Handle; IO::Handle->import(); - require FileHandle; FileHandle->import(); - require Socket; Socket->import(); - require Time::HiRes; Time::HiRes->import(); - }; - $CAN_USE_RUN_FORKED = $@ || !IS_VMS && !IS_WIN32; - - @ISA = qw[Exporter]; - @EXPORT_OK = qw[can_run run run_forked QUOTE]; -} - -require Carp; -use File::Spec; -use Params::Check qw[check]; -use Text::ParseWords (); # import ONLY if needed! -use Module::Load::Conditional qw[can_load]; -use Locale::Maketext::Simple Style => 'gettext'; - -=pod - -=head1 NAME - -IPC::Cmd - finding and running system commands made easy - -=head1 SYNOPSIS - - use IPC::Cmd qw[can_run run run_forked]; - - my $full_path = can_run('wget') or warn 'wget is not installed!'; - - ### commands can be arrayrefs or strings ### - my $cmd = "$full_path -b theregister.co.uk"; - my $cmd = [$full_path, '-b', 'theregister.co.uk']; - - ### in scalar context ### - my $buffer; - if( scalar run( command => $cmd, - verbose => 0, - buffer => \$buffer, - timeout => 20 ) - ) { - print "fetched webpage successfully: $buffer\n"; - } - - - ### in list context ### - my( $success, $error_code, $full_buf, $stdout_buf, $stderr_buf ) = - run( command => $cmd, verbose => 0 ); - - if( $success ) { - print "this is what the command printed:\n"; - print join "", @$full_buf; - } - - ### check for features - print "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3; - print "IPC::Run available: " . IPC::Cmd->can_use_ipc_run; - print "Can capture buffer: " . IPC::Cmd->can_capture_buffer; - - ### don't have IPC::Cmd be verbose, ie don't print to stdout or - ### stderr when running commands -- default is '0' - $IPC::Cmd::VERBOSE = 0; - - -=head1 DESCRIPTION - -IPC::Cmd allows you to run commands, interactively if desired, -platform independent but have them still work. - -The C function can tell you if a certain binary is installed -and if so where, whereas the C 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 is available. -If the verbose flag is passed, it will print diagnostic messages -if C 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 is available. -If the verbose flag is passed, it will print diagnostic messages -if C 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 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 is capable of -providing C on the current platform. - -=head1 FUNCTIONS - -=head2 $path = can_run( PROGRAM ); - -C takes but a single argument: the name of a binary you wish -to locate. C works much like the unix binary C or the bash -command C, which scans through your path, looking for the requested -binary . - -Unlike C and C, 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 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 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 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 to be installed or your system able to work with -C). - -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 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 call. If the timeout is triggered, the -C in the return value will be set to an object of the -C class. See the C section below for -details. - -Defaults to C<0>, meaning no timeout is set. - -=back - -C will return a simple C or C 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 for details on -what they can contain. -If the error was a timeout, the C will be prefixed with -the string C, 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 installed, -or if your system is able to work with C -- See below). -This element will be C 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 installed, -or if your system is able to work with C -- See below). -This element will be C 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 installed, -or if your system is able to work with C -- See below). -This element will be C if this is not the case. - -=back - -See the C Section below to see how C 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 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 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 - -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 - -Specify some text that will be passed into C of the executed program. - -=item C - -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 - -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 will return a HASHREF with the following keys: - -=over - -=item C - -The exit code of the executed program. - -=item C - -The number of seconds the program ran for before being terminated, or 0 if no timeout occurred. - -=item C - -Holds the standard output of the executed command -(or empty string if there were no stdout output; it's always defined!) - -=item C - -Holds the standard error of the executed command -(or empty string if there were no stderr output; it's always defined!) - -=item C - -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 - -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 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 is treated as a string, rather than two -seperate arguments to the C function. - -__END__ - -=head1 HOW IT WORKS - -C will try to execute your command using the following logic: - -=over 4 - -=item * - -If you have C installed, and the variable C<$IPC::Cmd::USE_IPC_RUN> -is set to true (See the C 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 Section), try to execute the command using -C. Buffers will be available on all platforms except C, -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 -when available and suitable. Defaults to true if you are on C. - -=head2 $IPC::Cmd::USE_IPC_OPEN3 - -This variable controls whether IPC::Cmd will try to use L -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 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 or C, if you provide a string as the -C argument, it is assumed to be appropriately escaped. You can -use the C constant to use as a portable quote character (see above). -However, if you provide and C, special rules apply: - -If your command contains C (< > | &), 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 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, if you provide a string as the C 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 as bug #37532: Unable to interleave -STDOUT and STDERR - -=back - -=head1 See Also - -C, C - -=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 code. - -=head1 BUG REPORTS - -Please report bugs or other issues to Ebug-ipc-cmd@rt.cpan.orgE. - -=head1 AUTHOR - -This module by Jos Boumans Ekane@cpan.orgE. - -=head1 COPYRIGHT - -This library is free software; you may redistribute and/or modify it -under the same terms as Perl itself. - -=cut diff --git a/Master/tlpkg/tlperl/lib/IPC/Open2.pm b/Master/tlpkg/tlperl/lib/IPC/Open2.pm deleted file mode 100755 index 4fc016a821a..00000000000 --- a/Master/tlpkg/tlperl/lib/IPC/Open2.pm +++ /dev/null @@ -1,121 +0,0 @@ -package IPC::Open2; - -use strict; -our ($VERSION, @ISA, @EXPORT); - -require 5.000; -require Exporter; - -$VERSION = 1.03; -@ISA = qw(Exporter); -@EXPORT = qw(open2); - -=head1 NAME - -IPC::Open2, open2 - open a process for both reading and writing - -=head1 SYNOPSIS - - use IPC::Open2; - - $pid = open2(\*CHLD_OUT, \*CHLD_IN, 'some cmd and args'); - # or without using the shell - $pid = open2(\*CHLD_OUT, \*CHLD_IN, 'some', 'cmd', 'and', 'args'); - - # or with handle autovivification - my($chld_out, $chld_in); - $pid = open2($chld_out, $chld_in, 'some cmd and args'); - # or without using the shell - $pid = open2($chld_out, $chld_in, 'some', 'cmd', 'and', 'args'); - - waitpid( $pid, 0 ); - my $child_exit_status = $? >> 8; - -=head1 DESCRIPTION - -The open2() function runs the given $cmd and connects $chld_out for -reading and $chld_in for writing. It's what you think should work -when you try - - $pid = open(HANDLE, "|cmd args|"); - -The write filehandle will have autoflush turned on. - -If $chld_out is a string (that is, a bareword filehandle rather than a glob -or a reference) and it begins with C<< >& >>, then the child will send output -directly to that file handle. If $chld_in is a string that begins with -C<< <& >>, then $chld_in will be closed in the parent, and the child will -read from it directly. In both cases, there will be a dup(2) instead of a -pipe(2) made. - -If either reader or writer is the null string, this will be replaced -by an autogenerated filehandle. If so, you must pass a valid lvalue -in the parameter slot so it can be overwritten in the caller, or -an exception will be raised. - -open2() returns the process ID of the child process. It doesn't return on -failure: it just raises an exception matching C. However, -C 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 when you're done with the process. -Failing to do this can result in an accumulation of defunct or "zombie" -processes. See L 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, both writing -to it and reading from it. This is presumably safe because you -"know" that commands like B will read a line at a time and -output a line at a time. Programs like B 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 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 for an alternative that handles STDERR as well. This -function is really just a wrapper around open3(). - -=cut - -# &open2: tom christiansen, -# -# usage: $pid = open2('rdr', 'wtr', 'some cmd and args'); -# or $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args'); -# -# spawn the given $cmd and connect $rdr for -# reading and $wtr for writing. return pid -# of child, or 0 on failure. -# -# WARNING: this is dangerous, as you may block forever -# unless you are very careful. -# -# $wtr is left unbuffered. -# -# abort program if -# rdr or wtr are null -# a system call fails - -require IPC::Open3; - -sub open2 { - local $Carp::CarpLevel = $Carp::CarpLevel + 1; - return IPC::Open3::_open3('open2', scalar caller, - $_[1], $_[0], '>&STDERR', @_[2 .. $#_]); -} - -1 diff --git a/Master/tlpkg/tlperl/lib/IPC/Open3.pm b/Master/tlpkg/tlperl/lib/IPC/Open3.pm deleted file mode 100755 index 815674b5d4f..00000000000 --- a/Master/tlpkg/tlperl/lib/IPC/Open3.pm +++ /dev/null @@ -1,376 +0,0 @@ -package IPC::Open3; - -use strict; -no strict 'refs'; # because users pass me bareword filehandles -our ($VERSION, @ISA, @EXPORT); - -require Exporter; - -use Carp; -use Symbol qw(gensym qualify); - -$VERSION = 1.04; -@ISA = qw(Exporter); -@EXPORT = qw(open3); - -=head1 NAME - -IPC::Open3, open3 - open a process for reading, writing, and error handling - -=head1 SYNOPSIS - - $pid = open3(\*CHLD_IN, \*CHLD_OUT, \*CHLD_ERR, - 'some cmd and args', 'optarg', ...); - - my($wtr, $rdr, $err); - use Symbol 'gensym'; $err = gensym; - $pid = open3($wtr, $rdr, $err, - 'some cmd and args', 'optarg', ...); - - waitpid( $pid, 0 ); - my $child_exit_status = $? >> 8; - -=head1 DESCRIPTION - -Extremely similar to open2(), open3() spawns the given $cmd and -connects CHLD_OUT for reading from the child, CHLD_IN for writing to -the child, and CHLD_ERR for errors. If CHLD_ERR is false, or the -same file descriptor as CHLD_OUT, then STDOUT and STDERR of the child -are on the same filehandle (this means that an autovivified lexical -cannot be used for the STDERR filehandle, see SYNOPSIS). The CHLD_IN -will have autoflush turned on. - -If CHLD_IN begins with C<< <& >>, then CHLD_IN will be closed in the -parent, and the child will read from it directly. If CHLD_OUT or -CHLD_ERR begins with C<< >& >>, then the child will send output -directly to that filehandle. In both cases, there will be a dup(2) -instead of a pipe(2) made. - -If either reader or writer is the null string, this will be replaced -by an autogenerated filehandle. If so, you must pass a valid lvalue -in the parameter slot so it can be overwritten in the caller, or -an exception will be raised. - -The filehandles may also be integers, in which case they are understood -as file descriptors. - -open3() returns the process ID of the child process. It doesn't return on -failure: it just raises an exception matching C. However, -C 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 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 when you're done with the process. -Failing to do this can result in an accumulation of defunct or "zombie" -processes. See L 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, both writing to it and reading -from it. This is presumably safe because you "know" that commands -like B will read a line at a time and output a line at a time. -Programs like B 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 and continually read and write a line from it. - -=head1 See Also - -=over 4 - -=item L - -Like Open3 but without STDERR catpure. - -=item L - -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 -# derived mostly from &open2 by tom christiansen, -# fixed for 5.001 by Ulrich Kunitz -# 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 -# -# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $ -# -# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...); -# -# spawn the given $cmd and connect rdr for -# reading, wtr for writing, and err for errors. -# if err is '', or the same as rdr, then stdout and -# stderr of the child are on the same fh. returns pid -# of child (or dies on failure). - - -# if wtr begins with '<&', then wtr will be closed in the parent, and -# the child will read from it directly. if rdr or err begins with -# '>&', then the child will send output directly to that fd. In both -# cases, there will be a dup() instead of a pipe() made. - - -# WARNING: this is dangerous, as you may block forever -# unless you are very careful. -# -# $wtr is left unbuffered. -# -# abort program if -# rdr or wtr are null -# a system call fails - -our $Me = 'open3 (bug)'; # you should never see this, it's always localized - -# Fatal.pm needs to be fixed WRT prototypes. - -sub xfork { - my $pid = fork; - defined $pid or croak "$Me: fork failed: $!"; - return $pid; -} - -sub xpipe { - pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!"; -} - -# I tried using a * prototype character for the filehandle but it still -# disallows a bearword while compiling under strict subs. - -sub xopen { - open $_[0], $_[1] or croak "$Me: open($_[0], $_[1]) failed: $!"; -} - -sub xclose { - close $_[0] or croak "$Me: close($_[0]) failed: $!"; -} - -sub fh_is_fd { - return $_[0] =~ /\A=?(\d+)\z/; -} - -sub xfileno { - return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd - return fileno $_[0]; -} - -my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32'; - -sub _open3 { - local $Me = shift; - my($package, $dad_wtr, $dad_rdr, $dad_err, @cmd) = @_; - my($dup_wtr, $dup_rdr, $dup_err, $kidpid); - - if (@cmd > 1 and $cmd[0] eq '-') { - croak "Arguments don't make sense when the command is '-'" - } - - # simulate autovivification of filehandles because - # it's too ugly to use @_ throughout to make perl do it for us - # tchrist 5-Mar-00 - - unless (eval { - $dad_wtr = $_[1] = gensym unless defined $dad_wtr && length $dad_wtr; - $dad_rdr = $_[2] = gensym unless defined $dad_rdr && length $dad_rdr; - 1; }) - { - # must strip crud for croak to add back, or looks ugly - $@ =~ s/(?<=value attempted) at .*//s; - croak "$Me: $@"; - } - - $dad_err ||= $dad_rdr; - - $dup_wtr = ($dad_wtr =~ s/^[<>]&//); - $dup_rdr = ($dad_rdr =~ s/^[<>]&//); - $dup_err = ($dad_err =~ s/^[<>]&//); - - # force unqualified filehandles into caller's package - $dad_wtr = qualify $dad_wtr, $package unless fh_is_fd($dad_wtr); - $dad_rdr = qualify $dad_rdr, $package unless fh_is_fd($dad_rdr); - $dad_err = qualify $dad_err, $package unless fh_is_fd($dad_err); - - my $kid_rdr = gensym; - my $kid_wtr = gensym; - my $kid_err = gensym; - - xpipe $kid_rdr, $dad_wtr if !$dup_wtr; - xpipe $dad_rdr, $kid_wtr if !$dup_rdr; - xpipe $dad_err, $kid_err if !$dup_err && $dad_err ne $dad_rdr; - - $kidpid = $do_spawn ? -1 : xfork; - if ($kidpid == 0) { # Kid - # A tie in the parent should not be allowed to cause problems. - untie *STDIN; - untie *STDOUT; - # If she wants to dup the kid's stderr onto her stdout I need to - # save a copy of her stdout before I put something else there. - if ($dad_rdr ne $dad_err && $dup_err - && xfileno($dad_err) == fileno(STDOUT)) { - my $tmp = gensym; - xopen($tmp, ">&$dad_err"); - $dad_err = $tmp; - } - - if ($dup_wtr) { - xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != xfileno($dad_wtr); - } else { - xclose $dad_wtr; - xopen \*STDIN, "<&=" . fileno $kid_rdr; - } - if ($dup_rdr) { - xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != xfileno($dad_rdr); - } else { - xclose $dad_rdr; - xopen \*STDOUT, ">&=" . fileno $kid_wtr; - } - if ($dad_rdr ne $dad_err) { - if ($dup_err) { - # I have to use a fileno here because in this one case - # I'm doing a dup but the filehandle might be a reference - # (from the special case above). - xopen \*STDERR, ">&" . xfileno($dad_err) - if fileno(STDERR) != xfileno($dad_err); - } else { - xclose $dad_err; - xopen \*STDERR, ">&=" . fileno $kid_err; - } - } else { - xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT); - } - return 0 if ($cmd[0] eq '-'); - local($")=(" "); - exec @cmd or do { - carp "$Me: exec of @cmd failed"; - eval { require POSIX; POSIX::_exit(255); }; - exit 255; - }; - } elsif ($do_spawn) { - # All the bookkeeping of coincidence between handles is - # handled in spawn_with_handles. - - my @close; - if ($dup_wtr) { - $kid_rdr = \*{$dad_wtr}; - push @close, $kid_rdr; - } else { - push @close, \*{$dad_wtr}, $kid_rdr; - } - if ($dup_rdr) { - $kid_wtr = \*{$dad_rdr}; - push @close, $kid_wtr; - } else { - push @close, \*{$dad_rdr}, $kid_wtr; - } - if ($dad_rdr ne $dad_err) { - if ($dup_err) { - $kid_err = \*{$dad_err}; - push @close, $kid_err; - } else { - push @close, \*{$dad_err}, $kid_err; - } - } else { - $kid_err = $kid_wtr; - } - require IO::Pipe; - $kidpid = eval { - spawn_with_handles( [ { mode => 'r', - open_as => $kid_rdr, - handle => \*STDIN }, - { mode => 'w', - open_as => $kid_wtr, - handle => \*STDOUT }, - { mode => 'w', - open_as => $kid_err, - handle => \*STDERR }, - ], \@close, @cmd); - }; - die "$Me: $@" if $@; - } - - xclose $kid_rdr if !$dup_wtr; - xclose $kid_wtr if !$dup_rdr; - xclose $kid_err if !$dup_err && $dad_rdr ne $dad_err; - # If the write handle is a dup give it away entirely, close my copy - # of it. - xclose $dad_wtr if $dup_wtr; - - select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe - $kidpid; -} - -sub open3 { - if (@_ < 4) { - local $" = ', '; - croak "open3(@_): not enough arguments"; - } - return _open3 'open3', scalar caller, @_ -} - -sub spawn_with_handles { - my $fds = shift; # Fields: handle, mode, open_as - my $close_in_child = shift; - my ($fd, $pid, @saved_fh, $saved, %saved, @errs); - require Fcntl; - - foreach $fd (@$fds) { - $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode}); - $saved{fileno $fd->{handle}} = $fd->{tmp_copy}; - } - foreach $fd (@$fds) { - bless $fd->{handle}, 'IO::Handle' - unless eval { $fd->{handle}->isa('IO::Handle') } ; - # If some of handles to redirect-to coincide with handles to - # redirect, we need to use saved variants: - $fd->{handle}->fdopen($saved{fileno $fd->{open_as}} || $fd->{open_as}, - $fd->{mode}); - } - unless ($^O eq 'MSWin32') { - # Stderr may be redirected below, so we save the err text: - foreach $fd (@$close_in_child) { - fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!" - unless $saved{fileno $fd}; # Do not close what we redirect! - } - } - - unless (@errs) { - $pid = eval { system 1, @_ }; # 1 == P_NOWAIT - push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!" if !$pid || $pid < 0; - } - - foreach $fd (@$fds) { - $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode}); - $fd->{tmp_copy}->close or croak "Can't close: $!"; - } - croak join "\n", @errs if @errs; - return $pid; -} - -1; # so require is happy diff --git a/Master/tlpkg/tlperl/lib/IPC/Run3.pm b/Master/tlpkg/tlperl/lib/IPC/Run3.pm deleted file mode 100755 index 008755112a6..00000000000 --- a/Master/tlpkg/tlperl/lib/IPC/Run3.pm +++ /dev/null @@ -1,850 +0,0 @@ -package IPC::Run3; -BEGIN { require 5.006_000; } # i.e. 5.6.0 -use strict; - -=head1 NAME - -IPC::Run3 - run a subprocess with input/ouput redirection - -=head1 VERSION - -version 0.043 - -=cut - -our $VERSION = '0.043'; - -=head1 SYNOPSIS - - use IPC::Run3; # Exports run3() by default - - run3 \@cmd, \$in, \$out, \$err; - -=head1 DESCRIPTION - -This module allows you to run a subprocess and redirect stdin, stdout, -and/or stderr to files and perl data structures. It aims to satisfy 99% of the -need for using C, C, and C -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, C and C, resp.) will be redirected. -Because the redirects come last, this allows C and C to default -to the parent's by just not specifying them -- a common use case. - -C throws an exception if the wrapped C call returned -1 -or anything went wrong with C'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 doesn't mean that the command -had a successful exit code. Hence you should always check C<$?>. - -See L for an option to handle the case of C -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 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 (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 (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 -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) - -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, \<, 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. - -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 and C 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 and -C, 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, C, C - -The value must a "layer" as described in L. -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, C - -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 Ced onto the -previous contents of the array). - -=item C - -If this is true C does B throw an exception if C -returns -1 (cf. L 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 call. - -=back - -=head1 HOW IT WORKS - -=over 4 - -=item (1) - -For each redirector C<$stdin>, C<$stdout>, and C<$stderr>, -C 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 opens the file -in the appropriate mode - -=item * - -in all other cases, C opens a temporary file -(using L) - -=back - -=item (2) - -If C 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 saves the parent's C, C and C by duplicating -them to new filehandles. It duplicates the filehandles from step (1) -to C, C and C, resp. - -=item (4) - -C runs the child by invoking L -with C<$cmd> as specified above. - -=item (5) - -C restores the parent's C, C and C saved in step (3). - -=item (6) - -If C 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 closes all filehandles that it opened explicitly in step (1). - -=back - -Note that when using temporary files, C 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 in a threaded environment if -concurrent calls of C 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 -on Win32 is emulated via Win32 threads and hence I/O mix up is possible -between forked children here (C 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, C, C, C - -=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, C - -=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 (not like C). - -=item - - -does not allow interaction with the subprocess - -=back - -=head2 compared to L - -=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 (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 ECE - -Ricardo SIGNES ECE performed some routine maintenance in -2005, thanks to help from the following ticket and/or patch submitters: Jody -Belka, Roderich Schupp, David Morel, and anonymous others. - -=cut diff --git a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfArrayBuffer.pm b/Master/tlpkg/tlperl/lib/IPC/Run3/ProfArrayBuffer.pm deleted file mode 100755 index 15c58ea0b20..00000000000 --- a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfArrayBuffer.pm +++ /dev/null @@ -1,86 +0,0 @@ -package IPC::Run3::ProfArrayBuffer; - -$VERSION = 0.043; - -=head1 NAME - -IPC::Run3::ProfArrayBuffer - Store profile events in RAM in an array - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -=cut - -use strict; - -=head1 METHODS - -=over - -=item C<< IPC::Run3::ProfArrayBuffer->new() >> - -=cut - -sub new { - my $class = ref $_[0] ? ref shift : shift; - - my $self = bless { @_ }, $class; - - $self->{Events} = []; - - return $self; -} - -=item C<< $buffer->app_call(@events) >> - -=item C<< $buffer->app_exit(@events) >> - -=item C<< $buffer->run_exit(@events) >> - -The three above methods push the given events onto the stack of recorded -events. - -=cut - -for my $subname ( qw(app_call app_exit run_exit) ) { - no strict 'refs'; - *{$subname} = sub { - push @{shift->{Events}}, [ $subname => @_ ]; - }; -} - -=item get_events - -Returns a list of all the events. Each event is an ARRAY reference -like: - - [ "app_call", 1.1, ... ]; - -=cut - -sub get_events { - my $self = shift; - @{$self->{Events}}; -} - -=back - -=head1 LIMITATIONS - -=head1 COPYRIGHT - -Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved - -=head1 LICENSE - -You may use this module under the terms of the BSD, Artistic, or GPL licenses, -any version. - -=head1 AUTHOR - -Barrie Slaymaker Ebarries@slaysys.comE - -=cut - -1; diff --git a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfLogReader.pm b/Master/tlpkg/tlperl/lib/IPC/Run3/ProfLogReader.pm deleted file mode 100755 index 987b3a24f50..00000000000 --- a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfLogReader.pm +++ /dev/null @@ -1,157 +0,0 @@ -package IPC::Run3::ProfLogReader; - -$VERSION = 0.043; - -=head1 NAME - -IPC::Run3::ProfLogReader - read and process a ProfLogger file - -=head1 SYNOPSIS - - use IPC::Run3::ProfLogReader; - - my $reader = IPC::Run3::ProfLogReader->new; ## use "run3.out" - my $reader = IPC::Run3::ProfLogReader->new( Source => $fn ); - - my $profiler = IPC::Run3::ProfPP; ## For example - my $reader = IPC::Run3::ProfLogReader->new( ..., Handler => $p ); - - $reader->read; - $eaderr->read_all; - -=head1 DESCRIPTION - -Reads a log file. Use the filename "-" to read from STDIN. - -=cut - -use strict; - -=head1 METHODS - -=head2 C<< IPC::Run3::ProfLogReader->new( ... ) >> - -=cut - -sub new { - my $class = ref $_[0] ? ref shift : shift; - my $self = bless { @_ }, $class; - - $self->{Source} = "run3.out" - unless defined $self->{Source} && length $self->{Source}; - - my $source = $self->{Source}; - - if ( ref $source eq "GLOB" || UNIVERSAL::isa( $source, "IO::Handle" ) ) { - $self->{FH} = $source; - } - elsif ( $source eq "-" ) { - $self->{FH} = \*STDIN; - } - else { - open PROFILE, "<$self->{Source}" or die "$!: $self->{Source}\n"; - $self->{FH} = *PROFILE{IO}; - } - return $self; -} - - -=head2 C<< $reader->set_handler( $handler ) >> - -=cut - -sub set_handler { $_[0]->{Handler} = $_[1] } - -=head2 C<< $reader->get_handler() >> - -=cut - -sub get_handler { $_[0]->{Handler} } - -=head2 C<< $reader->read() >> - -=cut - -sub read { - my $self = shift; - - my $fh = $self->{FH}; - my @ln = split / /, <$fh>; - - return 0 unless @ln; - return 1 unless $self->{Handler}; - - chomp $ln[-1]; - - ## Ignore blank and comment lines. - return 1 if @ln == 1 && ! length $ln[0] || 0 == index $ln[0], "#"; - - if ( $ln[0] eq "\\app_call" ) { - shift @ln; - my @times = split /,/, pop @ln; - $self->{Handler}->app_call( - [ - map { - s/\\\\/\\/g; - s/\\_/ /g; - $_; - } @ln - ], - @times - ); - } - elsif ( $ln[0] eq "\\app_exit" ) { - shift @ln; - $self->{Handler}->app_exit( pop @ln, @ln ); - } - else { - my @times = split /,/, pop @ln; - $self->{Handler}->run_exit( - [ - map { - s/\\\\/\\/g; - s/\\_/ /g; - $_; - } @ln - ], - @times - ); - } - - return 1; -} - - -=head2 C<< $reader->read_all() >> - -This method reads until there is nothing left to read, and then returns true. - -=cut - -sub read_all { - my $self = shift; - - 1 while $self->read; - - return 1; -} - - -=head1 LIMITATIONS - -=head1 COPYRIGHT - - Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved - -=head1 LICENSE - -You may use this module under the terms of the BSD, Artistic, or GPL licenses, -any version. - -=head1 AUTHOR - -Barrie Slaymaker Ebarries@slaysys.comE - -=cut - -1; diff --git a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfLogger.pm b/Master/tlpkg/tlperl/lib/IPC/Run3/ProfLogger.pm deleted file mode 100755 index 8bbc06a61b6..00000000000 --- a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfLogger.pm +++ /dev/null @@ -1,139 +0,0 @@ -package IPC::Run3::ProfLogger; - -$VERSION = 0.043; - -=head1 NAME - -IPC::Run3::ProfLogger - write profiling data to a log file - -=head1 SYNOPSIS - - use IPC::Run3::ProfLogger; - - my $logger = IPC::Run3::ProfLogger->new; ## write to "run3.out" - my $logger = IPC::Run3::ProfLogger->new( Destination => $fn ); - - $logger->app_call( \@cmd, $time ); - - $logger->run_exit( \@cmd1, @times1 ); - $logger->run_exit( \@cmd1, @times1 ); - - $logger->app_exit( $time ); - -=head1 DESCRIPTION - -Used by IPC::Run3 to write a profiling log file. Does not -generate reports or maintain statistics; its meant to have minimal -overhead. - -Its API is compatible with a tiny subset of the other IPC::Run profiling -classes. - -=cut - -use strict; - -=head1 METHODS - -=head2 C<< IPC::Run3::ProfLogger->new( ... ) >> - -=cut - -sub new { - my $class = ref $_[0] ? ref shift : shift; - my $self = bless { @_ }, $class; - - $self->{Destination} = "run3.out" - unless defined $self->{Destination} && length $self->{Destination}; - - open PROFILE, ">$self->{Destination}" - or die "$!: $self->{Destination}\n"; - binmode PROFILE; - $self->{FH} = *PROFILE{IO}; - - $self->{times} = []; - return $self; -} - -=head2 C<< $logger->run_exit( ... ) >> - -=cut - -sub run_exit { - my $self = shift; - my $fh = $self->{FH}; - print( $fh - join( - " ", - ( - map { - my $s = $_; - $s =~ s/\\/\\\\/g; - $s =~ s/ /_/g; - $s; - } @{shift()} - ), - join( - ",", - @{$self->{times}}, - @_, - ), - ), - "\n" - ); -} - -=head2 C<< $logger->app_exit( $arg ) >> - -=cut - -sub app_exit { - my $self = shift; - my $fh = $self->{FH}; - print $fh "\\app_exit ", shift, "\n"; -} - -=head2 C<< $logger->app_call( $t, @args) >> - -=cut - -sub app_call { - my $self = shift; - my $fh = $self->{FH}; - my $t = shift; - print( $fh - join( - " ", - "\\app_call", - ( - map { - my $s = $_; - $s =~ s/\\\\/\\/g; - $s =~ s/ /\\_/g; - $s; - } @_ - ), - $t, - ), - "\n" - ); -} - -=head1 LIMITATIONS - -=head1 COPYRIGHT - -Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved - -=head1 LICENSE - -You may use this module under the terms of the BSD, Artistic, or GPL licenses, -any version. - -=head1 AUTHOR - -Barrie Slaymaker Ebarries@slaysys.comE - -=cut - -1; diff --git a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfPP.pm b/Master/tlpkg/tlperl/lib/IPC/Run3/ProfPP.pm deleted file mode 100755 index 112c3a2e8d6..00000000000 --- a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfPP.pm +++ /dev/null @@ -1,156 +0,0 @@ -package IPC::Run3::ProfPP; - -$VERSION = 0.043; - -=head1 NAME - -IPC::Run3::ProfPP - Generate reports from IPC::Run3 profiling data - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -Used by IPC::Run3 and/or run3profpp to print out profiling reports for -human readers. Use other classes for extracting data in other ways. - -The output methods are plain text, override these (see the source for -now) to provide other formats. - -This class generates reports on each run3_exit() and app_exit() call. - -=cut - -require IPC::Run3::ProfReporter; -@ISA = qw( IPC::Run3::ProfReporter ); - -use strict; -use POSIX qw( floor ); - -=head1 METHODS - -=head2 C<< IPC::Run3::ProfPP->new() >> - -Returns a new profile reporting object. - -=cut - -sub _emit { shift; warn @_ } - -sub _t { - sprintf "%10.6f secs", @_; -} - -sub _r { - my ( $num, $denom ) = @_; - return () unless $denom; - sprintf "%10.6f", $num / $denom; -} - -sub _pct { - my ( $num, $denom ) = @_; - return () unless $denom; - sprintf " (%3d%%)", floor( 100 * $num / $denom + 0.5 ); -} - -=head2 C<< $profpp->handle_app_call() >> - -=cut - -sub handle_app_call { - my $self = shift; - $self->_emit("IPC::Run3 parent: ", - join( " ", @{$self->get_app_cmd} ), - "\n", - ); - - $self->{NeedNL} = 1; -} - -=head2 C<< $profpp->handle_app_exit() >> - -=cut - -sub handle_app_exit { - my $self = shift; - - $self->_emit("\n") if $self->{NeedNL} && $self->{NeedNL} != 1; - - $self->_emit( "IPC::Run3 total elapsed: ", - _t( $self->get_app_cumulative_time ), - "\n"); - $self->_emit( "IPC::Run3 calls to run3(): ", - sprintf( "%10d", $self->get_run_count ), - "\n"); - $self->_emit( "IPC::Run3 total spent in run3(): ", - _t( $self->get_run_cumulative_time ), - _pct( $self->get_run_cumulative_time, $self->get_app_cumulative_time ), - ", ", - _r( $self->get_run_cumulative_time, $self->get_run_count ), - " per call", - "\n"); - my $exclusive = - $self->get_app_cumulative_time - $self->get_run_cumulative_time; - $self->_emit( "IPC::Run3 total spent not in run3(): ", - _t( $exclusive ), - _pct( $exclusive, $self->get_app_cumulative_time ), - "\n"); - $self->_emit( "IPC::Run3 total spent in children: ", - _t( $self->get_sys_cumulative_time ), - _pct( $self->get_sys_cumulative_time, $self->get_app_cumulative_time ), - ", ", - _r( $self->get_sys_cumulative_time, $self->get_run_count ), - " per call", - "\n"); - my $overhead = - $self->get_run_cumulative_time - $self->get_sys_cumulative_time; - $self->_emit( "IPC::Run3 total overhead: ", - _t( $overhead ), - _pct( - $overhead, - $self->get_sys_cumulative_time - ), - ", ", - _r( $overhead, $self->get_run_count ), - " per call", - "\n"); -} - -=head2 C<< $profpp->handle_run_exit() >> - -=cut - -sub handle_run_exit { - my $self = shift; - my $overhead = $self->get_run_time - $self->get_sys_time; - - $self->_emit("\n") if $self->{NeedNL} && $self->{NeedNL} != 2; - $self->{NeedNL} = 3; - - $self->_emit( "IPC::Run3 child: ", - join( " ", @{$self->get_run_cmd} ), - "\n"); - $self->_emit( "IPC::Run3 run3() : ", _t( $self->get_run_time ), "\n", - "IPC::Run3 child : ", _t( $self->get_sys_time ), "\n", - "IPC::Run3 overhead: ", _t( $overhead ), - _pct( $overhead, $self->get_sys_time ), - "\n"); -} - -=head1 LIMITATIONS - -=head1 COPYRIGHT - - Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved - -=head1 LICENSE - -You may use this module under the terms of the BSD, Artistic, or GPL licenses, -any version. - -=head1 AUTHOR - -Barrie Slaymaker Ebarries@slaysys.comE - -=cut - -1; diff --git a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfReporter.pm b/Master/tlpkg/tlperl/lib/IPC/Run3/ProfReporter.pm deleted file mode 100755 index 2fa9060e1e4..00000000000 --- a/Master/tlpkg/tlperl/lib/IPC/Run3/ProfReporter.pm +++ /dev/null @@ -1,256 +0,0 @@ -package IPC::Run3::ProfReporter; - -$VERSION = 0.043; - -=head1 NAME - -IPC::Run3::ProfReporter - base class for handling profiling data - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -See L 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 - -=cut - -1; diff --git a/Master/tlpkg/tlperl/lib/IPC/System/Simple.pm b/Master/tlpkg/tlperl/lib/IPC/System/Simple.pm deleted file mode 100755 index 73172c5531f..00000000000 --- a/Master/tlpkg/tlperl/lib/IPC/System/Simple.pm +++ /dev/null @@ -1,1076 +0,0 @@ -package IPC::System::Simple; - -use 5.006; -use strict; -use warnings; -use re 'taint'; -use Carp; -use List::Util qw(first); -use Scalar::Util qw(tainted); -use Config; -use constant WINDOWS => ($^O eq 'MSWin32'); -use constant VMS => ($^O eq 'VMS'); - -BEGIN { - - # It would be lovely to use the 'if' module here, but it didn't - # enter core until 5.6.2, and we want to keep 5.6.0 compatibility. - - - if (WINDOWS) { - - ## no critic (ProhibitStringyEval) - - eval q{ - use Win32::Process qw(INFINITE NORMAL_PRIORITY_CLASS); - use File::Spec; - use Win32; - - # This uses the same rules as the core win32.c/get_shell() call. - - use constant WINDOWS_SHELL => eval { Win32::IsWinNT() } - ? [ qw(cmd.exe /x/d/c) ] - : [ qw(command.com /c) ]; - - # These are used when invoking _win32_capture - use constant NO_SHELL => 0; - use constant USE_SHELL => 1; - - }; - - ## use critic - - # Die nosily if any of the above broke. - die $@ if $@; - } -} - -# Note that we don't use WIFSTOPPED because perl never uses -# the WUNTRACED flag, and hence will never return early from -# system() if the child processes is suspended with a SIGSTOP. - -use POSIX qw(WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG); - -use constant FAIL_START => q{"%s" failed to start: "%s"}; -use constant FAIL_PLUMBING => q{Error in IPC::System::Simple plumbing: "%s" - "%s"}; -use constant FAIL_CMD_BLANK => q{Entirely blank command passed: "%s"}; -use constant FAIL_INTERNAL => q{Internal error in IPC::System::Simple: "%s"}; -use constant FAIL_TAINT => q{%s called with tainted argument "%s"}; -use constant FAIL_TAINT_ENV => q{%s called with tainted environment $ENV{%s}}; -use constant FAIL_SIGNAL => q{"%s" died to signal "%s" (%d)%s}; -use constant FAIL_BADEXIT => q{"%s" unexpectedly returned exit value %d}; - -use constant FAIL_UNDEF => q{%s called with undefined command}; - -use constant FAIL_POSIX => q{IPC::System::Simple does not understand the POSIX error '%s'. Please check http://search.cpan.org/perldoc?IPC::System::Simple to see if there is an updated version. If not please report this as a bug to http://rt.cpan.org/Public/Bug/Report.html?Queue=IPC-System-Simple}; - -# On Perl's older than 5.8.x we can't assume that there'll be a -# $^{TAINT} for us to check, so we assume that our args may always -# be tainted. -use constant ASSUME_TAINTED => ($] < 5.008); - -use constant EXIT_ANY_CONST => -1; # Used internally -use constant EXIT_ANY => [ EXIT_ANY_CONST ]; # Exported - -use constant UNDEFINED_POSIX_RE => qr{not (?:defined|a valid) POSIX macro|not implemented on this architecture}; - -require Exporter; -our @ISA = qw(Exporter); - -our @EXPORT_OK = qw( - capture capturex - run runx - system systemx - $EXITVAL EXIT_ANY -); - -our $VERSION = '1.20'; -our $EXITVAL = -1; - -my @Signal_from_number = split(' ', $Config{sig_name}); - -# Environment variables we don't want to see tainted. -my @Check_tainted_env = qw(PATH IFS CDPATH ENV BASH_ENV); -if (WINDOWS) { - push(@Check_tainted_env, 'PERL5SHELL'); -} -if (VMS) { - push(@Check_tainted_env, 'DCL$PATH'); -} - -# Not all systems implment the WIFEXITED calls, but POSIX -# will always export them (even if they're just stubs that -# die with an error). Test for the presence of a working -# WIFEXITED and friends, or define our own. - -eval { WIFEXITED(0); }; - -if ($@ =~ UNDEFINED_POSIX_RE) { - no warnings 'redefine'; ## no critic - *WIFEXITED = sub { not $_[0] & 0xff }; - *WEXITSTATUS = sub { $_[0] >> 8 }; - *WIFSIGNALED = sub { $_[0] & 127 }; - *WTERMSIG = sub { $_[0] & 127 }; -} elsif ($@) { - croak sprintf FAIL_POSIX, $@; -} - -# None of the POSIX modules I've found define WCOREDUMP, although -# many systems define it. Check the POSIX module in the hope that -# it may actually be there. - - -# TODO: Ideally, $NATIVE_WCOREDUMP should be a constant. - -my $NATIVE_WCOREDUMP; - -eval { POSIX::WCOREDUMP(1); }; - -if ($@ =~ UNDEFINED_POSIX_RE) { - *WCOREDUMP = sub { $_[0] & 128 }; - $NATIVE_WCOREDUMP = 0; -} elsif ($@) { - croak sprintf FAIL_POSIX, $@; -} else { - # POSIX actually has it defined! Huzzah! - *WCOREDUMP = \&POSIX::WCOREDUMP; - $NATIVE_WCOREDUMP = 1; -} - -sub _native_wcoredump { - return $NATIVE_WCOREDUMP; -} - -# system simply calls run - -*system = \&run; -*systemx = \&runx; - -# run is our way of running a process with system() semantics - -sub run { - - _check_taint(@_); - - my ($valid_returns, $command, @args) = _process_args(@_); - - # If we have arguments, we really want to call systemx, - # so we do so. - - if (@args) { - return systemx($valid_returns, $command, @args); - } - - # Without arguments, we're calling system, and checking - # the results. - - # We're throwing our own exception on command not found, so - # we don't need a warning from Perl. - - no warnings 'exec'; ## no critic - CORE::system($command,@args); - - return _process_child_error($?,$command,$valid_returns); -} - -# runx is just like system/run, but *never* invokes the shell. - -sub runx { - _check_taint(@_); - - my ($valid_returns, $command, @args) = _process_args(@_); - - if (WINDOWS) { - our $EXITVAL = -1; - - my $pid = _spawn_or_die($command, "$command @args"); - - $pid->Wait(INFINITE); # Wait for process exit. - $pid->GetExitCode($EXITVAL); - return _check_exit($command,$EXITVAL,$valid_returns); - } - - # If system() fails, we throw our own exception. We don't - # need to have perl complain about it too. - - no warnings; ## no critic - - CORE::system { $command } $command, @args; - - return _process_child_error($?, $command, $valid_returns); -} - -# capture is our way of running a process with backticks/qx semantics - -sub capture { - _check_taint(@_); - - my ($valid_returns, $command, @args) = _process_args(@_); - - if (@args) { - return capturex($valid_returns, $command, @args); - } - - if (WINDOWS) { - # USE_SHELL really means "You may use the shell if you need it." - return _win32_capture(USE_SHELL, $valid_returns, $command, @args); - } - - our $EXITVAL = -1; - - my $wantarray = wantarray(); - - # We'll produce our own warnings on failure to execute. - no warnings 'exec'; ## no critic - - if ($wantarray) { - my @results = qx($command); - _process_child_error($?,$command,$valid_returns); - return @results; - } - - my $results = qx($command); - _process_child_error($?,$command,$valid_returns); - return $results; -} - -# _win32_capture implements the capture and capurex commands on Win32. -# We need to wrap the whole internals of this sub into -# an if (WINDOWS) block to avoid it being compiled on non-Win32 systems. - -sub _win32_capture { - if (not WINDOWS) { - croak sprintf(FAIL_INTERNAL, "_win32_capture called when not under Win32"); - } else { - - my ($use_shell, $valid_returns, $command, @args) = @_; - - my $wantarray = wantarray(); - - # Perl doesn't support multi-arg open under - # Windows. Perl also doesn't provide very good - # feedback when normal backtails fail, either; - # it returns exit status from the shell - # (which is indistinguishable from the command - # running and producing the same exit status). - - # As such, we essentially have to write our own - # backticks. - - # We start by dup'ing STDOUT. - - open(my $saved_stdout, '>&', \*STDOUT) ## no critic - or croak sprintf(FAIL_PLUMBING, "Can't dup STDOUT", $!); - - # We now open up a pipe that will allow us to - # communicate with the new process. - - pipe(my ($read_fh, $write_fh)) - or croak sprintf(FAIL_PLUMBING, "Can't create pipe", $!); - - # Allow CRLF sequences to become "\n", since - # this is what Perl backticks do. - - binmode($read_fh, ':crlf'); - - # Now we re-open our STDOUT to $write_fh... - - open(STDOUT, '>&', $write_fh) ## no critic - or croak sprintf(FAIL_PLUMBING, "Can't redirect STDOUT", $!); - - # If we have args, or we're told not to use the shell, then - # we treat $command as our shell. Otherwise we grub around - # in our command to look for a command to run. - # - # Note that we don't actually *use* the shell (although in - # a future version we might). Being told not to use the shell - # (capturex) means we treat our command as really being a command, - # and not a command line. - - my $exe = @args ? $command : - (! $use_shell) ? $command : - $command =~ m{^"([^"]+)"}x ? $1 : - $command =~ m{(\S+) }x ? $1 : - croak sprintf(FAIL_CMD_BLANK, $command); - - # And now we spawn our new process with inherited - # filehandles. - - my $pid = _spawn_or_die($exe, "$command @args"); - - # Now restore our STDOUT. - open(STDOUT, '>&', $saved_stdout) ## no critic - or croak sprintf(FAIL_PLUMBING,"Can't restore STDOUT", $!); - - # Clean-up the filehandles we no longer need... - - close($write_fh) - or croak sprintf(FAIL_PLUMBING,q{Can't close write end of pipe}, $!); - close($saved_stdout) - or croak sprintf(FAIL_PLUMBING,q{Can't close saved STDOUT}, $!); - - # Read the data from our child... - - my (@results, $result); - - if ($wantarray) { - @results = <$read_fh>; - } else { - $result = join("",<$read_fh>); - } - - # Tidy up our windows process and we're done! - - $pid->Wait(INFINITE); # Wait for process exit. - $pid->GetExitCode($EXITVAL); - - _check_exit($command,$EXITVAL,$valid_returns); - - return $wantarray ? @results : $result; - - } -} - -# capturex() is just like backticks/qx, but never invokes the shell. - -sub capturex { - _check_taint(@_); - - my ($valid_returns, $command, @args) = _process_args(@_); - - our $EXITVAL = -1; - - my $wantarray = wantarray(); - - if (WINDOWS) { - return _win32_capture(NO_SHELL, $valid_returns, $command, @args); - } - - # We can't use a multi-arg piped open here, since 5.6.x - # doesn't like them. Instead we emulate what 5.8.x does, - # which is to create a pipe(), set the close-on-exec flag - # on the child, and the fork/exec. If the exec fails, the - # child writes to the pipe. If the exec succeeds, then - # the pipe closes without data. - - pipe(my ($read_fh, $write_fh)) - or croak sprintf(FAIL_PLUMBING, "Can't create pipe", $!); - - # This next line also does an implicit fork. - my $pid = open(my $pipe, '-|'); ## no critic - - if (not defined $pid) { - croak sprintf(FAIL_START, $command, $!); - } elsif (not $pid) { - # Child process, execs command. - - close($read_fh); - - # TODO: 'no warnings exec' doesn't get rid - # of the 'unlikely to be reached' warnings. - # This is a bug in perl / perldiag / perllexwarn / warnings. - - no warnings; ## no critic - - CORE::exec { $command } $command, @args; - - # Oh no, exec fails! Send the reason why to - # the parent. - - print {$write_fh} int($!); - exit(-1); - } - - { - # In parent process. - - close($write_fh); - - # Parent process, check for child error. - my $error = <$read_fh>; - - # Tidy up our pipes. - close($read_fh); - - # Check for error. - if ($error) { - # Setting $! to our child error number gives - # us nice looking strings when printed. - local $! = $error; - croak sprintf(FAIL_START, $command, $!); - } - } - - # Parent process, we don't care about our pid, but we - # do go and read our pipe. - - if ($wantarray) { - my @results = <$pipe>; - close($pipe); - _process_child_error($?,$command,$valid_returns); - return @results; - } - - # NB: We don't check the return status on close(), since - # on failure it sets $?, which we then inspect for more - # useful information. - - my $results = join("",<$pipe>); - close($pipe); - _process_child_error($?,$command,$valid_returns); - - return $results; - -} - -# Tries really hard to spawn a process under Windows. Returns -# the pid on success, or undef on error. - -sub _spawn_or_die { - - # We need to wrap practically the entire sub in an - # if block to ensure it doesn't get compiled under non-Win32 - # systems. Compiling on these systems would not only be a - # waste of time, but also results in complaints about - # the NORMAL_PRIORITY_CLASS constant. - - if (not WINDOWS) { - croak sprintf(FAIL_INTERNAL, "_spawn_or_die called when not under Win32"); - } else { - my ($orig_exe, $cmdline) = @_; - my $pid; - - my $exe = $orig_exe; - - # If our command doesn't have an extension, add one. - $exe .= $Config{_exe} if ($exe !~ m{\.}); - - Win32::Process::Create( - $pid, $exe, $cmdline, 1, NORMAL_PRIORITY_CLASS, "." - ) and return $pid; - - my @path = split(/;/,$ENV{PATH}); - - foreach my $dir (@path) { - my $fullpath = File::Spec->catfile($dir,$exe); - - # We're using -x here on the assumption that stat() - # is faster than spawn, so trying to spawn a process - # for each path element will be unacceptably - # inefficient. - - if (-x $fullpath) { - Win32::Process::Create( - $pid, $fullpath, $cmdline, 1, - NORMAL_PRIORITY_CLASS, "." - ) and return $pid; - } - } - - croak sprintf(FAIL_START, $orig_exe, $^E); - } -} - -# Complain on tainted arguments or environment. -# ASSUME_TAINTED is true for 5.6.x, since it's missing ${^TAINT} - -sub _check_taint { - return if not (ASSUME_TAINTED or ${^TAINT}); - my $caller = (caller(1))[3]; - foreach my $var (@_) { - if (tainted $var) { - croak sprintf(FAIL_TAINT, $caller, $var); - } - } - foreach my $var (@Check_tainted_env) { - if (tainted $ENV{$var} ) { - croak sprintf(FAIL_TAINT_ENV, $caller, $var); - } - } - - return; - -} - -# This subroutine performs the difficult task of interpreting -# $?. It's not intended to be called directly, as it will -# croak on errors, and its implementation and interface may -# change in the future. - -sub _process_child_error { - my ($child_error, $command, $valid_returns) = @_; - - $EXITVAL = -1; - - my $coredump = WCOREDUMP($child_error); - - # There's a bug in perl 5.10.0 where if the system - # does not provide a native WCOREDUMP, then $? will - # never contain coredump information. This code - # checks to see if we have the bug, and works around - # it if needed. - - if ($] >= 5.010 and not $NATIVE_WCOREDUMP) { - $coredump ||= WCOREDUMP( ${^CHILD_ERROR_NATIVE} ); - } - - if ($child_error == -1) { - croak sprintf(FAIL_START, $command, $!); - - } elsif ( WIFEXITED( $child_error ) ) { - $EXITVAL = WEXITSTATUS( $child_error ); - - return _check_exit($command,$EXITVAL,$valid_returns); - - } elsif ( WIFSIGNALED( $child_error ) ) { - my $signal_no = WTERMSIG( $child_error ); - my $signal_name = $Signal_from_number[$signal_no] || "UNKNOWN"; - - croak sprintf FAIL_SIGNAL, $command, $signal_name, $signal_no, ($coredump ? " and dumped core" : ""); - - - } - - croak sprintf(FAIL_INTERNAL, qq{'$command' ran without exit value or signal}); - -} - -# A simple subroutine for checking exit values. Results in better -# assurance of consistent error messages, and better forward support -# for new features in I::S::S. - -sub _check_exit { - my ($command, $exitval, $valid_returns) = @_; - - # If we have a single-value list consisting of the EXIT_ANY - # value, then we're happy with whatever exit value we're given. - if (@$valid_returns == 1 and $valid_returns->[0] == EXIT_ANY_CONST) { - return $exitval; - } - - if (not defined first { $_ == $exitval } @$valid_returns) { - croak sprintf FAIL_BADEXIT, $command, $exitval; - } - return $exitval; -} - - -# This subroutine simply determines a list of valid returns, the command -# name, and any arguments that we need to pass to it. - -sub _process_args { - my $valid_returns = [ 0 ]; - my $caller = (caller(1))[3]; - - if (not @_) { - croak "$caller called with no arguments"; - } - - if (ref $_[0] eq "ARRAY") { - $valid_returns = shift(@_); - } - - if (not @_) { - croak "$caller called with no command"; - } - - my $command = shift(@_); - - if (not defined $command) { - croak sprintf( FAIL_UNDEF, $caller ); - } - - return ($valid_returns,$command,@_); - -} - -1; - -__END__ - -=head1 NAME - -IPC::System::Simple - Run commands simply, with detailed diagnostics - -=head1 SYNOPSIS - - use IPC::System::Simple qw(system systemx capture capturex); - - system("some_command"); # Command succeeds or dies! - - system("some_command",@args); # Succeeds or dies, avoids shell if @args - - systemx("some_command",@args); # Succeeds or dies, NEVER uses the shell - - - # Capture the output of a command (just like backticks). Dies on error. - my $output = capture("some_command"); - - # Just like backticks in list context. Dies on error. - my @output = capture("some_command"); - - # As above, but avoids the shell if @args is non-empty - my $output = capture("some_command", @args); - - # As above, but NEVER invokes the shell. - my $output = capturex("some_command", @args); - my @output = capturex("some_command", @args); - -=head1 DESCRIPTION - -Calling Perl's in-built C function is easy, -determining if it was successful is I. Let's face it, -C<$?> isn't the nicest variable in the world to play with, and -even if you I check it, producing a well-formatted error -string takes a lot of work. - -C 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 commands will either succeeed (run to -completion and return a zero exit value), or die with rich diagnostic -messages. - -The C module also provides a simple replacement -to Perl's backticks operator. Simply write: - - use IPC::System::Simple qw(capture); - -and then use the L 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 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 provides a subroutine called -C, that executes a command using the same semantics is -Perl's built-in C: - - 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 command is that C will throw an exception on -failure, and allows a list of acceptable exit values to be set. -See L for further information. - -In fact, you can even have C replace the -default C 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 and C are aliases to each other. - -See also L for variants of -C and C that never invoke the shell, even with -a single argument. - -=head2 capture() - -A second subroutine, named C executes a command with -the same semantics as Perl's built-in backticks (and C): - - 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 -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 for a variant of -C that never invokes the shell, even with a single -argument. - -=head2 runx(), systemx() and capturex() - -The C, C and C commands are identical -to the multi-argument forms of C, C and C -respectively, but I invoke the shell, even when called with a -single argument. These forms are particularly useful when a command's -argument list I be empty, for example: - - systemx($cmd, @args); - -The use of C here guarantees that the shell will I -be invoked, even if C<@args> is empty. - -=head2 Exception handling - -In the case where the command returns an unexpected status, both C and -C 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 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 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 as the first argument. The -special constant C can be used to allow I 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 and replacement C 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 -can always be retrieved from the C<$IPC::System::Simple::EXITVAL> -variable: - -This is particularly useful when inspecting results from C, -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 v0.06, the C subroutine I will make available the full 32-bit -exit value on Win32 systems. This is different from the -previous versions of C and from Perl's -in-build C function, which can only handle 8-bit return values. - -The C subroutine always returns the 32-bit exit value under -Windows. The C subroutine also never uses the shell, -even when passed a single argument. - -Versions of C before v0.09 would not search -the C environment variable when the multi-argument form of -C was called. Versions from v0.09 onwards correctly search -the path provided the command is provided including the extension -(eg, C rather than just C, or C rather -than just C). 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 if it cannot be determined. The -signal number is always reported. If we detected that the -process dumped core, then the string C is -appeneded. - -=item IPC::System::Simple::%s called with no arguments - -You attempted to call C or C 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 or C with a list of acceptable exit values, -but no actual command. - -=item IPC::System::Simple::%s called with tainted argument "%s" - -You called C or C 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 for more information. - -=item IPC::System::Simple::%s called with tainted environment $ENV{%s} - -You called C or C but part of your environment was tainted -(untrusted). You should either delete the named environment -variable before calling C, or set it to an untainted value -(usually one set inside your program). See -L for more information. - -=item Error in IPC::System::Simple plumbing: "%s" - "%s" - -Implementing the C 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 section below. - -=item Internal error in IPC::System::Simple: "%s" - -You've found a bug in C. Please check to -see if an updated version of C is available. -If not, please file a bug report according to the L 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 when used on Win32 -system. C 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 -differentiates itself from other options by providing: - -=over 4 - -=item Extremely detailed diagnostics - -The diagnostics produced by C are designed -to provide as much information as possible. Rather than requiring -the developer to inspect C<$?>, C 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 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, C and C commands all set C<$EXITVAL>, -making it easy to determine the exit status of a command. -Additionally, the C and C interfaces return the exit -status. - -=item Consistent interfaces - -When called with multiple arguments, the C, C and -C interfaces I invoke the shell. This differs -from the in-built Perl C 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 is exported, the exotic form C -is not supported. Attemping to use the exotic form is a syntax -error. This affects the calling package I. Use C -if you need it, or consider using the L module to replace -C 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 status is not checked, as perl never spawns processes -with the C 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 capture. - -Only 8-bit values are returned when C or C -is called with a single value under Win32. Multi-argument calls -to C and C, as well as the C and -C 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. Your problem may -have already been fixed in a new release. - -You can find the C bug-tracker at -L . -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 . - -The module author loves to hear how C has made -your life better (or worse). Feedback can be sent to -Epjf@perltraining.com.auE. - -=head1 SEE ALSO - -L uses C to provide succeed-or-die -replacements to C (and other built-ins) with lexical scope. - -L, L, L, L, L, -L, L - -=head1 AUTHOR - -Paul Fenwick Epjf@cpan.orgE - -=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 -- cgit v1.2.3