File Coverage

blib/lib/IPC/System/Simple.pm
Criterion Covered Total %
statement 193 202 95.5
branch 38 44 86.3
condition 7 11 63.6
subroutine 44 46 95.6
pod 4 4 100.0
total 286 307 93.1


line stmt bran cond sub pod time code
1             package IPC::System::Simple;
2              
3             # ABSTRACT: Run commands simply, with detailed diagnostics
4              
5 31     31   919094 use 5.006;
  31         253  
6 31     31   159 use strict;
  31         56  
  31         681  
7 31     31   144 use warnings;
  31         59  
  31         1139  
8 31     31   191 use re 'taint';
  31         90  
  31         1835  
9 31     31   206 use Carp;
  31         57  
  31         2382  
10 31     31   212 use List::Util qw(first);
  31         51  
  31         3734  
11 31     31   203 use Scalar::Util qw(tainted);
  31         80  
  31         2072  
12 31     31   213 use Config;
  31         72  
  31         1856  
13 31     31   232 use constant WINDOWS => ($^O eq 'MSWin32');
  31         72  
  31         3296  
14 31     31   218 use constant VMS => ($^O eq 'VMS');
  31         59  
  31         2791  
15              
16             BEGIN {
17              
18             # It would be lovely to use the 'if' module here, but it didn't
19             # enter core until 5.6.2, and we want to keep 5.6.0 compatibility.
20              
21              
22 31     31   894 if (WINDOWS) {
23              
24             ## no critic (ProhibitStringyEval)
25              
26             eval q{
27             use Win32::Process qw(INFINITE NORMAL_PRIORITY_CLASS);
28             use File::Spec;
29             use Win32;
30             use Win32::ShellQuote;
31              
32             # This uses the same rules as the core win32.c/get_shell() call.
33             use constant WINDOWS_SHELL => eval { Win32::IsWinNT() }
34             ? [ File::Spec->catfile(Win32::GetFolderPath(Win32::CSIDL_SYSTEM), 'cmd.exe'), '/x/d/c' ]
35             : [ File::Spec->catfile(Win32::GetFolderPath(Win32::CSIDL_SYSTEM), 'command.com'), '/c' ];
36              
37             # These are used when invoking _win32_capture
38             use constant NO_SHELL => 0;
39             use constant USE_SHELL => 1;
40              
41             };
42              
43             ## use critic
44              
45             # Die nosily if any of the above broke.
46             die $@ if $@;
47             }
48             }
49              
50             # Note that we don't use WIFSTOPPED because perl never uses
51             # the WUNTRACED flag, and hence will never return early from
52             # system() if the child processes is suspended with a SIGSTOP.
53              
54 31     31   15927 use POSIX qw(WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG);
  31         208167  
  31         241  
55              
56 31     31   44654 use constant FAIL_START => q{"%s" failed to start: "%s"};
  31         67  
  31         2087  
57 31     31   535 use constant FAIL_PLUMBING => q{Error in IPC::System::Simple plumbing: "%s" - "%s"};
  31         69  
  31         1740  
58 31     31   193 use constant FAIL_CMD_BLANK => q{Entirely blank command passed: "%s"};
  31         61  
  31         1598  
59 31     31   183 use constant FAIL_INTERNAL => q{Internal error in IPC::System::Simple: "%s"};
  31         57  
  31         1441  
60 31     31   177 use constant FAIL_TAINT => q{%s called with tainted argument "%s"};
  31         57  
  31         1608  
61 31     31   179 use constant FAIL_TAINT_ENV => q{%s called with tainted environment $ENV{%s}};
  31         61  
  31         1699  
62 31     31   242 use constant FAIL_SIGNAL => q{"%s" died to signal "%s" (%d)%s};
  31         67  
  31         1493  
63 31     31   167 use constant FAIL_BADEXIT => q{"%s" unexpectedly returned exit value %d};
  31         67  
  31         1580  
64              
65 31     31   189 use constant FAIL_UNDEF => q{%s called with undefined command};
  31         63  
  31         1675  
