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