First pass at adding key files
This commit is contained in:
dsainty
@@ -0,0 +1,47 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::IPC::Run::Child
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Child.pm,v 1.2 2002/04/24 04:07:18 alex Exp $
|
||||
#
|
||||
# Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Child storrage class
|
||||
#
|
||||
|
||||
package GT::IPC::Run::Child;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %self = @_;
|
||||
bless \%self, $class;
|
||||
return \%self;
|
||||
}
|
||||
|
||||
sub program { if (@_ > 1) { $_[0]->{program} = $_[1]; } return $_[0]->{program}; }
|
||||
sub stderr_read { if (@_ > 1) { $_[0]->{stderr_read} = $_[1]; } return $_[0]->{stderr_read}; }
|
||||
sub stderr_write { if (@_ > 1) { $_[0]->{stderr_write} = $_[1]; } return $_[0]->{stderr_write}; }
|
||||
sub stdout_read { if (@_ > 1) { $_[0]->{stdout_read} = $_[1]; } return $_[0]->{stdout_read}; }
|
||||
sub stdout_write { if (@_ > 1) { $_[0]->{stdout_write} = $_[1]; } return $_[0]->{stdout_write}; }
|
||||
sub stdin_read { if (@_ > 1) { $_[0]->{stdin_read} = $_[1]; } return $_[0]->{stdin_read}; }
|
||||
sub stdin_write { if (@_ > 1) { $_[0]->{stdin_write} = $_[1]; } return $_[0]->{stdin_write}; }
|
||||
sub stdin { if (@_ > 1) { $_[0]->{stdin} = $_[1]; } return $_[0]->{stdin}; }
|
||||
sub handler_stdout { if (@_ > 1) { $_[0]->{handler_stdout} = $_[1]; } return $_[0]->{handler_stdout}; }
|
||||
sub handler_stderr { if (@_ > 1) { $_[0]->{handler_stderr} = $_[1]; } return $_[0]->{handler_stderr}; }
|
||||
sub exit_callback { if (@_ > 1) { $_[0]->{exit_callback} = $_[1]; } return $_[0]->{exit_callback}; }
|
||||
sub done_callback { if (@_ > 1) { $_[0]->{done_callback} = $_[1]; } return $_[0]->{done_callback}; }
|
||||
sub exit_status { if (@_ > 1) { $_[0]->{exit_status} = $_[1]; } return $_[0]->{exit_status}; }
|
||||
sub pid { if (@_ > 1) { $_[0]->{pid} = $_[1]; } return $_[0]->{pid}; }
|
||||
sub called_reaper { if (@_ > 1) { $_[0]->{called_reaper} = $_[1]; } return $_[0]->{called_reaper}; }
|
||||
sub process { if (@_ > 1) { $_[0]->{process} = $_[1]; } return $_[0]->{process}; }
|
||||
sub forked { if (@_ > 1) { $_[0]->{forked} = $_[1]; } return $_[0]->{forked}; }
|
||||
sub called_done { if (@_ > 1) { $_[0]->{called_done} = $_[1]; } return $_[0]->{called_done}; }
|
||||
|
||||
1;
|
||||
|
||||
131
site/slowtwitch.com/cgi-bin/articles/admin/GT/IPC/Run/Select.pm
Normal file
131
site/slowtwitch.com/cgi-bin/articles/admin/GT/IPC/Run/Select.pm
Normal file
@@ -0,0 +1,131 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::IPC::Run::Select
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Select.pm,v 1.6 2004/01/13 01:35:17 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Select IO for children handles
|
||||
#
|
||||
|
||||
package GT::IPC::Run::Select;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
|
||||
use POSIX qw(errno_h);
|
||||
use constants
|
||||
STDOUT_FN => 0,
|
||||
STDERR_FN => 1;
|
||||
|
||||
sub new {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($class) = @_;
|
||||
return bless {}, $class;
|
||||
}
|
||||
|
||||
sub add_stdout {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $pid, $stdout) = @_;
|
||||
my $bits = delete $self->{vec_bits};
|
||||
$bits = '' unless defined $bits;
|
||||
|
||||
if (defined $stdout) {
|
||||
my $stdout_fn = fileno($stdout);
|
||||
vec($bits, $stdout_fn, 1) = 1;
|
||||
$self->{$pid}[STDOUT_FN] = $stdout_fn;
|
||||
}
|
||||
$self->{vec_bits} = $bits;
|
||||
}
|
||||
|
||||
sub add_stderr {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $pid, $stderr) = @_;
|
||||
my $bits = delete $self->{vec_bits};
|
||||
$bits = '' unless defined $bits;
|
||||
|
||||
if (defined $stderr) {
|
||||
my $stderr_fn = fileno($stderr);
|
||||
vec($bits, $stderr_fn, 1) = 1;
|
||||
$self->{$pid}[STDERR_FN] = $stderr_fn;
|
||||
}
|
||||
$self->{vec_bits} = $bits;
|
||||
}
|
||||
|
||||
sub remove_stdout {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $pid) = @_;
|
||||
my $bits = delete $self->{vec_bits};
|
||||
$bits = '' unless defined $bits;
|
||||
|
||||
my $fn = $self->{$pid}[STDOUT_FN];
|
||||
if (defined $fn) {
|
||||
vec($bits, $fn, 1) = 0;
|
||||
undef $self->{$pid}[STDOUT_FN];
|
||||
}
|
||||
$self->{vec_bits} = $bits;
|
||||
}
|
||||
|
||||
sub remove_stderr {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $pid) = @_;
|
||||
my $bits = delete $self->{vec_bits};
|
||||
$bits = '' unless defined $bits;
|
||||
|
||||
my $fn = $self->{$pid}[STDERR_FN];
|
||||
if (defined $fn) {
|
||||
vec($bits, $fn, 1) = 0;
|
||||
undef $self->{$pid}[STDERR_FN];
|
||||
}
|
||||
$self->{vec_bits} = $bits;
|
||||
}
|
||||
|
||||
sub can_read {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $timeout) = @_;
|
||||
my $bits = delete $self->{vec_bits};
|
||||
my $sbits = $bits;
|
||||
|
||||
local $!;
|
||||
my $nfound;
|
||||
do {
|
||||
$! = 0;
|
||||
$nfound = select($sbits, undef, undef, $timeout);
|
||||
} while $! == EINTR;
|
||||
if (defined $sbits and $nfound > 0) {
|
||||
my (@stdout_waiting, @stderr_waiting);
|
||||
for my $pid (keys %$self ) {
|
||||
my $child = $self->{$pid};
|
||||
if (!defined $self->{$pid}[STDOUT_FN] and !defined $self->{$pid}[STDERR_FN]) {
|
||||
delete $self->{$pid};
|
||||
next;
|
||||
}
|
||||
if (defined $child->[STDOUT_FN] and (!defined $sbits or vec($sbits, $child->[STDOUT_FN], 1))) {
|
||||
push @stdout_waiting, $pid;
|
||||
}
|
||||
if (defined $child->[STDERR_FN] and (!defined $sbits or vec($sbits, $child->[STDERR_FN], 1))) {
|
||||
push @stderr_waiting, $pid;
|
||||
}
|
||||
}
|
||||
if (!@stdout_waiting and !@stderr_waiting) {
|
||||
$self->debug(
|
||||
"Select said we have nfound, but did not find anything pending!"
|
||||
) if $self->{_debug};
|
||||
}
|
||||
$self->{vec_bits} = $bits;
|
||||
return(\@stdout_waiting, \@stderr_waiting);
|
||||
}
|
||||
elsif ($nfound < 0) {
|
||||
$self->debug("Socket error: $!") if $self->{_debug};
|
||||
}
|
||||
$self->{vec_bits} = $bits;
|
||||
return [], [];
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
306
site/slowtwitch.com/cgi-bin/articles/admin/GT/IPC/Run/Unix.pm
Normal file
306
site/slowtwitch.com/cgi-bin/articles/admin/GT/IPC/Run/Unix.pm
Normal file
@@ -0,0 +1,306 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::IPC::Run::Unix
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Unix.pm,v 1.24 2004/02/17 01:33:07 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
|
||||
package GT::IPC::Run::Unix;
|
||||
|
||||
use strict;
|
||||
use vars qw/$EVENTS $ERROR_MESSAGE/;
|
||||
use base 'GT::Base';
|
||||
|
||||
use IO::Select;
|
||||
use POSIX qw(fcntl_h errno_h :sys_wait_h);
|
||||
|
||||
sub READ_BLOCK () { 512 }
|
||||
|
||||
@GT::IPC::Run::Unix::ISA = qw(GT::IPC::Run);
|
||||
$ERROR_MESSAGE = 'GT::IPC::Run';
|
||||
|
||||
sub execute {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self) = @_;
|
||||
|
||||
# unless ($self->{sigchld_installed}) {
|
||||
# $self->{chld_signal} = sub {
|
||||
# my $child;
|
||||
# while (($child = waitpid -1, WNOHANG) > 0) {
|
||||
# $self->{goners}{$child} = $?;
|
||||
# $self->debug(
|
||||
# "forked child $child exited with exit status (".
|
||||
# ($self->{goners}{$child} >> 8).
|
||||
# ")\n"
|
||||
# ) if $self->{_debug};
|
||||
# }
|
||||
# $SIG{CHLD} = $self->{chld_signal};
|
||||
# };
|
||||
# $SIG{CHLD} = $self->{chld_signal};
|
||||
# $self->{sigchld_installed} = 1;
|
||||
# }
|
||||
|
||||
# Create a semaphore pipe. This is used so that the parent doesn't
|
||||
# begin listening until the child's stdio has been set up.
|
||||
my ($child_pipe_read, $child_pipe_write) = $self->oneway;
|
||||
die "Could not create semaphore socket: $!" unless defined $child_pipe_read;
|
||||
|
||||
my $pid;
|
||||
if ($pid = fork) { # Parent
|
||||
my $child = delete $self->{current_child};
|
||||
$self->{select}->add_stdout($pid => $child->stdout_read);
|
||||
$self->{select}->add_stderr($pid => $child->stderr_read);
|
||||
$self->{children}{$pid} = $child;
|
||||
$child->pid($pid);
|
||||
if ($child->stdin and ref($child->stdin) eq 'SCALAR') {
|
||||
print {$child->stdin_write} ${$child->stdin};
|
||||
close $child->stdin_write;
|
||||
}
|
||||
|
||||
# Cludge to stop speed forking
|
||||
select undef, undef, undef, 0.001;
|
||||
|
||||
# Close what the parent will not need
|
||||
# close $child->stdout_write if $child->stdout_write;
|
||||
# close $child->stderr_write if $child->stderr_write;
|
||||
# close $child->stdin_read if $child->stdin_read;
|
||||
<$child_pipe_read>;
|
||||
close $child_pipe_read;
|
||||
close $child_pipe_write;
|
||||
return $pid;
|
||||
}
|
||||
else {
|
||||
$self->fatal(FORK => "$!") unless defined $pid;
|
||||
$self->debug("Forked: $$\n") if $self->{_debug} > 1;
|
||||
|
||||
# Get out self and out filenos
|
||||
my $self = delete $self->{current_child};
|
||||
my ($stdout_fn, $stderr_fn, $stdin_fn);
|
||||
$stdout_fn = fileno($self->stdout_write) if $self->stdout_write;
|
||||
$stderr_fn = fileno($self->stderr_write) if $self->stderr_write;
|
||||
$stdin_fn = fileno($self->stdin_read) if $self->stdin_read;
|
||||
# Close what the child won't need.
|
||||
# close $self->stdin_write if $self->stdin_write;
|
||||
# close $self->stderr_read if $self->stderr_read;
|
||||
# close $self->stdout_read if $self->stdout_read;
|
||||
|
||||
# Tied handles break this
|
||||
untie *STDOUT if tied *STDOUT;
|
||||
untie *STDERR if tied *STDERR;
|
||||
untie *STDIN if tied *STDIN;
|
||||
|
||||
# Redirect STDOUT to the write end of the stdout pipe.
|
||||
if (defined $stdout_fn) {
|
||||
$self->debug("Opening stdout to fileno $stdout_fn") if $self->{_debug};
|
||||
open( STDOUT, ">&$stdout_fn" )
|
||||
or die "can't redirect stdout in child pid $$: $!";
|
||||
$self->debug("stdout opened") if $self->{_debug};
|
||||
}
|
||||
|
||||
# Redirect STDIN from the read end of the stdin pipe.
|
||||
if (defined $stdin_fn) {
|
||||
$self->debug("Opening stdin to fileno $stdin_fn") if $self->{_debug};
|
||||
open( STDIN, "<&$stdin_fn" )
|
||||
or die "can't redirect STDIN in child pid $$: $!";
|
||||
$self->debug("stdin opened") if $self->{_debug};
|
||||
}
|
||||
|
||||
# Redirect STDERR to the write end of the stderr pipe.
|
||||
if (defined $stderr_fn) {
|
||||
$self->debug("Opening stderr to fileno $stderr_fn") if $self->{_debug};
|
||||
open( STDERR, ">&$stderr_fn" )
|
||||
or die "can't redirect stderr in child: $!";
|
||||
}
|
||||
|
||||
select STDERR; $| = 1;
|
||||
select STDOUT; $| = 1;
|
||||
|
||||
# Tell the parent that the stdio has been set up.
|
||||
close $child_pipe_read;
|
||||
print $child_pipe_write "go\n";
|
||||
close $child_pipe_write;
|
||||
|
||||
# Program code here
|
||||
my $program = $self->program;
|
||||
if (ref($program) eq 'ARRAY') {
|
||||
exec(@$program) or do {
|
||||
print STDERR "can't exec (@$program) in child pid $$:$!\n";
|
||||
eval { POSIX::_exit($?); };
|
||||
eval { kill KILL => $$; };
|
||||
};
|
||||
}
|
||||
elsif (ref($program) eq 'CODE') {
|
||||
$? = 0;
|
||||
$program->();
|
||||
|
||||
# In case flushing them wasn't good enough.
|
||||
close STDOUT if defined fileno(STDOUT);
|
||||
close STDERR if defined fileno(STDERR);
|
||||
|
||||
eval { POSIX::_exit($?); };
|
||||
eval { kill KILL => $$; };
|
||||
}
|
||||
else {
|
||||
exec($program) or do {
|
||||
print STDERR "can't exec ($program) in child pid $$:$!\n";
|
||||
eval { POSIX::_exit($?); };
|
||||
eval { kill KILL => $$; };
|
||||
};
|
||||
}
|
||||
die "How did I get here!";
|
||||
}
|
||||
}
|
||||
|
||||
sub put {
|
||||
# ------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $pid = shift;
|
||||
print {$self->{children}{$pid}->stdin_write} @_;
|
||||
}
|
||||
|
||||
sub do_one_loop {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $wait) = @_;
|
||||
$wait = 0.05 unless defined $wait;
|
||||
|
||||
# See if any children have exited
|
||||
my $child;
|
||||
while (($child = waitpid -1, WNOHANG) > 0) {
|
||||
next unless exists $self->{children}{$child};
|
||||
$self->{goners}{$child} = $?;
|
||||
$self->{children}{$child}->exit_status($?);
|
||||
$self->debug(
|
||||
"forked child $child exited with exit status (".
|
||||
($self->{goners}{$child} >> 8).
|
||||
")\n"
|
||||
) if $self->{_debug};
|
||||
}
|
||||
|
||||
for my $pid (keys %{$self->{goners}} ) {
|
||||
my $child = $self->{children}{$pid} or next;
|
||||
if (!$child->called_reaper) {
|
||||
$child->exit_callback->($pid, $self->{goners}{$pid})
|
||||
if $child->exit_callback;
|
||||
$child->called_reaper(1);
|
||||
}
|
||||
}
|
||||
my ($stdout_pending, $stderr_pending) = $self->{select}->can_read($wait);
|
||||
|
||||
my %not_pending = %{$self->{children}};
|
||||
for my $pid (@$stdout_pending, @$stderr_pending) {
|
||||
delete $not_pending{$pid};
|
||||
}
|
||||
for my $pid (keys %{$self->{goners}}) {
|
||||
my $child = $self->{children}{$pid} or next;
|
||||
if ($not_pending{$pid} and not $child->called_done) {
|
||||
$child->done_callback->($pid, $self->{goners}{$pid})
|
||||
if $child->done_callback;
|
||||
$child->called_done(1);
|
||||
}
|
||||
}
|
||||
|
||||
if (!@$stdout_pending and !@$stderr_pending) {
|
||||
$self->debug("Nothing else to do, flushing buffers")
|
||||
if $self->{_debug};
|
||||
$self->debug(
|
||||
"Children: ".
|
||||
keys(%{$self->{children}}).
|
||||
"; goners: ".
|
||||
keys(%{$self->{goners}})
|
||||
) if $self->{_debug};
|
||||
|
||||
# We still have children out there
|
||||
return 1 if keys(%{$self->{children}}) > keys(%{$self->{goners}});
|
||||
|
||||
# Flush output filters and delete children to free memory and FDs
|
||||
$self->flush_filters;
|
||||
|
||||
# Nothing left to do
|
||||
return 0;
|
||||
}
|
||||
# else we have stuff to do
|
||||
for my $pid (@$stdout_pending) {
|
||||
my $child = $self->{children}{$pid};
|
||||
$self->debug("STDOUT pending for $pid") if $self->{_debug};
|
||||
|
||||
my $ret = sysread($child->stdout_read, my $buff, READ_BLOCK);
|
||||
if (!$ret) {
|
||||
if ($! != EAGAIN and $! != 0) {
|
||||
# Socket error
|
||||
$self->debug(
|
||||
"$pid: Socket Read: $!: $^E; Errno: ", 0+$!
|
||||
) if $self->{_debug};
|
||||
}
|
||||
}
|
||||
else {
|
||||
# Process callbacks
|
||||
$self->debug("[$pid STDOUT]: `$buff'\n")
|
||||
if $self->{_debug} > 1;
|
||||
if ($child->handler_stdout) {
|
||||
$child->handler_stdout->put(\$buff);
|
||||
}
|
||||
}
|
||||
}
|
||||
for my $pid (@$stderr_pending) {
|
||||
my $child = $self->{children}{$pid};
|
||||
$self->debug("STDERR pending for $pid") if $self->{_debug};
|
||||
|
||||
my $ret = sysread($child->stderr_read, my $buff, READ_BLOCK);
|
||||
if (!$ret) {
|
||||
if ($! != EAGAIN and $! != 0) {
|
||||
# Socket error
|
||||
$self->debug(
|
||||
"$pid: Socket Read: $!: $^E; Errno: ", 0+$!
|
||||
) if $self->{_debug};
|
||||
}
|
||||
}
|
||||
else {
|
||||
# Process callbacks
|
||||
$self->debug("[$pid STDERR]: `$buff'\n")
|
||||
if $self->{_debug} > 1;
|
||||
if ($child->handler_stderr) {
|
||||
$child->handler_stderr->put(\$buff);
|
||||
}
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub flush_filters {
|
||||
# ------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
for my $pid (keys %{$self->{children}}) {
|
||||
my $child = delete $self->{children}{$pid};
|
||||
$self->select->remove_stdout($pid);
|
||||
$self->select->remove_stderr($pid);
|
||||
if ($child->handler_stdout) {
|
||||
$child->handler_stdout->flush;
|
||||
}
|
||||
if ($child->handler_stderr) {
|
||||
$child->handler_stderr->flush;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub stop_blocking {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $socket_handle) = @_;
|
||||
my $flags = fcntl($socket_handle, F_GETFL, 0) or die "getfl: $!";
|
||||
$flags = fcntl($socket_handle, F_SETFL, $flags | O_NONBLOCK)
|
||||
or die "setfl: $!";
|
||||
}
|
||||
|
||||
sub start_blocking {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $socket_handle) = @_;
|
||||
my $flags = fcntl($socket_handle, F_GETFL, 0) or die "getfl: $!";
|
||||
$flags = fcntl($socket_handle, F_SETFL, $flags & ~O_NONBLOCK)
|
||||
or die "setfl: $!";
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
505
site/slowtwitch.com/cgi-bin/articles/admin/GT/IPC/Run/Win32.pm
Normal file
505
site/slowtwitch.com/cgi-bin/articles/admin/GT/IPC/Run/Win32.pm
Normal file
@@ -0,0 +1,505 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::IPC::Run::Win32
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Win32.pm,v 1.16 2006/03/30 18:40:22 sbeck Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
|
||||
package GT::IPC::Run::Win32;
|
||||
|
||||
use strict;
|
||||
use vars qw/$EVENTS $ERROR_MESSAGE/;
|
||||
use base 'GT::Base';
|
||||
|
||||
use POSIX qw(fcntl_h errno_h :sys_wait_h);
|
||||
use GT::Lock qw/lock unlock/;
|
||||
use Win32;
|
||||
use Win32::Process;
|
||||
use Win32::Mutex;
|
||||
sub READ_BLOCK () { 512 }
|
||||
|
||||
# What Win32 module exports this?
|
||||
sub WSAEWOULDBLOCK () { 10035 }
|
||||
|
||||
@GT::IPC::Run::Win32::ISA = qw(GT::IPC::Run);
|
||||
|
||||
$ERROR_MESSAGE = 'GT::IPC::Run';
|
||||
|
||||
sub execute {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self) = @_;
|
||||
|
||||
my $pid;
|
||||
my $child = $self->{current_child};
|
||||
if (ref($child->program) eq 'ARRAY' or !ref($child->program)) {
|
||||
my $process = $self->fork_exec;
|
||||
$child->pid($process->GetProcessID);
|
||||
$child->process($process);
|
||||
}
|
||||
else {
|
||||
$child->pid($self->fork_code);
|
||||
$child->forked(1);
|
||||
}
|
||||
$self->{children}{$child->pid} = delete $self->{current_child};
|
||||
return $child->pid;
|
||||
}
|
||||
|
||||
sub put {
|
||||
# ------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $pid = shift;
|
||||
print {$self->{children}{$pid}->stdin_write} @_;
|
||||
}
|
||||
|
||||
sub fork_exec {
|
||||
# ------------------------------------------------------------------------
|
||||
# Called on Win32 systems when wanting to exec() a process. This replaces
|
||||
# forking and executing. You cannot get filehandle inheritance when exec()
|
||||
# after a fork, fun stuff.
|
||||
my $self = shift;
|
||||
|
||||
|
||||
my $child = $self->{current_child};
|
||||
my $process = '';
|
||||
my $program = ref($child->program) eq 'ARRAY'
|
||||
? $child->program
|
||||
: [split ' ', $child->program];
|
||||
open STDOUT_SAVE, ">&STDOUT";
|
||||
open STDERR_SAVE, ">&STDERR";
|
||||
open STDIN_SAVE, "<&STDIN";
|
||||
|
||||
# Redirect STDOUT to the write end of the stdout pipe.
|
||||
if ($child->stdout_write) {
|
||||
my $fn = fileno($child->stdout_write);
|
||||
if (defined $fn) {
|
||||
$self->debug("Opening stdout to fileno $fn") if $self->{_debug};
|
||||
open( STDOUT, ">&$fn" )
|
||||
or die "can't redirect stdout in child pid $$: $!";
|
||||
$self->debug("stdout opened") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
die "No fileno for stdout_write";
|
||||
}
|
||||
}
|
||||
|
||||
# Redirect STDIN from the read end of the stdin pipe.
|
||||
if ($child->stdin_read) {
|
||||
my $fn = fileno($child->stdin_read);
|
||||
if (defined $fn) {
|
||||
$self->debug("Opening stdin to fileno $fn") if $self->{_debug};
|
||||
open( STDIN, "<&$fn" )
|
||||
or die "can't redirect STDIN in child pid $$: $!";
|
||||
$self->debug("stdin opened") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
die "No fileno for stdin_read";
|
||||
}
|
||||
}
|
||||
|
||||
# Redirect STDERR to the write end of the stderr pipe.
|
||||
if ($child->stderr_write) {
|
||||
my $fn = fileno($child->stderr_write);
|
||||
if (defined $fn) {
|
||||
$self->debug("Opening stderr to fileno $fn") if $self->{_debug};
|
||||
open( STDERR, ">&$fn" )
|
||||
or die "can't redirect stderr in child: $!";
|
||||
}
|
||||
else {
|
||||
die "No fileno for stderr_write";
|
||||
}
|
||||
}
|
||||
|
||||
select STDOUT; $| = 1;
|
||||
select STDERR; $| = 1;
|
||||
select STDOUT;
|
||||
Win32::Process::Create(
|
||||
$process,
|
||||
$program->[0],
|
||||
"@$program",
|
||||
1,
|
||||
NORMAL_PRIORITY_CLASS,
|
||||
'.'
|
||||
) or do {
|
||||
open STDOUT, ">&STDOUT_SAVE";
|
||||
open STDERR, ">&STDERR_SAVE";
|
||||
open STDIN, "<&STDIN_SAVE";
|
||||
die "can't exec (@$program) using Win32::Process; Reason: ".
|
||||
Win32::FormatMessage(Win32::GetLastError);
|
||||
};
|
||||
syswrite($child->stdin_write, ${$child->stdin}, length(${$child->stdin}), 0)
|
||||
if ref($child->stdin) eq 'SCALAR';
|
||||
open STDOUT, ">&STDOUT_SAVE";
|
||||
open STDERR, ">&STDERR_SAVE";
|
||||
open STDIN, "<&STDIN_SAVE";
|
||||
return $process;
|
||||
}
|
||||
|
||||
sub fork_code {
|
||||
# ------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
# Hack to keep from forking too many process too fast, perl on windows
|
||||
# tends to segv when that happens
|
||||
select undef, undef, undef, 0.5;
|
||||
|
||||
# So we know when the child is finished setting up
|
||||
my $mutex = new Win32::Mutex(1, 'CHILD');
|
||||
my $pid;
|
||||
if ($pid = fork) { # Parent
|
||||
my $child = $self->{current_child};
|
||||
$mutex->wait(2000);
|
||||
print {$child->stdin_write} ${$child->stdin}
|
||||
if ref($child->stdin) eq 'SCALAR';
|
||||
return $pid;
|
||||
}
|
||||
else {
|
||||
$self->fatal( FORK => "$!" ) unless defined $pid;
|
||||
$self->debug("Forked: $$\n") if $self->{_debug} > 1;
|
||||
|
||||
# Hack to keep the child from destroying the mutex
|
||||
{
|
||||
package GT::IPC::Run::Mutex;
|
||||
@GT::IPC::Run::Mutex::ISA = 'Win32::Mutex';
|
||||
sub DESTROY {}
|
||||
}
|
||||
bless $mutex, 'GT::IPC::Run::Mutex';
|
||||
|
||||
my $child = $self->{current_child};
|
||||
my ($stdout, $stderr, $stdin) = (
|
||||
$child->stdout_write,
|
||||
$child->stderr_write,
|
||||
$child->stdin_read
|
||||
);
|
||||
|
||||
# Redirect STDOUT to the write end of the stdout pipe.
|
||||
if (defined $stdout) {
|
||||
*STDOUT = $stdout;
|
||||
$self->debug("stdout opened") if $self->{_debug};
|
||||
}
|
||||
|
||||
# Redirect STDIN from the read end of the stdin pipe.
|
||||
if (defined $stdin) {
|
||||
*STDIN = $stdin;
|
||||
$self->debug("stdin opened") if $self->{_debug};
|
||||
}
|
||||
|
||||
# Redirect STDERR to the write end of the stderr pipe.
|
||||
if (defined $stderr) {
|
||||
*STDERR = $stderr;
|
||||
}
|
||||
|
||||
select STDERR; $| = 1;
|
||||
select STDOUT; $| = 1;
|
||||
|
||||
# Tell the parent that the stdio has been set up.
|
||||
$mutex->release;
|
||||
|
||||
# Launch the code reference
|
||||
$child->program->();
|
||||
close STDOUT if defined fileno STDOUT;
|
||||
close STDERR if defined fileno STDERR;
|
||||
exit(0);
|
||||
}
|
||||
}
|
||||
|
||||
sub do_one_loop {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $wait) = @_;
|
||||
$wait = 0.05 unless defined $wait;
|
||||
|
||||
$self->check_for_exit;
|
||||
$self->debug(
|
||||
"Children: ". keys(%{$self->{children}}).
|
||||
"; goners: ". keys(%{$self->{goners}})
|
||||
) if $self->{_debug};
|
||||
|
||||
for my $pid (keys %{$self->{children}}) {
|
||||
my $child = $self->{children}{$pid};
|
||||
|
||||
if ($child->stdout_read) {
|
||||
my $ret = sysread($child->stdout_read, my $buff, READ_BLOCK);
|
||||
if (!$ret) {
|
||||
# Fun stuff with win32
|
||||
if ($! == EAGAIN) {
|
||||
# Socket error
|
||||
#$self->{select}->remove_stdout($pid);
|
||||
$self->debug(
|
||||
"1: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E)
|
||||
) if $self->{_debug};
|
||||
}
|
||||
elsif ($! == WSAEWOULDBLOCK and exists $self->{goners}{$pid}) {
|
||||
$child->{socket_err}++;
|
||||
$self->debug(
|
||||
"2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E)
|
||||
) if $self->{_debug} > 1;
|
||||
}
|
||||
else {
|
||||
$child->{socket_err}++;
|
||||
$self->debug(
|
||||
"2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E)
|
||||
) if $self->{_debug} > 1;
|
||||
}
|
||||
}
|
||||
else {
|
||||
# Process callbacks
|
||||
$self->debug("[$pid STDOUT]: `$buff'\n") if $self->{_debug} > 1;
|
||||
if (defined $child->handler_stdout) {
|
||||
$child->handler_stdout->put(\$buff);
|
||||
}
|
||||
}
|
||||
}
|
||||
if ($child->stderr_read) {
|
||||
my $ret = sysread($child->stderr_read, my $buff, READ_BLOCK);
|
||||
if (!$ret) {
|
||||
# Fun stuff with win32
|
||||
if ($! == EAGAIN) {
|
||||
# Socket error
|
||||
#$self->{select}->remove_stderr($pid);
|
||||
$self->debug(
|
||||
"1: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E)
|
||||
) if $self->{_debug};
|
||||
}
|
||||
elsif ($! == WSAEWOULDBLOCK and exists $self->{goners}{$pid}) {
|
||||
$child->{socket_err}++;
|
||||
$self->debug(
|
||||
"2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E)
|
||||
) if $self->{_debug} > 1;
|
||||
}
|
||||
else {
|
||||
$child->{socket_err}++;
|
||||
$self->debug(
|
||||
"2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E)
|
||||
) if $self->{_debug} > 1;
|
||||
}
|
||||
}
|
||||
else {
|
||||
# Process callbacks
|
||||
$self->debug("[$pid STDERR]: `$buff'\n") if $self->{_debug} > 1;
|
||||
if (defined $child->handler_stderr) {
|
||||
$child->handler_stderr->put(\$buff);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
# Call the "done" callback for anything that has exited and has no pending output
|
||||
my %not_pending = %{$self->{children}};
|
||||
for my $child (values %{$self->{children}}) {
|
||||
if ($child->{socket_err} >= 2) {
|
||||
delete $not_pending{$child->{pid}};
|
||||
}
|
||||
}
|
||||
for my $pid (keys %{$self->{goners}}) {
|
||||
my $child = $self->{children}{$pid} or next;
|
||||
if ($not_pending{$pid} and not $child->called_done) {
|
||||
$child->done_callback->($pid, $self->{goners}{$pid})
|
||||
if $child->done_callback;
|
||||
$child->called_done(1);
|
||||
}
|
||||
}
|
||||
|
||||
my $done;
|
||||
for my $child (values %{$self->{children}}) {
|
||||
if ($child->{socket_err} >= 2) {
|
||||
$done++;
|
||||
}
|
||||
}
|
||||
if ($done == keys %{$self->{children}} and (keys(%{$self->{children}}) <= keys(%{$self->{goners}}))) {
|
||||
# We still have children out there
|
||||
if (keys(%{$self->{children}}) > keys(%{$self->{goners}})) {
|
||||
$self->debug("We still have children") if $self->{_debug};
|
||||
return 1;
|
||||
}
|
||||
|
||||
$self->debug("Nothing else to do, flushing buffers")
|
||||
if $self->{_debug};
|
||||
|
||||
# Flush output filters
|
||||
for my $pid (keys %{$self->{children}}) {
|
||||
my $child = delete $self->{children}{$pid};
|
||||
$self->select->remove_stdout($pid);
|
||||
$self->select->remove_stderr($pid);
|
||||
if ($child->handler_stdout) {
|
||||
$child->handler_stdout->flush;
|
||||
}
|
||||
if ($child->handler_stderr) {
|
||||
$child->handler_stderr->flush;
|
||||
}
|
||||
}
|
||||
|
||||
# Nothing left to do
|
||||
$self->debug("Returning 0") if $self->{_debug};
|
||||
return 0;
|
||||
}
|
||||
|
||||
# for my $pid (@$stdout_pending) {
|
||||
# my $child = $self->{children}{$pid};
|
||||
# $self->debug("STDOUT pending for $pid") if $self->{_debug};
|
||||
#
|
||||
# my $ret = sysread($child->stdout_read, my $buff, READ_BLOCK);
|
||||
# if (!$ret) {
|
||||
# # Fun stuff with win32
|
||||
# if ($! != EAGAIN and $! != WSAEWOULDBLOCK) {
|
||||
# # Socket error
|
||||
# $self->{select}->remove_stdout($pid);
|
||||
# $self->debug("1: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ", (0+$!), "; OSErrno: ", (0+$^E))
|
||||
# if $self->{_debug};
|
||||
# }
|
||||
# else {
|
||||
# $self->debug("2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ", (0+$!), "; OSErrno: ", (0+$^E))
|
||||
# if $self->{_debug};
|
||||
# }
|
||||
# }
|
||||
# else {
|
||||
# # Process callbacks
|
||||
# $self->debug("[$pid STDOUT]: `$buff'\n") if $self->{_debug} > 1;
|
||||
# if (defined $child->handler_stdout) {
|
||||
# $child->handler_stdout->put(\$buff);
|
||||
# }
|
||||
# }
|
||||
# }
|
||||
#
|
||||
# for my $pid (@$stderr_pending) {
|
||||
# my $child = $self->{children}{$pid};
|
||||
# $self->debug("STDERR pending for $pid") if $self->{_debug};
|
||||
#
|
||||
# my $ret = sysread($child->stderr_read, my $buff, READ_BLOCK);
|
||||
# if (!$ret) {
|
||||
# # Fun stuff with win32
|
||||
# if ($! != EAGAIN and $! != WSAEWOULDBLOCK) {
|
||||
# # Socket error
|
||||
# $self->{select}->remove_stderr($pid);
|
||||
# $self->debug("1: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ", (0+$!), "; OSErrno: ", (0+$^E))
|
||||
# if $self->{_debug};
|
||||
# }
|
||||
# else {
|
||||
# $self->debug("2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ", (0+$!), "; OSErrno: ", (0+$^E))
|
||||
# if $self->{_debug};
|
||||
# }
|
||||
# }
|
||||
# else {
|
||||
# # Process callbacks
|
||||
# $self->debug("[$pid STDERR]: `$buff'\n") if $self->{_debug} > 1;
|
||||
# if (defined $child->handler_stderr) {
|
||||
# $child->handler_stderr->put(\$buff);
|
||||
# }
|
||||
# }
|
||||
# }
|
||||
return 1;
|
||||
}
|
||||
|
||||
my $warned;
|
||||
sub check_for_exit {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self) = @_;
|
||||
# This process was created with Win32::Process. The problem is
|
||||
# there is no way to reliably get the output from a Win32::Process
|
||||
# program in a loop like this. Output handles are not flushed when
|
||||
# process exits, which means that if it blocks a little we will
|
||||
# likly lose the last output it produces, this is so not nice.
|
||||
for my $pid (keys %{$self->{children}}) {
|
||||
my $child = $self->{children}{$pid};
|
||||
next if exists $self->{goners}{$pid};
|
||||
|
||||
if ($child->forked) {
|
||||
# Check if the program exited
|
||||
my $got_pid;
|
||||
my $waited = waitpid($pid, WNOHANG);
|
||||
my $killed = 1;
|
||||
$self->debug("waited: $waited; pid: $pid")
|
||||
if $self->{_debug};
|
||||
if ($waited < -1) {
|
||||
$self->{goners}{$pid} = $?;
|
||||
$child->exit_callback->($pid, $?)
|
||||
if $child->exit_callback;
|
||||
$self->debug(
|
||||
"forked child $pid exited with exit status (".
|
||||
($self->{goners}{$pid} >> 8).
|
||||
")\n"
|
||||
) if $self->{_debug};
|
||||
}
|
||||
elsif ($waited == -1) {
|
||||
$self->{goners}{$pid} = 0;
|
||||
$child->exit_callback->($pid, 0)
|
||||
if $child->exit_callback;
|
||||
}
|
||||
# elsif ($waited == -1) {
|
||||
# for my $pid (keys %{$self->{children}}) {
|
||||
# $self->{select}->remove_stdout($pid);
|
||||
# $self->{select}->remove_stderr($pid);
|
||||
# unless (exists $self->{goners}{$pid}) {
|
||||
# $self->{goners}{$pid} = -1;
|
||||
# $self->{children}{$pid}{exit_callback}->($pid, -1)
|
||||
# if $self->{children}{$pid}{exit_callback};
|
||||
# }
|
||||
# }
|
||||
# }
|
||||
# elsif (!$killed) {
|
||||
# $self->{goners}{$pid} = -1;
|
||||
# $self->{children}{$pid}{exit_callback}->($pid, -1)
|
||||
# if $self->{children}{$pid}{exit_callback};
|
||||
# $self->debug( "Could not get exit status of $pid")
|
||||
# if $self->{_debug};
|
||||
# }
|
||||
}
|
||||
else {
|
||||
|
||||
$self->debug("Checking if $pid is running") if $self->{_debug};
|
||||
if ($child->process and $child->process->Wait(0)) {
|
||||
$self->{goners}{$pid} = '';
|
||||
my $exit_code;
|
||||
$child->process->GetExitCode($exit_code);
|
||||
$self->{goners}{$pid} = $exit_code << 8;
|
||||
$child->exit_callback->($pid, ($exit_code << 8))
|
||||
if $child->exit_callback;
|
||||
$self->debug("$pid exited with status: $self->{goners}{$pid}")
|
||||
if $self->{_debug};
|
||||
}
|
||||
elsif ($self->{_debug}) {
|
||||
$self->debug("$pid is still running");
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub oneway {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self) = @_;
|
||||
$self->SUPER::oneway('inet');
|
||||
}
|
||||
|
||||
sub twoway {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self) = @_;
|
||||
$self->SUPER::twoway('inet');
|
||||
}
|
||||
|
||||
sub stop_blocking {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $socket_handle) = @_;
|
||||
my $set_it = "1";
|
||||
|
||||
# 126 is FIONBIO (some docs say 0x7F << 16)
|
||||
ioctl( $socket_handle,
|
||||
0x80000000 | (4 << 16) | (ord('f') << 8) | 126,
|
||||
$set_it
|
||||
) or die "ioctl: $^E";
|
||||
}
|
||||
|
||||
sub start_blocking {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $socket_handle) = @_;
|
||||
my $unset_it = "0";
|
||||
|
||||
# 126 is FIONBIO (some docs say 0x7F << 16)
|
||||
ioctl( $socket_handle,
|
||||
0x80000000 | (4 << 16) | (ord('f') << 8) | 126,
|
||||
$unset_it
|
||||
) or die "ioctl: $^E";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
Reference in New Issue
Block a user