File Coverage

blib/lib/System/Command.pm

Criterion	Covered	Total	%
statement	301	315	95.5
branch	43	60	71.6
condition	4	12	33.3
subroutine	85	88	96.5
pod	5	5	100.0
total	438	480	91.2

package System::Command;
$System::Command::VERSION = '1.120';
use warnings;
use strict;
use 5.006;

use Carp;
use Cwd qw( cwd );
use IO::Handle;
use Symbol ();
use Scalar::Util qw( blessed reftype );
use List::Util qw( reduce );
use System::Command::Reaper;

use Config;
use Fcntl qw( F_GETFD F_SETFD FD_CLOEXEC );

# MSWin32 support
use constant MSWin32 => $^O eq 'MSWin32';
require IPC::Run if MSWin32;

our $QUIET = 0;

# trace setup at startup
my $_trace_opts = sub {
    my ( $trace, $file, $th ) = split /=/, shift, 2;
    open $th, '>>', $file or carp "Can't open $file: $!" if $file;
    $th ||= *STDERR;
    return ( $trace, $th );
};
my @trace;
@trace = $_trace_opts->( $ENV{SYSTEM_COMMAND_TRACE} )
    if $ENV{SYSTEM_COMMAND_TRACE};

sub import {
    my ( $class, @args ) = @_;
    my %arg = ( quiet => sub { $QUIET = 1 } );
    for my $arg (@args) {
        $arg =~ s/^-//;    # allow dashed options
        croak "Unknown option '$arg' in 'use System::Command'"
            if !exists $arg{$arg};
        $arg{$arg}->();
    }
}

# a few simple accessors
{
    no strict 'refs';
    for my $attr (qw( pid stdin stdout stderr options )) {
        *$attr = sub { return $_[0]{$attr} };
    }
    for my $attr (qw( exit signal core )) {
        no strict 'refs';
        *$attr = sub { $_[0]->is_terminated(); return $_[0]{$attr} };
    }
    for my $attr (qw( cmdline )) {
        *$attr = sub { return @{ $_[0]{$attr} } };
    }
}

# REALLY PRIVATE FUNCTIONS
# a sub-process spawning function
my $_spawn = sub {
    my ($o, @cmd) = @_;
    my $pid;

    # setup filehandles
    my $in  = Symbol::gensym;
    my $out = Symbol::gensym;
    my $err = Symbol::gensym;

    # no buffering on pipes used for writing
    select( ( select($in), $| = 1 )[0] );

    # start the command
    if (MSWin32) {
        $pid = IPC::Run::start(
            [@cmd],
            ' $in,
            '>pipe'  => $out,
            '2>pipe' => $err,
        );
    }
    else {

        # the code below takes inspiration from IPC::Open3 and Sys::Cmd

        # create handles for the child process (using CAPITALS)
        my $IN  = Symbol::gensym;
        my $OUT = Symbol::gensym;
        my $ERR = Symbol::gensym;

        # no buffering on pipes used for writing
        select( ( select($OUT), $| = 1 )[0] );
        select( ( select($ERR), $| = 1 )[0] );

        # connect parent and child with pipes
        pipe $IN,  $in  or croak "input pipe(): $!";
        pipe $out, $OUT or croak "output pipe(): $!";
        pipe $err, $ERR or croak "errput pipe(): $!";

        # an extra pipe to communicate exec() failure
        pipe my ( $stat_r, $stat_w );

        # create the child process
        $pid = fork;
        croak "Can't fork: $!" if !defined $pid;

        if ($pid) {

            # parent won't use those handles
            close $stat_w;
            close $IN;
            close $OUT;
            close $ERR;

            # failed to fork+exec?
            my $mesg = do { local $/; <$stat_r> };
            die $mesg if $mesg;
        }
        else {    # kid

            # use $stat_r to communicate errors back to the parent
            eval {

                # child won't use those handles
                close $stat_r;
                close $in;
                close $out;
                close $err;

                # setup process group if possible
                setpgrp 0, 0 if $o->{setpgrp} && $Config{d_setpgrp};

                # close $stat_w on exec
                my $flags = fcntl( $stat_w, F_GETFD, 0 )
                    or croak "fcntl GETFD failed: $!";
                fcntl( $stat_w, F_SETFD, $flags | FD_CLOEXEC )
                    or croak "fcntl SETFD failed: $!";

                # associate STDIN, STDOUT and STDERR to the pipes
                my ( $fd_IN, $fd_OUT, $fd_ERR )
                    = ( fileno $IN, fileno $OUT, fileno $ERR );
                open \*STDIN, "<&=$fd_IN"
                    or croak "Can't open( \\*STDIN, '<&=$fd_IN' ): $!";
                open \*STDOUT, ">&=$fd_OUT"
                    or croak "Can't open( \\*STDOUT, '<&=$fd_OUT' ): $!";
                open \*STDERR, ">&=$fd_ERR"
                    or croak "Can't open( \\*STDERR, '<&=$fd_ERR' ): $!";

                # and finally, exec into @cmd
                exec( { $cmd[0] } @cmd )
                    or do { croak "Can't exec( @cmd ): $!"; }
            };

            # something went wrong
            print $stat_w $@;
            close $stat_w;

            # DIE DIE DIE
            eval { require POSIX; POSIX::_exit(255); };
            exit 255;
        }
    }

    return ( $pid, $in, $out, $err );
};

