File Coverage

blib/lib/Sys/Cmd.pm

Criterion	Covered	Total	%
statement	249	298	83.5
branch	81	130	62.3
condition	7	19	36.8
subroutine	27	30	90.0
pod	6	7	85.7
total	370	484	76.4

package    # Trick xt/ tests into working
  Sys::Cmd::Mo;

BEGIN {
#<<< No perltidy
# use Mo qw/build is required default import/;
#   The following line of code was produced from the previous line by
#   Mo::Inline version 0.40
no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{my$c=shift;my$s=bless{@_},$c;my%n=%{$c.'::'.':E'};map{$s->{$_}=$n{$_}->()if!exists$s->{$_}}keys%n;$s};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for@_;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};@_=(default,@_)if!($#_%2);$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'build::e'}=sub{my($P,$e)=@_;$e->{new}=sub{$c=shift;my$s=&{$M.Object::new}($c,@_);my@B;do{@B=($c.::BUILD,@B)}while($c)=@{$c.::ISA};exists&$_&&&$_($s)for@B;$s}};*{$M.'is::e'}=sub{my($P,$e,$o)=@_;$o->{is}=sub{my($m,$n,%a)=@_;$a{is}or return$m;sub{$#_&&$a{is}eq'ro'&&caller ne'Mo::coerce'?die$n.' is ro':$m->(@_)}}};*{$M.'required::e'}=sub{my($P,$e,$o)=@_;$o->{required}=sub{my($m,$n,%a)=@_;if($a{required}){my$C=*{$P."new"}{CODE}||*{$M.Object::new}{CODE};no warnings 'redefine';*{$P."new"}=sub{my$s=$C->(@_);my%a=@_[1..$#_];die$n." required"if!exists$a{$n};$s}}$m}};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;exists$a{default}or return$m;my($d,$r)=$a{default};my$g='HASH'eq($r=ref$d)?sub{+{%$d}}:'ARRAY'eq$r?sub{[@$d]}:'CODE'eq$r?$d:sub{$d};my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=$g and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$g->(@_):$m->(@_)}}};my$i=\&import;*{$M.import}=sub{(@_==2 and not$_[1])?pop@_:@_==1?push@_,grep!/import/,@f:();goto&$i};@f=qw[build is required default import];use strict;use warnings;
$INC{'Sys/Cmd/Mo.pm'} = __FILE__;
#>>>
}
1;

package Sys::Cmd;
use strict;
use warnings;
use 5.006;
use Carp;
use Exporter::Tidy all => [qw/spawn run runx/];
use File::Spec;
use IO::Handle;
use Log::Any qw/$log/;
use Sys::Cmd::Mo;

our $VERSION = '0.99.0_2';
our $CONFESS;

sub run {
    my $proc = spawn(@_);
    my @out  = $proc->stdout->getlines;
    my @err  = $proc->stderr->getlines;

    $proc->wait_child;

    if ( $proc->exit != 0 ) {
        Carp::confess(
            join( '', @err ) . 'Command exited with value ' . $proc->exit )
          if $CONFESS;
        Carp::croak(
            join( '', @err ) . 'Command exited with value ' . $proc->exit );
    }

    warn @err if @err;

    if (wantarray) {
        return @out;
    }
    else {
        return join( '', @out );
    }
}

sub runx {
    my $proc = spawn(@_);
    my @out  = $proc->stdout->getlines;
    my @err  = $proc->stderr->getlines;

    $proc->wait_child;

    if ( $proc->exit != 0 ) {
        Carp::confess(
            join( '', @err ) . 'Command exited with value ' . $proc->exit )
          if $CONFESS;
        Carp::croak(
            join( '', @err ) . 'Command exited with value ' . $proc->exit );
    }

    if (wantarray) {
        return @out, @err;
    }
    else {
        return join( '', @out, @err );
    }
}

sub spawn {
    my ( @cmd, @opts );
    map {
        if ( ref($_) eq 'HASH' ) {
            push( @opts, $_ );
        }
        else {
            push( @cmd, $_ );
        }
    } @_;

    Carp::confess '$cmd must be defined' unless @cmd && defined $cmd[0];
    Carp::confess __PACKAGE__ . ": only a single hashref allowed" if @opts > 1;

    unless ( 'CODE' eq ref $cmd[0] ) {

        if ( File::Spec->splitdir( $cmd[0] ) == 1 ) {
            require File::Which;
            $cmd[0] = File::Which::which( $cmd[0] )
              || Carp::confess 'command not found: ' . $cmd[0];
        }

        if ( !-x $cmd[0] ) {
            Carp::confess 'command not executable: ' . $cmd[0];
        }
    }

    $opts[0]->{cmd} = \@cmd;
    Sys::Cmd->new( %{ $opts[0] } );
}

