506 lines
17 KiB
Perl
506 lines
17 KiB
Perl
# ==================================================================
|
|
# 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;
|
|
|