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