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  => "/",
    ]

local/lib/perl5/IO/Async/ChildManager.pm  view on Meta::CPAN

# Writing to variables of $> and $) have tricky ways to obtain error results
sub setuid
{
   my ( $uid ) = @_;

   $> = $uid; my $saved_errno = $!;
   $> == $uid and return 1;

   $! = $saved_errno;
   return undef;
}

sub setgid
{
   my ( $gid ) = @_;

   $) = $gid; my $saved_errno = $!;
   $) == $gid and return 1;

   $! = $saved_errno;
   return undef;
}

sub setgroups
{
   my @groups = @_;

   my $gid = $)+0;
   # Put the primary GID as the first group in the supplementary list, because
   # some operating systems ignore this position, expecting it to indeed be
   # the primary GID.
   # See
   #   https://rt.cpan.org/Ticket/Display.html?id=65127
   @groups = grep { $_ != $gid } @groups;

   $) = "$gid $gid " . join " ", @groups; my $saved_errno = $!;

   # No easy way to detect success or failure. Just check that we have all and
   # only the right groups
   my %gotgroups = map { $_ => 1 } split ' ', "$)";

   $! = $saved_errno;
   $gotgroups{$_}-- or return undef for @groups;
   keys %gotgroups or return undef;

   return 1;
}

# Internal constructor
sub new
{
   my $class = shift;
   my ( %params ) = @_;

   my $loop = delete $params{loop} or croak "Expected a 'loop'";

   my $self = bless {
      loop => $loop,
   }, $class;

   weaken( $self->{loop} );

   return $self;
}

=head1 METHODS

When active, the following methods are available on the containing C<Loop>
object.

=cut

=head2 spawn_child

   $pid = $loop->spawn_child( %params )

This method creates a new child process to run a given code block or command.
The C<%params> hash takes the following keys:

=over 8

=item command => ARRAY or STRING

Either a reference to an array containing the command and its arguments, or a
plain string containing the command. This value is passed into perl's
C<exec> function.

=item code => CODE

A block of code to execute in the child process. It will be called in scalar
context inside an C<eval> block.

=item setup => ARRAY

A reference to an array which gives file descriptors to set up in the child
process before running the code or command. See below.

=item on_exit => CODE

A continuation to be called when the child processes exits. It will be invoked
in the following way:

 $on_exit->( $pid, $exitcode, $dollarbang, $dollarat )

The second argument is passed the plain perl C<$?> value.

=back

Exactly one of the C<command> or C<code> keys must be specified.

If the C<command> key is used, the given array or string is executed using the
C<exec> function. 

If the C<code> key is used, the return value will be used as the C<exit(2)>
code from the child if it returns (or 255 if it returned C<undef> or thows an
exception).

 Case          | ($exitcode >> 8)       | $dollarbang | $dollarat
 --------------+------------------------+-------------+----------
 exec succeeds | exit code from program |     0       |    ""
 exec fails    |         255            |     $!      |    ""