File Coverage

blib/lib/Sys/Cmd.pm
Criterion Covered Total %
statement 251 303 82.8
branch 79 128 61.7
condition 6 16 37.5
subroutine 27 30 90.0
pod 6 7 85.7
total 369 484 76.2


line stmt bran cond sub pod time code
1             package # Trick xt/ tests into working
2             Sys::Cmd::Mo;
3              
4             BEGIN {
5             #<<< No perltidy
6             # use Mo qw/build is required default import/;
7             # The following line of code was produced from the previous line by
8             # Mo::Inline version 0.39
9 4 0 66 4   52009 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..$#_];if(!exists$a{$n}){require Carp;Carp::croak($n." required")}$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;
  3 50 33 4   6  
  3 100 50 3   2487  
  4 50 0 3   174  
  3 50 33 3   6  
  3 50   3   1742  
  3 50   3   24  
  3 100   3   6  
  3 100   3   79  
  3 50   918   46  
  3 50       10  
  3 50       157  
  3 50       10  
  3 50       24  
  3 100       24  
  21 50       53  
  21 100       87  
  21 50       46  
  21         120  
  21         119  
  0         0  
  21         66  
  3         34  
  3         14  
  4         49  
  4         11  
  4         14  
  4         21  
  4         230  
  14         83  
  4         15  
  4         33  
  0         0  
  0         0  
  0         0  
  44         61  
  44         122  
  822         8476  
  44         108  
  44         183  
  44         60  
  44         195  
  4         12  
  11         58  
  4         11  
  4         8542  
  3         42  
  3         29  
  3         9  
  3         198  
  20         56  
  20         42  
  20         162  
  20         40  
  20         38  
  40         252  
  40         138  
  20         200  
  17         162  
  3         10  
  3         20  
  4         11  
  4         264  
  44         128  
  44         87  
  44         238  
  900         490264  
  3         23  
  3         17  
  3         9  
  3         164  
  39         94  
  39         78  
  3         4  
  3         13  
  3         9  
  20         104  
  17         126  
  17         71  
  0         0  
  0         0  
  17         101  
  39         85  
  3         9  
  3         17  
  4         11  
  4         30  
  44         156  
  44         139  
  13         27  
  13         54  
  0         0  
  0         0  
  0         0  
  13         21  
  13         53  
  13         28  
  0         0  
  13         99  
  431         1687  
  3         6  
  3         9  
  3         56  
  4         39  
  4         16  
  3         25  
  3         719  
  0         0  
  0         0  
  3         426  
  0         0  
  0         0  
  3         429  
  0         0  
  0         0  
  3         422  
  0         0  
  0         0  
10 3         108 $INC{'Sys/Cmd/Mo.pm'} = __FILE__;
11             #>>>
12             }
13             1;
14              
15             package Sys::Cmd;
16 3     3   19 use strict;
  3         6  
  3         88  
17 3     3   20 use warnings;
  3         9  
  3         92  
18 3     3   56 use 5.006;
  3         9  
19 3     3   18 use Carp;
  3         6  
  3         213  
20 3     3   2173 use Exporter::Tidy all => [qw/spawn run runx/];
  3         48  
  3         20  
21 3     3   184 use File::Spec;
  3         6  
  3         76  
22 3     3   565 use IO::Handle;
  3         6309  
  3         130  
23 3     3   1448 use Log::Any qw/$log/;
  3         30500  
  3         12  
24 3     3   6455 use Sys::Cmd::Mo;
  3         6  
  3         12  
