File Coverage

blib/lib/Proc/Hevy.pm

Criterion	Covered	Total	%
statement	70	72	97.2
branch	34	38	89.4
condition	14	21	66.6
subroutine	9	9	100.0
pod	1	1	100.0
total	128	141	90.7

package Proc::Hevy;

use strict;
use warnings;

use Carp;
use Errno qw( EWOULDBLOCK );
use IO::Pipe;
use IO::Select;
use Proc::Hevy::Reader;
use Proc::Hevy::Writer;


sub exec {
  my ( $class, @args ) = @_;

  confess 'Odd number of parameters'
    unless @args % 2 == 0;
  my %args = @args;

  confess 'command: Required parameter not defined'
    unless defined $args{command};

  if( ref( $args{command} ) =~ /^(?:CODE)?\z/ ) {
    $args{command} = [ $args{command} ];
  }
  elsif( ref( $args{command} ) ne 'ARRAY' ) {
    confess 'command: Must be an ARRAY reference';
  }

  ref( $args{stdin} ) =~ /^(?:ARRAY|CODE|GLOB)\z/
    or confess 'stdin: Must be one of ARRAY, CODE or GLOB reference'
      if exists $args{stdin} and ref $args{stdin};

  ref( $args{stdout} ) =~ /^(?:ARRAY|CODE|GLOB|SCALAR)\z/
    or confess 'stdout: Must be one of ARRAY, CODE, GLOB or SCALAR reference'
      if exists $args{stdout};

  ref( $args{stderr} ) =~ /^(?:ARRAY|CODE|GLOB|SCALAR)\z/
    or confess 'stderr: Must be one of ARRAY, CODE, GLOB or SCALAR reference'
      if exists $args{stderr};

  ref( $args{parent} ) eq 'CODE'
    or confess 'parent: Must be a CODE reference'
      if defined $args{parent};

  ref( $args{child} ) eq 'CODE'
    or confess 'child: Must be a CODE reference'
      if defined $args{child};

  $args{priority} = 0
    unless defined $args{priority};

  my $std_i = Proc::Hevy::Writer->new( stdin  => $args{stdin}  );
  my $std_o = Proc::Hevy::Reader->new( stdout => $args{stdout} );
  my $std_e = Proc::Hevy::Reader->new( stderr => $args{stderr} );

  # fork
  my $pid = fork;
  confess "fork: $!\n"
    unless defined $pid;

  if( $pid == 0 ) {
    # child

    # run callback, if needed
    $args{child}->( getppid )
      if defined $args{child};

    # set filehandles
    $std_i->child( \*STDIN,  0 );
    $std_o->child( \*STDOUT, 1 );
    $std_e->child( \*STDERR, 2 );

    # set process priority, if needed
    if( $args{priority} ) {
      my $priority = getpriority( 0, $$ );
      defined $priority
        or die "getpriority(): $$: $!\n";

      $priority += $args{priority};

      setpriority( 0, $$, $priority )
        or die "setpriority(): $$: $!\n";
    }

    # exec
    if( ref( $args{command}->[0] ) eq 'CODE' ) {
      my $sub = shift @{ $args{command} };
      $sub->( @{ $args{command} } );
      exit 0;
    }

    exec @{ $args{command} };
    warn "exec: $args{command}->[0]: $!\n";
    exit 1;
  }

  # parent

  # run callback, if needed
  $args{parent}->( $pid )
    if defined $args{parent};

  # set filehandles
  my ( $select_w, $select_r ) = ( IO::Select->new, IO::Select->new );

  my %handles = (
    $std_i->parent( $select_w ),
    $std_o->parent( $select_r ),
    $std_e->parent( $select_r ),
  );

  # loop
  while( $select_r->count or $select_w->count ) {
    my ( $readers, $writers ) = IO::Select->select( $select_r, $select_w );

    $handles{$_}->read
      for @$readers;

    $handles{$_}->write
      for @$writers;
  }

  # use waitpid() to avoid signal handlers
  my $rc = waitpid $pid, 0;
  confess "waitpid: $!"
    if $rc == -1;

  return $?;
}


1
__END__