File Coverage

inc/IPC/Run3.pm
Criterion Covered Total %
statement 106 164 64.6
branch 38 110 34.5
condition 20 67 29.8
subroutine 15 18 83.3
pod 1 1 100.0
total 180 360 50.0


line stmt bran cond sub pod time code
1             package IPC::Run3;
2              
3             =head1 NAME
4              
5             IPC::Run3 - run a subprocess in batch mode (a la system) on Unix, Win32, etc.
6              
7             =head1 VERSION
8              
9             version 0.034
10              
11             =cut
12              
13             $VERSION = '0.034';
14              
15             =head1 SYNOPSIS
16              
17             use IPC::Run3; # Exports run3() by default
18              
19             run3 \@cmd, \$in, \$out, \$err;
20             run3 \@cmd, \@in, \&out, \$err;
21              
22             =head1 DESCRIPTION
23              
24             This module allows you to run a subprocess and redirect stdin, stdout,
25             and/or stderr to files and perl data structures. It aims to satisfy 99% of the
26             need for using C, C, and C with a simple, extremely Perlish
27             API and none of the bloat and rarely used features of IPC::Run.
28              
29             Speed, simplicity, and portability are paramount. (That's speed of Perl code;
30             which is often much slower than the kind of buffered I/O that this module uses
31             to spool input to and output from the child command.) Disk space is not.
32              
33             =head2 C<< run3(\@cmd, INPUT, OUTPUT, \$err) >>
34              
35             Note that passing in a reference to C explicitly redirects the
36             associated file descriptor for C, C, or C from or to the
37             local equivalent of C (this does I pass a closed filehandle).
38             Passing in C (or not passing a redirection) allows the child to inherit
39             the corresponding C, C, or C from the parent.
40              
41             Because the redirects come last, this allows C and C to default
42             to the parent's by just not specifying them -- a common use case.
43              
44             B: This means that:
45              
46             run3 \@cmd, undef, \$out; # Pass on parent's STDIN
47              
48             B, it passes on the parent's. Use
49              
50             run3 \@cmd, \undef, \$out; # Close child's STDIN
51              
52             for that. It's not ideal, but it does work.
53              
54             If the exact same value is passed for C<$stdout> and C<$stderr>, then the child
55             will write both to the same filehandle. In general, this means that
56              
57             run3 \@cmd, \undef, "foo.txt", "foo.txt";
58             run3 \@cmd, \undef, \$both, \$both;
59              
60             will DWYM and pass a single file handle to the child for both C and
61             C, collecting all into C<$both>.
62              
63             =head1 DEBUGGING
64              
65             To enable debugging use the IPCRUN3DEBUG environment variable to
66             a non-zero integer value:
67              
68             $ IPCRUN3DEBUG=1 myapp
69              
70             =head1 PROFILING
71              
72             To enable profiling, set IPCRUN3PROFILE to a number to enable emitting profile
73             information to STDERR (1 to get timestamps, 2 to get a summary report at the
74             END of the program, 3 to get mini reports after each run) or to a filename to
75             emit raw data to a file for later analysis.
76              
77             =head1 COMPARISON
78              
79             Here's how it stacks up to existing APIs:
80              
81             =over
82              
83             =item compared to C, C, C, C:
84              
85             =over
86              
87             =item + redirects more than one file descriptor
88              
89             =item + returns TRUE on success, FALSE on failure
90              
91             =item + throws an error if problems occur in the parent process (or the pre-exec child)
92              
93             =item + allows a very perlish interface to Perl data structures and subroutines
94              
95             =item + allows 1 word invocations to avoid the shell easily:
96              
97             run3 ["foo"]; # does not invoke shell
98              
99             =item - does not return the exit code, leaves it in $?
100              
101             =back
102              
103             =item compared to C, C:
104              
105             =over
106              
107             =item + No lengthy, error prone polling / select loop needed
108              
109             =item + Hides OS dependancies
110              
111             =item + Allows SCALAR, ARRAY, and CODE references to source and sink I/O
112              
113             =item + I/O parameter order is like open3() (not like open2()).
114              
115             =item - Does not allow interaction with the subprocess
116              
117             =back
118              
119             =item compared to C:
120              
121             =over
122              
123             =item + Smaller, lower overhead, simpler, more portable
124              
125             =item + No select() loop portability issues
126              
127             =item + Does not fall prey to Perl closure leaks
128              
129             =item - Does not allow interaction with the subprocess (which
130             IPC::Run::run() allows by redirecting subroutines).
131              
132             =item - Lacks many features of IPC::Run::run() (filters, pipes,
133             redirects, pty support).
134              
135             =back
136              
137             =back
138              
139             =cut
140              
141             @EXPORT = qw( run3 );
142             %EXPORT_TAGS = ( all => \@EXPORT );
143             @ISA = qw( Exporter );
144 2     2   130441 use Exporter;
  2         4  
  2         67  
