874 lines
26 KiB
Perl
874 lines
26 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::IPC::Run
|
|
# Author : Scott Beck
|
|
# CVS Info : 087,071,086,086,085
|
|
# $Id: Run.pm,v 1.22 2006/05/26 21:56:30 brewt Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# Description:
|
|
# Runs programs or code references in parallel
|
|
#
|
|
package GT::IPC::Run;
|
|
|
|
use strict;
|
|
use base 'GT::Base';
|
|
use vars qw/@EXPORT_OK $SYSTEM $DEBUG $ERRORS/;
|
|
|
|
use Exporter();
|
|
use Socket;
|
|
use Symbol qw/gensym/;
|
|
use POSIX qw(fcntl_h errno_h :sys_wait_h);
|
|
|
|
use GT::IPC::Filter::Line;
|
|
use GT::IPC::Run::Select;
|
|
use GT::IPC::Run::Child;
|
|
|
|
my $can_run_socket = undef;
|
|
|
|
*import = \&Exporter::import;
|
|
@EXPORT_OK = qw/run/;
|
|
$DEBUG = 0;
|
|
|
|
sub READ_BLOCK () { 512 }
|
|
sub IS_WIN32 () { $^O eq 'MSWin32' }
|
|
|
|
$ERRORS = {
|
|
SEMAPHORE => "Could not create semephore socket; Reason: %s",
|
|
FORK => "Could not fork; Reason: %s"
|
|
};
|
|
|
|
BEGIN {
|
|
# http://support.microsoft.com/support/kb/articles/Q150/5/37.asp
|
|
# defines EINPROGRESS as 10035. We provide it here because some
|
|
# Win32 users report POSIX::EINPROGRESS is not vendor-supported.
|
|
if (IS_WIN32) {
|
|
eval '*EINPROGRESS = sub { 10036 };';
|
|
eval '*EWOULDBLOCK = sub { 10035 };';
|
|
eval '*F_GETFL = sub { 0 };';
|
|
eval '*F_SETFL = sub { 0 };';
|
|
require GT::IPC::Run::Win32;
|
|
import GT::IPC::Run::Win32;
|
|
$SYSTEM = 'GT::IPC::Run::Win32';
|
|
}
|
|
else {
|
|
require GT::IPC::Run::Unix;
|
|
import GT::IPC::Run::Unix;
|
|
$SYSTEM = 'GT::IPC::Run::Unix';
|
|
}
|
|
}
|
|
|
|
sub new {
|
|
# ------------------------------------------------------------------------
|
|
my $self = bless {}, $SYSTEM;
|
|
$self->{select} = new GT::IPC::Run::Select;
|
|
return $self;
|
|
}
|
|
|
|
sub run {
|
|
# ------------------------------------------------------------------------
|
|
my ($program, $out, $err, $in) = @_;
|
|
my $self = new GT::IPC::Run;
|
|
my $ref;
|
|
|
|
$self->fatal("No program specified to start")
|
|
unless defined $program;
|
|
$ref = ref $program;
|
|
$self->fatal("Invalid program passed to start $program")
|
|
if
|
|
$ref ne 'CODE' and
|
|
$ref ne 'ARRAY' and
|
|
$ref;
|
|
|
|
$ref = defined($out) ? ref($out) : undef;
|
|
my $out_is_handle = _is_handle($out);
|
|
$self->fatal(
|
|
BADARGS => "stdout handler is not a code ref or scalar ref"
|
|
) if
|
|
defined $ref and
|
|
$ref ne 'CODE' and
|
|
$ref ne 'SCALAR' and
|
|
!$out_is_handle and
|
|
$ref !~ /\AGT::IPC::Filter::/;
|
|
|
|
$ref = defined($err) ? ref($err) : undef;
|
|
my $err_is_handle = _is_handle($err);
|
|
$self->fatal(
|
|
BADARGS => "stderr handler is not a code ref or scalar ref"
|
|
) if
|
|
defined $ref and
|
|
$ref ne 'CODE' and
|
|
$ref ne 'SCALAR' and
|
|
!$err_is_handle and
|
|
$ref !~ /\AGT::IPC::Filter::/;
|
|
|
|
$ref = ref $in;
|
|
my $in_is_handle = _is_handle($in);
|
|
$self->fatal(
|
|
BADARGS => "stdin handler is not a scalar ref or filehandle"
|
|
) if
|
|
$ref ne 'SCALAR' and
|
|
!$in_is_handle and
|
|
$ref !~ /\AGT::IPC::Filter::/ and
|
|
defined $in;
|
|
|
|
my $pid = $self->start(
|
|
program => $program,
|
|
stdout => $out,
|
|
stderr => $err,
|
|
stdin => $in,
|
|
debug => $DEBUG
|
|
);
|
|
1 while $self->do_one_loop;
|
|
my $exit_code = $self->exit_code($pid);
|
|
return $exit_code;
|
|
}
|
|
|
|
sub start {
|
|
# ------------------------------------------------------------------------
|
|
my $self = shift;
|
|
$self->fatal(BADARGS => "Arguments to start() must be a hash")
|
|
if @_ & 1;
|
|
my %opts = @_;
|
|
my $ref;
|
|
|
|
$self->{_debug} = delete $opts{debug};
|
|
$self->{_debug} = $DEBUG unless defined $self->{_debug};
|
|
|
|
my $program = delete $opts{program};
|
|
$self->fatal("No program specified to start")
|
|
unless defined $program;
|
|
$ref = ref $program;
|
|
$self->fatal("Invalid program passed to start $program")
|
|
if
|
|
$ref ne 'CODE' and
|
|
$ref ne 'ARRAY' and
|
|
$ref;
|
|
|
|
my $out = delete $opts{stdout};
|
|
my $actual_out;
|
|
$ref = defined($out) ? ref($out) : undef;
|
|
my $out_is_handle = _is_handle($out);
|
|
|
|
# Default to line filter for stderr
|
|
if ($ref and $ref eq 'CODE') {
|
|
$actual_out = new GT::IPC::Filter::Line($out);
|
|
}
|
|
elsif ($ref and $ref eq 'SCALAR') {
|
|
$actual_out = new GT::IPC::Filter::Line(sub { $$out .= "$_[0]\n" });
|
|
}
|
|
elsif ($ref and $ref =~ /\AGT::IPC::Filter::/) {
|
|
$actual_out = $out;
|
|
}
|
|
elsif (defined($out) and !$out_is_handle) {
|
|
$self->fatal(
|
|
BADARGS => "stdout handler is not a code ref or scalar ref"
|
|
);
|
|
}
|
|
|
|
my $err = delete $opts{stderr};
|
|
my $actual_err;
|
|
my $err_is_handle = _is_handle($err);
|
|
$ref = defined($err) ? ref($err) : undef;
|
|
|
|
# Default to line filter for stderr
|
|
if ($ref and $ref eq 'CODE') {
|
|
$actual_err = new GT::IPC::Filter::Line($err);
|
|
}
|
|
elsif ($ref and $ref eq 'SCALAR') {
|
|
$actual_err = new GT::IPC::Filter::Line(sub { $$err .= "$_[0]\n" });
|
|
}
|
|
elsif ($ref and $ref =~ /\AGT::IPC::Filter::/) {
|
|
$actual_err = $err;
|
|
}
|
|
elsif (defined($err) and !$err_is_handle) {
|
|
$self->fatal(
|
|
BADARGS => "stderr handler is not a code ref or scalar ref"
|
|
);
|
|
}
|
|
|
|
my $in = delete $opts{stdin};
|
|
my $in_is_handle = _is_handle($in);
|
|
$ref = ref $in;
|
|
$self->fatal(
|
|
BADARGS => "stdin handler is not a scalar ref or filehandle"
|
|
) if
|
|
$ref ne 'SCALAR' and
|
|
!$in_is_handle and
|
|
defined $in;
|
|
|
|
|
|
my $exit_callback = delete $opts{reaper};
|
|
$self->fatal(
|
|
BADARGS => "The exit callback specified is not a code reference"
|
|
) if
|
|
defined $exit_callback and
|
|
ref($exit_callback) ne 'CODE';
|
|
|
|
my $done_callback = delete $opts{done_callback};
|
|
$self->fatal(
|
|
BADARGS => "The done callback specified is not a code reference"
|
|
) if
|
|
defined $done_callback and
|
|
ref($done_callback) ne 'CODE';
|
|
|
|
$self->fatal(
|
|
BADARGS => "Unknown arguments ", join(", ", keys %opts)
|
|
) if keys %opts;
|
|
|
|
# get the sockets we need for stdin/stdout/stderr communication
|
|
my ($stderr_read, $stderr_write) = $self->oneway;
|
|
$self->fatal("could not make stderr pipe: $!")
|
|
unless defined $stderr_read and defined $stderr_write;
|
|
my ($stdout_read, $stdout_write) = $self->twoway;
|
|
$self->fatal("could not make stdout pipe: $!")
|
|
unless defined $stdout_read and defined $stdout_write;
|
|
my ($stdin_read, $stdin_write) = $self->oneway;
|
|
$self->fatal("could not make stdin pipes: $!")
|
|
unless defined $stdin_read and defined $stdin_write;
|
|
|
|
# Defaults to blocking
|
|
$self->stop_blocking($stdout_read);
|
|
$self->stop_blocking($stdout_write);
|
|
$self->stop_blocking($stderr_read);
|
|
$self->stop_blocking($stderr_write);
|
|
|
|
# Change the ones they have overridden
|
|
if ($in_is_handle) {
|
|
$stdin_read = $in;
|
|
undef $stdin_write;
|
|
undef $in;
|
|
}
|
|
elsif (!$in) {
|
|
undef $stdin_write;
|
|
undef $stdin_read;
|
|
}
|
|
if ($out_is_handle) {
|
|
$stdout_write = $out;
|
|
undef $stdout_read;
|
|
undef $out;
|
|
}
|
|
elsif (!$out) {
|
|
undef $stdout_write;
|
|
undef $stdout_read;
|
|
}
|
|
if ($err_is_handle) {
|
|
$stderr_write = $err;
|
|
undef $stderr_read;
|
|
}
|
|
elsif (!$err) {
|
|
undef $stderr_write;
|
|
undef $stderr_read;
|
|
}
|
|
|
|
# Temporary location for these
|
|
$self->{current_child} = new GT::IPC::Run::Child(
|
|
program => $program,
|
|
stderr_read => $stderr_read,
|
|
stderr_write => $stderr_write,
|
|
stdout_read => $stdout_read,
|
|
stdout_write => $stdout_write,
|
|
stdin_write => $stdin_write,
|
|
stdin_read => $stdin_read,
|
|
stdin => $in,
|
|
handler_stdout => $actual_out,
|
|
handler_stderr => $actual_err,
|
|
exit_callback => $exit_callback,
|
|
done_callback => $done_callback,
|
|
exit_status => 0,
|
|
pid => 0
|
|
);
|
|
|
|
# Run the program/code ref
|
|
my $pid = $self->execute;
|
|
return $pid;
|
|
}
|
|
|
|
sub do_loop {
|
|
# ----------------------------------------------------------------------------
|
|
my ($self, $wait) = @_;
|
|
1 while $self->do_one_loop($wait);
|
|
}
|
|
|
|
sub exit_code {
|
|
# ----------------------------------------------------------------------------
|
|
my ($self, $pid) = @_;
|
|
$self->fatal( BADARGS => "No pid passed to exit_code" )
|
|
unless defined $pid;
|
|
return $self->{goners}{$pid};
|
|
}
|
|
|
|
sub twoway {
|
|
# ------------------------------------------------------------------------
|
|
my ( $self, $conduit_type ) = @_;
|
|
|
|
# Try UNIX-domain socketpair if no preferred conduit type is
|
|
# specified, or if the specified conduit type is 'socketpair'.
|
|
if (
|
|
(
|
|
not defined $conduit_type or
|
|
$conduit_type eq 'socketpair'
|
|
) and
|
|
not defined $can_run_socket
|
|
)
|
|
{
|
|
my ($rw1, $rw2) = (gensym, gensym);
|
|
|
|
eval {
|
|
socketpair( $rw1, $rw2, AF_UNIX, SOCK_STREAM, PF_UNSPEC )
|
|
or die "socketpair 1 failed: $!";
|
|
};
|
|
|
|
# Socketpair succeeded.
|
|
if ( !length $@ ) {
|
|
|
|
$self->debug("Using socketpair for twoway") if $self->{_debug};
|
|
# It's two-way, so each reader is also a writer.
|
|
|
|
select( ( select($rw1), $| = 1 )[0] );
|
|
select( ( select($rw2), $| = 1 )[0] );
|
|
return ( $rw1, $rw2, $rw1, $rw2 );
|
|
}
|
|
elsif ($DEBUG) {
|
|
$self->debug("Error with socketpair: $@\n");
|
|
}
|
|
}
|
|
|
|
# Try the pipe if no preferred conduit type is specified, or if the
|
|
# specified conduit type is 'pipe'.
|
|
if (
|
|
(
|
|
not defined $conduit_type or
|
|
$conduit_type eq 'pipe'
|
|
) and
|
|
not defined $can_run_socket
|
|
)
|
|
{
|
|
my ($read1, $write1, $read2, $write2) =
|
|
(gensym, gensym, gensym, gensym);
|
|
|
|
eval {
|
|
pipe($read1, $write1) or die "pipe 1 failed: $!";
|
|
pipe($read2, $write2) or die "pipe 2 failed: $!";
|
|
};
|
|
|
|
# Pipe succeeded.
|
|
if (!length $@) {
|
|
|
|
$self->debug("Using pipe for twoway") if $self->{_debug};
|
|
# Turn off buffering. POE::Kernel does this for us, but someone
|
|
# might want to use the pipe class elsewhere.
|
|
select((select($write1), $| = 1)[0]);
|
|
select((select($write2), $| = 1)[0]);
|
|
return($read1, $write1, $read2, $write2);
|
|
}
|
|
elsif ($self->{_debug}) {
|
|
$self->debug("Error with pipe(): $@");
|
|
}
|
|
}
|
|
|
|
# Try a pair of plain INET sockets if no preffered conduit type is
|
|
# specified, or if the specified conduit type is 'inet'.
|
|
if (
|
|
(
|
|
not defined $conduit_type or
|
|
$conduit_type eq 'inet'
|
|
) and (
|
|
$can_run_socket or
|
|
not defined $can_run_socket
|
|
)
|
|
)
|
|
{
|
|
my ($rw1, $rw2) = (gensym, gensym);
|
|
|
|
# Try using a pair of plain INET domain sockets.
|
|
eval { ($rw1, $rw2) = $self->make_socket }; # make_socket
|
|
# returns em
|
|
# non-blocking
|
|
|
|
# Sockets worked.
|
|
if (!length $@) {
|
|
|
|
$self->debug("Using inet socket for twoway") if $self->{_debug};
|
|
# Try sockets more often.
|
|
$can_run_socket = 1;
|
|
|
|
# Turn off buffering. POE::Kernel does this for us, but someone
|
|
# might want to use the pipe class elsewhere.
|
|
select((select($rw1), $| = 1)[0]);
|
|
select((select($rw2), $| = 1)[0]);
|
|
|
|
return($rw1, $rw2, $rw1, $rw2);
|
|
}
|
|
elsif ($self->{_debug}) {
|
|
$self->debug("Error with socket: $@");
|
|
}
|
|
|
|
# Sockets failed. Don't dry them again.
|
|
}
|
|
$self->debug("Nothing worked") if $self->{_debug};
|
|
|
|
# There's nothing left to try.
|
|
return(undef, undef, undef, undef);
|
|
}
|
|
|
|
sub oneway {
|
|
# ------------------------------------------------------------------------
|
|
my ( $self, $conduit_type ) = @_;
|
|
|
|
# Generate symbols to be used as filehandles for the pipe's ends.
|
|
my $read = gensym;
|
|
my $write = gensym;
|
|
|
|
# Try UNIX-domain socketpair if no preferred conduit type is
|
|
# specified, or if the specified conduit type is 'socketpair'.
|
|
if (
|
|
(
|
|
not defined $conduit_type or
|
|
$conduit_type eq 'socketpair'
|
|
) and
|
|
not defined $can_run_socket
|
|
)
|
|
{
|
|
|
|
eval {
|
|
socketpair($read, $write, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
|
|
or die "socketpair failed: $!";
|
|
};
|
|
|
|
# Socketpair succeeded.
|
|
if (!length $@) {
|
|
|
|
$self->debug("Using socketpair for oneway") if $self->{_debug};
|
|
# It's one-way, so shut down the unused directions.
|
|
shutdown($read, 1);
|
|
shutdown($write, 0);
|
|
|
|
# Turn off buffering. POE::Kernel does this for us, but someone
|
|
# might want to use the pipe class elsewhere.
|
|
select((select($write), $| = 1)[0]);
|
|
return($read, $write);
|
|
}
|
|
elsif ($self->{_debug}) {
|
|
$self->debug("Could not make socketpair: $@");
|
|
}
|
|
}
|
|
|
|
# Try the pipe if no preferred conduit type is specified, or if the
|
|
# specified conduit type is 'pipe'.
|
|
if (
|
|
(
|
|
not defined $conduit_type or
|
|
$conduit_type eq 'pipe'
|
|
) and
|
|
not defined $can_run_socket
|
|
)
|
|
{
|
|
|
|
eval { pipe($read, $write) or die "pipe failed: $!" };
|
|
|
|
# Pipe succeeded.
|
|
if (!length $@) {
|
|
|
|
$self->debug("Using pipe for oneway") if $self->{_debug};
|
|
# Turn off buffering. POE::Kernel does this for us, but
|
|
# someone might want to use the pipe class elsewhere.
|
|
select((select($write),$| = 1 )[0]);
|
|
return($read, $write);
|
|
}
|
|
elsif ($self->{_debug}) {
|
|
$self->debug("Could not make pipe: $@");
|
|
}
|
|
}
|
|
|
|
# Try a pair of plain INET sockets if no preffered conduit type is
|
|
# specified, or if the specified conduit type is 'inet'.
|
|
if (
|
|
(
|
|
not defined $conduit_type or
|
|
$conduit_type eq 'inet'
|
|
) and (
|
|
$can_run_socket or
|
|
not defined $can_run_socket
|
|
)
|
|
)
|
|
{
|
|
|
|
# Try using a pair of plain INET domain sockets.
|
|
eval { ($read, $write) = $self->make_socket };
|
|
|
|
if (!length $@) {
|
|
|
|
$self->debug("Using inet socket for oneway") if $self->{_debug};
|
|
# Try sockets more often.
|
|
$can_run_socket = 1;
|
|
|
|
# It's one-way, so shut down the unused directions.
|
|
shutdown($read, 1);
|
|
shutdown($write, 0);
|
|
|
|
# Turn off buffering. POE::Kernel does this for us, but someone
|
|
# might want to use the pipe class elsewhere.
|
|
select((select($write), $| = 1)[0]);
|
|
return($read, $write);
|
|
}
|
|
else {
|
|
$self->debug("Could not make socket: $@") if $self->{_debug};
|
|
$can_run_socket = 0;
|
|
}
|
|
}
|
|
$self->debug("Nothing worked") if $self->{_debug};
|
|
return(undef, undef);
|
|
}
|
|
|
|
|
|
# Make a socket. This is a homebrew socketpair() for systems that
|
|
# don't support it. The things I must do to make Windows happy.
|
|
|
|
sub make_socket {
|
|
# ------------------------------------------------------------------------
|
|
my ($self) = @_;
|
|
|
|
### Server side.
|
|
|
|
my $acceptor = gensym();
|
|
my $accepted = gensym();
|
|
|
|
my $tcp = getprotobyname('tcp') or die "getprotobyname: $!";
|
|
socket( $acceptor, PF_INET, SOCK_STREAM, $tcp ) or die "socket: $!";
|
|
|
|
setsockopt($acceptor, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) or die "reuse: $!";
|
|
|
|
my $server_addr = inet_aton('127.0.0.1') or die "inet_aton: $!";
|
|
$server_addr = pack_sockaddr_in( 0, $server_addr ) or die "sockaddr_in: $!";
|
|
|
|
bind($acceptor, $server_addr) or die "bind: $!";
|
|
|
|
$self->stop_blocking($acceptor);
|
|
|
|
$server_addr = getsockname($acceptor);
|
|
|
|
listen($acceptor, SOMAXCONN) or die "listen: $!";
|
|
|
|
### Client side.
|
|
|
|
my $connector = gensym();
|
|
|
|
socket($connector, PF_INET, SOCK_STREAM, $tcp) or die "socket: $!";
|
|
|
|
$self->stop_blocking($connector);
|
|
|
|
unless (connect( $connector, $server_addr)) {
|
|
die "connect: $!"
|
|
if $! and ($! != EINPROGRESS) and ($! != EWOULDBLOCK);
|
|
}
|
|
|
|
my $connector_address = getsockname($connector);
|
|
my ( $connector_port, $connector_addr ) =
|
|
unpack_sockaddr_in($connector_address);
|
|
|
|
### Loop around 'til it's all done. I thought I was done writing
|
|
### select loops. Damnit.
|
|
|
|
my $in_read = '';
|
|
my $in_write = '';
|
|
|
|
vec($in_read, fileno($acceptor), 1) = 1;
|
|
vec($in_write, fileno($connector), 1) = 1;
|
|
|
|
my $done = 0;
|
|
while ( $done != 0x11 ) {
|
|
my $hits =
|
|
select( my $out_read = $in_read, my $out_write = $in_write, undef,
|
|
5 );
|
|
|
|
# For some reason this always dies when called
|
|
# successivly (quickly) on the 5th or 6th call
|
|
die "select: $^E" if $hits < 0;
|
|
#next unless $hits;
|
|
# try again?
|
|
# return $self->make_socket unless $hits;
|
|
|
|
# Accept happened.
|
|
if ( vec( $out_read, fileno($acceptor), 1 ) ) {
|
|
my $peer = accept( $accepted, $acceptor ) or die "accept: $!";
|
|
my ( $peer_port, $peer_addr ) = unpack_sockaddr_in($peer);
|
|
|
|
if ( $peer_port == $connector_port
|
|
and $peer_addr eq $connector_addr )
|
|
{
|
|
vec( $in_read, fileno($acceptor), 1 ) = 0;
|
|
$done |= 0x10;
|
|
}
|
|
}
|
|
|
|
# Connect happened.
|
|
if ( vec( $out_write, fileno($connector), 1 ) ) {
|
|
$! = unpack( 'i', getsockopt( $connector, SOL_SOCKET, SO_ERROR ) );
|
|
die "connect: $!" if $!;
|
|
|
|
vec( $in_read, fileno($acceptor), 1 ) = 0;
|
|
$done |= 0x01;
|
|
}
|
|
}
|
|
|
|
# Turn blocking back on, damnit.
|
|
$self->start_blocking($accepted);
|
|
$self->start_blocking($connector);
|
|
|
|
return ( $accepted, $connector );
|
|
}
|
|
|
|
sub _is_handle {
|
|
my $ref = ref($_[0]);
|
|
return (
|
|
($ref and $ref eq 'GLOB') or
|
|
($ref and $_[0] =~ /=GLOB\(/)
|
|
);
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
GT::IPC::Run - Run programs or code in parallel
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use GT::IPC::Run;
|
|
|
|
# stderr and stdout filters default to a
|
|
# GT::IPC::Line::Filter
|
|
my $exit_code = run
|
|
'/bin/ls', # Program to run
|
|
\*stdout_handle, # stdout event
|
|
\&stderr_handler, # stderr event
|
|
\$stdin; # stdin
|
|
|
|
|
|
my $io = new GT::IPC::Run;
|
|
|
|
use GT::IPC::Filter::Line;
|
|
|
|
my $pid = $io->start(
|
|
stdout => GT::IPC::Filter::Line->new(
|
|
regex => "\r?\n",
|
|
output => sub { print "Output: $_[0]\n" }
|
|
),
|
|
program => sub { print "I got forked\n" },
|
|
);
|
|
|
|
while ($io->do_one_loop) {
|
|
if (defined(my $exit = $io->exit_code($pid))) {
|
|
print "$pid exited ", ($exit>>8), "\n";
|
|
}
|
|
}
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Module to simplify running a program or code reference in parallel. Allows
|
|
catching and filtering the output of the program and filtering it.
|
|
|
|
=head1 FUNCTIONS
|
|
|
|
GT::IPC::Run will import one function C<run()> if you request it to.
|
|
|
|
=head2 run
|
|
|
|
Run is a simple interface to running a program or a subroutine in a separate
|
|
process and catching the output, both stderr and stdout. This function takes
|
|
four arguments, only the first argument is required.
|
|
|
|
=over 4
|
|
|
|
=item First Argument
|
|
|
|
The first argument to C<run()> is the program to run or the code reference to
|
|
run. This argument can be one of three things.
|
|
|
|
If a code reference if passed as the first argument to C<run()>, GT::IPC::Run
|
|
will fork off and run the code reference. You SHOULD NOT exit in the code
|
|
reference if you want your code to work on Windows. Calling C<die()> is ok,
|
|
as your code is evaled. There are some things you CAN NOT do if you want your
|
|
code to work on Windows.
|
|
|
|
You SHOULD NOT make any calles to C<system()> or C<exec()>. For some reason, on
|
|
Windows, this breaks filehandle inheritance so all your output from that moment
|
|
on (including the C<system()> or C<exec()>) call will go to the real output
|
|
channel, STDERR or STDOUT.
|
|
|
|
You SHOULD NOT change STDERR or STDOUT. The child process on Windows can
|
|
affect the filehandles in the parent. This is probably because of the way
|
|
C<fork()> on Windows is emulated as threads.
|
|
|
|
You probably should not C<fork()> either, though this is not confirmed I
|
|
really doubt it will work the way you plan.
|
|
|
|
If an array reference is passed in it will be dereferenced and passed to
|
|
C<exec()>. If a scalar is passed in it will be passed to C<exec()>.
|
|
|
|
On Windows the arguments are passed to Win32::Process::Create as the program
|
|
you wish to run. See L<Win32::Process::Create>.
|
|
|
|
=item Second Argument
|
|
|
|
The second argument to C<run()> is what you want to happen to STDOUT as it
|
|
comes in. This argument can be one of three things.
|
|
|
|
If it is a reference to a GT::IPC::Filter:: class, that will be used to call
|
|
your code. See L<GT::IPC::Filter> for details.
|
|
|
|
If it is a code reference, a new GT::IPC::Filter::Line object will be created
|
|
and your code reference will be passed in. Exactly:
|
|
|
|
$out = GT::IPC::Filter::Line->new($out);
|
|
|
|
GT::IPC::Filter::Line will call your code reference for each line of output
|
|
from the program, the end of the line will be stripped. See
|
|
L<GT::IPC::Filter::Line> for details.
|
|
|
|
If the argument is a scalar reference, again, a new GT::IPC::Filter::Line
|
|
object will be created. Exactly:
|
|
|
|
|
|
$out = GT::IPC::Filter::Line->new(sub { $$out .= $_[0] });
|
|
|
|
|
|
=item Third Argument
|
|
|
|
The third argument to L<run()> is used to handle STDERR if and when what you
|
|
are running produces it.
|
|
|
|
This can be the exact same thing as the second argument, but will work on
|
|
STDERR.
|
|
|
|
=item Forth Argument
|
|
|
|
This argument is how to handle STDIN. It may be one of two things.
|
|
|
|
If it is a SCALAR, it will be printed to the input of what you are running.
|
|
|
|
=back
|
|
|
|
=head1 METHODS
|
|
|
|
=head2 new
|
|
|
|
The is a simple method that takes no arguments and returns a GT::IPC::Run
|
|
object. It may take options in the future.
|
|
|
|
=head2 start
|
|
|
|
This is the more complex method to start a program running. When you call this
|
|
method, the program you specify is started right away and it's PID (process ID)
|
|
is returned to you. After you call this you will either need to call
|
|
C<do_loop()> or C<do_one_loop()> to start getting the programs or code
|
|
references output. See L<"do_loop"> and L<"do_one_loop"> else where in this
|
|
document.
|
|
|
|
This method takes a hash of arguments. The arguments are:
|
|
|
|
=over 4
|
|
|
|
=item program
|
|
|
|
The name of the program, or code reference you wish to run. This is treated
|
|
the same way as the first argument to L<run()>. See L<"run"> else where in
|
|
this document for a description of how this argument is treated.
|
|
|
|
=item stdout
|
|
|
|
This is how you want STDOUT treated. It can be the same things as the second
|
|
argument to L<run()>. See L<"run"> else where in this document for a
|
|
description of how this argument is treated.
|
|
|
|
=item stderr
|
|
|
|
This is how you want STDERR treated. It can be the same things as the third
|
|
argument to L<run()>. See L<"run"> else where in this document for a
|
|
description of how this argument is treated.
|
|
|
|
=item stdin
|
|
|
|
This argument is how to handle STDIN. It may be one of two things. It is
|
|
treated like the forth argument to L<run()>. See L<"run"> else where in this
|
|
document for a description of how this argument is treated.
|
|
|
|
=item reaper
|
|
|
|
This is a code reference that will be ran once a process has exited. Note: the
|
|
process may not be done sending us STDOUT or STDERR when it exits.
|
|
|
|
The code reference is called with the pid as it's first argument and the exit
|
|
status of the program for its second argument. The exit status is the same as
|
|
it is returned by waitpid(). The exit status is somewhat fiddled on Windows to
|
|
act the way you want it to, e.g. C<$exit_status E<gt>E<gt> 8> will be the
|
|
number the program exited with.
|
|
|
|
=item done_callback
|
|
|
|
This is a code reference that works similarly to reaper except that it is only
|
|
called after the child has died AND all STDOUT/STDERR output has been sent,
|
|
unlike reaper which is called on exit, regardless of any output that may still
|
|
be pending.
|
|
|
|
The code reference is called wih the pid and exit status of the program as its
|
|
two arguments.
|
|
|
|
=back
|
|
|
|
=head2 do_one_loop
|
|
|
|
This method takes one argument, the time to wait for C<select()> to return
|
|
something in milliseconds. This does one select loop on all the processes. You
|
|
will need to called this after you call C<start()>. Typically:
|
|
|
|
my $ipc = new GT::IPC::Run;
|
|
my $pid = $ipc->start(program => 'ls');
|
|
1 while $ipc->do_one_loop;
|
|
my $exit_status = $ipc->exit_code($pid);
|
|
|
|
|
|
=head2 do_loop
|
|
|
|
This is similar to C<do_one_loop>, except it does not return unless all
|
|
processes are finished. Almost the same as:
|
|
|
|
1 while $ipc->do_one_loop;
|
|
|
|
You can pass the wait time to C<do_loop()> and it will be passed on to
|
|
C<do_one_loop>. The wait time is in milliseconds.
|
|
|
|
=head2 exit_code
|
|
|
|
This method takes a pid as an argument and returns the exit status of that
|
|
processes pid. If the process has not exited yet or GT::IPC::Run did not launch
|
|
the process, returns undefined. The exit code returned by this is the same as
|
|
returned by waitpid. See L<perlfunc/waitpid> and L<perlfunc/system>.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
See L<perlipc>, L<perlfunc/system>, L<perlfunc/exec>, L<perlfork>, and
|
|
L<Win32::Process>.
|
|
|
|
=head1 MAINTAINER
|
|
|
|
Scott Beck
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
http://www.gossamer-threads.com/
|
|
|
|
=head1 VERSION
|
|
|
|
Revision: $Id: Run.pm,v 1.22 2006/05/26 21:56:30 brewt Exp $
|
|
|
|
=cut
|
|
|