66              
67              
68 31     31   180 use constant FAIL_POSIX => q{IPC::System::Simple does not understand the POSIX error '%s'. Please check https://metacpan.org/pod/IPC::System::Simple to see if there is an updated version. If not please report this as a bug to https://github.com/pjf/ipc-system-simple/issues};
  31         52  
  31         1793  
69              
70             # On Perl's older than 5.8.x we can't assume that there'll be a
71             # $^{TAINT} for us to check, so we assume that our args may always
72             # be tainted.
73 31     31   184 use constant ASSUME_TAINTED => ($] < 5.008);
  31         382  
  31         1844  
74              
75 31     31   199 use constant EXIT_ANY_CONST => -1; # Used internally
  31         50  
  31         1789  
76 31     31   189 use constant EXIT_ANY => [ EXIT_ANY_CONST ]; # Exported
  31         61  
  31         3748  
77              
78 31     31   210 use constant UNDEFINED_POSIX_RE => qr{not (?:defined|a valid) POSIX macro|not implemented on this architecture};
  31         47  
  31         7601  
79              
80             require Exporter;
81             our @ISA = qw(Exporter);
82              
83             our @EXPORT_OK = qw(
84             capture capturex
85             run runx
86             system systemx
87             $EXITVAL EXIT_ANY
88             );
89              
90             our $VERSION = '1.30';
91             $VERSION =~ tr/_//d;
92              
93             our $EXITVAL = -1;
94              
95             my @Signal_from_number = split(' ', $Config{sig_name});
96              
97             # Environment variables we don't want to see tainted.
98             my @Check_tainted_env = qw(PATH IFS CDPATH ENV BASH_ENV);
99             if (WINDOWS) {
100             push(@Check_tainted_env, 'PERL5SHELL');
101             }
102             if (VMS) {
103             push(@Check_tainted_env, 'DCL$PATH');
104             }
105              
106             # Not all systems implement the WIFEXITED calls, but POSIX
107             # will always export them (even if they're just stubs that
108             # die with an error). Test for the presence of a working
109             # WIFEXITED and friends, or define our own.
110              
111             eval { WIFEXITED(0); };
112              
113             if ($@ =~ UNDEFINED_POSIX_RE) {
114 31     31   232 no warnings 'redefine'; ## no critic
  31         52  
  31         9171  
115             *WIFEXITED = sub { not $_[0] & 0xff };
116             *WEXITSTATUS = sub { $_[0] >> 8 };
117             *WIFSIGNALED = sub { $_[0] & 127 };
118             *WTERMSIG = sub { $_[0] & 127 };
119             } elsif ($@) {
120             croak sprintf FAIL_POSIX, $@;
121             }
122              
123             # None of the POSIX modules I've found define WCOREDUMP, although
124             # many systems define it. Check the POSIX module in the hope that
125             # it may actually be there.
126              
127              
128             # TODO: Ideally, $NATIVE_WCOREDUMP should be a constant.
129              
130             my $NATIVE_WCOREDUMP;
131              
132             eval { POSIX::WCOREDUMP(1); };
133              
134             if ($@ =~ UNDEFINED_POSIX_RE) {
135 360     360   3472 *WCOREDUMP = sub { $_[0] & 128 };
136             $NATIVE_WCOREDUMP = 0;
137             } elsif ($@) {
138             croak sprintf FAIL_POSIX, $@;
139             } else {
140             # POSIX actually has it defined! Huzzah!
141             *WCOREDUMP = \&POSIX::WCOREDUMP;
142             $NATIVE_WCOREDUMP = 1;
143             }
144              
145             sub _native_wcoredump {
146 0     0   0 return $NATIVE_WCOREDUMP;
147             }
148              
149             # system simply calls run
150              
151 31     31   256 no warnings 'once'; ## no critic
  31         70  
  31         1910  
152             *system = \&run;
153             *systemx = \&runx;
154 31     31   554 use warnings;
  31         59  
  31         5519  
