First pass at adding key files
This commit is contained in:
dsainty
505
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Win32.pm
Normal file
505
site/slowtwitch.com/cgi-bin/articles/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