File Coverage

blib/lib/System/Sub.pm

Criterion	Covered	Total	%
statement	111	137	81.0
branch	56	86	65.1
condition	7	12	58.3
subroutine	20	23	86.9
pod			n/a
total	194	258	75.1

use strict;
use warnings;
package System::Sub;
$System::Sub::VERSION = '0.162800';
use File::Which ();
use Sub::Name 'subname';
use Symbol 'gensym';
use IPC::Run qw(start finish);
use Scalar::Util 1.11 ();  # set_prototype(&$) appeared in 1.11

our @CARP_NOT;

use constant DEBUG => !! $ENV{PERL_SYSTEM_SUB_DEBUG};



my %OPTIONS = (
    # Value is the expected ref of the option value
    # undef is no value
    '>' => '',
    '<' => '',
    'ENV' => 'HASH',
    '?' => 'CODE',
);

sub _croak
{
    require Carp;
    goto &Carp::croak
}

sub _carp
{
    require Carp;
    goto &Carp::carp
}

sub import
{
    my $pkg = (caller)[0];
    shift;

    my $common_options;
    $common_options = shift if @_ && ref($_[0]) eq 'ARRAY';

    while (@_) {
        my $name = shift;
        # Must be a scalar
        _croak "invalid arg: SCALAR expected" unless defined ref $name && ! ref $name;
        my ($fq_name, $proto);
        if ($name =~ s/\(([^)]*)\)$//s) {
            $proto = $1;
        }
        if (index($name, ':') > 0) {
            $fq_name = $name;
            $name = substr($fq_name, 1+rindex($fq_name, ':'));
        } else {
            $fq_name = $pkg.'::'.$name;
        }

        my $options;
        if (@_ && ref $_[0]) {
            $options = shift;
            splice(@$options, 0, 0, @$common_options) if $common_options;
        } elsif ($common_options) {
            # Just duplicate common options
            $options = [ @$common_options ];
        }

        my $cmd = $name;
        my $args;
        my %options;

        if ($options) {
            while (@$options) {
                my $opt = shift @$options;
                (my $opt_short = $opt) =~ s/^[\$\@\%\&]//;
                if ($opt eq '--') {
                    _croak 'duplicate @ARGV' if $args && !$common_options;
                    $args = $options;
                    last
                } elsif ($opt eq '()') {
                    $proto = shift @$options;
                } elsif ($opt =~ /^\$?0$/s) { # $0
                    $cmd = shift @$options;
                } elsif ($opt =~ /^\@?ARGV$/) { # @ARGV
                    _croak "$name: invalid \@ARGV" if ref($options->[0]) ne 'ARRAY';
                    $args = shift @$options;
                } elsif (! exists ($OPTIONS{$opt_short})) {
                    _carp "$name: unknown option $opt";
                } elsif (defined $OPTIONS{$opt_short}) {
                    my $value = shift @$options;
                    unless (defined $value) {
                        _croak "$name: value expected for option $opt"
                    } elsif (ref($value) ne $OPTIONS{$opt_short}) {
                        _croak "$name: invalid value for option $opt"
                    }
                    $options{$opt_short} = $value;
                } else {
                    $options{$opt_short} = 1;
                }
            }
        }

        unless (File::Spec->file_name_is_absolute($cmd)) {
            my ($vol, $dir, undef) = File::Spec->splitpath($cmd);
            if (length($vol)+length($dir) == 0) {
                $cmd = File::Which::which($cmd);
            }
        }

        my $sub = defined($cmd)
                ? _build_sub($name, [ $cmd, ($args ? @$args : ())], \%options)
                : sub { _croak "'$name' not found in PATH" };

        # As set_prototype *has* a prototype, we have to workaround it
        # with '&'
        &Scalar::Util::set_prototype($sub, $proto) if defined $proto;

        no strict 'refs';
        *{$fq_name} = subname $fq_name, $sub;
    }
}

sub _handle_error
{
    my ($name, $code, $cmd, $handler) = @_;
    if ($handler) {
        $handler->($name, $?, $cmd);
    } else {
        _croak "$name error ".($?>>8)
    }
}

sub _build_sub
{
    my ($name, $cmd, $options) = @_;

    return sub {
        my ($input, $output_cb);
        $output_cb = pop if ref $_[$#_] eq 'CODE';
        $input = pop if ref $_[$#_];
        my @cmd = (@$cmd, @_);

        print join(' ', '[', (map { / / ? qq{"$_"} : $_ } @cmd), ']'), "\n"
            if DEBUG;

        my $h;
        my $out = gensym; # IPC::Run needs GLOBs

        # errors from IPC::Run must be reported as comming from our
        # caller, not from here
        local @IPC::Run::CARP_NOT = (@IPC::Run::CARP_NOT, __PACKAGE__);

        local %ENV = (%ENV, %{$options->{ENV}}) if exists $options->{ENV};

        if ($input) {
            my $in = gensym;
            $h = start \@cmd,
                       'pipe', $out or _croak $!;
            binmode($in, $options->{'>'}) if exists $options->{'>'};
            if (ref $input eq 'ARRAY') {
                print $in map { "$_$/" } @$input;
            } elsif (ref $input eq 'SCALAR') {
                # use ${$input}} as raw input
                print $in $$input;
            }
            close $in;
        } else {
            $h = start \@cmd, \undef, '>pipe', $out or _croak $!;
        }
        binmode($out, $options->{'<'}) if exists $options->{'<'};
        if (wantarray) {
            my @output;
            if ($output_cb) {
                local $_;
                while (<$out>) {
                    chomp;
                    push @output, $output_cb->($_)
                }
            } else {
                while (my $x = <$out>) {
                    chomp $x;
                    push @output, $x
                }
            }
            close $out;
            finish $h;
            _handle_error($name, $?, \@cmd, $options->{'?'}) if $? >> 8;
            return @output
        } elsif (defined wantarray) {
            # Only the first line
            my $output;
            defined($output = <$out>) and chomp $output;
            close $out;
            finish $h;
            _handle_error($name, $?, \@cmd, $options->{'?'}) if $? >> 8;
            _croak "no output" unless defined $output;
            return $output
        } else { # void context
            if ($output_cb) {
                local $_;
                while (<$out>) {
                    chomp;
                    $output_cb->($_)
                }
            }
            close $out;
            finish $h;
            _handle_error($name, $?, \@cmd, $options->{'?'}) if $? >> 8;
            return
        }
    }
}


1;
__END__