Acme-Sort-Sleep

 view release on metacpan or  search on metacpan

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

{
   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;

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

=item nice => INT

Change the child process's scheduling priority using C<POSIX::nice>.

=item chdir => STRING

Change the child process's working directory using C<chdir>.

=item setuid => INT

=item setgid => INT

Change the child process's effective UID or GID.

=item setgroups => ARRAY

Change the child process's groups list, to those groups whose numbers are
given in the ARRAY reference.

On most systems, only the privileged superuser change user or group IDs.
L<IO::Async> will B<NOT> check before detaching the child process whether

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

suggested to set the primary GID first. Moreover, some operating systems may
require that the supplementary groups list contains the primary GID.

=back

If no directions for what to do with C<stdin>, C<stdout> and C<stderr> are
given, a default of C<keep> is implied. All other file descriptors will be
closed, unless a C<keep> operation is given for them.

If C<setuid> is used, be sure to place it after any other operations that
might require superuser privileges, such as C<setgid> or opening special
files.

=cut

sub _check_setup_and_canonicise
{
   my $self = shift;
   my ( $setup ) = @_;

   ref $setup eq "ARRAY" or croak "'setup' must be an ARRAY reference";

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

      }
      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'";
      }

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

            }
            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->();
   };

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

use warnings;

our $VERSION = '0.70';

use base qw( IO::Async::Timer::Periodic );

use Carp;
use File::stat;

# No point watching blksize or blocks
my @STATS = qw( dev ino mode nlink uid gid rdev size atime mtime ctime );

=head1 NAME

C<IO::Async::File> - watch a file for changes

=head1 SYNOPSIS

 use IO::Async::File;

 use IO::Async::Loop;

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

sub watch_child
{
   my $self = shift;
   my ( $pid, $code ) = @_;

   my $childwatches = $self->{childwatches};

   croak "Already have a handler for $pid" if exists $childwatches->{$pid};

   if( HAVE_SIGNALS and !$self->{childwatch_sigid} ) {
      $self->{childwatch_sigid} = $self->attach_signal(
         CHLD => sub { _reap_children( $childwatches ) }
      );

      # There's a chance the child has already exited
      my $zid = waitpid( $pid, WNOHANG );
      if( defined $zid and $zid > 0 ) {
         my $exitstatus = $?;
         $self->later( sub { $code->( $pid, $exitstatus ) } );
         return;
      }

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

sub unwatch_child
{
   my $self = shift;
   my ( $pid ) = @_;

   my $childwatches = $self->{childwatches};

   delete $childwatches->{$pid};

   if( HAVE_SIGNALS and !keys %$childwatches ) {
      $self->detach_signal( CHLD => delete $self->{childwatch_sigid} );
   }
}

=head1 METHODS FOR SUBCLASSES

The following methods are provided to access internal features which are
required by specific subclasses to implement the loop functionality. The use
cases of each will be documented in the above section.

=cut

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

   croak "Already have a resolver method called '$name'" if exists $METHODS{$name};
   $METHODS{$name} = $code;
}

=head1 BUILT-IN RESOLVERS

The following resolver names are implemented by the same-named perl function,
taking and returning a list of values exactly as the perl function does:

 getpwnam getpwuid
 getgrnam getgrgid
 getservbyname getservbyport
 gethostbyname gethostbyaddr
 getnetbyname getnetbyaddr
 getprotobyname getprotobynumber

=cut

# Now register the inbuilt methods

register_resolver getpwnam => sub { my @r = getpwnam( $_[0] ) or die "$!\n"; @r };
register_resolver getpwuid => sub { my @r = getpwuid( $_[0] ) or die "$!\n"; @r };

register_resolver getgrnam => sub { my @r = getgrnam( $_[0] ) or die "$!\n"; @r };
register_resolver getgrgid => sub { my @r = getgrgid( $_[0] ) or die "$!\n"; @r };

register_resolver getservbyname => sub { my @r = getservbyname( $_[0], $_[1] ) or die "$!\n"; @r };
register_resolver getservbyport => sub { my @r = getservbyport( $_[0], $_[1] ) or die "$!\n"; @r };

register_resolver gethostbyname => sub { my @r = gethostbyname( $_[0] ) or die "$!\n"; @r };
register_resolver gethostbyaddr => sub { my @r = gethostbyaddr( $_[0], $_[1] ) or die "$!\n"; @r };

register_resolver getnetbyname => sub { my @r = getnetbyname( $_[0] ) or die "$!\n"; @r };
register_resolver getnetbyaddr => sub { my @r = getnetbyaddr( $_[0], $_[1] ) or die "$!\n"; @r };