Acme-Sort-Sleep
view release on metacpan or search on metacpan
local/lib/perl5/IO/Async/ChildManager.pm view on Meta::CPAN
# You may distribute under the terms of either the GNU General Public License
# or the Artistic License (the same terms as Perl itself)
#
# (C) Paul Evans, 2007-2014 -- leonerd@leonerd.org.uk
package IO::Async::ChildManager;
use strict;
use warnings;
our $VERSION = '0.70';
# Not a notifier
use IO::Async::Stream;
use IO::Async::OS;
use Carp;
use Scalar::Util qw( weaken );
use POSIX qw( _exit dup dup2 nice );
use constant LENGTH_OF_I => length( pack( "I", 0 ) );
=head1 NAME
C<IO::Async::ChildManager> - facilitates the execution of child processes
=head1 SYNOPSIS
This object is used indirectly via an L<IO::Async::Loop>:
use IO::Async::Loop;
my $loop = IO::Async::Loop->new;
...
$loop->run_child(
command => "/bin/ps",
on_finish => sub {
my ( $pid, $exitcode, $stdout, $stderr ) = @_;
my $status = ( $exitcode >> 8 );
print "ps [PID $pid] exited with status $status\n";
},
);
$loop->open_child(
command => [ "/bin/ping", "-c4", "some.host" ],
stdout => {
on_read => sub {
my ( $stream, $buffref, $eof ) = @_;
while( $$buffref =~ s/^(.*)\n// ) {
print "PING wrote: $1\n";
}
return 0;
},
},
on_finish => sub {
my ( $pid, $exitcode ) = @_;
my $status = ( $exitcode >> 8 );
...
},
);
my ( $pipeRd, $pipeWr ) = IO::Async::OS->pipepair;
$loop->spawn_child(
command => "/usr/bin/my-command",
setup => [
stdin => [ "open", "<", "/dev/null" ],
stdout => $pipeWr,
stderr => [ "open", ">>", "/var/log/mycmd.log" ],
chdir => "/",
]
on_exit => sub {
my ( $pid, $exitcode ) = @_;
my $status = ( $exitcode >> 8 );
print "Command exited with status $status\n";
local/lib/perl5/IO/Async/ChildManager.pm view on Meta::CPAN
elsif( $ref eq "ARRAY" ) {
# Already OK
}
elsif( $ref eq "GLOB" or eval { $value->isa( "IO::Handle" ) } ) {
$value = [ 'dup', $value ];
}
else {
croak "Unrecognised reference type '$ref' for file descriptor $fd";
}
my $operation = $value->[0];
grep { $_ eq $operation } qw( open close dup keep ) or
croak "Unrecognised operation '$operation' for file descriptor $fd";
}
elsif( $key eq "env" ) {
ref $value eq "HASH" or croak "Expected HASH reference for 'env' setup key";
}
elsif( $key eq "nice" ) {
$value =~ m/^\d+$/ or croak "Expected integer for 'nice' setup key";
}
elsif( $key eq "chdir" ) {
# This isn't a purely watertight test, but it does guard against
# silly things like passing a reference - directories such as
# ARRAY(0x12345) are unlikely to exist
-d $value or croak "Working directory '$value' does not exist";
}
elsif( $key eq "setuid" ) {
$value =~ m/^\d+$/ or croak "Expected integer for 'setuid' setup key";
}
elsif( $key eq "setgid" ) {
$value =~ m/^\d+$/ or croak "Expected integer for 'setgid' setup key";
$has_setgroups and carp "It is suggested to 'setgid' before 'setgroups'";
}
elsif( $key eq "setgroups" ) {
ref $value eq "ARRAY" or croak "Expected ARRAY reference for 'setgroups' setup key";
m/^\d+$/ or croak "Expected integer in 'setgroups' array" for @$value;
$has_setgroups = 1;
}
else {
croak "Unrecognised setup operation '$key'";
}
push @setup, $key => $value;
}
return @setup;
}
sub _spawn_in_parent
{
my $self = shift;
my ( $readpipe, $kid, $on_exit ) = @_;
my $loop = $self->{loop};
# We need to wait for both the errno pipe to close, and for waitpid
# to give us an exit code. We'll form two closures over these two
# variables so we can cope with those happening in either order
my $dollarbang;
my ( $dollarat, $length_dollarat );
my $exitcode;
my $pipeclosed = 0;
$loop->add( IO::Async::Stream->new(
notifier_name => "statuspipe,kid=$kid",
read_handle => $readpipe,
on_read => sub {
my ( $self, $buffref, $eof ) = @_;
if( !defined $dollarbang ) {
if( length( $$buffref ) >= 2 * LENGTH_OF_I ) {
( $dollarbang, $length_dollarat ) = unpack( "II", $$buffref );
substr( $$buffref, 0, 2 * LENGTH_OF_I, "" );
return 1;
}
}
elsif( !defined $dollarat ) {
if( length( $$buffref ) >= $length_dollarat ) {
$dollarat = substr( $$buffref, 0, $length_dollarat, "" );
return 1;
}
}
if( $eof ) {
$dollarbang = 0 if !defined $dollarbang;
if( !defined $length_dollarat ) {
$length_dollarat = 0;
$dollarat = "";
}
$pipeclosed = 1;
if( defined $exitcode ) {
local $! = $dollarbang;
$on_exit->( $kid, $exitcode, $!, $dollarat );
}
}
return 0;
}
) );
$loop->watch_child( $kid => sub {
( my $kid, $exitcode ) = @_;
if( $pipeclosed ) {
local $! = $dollarbang;
$on_exit->( $kid, $exitcode, $!, $dollarat );
}
} );
return $kid;
}
sub _spawn_in_child
{
my $self = shift;
my ( $writepipe, $code, $setup ) = @_;
my $exitvalue = eval {
# Map of which handles will be in use by the end
my %fd_in_use = ( 0 => 1, 1 => 1, 2 => 1 ); # Keep STDIN, STDOUT, STDERR
# Count of how many times we'll need to use the current handles.
my %fds_refcount = %fd_in_use;
# To dup2() without clashes we might need to temporarily move some handles
my %dup_from;
my $max_fd = 0;
my $writepipe_clashes = 0;
if( @$setup ) {
# The writepipe might be in the way of a setup filedescriptor. If it
# is we'll have to dup2 it out of the way then close the original.
foreach my $i ( 0 .. $#$setup/2 ) {
my ( $key, $value ) = @$setup[$i*2, $i*2 + 1];
$key =~ m/^fd(\d+)$/ or next;
my $fd = $1;
$max_fd = $fd if $fd > $max_fd;
$writepipe_clashes = 1 if $fd == fileno $writepipe;
my ( $operation, @params ) = @$value;
$operation eq "close" and do {
delete $fd_in_use{$fd};
local/lib/perl5/IO/Async/ChildManager.pm view on Meta::CPAN
my $fd = $1;
my( $operation, @params ) = @$value;
$operation eq "dup" and do {
my $from = fileno $params[0];
if( $from != $fd ) {
if( exists $dup_from{$fd} ) {
defined( $dup_from{$fd} = dup( $fd ) ) or die "Cannot dup($fd) - $!";
}
my $real_from = $dup_from{$from};
POSIX::close( $fd );
dup2( $real_from, $fd ) or die "Cannot dup2($real_from to $fd) - $!\n";
}
$fds_refcount{$from}--;
if( !$fds_refcount{$from} and !$fd_in_use{$from} ) {
POSIX::close( $from );
delete $dup_from{$from};
}
};
$operation eq "open" and do {
my ( $mode, $filename ) = @params;
open( my $fh, $mode, $filename ) or die "Cannot open('$mode', '$filename') - $!\n";
my $from = fileno $fh;
dup2( $from, $fd ) or die "Cannot dup2($from to $fd) - $!\n";
close $fh;
};
}
elsif( $key eq "env" ) {
%ENV = %$value;
}
elsif( $key eq "nice" ) {
nice( $value ) or die "Cannot nice($value) - $!";
}
elsif( $key eq "chdir" ) {
chdir( $value ) or die "Cannot chdir('$value') - $!";
}
elsif( $key eq "setuid" ) {
setuid( $value ) or die "Cannot setuid('$value') - $!";
}
elsif( $key eq "setgid" ) {
setgid( $value ) or die "Cannot setgid('$value') - $!";
}
elsif( $key eq "setgroups" ) {
setgroups( @$value ) or die "Cannot setgroups() - $!";
}
}
}
$code->();
};
my $writebuffer = "";
$writebuffer .= pack( "I", $!+0 );
$writebuffer .= pack( "I", length( $@ ) ) . $@;
syswrite( $writepipe, $writebuffer );
return $exitvalue;
}
=head1 AUTHOR
Paul Evans <leonerd@leonerd.org.uk>
=cut
0x55AA;
( run in 0.728 second using v1.01-cache-2.11-cpan-39bf76dae61 )