145              
146 2     2   6 use strict;
  2         3  
  2         75  
147 2   50 2   7 use constant debugging => $ENV{IPCRUN3DEBUG} || $ENV{IPCRUNDEBUG} || 0;
  2         1  
  2         160  
148 2   50 2   12 use constant profiling => $ENV{IPCRUN3PROFILE} || $ENV{IPCRUNPROFILE} || 0;
  2         3  
  2         103  
149 2     2   7 use constant is_win32 => 0 <= index $^O, "Win32";
  2         2  
  2         101  
150              
151             BEGIN {
152 2     2   29 if ( is_win32 ) {
153             eval "use Win32 qw( GetOSName ); 1" or die $@;
154             }
155             }
156              
157             #use constant is_win2k => is_win32 && GetOSName() =~ /Win2000/i;
158             #use constant is_winXP => is_win32 && GetOSName() =~ /WinXP/i;
159              
160 2     2   7 use Carp qw( croak );
  2         5  
  2         78  
161 2     2   1343 use File::Temp qw( tempfile );
  2         28764  
  2         112  
162 2     2   862 use POSIX qw( dup dup2 );
  2         8569  
  2         12  
163              
164             # We cache the handles of our temp files in order to
165             # keep from having to incur the (largish) overhead of File::Temp
166             my %fh_cache;
167             my $fh_cache_pid = $$;
168              
169             my $profiler;
170              
171 0     0   0 sub _profiler { $profiler } # test suite access
172              
173             BEGIN {
174 2     2   5143 if ( profiling ) {
175             eval "use Time::HiRes qw( gettimeofday ); 1" or die $@;
176             if ( $ENV{IPCRUN3PROFILE} =~ /\A\d+\z/ ) {
177             require IPC::Run3::ProfPP;
178             IPC::Run3::ProfPP->import;
179             $profiler = IPC::Run3::ProfPP->new(Level => $ENV{IPCRUN3PROFILE});
180             } else {
181             my ( $dest, undef, $class ) =
182             reverse split /(=)/, $ENV{IPCRUN3PROFILE}, 2;
183             $class = "IPC::Run3::ProfLogger"
184             unless defined $class && length $class;
185             if ( not eval "require $class" ) {
186             my $e = $@;
187             $class = "IPC::Run3::$class";
188             eval "require IPC::Run3::$class" or die $e;
189             }
190             $profiler = $class->new( Destination => $dest );
191             }
192             $profiler->app_call( [ $0, @ARGV ], scalar gettimeofday() );
193             }
194             }
195              
196              
197             END {
198 2     2   54821 $profiler->app_exit( scalar gettimeofday() ) if profiling;
199             }
200              
201             sub _spool_data_to_child {
202 8     8   28 my ( $type, $source, $binmode_it ) = @_;
203              
204             # If undef (not \undef) passed, they want the child to inherit
205             # the parent's STDIN.
206 8 50       19 return undef unless defined $source;
207 8         11 warn "binmode()ing STDIN\n" if is_win32 && debugging && $binmode_it;
208              
209 8         11 my $fh;
210 8 100       31 if ( ! $type ) {
    50          
211 3         9 local *FH; # Do this the backcompat way
212 3 50       125 open FH, "<$source" or croak "$!: $source";
213 3         11 $fh = *FH{IO};
214 3         3 if ( is_win32 ) {
215             binmode $fh, ":raw"; # Remove all layers
216             binmode $fh, ":crlf" unless $binmode_it;
217             }
218 3         5 warn "run3(): feeding file '$source' to child STDIN\n"
219             if debugging >= 2;
220             } elsif ( $type eq "FH" ) {
221 0         0 $fh = $source;
222 0         0 warn "run3(): feeding filehandle '$source' to child STDIN\n"
223             if debugging >= 2;
224             } else {
225 5   66     22 $fh = $fh_cache{in} ||= tempfile;
226 5         162155 truncate $fh, 0;
227 5         21 seek $fh, 0, 0;
228 5         6 if ( is_win32 ) {
229             binmode $fh, ":raw"; # Remove any previous layers
230             binmode $fh, ":crlf" unless $binmode_it;
231             }
232 5         20 my $seekit;
233 5 50       28 if ( $type eq "SCALAR" ) {
    0          
    0          
234              
235             # When the run3()'s caller asks to feed an empty file
236             # to the child's stdin, we want to pass a live file
237             # descriptor to an empty file (like /dev/null) so that
238             # they don't get surprised by invalid fd errors and get
239             # normal EOF behaviors.
240 5 50       35 return $fh unless defined $$source; # \undef passed
241              
242 0         0 warn "run3(): feeding SCALAR to child STDIN",
243             debugging >= 3
244             ? ( ": '", $$source, "' (", length $$source, " chars)" )
245             : (),
246             "\n"
247             if debugging >= 2;
248              
249 0         0 $seekit = length $$source;
250 0 0       0 print $fh $$source or die "$! writing to temp file";
251              
252             } elsif ( $type eq "ARRAY" ) {
253 0         0 warn "run3(): feeding ARRAY to child STDIN",
254             debugging >= 3 ? ( ": '", @$source, "'" ) : (),
255             "\n"
256             if debugging >= 2;
257              
258 0 0       0 print $fh @$source or die "$! writing to temp file";
259 0         0 $seekit = grep length, @$source;
260             } elsif ( $type eq "CODE" ) {
261 0         0 warn "run3(): feeding output of CODE ref '$source' to child STDIN\n"
262             if debugging >= 2;
263 0         0 my $parms = []; # TODO: get these from $options
264 0         0 while (1) {
265 0         0 my $data = $source->( @$parms );
266 0 0       0 last unless defined $data;
267 0 0       0 print $fh $data or die "$! writing to temp file";
268 0         0 $seekit = length $data;
269             }
270             }
271              
272 0 0 0     0 seek $fh, 0, 0 or croak "$! seeking on temp file for child's stdin"
273             if $seekit;
274             }
275              
276 3 50       10 croak "run3() can't redirect $type to child stdin"
277             unless defined $fh;
278              
279 3         7 return $fh;
280             }
281              
282             sub _fh_for_child_output {
283 8     8   36 my ( $what, $type, $dest, $binmode_it ) = @_;
284              
285 8         17 my $fh;
286 8 50 33     61 if ( $type eq "SCALAR" && $dest == \undef ) {
    50          
    50          
287 0         0 warn "run3(): redirecting child $what to oblivion\n"
288             if debugging >= 2;
289              
290 0   0     0 $fh = $fh_cache{nul} ||= do {
291 0         0 local *FH;
292 0         0 open FH, ">" . File::Spec->devnull;
293 0         0 *FH{IO};
294             };
295             } elsif ( $type eq "FH" ) {
296 0         0 $fh = $dest;
297 0         0 warn "run3(): redirecting $what to filehandle '$dest'\n"
298             if debugging >= 3;
299             } elsif ( !$type ) {
300 8         9 warn "run3(): feeding child $what to file '$dest'\n"
301             if debugging >= 2;
302              
303 8         21 local *FH;
304 8 50       754 open FH, ">$dest" or croak "$!: $dest";
305 8         37 $fh = *FH{IO};
306             } else {
307 0         0 warn "run3(): capturing child $what\n"
308             if debugging >= 2;
309              
310 0   0     0 $fh = $fh_cache{$what} ||= tempfile;
311 0         0 seek $fh, 0, 0;
312 0         0 truncate $fh, 0;
313             }
314              
315 8         10 if ( is_win32 ) {
316             warn "binmode()ing $what\n" if debugging && $binmode_it;
317             binmode $fh, ":raw";
318             binmode $fh, ":crlf" unless $binmode_it;
319             }
320 8         23 return $fh;
321             }
322              
323             sub _read_child_output_fh {
324 0     0   0 my ( $what, $type, $dest, $fh, $options ) = @_;
325              
326 0 0 0     0 return if $type eq "SCALAR" && $dest == \undef;
327              
328 0 0       0 seek $fh, 0, 0 or croak "$! seeking on temp file for child $what";
329              
330 0 0       0 if ( $type eq "SCALAR" ) {
    0          
    0          
331 0         0 warn "run3(): reading child $what to SCALAR\n"
332             if debugging >= 3;
333              
334             # two read()s are used instead of 1 so that the first will be
335             # logged even it reads 0 bytes; the second won't.
336 0         0 my $count = read $fh, $$dest, 10_000;
337 0         0 while (1) {
338 0 0       0 croak "$! reading child $what from temp file"
339             unless defined $count;
340              
341 0 0       0 last unless $count;
342              
343 0         0 warn "run3(): read $count bytes from child $what",
344             debugging >= 3 ? ( ": '", substr( $$dest, -$count ), "'" ) : (),
345             "\n"
346             if debugging >= 2;
347              
348 0         0 $count = read $fh, $$dest, 10_000, length $$dest;
349             }
350             } elsif ( $type eq "ARRAY" ) {
351 0         0 @$dest = <$fh>;
352 0         0 if ( debugging >= 2 ) {
353             my $count = 0;
354             $count += length for @$dest;
355             warn
356             "run3(): read ",
357             scalar @$dest,
358             " records, $count bytes from child $what",
359             debugging >= 3 ? ( ": '", @$dest, "'" ) : (),
360             "\n";
361             }
362             } elsif ( $type eq "CODE" ) {
363 0         0 warn "run3(): capturing child $what to CODE ref\n"
364             if debugging >= 3;
365              
366 0         0 local $_;
367 0         0 while ( <$fh> ) {
368 0         0 warn
369             "run3(): read ",
370             length,
371             " bytes from child $what",
372             debugging >= 3 ? ( ": '", $_, "'" ) : (),
373             "\n"
374             if debugging >= 2;
375              
376 0         0 $dest->( $_ );
377             }
378             } else {
379 0         0 croak "run3() can't redirect child $what to a $type";
380             }
381              
382             }
383              
384             sub _type {
385 24     24   36 my ( $redir ) = @_;
386 24 50       26 return "FH" if eval { $redir->isa("IO::Handle") };
  24         258  
387 24         36 my $type = ref $redir;
388 24 50       71 return $type eq "GLOB" ? "FH" : $type;
389             }
390              
391             sub _max_fd {
392 0     0   0 my $fd = dup(0);
393 0         0 POSIX::close $fd;
394 0         0 return $fd;
395             }
396              
397             my $run_call_time;
398             my $sys_call_time;
399             my $sys_exit_time;
400              
401             sub run3 {
402 8     8 1 104307 $run_call_time = gettimeofday() if profiling;
403              
404 8 50 33     123 my $options = @_ && ref $_[-1] eq "HASH" ? pop : {};
405              
406 8         24 my ( $cmd, $stdin, $stdout, $stderr ) = @_;
407              
408 8         17 print STDERR "run3(): running ",
409             join( " ", map "'$_'", ref $cmd ? @$cmd : $cmd ),
410             "\n"
411             if debugging;
412              
413 8 50       26 if ( ref $cmd ) {
414 8 50       23 croak "run3(): empty command" unless @$cmd;
415 8 50       26 croak "run3(): undefined command" unless defined $cmd->[0];
416 8 50       28 croak "run3(): command name ('')" unless length $cmd->[0];
417             } else {
418 0 0       0 croak "run3(): missing command" unless @_;
419 0 0       0 croak "run3(): undefined command" unless defined $cmd;
420 0 0       0 croak "run3(): command ('')" unless length $cmd;
421             }
422              
423 8         48 my $in_type = _type $stdin;
424 8         19 my $out_type = _type $stdout;
425 8         17 my $err_type = _type $stderr;
426              
427 8 50       66 if ($fh_cache_pid != $$) {
428             # fork detected, close all cached filehandles and clear the cache
429 0         0 close $_ foreach values %fh_cache;
430 0         0 %fh_cache = ();
431 0         0 $fh_cache_pid = $$;
432             }
433            
434             # This routine procedes in stages so that a failure in an early
435             # stage prevents later stages from running, and thus from needing
436             # cleanup.
437              
438             my $in_fh = _spool_data_to_child $in_type, $stdin,
439 8 50       71 $options->{binmode_stdin} if defined $stdin;
440              
441             my $out_fh = _fh_for_child_output "stdout", $out_type, $stdout,
442 8 50       77 $options->{binmode_stdout} if defined $stdout;
443              
444 8   33     90 my $tie_err_to_out =
445             defined $stderr && defined $stdout && $stderr eq $stdout;
446              
447             my $err_fh = $tie_err_to_out
448             ? $out_fh
449             : _fh_for_child_output "stderr", $err_type, $stderr,
450 8 50       35 $options->{binmode_stderr} if defined $stderr;
    50          
451              
452             # this should make perl close these on exceptions
453 8         19 local *STDIN_SAVE;
454 8         16 local *STDOUT_SAVE;
455 8         12 local *STDERR_SAVE;
456              
457 8 50       63 my $saved_fd0 = dup( 0 ) if defined $in_fh;
458              
459             # open STDIN_SAVE, "<&STDIN"# or croak "run3(): $! saving STDIN"
460             # if defined $in_fh;
461 8 50 33     91 open STDOUT_SAVE, ">&STDOUT" or croak "run3(): $! saving STDOUT"
462             if defined $out_fh;
463 8 50 33     67 open STDERR_SAVE, ">&STDERR" or croak "run3(): $! saving STDERR"
464             if defined $err_fh;
465              
466 8         12 my $ok = eval {
467             # The open() call here seems to not force fd 0 in some cases;
468             # I ran in to trouble when using this in VCP, not sure why.
469             # the dup2() seems to work.
470 8 50 33     161 dup2( fileno $in_fh, 0 )
471             # open STDIN, "<&=" . fileno $in_fh
472             or croak "run3(): $! redirecting STDIN"
473             if defined $in_fh;
474              
475             # close $in_fh or croak "$! closing STDIN temp file"
476             # if ref $stdin;
477              
478 8 50 33     164 open STDOUT, ">&" . fileno $out_fh
479             or croak "run3(): $! redirecting STDOUT"
480             if defined $out_fh;
481              
482 8 50 33     112 open STDERR, ">&" . fileno $err_fh
483             or croak "run3(): $! redirecting STDERR"
484             if defined $err_fh;
485              
486 8         11 $sys_call_time = gettimeofday() if profiling;
487              
488             my $r = ref $cmd
489 8         11481693 ? system { $cmd->[0] }
490             is_win32
491             ? map {
492             # Probably need to offer a win32 escaping
493             # option, every command may be different.
494 8 50       23 ( my $s = $_ ) =~ s/"/"""/g;
495             $s = qq{"$s"};
496             $s;
497             } @$cmd
498             : @$cmd
499             : system $cmd;
500              
501 8         105 $sys_exit_time = gettimeofday() if profiling;
502              
503 8 50 33     113 unless ( defined $r && $r != -1 ) {
504 0         0 if ( debugging ) {
505             my $err_fh = defined $err_fh ? \*STDERR_SAVE : \*STDERR;
506             print $err_fh "run3(): system() error $!\n"
507             }
508 0         0 die $!;
509             }
510              
511 8         26 if ( debugging ) {
512             my $err_fh = defined $err_fh ? \*STDERR_SAVE : \*STDERR;
513             print $err_fh "run3(): \$? is $?\n"
514             }
515 8         109 1;
516             };
517 8         33 my $x = $@;
518              
519 8         9 my @errs;
520              
521 8 50       36 if ( defined $saved_fd0 ) {
522 8         81 dup2( $saved_fd0, 0 );
523 8         46 POSIX::close( $saved_fd0 );
524             }
525              
526             # open STDIN, "<&STDIN_SAVE"# or push @errs, "run3(): $! restoring STDIN"
527             # if defined $in_fh;
528 8 50 33     255 open STDOUT, ">&STDOUT_SAVE" or push @errs, "run3(): $! restoring STDOUT"
529             if defined $out_fh;
530 8 50 33     81 open STDERR, ">&STDERR_SAVE" or push @errs, "run3(): $! restoring STDERR"
531             if defined $err_fh;
532              
533 8 50       26 croak join ", ", @errs if @errs;
534              
535 8 50       18 die $x unless $ok;
536              
537 8 50 33     55 _read_child_output_fh "stdout", $out_type, $stdout, $out_fh, $options
      33        
538             if defined $out_fh && $out_type && $out_type ne "FH";
539 8 0 33     38 _read_child_output_fh "stderr", $err_type, $stderr, $err_fh, $options
      33        
      33        
540             if defined $err_fh && $err_type && $err_type ne "FH" && !$tie_err_to_out;
541 8         11 $profiler->run_exit(
542             $cmd,
543             $run_call_time,
544             $sys_call_time,
545             $sys_exit_time,
546             scalar gettimeofday()
547             ) if profiling;
548              
549 8         289 return 1;
550             }
551              
552             =head1 TODO
553              
554             pty support
555              
556             =head1 LIMITATIONS
557              
558             Often uses intermediate files (determined by File::Temp, and thus by the
559             File::Spec defaults and the TMPDIR env. variable) for speed, portability and
560             simplicity.
561              
562             Use extrem caution when using C in a threaded environment if
563             concurrent calls of C are possible. Most likely, I/O from different
564             invocations will get mixed up. The reason is that in most thread
565             implementations all threads in a process share the same STDIN/STDOUT/STDERR.
566             Known failures are Perl ithreads on Linux and Win32. Note that C
567             on Win32 is emulated via Win32 threads and hence I/O mix up is possible
568             between forked children here (C is "fork safe" on Unix, though).
569              
570             =head1 COPYRIGHT
571              
572             Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
573              
574             =head1 LICENSE
575              
576             You may use this module under the terms of the BSD, Artistic, or GPL licenses,
577             any version.
578              
579             =head1 AUTHOR
580              
581             Barrie Slaymaker ECE
582              
583             Ricardo SIGNES ECE performed some routine maintenance in
584             2005, thanks to help from the following ticket and/or patch submitters: Jody
585             Belka, Roderich Schupp, David Morel, and anonymous others.
586              
587             =cut
588              
589             1;