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

107
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter.pm Normal file
View File

@ -0,0 +1,107 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::IPC::Filter
# Author: Scott Beck
# CVS Info : 087,071,086,086,085
# $Id: Filter.pm,v 1.3 2004/01/13 01:35:17 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description: Does nothing for now, here as a referance.
#
package GT::IPC::Filter;
# ==================================================================
die "Do not use me";
1;
__END__
=head1 SYNOPSIS
use GT::IPC::Filter::Foo;
my $filter = new GT::IPC::Filter::Foo(sub { my $out = shift ... });
# -or-
my $filter = new GT::IPC::Filter::Foo(
output => sub { my $out = shift; .. },
%options
);
$filter->put(\$data);
$filter->flush;
=head1 DESCRIPTION
This documents how to create a filter. The filter system documented here is
used for GT::IPC::Run, L<GT::IPC::Run>, currently but could be useful for other
things relating to IO and IPC.
=head1 METHODS
You will need to impliment three methods to create a filter. These methods are
pretty simple and strait forward.
=head2 new
This is your constructor. You will need to return an object. You should be able
to take a sigle argument as well as a hash of options. It isn't manditory but
it will keep the filter interface consistent.
The one argument form of C<new()> is a code reference. This code reference will
be called with the data (in whatever form) after you filter it. You should
default the rest of your arguments to something reasonable. If there are no
reasonable defaults for your options you can stray from this and require the
hash form, but you should have a nice error for people that call you with the
one argument form:
$class->fatal(
BADARGS => "This class does not accept the one argument form for filters"
) if @_ == 1;
The hash form should take a key C<output> which will be the code reference
output will go to once you filter it. The rest of the keys are up to you. Try
to have reasonable defaults for the other keys, but fatal if there are any that
are required and not present.
=head2 put
This method is called with a scaler reference of the data you will be
filtering. You are expect to make changes to the data and call the C<output>
code reference with the formatted data. For example GT::IPC::Filter::Line
calles the C<output> code reference with each line of data, see
L<GT::IPC::Filter::Line>. It is ok if you change the scalar reference passed
into you.
=head2 flush
C<flush()> if called when the stream of data is at an end. Not arguments are
passed to it. You are expected send any data you are buffering to the C<output>
code reference at this point, after filtering it if nessisary.
=head1 SEE ALSO
See L<GT::IPC::Run>, L<GT::IPC::Filter::Line>, L<GT::IPC::Filter::Stream>,
and L<GT::IPC::Filter::Block>.
=head1 MAINTAINER
Scott Beck
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Filter.pm,v 1.3 2004/01/13 01:35:17 jagerman Exp $
=cut

154
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Block.pm Normal file
View File

@ -0,0 +1,154 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::IPC::Filter::Block
# Author : Scott Beck
# CVS Info : 087,071,086,086,085
# $Id: Block.pm,v 1.7 2004/01/13 01:35:17 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description: Filter streams of input out in block sizes.
#
package GT::IPC::Filter::Block;
# ==================================================================
use strict;
use base 'GT::Base';
sub new {
# ----------------------------------------------------------------------------
my $class = shift;
if (@_ == 1) {
@_ = (output => $_[0]);
}
$class->fatal(BADARGS => "Arguments to new() must be a hash")
if @_ & 1;
my %opts = @_;
my $output = delete $opts{output};
$class->fatal(BADARGS => "No output for new()")
unless defined $output;
$class->fatal(BADARGS => "No output passed to new() is not a code ref")
unless ref($output) eq 'CODE';
my $block_size = delete $opts{block_size};
$block_size = 512 unless defined $block_size;
return bless {
block_size => $block_size,
output => $output,
}, $class;
}
sub put {
# ----------------------------------------------------------------------------
my ($self, $in) = @_;
if (defined $self->{buffer}) {
$$in = $self->{buffer} . $$in;
undef $self->{buffer};
}
if (length($$in) >= $self->{block_size}) {
my $gets = int(length($$in) / $self->{block_size});
for (1 .. $gets) {
$self->{output}->(substr($$in, 0, $self->{block_size}));
substr($$in, 0, $self->{block_size}) = '';
}
}
$self->{buffer} = $$in;
}
sub flush {
# ----------------------------------------------------------------------------
my ($self) = @_;
$self->{output}->($self->{buffer}) if defined $self->{buffer};
undef $self->{buffer};
}
1;
__END__
=head1 NAME
GT::IPC::Filter::Block - Implements block based filtering for output streams.
=head1 SYNOPSIS
use GT::IPC::Filter::Block;
my $filter = new GT::IPC::Filter::Block(
sub { my $block = shift ... }
);
# -or-
my $filter = new GT::IPC::Filter::Block(
output => sub { my $out = shift; .. },
block_size => 512 # Default
);
$filter->put(\$data);
$filter->flush;
=head1 DESCRIPTION
Implements block based filtering to an output code reference. Used mainly in
GT::IPC::Run, L<GT::IPC::Run> for details.
=head1 METHODS
There are three methods (as with all filters in this class).
=head2 new
Takes either a single argument, which is a code reference to call output with,
or a hash of options.
=over 4
=item output
This is the code reference you would like called with each block of output.
The blocks are stripped of there ending before this is called.
=item block_size
This is the size of chunks of data you want your code reference called with. It
defaults to 512.
=back
=head2 put
This method takes a stream of data, it converted it into block based data using
the C<block_size> you specified and passes each block to the code reference
specified by C<new()>, see L<"new">. There is buffering that happens here.
=head2 flush
This method should be called last, when the data stream is over. It flushes the
remaining buffer out to the code reference.
=head1 SEE ALSO
See L<GT::IPC::Run>.
=head1 MAINTAINER
Scott Beck
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Block.pm,v 1.7 2004/01/13 01:35:17 jagerman Exp $
=cut

