File Coverage

blib/lib/System/Sub.pm
Criterion Covered Total %
statement 111 135 82.2
branch 56 86 65.1
condition 7 12 58.3
subroutine 20 23 86.9
pod n/a
total 194 256 75.7


line stmt bran cond sub pod time code
1 6     6   151235 use strict;
  6         18  
  6         268  
2 6     6   34 use warnings;
  6         13  
  6         458  
3             package System::Sub;
4             $System::Sub::VERSION = '0.142280';
5 6     6   5777 use File::Which ();
  6         8960  
  6         137  
6 6     6   5480 use Sub::Name 'subname';
  6         5879  
  6         482  
7 6     6   6678 use Symbol 'gensym';
  6         6266  
  6         513  
8 6     6   9518 use IPC::Run qw(start finish);
  6         376586  
  6         430  
9 6     6   66 use Scalar::Util 1.11 (); # set_prototype(&$) appeared in 1.11
  6         228  
  6         267  
10              
11             our @CARP_NOT;
12              
13 6     6   32 use constant DEBUG => !! $ENV{PERL_SYSTEM_SUB_DEBUG};
  6         13  
  6         4903  
14              
15              
16              
17             my %OPTIONS = (
18             # Value is the expected ref of the option value
19             # undef is no value
20             '>' => '',
21             '<' => '',
22             'ENV' => 'HASH',
23             '?' => 'CODE',
24             );
25              
26             sub _croak
27             {
28 0     0   0 require Carp;
29 0         0 goto &Carp::croak
30             }
31              
32             sub _carp
33             {
34 0     0   0 require Carp;
35 0         0 goto &Carp::carp
36             }
37              
38             sub import
39             {
40 6     6   167 my $pkg = (caller)[0];
41 6         17 shift;
42              
43 6         15 my $common_options;
44 6 100 66     86 $common_options = shift if @_ && ref($_[0]) eq 'ARRAY';
45              
46 6         33 while (@_) {
47 10         21 my $name = shift;
48             # Must be a scalar
49 10 50 33     70 _croak "invalid arg: SCALAR expected" unless defined ref $name && ! ref $name;
50 10         17 my ($fq_name, $proto);
51 10 100       55 if ($name =~ s/\(([^)]*)\)$//s) {
52 3         12 $proto = $1;
53             }
54 10 100       104 if (index($name, ':') > 0) {
55 1         1 $fq_name = $name;
56 1         13 $name = substr($fq_name, 1+rindex($fq_name, ':'));
57             } else {
58 9         27 $fq_name = $pkg.'::'.$name;
59             }
60              
61 10         15 my $options;
62 10 100 100     66 if (@_ && ref $_[0]) {
    100          
63 7         14 $options = shift;
64 7 100       24 splice(@$options, 0, 0, @$common_options) if $common_options;
65             } elsif ($common_options) {
66             # Just duplicate common options
67 2         6 $options = [ @$common_options ];
68             }
69              
70 10         22 my $cmd = $name;
71 10         15 my $args;
72             my %options;
73              
74 10 100       29 if ($options) {
75 9         24 while (@$options) {
76 20         29 my $opt = shift @$options;
77 20         53 (my $opt_short = $opt) =~ s/^[\$\@\%\&]//;
78 20 100       128 if ($opt eq '--') {
    100          
    100          
    100          
    50          
    50          
79 1 50 33     15 _croak 'duplicate @ARGV' if $args && !$common_options;
80 1         3 $args = $options;
81             last
82 1         9 } elsif ($opt eq '()') {
83 2         8 $proto = shift @$options;
84             } elsif ($opt =~ /^\$?0$/s) { # $0
85 9         31 $cmd = shift @$options;
86             } elsif ($opt =~ /^\@?ARGV$/) { # @ARGV
87 5 50       22 _croak "$name: invalid \@ARGV" if ref($options->[0]) ne 'ARRAY';
88 5         17 $args = shift @$options;
89             } elsif (! exists ($OPTIONS{$opt_short})) {
90 0         0 _carp "$name: unknown option $opt";
91             } elsif (defined $OPTIONS{$opt_short}) {
92 3         6 my $value = shift @$options;
93 3 50       16 unless (defined $value) {
    50          
94 0         0 _croak "$name: value expected for option $opt"
95             } elsif (ref($value) ne $OPTIONS{$opt_short}) {
96 0         0 _croak "$name: invalid value for option $opt"
97             }
98 3         11 $options{$opt_short} = $value;
99             } else {
100 0         0 $options{$opt_short} = 1;
101             }
102             }
103             }
104              
105 10 100       172 unless (File::Spec->file_name_is_absolute($cmd)) {
106 1         62 my ($vol, $dir, undef) = File::Spec->splitpath($cmd);
107 1 50       4 if (length($vol)+length($dir) == 0) {
108 1         13 $cmd = File::Which::which($cmd);
109             }
110             }
111              
112             my $sub = defined($cmd)
113             ? _build_sub($name, [ $cmd, ($args ? @$args : ())], \%options)
114 10 100   0   335 : sub { _croak "'$name' not found in PATH" };
  0 50       0  
115              
116             # As set_prototype *has* a prototype, we have to workaround it
117             # with '&'
118 10 100       47 &Scalar::Util::set_prototype($sub, $proto) if defined $proto;
119              
120 6     6   41 no strict 'refs';
  6         11  
  6         12695  
121 10         96 *{$fq_name} = subname $fq_name, $sub;
  10         12264  
122             }
123             }
124              
125             sub _handle_error
126             {
127 2     2   23 my ($name, $code, $cmd, $handler) = @_;
128 2 50       11 if ($handler) {
129 2         19 $handler->($name, $?, $cmd);
130             } else {
131 0         0 _croak "$name error ".($?>>8)
132             }
133             }
134              
135             sub _build_sub
136             {
137 10     10   19 my ($name, $cmd, $options) = @_;
138              
139             return sub {
140 16     16   35635 my ($input, $output_cb);
        7      
        7      
        3      
        3      
        2      
        5      
        5      
141 16 50       146 $output_cb = pop if ref $_[$#_] eq 'CODE';
142 16 50       91 $input = pop if ref $_[$#_];
143 16         188 my @cmd = (@$cmd, @_);
144              
145 16         27 print join(' ', '[', (map { / / ? qq{"$_"} : $_ } @cmd), ']'), "\n"
146             if DEBUG;
147              
148 16         35 my $h;
149 16         256 my $out = gensym; # IPC::Run needs GLOBs
150              
151             # errors from IPC::Run must be reported as comming from our
152             # caller, not from here
153 16         667 local @IPC::Run::CARP_NOT = (@IPC::Run::CARP_NOT, __PACKAGE__);
154              
155 16 100       104 local %ENV = (%ENV, %{$options->{ENV}}) if exists $options->{ENV};
  3         309  
156              
157 16 50       101 if ($input) {
158 0         0 my $in = gensym;
159 0 0       0 $h = start \@cmd,
160             'pipe', $out or _croak $!;
161 0 0       0 binmode($in, $options->{'>'}) if exists $options->{'>'};
162 0 0       0 if (ref $input eq 'ARRAY') {
    0          
163 0         0 print $in map { "$_$/" } @$input;
  0         0  
164             } elsif (ref $input eq 'SCALAR') {
165             # use ${$input}} as raw input
166 0         0 print $in $$input;
167             }
168 0         0 close $in;
169             } else {
170 16 50       151 $h = start \@cmd, \undef, '>pipe', $out or _croak $!;
171             }
172 16 50       220188 binmode($out, $options->{'<'}) if exists $options->{'<'};
173 16 100       224 if (wantarray) {
    100          
174 6         48 my @output;
175 6 50       78 if ($output_cb) {
176 0         0 while (<$out>) {
177 0         0 chomp;
178 0         0 push @output, $output_cb->($_)
179             }
180             } else {
181 6         56059 while (<$out>) {
182 8         38 chomp;
183 8         1866 push @output, $_
184             }
185             }
186 6         215 close $out;
187 6         115 finish $h;
188 6 50       9231 _handle_error($name, $?, \@cmd, $options->{'?'}) if $? >> 8;
189             return @output
190 6         416 } elsif (defined wantarray) {
191             # Only the first line
192 8         51 my $output;
193 8 50       16059 defined($output = <$out>) and chomp $output;
194 8         254 close $out;
195 8         251 finish $h;
196 8 50       17561 _handle_error($name, $?, \@cmd, $options->{'?'}) if $? >> 8;
197 8 50       58 _croak "no output" unless defined $output;
198 8         404 return $output
199             } else { # void context
200 2 50       15 if ($output_cb) {
201 0         0 while (<$out>) {
202 0         0 chomp;
203 0         0 $output_cb->($_)
204             }
205             }
206 2         31 close $out;
207 2         37 finish $h;
208 2 50       44364 _handle_error($name, $?, \@cmd, $options->{'?'}) if $? >> 8;
209             return
210 2         6746 }
211             }
212 10         97 }
213              
214              
215             1;
216             __END__