my $_dump_ref = sub {
    require Data::Dumper;    # only load if needed
    local $Data::Dumper::Indent    = 0;
    local $Data::Dumper::Purity    = 0;
    local $Data::Dumper::Maxdepth  = 0;
    local $Data::Dumper::Quotekeys = 0;
    local $Data::Dumper::Sortkeys  = 1;
    local $Data::Dumper::Useqq     = 1;
    local $Data::Dumper::Terse     = 1;
    return Data::Dumper->Dump( [shift] );
};

my $_do_trace = sub {
    my ( $trace, $th, $pid, $cmd, $o ) = @_;
    print $th "System::Command cmd[$pid]: ",
        join( ' ', map /\s/ ? $_dump_ref->($_) : $_, @$cmd ), "\n";
    print $th map "System::Command opt[$pid]: $_->[0] => $_->[1]\n",
        map [ $_ => $_dump_ref->( $o->{$_} ) ],
        grep { $_ ne 'env' } sort keys %$o
        if $trace > 1;
    print $th map "System::Command env[$pid]: $_->[0] => $_->[1]\n",
        map [ $_ => $_dump_ref->( $o->{env}{$_} ) ],
        keys %{ $o->{env} || {} }
        if $trace > 2;
};

# module methods
sub new {
    my ( $class, @cmd ) = @_;

    # split the args
    my @o = { setpgrp => 1 };
    @cmd = grep { !( ref eq 'HASH' ? push @o, $_ : 0 ) } @cmd;

    # merge the option hashes
    my $o = reduce {
        +{  %$a, %$b,
            exists $a->{env} && exists $b->{env}
            ? ( env => { %{ $a->{env} }, %{ $b->{env} } } )
            : ()
        };
    }
    @o;

    # open the trace file before changing directory
    my ( $trace, $th );
    ( $trace, $th ) = $_trace_opts->( $o->{trace} ) if $o->{trace};
    ( $trace, $th ) = @trace if @trace;    # environment override

    # chdir to the expected directory
    my $orig = cwd;
    my $dest = defined $o->{cwd} ? $o->{cwd} : undef;
    if ( defined $dest ) {
        chdir $dest or croak "Can't chdir to $dest: $!";
    }

    # keep changes to the environment local
    local %ENV = %ENV;

    # update the environment
    if ( exists $o->{env} ) {
        croak "ENV variables cannot be empty strings on Win32"
            if MSWin32 and grep { defined and !length } values %{ $o->{env} };
        @ENV{ keys %{ $o->{env} } } = values %{ $o->{env} };
        delete $ENV{$_}
            for grep { !defined $o->{env}{$_} } keys %{ $o->{env} };
    }

    # interactive mode requested
    if ( $o->{interactive} ) {
        croak "Can't run command in interactive mode: not a terminal"
          unless -t STDIN;

        system { $cmd[0] } @cmd;

        my $self = bless {
            cmdline => [@cmd],
            options => $o,
            stdin   => IO::Handle->new,
            stdout  => IO::Handle->new,
            stderr  => IO::Handle->new,
            exit    => $? >> 8,
            signal  => $? & 127,
            core    => $? & 128,
        }, $class;

        defined reftype( $o->{$_} )
          and reftype( $o->{$_} ) eq 'SCALAR'
          and ${ $o->{$_} } = $self->{$_}
          for qw( exit signal core );

        return $self;
    }

    # start the command
    my ( $pid, $in, $out, $err ) = eval { $_spawn->( $o, @cmd ); };

    # FIXME - better check error conditions
    if ( !defined $pid ) {
        $_do_trace->( $trace, $th, '!', \@cmd, $o ) if $trace;
        croak $@;
    }

    # trace is mostly a debugging tool
    $_do_trace->( $trace, $th, $pid, \@cmd, $o ) if $trace;

    # some input was provided
    if ( defined $o->{input} ) {
        local $SIG{PIPE}
            = sub { croak "Broken pipe when writing to: @cmd" }
            if $Config{sig_name} =~ /\bPIPE\b/;
        print {$in} $o->{input} if length $o->{input};
        $in->close;
    }

    # chdir back to origin
    if ( defined $dest ) {
        chdir $orig or croak "Can't chdir back to $orig: $!";
    }

    # create the object
    my $self = bless {
        cmdline  => [@cmd],
        options  => $o,
        pid      => MSWin32 ? $pid->{KIDS}[0]{PID} : $pid,
        stdin    => $in,
        stdout   => $out,
        stderr   => $err,
      ( _ipc_run => $pid )x!! MSWin32,
    }, $class;

    # create the subprocess reaper and link the handles and command to it
    ${*$in} = ${*$out} = ${*$err} = $self->{reaper}    # typeglobs FTW
      = System::Command::Reaper->new( $self, { trace => $trace, th => $th } );

    return $self;
}

