saint/discourse-legacysite-perl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

First pass at adding key files

Browse Source
This commit is contained in:
dsainty
2024-06-17 21:49:12 +10:00
commit aa25e9347f
1274 changed files with 392549 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

47
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Child.pm Normal file
View File

@ -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/GT/IPC/Run/Select.pm Normal file
View 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/GT/IPC/Run/Unix.pm Normal file
View 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/GT/IPC/Run/Win32.pm Normal file
View 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;