176
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Line.pm Normal file
View File

@ -0,0 +1,176 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::IPC::Filter::Line
# Author : Scott Beck
# CVS Info : 087,071,086,086,085
# $Id: Line.pm,v 1.7 2004/01/13 01:35:17 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description: Filter streams of input out to a line.
#
package GT::IPC::Filter::Line;
# ==================================================================
use strict;
use base 'GT::Base';
sub new {
# ----------------------------------------------------------------------------
my $class = shift;
if (@_ == 1) {
@_ = (output => $_[0]);
}
$class->fatal(BADARGS => "Arguments to new() must be a hash")
if @_ & 1;
my %opts = @_;
my $output = delete $opts{output};
$class->fatal(BADARGS => "No output for new()")
unless defined $output;
$class->fatal(BADARGS => "No output passed to new() is not a code ref")
unless ref($output) eq 'CODE';
my $regex = delete $opts{regex};
my $literal = delete $opts{literal};
$class->fatal(BADARGS => "You can only specify one of literal and regex")
if defined $regex and defined $literal;
if (defined $literal) {
$regex = quotemeta $literal;
}
if (!defined $regex) {
$regex = '\x0D\x0A?|\x0A\x0D?';
}
return bless {
regex => $regex,
output => $output,
}, $class;
}
sub put {
# ----------------------------------------------------------------------------
my ($self, $in) = @_;
if (defined $self->{buffer}) {
$$in = $self->{buffer} . $$in;
undef $self->{buffer};
}
my $regex = $self->{regex};
my @in = split /($regex)/ => $$in;
# Not a complete line
if ($in[$#in] !~ /$regex/) {
$self->{buffer} = pop @in;
}
for (my $i = 0; $i < $#in; $i += 2) {
$self->{output}->($in[$i]);
}
}
sub flush {
# ----------------------------------------------------------------------------
my ($self) = @_;
$self->{output}->($self->{buffer}) if defined $self->{buffer};
undef $self->{buffer};
}
1;
__END__
=head1 NAME
GT::IPC::Filter::Line - Implements line based filtering for output streams.
=head1 SYNOPSIS
use GT::IPC::Filter::Line;
my $filter = new GT::IPC::Filter::Line(
sub { my $line = shift ... }
);
# -or-
my $filter = new GT::IPC::Filter::Line(
output => sub { my $out = shift; .. },
regex => '\r?\n'
);
$filter->put(\$data);
$filter->flush;
=head1 DESCRIPTION
Implements line based filtering to an output code reference. Used mainly in
GT::IPC::Run, L<GT::IPC::Run> for details.
=head1 METHODS
There are three methods (as with all filters in this class).
=head2 new
Takes either a single argument, which is a code reference to call output with,
or a hash of options.
=over 4
=item output
This is the code reference you would like called with each line of output. The
lines are stripped of there ending before this is called.
=item regex
Specify the regex to use in order to determine the end of line sequence. This
regex is used in a split on the input stream. If you capture in this regex it
will break the output.
=item literal
Specifies a literal new line sequence. The only difference between this option
and the C<regex> option is it is C<quotemeta>, See L<perlfunc/quotemeta>.
=back
=head2 put
This method takes a stream of data, it converted it into line based data and
passes each line to the code reference specified by C<new()>, see L<"new">.
There is buffering that happens here because we have no way of knowing if the
output stream does not end with a new line, also streams almost always get
partial lines.
=head2 flush
This method should be called last, when the data stream is over. It flushes the
remaining buffer out to the code reference.
=head1 SEE ALSO
See L<GT::IPC::Run>.
=head1 MAINTAINER
Scott Beck
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Line.pm,v 1.7 2004/01/13 01:35:17 jagerman Exp $
=cut

127
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Stream.pm Normal file
View File

@ -0,0 +1,127 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::IPC::Filter::Stream
# Author : Scott Beck
# CVS Info : 087,071,086,086,085
# $Id: Stream.pm,v 1.5 2006/05/26 21:56:30 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description: Filter streams of input out to a streams ;).
#
package GT::IPC::Filter::Stream;
# ==================================================================
use strict;
use base 'GT::Base';
sub new {
# ----------------------------------------------------------------------------
my $class = shift;
if (@_ == 1) {
@_ = (output => $_[0]);
}
$class->fatal(BADARGS => "Arguments to new() must be a hash")
if @_ & 1;
my %opts = @_;
my $output = delete $opts{output};
$class->fatal(BADARGS => "No output for new()")
unless defined $output;
$class->fatal(BADARGS => "No output passed to new() is not a code ref")
unless ref($output) eq 'CODE';
return bless { output => $output }, $class;
}
sub put {
# ----------------------------------------------------------------------------
my ($self, $in) = @_;
$self->{output}->($$in);
}
sub flush {
# ----------------------------------------------------------------------------
# Does nothing
}
1;
__END__
=head1 NAME
GT::IPC::Filter::Block - Implements stream based filtering for output streams.
=head1 SYNOPSIS
use GT::IPC::Filter::Stream;
my $filter = new GT::IPC::Filter::Block(
sub { my $chunk = shift ... }
);
# -or-
my $filter = new GT::IPC::Filter::Block(
output => sub { my $chunk = shift; .. },
);
$filter->put(\$data);
$filter->flush;
=head1 DESCRIPTION
Implements stream based filtering to an output code reference. Used mainly in
GT::IPC::Run, L<GT::IPC::Run> for details. Basically just a pass through to
your code reference.
=head1 METHODS
There are three methods (as with all filters in this class).
=head2 new
Takes either a single argument, which is a code reference to call output with,
or a hash of options.
=over 4
=item output
This is the code reference you would like called with each output.
=back
=head2 put
This method takes a stream of data and passed it strait to your code reference.
There is no buffering that happens here.
=head2 flush
This method does nothing.
=head1 SEE ALSO
See L<GT::IPC::Run>.
=head1 MAINTAINER
Scott Beck
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Stream.pm,v 1.5 2006/05/26 21:56:30 brewt Exp $
=cut

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

@ -0,0 +1,873 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::IPC::Run
# Author : Scott Beck
# CVS Info : 087,071,086,086,085
# $Id: Run.pm,v 1.22 2006/05/26 21:56:30 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description:
# Runs programs or code references in parallel
#
package GT::IPC::Run;
use strict;
use base 'GT::Base';
use vars qw/@EXPORT_OK $SYSTEM $DEBUG $ERRORS/;
use Exporter();
use Socket;
use Symbol qw/gensym/;
use POSIX qw(fcntl_h errno_h :sys_wait_h);
use GT::IPC::Filter::Line;
use GT::IPC::Run::Select;
use GT::IPC::Run::Child;
my $can_run_socket = undef;
*import = \&Exporter::import;
@EXPORT_OK = qw/run/;
$DEBUG = 0;
sub READ_BLOCK () { 512 }
sub IS_WIN32 () { $^O eq 'MSWin32' }
$ERRORS = {
SEMAPHORE => "Could not create semephore socket; Reason: %s",
FORK => "Could not fork; Reason: %s"
};
BEGIN {
# http://support.microsoft.com/support/kb/articles/Q150/5/37.asp
# defines EINPROGRESS as 10035. We provide it here because some
# Win32 users report POSIX::EINPROGRESS is not vendor-supported.
if (IS_WIN32) {
eval '*EINPROGRESS = sub { 10036 };';
eval '*EWOULDBLOCK = sub { 10035 };';
eval '*F_GETFL = sub { 0 };';
eval '*F_SETFL = sub { 0 };';
require GT::IPC::Run::Win32;
import GT::IPC::Run::Win32;
$SYSTEM = 'GT::IPC::Run::Win32';
}
else {
require GT::IPC::Run::Unix;
import GT::IPC::Run::Unix;
$SYSTEM = 'GT::IPC::Run::Unix';
}
}
sub new {
# ------------------------------------------------------------------------
my $self = bless {}, $SYSTEM;
$self->{select} = new GT::IPC::Run::Select;
return $self;
}
sub run {
# ------------------------------------------------------------------------
my ($program, $out, $err, $in) = @_;
my $self = new GT::IPC::Run;
my $ref;
$self->fatal("No program specified to start")
unless defined $program;
$ref = ref $program;
$self->fatal("Invalid program passed to start $program")
if
$ref ne 'CODE' and
$ref ne 'ARRAY' and
$ref;
$ref = defined($out) ? ref($out) : undef;
my $out_is_handle = _is_handle($out);
$self->fatal(
BADARGS => "stdout handler is not a code ref or scalar ref"
) if
defined $ref and
$ref ne 'CODE' and
$ref ne 'SCALAR' and
!$out_is_handle and
$ref !~ /\AGT::IPC::Filter::/;
$ref = defined($err) ? ref($err) : undef;
my $err_is_handle = _is_handle($err);
$self->fatal(
BADARGS => "stderr handler is not a code ref or scalar ref"
) if
defined $ref and
$ref ne 'CODE' and
$ref ne 'SCALAR' and
!$err_is_handle and
$ref !~ /\AGT::IPC::Filter::/;
$ref = ref $in;
my $in_is_handle = _is_handle($in);
$self->fatal(
BADARGS => "stdin handler is not a scalar ref or filehandle"
) if
$ref ne 'SCALAR' and
!$in_is_handle and
$ref !~ /\AGT::IPC::Filter::/ and
defined $in;
my $pid = $self->start(
program => $program,
stdout => $out,
stderr => $err,
stdin => $in,
debug => $DEBUG
);
1 while $self->do_one_loop;
my $exit_code = $self->exit_code($pid);
return $exit_code;
}
sub start {
# ------------------------------------------------------------------------
my $self = shift;
$self->fatal(BADARGS => "Arguments to start() must be a hash")
if @_ & 1;
my %opts = @_;
my $ref;
$self->{_debug} = delete $opts{debug};
$self->{_debug} = $DEBUG unless defined $self->{_debug};
my $program = delete $opts{program};
$self->fatal("No program specified to start")
unless defined $program;
$ref = ref $program;
$self->fatal("Invalid program passed to start $program")
if
$ref ne 'CODE' and
$ref ne 'ARRAY' and
$ref;
my $out = delete $opts{stdout};
my $actual_out;
$ref = defined($out) ? ref($out) : undef;
my $out_is_handle = _is_handle($out);
# Default to line filter for stderr
if ($ref and $ref eq 'CODE') {
$actual_out = new GT::IPC::Filter::Line($out);
}
elsif ($ref and $ref eq 'SCALAR') {
$actual_out = new GT::IPC::Filter::Line(sub { $$out .= "$_[0]\n" });
}
elsif ($ref and $ref =~ /\AGT::IPC::Filter::/) {
$actual_out = $out;
}
elsif (defined($out) and !$out_is_handle) {
$self->fatal(
BADARGS => "stdout handler is not a code ref or scalar ref"
);
}
my $err = delete $opts{stderr};
my $actual_err;
my $err_is_handle = _is_handle($err);
$ref = defined($err) ? ref($err) : undef;
# Default to line filter for stderr
if ($ref and $ref eq 'CODE') {
$actual_err = new GT::IPC::Filter::Line($err);
}
elsif ($ref and $ref eq 'SCALAR') {
$actual_err = new GT::IPC::Filter::Line(sub { $$err .= "$_[0]\n" });
}
elsif ($ref and $ref =~ /\AGT::IPC::Filter::/) {
$actual_err = $err;
}
elsif (defined($err) and !$err_is_handle) {
$self->fatal(
BADARGS => "stderr handler is not a code ref or scalar ref"
);
}
my $in = delete $opts{stdin};
my $in_is_handle = _is_handle($in);
$ref = ref $in;
$self->fatal(
BADARGS => "stdin handler is not a scalar ref or filehandle"
) if
$ref ne 'SCALAR' and
!$in_is_handle and
defined $in;
my $exit_callback = delete $opts{reaper};
$self->fatal(
BADARGS => "The exit callback specified is not a code reference"
) if
defined $exit_callback and
ref($exit_callback) ne 'CODE';
my $done_callback = delete $opts{done_callback};
$self->fatal(
BADARGS => "The done callback specified is not a code reference"
) if
defined $done_callback and
ref($done_callback) ne 'CODE';
$self->fatal(
BADARGS => "Unknown arguments ", join(", ", keys %opts)
) if keys %opts;
# get the sockets we need for stdin/stdout/stderr communication
my ($stderr_read, $stderr_write) = $self->oneway;
$self->fatal("could not make stderr pipe: $!")
unless defined $stderr_read and defined $stderr_write;
my ($stdout_read, $stdout_write) = $self->twoway;
$self->fatal("could not make stdout pipe: $!")
unless defined $stdout_read and defined $stdout_write;
my ($stdin_read, $stdin_write) = $self->oneway;
$self->fatal("could not make stdin pipes: $!")
unless defined $stdin_read and defined $stdin_write;
# Defaults to blocking
$self->stop_blocking($stdout_read);
$self->stop_blocking($stdout_write);
$self->stop_blocking($stderr_read);
$self->stop_blocking($stderr_write);
# Change the ones they have overridden
if ($in_is_handle) {
$stdin_read = $in;
undef $stdin_write;
undef $in;
}
elsif (!$in) {
undef $stdin_write;
undef $stdin_read;
}
if ($out_is_handle) {
$stdout_write = $out;
undef $stdout_read;
undef $out;
}
elsif (!$out) {
undef $stdout_write;
undef $stdout_read;
}
if ($err_is_handle) {
$stderr_write = $err;
undef $stderr_read;
}
elsif (!$err) {
undef $stderr_write;
undef $stderr_read;
}
# Temporary location for these
$self->{current_child} = new GT::IPC::Run::Child(
program => $program,
stderr_read => $stderr_read,
stderr_write => $stderr_write,
stdout_read => $stdout_read,
stdout_write => $stdout_write,
stdin_write => $stdin_write,
stdin_read => $stdin_read,
stdin => $in,
handler_stdout => $actual_out,
handler_stderr => $actual_err,
exit_callback => $exit_callback,
done_callback => $done_callback,
exit_status => 0,
pid => 0
);
# Run the program/code ref
my $pid = $self->execute;
return $pid;
}
sub do_loop {
# ----------------------------------------------------------------------------
my ($self, $wait) = @_;
1 while $self->do_one_loop($wait);
}
sub exit_code {
# ----------------------------------------------------------------------------
my ($self, $pid) = @_;
$self->fatal( BADARGS => "No pid passed to exit_code" )
unless defined $pid;
return $self->{goners}{$pid};
}
sub twoway {
# ------------------------------------------------------------------------
my ( $self, $conduit_type ) = @_;
# Try UNIX-domain socketpair if no preferred conduit type is
# specified, or if the specified conduit type is 'socketpair'.
if (
(
not defined $conduit_type or
$conduit_type eq 'socketpair'
) and
not defined $can_run_socket
)
{
my ($rw1, $rw2) = (gensym, gensym);
eval {
socketpair( $rw1, $rw2, AF_UNIX, SOCK_STREAM, PF_UNSPEC )
or die "socketpair 1 failed: $!";
};
# Socketpair succeeded.
if ( !length $@ ) {
$self->debug("Using socketpair for twoway") if $self->{_debug};
# It's two-way, so each reader is also a writer.
select( ( select($rw1), $| = 1 )[0] );
select( ( select($rw2), $| = 1 )[0] );
return ( $rw1, $rw2, $rw1, $rw2 );
}
elsif ($DEBUG) {
$self->debug("Error with socketpair: $@\n");
}
}
# Try the pipe if no preferred conduit type is specified, or if the
# specified conduit type is 'pipe'.
if (
(
not defined $conduit_type or
$conduit_type eq 'pipe'
) and
not defined $can_run_socket
)
{
my ($read1, $write1, $read2, $write2) =
(gensym, gensym, gensym, gensym);
eval {
pipe($read1, $write1) or die "pipe 1 failed: $!";
pipe($read2, $write2) or die "pipe 2 failed: $!";
};
# Pipe succeeded.
if (!length $@) {
$self->debug("Using pipe for twoway") if $self->{_debug};
# Turn off buffering. POE::Kernel does this for us, but someone
# might want to use the pipe class elsewhere.
select((select($write1), $| = 1)[0]);
select((select($write2), $| = 1)[0]);
return($read1, $write1, $read2, $write2);
}
elsif ($self->{_debug}) {
$self->debug("Error with pipe(): $@");
}
}
# Try a pair of plain INET sockets if no preffered conduit type is
# specified, or if the specified conduit type is 'inet'.
if (
(
not defined $conduit_type or
$conduit_type eq 'inet'
) and (
$can_run_socket or
not defined $can_run_socket
)
)
{
my ($rw1, $rw2) = (gensym, gensym);
# Try using a pair of plain INET domain sockets.
eval { ($rw1, $rw2) = $self->make_socket }; # make_socket
# returns em
# non-blocking
# Sockets worked.
if (!length $@) {
$self->debug("Using inet socket for twoway") if $self->{_debug};
# Try sockets more often.
$can_run_socket = 1;
# Turn off buffering. POE::Kernel does this for us, but someone
# might want to use the pipe class elsewhere.
select((select($rw1), $| = 1)[0]);
select((select($rw2), $| = 1)[0]);
return($rw1, $rw2, $rw1, $rw2);
}
elsif ($self->{_debug}) {
$self->debug("Error with socket: $@");
}
# Sockets failed. Don't dry them again.
}
$self->debug("Nothing worked") if $self->{_debug};
# There's nothing left to try.
return(undef, undef, undef, undef);
}
sub oneway {
# ------------------------------------------------------------------------
my ( $self, $conduit_type ) = @_;
# Generate symbols to be used as filehandles for the pipe's ends.
my $read = gensym;
my $write = gensym;
# Try UNIX-domain socketpair if no preferred conduit type is
# specified, or if the specified conduit type is 'socketpair'.
if (
(
not defined $conduit_type or
$conduit_type eq 'socketpair'
) and
not defined $can_run_socket
)
{
eval {
socketpair($read, $write, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
or die "socketpair failed: $!";
};
# Socketpair succeeded.
if (!length $@) {
$self->debug("Using socketpair for oneway") if $self->{_debug};
# It's one-way, so shut down the unused directions.
shutdown($read, 1);
shutdown($write, 0);
# Turn off buffering. POE::Kernel does this for us, but someone
# might want to use the pipe class elsewhere.
select((select($write), $| = 1)[0]);
return($read, $write);
}
elsif ($self->{_debug}) {
$self->debug("Could not make socketpair: $@");
}
}
# Try the pipe if no preferred conduit type is specified, or if the
# specified conduit type is 'pipe'.
if (
(
not defined $conduit_type or
$conduit_type eq 'pipe'
) and
not defined $can_run_socket
)
{
eval { pipe($read, $write) or die "pipe failed: $!" };
# Pipe succeeded.
if (!length $@) {
$self->debug("Using pipe for oneway") if $self->{_debug};
# Turn off buffering. POE::Kernel does this for us, but
# someone might want to use the pipe class elsewhere.
select((select($write),$| = 1 )[0]);
return($read, $write);
}
elsif ($self->{_debug}) {
$self->debug("Could not make pipe: $@");
}
}
# Try a pair of plain INET sockets if no preffered conduit type is
# specified, or if the specified conduit type is 'inet'.
if (
(
not defined $conduit_type or
$conduit_type eq 'inet'
) and (
$can_run_socket or
not defined $can_run_socket
)
)
{
# Try using a pair of plain INET domain sockets.
eval { ($read, $write) = $self->make_socket };
if (!length $@) {
$self->debug("Using inet socket for oneway") if $self->{_debug};
# Try sockets more often.
$can_run_socket = 1;
# It's one-way, so shut down the unused directions.
shutdown($read, 1);
shutdown($write, 0);
# Turn off buffering. POE::Kernel does this for us, but someone
# might want to use the pipe class elsewhere.
select((select($write), $| = 1)[0]);
return($read, $write);
}
else {
$self->debug("Could not make socket: $@") if $self->{_debug};
$can_run_socket = 0;
}
}
$self->debug("Nothing worked") if $self->{_debug};
return(undef, undef);
}
# Make a socket. This is a homebrew socketpair() for systems that
# don't support it. The things I must do to make Windows happy.
sub make_socket {
# ------------------------------------------------------------------------
my ($self) = @_;
### Server side.
my $acceptor = gensym();
my $accepted = gensym();
my $tcp = getprotobyname('tcp') or die "getprotobyname: $!";
socket( $acceptor, PF_INET, SOCK_STREAM, $tcp ) or die "socket: $!";
setsockopt($acceptor, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) or die "reuse: $!";
my $server_addr = inet_aton('127.0.0.1') or die "inet_aton: $!";
$server_addr = pack_sockaddr_in( 0, $server_addr ) or die "sockaddr_in: $!";
bind($acceptor, $server_addr) or die "bind: $!";
$self->stop_blocking($acceptor);
$server_addr = getsockname($acceptor);
listen($acceptor, SOMAXCONN) or die "listen: $!";
### Client side.
my $connector = gensym();
socket($connector, PF_INET, SOCK_STREAM, $tcp) or die "socket: $!";
$self->stop_blocking($connector);
unless (connect( $connector, $server_addr)) {
die "connect: $!"
if $! and ($! != EINPROGRESS) and ($! != EWOULDBLOCK);
}
my $connector_address = getsockname($connector);
my ( $connector_port, $connector_addr ) =
unpack_sockaddr_in($connector_address);
### Loop around 'til it's all done. I thought I was done writing
### select loops. Damnit.
my $in_read = '';
my $in_write = '';
vec($in_read, fileno($acceptor), 1) = 1;
vec($in_write, fileno($connector), 1) = 1;
my $done = 0;
while ( $done != 0x11 ) {
my $hits =
select( my $out_read = $in_read, my $out_write = $in_write, undef,
5 );
# For some reason this always dies when called
# successivly (quickly) on the 5th or 6th call
die "select: $^E" if $hits < 0;
#next unless $hits;
# try again?
# return $self->make_socket unless $hits;
# Accept happened.
if ( vec( $out_read, fileno($acceptor), 1 ) ) {
my $peer = accept( $accepted, $acceptor ) or die "accept: $!";
my ( $peer_port, $peer_addr ) = unpack_sockaddr_in($peer);
if ( $peer_port == $connector_port
and $peer_addr eq $connector_addr )
{
vec( $in_read, fileno($acceptor), 1 ) = 0;
$done |= 0x10;
}
}
# Connect happened.
if ( vec( $out_write, fileno($connector), 1 ) ) {
$! = unpack( 'i', getsockopt( $connector, SOL_SOCKET, SO_ERROR ) );
die "connect: $!" if $!;
vec( $in_read, fileno($acceptor), 1 ) = 0;
$done |= 0x01;
}
}
# Turn blocking back on, damnit.
$self->start_blocking($accepted);
$self->start_blocking($connector);
return ( $accepted, $connector );
}
sub _is_handle {
my $ref = ref($_[0]);
return (
($ref and $ref eq 'GLOB') or
($ref and $_[0] =~ /=GLOB\(/)
);
}
1;
__END__
=head1 NAME
GT::IPC::Run - Run programs or code in parallel
=head1 SYNOPSIS
use GT::IPC::Run;
# stderr and stdout filters default to a
# GT::IPC::Line::Filter
my $exit_code = run
'/bin/ls', # Program to run
\*stdout_handle, # stdout event
\&stderr_handler, # stderr event
\$stdin; # stdin
my $io = new GT::IPC::Run;
use GT::IPC::Filter::Line;
my $pid = $io->start(
stdout => GT::IPC::Filter::Line->new(
regex => "\r?\n",
output => sub { print "Output: $_[0]\n" }
),
program => sub { print "I got forked\n" },
);
while ($io->do_one_loop) {
if (defined(my $exit = $io->exit_code($pid))) {
print "$pid exited ", ($exit>>8), "\n";
}
}
=head1 DESCRIPTION
Module to simplify running a program or code reference in parallel. Allows
catching and filtering the output of the program and filtering it.
=head1 FUNCTIONS
GT::IPC::Run will import one function C<run()> if you request it to.
=head2 run
Run is a simple interface to running a program or a subroutine in a separate
process and catching the output, both stderr and stdout. This function takes
four arguments, only the first argument is required.
=over 4
=item First Argument
The first argument to C<run()> is the program to run or the code reference to
run. This argument can be one of three things.
If a code reference if passed as the first argument to C<run()>, GT::IPC::Run
will fork off and run the code reference. You SHOULD NOT exit in the code
reference if you want your code to work on Windows. Calling C<die()> is ok,
as your code is evaled. There are some things you CAN NOT do if you want your
code to work on Windows.
You SHOULD NOT make any calles to C<system()> or C<exec()>. For some reason, on
Windows, this breaks filehandle inheritance so all your output from that moment
on (including the C<system()> or C<exec()>) call will go to the real output
channel, STDERR or STDOUT.
You SHOULD NOT change STDERR or STDOUT. The child process on Windows can
affect the filehandles in the parent. This is probably because of the way
C<fork()> on Windows is emulated as threads.
You probably should not C<fork()> either, though this is not confirmed I
really doubt it will work the way you plan.
If an array reference is passed in it will be dereferenced and passed to
C<exec()>. If a scalar is passed in it will be passed to C<exec()>.
On Windows the arguments are passed to Win32::Process::Create as the program
you wish to run. See L<Win32::Process::Create>.
=item Second Argument
The second argument to C<run()> is what you want to happen to STDOUT as it
comes in. This argument can be one of three things.
If it is a reference to a GT::IPC::Filter:: class, that will be used to call
your code. See L<GT::IPC::Filter> for details.
If it is a code reference, a new GT::IPC::Filter::Line object will be created
and your code reference will be passed in. Exactly:
$out = GT::IPC::Filter::Line->new($out);
GT::IPC::Filter::Line will call your code reference for each line of output
from the program, the end of the line will be stripped. See
L<GT::IPC::Filter::Line> for details.
If the argument is a scalar reference, again, a new GT::IPC::Filter::Line
object will be created. Exactly:
$out = GT::IPC::Filter::Line->new(sub { $$out .= $_[0] });
=item Third Argument
The third argument to L<run()> is used to handle STDERR if and when what you
are running produces it.
This can be the exact same thing as the second argument, but will work on
STDERR.
=item Forth Argument
This argument is how to handle STDIN. It may be one of two things.
If it is a SCALAR, it will be printed to the input of what you are running.
=back
=head1 METHODS
=head2 new
The is a simple method that takes no arguments and returns a GT::IPC::Run
object. It may take options in the future.
=head2 start
This is the more complex method to start a program running. When you call this
method, the program you specify is started right away and it's PID (process ID)
is returned to you. After you call this you will either need to call
C<do_loop()> or C<do_one_loop()> to start getting the programs or code
references output. See L<"do_loop"> and L<"do_one_loop"> else where in this
document.
This method takes a hash of arguments. The arguments are:
=over 4
=item program
The name of the program, or code reference you wish to run. This is treated
the same way as the first argument to L<run()>. See L<"run"> else where in
this document for a description of how this argument is treated.
=item stdout
This is how you want STDOUT treated. It can be the same things as the second
argument to L<run()>. See L<"run"> else where in this document for a
description of how this argument is treated.
=item stderr
This is how you want STDERR treated. It can be the same things as the third
argument to L<run()>. See L<"run"> else where in this document for a
description of how this argument is treated.
=item stdin
This argument is how to handle STDIN. It may be one of two things. It is
treated like the forth argument to L<run()>. See L<"run"> else where in this
document for a description of how this argument is treated.
=item reaper
This is a code reference that will be ran once a process has exited. Note: the
process may not be done sending us STDOUT or STDERR when it exits.
The code reference is called with the pid as it's first argument and the exit
status of the program for its second argument. The exit status is the same as
it is returned by waitpid(). The exit status is somewhat fiddled on Windows to
act the way you want it to, e.g. C<$exit_status E<gt>E<gt> 8> will be the
number the program exited with.
=item done_callback
This is a code reference that works similarly to reaper except that it is only
called after the child has died AND all STDOUT/STDERR output has been sent,
unlike reaper which is called on exit, regardless of any output that may still
be pending.
The code reference is called wih the pid and exit status of the program as its
two arguments.
=back
=head2 do_one_loop
This method takes one argument, the time to wait for C<select()> to return
something in milliseconds. This does one select loop on all the processes. You
will need to called this after you call C<start()>. Typically:
my $ipc = new GT::IPC::Run;
my $pid = $ipc->start(program => 'ls');
1 while $ipc->do_one_loop;
my $exit_status = $ipc->exit_code($pid);
=head2 do_loop
This is similar to C<do_one_loop>, except it does not return unless all
processes are finished. Almost the same as:
1 while $ipc->do_one_loop;
You can pass the wait time to C<do_loop()> and it will be passed on to
C<do_one_loop>. The wait time is in milliseconds.
=head2 exit_code
This method takes a pid as an argument and returns the exit status of that
processes pid. If the process has not exited yet or GT::IPC::Run did not launch
the process, returns undefined. The exit code returned by this is the same as
returned by waitpid. See L<perlfunc/waitpid> and L<perlfunc/system>.
=head1 SEE ALSO
See L<perlipc>, L<perlfunc/system>, L<perlfunc/exec>, L<perlfork>, and
L<Win32::Process>.
=head1 MAINTAINER
Scott Beck
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Run.pm,v 1.22 2006/05/26 21:56:30 brewt Exp $
=cut

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;