First pass at adding key files
This commit is contained in:
dsainty
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;
|
||||
Reference in New Issue
Block a user