25              
26             our $VERSION = '0.99.0_1';
27             our $CONFESS;
28              
29             sub run {
30 0     0 1 0 my $proc = spawn(@_);
31 0         0 my @out = $proc->stdout->getlines;
32 0         0 my @err = $proc->stderr->getlines;
33              
34 0         0 $proc->wait_child;
35              
36 0 0       0 if ( $proc->exit != 0 ) {
37 0 0       0 Carp::confess(
38             join( '', @err ) . 'Command exited with value ' . $proc->exit )
39             if $CONFESS;
40 0         0 Carp::croak(
41             join( '', @err ) . 'Command exited with value ' . $proc->exit );
42             }
43              
44 0 0       0 warn @err if @err;
45              
46 0 0       0 if (wantarray) {
47 0         0 return @out;
48             }
49             else {
50 0         0 return join( '', @out );
51             }
52             }
53              
54             sub runx {
55 0     0 1 0 my $proc = spawn(@_);
56 0         0 my @out = $proc->stdout->getlines;
57 0         0 my @err = $proc->stderr->getlines;
58              
59 0         0 $proc->wait_child;
60              
61 0 0       0 if ( $proc->exit != 0 ) {
62 0 0       0 Carp::confess(
63             join( '', @err ) . 'Command exited with value ' . $proc->exit )
64             if $CONFESS;
65 0         0 Carp::croak(
66             join( '', @err ) . 'Command exited with value ' . $proc->exit );
67             }
68              
69 0 0       0 if (wantarray) {
70 0         0 return @out, @err;
71             }
72             else {
73 0         0 return join( '', @out, @err );
74             }
75             }
76              
77             sub spawn {
78 26     26 1 76916 my @cmd = grep { ref $_ ne 'HASH' } @_;
  54         204  
79              
80 26 50       140 defined $cmd[0] || Carp::confess '$cmd must be defined';
81              
82 26 100       128 unless ( ref $cmd[0] eq 'CODE' ) {
83              
84 24 100       318 if ( File::Spec->splitdir( $cmd[0] ) == 1 ) {
85 4         1510 require File::Which;
86 4   33     2584 $cmd[0] = File::Which::which( $cmd[0] )
87             || Carp::confess 'command not found: ' . $cmd[0];
88             }
89              
90 20 100       1000 if ( !-x $cmd[0] ) {
91 2         500 Carp::confess 'command not executable: ' . $cmd[0];
92             }
93             }
94              
95 20         92 my @opts = grep { ref $_ eq 'HASH' } @_;
  48         160  
96 20 50       80 if ( @opts > 2 ) {
97 0         0 Carp::confess __PACKAGE__ . ": only a single hashref allowed";
98             }
99              
100 20 100       68 my %args = @opts ? %{ $opts[0] } : ();
  14         76  
101 20         68 $args{cmd} = \@cmd;
102              
103 20         282 return Sys::Cmd->new(%args);
104             }
105              
106             has 'cmd' => (
107             is => 'ro',
108             isa => sub {
109             ref $_[0] eq 'ARRAY' || Carp::confess "cmd must be ARRAYREF";
110             @{ $_[0] } || Carp::confess "Missing cmd elements";
111             if ( grep { !defined $_ } @{ $_[0] } ) {
112             Carp::confess 'cmd array cannot contain undef elements';
113             }
114             },
115             required => 1,
116             );
117              
118             has 'encoding' => (
119             is => 'ro',
120             default => sub { ':utf8' },
121             );
122              
123             has 'env' => (
124             is => 'ro',
125             isa => sub { ref $_[0] eq 'HASH' || Carp::confess "env must be HASHREF" },
126             );
127              
128             has 'dir' => ( is => 'ro', );
129              
130             has 'input' => ( is => 'ro', );
131              
132             has 'pid' => (
133             is => 'rw',
134             init_arg => undef,
135             );
136              
137             has 'stdin' => (
138             is => 'rw',
139             init_arg => undef,
140             default => sub { IO::Handle->new },
141             );
142              
143             has 'stdout' => (
144             is => 'rw',
145             init_arg => undef,
146             default => sub { IO::Handle->new },
147             );
148              
149             has 'stderr' => (
150             is => 'rw',
151             init_arg => undef,
152             default => sub { IO::Handle->new },
153             );
154              
155             has on_exit => (
156             is => 'rw',
157             init_arg => 'on_exit',
158             );
159              
160             has 'exit' => (
161             is => 'rw',
162             init_arg => undef,
163             );
164              
165             has 'signal' => (
166             is => 'rw',
167             init_arg => undef,
168             );
169              
170             has 'core' => (
171             is => 'rw',
172             init_arg => undef,
173             );
174              
175             sub BUILD {
176 20     20 0 44 my $self = shift;
177 20         86 my $dir = $self->dir;
178              
179 20 100       1386 require File::chdir if $dir;
180 20 100       7576 local $File::chdir::CWD = $dir if $dir;
181              
182 18         1840 local %ENV = %ENV;
183              
184 18 100       108 if ( defined( my $x = $self->env ) ) {
185 10         68 while ( my ( $key, $val ) = each %$x ) {
186 16 100       48 if ( defined $val ) {
187 12         82 $ENV{$key} = $val;
188             }
189             else {
190 4         24 delete $ENV{$key};
191             }
192             }
193             }
194              
195 18 100       172 if ( ref $self->cmd->[0] eq 'CODE' ) {
196 2         12 $self->_fork;
197             }
198             else {
199 16         68 $self->_spawn;
200             }
201              
202 17         68 my $enc = $self->encoding;
203 17 50       47 binmode( $self->stdin, $enc ) or warn "binmode stdin: $!";
204 17 50       59 binmode( $self->stdout, $enc ) or warn "binmode stdout: $!";
205 17 50       59 binmode( $self->stderr, $enc ) or warn "binmode stderr: $!";
206              
207 17         49 $log->debugf( '[%d][%s] %s', $self->pid, $enc, scalar $self->cmdline );
208              
209             # some input was provided
210 17 100       103 if ( defined( my $input = $self->input ) ) {
211             local $SIG{PIPE} =
212 4     0   164 sub { warn "Broken pipe when writing to:" . $self->cmdline };
  0         0  
213              
214 4 100       32 $self->stdin->print($input) if length $input;
215              
216 4         98 $self->stdin->close;
217             }
218              
219 17         969 return;
220             }
221              
222             sub _spawn {
223 16     16   36 my $self = shift;
224 16         2690 require Proc::FastSpawn;
225              
226             # Get new handles to descriptors 0,1,2
227 16         1350 my $fd0 = IO::Handle->new_from_fd( 0, 'r' );
228 16         1848 my $fd1 = IO::Handle->new_from_fd( 1, 'w' );
229 16         1056 my $fd2 = IO::Handle->new_from_fd( 2, 'w' );
230              
231             # Backup the original 0,1,2 file descriptors
232 16         1340 open my $old_fd0, '<&', 0;
233 16         306 open my $old_fd1, '>&', 1;
234 16         292 open my $old_fd2, '>&', 2;
235              
236             # Pipe our filehandles to new child filehandles
237 16 50       114 pipe( my $child_in, $self->stdin ) || die "pipe: $!";
238 16 50       1112 pipe( $self->stdout, my $child_out ) || die "pipe: $!";
239 16 50       848 pipe( $self->stderr, my $child_err ) || die "pipe: $!";
240              
241             # Make sure that 0,1,2 are inherited (probably are anyway)
242 16         1006 Proc::FastSpawn::fd_inherit( $_, 1 ) for 0, 1, 2;
243              
244             # But don't inherit the rest
245             Proc::FastSpawn::fd_inherit( fileno($_), 0 )
246 16         76 for $old_fd0, $old_fd1, $old_fd2, $child_in, $child_out, $child_err,
247             $self->stdin, $self->stdout, $self->stderr;
248              
249 16         48 eval {
250             # Re-open 0,1,2 by duping the child pipe ends
251 16         358 open $fd0, '<&', fileno($child_in);
252 16         304 open $fd1, '>&', fileno($child_out);
253 16         376 open $fd2, '>&', fileno($child_err);
254              
255             # Kick off the new process
256             $self->pid(
257             Proc::FastSpawn::spawn(
258             $self->cmd->[0],
259             $self->cmd,
260             [
261 16 50       86 map { $_ . '=' . ( defined $ENV{$_} ? $ENV{$_} : '' ) }
  584         7806  
262             keys %ENV
263             ]
264             )
265             );
266             };
267 16         188 my $err = $@;
268              
269             # Restore our local 0,1,2 to the originals
270 16         486 open $fd0, '<&', fileno($old_fd0);
271 16         320 open $fd1, '>&', fileno($old_fd1);
272 16         298 open $fd2, '>&', fileno($old_fd2);
273              
274             # Complain if the spawn failed for some reason
275 16 50       64 Carp::croak $err if $err;
276 16 50       58 Carp::croak 'Unable to spawn child' unless defined $self->pid;
277              
278             # Parent doesn't need to see the child or backup descriptors anymore
279             close($_)
280 16         404 for $old_fd0, $old_fd1, $old_fd2, $child_in, $child_out, $child_err;
281              
282 16         62 $self->stdin->autoflush(1);
283              
284 16         1348 return;
285             }
286              
287             sub _fork {
288 2     2   84 my $self = shift;
289              
290 2 50       24 pipe( my $child_in, $self->stdin ) || die "pipe: $!";
291 2 50       174 pipe( $self->stdout, my $child_out ) || die "pipe: $!";
292 2 50       106 pipe( $self->stderr, my $child_err ) || die "pipe: $!";
293              
294 2         2828 $self->pid( fork() );
295 2 50       49 if ( !defined $self->pid ) {
296 0         0 my $why = $!;
297 0         0 die "fork: $why";
298             }
299              
300 2 100       65 if ( $self->pid > 0 ) { # parent
301 1         38 close $child_in;
302 1         13 close $child_out;
303 1         25 close $child_err;
304              
305 1         24 $self->stdin->autoflush(1);
306 1         289 return;
307             }
308              
309             # Child
310              
311 1         42 $self->exit(0); # stop DESTROY() from trying to reap
312 1         115 $child_out->autoflush(1);
313 1         209 $child_err->autoflush(1);
314              
315 1         63 my $enc = $self->encoding;
316              
317 1         47 foreach my $h (
318             [ \*STDIN, '<&=' . $enc, $child_in ],
319             [ \*STDOUT, '>&=' . $enc, $child_out ],
320             [ \*STDERR, '>&=' . $enc, $child_err ]
321             )
322             {
323 3 50       139 open( $h->[0], $h->[1], fileno( $h->[2] ) )
324             or print $child_err sprintf '[%d] open %s: %s', $self->pid,
325             $h->[0], $!;
326             }
327              
328 1         13 close $self->stdin;
329 1         11 close $self->stdout;
330 1         9 close $self->stderr;
331 1         8 close $child_in;
332 1         22 close $child_out;
333 1         8 close $child_err;
334              
335 1 50       27 if ( ref( my $code = $self->cmd->[0] ) eq 'CODE' ) {
336 1         14 $code->();
337 0         0 _exit(0);
338             }
339              
340 0         0 exec( @{ $self->cmd } );
  0         0  
341 0         0 die "exec: $!";
342             }
343              
344             sub cmdline {
345 29     29 1 4437 my $self = shift;
346 29 100       80 if (wantarray) {
347 12         24 return @{ $self->cmd };
  12         56  
348             }
349             else {
350 17         32 return join( ' ', @{ $self->cmd } );
  17         45  
351             }
352             }
353              
354             sub wait_child {
355 37     37 1 99 my $self = shift;
356              
357 37 100       105 return unless defined $self->pid;
358 35 100       112 return $self->exit if defined $self->exit;
359              
360 17         99 local $?;
361 17         73 local $!;
362              
363 17         41 my $pid = waitpid $self->pid, 0;
364 17         85 my $ret = $?;
365              
366 17 50       55 if ( $pid != $self->pid ) {
367 0         0 warn sprintf( 'Could not reap child process %d (waitpid returned: %d)',
368             $self->pid, $pid );
369 0         0 $pid = $self->pid;
370 0         0 $ret = 0;
371             }
372              
373 17 50       63 if ( $ret == -1 ) {
374              
375             # So waitpid returned a PID but then sets $? to this
376             # strange value? (Strange in that tests randomly show it to
377             # be invalid.) Most likely a perl bug; I think that waitpid
378             # got interrupted and when it restarts/resumes the status
379             # is lost.
380             #
381             # See http://www.perlmonks.org/?node_id=641620 for a
382             # possibly related discussion.
383             #
384             # However, since I localised $? and $! above I haven't seen
385             # this problem again, so I hope that is a good enough work
386             # around. Lets warn any way so that we know when something
387             # dodgy is going on.
388 0         0 warn __PACKAGE__
389             . ' received invalid child exit status for pid '
390             . $pid
391             . ' Setting to 0';
392 0         0 $ret = 0;
393              
394             }
395              
396             $log->debugf(
397 17         58 '(PID %d) exit: %d signal: %d core: %d',
398             $pid,
399             $self->exit( $ret >> 8 ),
400             $self->signal( $ret & 127 ),
401             $self->core( $ret & 128 )
402             );
403              
404 17 100       104 if ( my $subref = $self->on_exit ) {
405 2         10 $subref->($self);
406             }
407              
408 17         49 return $self->exit;
409             }
410              
411             sub close {
412 33     33 1 797 my $self = shift;
413              
414 33         123 foreach my $h (qw/stdin stdout stderr/) {
415              
416             # may not be defined during global destruction
417 99 50       1372 my $fh = $self->$h or next;
418 99 100       458 $fh->opened or next;
419 47 100       345 if ( $h eq 'stderr' ) {
420             warn sprintf( '[%d] uncollected stderr: %s', $self->pid, $_ )
421 17         43 for $self->stderr->getlines;
422             }
423 47 50       621807 $fh->close || Carp::carp "error closing $h: $!";
424             }
425              
426 33         487 return;
427             }
428              
429             sub DESTROY {
430 20     20   21727 my $self = shift;
431 20         81 $self->close;
432 20         72 $self->wait_child;
433 20         312 return;
434             }
435              
436             1;
437              
438             __END__