has 'cmd' => (
    is  => 'ro',
    isa => sub {
        ref $_[0] eq 'ARRAY' || Carp::confess "cmd must be ARRAYREF";
        @{ $_[0] }           || Carp::confess "Missing cmd elements";
        if ( grep { !defined $_ } @{ $_[0] } ) {
            Carp::confess 'cmd array cannot contain undef elements';
        }
    },
    required => 1,
);

has _code => (
    is      => 'ro',
    default => sub {
        my $c = $_[0]->cmd->[0];
        ref($c) eq 'CODE' ? $c : undef;
    },
);

has 'encoding' => (
    is      => 'ro',
    default => sub { ':utf8' },
);

has 'env' => (
    is  => 'ro',
    isa => sub { ref $_[0] eq 'HASH' || Carp::confess "env must be HASHREF" },
);

has 'dir' => ( is => 'ro', );

has 'input' => ( is => 'ro', );

has 'pid' => (
    is       => 'rw',
    init_arg => undef,
);

has 'stdin' => (
    is       => 'rw',
    init_arg => undef,
    default  => sub { IO::Handle->new },
);

has 'stdout' => (
    is       => 'rw',
    init_arg => undef,
    default  => sub { IO::Handle->new },
);

has 'stderr' => (
    is       => 'rw',
    init_arg => undef,
    default  => sub { IO::Handle->new },
);

has on_exit => (
    is       => 'rw',
    init_arg => 'on_exit',
);

has 'exit' => (
    is       => 'rw',
    init_arg => undef,
);

has 'signal' => (
    is       => 'rw',
    init_arg => undef,
);

has 'core' => (
    is       => 'rw',
    init_arg => undef,
);

sub BUILD {
    my $self = shift;
    my $dir  = $self->dir;

    require File::chdir            if $dir;
    local $File::chdir::CWD = $dir if $dir;

    local %ENV = %ENV;

    if ( defined( my $x = $self->env ) ) {
        while ( my ( $key, $val ) = each %$x ) {
            if ( defined $val ) {
                $ENV{$key} = $val;
            }
            else {
                delete $ENV{$key};
            }
        }
    }

    $self->_code ? $self->_fork : $self->_spawn;
    $self->stdin->autoflush(1);

    my $enc = $self->encoding;
    binmode( $self->stdin,  $enc ) or warn "binmode stdin: $!";
    binmode( $self->stdout, $enc ) or warn "binmode stdout: $!";
    binmode( $self->stderr, $enc ) or warn "binmode stderr: $!";

    $log->debugf( '[%d][%s] %s', $self->pid, $enc, scalar $self->cmdline );

    # some input was provided
    if ( defined( my $input = $self->input ) ) {
        local $SIG{PIPE} =
          sub { warn "Broken pipe when writing to:" . $self->cmdline };

        $self->stdin->print($input) if length $input;

        $self->stdin->close;
    }

    return;
}

sub _spawn {
    my $self = shift;
    require Proc::FastSpawn;

    # Get new handles to descriptors 0,1,2
    my $fd0 = IO::Handle->new_from_fd( 0, 'r' );
    my $fd1 = IO::Handle->new_from_fd( 1, 'w' );
    my $fd2 = IO::Handle->new_from_fd( 2, 'w' );

    # Backup the original 0,1,2 file descriptors
    open my $old_fd0, '<&', 0;
    open my $old_fd1, '>&', 1;
    open my $old_fd2, '>&', 2;

    # Pipe our filehandles to new child filehandles
    pipe( my $child_in,  $self->stdin )  || die "pipe: $!";
    pipe( $self->stdout, my $child_out ) || die "pipe: $!";
    pipe( $self->stderr, my $child_err ) || die "pipe: $!";

    # Make sure that 0,1,2 are inherited (probably are anyway)
    Proc::FastSpawn::fd_inherit( $_, 1 ) for 0, 1, 2;

    # But don't inherit the rest
    Proc::FastSpawn::fd_inherit( fileno($_), 0 )
      for $old_fd0, $old_fd1, $old_fd2, $child_in, $child_out, $child_err,
      $self->stdin, $self->stdout, $self->stderr;

    eval {
        # Re-open 0,1,2 by duping the child pipe ends
        open $fd0, '<&', fileno($child_in);
        open $fd1, '>&', fileno($child_out);
        open $fd2, '>&', fileno($child_err);

        # Kick off the new process
        $self->pid(
            Proc::FastSpawn::spawn(
                $self->cmd->[0],
                $self->cmd,
                [
                    map { $_ . '=' . ( defined $ENV{$_} ? $ENV{$_} : '' ) }
                      keys %ENV
                ]
            )
        );
    };
    my $err = $@;

    # Restore our local 0,1,2 to the originals
    open $fd0, '<&', fileno($old_fd0);
    open $fd1, '>&', fileno($old_fd1);
    open $fd2, '>&', fileno($old_fd2);

    # Complain if the spawn failed for some reason
    Carp::croak $err if $err;
    Carp::croak 'Unable to spawn child' unless defined $self->pid;

    # Parent doesn't need to see the child or backup descriptors anymore
    close($_)
      for $old_fd0, $old_fd1, $old_fd2, $child_in, $child_out, $child_err;

    return;
}

