Alien-ROOT
view release on metacpan or search on metacpan
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
if( scalar run( command => $cmd,
verbose => 0,
buffer => \$buffer,
timeout => 20 )
) {
print "fetched webpage successfully: $buffer\n";
}
### in list context ###
my( $success, $error_message, $full_buf, $stdout_buf, $stderr_buf ) =
run( command => $cmd, verbose => 0 );
if( $success ) {
print "this is what the command printed:\n";
print join "", @$full_buf;
}
### check for features
print "IPC::Open3 available: " . IPC::Cmd->can_use_ipc_open3;
print "IPC::Run available: " . IPC::Cmd->can_use_ipc_run;
print "Can capture buffer: " . IPC::Cmd->can_capture_buffer;
### don't have IPC::Cmd be verbose, ie don't print to stdout or
### stderr when running commands -- default is '0'
$IPC::Cmd::VERBOSE = 0;
=head1 DESCRIPTION
IPC::Cmd allows you to run commands platform independently,
interactively if desired, but have them still work.
The C<can_run> function can tell you if a certain binary is installed
and if so where, whereas the C<run> function can actually execute any
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
) {
next if ! $dir || ! -d $dir;
my $abs = File::Spec->catfile( IS_WIN32 ? Win32::GetShortPathName( $dir ) : $dir, $command);
push @possibles, $abs if $abs = MM->maybe_command($abs);
}
}
return @possibles if wantarray and $INSTANCES;
return shift @possibles;
}
=head2 $ok | ($ok, $err, $full_buf, $stdout_buff, $stderr_buff) = run( command => COMMAND, [verbose => BOOL, buffer => \$SCALAR, timeout => DIGIT] );
C<run> takes 4 arguments:
=over 4
=item command
This is the command to execute. It may be either a string or an array
reference.
This is a required argument.
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
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
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
my $ps = $opts->{'parent_info'};
# child was killed, inform parent
if ($real_exit & 127) {
print $ps "$pid killed with " . ($real_exit & 127) . "\n";
}
print $ps "reaped $pid\n";
}
if ($opts->{'parent_stdout'} || $opts->{'parent_stderr'}) {
return $exit_value;
}
else {
return {
'stdout' => $child_output->{$child_output->{'out'}}->{'scalar_buffer'},
'stderr' => $child_output->{$child_output->{'err'}}->{'scalar_buffer'},
'exit_code' => $exit_value,
};
}
}
=head2 $hashref = run_forked( COMMAND, { child_stdin => SCALAR, timeout => DIGIT, stdout_handler => CODEREF, stderr_handler => CODEREF} );
C<run_forked> is used to execute some program or a coderef,
optionally feed it with some input, get its return code
and output (both stdout and stderr into separate buffers).
In addition, it allows to terminate the program
if it takes too long to finish.
The important and distinguishing feature of run_forked
is execution timeout which at first seems to be
quite a simple task but if you think
that the program which you're spawning
might spawn some children itself (which
in their turn could do the same and so on)
it turns out to be not a simple issue.
C<run_forked> is designed to survive and
successfully terminate almost any long running task,
even a fork bomb in case your system has the resources
to survive during given timeout.
This is achieved by creating separate watchdog process
which spawns the specified program in a separate
process session and supervises it: optionally
feeds it with input, stores its exit code,
stdout and stderr, terminates it in case
it runs longer than specified.
Invocation requires the command to be executed or a coderef and optionally a hashref of options:
=over
=item C<timeout>
Specify in seconds how long to run the command before it is killed with with SIG_KILL (9),
which effectively terminates it and all of its children (direct or indirect).
=item C<child_stdin>
Specify some text that will be passed into the C<STDIN> of the executed program.
=item C<stdout_handler>
Coderef of a subroutine to call when a portion of data is received on
STDOUT from the executing program.
=item C<stderr_handler>
Coderef of a subroutine to call when a portion of data is received on
STDERR from the executing program.
=item C<discard_output>
Discards the buffering of the standard output and standard errors for return by run_forked().
With this option you have to use the std*_handlers to read what the command outputs.
Useful for commands that send a lot of output.
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
=item C<timeout>
The number of seconds the program ran for before being terminated, or 0 if no timeout occurred.
=item C<stdout>
Holds the standard output of the executed command (or empty string if
there was no STDOUT output or if C<discard_output> was used; it's always defined!)
=item C<stderr>
Holds the standard error of the executed command (or empty string if
there was no STDERR output or if C<discard_output> was used; it's always defined!)
=item C<merged>
Holds the standard output and error of the executed command merged into one stream
(or empty string if there was no output at all or if C<discard_output> was used; it's always defined!)
=item C<err_msg>
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
$opts->{'timeout'} = 0 unless $opts->{'timeout'};
$opts->{'terminate_wait_time'} = 2 unless defined($opts->{'terminate_wait_time'});
# turned on by default
$opts->{'clean_up_children'} = 1 unless defined($opts->{'clean_up_children'});
# sockets to pass child stdout to parent
my $child_stdout_socket;
my $parent_stdout_socket;
# sockets to pass child stderr to parent
my $child_stderr_socket;
my $parent_stderr_socket;
# sockets for child -> parent internal communication
my $child_info_socket;
my $parent_info_socket;
socketpair($child_stdout_socket, $parent_stdout_socket, 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 $flags;
# prepare sockets to read from child
$flags = 0;
fcntl($child_stdout_socket, POSIX::F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
$flags |= POSIX::O_NONBLOCK;
fcntl($child_stdout_socket, POSIX::F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
$flags = 0;
fcntl($child_stderr_socket, POSIX::F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
$flags |= POSIX::O_NONBLOCK;
fcntl($child_stderr_socket, POSIX::F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
$flags = 0;
fcntl($child_info_socket, POSIX::F_GETFL, $flags) || die "can't fnctl F_GETFL: $!";
$flags |= POSIX::O_NONBLOCK;
fcntl($child_info_socket, POSIX::F_SETFL, $flags) || die "can't fnctl F_SETFL: $!";
# print "child $pid started\n";
my $child_timedout = 0;
my $child_finished = 0;
my $child_stdout = '';
my $child_stderr = '';
my $child_merged = '';
my $child_exit_code = 0;
my $child_killed_by_signal = 0;
my $parent_died = 0;
my $got_sig_child = 0;
my $got_sig_quit = 0;
my $orig_sig_child = $SIG{'CHLD'};
$SIG{'CHLD'} = sub { $got_sig_child = time(); };
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
while (my $l = <$child_stdout_socket>) {
if (!$opts->{'discard_output'}) {
$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>) {
if (!$opts->{'discard_output'}) {
$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
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
# are reused quickly (there are lots of processes
# spawning new process groups for example)
#
if ($opts->{'clean_up_children'}) {
kill(-9, $pid);
}
# print "child $pid finished\n";
close($child_stdout_socket);
close($child_stderr_socket);
close($child_info_socket);
my $o = {
'stdout' => $child_stdout,
'stderr' => $child_stderr,
'merged' => $child_merged,
'timeout' => $child_timedout ? $opts->{'timeout'} : 0,
'exit_code' => $child_exit_code,
'parent_died' => $parent_died,
'killed_by_signal' => $child_killed_by_signal,
'child_pgid' => $pid,
};
my $err_msg = '';
if ($o->{'exit_code'}) {
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
}
if ($o->{'timeout'}) {
$err_msg .= "ran more than [$o->{'timeout'}] seconds\n";
}
if ($o->{'parent_died'}) {
$err_msg .= "parent died\n";
}
if ($o->{'stdout'}) {
$err_msg .= "stdout:\n" . $o->{'stdout'} . "\n";
}
if ($o->{'stderr'}) {
$err_msg .= "stderr:\n" . $o->{'stderr'} . "\n";
}
if ($o->{'killed_by_signal'}) {
$err_msg .= "killed by signal [" . $o->{'killed_by_signal'} . "]\n";
}
$o->{'err_msg'} = $err_msg;
if ($orig_sig_child) {
$SIG{'CHLD'} = $orig_sig_child;
}
else {
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
# which do setsid theirselves -- can't do anything
# with those)
POSIX::setsid() || die("Error running setsid: " . $!);
if ($opts->{'child_BEGIN'} && ref($opts->{'child_BEGIN'}) eq 'CODE') {
$opts->{'child_BEGIN'}->();
}
close($child_stdout_socket);
close($child_stderr_socket);
close($child_info_socket);
my $child_exit_code;
# allow both external programs
# and internal perl calls
if (!ref($cmd)) {
$child_exit_code = open3_run($cmd, {
'parent_info' => $parent_info_socket,
'parent_stdout' => $parent_stdout_socket,
'parent_stderr' => $parent_stderr_socket,
'child_stdin' => $opts->{'child_stdin'},
});
}
elsif (ref($cmd) eq 'CODE') {
$child_exit_code = $cmd->({
'opts' => $opts,
'parent_info' => $parent_info_socket,
'parent_stdout' => $parent_stdout_socket,
'parent_stderr' => $parent_stderr_socket,
'child_stdin' => $opts->{'child_stdin'},
});
}
else {
print $parent_stderr_socket "Invalid command reference: " . ref($cmd) . "\n";
$child_exit_code = 1;
}
close($parent_stdout_socket);
close($parent_stderr_socket);
close($parent_info_socket);
if ($opts->{'child_END'} && ref($opts->{'child_END'}) eq 'CODE') {
$opts->{'child_END'}->();
}
POSIX::_exit $child_exit_code;
}
}
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
(IS_WIN32 ? \*STDOUT : $kidout)
);
STDOUT->autoflush(1); STDERR->autoflush(1); STDIN->autoflush(1);
$kidout->autoflush(1) if UNIVERSAL::can($kidout, 'autoflush');
$kiderror->autoflush(1) if UNIVERSAL::can($kiderror, 'autoflush');
### add an explicit break statement
### code courtesy of theorbtwo from #london.pm
my $stdout_done = 0;
my $stderr_done = 0;
OUTER: while ( my @ready = $selector->can_read ) {
for my $h ( @ready ) {
my $buf;
### $len is the amount of bytes read
my $len = sysread( $h, $buf, 4096 ); # try to read 4096 bytes
### see perldoc -f sysread: it returns undef on error,
### so bail out.
inc/inc_IPC-Cmd/IPC/Cmd.pm view on Meta::CPAN
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 );
( run in 1.479 second using v1.01-cache-2.11-cpan-49f99fa48dc )