155              
156             # run is our way of running a process with system() semantics
157              
158             sub run {
159              
160 114     114 1 158887 _check_taint(@_);
161              
162 104         587 my ($valid_returns, $command, @args) = _process_args(@_);
163              
164             # If we have arguments, we really want to call systemx,
165             # so we do so.
166              
167 98 100       336 if (@args) {
168 60         340 return systemx($valid_returns, $command, @args);
169             }
170              
171 38         86 if (WINDOWS) {
172             my $pid = _spawn_or_die(&WINDOWS_SHELL->[0], join ' ', @{&WINDOWS_SHELL}, $command);
173             $pid->Wait(INFINITE); # Wait for process exit.
174             $pid->GetExitCode($EXITVAL);
175             return _check_exit($command,$EXITVAL,$valid_returns);
176             }
177              
178             # Without arguments, we're calling system, and checking
179             # the results.
180              
181             # We're throwing our own exception on command not found, so
182             # we don't need a warning from Perl.
183              
184             {
185             # silence 'Statement unlikely to be reached' warning
186 31     31   224 no warnings 'exec'; ## no critic
  31         59  
  31         6375  
  38         82  
187 38         282233 CORE::system($command,@args);
188             }
189              
190 38         1923 return _process_child_error($?,$command,$valid_returns);
191             }
192              
193             # runx is just like system/run, but *never* invokes the shell.
194              
195             sub runx {
196 96     96 1 90907 _check_taint(@_);
197              
198 96         334 my ($valid_returns, $command, @args) = _process_args(@_);
199              
200 96         197 if (WINDOWS) {
201             our $EXITVAL = -1;
202              
203             my $pid = _spawn_or_die($command, Win32::ShellQuote::quote_native($command, @args));
204              
205             $pid->Wait(INFINITE); # Wait for process exit.
206             $pid->GetExitCode($EXITVAL);
207             return _check_exit($command,$EXITVAL,$valid_returns);
208             }
209              
210             # If system() fails, we throw our own exception. We don't
211             # need to have perl complain about it too.
212              
213 31     31   224 no warnings; ## no critic
  31         63  
  31         5291  
214              
215 96         169 CORE::system { $command } $command, @args;
  96         491669  
216              
217 96         6955 return _process_child_error($?, $command, $valid_returns);
218             }
219              
220             # capture is our way of running a process with backticks/qx semantics
221              
222             sub capture {
223 57     57 1 116662 _check_taint(@_);
224              
225 57         369 my ($valid_returns, $command, @args) = _process_args(@_);
226              
227 53 100       362 if (@args) {
228 39         258 return capturex($valid_returns, $command, @args);
229             }
230              
231 14         69 if (WINDOWS) {
232             # USE_SHELL really means "You may use the shell if you need it."
233             return _win32_capture(USE_SHELL, $valid_returns, $command);
234             }
235              
236 14         51 our $EXITVAL = -1;
237              
238 14         71 my $wantarray = wantarray();
239              
240             # We'll produce our own warnings on failure to execute.
241 31     31   233 no warnings 'exec'; ## no critic
  31         58  
  31         22935  
242              
243 14 100       83 if ($wantarray) {
244 1         5441 my @results = qx($command);
245 1         41 _process_child_error($?,$command,$valid_returns);
246 1         29 return @results;
247             }
248              
249 13         56495 my $results = qx($command);
250 13         1006 _process_child_error($?,$command,$valid_returns);
251 10         386 return $results;
252             }
253              
254             # _win32_capture implements the capture and capurex commands on Win32.
255             # We need to wrap the whole internals of this sub into
256             # an if (WINDOWS) block to avoid it being compiled on non-Win32 systems.
257              
258             sub _win32_capture {
259 0     0   0 if (not WINDOWS) {
260 0         0 croak sprintf(FAIL_INTERNAL, "_win32_capture called when not under Win32");
261             } else {
262              
263             my ($use_shell, $valid_returns, $command, @args) = @_;
264              
265             my $wantarray = wantarray();
266              
267             # Perl doesn't support multi-arg open under
268             # Windows. Perl also doesn't provide very good
269             # feedback when normal backtails fail, either;
270             # it returns exit status from the shell
271             # (which is indistinguishable from the command
272             # running and producing the same exit status).
273              
274             # As such, we essentially have to write our own
275             # backticks.
276              
277             # We start by dup'ing STDOUT.
278              
279             open(my $saved_stdout, '>&', \*STDOUT) ## no critic
280             or croak sprintf(FAIL_PLUMBING, "Can't dup STDOUT", $!);
281              
282             # We now open up a pipe that will allow us to
283             # communicate with the new process.
284              
285             pipe(my ($read_fh, $write_fh))
286             or croak sprintf(FAIL_PLUMBING, "Can't create pipe", $!);
287              
288             # Allow CRLF sequences to become "\n", since
289             # this is what Perl backticks do.
290              
291             binmode($read_fh, ':crlf');
292              
293             # Now we re-open our STDOUT to $write_fh...
294              
295             open(STDOUT, '>&', $write_fh) ## no critic
296             or croak sprintf(FAIL_PLUMBING, "Can't redirect STDOUT", $!);
297              
298             # If we have args, or we're told not to use the shell, then
299             # we treat $command as our shell. Otherwise we grub around
300             # in our command to look for a command to run.
301             #
302             # Note that we don't actually *use* the shell (although in
303             # a future version we might). Being told not to use the shell
304             # (capturex) means we treat our command as really being a command,
305             # and not a command line.
306              
307             my $exe = @args ? $command :
308             (! $use_shell) ? $command :
309             $command =~ m{^"([^"]+)"}x ? $1 :
310             $command =~ m{(\S+) }x ? $1 :
311             croak sprintf(FAIL_CMD_BLANK, $command);
312              
313             # And now we spawn our new process with inherited
314             # filehandles.
315              
316             my $err;
317             my $pid = eval {
318             _spawn_or_die($exe, @args ? Win32::ShellQuote::quote_native($command, @args) : $command);
319             }
320             or do {
321             $err = $@;
322             };
323              
324             # Regardless of whether our command ran, we must restore STDOUT.
325             # RT #48319
326             open(STDOUT, '>&', $saved_stdout) ## no critic
327             or croak sprintf(FAIL_PLUMBING,"Can't restore STDOUT", $!);
328              
329             # And now, if there was an actual error , propagate it.
330             die $err if defined $err; # If there's an error from _spawn_or_die
331              
332             # Clean-up the filehandles we no longer need...
333              
334             close($write_fh)
335             or croak sprintf(FAIL_PLUMBING,q{Can't close write end of pipe}, $!);
336             close($saved_stdout)
337             or croak sprintf(FAIL_PLUMBING,q{Can't close saved STDOUT}, $!);
338              
339             # Read the data from our child...
340              
341             my (@results, $result);
342              
343             if ($wantarray) {
344             @results = <$read_fh>;
345             } else {
346             $result = join("",<$read_fh>);
347             }
348              
349             # Tidy up our windows process and we're done!
350              
351             $pid->Wait(INFINITE); # Wait for process exit.
352             $pid->GetExitCode($EXITVAL);
353              
354             _check_exit($command,$EXITVAL,$valid_returns);
355              
356             return $wantarray ? @results : $result;
357              
358             }
359             }
360              
361             # capturex() is just like backticks/qx, but never invokes the shell.
362              
363             sub capturex {
364 56     56 1 30299 _check_taint(@_);
365              
366 56         248 my ($valid_returns, $command, @args) = _process_args(@_);
367              
368 56         248 our $EXITVAL = -1;
369              
370 56         332 my $wantarray = wantarray();
371              
372 56         182 if (WINDOWS) {
373             return _win32_capture(NO_SHELL, $valid_returns, $command, @args);
374             }
375              
376             # We can't use a multi-arg piped open here, since 5.6.x
377             # doesn't like them. Instead we emulate what 5.8.x does,
378             # which is to create a pipe(), set the close-on-exec flag
379             # on the child, and the fork/exec. If the exec fails, the
380             # child writes to the pipe. If the exec succeeds, then
381             # the pipe closes without data.
382              
383 56 50       3274 pipe(my ($read_fh, $write_fh))
384             or croak sprintf(FAIL_PLUMBING, "Can't create pipe", $!);
385              
386             # This next line also does an implicit fork.
387 56         44578 my $pid = open(my $pipe, '-|'); ## no critic
388              
389 56 50       4817 if (not defined $pid) {
    100          
390 0         0 croak sprintf(FAIL_START, $command, $!);
391             } elsif (not $pid) {
392             # Child process, execs command.
393              
394 15         1254 close($read_fh);
395              
396             # TODO: 'no warnings exec' doesn't get rid
397             # of the 'unlikely to be reached' warnings.
398             # This is a bug in perl / perldiag / perllexwarn / warnings.
399              
400 31     31   249 no warnings; ## no critic
  31         62  
  31         33327  
401              
402 15         269 CORE::exec { $command } $command, @args;
  15         0  
403              
404             # Oh no, exec fails! Send the reason why to
405             # the parent.
406              
407 0         0 print {$write_fh} int($!);
  0         0  
408 0         0 exit(-1);
409             }
410              
411             {
412             # In parent process.
413              
414 41         1215 close($write_fh);
  41         749  
415              
416             # Parent process, check for child error.
417 41         10832997 my $error = <$read_fh>;
418              
419             # Tidy up our pipes.
420 41         1615 close($read_fh);
421              
422             # Check for error.
423 41 100       692 if ($error) {
424             # Setting $! to our child error number gives
425             # us nice looking strings when printed.
426 5         221 local $! = $error;
427 5         18294 croak sprintf(FAIL_START, $command, $!);
428             }
429             }
430              
431             # Parent process, we don't care about our pid, but we
432             # do go and read our pipe.
433              
434 36 100       312 if ($wantarray) {
435 7         22059 my @results = <$pipe>;
436 7         382 close($pipe);
437 7         225 _process_child_error($?,$command,$valid_returns);
438 7         534 return @results;
439             }
440              
441             # NB: We don't check the return status on close(), since
442             # on failure it sets $?, which we then inspect for more
443             # useful information.
444              
445 29         77935 my $results = join("",<$pipe>);
446 29         1721 close($pipe);
447 29         967 _process_child_error($?,$command,$valid_returns);
448            
449 29         2083 return $results;
450              
451             }
452              
453             # Tries really hard to spawn a process under Windows. Returns
454             # the pid on success, or undef on error.
455              
456             sub _spawn_or_die {
457              
458             # We need to wrap practically the entire sub in an
459             # if block to ensure it doesn't get compiled under non-Win32
460             # systems. Compiling on these systems would not only be a
461             # waste of time, but also results in complaints about
462             # the NORMAL_PRIORITY_CLASS constant.
463              
464 1     1   808 if (not WINDOWS) {
465 1         88 croak sprintf(FAIL_INTERNAL, "_spawn_or_die called when not under Win32");
466             } else {
467             my ($orig_exe, $cmdline) = @_;
468             my $pid;
469              
470             my $exe = $orig_exe;
471              
472             # If our command doesn't have an extension, add one.
473             $exe .= $Config{_exe} if ($exe !~ m{\.});
474              
475             Win32::Process::Create(
476             $pid, $exe, $cmdline, 1, NORMAL_PRIORITY_CLASS, "."
477             ) and return $pid;
478              
479             my @path = split(/;/,$ENV{PATH});
480              
481             foreach my $dir (@path) {
482             my $fullpath = File::Spec->catfile($dir,$exe);
483              
484             # We're using -x here on the assumption that stat()
485             # is faster than spawn, so trying to spawn a process
486             # for each path element will be unacceptably
487             # inefficient.
488              
489             if (-x $fullpath) {
490             Win32::Process::Create(
491             $pid, $fullpath, $cmdline, 1,
492             NORMAL_PRIORITY_CLASS, "."
493             ) and return $pid;
494             }
495             }
496              
497             croak sprintf(FAIL_START, $orig_exe, $^E);
498             }
499             }
500              
501             # Complain on tainted arguments or environment.
502             # ASSUME_TAINTED is true for 5.6.x, since it's missing ${^TAINT}
503              
504             sub _check_taint {
505 323 100   323   3135 return if not (ASSUME_TAINTED or ${^TAINT});
506 23         206 my $caller = (caller(1))[3];
507 23         103 foreach my $var (@_) {
508 50 100       240 if (tainted $var) {
509 5         681 croak sprintf(FAIL_TAINT, $caller, $var);
510             }
511             }
512 18         68 foreach my $var (@Check_tainted_env) {
513 70 100       430 if (tainted $ENV{$var} ) {
514 5         758 croak sprintf(FAIL_TAINT_ENV, $caller, $var);
515             }
516             }
517              
518 13         27 return;
519              
520             }
521              
522             # This subroutine performs the difficult task of interpreting
523             # $?. It's not intended to be called directly, as it will
524             # croak on errors, and its implementation and interface may
525             # change in the future.
526              
527             sub _process_child_error {
528 184     184   4536 my ($child_error, $command, $valid_returns) = @_;
529            
530 184         1439 $EXITVAL = -1;
531              
532 184         3823 my $coredump = WCOREDUMP($child_error);
533              
534             # There's a bug in perl 5.8.9 and 5.10.0 where if the system
535             # does not provide a native WCOREDUMP, then $? will
536             # never contain coredump information. This code
537             # checks to see if we have the bug, and works around
538             # it if needed.
539              
540 184 50 33     4201 if ($] >= 5.008009 and not $NATIVE_WCOREDUMP) {
541 184   66     2470 $coredump ||= WCOREDUMP( ${^CHILD_ERROR_NATIVE} );
542             }
543              
544 184 100       2304 if ($child_error == -1) {
    100          
    50          
545 8         4820 croak sprintf(FAIL_START, $command, $!);
546              
547             } elsif ( WIFEXITED( $child_error ) ) {
548 175         933 $EXITVAL = WEXITSTATUS( $child_error );
549              
550 175         1570 return _check_exit($command,$EXITVAL,$valid_returns);
551              
552             } elsif ( WIFSIGNALED( $child_error ) ) {
553 1         22 my $signal_no = WTERMSIG( $child_error );
554 1   50     23 my $signal_name = $Signal_from_number[$signal_no] || "UNKNOWN";
555              
556 1 50       609 croak sprintf FAIL_SIGNAL, $command, $signal_name, $signal_no, ($coredump ? " and dumped core" : "");
557              
558              
559             }
560              
561 0         0 croak sprintf(FAIL_INTERNAL, qq{'$command' ran without exit value or signal});
562              
563             }
564              
565             # A simple subroutine for checking exit values. Results in better
566             # assurance of consistent error messages, and better forward support
567             # for new features in I::S::S.
568              
569             sub _check_exit {
570 177     177   768 my ($command, $exitval, $valid_returns) = @_;
571              
572             # If we have a single-value list consisting of the EXIT_ANY
573             # value, then we're happy with whatever exit value we're given.
574 177 100 100     2164 if (@$valid_returns == 1 and $valid_returns->[0] == EXIT_ANY_CONST) {
575 2         65 return $exitval;
576             }
577              
578 175 100   181   6595 if (not defined first { $_ == $exitval } @$valid_returns) {
  181         1731  
579 45         19514 croak sprintf FAIL_BADEXIT, $command, $exitval;
580             }
581 130         4432 return $exitval;
582             }
583              
584              
585             # This subroutine simply determines a list of valid returns, the command
586             # name, and any arguments that we need to pass to it.
587              
588             sub _process_args {
589 313     313   1138 my $valid_returns = [ 0 ];
590 313         3988 my $caller = (caller(1))[3];
591              
592 313 100       1400 if (not @_) {
593 5         495 croak "$caller called with no arguments";
594             }
595              
596 308 100       1377 if (ref $_[0] eq "ARRAY") {
597 116         315 $valid_returns = shift(@_);
598             }
599              
600 308 100       1242 if (not @_) {
601 5         536 croak "$caller called with no command";
602             }
603              
604 303         767 my $command = shift(@_);
605              
606 303 50       684 if (not defined $command) {
607 0         0 croak sprintf( FAIL_UNDEF, $caller );
608             }
609              
610 303         1525 return ($valid_returns,$command,@_);
611              
612             }
613              
614             1;
615              
616             __END__