regressions/inc/IPC/Run3.pm

   1 package IPC::Run3;
   2
   3 $VERSION = 0.010;
   4
   5 =head1 NAME
   6
   7 IPC::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
  19 This module allows you to run a subprocess and redirect stdin, stdout,
  20 and/or stderr to files and perl data structures.  It aims to satisfy 99%
  21 of the need for using system()/qx``/open3() with a simple, extremely
  22 Perlish API and none of the bloat and rarely used features of IPC::Run.
  23
  24 Speed (of Perl code; which is often much slower than the kind of
  25 buffered I/O that this module uses to spool input to and output from the
  26 child command), simplicity, and portability are paramount.  Disk space
  27 is not.
  28
  29 Note that passing in \undef explicitly redirects the associated file
  30 descriptor for STDIN, STDOUT, or STDERR from or to the local equivalent
  31 of /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
  33 corresponding STDIN, STDOUT, or STDERR from the parent.
  34
  35 Because the redirects come last, this allows STDOUT and STDERR to
  36 default to the parent's by just not specifying them; a common use
  37 case.
  38
  39 B<Note>: This means that:
  40
  41     run3 \@cmd, undef, \$out;   ## Pass on parent's STDIN
  42
  43 B<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
  47 for that.  It's not ideal, but it does work.
  48
  49 If the exact same value is passed for $stdout and $stderr, then
  50 the child will write both to the same filehandle.  In general, this
  51 means that
  52
  53     run3 \@cmd, \undef, "foo.txt", "foo.txt";
  54     run3 \@cmd, \undef, \$both, \$both;
  55
  56 will DWYM and pass a single file handle to the child for both
  57 STDOUT and STDERR, collecting all into $both.
  58
  59 =head1 DEBUGGING
  60
  61 To enable debugging use the IPCRUN3DEBUG environment variable to
  62 a non-zero integer value:
  63
  64     $ IPCRUN3DEBUG=1 myapp
  65
  66 .
  67
  68 =head1 PROFILING
  69
  70 To enable profiling, set IPCRUN3PROFILE to a number to enable
  71 emitting profile information to STDERR (1 to get timestamps,
  72 2 to get a summary report at the END of the program,
  73 3 to get mini reports after each run) or to a filename to
  74 emit raw data to a file for later analysis.
  75
  76 =head1 COMPARISON
  77
  78 Here'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
  91 pre-exec child)
  92
  93 =item + allows a very perlish interface to perl data structures and
  94 subroutines
  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
 131 IPC::Run::run() allows by redirecting subroutines).
 132
 133 =item - Lacks many features of IPC::Run::run() (filters, pipes,
 134 redirects, 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 );
 145 use Exporter;
 146
 147 use strict;
 148 use constant debugging => $ENV{IPCRUN3DEBUG} || $ENV{IPCRUNDEBUG} || 0;
 149 use constant profiling => $ENV{IPCRUN3PROFILE} || $ENV{IPCRUNPROFILE} || 0;
 150 use constant is_win32  => 0 <= index $^O, "Win32";
 151
 152 BEGIN {
 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
 161 use Carp qw( croak );
 162 use File::Temp qw( tempfile );
 163 use UNIVERSAL qw( isa );
 164 use 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
 168 my %fh_cache;
 169
 170 my $profiler;
 171
 172 sub _profiler { $profiler } ## test suite access
 173
 174 BEGIN {
 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
 202 END {
 203     $profiler->app_exit( scalar gettimeofday() ) if profiling;
 204 }
 205
 206
 207 sub _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
 293 sub _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
 333 sub _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
 399 sub _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
 407 sub _max_fd {
 408     my $fd = dup(0);
 409     POSIX::close $fd;
 410     return $fd;
 411 }
 412
 413 my $run_call_time;
 414 my $sys_call_time;
 415 my $sys_exit_time;
 416
 417 sub 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
 562 my $in_fh;
 563 my $in_fd;
 564 my $out_fh;
 565 my $out_fd;
 566 my $err_fh;
 567 my $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
 580 sub _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
 643 pty support
 644
 645 =head1 LIMITATIONS
 646
 647 Often uses intermediate files (determined by File::Temp, and thus by the
 648 File::Spec defaults and the TMPDIR env. variable) for speed, portability and
 649 simplicity.
 650
 651 =head1 COPYRIGHT
 652
 653     Copyright 2003, R. Barrie Slaymaker, Jr., All Rights Reserved
 654
 655 =head1 LICENSE
 656
 657 You may use this module under the terms of the BSD, Artistic, or GPL licenses,
 658 any version.
 659
 660 =head1 AUTHOR
 661
 662 Barrie Slaymaker <barries@slaysys.com>
 663
 664 =cut
 665
 666 1;