view release on metacpan or  search on metacpan

lib/System/Sub.pm  view on Meta::CPAN

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;