sub _fork {
    my $self = shift;

    pipe( my $child_in,  $self->stdin )  || die "pipe: $!";
    pipe( $self->stdout, my $child_out ) || die "pipe: $!";
    pipe( $self->stderr, my $child_err ) || die "pipe: $!";

    $self->pid( fork() );
    if ( !defined $self->pid ) {
        my $why = $!;
        die "fork: $why";
    }

    if ( $self->pid > 0 ) {    # parent
        close $child_in;
        close $child_out;
        close $child_err;
        return;
    }

    # Child
    $self->exit(0);            # stop DESTROY() from trying to reap
    $child_err->autoflush(1);

    my $enc = $self->encoding;

    foreach my $quad (
        [ \*STDIN,  '<&=' . $enc, fileno($child_in),  0 ],
        [ \*STDOUT, '>&=' . $enc, fileno($child_out), 1 ],
        [ \*STDERR, '>&=' . $enc, fileno($child_err), 1 ]
      )
    {
        my ( $fh, $mode, $fileno, $autoflush ) = @$quad;

        open( $fh, $mode, $fileno )
          or print $child_err sprintf "[%d] open %s, %s: %s\n", $self->pid,
          $fh, $mode, $!;

        $fh->autoflush(1) if $autoflush;
    }

    close $self->stdin;
    close $self->stdout;
    close $self->stderr;
    close $child_in;
    close $child_out;
    close $child_err;

    if ( my $code = $self->_code ) {
        $code->();
        _exit(0);
    }

    exec( @{ $self->cmd } );
    die "exec: $!";
}

sub cmdline {
    my $self = shift;
    if (wantarray) {
        return @{ $self->cmd };
    }
    else {
        return join( ' ', @{ $self->cmd } );
    }
}

sub wait_child {
    my $self = shift;

    return unless defined $self->pid;
    return $self->exit if defined $self->exit;

    local $?;
    local $!;

    my $pid = waitpid $self->pid, 0;
    my $ret = $?;

    if ( $pid != $self->pid ) {
        warn sprintf( 'Could not reap child process %d (waitpid returned: %d)',
            $self->pid, $pid );
        $pid = $self->pid;
        $ret = 0;
    }

    if ( $ret == -1 ) {

        # So waitpid returned a PID but then sets $? to this
        # strange value? (Strange in that tests randomly show it to
        # be invalid.) Most likely a perl bug; I think that waitpid
        # got interrupted and when it restarts/resumes the status
        # is lost.
        #
        # See http://www.perlmonks.org/?node_id=641620 for a
        # possibly related discussion.
        #
        # However, since I localised $? and $! above I haven't seen
        # this problem again, so I hope that is a good enough work
        # around. Lets warn any way so that we know when something
        # dodgy is going on.
        warn __PACKAGE__
          . ' received invalid child exit status for pid '
          . $pid
          . ' Setting to 0';
        $ret = 0;

    }

    $log->debugf(
        '(PID %d) exit: %d signal: %d core: %d',
        $pid,
        $self->exit( $ret >> 8 ),
        $self->signal( $ret & 127 ),
        $self->core( $ret & 128 )
    );

    if ( my $subref = $self->on_exit ) {
        $subref->($self);
    }

    return $self->exit;
}

sub close {
    my $self = shift;

    foreach my $h (qw/stdin stdout stderr/) {

        # may not be defined during global destruction
        my $fh = $self->$h or next;
        $fh->opened        or next;
        if ( $h eq 'stderr' ) {
            warn sprintf( '[%d] uncollected stderr: %s', $self->pid, $_ )
              for $self->stderr->getlines;
        }
        $fh->close || Carp::carp "error closing $h: $!";
    }

    return;
}

sub DESTROY {
    my $self = shift;
    $self->close;
    $self->wait_child;
    return;
}

1;

__END__