sub spawn {
    my ( $class, @cmd ) = @_;
    return @{ $class->new(@cmd) }{qw( pid stdin stdout stderr )};
}

sub loop_on {
    my $self = shift;

    # handle options and defaults
    my %args = (
        stderr => sub { print STDERR shift },
        @_
    );
    for my $which ( grep exists $args{$_}, qw( stdout stderr ) ) {
        if ( $args{$which} ) {
            croak "'$which' option must be a CODE reference"
              if reftype $args{$which} ne 'CODE';
        }
        else {
            delete $args{$which};
        }
    }

    # create an object for the class method
    if ( !ref $self ) {
        die "'command' attribute required by loop_on when used as a class method"
          if !exists $args{command};
        $self = $self->new( @{ $args{command} } );
    }

    require IO::Select;
    my $select = IO::Select->new( $self->stdout, $self->stderr );

    local $/ = $args{input_record_separator}
      if exists $args{input_record_separator};

    # loop until end of streams
    while ( my @ready = $select->can_read ) {
        for my $fh (@ready) {
            my $which = $fh == $self->stdout ? 'stdout' : 'stderr';
            if ( defined( my $line = <$fh> ) ) {
                my $ret = 1;
                $ret = $args{$which}->($line)
                  if exists $args{$which};
                return if !$ret;
            }
            else {
                $select->remove($fh);
                $fh->close;
            }
        }
    }

    # close all pipes and wait for the child to terminate
    $self->close;

    # success in the Unix sense
    return defined $self->exit && $self->exit == 0;
}

# delegate those to the reaper (when there's one)
sub is_terminated {
    return $_[0]{options}{interactive}
      ? 1
      : $_[0]{reaper}->is_terminated();
}

sub close {
    $_[0]{reaper}->close() unless $_[0]{options}{interactive};
    return $_[0];
}

1;

__END__