IPC-Run-0.96/0000755000000000000000000000000013105336354011326 5ustar rootrootIPC-Run-0.96/eg/0000755000000000000000000000000013105336354011721 5ustar rootrootIPC-Run-0.96/eg/runsu0000644000000000000000000000167313105335071013022 0ustar rootroot#!/usr/bin/perl -w ## Demonstration of chatting with a bash shell. use strict; use IPC::Run qw( start pump finish timeout ); $IPC::Run::debug = 10; my ( $in, $out ); die "usage: runsu " unless @ARGV; my $user = @ARGV > 1 ? shift : $ENV{USER} || $ENV{USERNAME}; my $passwd = shift; my $h = start( [ qw(su - ), $user ], 'pty>', \$out, timeout(5), ); pump $h until $out =~ /^password/im; $in = "$passwd\n"; ## Assume atomic prompt writes ## and that a non-word is the last char in the prompt. $out = ''; pump $h until $out =~ /([^\r\n\w]\s*)(?!\n)$/; my $prompt = $1; print "Detected prompt string = '$prompt'\n"; $prompt = quotemeta $prompt; for (qw( ls ps fOoBaR pwd )) { $in = $_ . "\n"; $out = ''; $h->timeout(5); # restart the timeout pump $h until $out =~ s/\A((?s:.*))(?=^.*?$prompt(?!\n)\Z)//m; print map { "su: $_\n" } split( /\n/m, $1 ); } $in = "exit\n"; finish $h ; IPC-Run-0.96/eg/factorial0000644000000000000000000000325413105335071013607 0ustar rootroot#!/usr/bin/perl -w ## Demonstration of event-driven interaction with a subprocess ## Event driven programming is a pain. This code is not that readable ## and is not a good place to start, especially since few people (including ## me) are familiar with bc's nuances. use strict; use IPC::Run qw( run ); die "usage: $0 \n\nwhere is a positive integer\n" unless @ARGV; my $i = shift; die "\$i must be > 0, not '$i'" unless $i =~ /^\d+$/ && $i > 0; ## bc instructions to initialize two variables and print one out my $stdin_queue = "a = i = $i ; i\n"; ## Note the FALSE on failure result (opposite of system()). die $! unless run( ['bc'], sub { ## Consume all input and return it. This is used instead of a plain ## scalar because run() would close bc's stdin the first time the ## scalar emptied. my $r = $stdin_queue; $stdin_queue = ''; return $r; }, sub { my $out = shift; print "bc said: ", $out; if ( $out =~ s/.*?(\d+)\n/$1/g ) { ## Grab the number from bc. Assume all numbers are delivered in ## single chunks and all numbers are significant. if ( $out > $i ) { ## i! is always >i for i > 0 print "result = ", $out, "\n"; $stdin_queue = undef; } elsif ( $out == '1' ) { ## End of calculation loop, get bc to output the result. $stdin_queue = "a\n"; } else { ## get bc to calculate the next iteration and print it out. $stdin_queue = "i = i - 1 ; a = a * i ; i\n"; } } }, ); IPC-Run-0.96/eg/run_daemon0000644000000000000000000000054013105335071013765 0ustar rootroot#!/usr/local/bin/perl -w ## An example of how to daemonize. See the IPC::Run LIMITATIONS section for ## some reasons why this can be a bit dangerous. use strict; use IPC::Run qw( run close_terminal ); run( sub { # ... your code here ... sleep 15; }, init => sub { close_terminal; exit if fork; } ); IPC-Run-0.96/eg/factorial_scalar0000644000000000000000000000141513105335071015131 0ustar rootroot#!/usr/bin/perl -w ## Demonstration of using a scalar to queue input to a child process use strict; use IPC::Run qw( start timeout ); die "usage: $0 \n\nwhere is a positive integer\n" unless @ARGV; my $i = shift; die "\$i must be > 0, not '$i'" unless $i =~ /^\d+$/ && $i > 0; my ( $in, $out ); my $h = start ['bc'], \$in, \$out, timeout(5); $in = "a = i = $i ; i\n"; while () { $out = ''; $h->pump until $out =~ s/.*?(\d+)\n/$1/g; print "bc said: $out\n"; if ( $out > $i ) { print "result = $out\n"; $in = undef; last; } elsif ( $out == '1' ) { ## End of calculation loop, get bc to output the result $in = "a\n"; } else { $in = "i = i - 1 ; a = a * i ; i\n"; } } $h->finish; IPC-Run-0.96/eg/factorial_pipe0000644000000000000000000000154013105335071014620 0ustar rootroot#!/usr/bin/perl -w ## Demonstration using a pipe to send input to a child process use strict; use IPC::Run qw( start pump finish ); die "usage: $0 \n\nwhere is a positive integer\n" unless @ARGV; my $i = shift; die "\$i must be > 0, not '$i'" unless $i =~ /^\d+$/ && $i > 0; my $out; my $h = start ['bc'], '', \$out; my $tmp = select IN; $| = 1; select $tmp; print IN "a = i = $i ; i\n"; while () { $out = ''; pump $h until $out =~ s/.*?(\d+)\n/$1/g; print "bc said: $out\n"; if ( $out > $i ) { ## i! is always >i for i > 0 print "result = ", $out, "\n"; close(IN); last; } elsif ( $out == '1' ) { ## End of calculation loop, get bc to output the result print IN "a\n"; } else { print IN "i = i - 1 ; a = a * i ; i\n"; } } finish $h ; IPC-Run-0.96/eg/runsh0000644000000000000000000000215613105335071013002 0ustar rootroot#!/usr/bin/perl -w ## Demonstration of chatting with a bash shell. use strict; use IPC::Run qw( start pump finish timeout ); my ( $in, $out, $err ); my $h = start( [qw(sh -login -i )], \$in, \$out, \$err, debug => 0, timeout(5), ); ## The first thing we do is to convert the user's prompt. Normally, we would ## do a '' as the first command in the for () loop so we could detect errors ## that bash might emit on startup. In this case, we need to do this ## initialization first so that we have a prompt to look for so we know that ## it's ready to accept input. This is all because the startup scripts ## that bash runs set PS1, and we can't have that. $in = "PS1=' '\n"; ## bash prompts on stderr. Consume everything before the first ## (which is the second prompt bash issues). pump $h until $err =~ s/.*(?=^ (?!\n)\Z)//ms; for (qw( ls ps fOoBaR pwd )) { $in = $_ . "\n"; $out = ''; pump $h until $err =~ s/\A( .*)(?=^ (?!\n)\Z)//ms; print map { "sh err: $_\n" } split( /\n/m, $1 ); print map { "sh: $_\n" } split( /\n/m, $out ); } finish $h ; IPC-Run-0.96/eg/synopsis_scripting0000644000000000000000000000110713105335071015607 0ustar rootrootuse strict; my @cat = qw( cat ); my ( $in_q, $out_q, $err_q ); use IPC::Run qw( start pump finish timeout ); # Incrementally read from / write to scalars. Note that $in_q # is a queue that is drained as it is used. $h is for "harness". my $h = start \@cat, \$in_q, \$out_q, \$err_q, timeout(10), debug => 1; $in_q .= "some input\n"; pump $h until $out_q =~ /input\n/g; $in_q .= "some more input\n"; pump $h until $out_q =~ /\G.*more input\n/; $in_q .= "some final input\n"; finish $h or die "cat returned $?"; warn $err_q if $err_q; print $out_q ; ## All of cat's output IPC-Run-0.96/t/0000755000000000000000000000000013105336354011571 5ustar rootrootIPC-Run-0.96/t/98_pod_coverage.t0000644000000000000000000000306013105335071014725 0ustar rootroot#!/usr/bin/perl # Test that the syntax of our POD documentation is valid use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Test::Pod::Coverage 1.04', ); # Don't run tests during end-user installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing modules foreach my $MODULE (@MODULES) { eval "use $MODULE"; if ($@) { $ENV{RELEASE_TESTING} ? die("Failed to load required release-testing module $MODULE") : plan( skip_all => "$MODULE not available for testing" ); } } plan tests => 7; #my $private_subs = { private => [qr/foo_fizz/]}; #pod_coverage_ok('IPC::Run', $private_subs, "Test IPC::Run that all modules are documented."); pod_coverage_ok( 'IPC::Run', "Test IPC::Run that all modules are documented." ); pod_coverage_ok( 'IPC::Run::Debug', "Test IPC::Run::Debug that all modules are documented." ); pod_coverage_ok( 'IPC::Run::IO', "Test IPC::Run::IO that all modules are documented." ); pod_coverage_ok( 'IPC::Run::Timer', "Test IPC::Run::Timer that all modules are documented." ); TODO: { local $TODO = "These modules are not fully documented yet."; pod_coverage_ok( 'IPC::Run::Win32Helper', "Test IPC::Run::Win32Helper that all modules are documented." ); pod_coverage_ok( 'IPC::Run::Win32IO', "Test IPC::Run::Win32IO that all modules are documented." ); pod_coverage_ok( 'IPC::Run::Win32Pump', "Test IPC::Run::Win32Pump that all modules are documented." ); } IPC-Run-0.96/t/run.t0000644000000000000000000004754313105335071012572 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME run.t - Test suite for IPC::Run::run, etc. =cut use strict; BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } my @WARNING_MESSAGES; $SIG{__WARN__} = sub { push @WARNING_MESSAGES, @_; diag("WARN: $_") foreach (@_); }; sub get_warnings { my @warnings = @WARNING_MESSAGES; @WARNING_MESSAGES = (); return @warnings; } ## Handy to have when our output is intermingled with debugging output sent ## to the debugging fd. select STDERR; select STDOUT; use Test::More tests => 268; use IPC::Run::Debug qw( _map_fds ); use IPC::Run qw( :filters :filter_imp start ); require './t/lib/Test.pm'; IPC::Run::Test->import(); # Must do this this late as plan uses localtime, and localtime on darwin opens # a file descriptor. Quite probably other operating systems do file descriptor # things during the test setup. my $fd_map = _map_fds; sub run { IPC::Run::run( ref $_[0] ? ( noinherit => 1 ) : (), @_ ); } ## Test at least some of the win32 PATHEXT logic my $perl = $^X; $perl =~ s/\.\w+\z// if IPC::Run::Win32_MODE(); sub _unlink { my ($f) = @_; my $tries; while () { return if unlink $f; if ( $^O =~ /Win32/ && ++$tries <= 10 ) { print STDOUT "# Waiting for Win32 to allow $f to be unlinked ($!)\n"; select undef, undef, undef, 0.1; next; } die "$! unlinking $f at ", join( ", line ", (caller)[ 1, 2 ] ), "\n"; } } my $text = "Hello World\n"; my @perl = ($perl); my $emitter_script = qq{print '$text'; print STDERR uc( '$text' ) unless \@ARGV }; my @emitter = ( @perl, '-e', $emitter_script ); my $in; my $out; my $err; my $in_file = 'run.t.in'; my $out_file = 'run.t.out'; my $err_file = 'run.t.err'; my $h; sub slurp($) { my ($f) = @_; open( S, "<$f" ) or return "$! $f"; my $r = join( '', ); close S or warn "$!: $f"; select 0.1 if $^O =~ /Win32/; return $r; } sub spit($$) { my ( $f, $s ) = @_; open( S, ">$f" ) or die "$! $f"; print S $s or die "$! $f"; close S or die "$! $f"; } ## ## A grossly inefficient filter to test filter ## chains. It's inefficient because we want to make sure that the ## filter chain flushing logic works. The inefficiency is that it ## doesn't process as much input as it could each call, so lots of calls ## are required. ## sub alt_casing_filter { my ( $in_ref, $out_ref ) = @_; return input_avail && do { $$out_ref .= lc( substr( $$in_ref, 0, 1, '' ) ); 1; } && ( !input_avail || do { $$out_ref .= uc( substr( $$in_ref, 0, 1, '' ) ); 1; } ); } sub case_inverting_filter { my ( $in_ref, $out_ref ) = @_; return input_avail && do { $$in_ref =~ tr/a-zA-Z/A-Za-z/; $$out_ref .= $$in_ref; $$in_ref = ''; 1; }; } sub eok { my ( $got, $exp, $name ) = @_; $got =~ s/([\000-\037])/sprintf "\\0x%02x", ord $1/ge if defined $exp; $exp =~ s/([\000-\037])/sprintf "\\0x%02x", ord $1/ge if defined $exp; my ( $pack, $file, $line ) = caller(); $name ||= qq[eok at $file line $line]; local $Test::Builder::Level = $Test::Builder::Level + 1; return is( $got, $exp, $name ); } my $r; is( _map_fds, $fd_map ); $fd_map = _map_fds; ## ## Internal testing ## filter_tests( "alt_casing_filter", "Hello World", [ "hElLo wOrLd" =~ m/(..?)/g ], \&alt_casing_filter ), is( _map_fds, $fd_map ); $fd_map = _map_fds; filter_tests( "case_inverting_filter", "Hello World", "hELLO wORLD", \&case_inverting_filter ), is( _map_fds, $fd_map ); $fd_map = _map_fds; ## ## Calling the local system shell ## ok( run qq{$perl -e exit} ); is( $?, 0 ); is( _map_fds, $fd_map ); $fd_map = _map_fds; SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "$^O's shell returns 0 even if last command doesn't", 3 ); } ok( !run(qq{$perl -e 'exit(42)'}) ); ok($?); is( $? >> 8, 42 ); } is( _map_fds, $fd_map ); $fd_map = _map_fds; ## ## Simple commands, not executed via shell ## ok( run $perl, qw{-e exit} ); is( $?, 0 ); is( _map_fds, $fd_map ); $fd_map = _map_fds; ok( !run $perl, qw{-e exit(42)} ); ok($?); is $? >> 8, 42; is( _map_fds, $fd_map ); $fd_map = _map_fds; ## ## A function ## SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "Can't spawn subroutines on $^O", 5 ); } ok run sub { }; is $?, 0; ok !run sub { exit 42 }; ok $? ; is $? >> 8, 42; } is( _map_fds, $fd_map ); $fd_map = _map_fds; ## ## A function, and an init function ## SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "Can't spawn subroutines on $^O", 2 ); } my $e = 0; ok( !run( sub { exit($e) }, init => sub { $e = 42 } ) ); ok($?); } is( _map_fds, $fd_map ); $fd_map = _map_fds; ## ## scalar ref I & O redirection using op tokens ## $out = 'REPLACE ME'; $fd_map = _map_fds; $r = run [ @emitter, "nostderr" ], '>', \$out; ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, $text ); $out = 'REPLACE ME'; $fd_map = _map_fds; $r = run [ @emitter, "nostderr" ], '<', \undef, '>', \$out; ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, $text ); $in = $emitter_script; $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run \@perl, '<', \$in, '>', \$out, '2>', \$err,; ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $in, $emitter_script ); eok( $out, $text ); eok( $err, uc($text) ); ## ## scalar ref I & O redirection, succinct mode. ## $in = $emitter_script; $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run \@perl, \$in, \$out, \$err; ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $in, $emitter_script ); eok( $out, $text ); eok( $err, uc($text) ); ## ## Long output, to test for blocking read. ## ## Assume pipe buffer length <= 10000, need to double that to assure enough ## chars to fill a buffer so. This test adapted from a test submitted by ## Borislav Deianov . $in = "-" x 20000 . "end\n"; $out = 'REPLACE ME'; $fd_map = _map_fds; $r = run [ $perl, qw{-e print"-"x20000;;} ], \$in, \$out; ok($r); ok( !$? ); is( _map_fds, $fd_map ); is( length $out, 20000 ); unlike( $out, qr/[^-]/ ); ## ## Long output run through twice ## ## Adapted from a stress test by Aaron Elkiss ## $h = start [ $perl, qw( -pe BEGIN{$|=1}1 ) ], \$in, \$out; $in = "\n"; $out = ""; pump $h until length $out; is $out, "\n"; my $long_string = "x" x 20000 . "DOC2\n"; $in = $long_string; $out = ""; my $ok_1 = eval { pump $h until $out =~ /DOC2/; 1; }; my $x = $@; my $ok_2 = eval { finish $h; 1; }; $x = $@ if $ok_1 && !$ok_2; if ( $ok_1 && $ok_2 ) { is $long_string, $out; } else { $x =~ s/(x+)/sprintf "...%d \"x\" chars...", length $1/e; is $x, ""; } ## ## child function, scalar ref I & O redirection, succinct mode. ## SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "Can't spawn subroutines on $^O", 6 ); } $in = $text; $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run( sub { while (<>) { print; print STDERR uc($_) } }, \$in, \$out, \$err ); ok($r); ok !$?; is( _map_fds, $fd_map ); eok( $in, $text ); eok( $out, $text ); eok( $err, uc($text) ); } ## ## here document as input ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run \@perl, \<', \$out, '2>', \$err; ## Assume this won't block... print IN $emitter_script; close IN or warn $!; $r = $h->finish; ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc($text) ); ## ## filehandle input redirection, passed via *F{IO} ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; spit( $in_file, $emitter_script ); open( F, "<$in_file" ) or die "$! $in_file"; $r = run \@perl, *F{IO}, \$out, \$err; close F; _unlink $in_file; ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc($text) ); ## ## filehandle output redirection ## $fd_map = _map_fds; open( OUT, ">$out_file" ) or die "$! $out_file"; open( ERR, ">$err_file" ) or die "$! $err_file"; print OUT "out: "; print ERR uc("err: "); $r = run \@emitter, \undef, \*OUT, \*ERR; print OUT " more out data"; print ERR uc(" more err data"); close OUT; close ERR; $out = slurp($out_file); $err = slurp($err_file); _unlink $out_file; _unlink $err_file; ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, "out: $text more out data" ); eok( $err, uc("err: $text more err data") ); ## ## filehandle output redirection via a pipe that is returned to the caller ## $fd_map = _map_fds; $r = run \@emitter, \undef, '>pipe', \*OUT, '2>pipe', \*ERR; $out = ''; $err = ''; read OUT, $out, 10000 or warn $!; read ERR, $err, 10000 or warn $!; close OUT or warn $!; close ERR or warn $!; ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc($text) ); ## ## sub I & O redirection ## $in = $emitter_script; $out = undef; $err = undef; $fd_map = _map_fds; $r = run( \@perl, '<', sub { my $f = $in; $in = undef; return $f }, '>', sub { $out .= shift }, '2>', sub { $err .= shift }, ); ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc($text) ); ## ## input redirection from a file ## $out = undef; $err = undef; $fd_map = _map_fds; spit( $in_file, $emitter_script ); $r = run( \@perl, "<$in_file", '>', sub { $out .= shift }, '2>', sub { $err .= shift }, ); _unlink $in_file; ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc($text) ); ## ## reading input from a non standard fd ## SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "$^O does not allow redirection of file descriptors > 2", 11 ); } $out = undef; $err = undef; $fd_map = _map_fds; $r = run( ## FreeBSD doesn't guarantee that fd 3 or 4 are available, so ## don't assume, go for 5. [ @perl, '-le', 'open( STDIN, "<&5" ) or die $!; print ' ], "5<", \"Hello World", '>', \$out, '2>', \$err, ); ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, '' ); ## ## duping input descriptors and an input descriptor > 0 ## $in = $emitter_script; $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run( \@perl, '>', \$out, '2>', \$err, '3<', \$in, '0<&3', ); ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $in, $emitter_script ); eok( $out, $text ); eok( $err, uc($text) ); } ## ## closing input descriptors ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; spit( $in_file, $emitter_script ); $r = run( [ @perl, '-e', '$l = readline *STDIN or die $!; print $l' ], '>', \$out, '2>', \$err, '<', $in_file, '0<&-', ); _unlink $in_file; ok( !$r ); ok($?); is( _map_fds, $fd_map ); eok( $out, '' ); #ok( $err =~ /file descriptor/i ? "Bad file descriptor error" : $err, "Bad file descriptor error" ); # XXX This should be use Errno; if $!{EBADF}. --rs is( length $err ? "Bad file descriptor error" : $err, "Bad file descriptor error" ); ## ## input redirection from a non-existent file ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; my $bad_file = "$in_file.nonexistent"; _unlink $bad_file if -e $bad_file; eval { $r = run \@perl, ">$out_file", "<$bad_file"; }; like $@, qr/\Q$bad_file\E/; is( _map_fds, $fd_map ); ## ## output redirection to a file w/ creation or truncation ## $fd_map = _map_fds; _unlink $out_file if -x $out_file; _unlink $err_file if -x $err_file; $r = run( \@emitter, ">$out_file", "2>$err_file", ); $out = slurp($out_file); $err = slurp($err_file); ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc($text) ); ## ## output file redirection, w/ truncation ## $fd_map = _map_fds; spit( $out_file, 'out: ' ); spit( $err_file, 'ERR: ' ); $r = run( \@emitter, ">$out_file", "2>$err_file", ); $out = slurp($out_file); _unlink $out_file; $err = slurp($err_file); _unlink $err_file; ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc($text) ); ## ## output file redirection w/ append ## spit( $out_file, 'out: ' ); spit( $err_file, 'ERR: ' ); $fd_map = _map_fds; $r = run( \@emitter, ">>$out_file", "2>>$err_file", ); $out = slurp($out_file); _unlink $out_file; $err = slurp($err_file); _unlink $err_file; ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, "out: $text" ); eok( $err, uc("err: $text") ); ## ## dup()ing output descriptors ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run \@emitter, '>', \$out, '2>', \$err, '2>&1'; ok($r); ok( !$? ); is( _map_fds, $fd_map ); like $out, qr/(?:$text){2}/i; eok( $err, '' ); ## ## stderr & stdout redirection to the same file via >&word ## $fd_map = _map_fds; _unlink $out_file if -x $out_file; $r = run \@emitter, ">&$out_file"; $out = slurp($out_file); ok($r); ok( !$? ); is( _map_fds, $fd_map ); like $out, qr/(?:$text){2}/i; ## ## Non-zero exit value, command with args, no redirects. ## $fd_map = _map_fds; $r = run [ @perl, '-e', 'exit(42)' ]; ok( !$r ); is( $?, 42 << 8 ); is( _map_fds, $fd_map ); ## ## Zero exit value, command with args, no redirects. ## $fd_map = _map_fds; $r = run [ @perl, qw{ -e exit } ]; ok($r); ok( !$? ); is( _map_fds, $fd_map ); ## ## dup()ing output descriptors that collide. ## ## This test assumes that our caller doesn't leave a lot of fds opened, ## and assumes that $out_file will be opened on fd 3, 4 or 5. ## SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "$^O does not allow redirection of file descriptors > 2", 5 ); } $out = 'REPLACE ME'; $err = 'REPLACE ME'; _unlink $out_file if -x $out_file; $fd_map = _map_fds; $r = run( \@emitter, "<", \"", "3>&1", "4>&1", "5>&1", ">$out_file", '2>', \$err, ); $out = slurp($out_file); _unlink $out_file; ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc($text) ); } ## ## Pipelining ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run( [ @perl, '-lane', 'print STDERR qq{1:$_}; print uc($F[0]), q{ },$F[1]' ], \q{Hello World}, '|', [ @perl, '-lane', 'print STDERR qq{2:$_}; print $F[0], q{ },lc($F[1])' ], \$out, \$err, ); ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, "HELLO world\n" ); eok( $err, "1:Hello World\n2:HELLO World\n" ); ## ## Parallel (unpiplined) processes ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run( [ @perl, '-lane', 'print STDERR qq{1:$_}; print uc($F[0]),q{ },$F[1]' ], \q{Hello World}, '&', [ @perl, '-lane', 'print STDERR "2:$_"; print $F[0],q{ },lc( $F[1] )' ], \q{Hello World}, \$out, \$err, ); ok($r); ok( !$? ); is( _map_fds, $fd_map ); like $out, qr/^(?:HELLO World\n|Hello world\n){2}$/s; like $err, qr/^(?:[12]:Hello World.*){2}$/s; ## ## A few error cases... ## eval { $r = run \@perl, '<', [], [] }; like( $@, qr/not allowed/ ); eval { $r = run \@perl, '>', [], [] }; like( $@, qr/not allowed/ ); foreach my $foo (qw( | & < > >& 1>&2 >file ', \$out, '2>', \$err, _simulate_fork_failure => 1 ); }; ok($@); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, '' ); eok( $err, '' ); $fd_map = _map_fds; eval { $r = run \@perl, ' 1; }; ok($@); ok( !$? ); is( _map_fds, $fd_map ); $fd_map = _map_fds; eval { $r = run \@perl, '>file', _simulate_open_failure => 1; }; ok($@); ok( !$? ); is( _map_fds, $fd_map ); ## ## harness, pump, run ## $in = 'SHOULD BE UNCHANGED'; $out = 'REPLACE ME'; $err = 'REPLACE ME'; $? = 99; $fd_map = _map_fds; $h = start( [ @perl, '-pe', 'BEGIN { $| = 1 } print STDERR uc($_)' ], \$in, \$out, \$err, ); isa_ok( $h, 'IPC::Run' ); is( $?, 99 ); eok( $in, 'SHOULD BE UNCHANGED' ); eok( $out, '' ); eok( $err, '' ); ok( $h->pumpable ); $in = ''; $? = 0; pump_nb $h for ( 1 .. 100 ); pass("after pump_nb"); eok( $in, '' ); eok( $out, '' ); eok( $err, '' ); ok( $h->pumpable ); $in = $text; $? = 0; pump $h until $out =~ /Hello World/; pass("after pump"); ok( !$? ); eok( $in, '' ); eok( $out, $text ); ok( $h->pumpable ); ok( $h->finish ); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, $text ); eok( $err, uc($text) ); ok( !$h->pumpable ); ## ## start, run, run, run. See Tom run. A do-run-run, a-do-run-run. ## $in = 'SHOULD BE UNCHANGED'; $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $h = start( [ @perl, '-pe', 'binmode STDOUT; binmode STDERR; BEGIN { $| = 1 } print STDERR uc($_)' ], \$in, \$out, \$err, ); ok( $h->isa('IPC::Run') ); eok( $in, 'SHOULD BE UNCHANGED' ); eok( $out, '' ); eok( $err, '' ); ok( $h->pumpable ); $in = $text; ok( $h->finish ); ok( !$? ); is( _map_fds, $fd_map ); eok( $in, '' ); eok( $out, $text ); eok( $err, uc($text) ); ok( !$h->pumpable ); $in = $text; $out = 'REPLACE ME'; $err = 'REPLACE ME'; ok( $h->run ); ok( !$? ); is( _map_fds, $fd_map ); eok( $in, $text ); eok( $out, $text ); eok( $err, uc($text) ); ok( !$h->pumpable ); $in = $text; $out = 'REPLACE ME'; $err = 'REPLACE ME'; ok( $h->run ); ok( !$? ); is( _map_fds, $fd_map ); eok( $in, $text ); eok( $out, $text ); eok( $err, uc($text) ); ok( !$h->pumpable ); ## ## Output filters ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $r = run( \@emitter, '>', \&alt_casing_filter, \&case_inverting_filter, \$out, '2>', \$err, ); ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $out, "HeLlO WoRlD\n" ); eok( $err, uc($text) ); ## ## Input filters ## $out = 'REPLACE ME'; $err = 'REPLACE ME'; $fd_map = _map_fds; $in = $text; $r = run( [ @perl, '-pe', 'binmode STDOUT; binmode STDERR; print STDERR uc $_' ], '0<', \&case_inverting_filter, \&alt_casing_filter, \$in, '1>', \$out, '2>', \$err, ); ok($r); ok( !$? ); is( _map_fds, $fd_map ); eok( $in, $text ); eok( $out, "HeLlO WoRlD\n" ); eok( $err, uc($text) ); { # no warnings for an empty path but it does die. # Some other OSes might not support find. Windows and UNIX do... my @simple_command = ('bogusprogram'); local $ENV{PATH}; delete $ENV{PATH}; eval { $h = start \@simple_command, \$in, \$out; }; ok( $@, "Error running bogus program when path is empty" ); my ($message) = get_warnings(); is( $message, undef, "No warnings found during program call with empty path" ); finish $h; # Close out the program call } IPC-Run-0.96/t/binmode.t0000644000000000000000000000511513105335071013370 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME binary.t - Test suite for IPC::Run binary functionality =cut use strict; BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } ## Handy to have when our output is intermingled with debugging output sent ## to the debugging fd. select STDERR; select STDOUT; use Test::More tests => 24; use IPC::Run qw( harness run binary ); sub Win32_MODE(); *Win32_MODE = \&IPC::Run::Win32_MODE; my $crlf_text = "Hello World\r\n"; my $text = $crlf_text; $text =~ s/\r//g if Win32_MODE; my $nl_text = $crlf_text; $nl_text =~ s/\r//g; my @perl = ($^X); my $emitter_script = q{ binmode STDOUT; print qq{Hello World\r\n} }; my @emitter = ( @perl, '-e', $emitter_script ); my $reporter_script = q{ binmode STDIN; $_ = join q{}, <>; s/([\000-\037])/sprintf qq{\\\\0x%02x}, ord $1/ge; print }; my @reporter = ( @perl, '-e', $reporter_script ); my $in; my $out; my $err; sub f($) { my $s = shift; $s =~ s/([\000-\027])/sprintf "\\0x%02x", ord $1/ge; $s; } ## Parsing tests is( eval { harness [], '>', binary, \$out } ? 1 : $@, 1 ); is( eval { harness [], '>', binary, "foo" } ? 1 : $@, 1 ); is( eval { harness [], '<', binary, \$in } ? 1 : $@, 1 ); is( eval { harness [], '<', binary, "foo" } ? 1 : $@, 1 ); ## Testing from-kid now so we can use it to test stdin later ok( run( \@emitter, ">", \$out ) ); is( f($out), f($text), "no binary" ); ok( run( \@emitter, ">", binary, \$out ) ); is( f($out), f($crlf_text), "out binary" ); ok( run( \@emitter, ">", binary(0), \$out ) ); is( f($out), f($text), "out binary 0" ); ok( run( \@emitter, ">", binary(1), \$out ) ); is( f($out), f($crlf_text), "out binary 1" ); ## Test to-kid ok( run( \@reporter, "<", \$nl_text, ">", \$out ) ); is( $out, "Hello World" . ( Win32_MODE ? "\\0x0d" : "" ) . "\\0x0a", "reporter < \\n" ); ok( run( \@reporter, "<", binary, \$nl_text, ">", \$out ) ); is( $out, "Hello World\\0x0a", "reporter < binary \\n" ); ok( run( \@reporter, "<", binary, \$crlf_text, ">", \$out ) ); is( $out, "Hello World\\0x0d\\0x0a", "reporter < binary \\r\\n" ); ok( run( \@reporter, "<", binary(0), \$nl_text, ">", \$out ) ); is( $out, "Hello World" . ( Win32_MODE ? "\\0x0d" : "" ) . "\\0x0a", "reporter < binary(0) \\n" ); ok( run( \@reporter, "<", binary(1), \$nl_text, ">", \$out ) ); is( $out, "Hello World\\0x0a", "reporter < binary(1) \\n" ); ok( run( \@reporter, "<", binary(1), \$crlf_text, ">", \$out ) ); is( $out, "Hello World\\0x0d\\0x0a", "reporter < binary(1) \\r\\n" ); IPC-Run-0.96/t/win32_compile.t0000644000000000000000000000331013105335071014420 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME win32_compile.t - See if IPC::Run::Win32Helper compiles, even on Unix =cut use strict; BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More; BEGIN { unless ( eval "require 5.006" ) { ## NOTE: I'm working around this here because I don't want this ## test to fail on non-Win32 systems with older Perls. Makefile.PL ## does the require 5.6.0 to protect folks on Windows. plan( skip_all => "perl5.00503's Socket.pm does not export IPPROTO_TCP" ); } if ( $^O eq 'android' ) { plan( skip_all => "android does not support getprotobyname()" ); } $INC{$_} = 1 for qw( Win32/Process.pm Win32API/File.pm ); package Win32API::File; use vars qw( @ISA @EXPORT ); @ISA = qw( Exporter ); @EXPORT = qw( GetOsFHandle OsFHandleOpen OsFHandleOpenFd FdGetOsFHandle SetHandleInformation SetFilePointer HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE createFile WriteFile ReadFile CloseHandle FILE_ATTRIBUTE_TEMPORARY FILE_FLAG_DELETE_ON_CLOSE FILE_FLAG_WRITE_THROUGH FILE_BEGIN ); eval "sub $_ { 1 }" for @EXPORT; use Exporter; package Win32::Process; use vars qw( @ISA @EXPORT ); @ISA = qw( Exporter ); @EXPORT = qw( NORMAL_PRIORITY_CLASS ); eval "sub $_ {}" for @EXPORT; use Exporter; } sub Socket::IPPROTO_TCP() { undef } package main; use IPC::Run::Win32Helper; use IPC::Run::Win32IO; plan( tests => 1 ); ok(1); IPC-Run-0.96/t/signal.t0000644000000000000000000000215013105335071013224 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME signal.t - Test suite IPC::Run->signal =cut use strict; BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More; use IPC::Run qw( :filters :filter_imp start run ); require './t/lib/Test.pm'; IPC::Run::Test->import(); BEGIN { if ( IPC::Run::Win32_MODE() ) { plan skip_all => 'Skipping on Win32'; exit(0); } else { plan tests => 3; } } my @receiver = ( $^X, '-e', <<'END_RECEIVER', my $which = " "; sub s{ $which = $_[0] }; $SIG{$_}=\&s for (qw(USR1 USR2)); $| = 1; print "Ok\n"; for (1..10) { sleep 1; print $which, "\n" } END_RECEIVER ); my $h; my $out; $h = start \@receiver, \undef, \$out; pump $h until $out =~ /Ok/; ok 1; $out = ""; $h->signal("USR2"); pump $h; $h->signal("USR1"); pump $h; $h->signal("USR2"); pump $h; $h->signal("USR1"); pump $h; ok $out, "USR2\nUSR1\nUSR2\nUSR1\n"; $h->signal("TERM"); finish $h; ok(1); IPC-Run-0.96/t/98_pod.t0000644000000000000000000000125713105335071013060 0ustar rootroot#!/usr/bin/perl # Test that the syntax of our POD documentation is valid use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Pod::Simple 3.07', 'Test::Pod 1.26', ); # Don't run tests during end-user installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing modules foreach my $MODULE (@MODULES) { eval "use $MODULE"; if ($@) { $ENV{RELEASE_TESTING} ? die("Failed to load required release-testing module $MODULE") : plan( skip_all => "$MODULE not available for testing" ); } } all_pod_files_ok(); 1; IPC-Run-0.96/t/kill_kill.t0000644000000000000000000000230213105335071013714 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME kill_kill.t - Test suite for IPC::Run->kill_kill =cut BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use strict; use Test::More; use IPC::Run (); # Don't run this test script on Windows at all if ( IPC::Run::Win32_MODE() ) { plan( skip_all => 'Temporarily ignoring test failure on Win32' ); exit(0); } else { plan( tests => 2 ); } # Test 1 SCOPE: { my $h = IPC::Run::start( [ $^X, '-e', 'sleep while 1', ] ); my $needed = $h->kill_kill; ok( !$needed, 'Did not need kill_kill' ); } # Test 2 SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "$^O does not support ignoring the TERM signal", 1 ); } my $out; my $h = IPC::Run::start( [ $^X, '-e', '$SIG{TERM}=sub{};$|=1;print "running\n";sleep while 1', ], \undef, \$out ); pump $h until $out =~ /running/; my $needed = $h->kill_kill( grace => 1 ); ok( $needed, 'Did not need kill_kill' ); } IPC-Run-0.96/t/filter.t0000644000000000000000000000417013105335071013240 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME filter.t - Test suite for IPC::Run filter scaffolding =cut use strict; BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More tests => 80; require './t/lib/Test.pm'; IPC::Run::Test->import(); use IPC::Run qw( :filters :filter_imp ); sub uc_filter { my ( $in_ref, $out_ref ) = @_; return input_avail && do { $$out_ref .= uc($$in_ref); $$in_ref = ''; 1; } } my $string; sub string_source { my ( $in_ref, $out_ref ) = @_; return undef unless defined $string; $$out_ref .= $string; $string = undef; return 1; } my $accum; sub accum { my ( $in_ref, $out_ref ) = @_; return input_avail && do { $accum .= $$in_ref; $$in_ref = ''; 1; }; } my $op; ## "import" the things we're testing. *_init_filters = \&IPC::Run::_init_filters; *_do_filters = \&IPC::Run::_do_filters; filter_tests( "filter_tests", "hello world", "hello world" ); filter_tests( "filter_tests []", [qq(hello world)], [qq(hello world)] ); filter_tests( "filter_tests [] 2", [qw(hello world)], [qw(hello world)] ); filter_tests( "uc_filter", "hello world", "HELLO WORLD", \&uc_filter ); filter_tests( "chunking_filter by lines 1", "hello 1\nhello 2\nhello 3", [ "hello 1\n", "hello 2\n", "hello 3" ], new_chunker ); filter_tests( "chunking_filter by lines 2", "hello 1\nhello 2\nhello 3", [ "hello 1\n", "hello 2\n", "hello 3" ], new_chunker ); filter_tests( "chunking_filter by lines 2", [ split( /(\s|\n)/, "hello 1\nhello 2\nhello 3" ) ], [ "hello 1\n", "hello 2\n", "hello 3" ], new_chunker ); filter_tests( "chunking_filter by an odd separator", "hello world", "hello world", new_chunker('odd separator') ); filter_tests( "chunking_filter 2", "hello world", [ 'hello world' =~ m/(.)/g ], new_chunker(qr/./) ); filter_tests( "appending_filter", [qw( 1 2 3 )], [qw( 1a 2a 3a )], new_appender("a") ); IPC-Run-0.96/t/pty.t0000644000000000000000000001223713105335071012572 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME pty.t - Test suite for IPC::Run's pty (psuedo-terminal) support =head1 DESCRIPTION This test suite starts off with a test that seems to cause a deadlock on freebsd: \@cmd, '', ..., '2>'... This seems to cause the child process entry in the process table to hang around after the child exits. Both output pipes are closed, but the PID is still valid so IPC::Run::finish() thinks it's still alive and the whole shebang deadlocks waiting for the child to exit. This is a very rare corner condition, so I'm not patching in a fix yet. One fix might be to hack IPC::Run to close the master pty when all outputs from the child are closed. That's a hack, not sure what to do about it. This problem needs to be reproduced in a standalone script and investigated further, but I have not the time. =cut use strict; BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More; BEGIN { if ( eval { require IO::Pty; } ) { plan tests => 32; } else { plan skip_all => "IO::Pty not installed"; } } use IPC::Run::Debug qw( _map_fds ); use IPC::Run qw( start pump finish ); select STDERR; select STDOUT; sub pty_warn { warn "\nWARNING: $_[0].\nWARNING: 'pty>' $_[1] not work.\n\n"; } if ( $^O !~ /Win32/ ) { # my $min = 0.9; for ( eval { require IO::Pty; IO::Pty->VERSION } ) { s/_//g if defined; if ( !defined ) { pty_warn "IO::Pty not found", "will"; } elsif ( $_ == 0.02 ) { pty_warn "IO::Pty v$_ has spurious warnings, try 0.9 or later", "may"; } elsif ( $_ < 1.00 ) { pty_warn "IO::Pty 1.00 is strongly recommended", "may"; } } } diag("IO::Tty $IO::Tty::VERSION, IO::Pty $IO::Pty::VERSION"); my $echoer_script = <) { print STDERR uc \$_; print; last if /quit/; } TOHERE ## ## $^X is the path to the perl binary. This is used run all the subprocesses. ## my @echoer = ( $^X, '-e', $echoer_script ); my $in; my $out; my $err; my $h; my $r; my $fd_map; my $text = "hello world\n"; ## TODO: test lots of mixtures of pty's and pipes & files. Use run(). ## Older Perls can't ok( a, qr// ), so I manually do that here. my $exp; my $platform_skip = $^O =~ /(?:dragonfly|aix|freebsd|openbsd|darwin)/ ? "$^O deadlocks on this test" : ""; ## ## stdin only ## SKIP: { if ($platform_skip) { skip( $platform_skip, 9 ); } $out = 'REPLACE ME'; $? = 99; $fd_map = _map_fds; $h = start \@echoer, '', \$out, '2>', \$err; $in = "hello\n"; $? = 0; pump $h until $out =~ /hello/ && $err =~ /HELLO/; is( $out, "hello\n" ); $exp = qr/^HELLO\n(?!\n)$/; $err =~ $exp ? ok(1) : is( $err, $exp ); is( $in, '' ); $in = "world\n"; $? = 0; pump $h until $out =~ /world/ && $err =~ /WORLD/; is( $out, "hello\nworld\n" ); $exp = qr/^HELLO\nWORLD\n(?!\n)$/; $err =~ $exp ? ok(1) : is( $err, $exp ); is( $in, '' ); $in = "quit\n"; ok( $h->finish ); ok( !$? ); is( _map_fds, $fd_map ); } ## ## stdout, stderr ## $out = 'REPLACE ME'; $? = 99; $fd_map = _map_fds; $h = start \@echoer, \$in, '>pty>', \$out; $in = "hello\n"; $? = 0; pump $h until $out =~ /hello\r?\n/; ## We assume that the slave's write()s are atomic $exp = qr/^(?:hello\r?\n){2}(?!\n)$/i; $out =~ $exp ? ok(1) : is( $out, $exp ); is( $in, '' ); $in = "world\n"; $? = 0; pump $h until $out =~ /world\r?\n/; $exp = qr/^(?:hello\r?\n){2}(?:world\r?\n){2}(?!\n)$/i; $out =~ $exp ? ok(1) : is( $out, $exp ); is( $in, '' ); $in = "quit\n"; ok( $h->finish ); ok( !$? ); is( _map_fds, $fd_map ); ## ## stdout only ## $out = 'REPLACE ME'; $? = 99; $fd_map = _map_fds; $h = start \@echoer, \$in, '>pty>', \$out, '2>', \$err; $in = "hello\n"; $? = 0; pump $h until $out =~ /hello\r?\n/ && $err =~ /HELLO/; $exp = qr/^hello\r?\n(?!\n)$/; $out =~ $exp ? ok(1) : is( $out, $exp ); $exp = qr/^HELLO\n(?!\n)$/; $err =~ $exp ? ok(1) : is( $err, $exp ); is( $in, '' ); $in = "world\n"; $? = 0; pump $h until $out =~ /world\r?\n/ && $err =~ /WORLD/; $exp = qr/^hello\r?\nworld\r?\n(?!\n)$/; $out =~ $exp ? ok(1) : is( $out, $exp ); $exp = qr/^HELLO\nWORLD\n(?!\n)$/, $err =~ $exp ? ok(1) : is( $err, $exp ); is( $in, '' ); $in = "quit\n"; ok( $h->finish ); ok( !$? ); is( _map_fds, $fd_map ); ## ## stdin, stdout, stderr ## $out = 'REPLACE ME'; $? = 99; $fd_map = _map_fds; $h = start \@echoer, 'pty>', \$out; $in = "hello\n"; $? = 0; pump $h until $out =~ /hello.*hello.*hello\r?\n/is; ## We assume that the slave's write()s are atomic $exp = qr/^(?:hello\r?\n){3}(?!\n)$/i; $out =~ $exp ? ok(1) : is( $out, $exp ); is( $in, '' ); $in = "world\n"; $? = 0; pump $h until $out =~ /world.*world.*world\r?\n/is; $exp = qr/^(?:hello\r?\n){3}(?:world\r?\n){3}(?!\n)$/i; $out =~ $exp ? ok(1) : is( $out, $exp ); is( $in, '' ); $in = "quit\n"; ok( $h->finish ); ok( !$? ); is( _map_fds, $fd_map ); IPC-Run-0.96/t/97_meta.t0000644000000000000000000000111613105335071013215 0ustar rootroot#!/usr/bin/perl # Test that our META.yml file matches the current specification. use strict; BEGIN { $| = 1; $^W = 1; } my $MODULE = 'Test::CPAN::Meta 0.12'; # Don't run tests for installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing module eval "use $MODULE"; if ($@) { $ENV{RELEASE_TESTING} ? die("Failed to load required release-testing module $MODULE") : plan( skip_all => "$MODULE not available for testing" ); } meta_yaml_ok(); IPC-Run-0.96/t/timer.t0000644000000000000000000000653613105335071013103 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME timer.t - Test suite for IPC::Run::Timer =cut use strict; BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More tests => 77; use IPC::Run qw( run ); use IPC::Run::Timer qw( :all ); my $t; my $started; $t = timer( # debug => 1, 1, ); is( ref $t, 'IPC::Run::Timer' ); is( $t->interval, 1 ); $t->interval(0); is( $t->interval, 0 ); $t->interval(0.1); ok( $t->interval > 0 ); $t->interval(1); ok( $t->interval >= 1 ); $t->interval(30); ok( $t->interval >= 30 ); $t->interval(30.1); ok( $t->interval > 30 ); $t->interval(30.1); ok( $t->interval <= 31 ); SKIP: { skip( "Perl below 5.8.9 doesn't seem to be able to handle infinity", 1 ) if ( $] < 5.008009 ); $t->interval('inf'); ok( $t->interval > 1000, "Infinity timer." ); } $t->interval("1:0"); is( $t->interval, 60 ); $t->interval("1:0:0"); is( $t->interval, 3600 ); $t->interval("1:1:1"); is( $t->interval, 3661 ); $t->interval("1:1:1.1"); ok( $t->interval > 3661 ); $t->interval("1:1:1.1"); ok( $t->interval <= 3662 ); $t->interval("1:1:1:1"); is( $t->interval, 90061 ); SCOPE: { eval { $t->interval("1:1:1:1:1") }; my $msg = 'IPC::Run: expected <= 4'; $@ =~ /$msg/ ? ok(1) : is( $@, $msg ); } SCOPE: { eval { $t->interval("foo") }; my $msg = 'IPC::Run: non-numeric'; $@ =~ /$msg/ ? ok(1) : is( $@, $msg ); } SCOPE: { eval { $t->interval("1foo1:9:bar:0") }; my $msg = 'IPC::Run: non-numeric'; $@ =~ /$msg/ ? ok(1) : is( $@, $msg ); } SCOPE: { eval { $t->interval("6:4:") }; my $msg = 'IPC::Run: non-numeric'; $@ =~ /$msg/ ? ok(1) : is( $@, $msg ); } $t->reset; $t->interval(5); $t->start( 1, 0 ); ok( !$t->is_expired ); ok( !!$t->is_running ); ok( !$t->is_reset ); ok( !!$t->check(0) ); ok( !$t->is_expired ); ok( !!$t->is_running ); ok( !$t->is_reset ); ok( !!$t->check(1) ); ok( !$t->is_expired ); ok( !!$t->is_running ); ok( !$t->is_reset ); ok( !$t->check(2) ); ok( !!$t->is_expired ); ok( !$t->is_running ); ok( !$t->is_reset ); ok( !$t->check(3) ); ok( !!$t->is_expired ); ok( !$t->is_running ); ok( !$t->is_reset ); ## Restarting from the expired state. $t->start( undef, 0 ); ok( !$t->is_expired ); ok( !!$t->is_running ); ok( !$t->is_reset ); ok( !!$t->check(0) ); ok( !$t->is_expired ); ok( !!$t->is_running ); ok( !$t->is_reset ); ok( !!$t->check(1) ); ok( !$t->is_expired ); ok( !!$t->is_running ); ok( !$t->is_reset ); ok( !$t->check(2) ); ok( !!$t->is_expired ); ok( !$t->is_running ); ok( !$t->is_reset ); ok( !$t->check(3) ); ok( !!$t->is_expired ); ok( !$t->is_running ); ok( !$t->is_reset ); ## Restarting while running $t->start( 1, 0 ); $t->start( undef, 0 ); ok( !$t->is_expired ); ok( !!$t->is_running ); ok( !$t->is_reset ); ok( !!$t->check(0) ); ok( !$t->is_expired ); ok( !!$t->is_running ); ok( !$t->is_reset ); ok( !!$t->check(1) ); ok( !$t->is_expired ); ok( !!$t->is_running ); ok( !$t->is_reset ); ok( !$t->check(2) ); ok( !!$t->is_expired ); ok( !$t->is_running ); ok( !$t->is_reset ); ok( !$t->check(3) ); ok( !!$t->is_expired ); ok( !$t->is_running ); ok( !$t->is_reset ); my $got; eval { $got = "timeout fired"; run [ $^X, '-e', 'sleep 3' ], timeout 1; $got = "timeout didn't fire"; }; is $got, "timeout fired", "timer firing in run()"; IPC-Run-0.96/t/99_perl_minimum_version.t0000644000000000000000000000133713105335071016540 0ustar rootroot#!/usr/bin/perl # Test that our declared minimum Perl version matches our syntax use strict; BEGIN { $| = 1; $^W = 1; } my @MODULES = ( 'Perl::MinimumVersion 1.20', 'Test::MinimumVersion 0.008', ); # Don't run tests during end-user installs use Test::More; unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) { plan( skip_all => "Author tests not required for installation" ); } # Load the testing modules foreach my $MODULE (@MODULES) { eval "use $MODULE"; if ($@) { $ENV{RELEASE_TESTING} ? die("Failed to load required release-testing module $MODULE") : plan( skip_all => "$MODULE not available for testing" ); } } all_minimum_version_from_metayml_ok(); 1; IPC-Run-0.96/t/pump.t0000644000000000000000000000277713105335071012747 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME pump.t - Test suite for IPC::Run::run, etc. =cut use strict; BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More tests => 27; use IPC::Run::Debug qw( _map_fds ); use IPC::Run qw( start pump finish timeout ); ## ## $^X is the path to the perl binary. This is used run all the subprocesses. ## my @echoer = ( $^X, '-pe', 'BEGIN { $| = 1 }' ); my $in; my $out; my $h; my $fd_map; $in = 'SHOULD BE UNCHANGED'; $out = 'REPLACE ME'; $? = 99; $fd_map = _map_fds; $h = start( \@echoer, \$in, \$out, timeout 5 ); ok( $h->isa('IPC::Run') ); is( $?, 99 ); is( $in, 'SHOULD BE UNCHANGED' ); is( $out, '' ); ok( $h->pumpable ); $in = ''; $? = 0; pump_nb $h for ( 1 .. 100 ); ok(1); is( $in, '' ); is( $out, '' ); ok( $h->pumpable ); $in = "hello\n"; $? = 0; pump $h until $out =~ /hello/; ok(1); ok( !$? ); is( $in, '' ); is( $out, "hello\n" ); ok( $h->pumpable ); $in = "world\n"; $? = 0; pump $h until $out =~ /world/; ok(1); ok( !$? ); is( $in, '' ); is( $out, "hello\nworld\n" ); ok( $h->pumpable ); ## Test \G pos() restoral $in = "hello\n"; $out = ""; $? = 0; pump $h until $out =~ /hello\n/g; ok(1); is pos($out), 6, "pos\$out"; $in = "world\n"; $? = 0; pump $h until $out =~ /\Gworld/gc; ok(1); ok( $h->finish ); ok( !$? ); is( _map_fds, $fd_map ); is( $out, "hello\nworld\n" ); ok( !$h->pumpable ); IPC-Run-0.96/t/parallel.t0000644000000000000000000000176513105335071013556 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME parallel.t - Test suite for running multiple processes in parallel. =cut use strict; BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } ## Handy to have when our output is intermingled with debugging output sent ## to the debugging fd. select STDERR; select STDOUT; BEGIN { use Test::More; if ( $^O eq 'MSWin32' ) { plan skip_all => 'Parallel tests are dangerous on MSWin32'; } else { plan tests => 6; } } use IPC::Run qw( start pump finish ); my $text1 = "Hello world 1\n"; my $text2 = "Hello world 2\n"; my @perl = ($^X); my @catter = ( @perl, '-pe1' ); my ( $h1, $h2 ); my ( $out1, $out2 ); $h1 = start \@catter, "<", \$text1, ">", \$out1; ok($h1); $h2 = start \@catter, "<", \$text2, ">", \$out2; ok($h2); pump $h1; ok(1); pump $h2; ok(1); finish $h1; ok(1); finish $h2; ok(1); IPC-Run-0.96/t/windows_search_path.t0000644000000000000000000000163613105335071016012 0ustar rootroot#!perl -w use strict; use warnings; use Test::More tests => 11; use IPC::Run; { no warnings; sub IPC::Run::Win32_MODE { 1 } } is( IPC::Run::Win32_MODE, 1, "We're win32 mode?" ); $^O = 'Win32'; # Proves that files in subdirs with . still work. mkdir '5.11.5'; my @tests = qw( ./temp ./temp.EXE .\\temp .\\temp.EXE ./5.11.5/temp ./5.11.5/temp.EXE ./5.11.5/temp ./5.11.5/temp.BAT ./5.11.5/temp ./5.11.5/temp.COM ); while (@tests) { my $path = shift @tests; my $result = shift @tests; touch($result); my $got = eval { IPC::Run::_search_path($path) }; is( $@, '', "No error calling _search_path for '$path'" ); is( $got, $result, "Executable $result found" ); unlink $result; } exit; sub touch { my $file = shift; open( FH, ">$file" ) or die; print FH 1 or die; close FH or die; chmod( 0700, $file ) or die; } sub END { rmdir('5.11.5'); } IPC-Run-0.96/t/lib/0000755000000000000000000000000013105336354012337 5ustar rootrootIPC-Run-0.96/t/lib/Test.pm0000644000000000000000000000753613105335071013622 0ustar rootrootpackage IPC::Run::Test; use strict; use Test::More; use Exporter; use IPC::Run qw{ harness }; use IPC::Run::IO; use vars qw{@ISA @EXPORT}; BEGIN { @ISA = qw{ Exporter }; @EXPORT = qw{ filter_tests }; } ## This is not needed by most users. Should really move to IPC::Run::TestUtils #=item filter_tests # # my @tests = filter_tests( "foo", "in", "out", \&filter ); # $_->() for ( @tests ); # #This creates a list of test subs that can be used to test most filters #for basic functionality. The first parameter is the name of the #filter to be tested, the second is sample input, the third is the #test(s) to apply to the output(s), and the rest of the parameters are #the filters to be linked and tested. # #If the filter chain is to be fed multiple inputs in sequence, the second #parameter should be a reference to an array of those inputs: # # my @tests = filter_tests( "foo", [qw(1 2 3)], "123", \&filter ); # #If the filter chain should produce a sequence of outputs, then the #third parameter should be a reference to an array of those outputs: # # my @tests = filter_tests( # "foo", # "1\n\2\n", # [ qr/^1$/, qr/^2$/ ], # new_chunker # ); # #See t/run.t and t/filter.t for an example of this in practice. # #=cut ## ## Filter testing routines ## sub filter_tests($;@) { my ( $name, $in, $exp, @filters ) = @_; my @in = ref $in eq 'ARRAY' ? @$in : ($in); my @exp = ref $exp eq 'ARRAY' ? @$exp : ($exp); my IPC::Run::IO $op; my $output; my @input; my $in_count = 0; my @out; my $h; SCOPE: { $h = harness(); $op = IPC::Run::IO->_new_internal( '<', 0, 0, 0, undef, IPC::Run::new_string_sink( \$output ), @filters, IPC::Run::new_string_source( \@input ), ); $op->_init_filters; @input = (); $output = ''; is( !defined $op->_do_filters($h), 1, "$name didn't pass undef (EOF) through" ); } ## See if correctly does nothing on 0, (please try again) SCOPE: { $op->_init_filters; $output = ''; @input = (''); is( $op->_do_filters($h), 0, "$name didn't return 0 (please try again) when given a 0" ); } SCOPE: { @input = (''); is( $op->_do_filters($h), 0, "$name didn't return 0 (please try again) when given a second 0" ); } SCOPE: { for ( 1 .. 100 ) { last unless defined $op->_do_filters($h); } is( !defined $op->_do_filters($h), 1, "$name didn't return undef (EOF) after two 0s and an undef" ); } ## See if it can take @in and make @out SCOPE: { $op->_init_filters; $output = ''; @input = @in; while ( defined $op->_do_filters($h) && @input ) { if ( length $output ) { push @out, $output; $output = ''; } } if ( length $output ) { push @out, $output; $output = ''; } is( scalar @input, 0, "$name didn't consume it's input" ); } SCOPE: { for ( 1 .. 100 ) { last unless defined $op->_do_filters($h); if ( length $output ) { push @out, $output; $output = ''; } } is( !defined $op->_do_filters($h), 1, "$name didn't return undef (EOF), tried 100 times" ); } SCOPE: { is( join( ', ', map "'$_'", @out ), join( ', ', map "'$_'", @exp ), $name ); } SCOPE: { ## Force the harness to be cleaned up. $h = undef; ok(1); } } 1; IPC-Run-0.96/t/io.t0000644000000000000000000000431713105335071012365 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME io.t - Test suite exercising IPC::Run::IO with IPC::Run::run. =cut use strict; BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More tests => 14; use IPC::Run qw( :filters run io ); use IPC::Run::Debug qw( _map_fds ); my $text = "Hello World\n"; my $emitter_script = qq{print '$text'; print STDERR uc( '$text' )}; ## ## $^X is the path to the perl binary. This is used run all the subprocesses. ## my @perl = ($^X); my @emitter = ( @perl, '-e', $emitter_script ); my $recv; my $send; my $in_file = 'io.t.in'; my $out_file = 'io.t.out'; my $err_file = 'io.t.err'; my $io; my $r; my $fd_map; ## TODO: Test filters, etc. sub slurp($) { my ($f) = @_; open( S, "<$f" ) or return "$! '$f'"; my $r = join( '', ); close S or warn "$! closing '$f'"; return $r; } sub spit($$) { my ( $f, $s ) = @_; open( S, ">$f" ) or die "$! '$f'"; print S $s or die "$! '$f'"; close S or die "$! '$f'"; } sub wipe($) { my ($f) = @_; unlink $f or warn "$! unlinking '$f'" if -f $f; } $io = io( 'foo', '<', \$send ); ok $io->isa('IPC::Run::IO'); is( io( 'foo', '<', \$send )->mode, 'w' ); is( io( 'foo', '<<', \$send )->mode, 'wa' ); is( io( 'foo', '>', \$recv )->mode, 'r' ); is( io( 'foo', '>>', \$recv )->mode, 'ra' ); SKIP: { if ( IPC::Run::Win32_MODE() ) { skip( "$^O does not allow select() on non-sockets", 9 ); } ## ## Input from a file ## SCOPE: { spit $in_file, $text; $recv = 'REPLACE ME'; $fd_map = _map_fds; $r = run io( $in_file, '>', \$recv ); wipe $in_file; ok($r); } ok( !$? ); is( _map_fds, $fd_map ); is( $recv, $text ); ## ## Output to a file ## SCOPE: { wipe $out_file; $send = $text; $fd_map = _map_fds; $r = run io( $out_file, '<', \$send ); $recv = slurp $out_file; wipe $out_file; ok($r); } ok( !$? ); is( _map_fds, $fd_map ); is( $send, $text ); is( $recv, $text ); } IPC-Run-0.96/t/bogus.t0000644000000000000000000000175713105335071013102 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME bogus.t - test bogus file cases. =cut use strict; BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More tests => 2; use IPC::Run qw( start ); SCOPE: { ## Older Test.pm's don't grok qr// in $expected. my $expected = 'file not found'; eval { start ["./bogus_really_bogus"] }; my $got = $@ =~ $expected ? $expected : $@ || ""; is( $got, $expected, "starting ./bogus_really_bogus" ); } SKIP: { if ( IPC::Run::Win32_MODE() ) { skip "Can't really exec() $^O", 1; } ## Older Test.pm's don't grok qr// in $expected. my $expected = 'exec failed'; my $h = eval { start( [ $^X, "-e", 1 ], _simulate_exec_failure => 1 ); }; my $got = $@ =~ $expected ? $expected : $@ || ""; is( $got, $expected, "starting $^X with simulated_exec_failure => 1" ); } IPC-Run-0.96/t/harness.t0000644000000000000000000000700413105335071013415 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME harness.t - Test suite for IPC::Run::harness =cut use strict; BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More tests => 120; use IPC::Run qw( harness ); my $f; sub expand_test { my ( $args, $expected ) = @_; my $h; my @out; my $i = 0; SCOPE: { $h = IPC::Run::harness(@$args); @out = @{ $h->{KIDS}->[0]->{OPS} }; is( scalar(@out), scalar(@$expected), join( ' ', @$args ) ); } foreach my $h (@$expected) { my $j = $i++; foreach ( sort keys %$h ) { my ( $key, $value ) = ( $_, $h->{$_} ); my $got = $out[$j]->{$key}; $got = @$got if ref $got eq 'ARRAY'; $got = '' unless defined $got; is( $got, $value, join( ' ', @$args ) . ": $j, $key" ); } } } expand_test( [ ['a'], qw( '<', SOURCE => 'b', KFD => 0, }, { TYPE => '<', SOURCE => 'c', KFD => 0, }, { TYPE => '<', SOURCE => 'd', KFD => 0, }, { TYPE => '<', SOURCE => 'e', KFD => 0, }, { TYPE => '<', SOURCE => 'f', KFD => 1, }, { TYPE => '<', SOURCE => 'g', KFD => 1, }, ] ); expand_test( [ ['a'], qw( >b > c 2>d 2> e >>f >> g 2>>h 2>> i) ], [ { TYPE => '>', DEST => 'b', KFD => 1, TRUNC => 1, }, { TYPE => '>', DEST => 'c', KFD => 1, TRUNC => 1, }, { TYPE => '>', DEST => 'd', KFD => 2, TRUNC => 1, }, { TYPE => '>', DEST => 'e', KFD => 2, TRUNC => 1, }, { TYPE => '>', DEST => 'f', KFD => 1, TRUNC => '', }, { TYPE => '>', DEST => 'g', KFD => 1, TRUNC => '', }, { TYPE => '>', DEST => 'h', KFD => 2, TRUNC => '', }, { TYPE => '>', DEST => 'i', KFD => 2, TRUNC => '', }, ] ); expand_test( [ ['a'], qw( >&b >& c &>d &> e ) ], [ { TYPE => '>', DEST => 'b', KFD => 1, TRUNC => 1, }, { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, { TYPE => '>', DEST => 'c', KFD => 1, TRUNC => 1, }, { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, { TYPE => '>', DEST => 'd', KFD => 1, TRUNC => 1, }, { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, { TYPE => '>', DEST => 'e', KFD => 1, TRUNC => 1, }, { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, ] ); expand_test( [ ['a'], '>&', sub { }, sub { }, \$f, '>', sub { }, sub { }, \$f, '<', sub { }, sub { }, \$f, ], [ { TYPE => '>', DEST => \$f, KFD => 1, TRUNC => 1, FILTERS => 2 }, { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, { TYPE => '>', DEST => \$f, KFD => 1, TRUNC => 1, FILTERS => 2 }, { TYPE => '<', SOURCE => \$f, KFD => 0, FILTERS => 3 }, ] ); expand_test( [ ['a'], '<', \$f, '>', \$f ], [ { TYPE => '<', SOURCE => \$f, KFD => 0, }, { TYPE => '>', DEST => \$f, KFD => 1, }, ] ); expand_test( [ ['a'], 'pipe', \$f ], [ { TYPE => ' \$f, KFD => 0, }, { TYPE => '>pipe', DEST => \$f, KFD => 1, }, ] ); expand_test( [ ['a'], '', \$f ], [ { TYPE => ' \$f, KFD => 0, }, { TYPE => '>', DEST => \$f, KFD => 1, }, ] ); IPC-Run-0.96/t/timeout.t0000644000000000000000000000412413105335071013440 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME timeout.t - Test suite for IPC::Run timeouts =cut use strict; BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } ## Separate from run.t so run.t is not too slow. use Test::More tests => 26; use IPC::Run qw( harness timeout ); my $h; my $t; my $in; my $out; my $started; $h = harness( [$^X], \$in, \$out, $t = timeout(1) ); ok( $h->isa('IPC::Run') ); ok( !!$t->is_reset ); ok( !$t->is_running ); ok( !$t->is_expired ); $started = time; $h->start; ok(1); ok( !$t->is_reset ); ok( !!$t->is_running ); ok( !$t->is_expired ); $in = ''; eval { $h->pump }; # Older perls' Test.pms don't know what to do with qr//s $@ =~ /IPC::Run: timeout/ ? ok(1) : is( $@, qr/IPC::Run: timeout/ ); SCOPE: { my $elapsed = time - $started; $elapsed >= 1 ? ok(1) : is( $elapsed, ">= 1" ); is( $t->interval, 1 ); ok( !$t->is_reset ); ok( !$t->is_running ); ok( !!$t->is_expired ); ## ## Starting from an expired state ## $started = time; $h->start; ok(1); ok( !$t->is_reset ); ok( !!$t->is_running ); ok( !$t->is_expired ); $in = ''; eval { $h->pump }; $@ =~ /IPC::Run: timeout/ ? ok(1) : is( $@, qr/IPC::Run: timeout/ ); ok( !$t->is_reset ); ok( !$t->is_running ); ok( !!$t->is_expired ); } SCOPE: { my $elapsed = time - $started; $elapsed >= 1 ? ok(1) : is( $elapsed, ">= 1" ); $h = harness( [$^X], \$in, \$out, timeout(1) ); $started = time; $h->start; $in = ''; eval { $h->pump }; $@ =~ /IPC::Run: timeout/ ? ok(1) : is( $@, qr/IPC::Run: timeout/ ); } SCOPE: { my $elapsed = time - $started; $elapsed >= 1 ? ok(1) : is( $elapsed, ">= 1" ); } { $h = harness( [ $^X, '-e', 'sleep 1' ], timeout(10), debug => 0 ); my $started_at = time; $h->start; $h->finish; my $finished_at = time; ok( $finished_at - $started_at <= 2, 'not too slow to reap' ) or diag( $finished_at - $started_at . " seconds passed" ); } IPC-Run-0.96/t/adopt.t0000644000000000000000000000346113105335071013064 0ustar rootroot#!/usr/bin/perl =pod =head1 NAME adopt.t - Test suite for IPC::Run::adopt =cut use strict; BEGIN { $| = 1; $^W = 1; if ( $ENV{PERL_CORE} ) { chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; unshift @INC, 'lib', '../..'; $^X = '../../../t/' . $^X; } } use Test::More skip_all => 'adopt not implemented yet'; # use Test::More tests => 29; use IPC::Run qw( start pump finish ); ## ## $^X is the path to the perl binary. This is used run all the subprocesses. ## my @echoer = ( $^X, '-pe', 'BEGIN { $| = 1 }' ); ## ## harness, pump, run ## SCOPE: { my $in = 'SHOULD BE UNCHANGED'; my $out = 'REPLACE ME'; $? = 99; my $fd_map = IPC::Run::_map_fds(); my $h = start( \@echoer, \$in, \$out ); ok( $h->isa('IPC::Run') ); ok( $?, 99 ); ok( $in, 'SHOULD BE UNCHANGED' ); ok( $out, '' ); ok( $h->pumpable ); $in = ''; $? = 0; pump_nb $h for ( 1 .. 100 ); ok(1); ok( $in, '' ); ok( $out, '' ); ok( $h->pumpable ); } SCOPE: { my $in = 'SHOULD BE UNCHANGED'; my $out = 'REPLACE ME'; $? = 99; my $fd_map = IPC::Run::_map_fds(); my $h = start( \@echoer, \$in, \$out ); ok( $h->isa('IPC::Run') ); ok( $?, 99 ); ok( $in, 'SHOULD BE UNCHANGED' ); ok( $out, '' ); ok( $h->pumpable ); $in = "hello\n"; $? = 0; pump $h until $out =~ /hello/; ok(1); ok( !$? ); ok( $in, '' ); ok( $out, "hello\n" ); ok( $h->pumpable ); $in = "world\n"; $? = 0; pump $h until $out =~ /world/; ok(1); ok( !$? ); ok( $in, '' ); ok( $out, "hello\nworld\n" ); ok( $h->pumpable ); warn "hi"; ok( $h->finish ); ok( !$? ); ok( IPC::Run::_map_fds(), $fd_map ); ok( $out, "hello\nworld\n" ); ok( !$h->pumpable ); } IPC-Run-0.96/abuse/0000755000000000000000000000000013105336354012425 5ustar rootrootIPC-Run-0.96/abuse/blocking_writes0000644000000000000000000000203113105335071015524 0ustar rootroot#!/usr/bin/perl ## Submitted by Borislav Deianov ## This stresses the blocking write to see if it blocks. use Fcntl; use IO::Pty; use IPC::Run qw(run); sub makecmd { return [ 'perl', '-e', ', print "\n" x ' . $_[0] . '; while(){last if /end/}' ]; } pipe R, W; fcntl( W, F_SETFL, O_NONBLOCK ); while ( syswrite( W, "\n", 1 ) ) { $pipebuf++ } print "pipe buffer size is $pipebuf\n"; $in = "\n" x ( $pipebuf * 3 ) . "end\n"; print "reading from scalar via pipe... "; run( makecmd( $pipebuf * 3 ), '<', \$in, '>', \$out ); print "done\n"; print "reading from code via pipe... "; run( makecmd( $pipebuf * 3 ), '<', sub { $t = $in; undef $in; $t }, '>', \$out ); print "done\n"; $pty = IO::Pty->new(); $pty->blocking(0); $slave = $pty->slave(); while ( $pty->syswrite( "\n", 1 ) ) { $ptybuf++ } print "pty buffer size is $ptybuf\n"; $in = "\n" x ( $ptybuf * 3 ) . "end\n"; print "reading via pty... "; run( makecmd( $ptybuf * 3 ), '', \$out ); print "done\n"; IPC-Run-0.96/abuse/timers0000644000000000000000000000032213105335071013643 0ustar rootroot#!/usr/local/lib/perl -w use strict; use IPC::Run qw( :all ); $IPC::Run::debug = 10; alarm 5; $SIG{ALRM} = sub { die "timeout never fired!" }; my $out; run [ $^X, '-e', 'sleep 10' ], ">", \$out, timeout 1; IPC-Run-0.96/abuse/blocking_debug_with_sub_coprocess0000644000000000000000000000150013105335071021261 0ustar rootroot#!/opt/i386-linux/perl/bin/perl -w ## Submitted by Blair Zajac ## Tests blocking when piping though a &sub coprocess. ## Fixed, now in test suite. $| = 1; use strict; use Carp; use Symbol; use IPC::Run 0.44 qw(start); print "My pid is $$\n"; my $out_fd = gensym; open( $out_fd, ">ZZZ.test" ) or die "$0: open: $!\n"; my $queue = ''; my @commands = ( [ [ 'cat', '-' ], \$queue, '|' ], [ ['cat'], '|' ], [ \&double, '>', $out_fd ] ); my $harness = start 'debug' => 10, map { @$_ } @commands; $harness or die "$0: harness\n"; close($out_fd) or die "$0: cannot close: $!\n"; for ( 1 .. 100 ) { $queue .= rand(100) . "\n"; $harness->pump; } $harness->finish or die "$0: finish\n"; exit 0; sub double { while () { s/\s+$//; print "$_ $_\n"; } } IPC-Run-0.96/abuse/broken_pipe_on_bad_executable_name0000644000000000000000000000045713105335071021351 0ustar rootroot#!/usr/bin/perl -w ## Submitted by Dave Mitchell use IPC::Run qw(run timeout); $IPC::Run::debug = 10; warn "parent id=$$\n"; $res = run [ './nosuchfile', 0 ], \"foo", \$out, \$err; warn "running after 'run', pid=$$\n\$?=$?\nstderr=[[[[$err]]]]\nstdout=[[[[$out]]]]\n"; IPC-Run-0.96/lib/0000755000000000000000000000000013105336354012074 5ustar rootrootIPC-Run-0.96/lib/IPC/0000755000000000000000000000000013105336354012507 5ustar rootrootIPC-Run-0.96/lib/IPC/Run/0000755000000000000000000000000013105336354013253 5ustar rootrootIPC-Run-0.96/lib/IPC/Run/Debug.pm0000644000000000000000000001716013105336303014636 0ustar rootrootpackage IPC::Run::Debug; =pod =head1 NAME IPC::Run::Debug - debugging routines for IPC::Run =head1 SYNOPSIS ## ## Environment variable usage ## ## To force debugging off and shave a bit of CPU and memory ## by compile-time optimizing away all debugging code in IPC::Run ## (debug => ...) options to IPC::Run will be ignored. export IPCRUNDEBUG=none ## To force debugging on (levels are from 0..10) export IPCRUNDEBUG=basic ## Leave unset or set to "" to compile in debugging support and ## allow runtime control of it using the debug option. =head1 DESCRIPTION Controls IPC::Run debugging. Debugging levels are now set by using words, but the numbers shown are still supported for backwards compatibility: 0 none disabled (special, see below) 1 basic what's running 2 data what's being sent/received 3 details what's going on in more detail 4 gory way too much detail for most uses 10 all use this when submitting bug reports noopts optimizations forbidden due to inherited STDIN The C level is special when the environment variable IPCRUNDEBUG is set to this the first time IPC::Run::Debug is loaded: it prevents the debugging code from being compiled in to the remaining IPC::Run modules, saving a bit of cpu. To do this in a script, here's a way that allows it to be overridden: BEGIN { unless ( defined $ENV{IPCRUNDEBUG} ) { eval 'local $ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"' or die $@; } } This should force IPC::Run to not be debuggable unless somebody sets the IPCRUNDEBUG flag; modify this formula to grep @ARGV if need be: BEGIN { unless ( grep /^--debug/, @ARGV ) { eval 'local $ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"' or die $@; } Both of those are untested. =cut ## We use @EXPORT for the end user's convenience: there's only one function ## exported, it's homonymous with the module, it's an unusual name, and ## it can be suppressed by "use IPC::Run ();". use strict; use Exporter; use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS}; BEGIN { $VERSION = '0.96'; @ISA = qw( Exporter ); @EXPORT = qw( _debug _debug_desc_fd _debugging _debugging_data _debugging_details _debugging_gory_details _debugging_not_optimized _set_child_debug_name ); @EXPORT_OK = qw( _debug_init _debugging_level _map_fds ); %EXPORT_TAGS = ( default => \@EXPORT, all => [ @EXPORT, @EXPORT_OK ], ); } my $disable_debugging = defined $ENV{IPCRUNDEBUG} && ( !$ENV{IPCRUNDEBUG} || lc $ENV{IPCRUNDEBUG} eq "none" ); eval( $disable_debugging ? <<'STUBS' : <<'SUBS' ) or die $@; sub _map_fds() { "" } sub _debug {} sub _debug_desc_fd {} sub _debug_init {} sub _set_child_debug_name {} sub _debugging() { 0 } sub _debugging_level() { 0 } sub _debugging_data() { 0 } sub _debugging_details() { 0 } sub _debugging_gory_details() { 0 } sub _debugging_not_optimized() { 0 } 1; STUBS use POSIX (); sub _map_fds { my $map = ''; my $digit = 0; my $in_use; my $dummy; for my $fd (0..63) { ## I'd like a quicker way (less user, cpu & especially sys and kernel ## calls) to detect open file descriptors. Let me know... ## Hmmm, could do a 0 length read and check for bad file descriptor... ## but that segfaults on Win32 my $test_fd = POSIX::dup( $fd ); $in_use = defined $test_fd; POSIX::close $test_fd if $in_use; $map .= $in_use ? $digit : '-'; $digit = 0 if ++$digit > 9; } warn "No fds open???" unless $map =~ /\d/; $map =~ s/(.{1,12})-*$/$1/; return $map; } use vars qw( $parent_pid ); $parent_pid = $$; ## TODO: move debugging to its own module and make it compile-time ## optimizable. ## Give kid process debugging nice names my $debug_name; sub _set_child_debug_name { $debug_name = shift; } ## There's a bit of hackery going on here. ## ## We want to have any code anywhere be able to emit ## debugging statements without knowing what harness the code is ## being called in/from, since we'd need to pass a harness around to ## everything. ## ## Thus, $cur_self was born. # my %debug_levels = ( none => 0, basic => 1, data => 2, details => 3, gore => 4, gory_details => 4, "gory details" => 4, gory => 4, gorydetails => 4, all => 10, notopt => 0, ); my $warned; sub _debugging_level() { my $level = 0; $level = $IPC::Run::cur_self->{debug} || 0 if $IPC::Run::cur_self && ( $IPC::Run::cur_self->{debug} || 0 ) >= $level; if ( defined $ENV{IPCRUNDEBUG} ) { my $v = $ENV{IPCRUNDEBUG}; $v = $debug_levels{lc $v} if $v =~ /[a-zA-Z]/; unless ( defined $v ) { $warned ||= warn "Unknown debug level $ENV{IPCRUNDEBUG}, assuming 'basic' (1)\n"; $v = 1; } $level = $v if $v > $level; } return $level; } sub _debugging_atleast($) { my $min_level = shift || 1; my $level = _debugging_level; return $level >= $min_level ? $level : 0; } sub _debugging() { _debugging_atleast 1 } sub _debugging_data() { _debugging_atleast 2 } sub _debugging_details() { _debugging_atleast 3 } sub _debugging_gory_details() { _debugging_atleast 4 } sub _debugging_not_optimized() { ( $ENV{IPCRUNDEBUG} || "" ) eq "notopt" } sub _debug_init { ## This routine is called only in spawned children to fake out the ## debug routines so they'll emit debugging info. $IPC::Run::cur_self = {}; ( $parent_pid, $^T, $IPC::Run::cur_self->{debug}, $IPC::Run::cur_self->{DEBUG_FD}, $debug_name ) = @_; } sub _debug { # return unless _debugging || _debugging_not_optimized; my $fd = defined &IPC::Run::_debug_fd ? IPC::Run::_debug_fd() : fileno STDERR; my $s; my $debug_id; $debug_id = join( " ", join( "", defined $IPC::Run::cur_self ? "#$IPC::Run::cur_self->{ID}" : (), "($$)", ), defined $debug_name && length $debug_name ? $debug_name : (), ); my $prefix = join( "", "IPC::Run", sprintf( " %04d", time - $^T ), ( _debugging_details ? ( " ", _map_fds ) : () ), length $debug_id ? ( " [", $debug_id, "]" ) : (), ": ", ); my $msg = join( '', map defined $_ ? $_ : "", @_ ); chomp $msg; $msg =~ s{^}{$prefix}gm; $msg .= "\n"; POSIX::write( $fd, $msg, length $msg ); } my @fd_descs = ( 'stdin', 'stdout', 'stderr' ); sub _debug_desc_fd { return unless _debugging; my $text = shift; my $op = pop; my $kid = $_[0]; Carp::carp join " ", caller(0), $text, $op if defined $op && UNIVERSAL::isa( $op, "IO::Pty" ); _debug( $text, ' ', ( defined $op->{FD} ? $op->{FD} < 3 ? ( $fd_descs[$op->{FD}] ) : ( 'fd ', $op->{FD} ) : $op->{FD} ), ( defined $op->{KFD} ? ( ' (kid', ( defined $kid ? ( ' ', $kid->{NUM}, ) : () ), "'s ", ( $op->{KFD} < 3 ? $fd_descs[$op->{KFD}] : defined $kid && defined $kid->{DEBUG_FD} && $op->{KFD} == $kid->{DEBUG_FD} ? ( 'debug (', $op->{KFD}, ')' ) : ( 'fd ', $op->{KFD} ) ), ')', ) : () ), ); } 1; SUBS =pod =head1 AUTHOR Barrie Slaymaker , with numerous suggestions by p5p. =cut IPC-Run-0.96/lib/IPC/Run/Timer.pm0000644000000000000000000004070713105336303014673 0ustar rootrootpackage IPC::Run::Timer; =pod =head1 NAME IPC::Run::Timer -- Timer channels for IPC::Run. =head1 SYNOPSIS use IPC::Run qw( run timer timeout ); ## or IPC::Run::Timer ( timer timeout ); ## or IPC::Run::Timer ( :all ); ## A non-fatal timer: $t = timer( 5 ); # or... $t = IO::Run::Timer->new( 5 ); run $t, ...; ## A timeout (which is a timer that dies on expiry): $t = timeout( 5 ); # or... $t = IO::Run::Timer->new( 5, exception => "harness timed out" ); =head1 DESCRIPTION This class and module allows timers and timeouts to be created for use by IPC::Run. A timer simply expires when it's time is up. A timeout is a timer that throws an exception when it expires. Timeouts are usually a bit simpler to use than timers: they throw an exception on expiration so you don't need to check them: ## Give @cmd 10 seconds to get started, then 5 seconds to respond my $t = timeout( 10 ); $h = start( \@cmd, \$in, \$out, $t, ); pump $h until $out =~ /prompt/; $in = "some stimulus"; $out = ''; $t->time( 5 ) pump $h until $out =~ /expected response/; You do need to check timers: ## Give @cmd 10 seconds to get started, then 5 seconds to respond my $t = timer( 10 ); $h = start( \@cmd, \$in, \$out, $t, ); pump $h until $t->is_expired || $out =~ /prompt/; $in = "some stimulus"; $out = ''; $t->time( 5 ) pump $h until $out =~ /expected response/ || $t->is_expired; Timers and timeouts that are reset get started by start() and pump(). Timers change state only in pump(). Since run() and finish() both call pump(), they act like pump() with respect to timers. Timers and timeouts have three states: reset, running, and expired. Setting the timeout value resets the timer, as does calling the reset() method. The start() method starts (or restarts) a timer with the most recently set time value, no matter what state it's in. =head2 Time values All time values are in seconds. Times may be any kind of perl number, e.g. as integer or floating point seconds, optionally preceded by punctuation-separated days, hours, and minutes. Examples: 1 1 second 1.1 1.1 seconds 60 60 seconds 1:0 1 minute 1:1 1 minute, 1 second 1:90 2 minutes, 30 seconds 1:2:3:4.5 1 day, 2 hours, 3 minutes, 4.5 seconds 'inf' the infinity perl special number (the timer never finishes) Absolute date/time strings are *not* accepted: year, month and day-of-month parsing is not available (patches welcome :-). =head2 Interval fudging When calculating an end time from a start time and an interval, IPC::Run::Timer instances add a little fudge factor. This is to ensure that no time will expire before the interval is up. First a little background. Time is sampled in discrete increments. We'll call the exact moment that the reported time increments from one interval to the next a tick, and the interval between ticks as the time period. Here's a diagram of three ticks and the periods between them: -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-... ^ ^ ^ |<--- period 0 ---->|<--- period 1 ---->| | | | tick 0 tick 1 tick 2 To see why the fudge factor is necessary, consider what would happen when a timer with an interval of 1 second is started right at the end of period 0: -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-... ^ ^ ^ ^ | | | | | | | | tick 0 |tick 1 tick 2 | start $t Assuming that check() is called many times per period, then the timer is likely to expire just after tick 1, since the time reported will have lept from the value '0' to the value '1': -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-... ^ ^ ^ ^ ^ | | | | | | | | | | tick 0 |tick 1| tick 2 | | start $t | | check $t Adding a fudge of '1' in this example means that the timer is guaranteed not to expire before tick 2. The fudge is not added to an interval of '0'. This means that intervals guarantee a minimum interval. Given that the process running perl may be suspended for some period of time, or that it gets busy doing something time-consuming, there are no other guarantees on how long it will take a timer to expire. =head1 SUBCLASSING INCOMPATIBLE CHANGE: Due to the awkwardness introduced by ripping pseudohashes out of Perl, this class I uses the fields pragma. =head1 FUNCTIONS & METHODS =over =cut use strict; use Carp; use Fcntl; use Symbol; use Exporter; use Scalar::Util (); use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS ); BEGIN { $VERSION = '0.96'; @ISA = qw( Exporter ); @EXPORT_OK = qw( check end_time exception expire interval is_expired is_reset is_running name reset start timeout timer ); %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); } require IPC::Run; use IPC::Run::Debug; ## ## Some helpers ## my $resolution = 1; sub _parse_time { for ( $_[0] ) { my $val; if ( not defined $_ ) { $val = $_; } else { my @f = split( /:/, $_, -1 ); if ( scalar @f > 4 ) { croak "IPC::Run: expected <= 4 elements in time string '$_'"; } for (@f) { if ( not Scalar::Util::looks_like_number($_) ) { croak "IPC::Run: non-numeric element '$_' in time string '$_'"; } } my ( $s, $m, $h, $d ) = reverse @f; $val = ( ( ( $d || 0 ) * 24 + ( $h || 0 ) ) * 60 + ( $m || 0 ) ) * 60 + ( $s || 0 ); } return $val; } } sub _calc_end_time { my IPC::Run::Timer $self = shift; my $interval = $self->interval; $interval += $resolution if $interval; $self->end_time( $self->start_time + $interval ); } =item timer A constructor function (not method) of IPC::Run::Timer instances: $t = timer( 5 ); $t = timer( 5, name => 'stall timer', debug => 1 ); $t = timer; $t->interval( 5 ); run ..., $t; run ..., $t = timer( 5 ); This convenience function is a shortened spelling of IPC::Run::Timer->new( ... ); . It returns a timer in the reset state with a given interval. If an exception is provided, it will be thrown when the timer notices that it has expired (in check()). The name is for debugging usage, if you plan on having multiple timers around. If no name is provided, a name like "timer #1" will be provided. =cut sub timer { return IPC::Run::Timer->new(@_); } =item timeout A constructor function (not method) of IPC::Run::Timer instances: $t = timeout( 5 ); $t = timeout( 5, exception => "kablooey" ); $t = timeout( 5, name => "stall", exception => "kablooey" ); $t = timeout; $t->interval( 5 ); run ..., $t; run ..., $t = timeout( 5 ); A This convenience function is a shortened spelling of IPC::Run::Timer->new( exception => "IPC::Run: timeout ...", ... ); . It returns a timer in the reset state that will throw an exception when it expires. Takes the same parameters as L, any exception passed in overrides the default exception. =cut sub timeout { my $t = IPC::Run::Timer->new(@_); $t->exception( "IPC::Run: timeout on " . $t->name ) unless defined $t->exception; return $t; } =item new IPC::Run::Timer->new() ; IPC::Run::Timer->new( 5 ) ; IPC::Run::Timer->new( 5, exception => 'kablooey' ) ; Constructor. See L for details. =cut my $timer_counter; sub new { my $class = shift; $class = ref $class || $class; my IPC::Run::Timer $self = bless {}, $class; $self->{STATE} = 0; $self->{DEBUG} = 0; $self->{NAME} = "timer #" . ++$timer_counter; while (@_) { my $arg = shift; if ( $arg eq 'exception' ) { $self->exception(shift); } elsif ( $arg eq 'name' ) { $self->name(shift); } elsif ( $arg eq 'debug' ) { $self->debug(shift); } else { $self->interval($arg); } } _debug $self->name . ' constructed' if $self->{DEBUG} || _debugging_details; return $self; } =item check check $t; check $t, $now; $t->check; Checks to see if a timer has expired since the last check. Has no effect on non-running timers. This will throw an exception if one is defined. IPC::Run::pump() calls this routine for any timers in the harness. You may pass in a version of now, which is useful in case you have it lying around or you want to check several timers with a consistent concept of the current time. Returns the time left before end_time or 0 if end_time is no longer in the future or the timer is not running (unless, of course, check() expire()s the timer and this results in an exception being thrown). Returns undef if the timer is not running on entry, 0 if check() expires it, and the time left if it's left running. =cut sub check { my IPC::Run::Timer $self = shift; return undef if !$self->is_running; return 0 if $self->is_expired; my ($now) = @_; $now = _parse_time($now); $now = time unless defined $now; _debug( "checking ", $self->name, " (end time ", $self->end_time, ") at ", $now ) if $self->{DEBUG} || _debugging_details; my $left = $self->end_time - $now; return $left if $left > 0; $self->expire; return 0; } =item debug Sets/gets the current setting of the debugging flag for this timer. This has no effect if debugging is not enabled for the current harness. =cut sub debug { my IPC::Run::Timer $self = shift; $self->{DEBUG} = shift if @_; return $self->{DEBUG}; } =item end_time $et = $t->end_time; $et = end_time $t; $t->end_time( time + 10 ); Returns the time when this timer will or did expire. Even if this time is in the past, the timer may not be expired, since check() may not have been called yet. Note that this end_time is not start_time($t) + interval($t), since some small extra amount of time is added to make sure that the timer does not expire before interval() elapses. If this were not so, then Changing end_time() while a timer is running will set the expiration time. Changing it while it is expired has no affect, since reset()ing a timer always clears the end_time(). =cut sub end_time { my IPC::Run::Timer $self = shift; if (@_) { $self->{END_TIME} = shift; _debug $self->name, ' end_time set to ', $self->{END_TIME} if $self->{DEBUG} > 2 || _debugging_details; } return $self->{END_TIME}; } =item exception $x = $t->exception; $t->exception( $x ); $t->exception( undef ); Sets/gets the exception to throw, if any. 'undef' means that no exception will be thrown. Exception does not need to be a scalar: you may ask that references be thrown. =cut sub exception { my IPC::Run::Timer $self = shift; if (@_) { $self->{EXCEPTION} = shift; _debug $self->name, ' exception set to ', $self->{EXCEPTION} if $self->{DEBUG} || _debugging_details; } return $self->{EXCEPTION}; } =item interval $i = interval $t; $i = $t->interval; $t->interval( $i ); Sets the interval. Sets the end time based on the start_time() and the interval (and a little fudge) if the timer is running. =cut sub interval { my IPC::Run::Timer $self = shift; if (@_) { $self->{INTERVAL} = _parse_time(shift); _debug $self->name, ' interval set to ', $self->{INTERVAL} if $self->{DEBUG} > 2 || _debugging_details; $self->_calc_end_time if $self->state; } return $self->{INTERVAL}; } =item expire expire $t; $t->expire; Sets the state to expired (undef). Will throw an exception if one is defined and the timer was not already expired. You can expire a reset timer without starting it. =cut sub expire { my IPC::Run::Timer $self = shift; if ( defined $self->state ) { _debug $self->name . ' expired' if $self->{DEBUG} || _debugging; $self->state(undef); croak $self->exception if $self->exception; } return undef; } =item is_running =cut sub is_running { my IPC::Run::Timer $self = shift; return $self->state ? 1 : 0; } =item is_reset =cut sub is_reset { my IPC::Run::Timer $self = shift; return defined $self->state && $self->state == 0; } =item is_expired =cut sub is_expired { my IPC::Run::Timer $self = shift; return !defined $self->state; } =item name Sets/gets this timer's name. The name is only used for debugging purposes so you can tell which freakin' timer is doing what. =cut sub name { my IPC::Run::Timer $self = shift; $self->{NAME} = shift if @_; return defined $self->{NAME} ? $self->{NAME} : defined $self->{EXCEPTION} ? 'timeout' : 'timer'; } =item reset reset $t; $t->reset; Resets the timer to the non-running, non-expired state and clears the end_time(). =cut sub reset { my IPC::Run::Timer $self = shift; $self->state(0); $self->end_time(undef); _debug $self->name . ' reset' if $self->{DEBUG} || _debugging; return undef; } =item start start $t; $t->start; start $t, $interval; start $t, $interval, $now; Starts or restarts a timer. This always sets the start_time. It sets the end_time based on the interval if the timer is running or if no end time has been set. You may pass an optional interval or current time value. Not passing a defined interval causes the previous interval setting to be re-used unless the timer is reset and an end_time has been set (an exception is thrown if no interval has been set). Not passing a defined current time value causes the current time to be used. Passing a current time value is useful if you happen to have a time value lying around or if you want to make sure that several timers are started with the same concept of start time. You might even need to lie to an IPC::Run::Timer, occasionally. =cut sub start { my IPC::Run::Timer $self = shift; my ( $interval, $now ) = map { _parse_time($_) } @_; $now = _parse_time($now); $now = time unless defined $now; $self->interval($interval) if defined $interval; ## start()ing a running or expired timer clears the end_time, so that the ## interval is used. So does specifying an interval. $self->end_time(undef) if !$self->is_reset || $interval; croak "IPC::Run: no timer interval or end_time defined for " . $self->name unless defined $self->interval || defined $self->end_time; $self->state(1); $self->start_time($now); ## The "+ 1" is in case the START_TIME was sampled at the end of a ## tick (which are one second long in this module). $self->_calc_end_time unless defined $self->end_time; _debug( $self->name, " started at ", $self->start_time, ", with interval ", $self->interval, ", end_time ", $self->end_time ) if $self->{DEBUG} || _debugging; return undef; } =item start_time Sets/gets the start time, in seconds since the epoch. Setting this manually is a bad idea, it's better to call L() at the correct time. =cut sub start_time { my IPC::Run::Timer $self = shift; if (@_) { $self->{START_TIME} = _parse_time(shift); _debug $self->name, ' start_time set to ', $self->{START_TIME} if $self->{DEBUG} > 2 || _debugging; } return $self->{START_TIME}; } =item state $s = state $t; $t->state( $s ); Get/Set the current state. Only use this if you really need to transfer the state to/from some variable. Use L, L, L, L, L, L. Note: Setting the state to 'undef' to expire a timer will not throw an exception. =back =cut sub state { my IPC::Run::Timer $self = shift; if (@_) { $self->{STATE} = shift; _debug $self->name, ' state set to ', $self->{STATE} if $self->{DEBUG} > 2 || _debugging; } return $self->{STATE}; } 1; =pod =head1 TODO use Time::HiRes; if it's present. Add detection and parsing of [[[HH:]MM:]SS formatted times and intervals. =head1 AUTHOR Barrie Slaymaker =cut IPC-Run-0.96/lib/IPC/Run/Win32Pump.pm0000644000000000000000000001221413105336303015347 0ustar rootrootpackage IPC::Run::Win32Pump; =pod =head1 NAME IPC::Run::Win32Pump - helper processes to shovel data to/from parent, child =head1 SYNOPSIS Internal use only; see IPC::Run::Win32IO and best of luck to you. =head1 DESCRIPTION See L for details. This module is used in subprocesses that are spawned to shovel data to/from parent processes from/to their child processes. Where possible, pumps are optimized away. NOTE: This is not a real module: it's a script in module form, designed to be run like $^X -MIPC::Run::Win32Pumper -e 1 ... It parses a bunch of command line parameters from IPC::Run::Win32IO. =cut use strict; use vars qw{$VERSION}; BEGIN { $VERSION = '0.96'; } use Win32API::File qw( OsFHandleOpen ); my ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label ); BEGIN { ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label ) = @ARGV; ## Rather than letting IPC::Run::Debug export all-0 constants ## when not debugging, we do it manually in order to not even ## load IPC::Run::Debug. if ($debug) { eval "use IPC::Run::Debug qw( :default _debug_init ); 1;" or die $@; } else { eval < 100; $msg =~ s/\n/\\n/g; $msg =~ s/\r/\\r/g; $msg =~ s/\t/\\t/g; $msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg; _debug sprintf( "%5d chars revc: ", $count ), $msg; } $total_count += $count; $buf =~ s/\r//g unless $binmode; if (_debugging_gory_details) { my $msg = "'$buf'"; substr( $msg, 100, -1 ) = '...' if length $msg > 100; $msg =~ s/\n/\\n/g; $msg =~ s/\r/\\r/g; $msg =~ s/\t/\\t/g; $msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg; _debug sprintf( "%5d chars sent: ", $count ), $msg; } print $buf; } _debug "Exiting, transferred $total_count chars" if _debugging_details; ## Perform a graceful socket shutdown. Windows defaults to SO_DONTLINGER, ## which should cause a "graceful shutdown in the background" on sockets. ## but that's only true if the process closes the socket manually, it ## seems; if the process exits and lets the OS clean up, the OS is not ## so kind. STDOUT is not always a socket, of course, but it won't hurt ## to close a pipe and may even help. With a closed source OS, who ## can tell? ## ## In any case, this close() is one of the main reasons we have helper ## processes; if the OS closed socket fds gracefully when an app exits, ## we'd just redirect the client directly to what is now the pump end ## of the socket. As it is, however, we need to let the client play with ## pipes, which don't have the abort-on-app-exit behavior, and then ## adapt to the sockets in the helper processes to allow the parent to ## select. ## ## Possible alternatives / improvements: ## ## 1) use helper threads instead of processes. I don't trust perl's threads ## as of 5.005 or 5.6 enough (which may be myopic of me). ## ## 2) figure out if/how to get at WaitForMultipleObjects() with pipe ## handles. May be able to take the Win32 handle and pass it to ## Win32::Event::wait_any, dunno. ## ## 3) Use Inline::C or a hand-tooled XS module to do helper threads. ## This would be faster than #1, but would require a ppm distro. ## close STDOUT; close STDERR; 1; =pod =head1 AUTHOR Barries Slaymaker . Funded by Perforce Software, Inc. =head1 COPYRIGHT Copyright 2001, Barrie Slaymaker, All Rights Reserved. You may use this under the terms of either the GPL 2.0 ir the Artistic License. =cut IPC-Run-0.96/lib/IPC/Run/IO.pm0000644000000000000000000003455113105336303014122 0ustar rootrootpackage IPC::Run::IO; =head1 NAME IPC::Run::IO -- I/O channels for IPC::Run. =head1 SYNOPSIS B use IPC::Run qw( io ); ## The sense of '>' and '<' is opposite of perl's open(), ## but agrees with IPC::Run. $io = io( "filename", '>', \$recv ); $io = io( "filename", 'r', \$recv ); ## Append to $recv: $io = io( "filename", '>>', \$recv ); $io = io( "filename", 'ra', \$recv ); $io = io( "filename", '<', \$send ); $io = io( "filename", 'w', \$send ); $io = io( "filename", '<<', \$send ); $io = io( "filename", 'wa', \$send ); ## Handles / IO objects that the caller opens: $io = io( \*HANDLE, '<', \$send ); $f = IO::Handle->new( ... ); # Any subclass of IO::Handle $io = io( $f, '<', \$send ); require IPC::Run::IO; $io = IPC::Run::IO->new( ... ); ## Then run(), harness(), or start(): run $io, ...; ## You can, of course, use io() or IPC::Run::IO->new() as an ## argument to run(), harness, or start(): run io( ... ); =head1 DESCRIPTION This class and module allows filehandles and filenames to be harnessed for I/O when used IPC::Run, independent of anything else IPC::Run is doing (except that errors & exceptions can affect all things that IPC::Run is doing). =head1 SUBCLASSING INCOMPATIBLE CHANGE: due to the awkwardness introduced in ripping pseudohashes out of Perl, this class I uses the fields pragma. =cut ## This class is also used internally by IPC::Run in a very intimate way, ## since this is a partial factoring of code from IPC::Run plus some code ## needed to do standalone channels. This factoring process will continue ## at some point. Don't know how far how fast. use strict; use Carp; use Fcntl; use Symbol; use IPC::Run::Debug; use IPC::Run qw( Win32_MODE ); use vars qw{$VERSION}; BEGIN { $VERSION = '0.96'; if (Win32_MODE) { eval "use IPC::Run::Win32Helper; require IPC::Run::Win32IO; 1" or ( $@ && die ) or die "$!"; } } sub _empty($); *_empty = \&IPC::Run::_empty; =head1 SUBROUTINES =over 4 =item new I think it takes >> or << along with some other data. TODO: Needs more thorough documentation. Patches welcome. =cut sub new { my $class = shift; $class = ref $class || $class; my ( $external, $type, $internal ) = ( shift, shift, pop ); croak "$class: '$_' is not a valid I/O operator" unless $type =~ /^(?:<>?)$/; my IPC::Run::IO $self = $class->_new_internal( $type, undef, undef, $internal, undef, @_ ); if ( !ref $external ) { $self->{FILENAME} = $external; } elsif ( ref eq 'GLOB' || UNIVERSAL::isa( $external, 'IO::Handle' ) ) { $self->{HANDLE} = $external; $self->{DONT_CLOSE} = 1; } else { croak "$class: cannot accept " . ref($external) . " to do I/O with"; } return $self; } ## IPC::Run uses this ctor, since it preparses things and needs more ## smarts. sub _new_internal { my $class = shift; $class = ref $class || $class; $class = "IPC::Run::Win32IO" if Win32_MODE && $class eq "IPC::Run::IO"; my IPC::Run::IO $self; $self = bless {}, $class; my ( $type, $kfd, $pty_id, $internal, $binmode, @filters ) = @_; # Older perls (<=5.00503, at least) don't do list assign to # psuedo-hashes well. $self->{TYPE} = $type; $self->{KFD} = $kfd; $self->{PTY_ID} = $pty_id; $self->binmode($binmode); $self->{FILTERS} = [@filters]; ## Add an adapter to the end of the filter chain (which is usually just the ## read/writer sub pushed by IPC::Run) to the DEST or SOURCE, if need be. if ( $self->op =~ />/ ) { croak "'$_' missing a destination" if _empty $internal; $self->{DEST} = $internal; if ( UNIVERSAL::isa( $self->{DEST}, 'CODE' ) ) { ## Put a filter on the end of the filter chain to pass the ## output on to the CODE ref. For SCALAR refs, the last ## filter in the chain writes directly to the scalar itself. See ## _init_filters(). For CODE refs, however, we need to adapt from ## the SCALAR to calling the CODE. unshift( @{ $self->{FILTERS} }, sub { my ($in_ref) = @_; return IPC::Run::input_avail() && do { $self->{DEST}->($$in_ref); $$in_ref = ''; 1; } } ); } } else { croak "'$_' missing a source" if _empty $internal; $self->{SOURCE} = $internal; if ( UNIVERSAL::isa( $internal, 'CODE' ) ) { push( @{ $self->{FILTERS} }, sub { my ( $in_ref, $out_ref ) = @_; return 0 if length $$out_ref; return undef if $self->{SOURCE_EMPTY}; my $in = $internal->(); unless ( defined $in ) { $self->{SOURCE_EMPTY} = 1; return undef; } return 0 unless length $in; $$out_ref = $in; return 1; } ); } elsif ( UNIVERSAL::isa( $internal, 'SCALAR' ) ) { push( @{ $self->{FILTERS} }, sub { my ( $in_ref, $out_ref ) = @_; return 0 if length $$out_ref; ## pump() clears auto_close_ins, finish() sets it. return $self->{HARNESS}->{auto_close_ins} ? undef : 0 if IPC::Run::_empty ${ $self->{SOURCE} } || $self->{SOURCE_EMPTY}; $$out_ref = $$internal; eval { $$internal = '' } if $self->{HARNESS}->{clear_ins}; $self->{SOURCE_EMPTY} = $self->{HARNESS}->{auto_close_ins}; return 1; } ); } } return $self; } =item filename Gets/sets the filename. Returns the value after the name change, if any. =cut sub filename { my IPC::Run::IO $self = shift; $self->{FILENAME} = shift if @_; return $self->{FILENAME}; } =item init Does initialization required before this can be run. This includes open()ing the file, if necessary, and clearing the destination scalar if necessary. =cut sub init { my IPC::Run::IO $self = shift; $self->{SOURCE_EMPTY} = 0; ${ $self->{DEST} } = '' if $self->mode =~ /r/ && ref $self->{DEST} eq 'SCALAR'; $self->open if defined $self->filename; $self->{FD} = $self->fileno; if ( !$self->{FILTERS} ) { $self->{FBUFS} = undef; } else { @{ $self->{FBUFS} } = map { my $s = ""; \$s; } ( @{ $self->{FILTERS} }, '' ); $self->{FBUFS}->[0] = $self->{DEST} if $self->{DEST} && ref $self->{DEST} eq 'SCALAR'; push @{ $self->{FBUFS} }, $self->{SOURCE}; } return undef; } =item open If a filename was passed in, opens it. Determines if the handle is open via fileno(). Throws an exception on error. =cut my %open_flags = ( '>' => O_RDONLY, '>>' => O_RDONLY, '<' => O_WRONLY | O_CREAT | O_TRUNC, '<<' => O_WRONLY | O_CREAT | O_APPEND, ); sub open { my IPC::Run::IO $self = shift; croak "IPC::Run::IO: Can't open() a file with no name" unless defined $self->{FILENAME}; $self->{HANDLE} = gensym unless $self->{HANDLE}; _debug "opening '", $self->filename, "' mode '", $self->mode, "'" if _debugging_data; sysopen( $self->{HANDLE}, $self->filename, $open_flags{ $self->op }, ) or croak "IPC::Run::IO: $! opening '$self->{FILENAME}', mode '" . $self->mode . "'"; return undef; } =item open_pipe If this is a redirection IO object, this opens the pipe in a platform independent manner. =cut sub _do_open { my $self = shift; my ( $child_debug_fd, $parent_handle ) = @_; if ( $self->dir eq "<" ) { ( $self->{TFD}, $self->{FD} ) = IPC::Run::_pipe_nb; if ($parent_handle) { CORE::open $parent_handle, ">&=$self->{FD}" or croak "$! duping write end of pipe for caller"; } } else { ( $self->{FD}, $self->{TFD} ) = IPC::Run::_pipe; if ($parent_handle) { CORE::open $parent_handle, "<&=$self->{FD}" or croak "$! duping read end of pipe for caller"; } } } sub open_pipe { my IPC::Run::IO $self = shift; ## Hmmm, Maybe allow named pipes one day. But until then... croak "IPC::Run::IO: Can't pipe() when a file name has been set" if defined $self->{FILENAME}; $self->_do_open(@_); ## return ( child_fd, parent_fd ) return $self->dir eq "<" ? ( $self->{TFD}, $self->{FD} ) : ( $self->{FD}, $self->{TFD} ); } sub _cleanup { ## Called from Run.pm's _cleanup my $self = shift; undef $self->{FAKE_PIPE}; } =item close Closes the handle. Throws an exception on failure. =cut sub close { my IPC::Run::IO $self = shift; if ( defined $self->{HANDLE} ) { close $self->{HANDLE} or croak( "IPC::Run::IO: $! closing " . ( defined $self->{FILENAME} ? "'$self->{FILENAME}'" : "handle" ) ); } else { IPC::Run::_close( $self->{FD} ); } $self->{FD} = undef; return undef; } =item fileno Returns the fileno of the handle. Throws an exception on failure. =cut sub fileno { my IPC::Run::IO $self = shift; my $fd = fileno $self->{HANDLE}; croak( "IPC::Run::IO: $! " . ( defined $self->{FILENAME} ? "'$self->{FILENAME}'" : "handle" ) ) unless defined $fd; return $fd; } =item mode Returns the operator in terms of 'r', 'w', and 'a'. There is a state 'ra', unlike Perl's open(), which indicates that data read from the handle or file will be appended to the output if the output is a scalar. This is only meaningful if the output is a scalar, it has no effect if the output is a subroutine. The redirection operators can be a little confusing, so here's a reference table: > r Read from handle in to process < w Write from process out to handle >> ra Read from handle in to process, appending it to existing data if the destination is a scalar. << wa Write from process out to handle, appending to existing data if IPC::Run::IO opened a named file. =cut sub mode { my IPC::Run::IO $self = shift; croak "IPC::Run::IO: unexpected arguments for mode(): @_" if @_; ## TODO: Optimize this return ( $self->{TYPE} =~ /{TYPE} =~ /<<|>>/ ? 'a' : '' ); } =item op Returns the operation: '<', '>', '<<', '>>'. See L if you want to spell these 'r', 'w', etc. =cut sub op { my IPC::Run::IO $self = shift; croak "IPC::Run::IO: unexpected arguments for op(): @_" if @_; return $self->{TYPE}; } =item binmode Sets/gets whether this pipe is in binmode or not. No effect off of Win32 OSs, of course, and on Win32, no effect after the harness is start()ed. =cut sub binmode { my IPC::Run::IO $self = shift; $self->{BINMODE} = shift if @_; return $self->{BINMODE}; } =item dir Returns the first character of $self->op. This is either "<" or ">". =cut sub dir { my IPC::Run::IO $self = shift; croak "IPC::Run::IO: unexpected arguments for dir(): @_" if @_; return substr $self->{TYPE}, 0, 1; } ## ## Filter Scaffolding ## #my $filter_op ; ## The op running a filter chain right now #my $filter_num; ## Which filter is being run right now. use vars ( '$filter_op', ## The op running a filter chain right now '$filter_num' ## Which filter is being run right now. ); sub _init_filters { my IPC::Run::IO $self = shift; confess "\$self not an IPC::Run::IO" unless UNIVERSAL::isa( $self, "IPC::Run::IO" ); $self->{FBUFS} = []; $self->{FBUFS}->[0] = $self->{DEST} if $self->{DEST} && ref $self->{DEST} eq 'SCALAR'; return unless $self->{FILTERS} && @{ $self->{FILTERS} }; push @{ $self->{FBUFS} }, map { my $s = ""; \$s; } ( @{ $self->{FILTERS} }, '' ); push @{ $self->{FBUFS} }, $self->{SOURCE}; } =item poll TODO: Needs confirmation that this is correct. Was previously undocumented. I believe this is polling the IO for new input and then returns undef if there will never be any more input, 0 if there is none now, but there might be in the future, and TRUE if more input was gotten. =cut sub poll { my IPC::Run::IO $self = shift; my ($harness) = @_; if ( defined $self->{FD} ) { my $d = $self->dir; if ( $d eq "<" ) { if ( vec $harness->{WOUT}, $self->{FD}, 1 ) { _debug_desc_fd( "filtering data to", $self ) if _debugging_details; return $self->_do_filters($harness); } } elsif ( $d eq ">" ) { if ( vec $harness->{ROUT}, $self->{FD}, 1 ) { _debug_desc_fd( "filtering data from", $self ) if _debugging_details; return $self->_do_filters($harness); } } } return 0; } sub _do_filters { my IPC::Run::IO $self = shift; ( $self->{HARNESS} ) = @_; my ( $saved_op, $saved_num ) = ( $IPC::Run::filter_op, $IPC::Run::filter_num ); $IPC::Run::filter_op = $self; $IPC::Run::filter_num = -1; my $redos = 0; my $r; { $@ = ''; $r = eval { IPC::Run::get_more_input(); }; # Detect Resource temporarily unavailable and re-try 200 times (2 seconds), assuming select behaves (which it doesn't always? need ref) if ( ( $@ || '' ) =~ $IPC::Run::_EAGAIN && $redos++ < 200 ) { select( undef, undef, undef, 0.01 ); redo; } } ( $IPC::Run::filter_op, $IPC::Run::filter_num ) = ( $saved_op, $saved_num ); $self->{HARNESS} = undef; die "ack ", $@ if $@; return $r; } =back =head1 AUTHOR Barrie Slaymaker =head1 TODO Implement bidirectionality. =cut 1; IPC-Run-0.96/lib/IPC/Run/Win32Helper.pm0000644000000000000000000004204713105336303015654 0ustar rootrootpackage IPC::Run::Win32Helper; =pod =head1 NAME IPC::Run::Win32Helper - helper routines for IPC::Run on Win32 platforms. =head1 SYNOPSIS use IPC::Run::Win32Helper; # Exports all by default =head1 DESCRIPTION IPC::Run needs to use sockets to redirect subprocess I/O so that the select() loop will work on Win32. This seems to only work on WinNT and Win2K at this time, not sure if it will ever work on Win95 or Win98. If you have experience in this area, please contact me at barries@slaysys.com, thanks!. =cut use strict; use Carp; use IO::Handle; use vars qw{ $VERSION @ISA @EXPORT }; BEGIN { $VERSION = '0.96'; @ISA = qw( Exporter ); @EXPORT = qw( win32_spawn win32_parse_cmd_line _dont_inherit _inherit ); } require POSIX; use Text::ParseWords; use Win32::Process; use IPC::Run::Debug; use Win32API::File qw( FdGetOsFHandle SetHandleInformation HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE ); ## Takes an fd or a GLOB ref, never never never a Win32 handle. sub _dont_inherit { for (@_) { next unless defined $_; my $fd = $_; $fd = fileno $fd if ref $fd; _debug "disabling inheritance of ", $fd if _debugging_details; my $osfh = FdGetOsFHandle $fd; croak $^E if !defined $osfh || $osfh == INVALID_HANDLE_VALUE; SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 0 ); } } sub _inherit { #### REMOVE for (@_) { #### REMOVE next unless defined $_; #### REMOVE my $fd = $_; #### REMOVE $fd = fileno $fd if ref $fd; #### REMOVE _debug "enabling inheritance of ", $fd if _debugging_details; #### REMOVE my $osfh = FdGetOsFHandle $fd; #### REMOVE croak $^E if !defined $osfh || $osfh == INVALID_HANDLE_VALUE; #### REMOVE #### REMOVE SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 1 ); #### REMOVE } #### REMOVE } #### REMOVE #### REMOVE #sub _inherit { # for ( @_ ) { # next unless defined $_; # my $osfh = GetOsFHandle $_; # croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE; # SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT ); # } #} =pod =head1 FUNCTIONS =over =item optimize() Most common incantations of C (I C, C, or C) now use temporary files to redirect input and output instead of pumper processes. Temporary files are used when sending to child processes if input is taken from a scalar with no filter subroutines. This is the only time we can assume that the parent is not interacting with the child's redirected input as it runs. Temporary files are used when receiving from children when output is to a scalar or subroutine with or without filters, but only if the child in question closes its inputs or takes input from unfiltered SCALARs or named files. Normally, a child inherits its STDIN from its parent; to close it, use "0<&-" or the C<< noinherit => 1 >> option. If data is sent to the child from CODE refs, filehandles or from scalars through filters than the child's outputs will not be optimized because C assumes the parent is interacting with the child. It is ok if the output is filtered or handled by a subroutine, however. This assumes that all named files are real files (as opposed to named pipes) and won't change; and that a process is not communicating with the child indirectly (through means not visible to IPC::Run). These can be an invalid assumptions, but are the 99% case. Write me if you need an option to enable or disable optimizations; I suspect it will work like the C modifier. To detect cases that you might want to optimize by closing inputs, try setting the C environment variable to the special C value: C:> set IPCRUNDEBUG=notopt C:> my_app_that_uses_IPC_Run.pl =item optimizer() rationalizations Only for that limited case can we be sure that it's ok to batch all the input in to a temporary file. If STDIN is from a SCALAR or from a named file or filehandle (again, only in C), then outputs to CODE refs are also assumed to be safe enough to batch through a temp file, otherwise only outputs to SCALAR refs are batched. This can cause a bit of grief if the parent process benefits from or relies on a bit of "early returns" coming in before the child program exits. As long as the output is redirected to a SCALAR ref, this will not be visible. When output is redirected to a subroutine or (deprecated) filters, the subroutine will not get any data until after the child process exits, and it is likely to get bigger chunks of data at once. The reason for the optimization is that, without it, "pumper" processes are used to overcome the inconsistencies of the Win32 API. We need to use anonymous pipes to connect to the child processes' stdin, stdout, and stderr, yet select() does not work on these. select() only works on sockets on Win32. So for each redirected child handle, there is normally a "pumper" process that connects to the parent using a socket--so the parent can select() on that fd--and to the child on an anonymous pipe--so the child can read/write a pipe. Using a socket to connect directly to the child (as at least one MSDN article suggests) seems to cause the trailing output from most children to be lost. I think this is because child processes rarely close their stdout and stderr explicitly, and the winsock dll does not seem to flush output when a process that uses it exits without explicitly closing them. Because of these pumpers and the inherent slowness of Win32 CreateProcess(), child processes with redirects are quite slow to launch; so this routine looks for the very common case of reading/writing to/from scalar references in a run() routine and converts such reads and writes in to temporary file reads and writes. Such files are marked as FILE_ATTRIBUTE_TEMPORARY to increase speed and as FILE_FLAG_DELETE_ON_CLOSE so it will be cleaned up when the child process exits (for input files). The user's default permissions are used for both the temporary files and the directory that contains them, hope your Win32 permissions are secure enough for you. Files are created with the Win32API::File defaults of FILE_SHARE_READ|FILE_SHARE_WRITE. Setting the debug level to "details" or "gory" will give detailed information about the optimization process; setting it to "basic" or higher will tell whether or not a given call is optimized. Setting it to "notopt" will highlight those calls that aren't optimized. =cut sub optimize { my ($h) = @_; my @kids = @{ $h->{KIDS} }; my $saw_pipe; my ( $ok_to_optimize_outputs, $veto_output_optimization ); for my $kid (@kids) { ( $ok_to_optimize_outputs, $veto_output_optimization ) = () unless $saw_pipe; _debug "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over ok of non-SCALAR output optimization" if _debugging_details && $ok_to_optimize_outputs; _debug "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over veto of non-SCALAR output optimization" if _debugging_details && $veto_output_optimization; if ( $h->{noinherit} && !$ok_to_optimize_outputs ) { _debug "Win32 optimizer: (kid $kid->{NUM}) STDIN not inherited from parent oking non-SCALAR output optimization" if _debugging_details && $ok_to_optimize_outputs; $ok_to_optimize_outputs = 1; } for ( @{ $kid->{OPS} } ) { if ( substr( $_->{TYPE}, 0, 1 ) eq "<" ) { if ( $_->{TYPE} eq "<" ) { if ( @{ $_->{FILTERS} } > 1 ) { ## Can't assume that the filters are idempotent. } elsif (ref $_->{SOURCE} eq "SCALAR" || ref $_->{SOURCE} eq "GLOB" || UNIVERSAL::isa( $_, "IO::Handle" ) ) { if ( $_->{KFD} == 0 ) { _debug "Win32 optimizer: (kid $kid->{NUM}) 0$_->{TYPE}", ref $_->{SOURCE}, ", ok to optimize outputs" if _debugging_details; $ok_to_optimize_outputs = 1; } $_->{SEND_THROUGH_TEMP_FILE} = 1; next; } elsif ( !ref $_->{SOURCE} && defined $_->{SOURCE} ) { if ( $_->{KFD} == 0 ) { _debug "Win32 optimizer: (kid $kid->{NUM}) 0<$_->{SOURCE}, ok to optimize outputs", if _debugging_details; $ok_to_optimize_outputs = 1; } next; } } _debug "Win32 optimizer: (kid $kid->{NUM}) ", $_->{KFD}, $_->{TYPE}, defined $_->{SOURCE} ? ref $_->{SOURCE} ? ref $_->{SOURCE} : $_->{SOURCE} : defined $_->{FILENAME} ? $_->{FILENAME} : "", @{ $_->{FILTERS} } > 1 ? " with filters" : (), ", VETOING output opt." if _debugging_details || _debugging_not_optimized; $veto_output_optimization = 1; } elsif ( $_->{TYPE} eq "close" && $_->{KFD} == 0 ) { $ok_to_optimize_outputs = 1; _debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&-, ok to optimize outputs" if _debugging_details; } elsif ( $_->{TYPE} eq "dup" && $_->{KFD2} == 0 ) { $veto_output_optimization = 1; _debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&$_->{KFD2}, VETOING output opt." if _debugging_details || _debugging_not_optimized; } elsif ( $_->{TYPE} eq "|" ) { $saw_pipe = 1; } } if ( !$ok_to_optimize_outputs && !$veto_output_optimization ) { _debug "Win32 optimizer: (kid $kid->{NUM}) child STDIN not redirected, VETOING non-SCALAR output opt." if _debugging_details || _debugging_not_optimized; $veto_output_optimization = 1; } if ( $ok_to_optimize_outputs && $veto_output_optimization ) { $ok_to_optimize_outputs = 0; _debug "Win32 optimizer: (kid $kid->{NUM}) non-SCALAR output optimizations VETOed" if _debugging_details || _debugging_not_optimized; } ## SOURCE/DEST ARRAY means it's a filter. ## TODO: think about checking to see if the final input/output of ## a filter chain (an ARRAY SOURCE or DEST) is a scalar...but ## we may be deprecating filters. for ( @{ $kid->{OPS} } ) { if ( $_->{TYPE} eq ">" ) { if ( ref $_->{DEST} eq "SCALAR" || ( ( @{ $_->{FILTERS} } > 1 || ref $_->{DEST} eq "CODE" || ref $_->{DEST} eq "ARRAY" ## Filters? ) && ( $ok_to_optimize_outputs && !$veto_output_optimization ) ) ) { $_->{RECV_THROUGH_TEMP_FILE} = 1; next; } _debug "Win32 optimizer: NOT optimizing (kid $kid->{NUM}) ", $_->{KFD}, $_->{TYPE}, defined $_->{DEST} ? ref $_->{DEST} ? ref $_->{DEST} : $_->{SOURCE} : defined $_->{FILENAME} ? $_->{FILENAME} : "", @{ $_->{FILTERS} } ? " with filters" : (), if _debugging_details; } } } } =pod =item win32_parse_cmd_line @words = win32_parse_cmd_line( q{foo bar 'baz baz' "bat bat"} ); returns 4 words. This parses like the bourne shell (see the bit about shellwords() in L), assuming we're trying to be a little cross-platform here. The only difference is that "\" is *not* treated as an escape except when it precedes punctuation, since it's used all over the place in DOS path specs. TODO: globbing? probably not (it's unDOSish). TODO: shebang emulation? Probably, but perhaps that should be part of Run.pm so all spawned processes get the benefit. LIMITATIONS: shellwords dies silently on malformed input like a\" =cut sub win32_parse_cmd_line { my $line = shift; $line =~ s{(\\[\w\s])}{\\$1}g; return shellwords $line; } =pod =item win32_spawn Spawns a child process, possibly with STDIN, STDOUT, and STDERR (file descriptors 0, 1, and 2, respectively) redirected. B. Cannot redirect higher file descriptors due to lack of support for this in the Win32 environment. This can be worked around by marking a handle as inheritable in the parent (or leaving it marked; this is the default in perl), obtaining it's Win32 handle with C or C and passing it to the child using the command line, the environment, or any other IPC mechanism (it's a plain old integer). The child can then use C or C and possibly C<&BAR">> or C<&$fd>> as need be. Ach, the pain! Remember to check the Win32 handle against INVALID_HANDLE_VALUE. =cut sub _save { my ( $saved, $saved_as, $fd ) = @_; ## We can only save aside the original fds once. return if exists $saved->{$fd}; my $saved_fd = IPC::Run::_dup($fd); _dont_inherit $saved_fd; $saved->{$fd} = $saved_fd; $saved_as->{$saved_fd} = $fd; _dont_inherit $saved->{$fd}; } sub _dup2_gently { my ( $saved, $saved_as, $fd1, $fd2 ) = @_; _save $saved, $saved_as, $fd2; if ( exists $saved_as->{$fd2} ) { ## The target fd is colliding with a saved-as fd, gotta bump ## the saved-as fd to another fd. my $orig_fd = delete $saved_as->{$fd2}; my $saved_fd = IPC::Run::_dup($fd2); _dont_inherit $saved_fd; $saved->{$orig_fd} = $saved_fd; $saved_as->{$saved_fd} = $orig_fd; } _debug "moving $fd1 to kid's $fd2" if _debugging_details; IPC::Run::_dup2_rudely( $fd1, $fd2 ); } sub win32_spawn { my ( $cmd, $ops ) = @_; ## NOTE: The debug pipe write handle is passed to pump processes as STDOUT. ## and is not to the "real" child process, since they would not know ## what to do with it...unlike Unix, we have no code executing in the ## child before the "real" child is exec()ed. my %saved; ## Map of parent's orig fd -> saved fd my %saved_as; ## Map of parent's saved fd -> orig fd, used to ## detect collisions between a KFD and the fd a ## parent's fd happened to be saved to. for my $op (@$ops) { _dont_inherit $op->{FD} if defined $op->{FD}; if ( defined $op->{KFD} && $op->{KFD} > 2 ) { ## TODO: Detect this in harness() ## TODO: enable temporary redirections if ever necessary, not ## sure why they would be... ## 4>&1 1>/dev/null 1>&4 4>&- croak "Can't redirect fd #", $op->{KFD}, " on Win32"; } ## This is very similar logic to IPC::Run::_do_kid_and_exit(). if ( defined $op->{TFD} ) { unless ( $op->{TFD} == $op->{KFD} ) { _dup2_gently \%saved, \%saved_as, $op->{TFD}, $op->{KFD}; _dont_inherit $op->{TFD}; } } elsif ( $op->{TYPE} eq "dup" ) { _dup2_gently \%saved, \%saved_as, $op->{KFD1}, $op->{KFD2} unless $op->{KFD1} == $op->{KFD2}; } elsif ( $op->{TYPE} eq "close" ) { _save \%saved, \%saved_as, $op->{KFD}; IPC::Run::_close( $op->{KFD} ); } elsif ( $op->{TYPE} eq "init" ) { ## TODO: detect this in harness() croak "init subs not allowed on Win32"; } } my $process; my $cmd_line = join " ", map { ( my $s = $_ ) =~ s/"/"""/g; $s = qq{"$s"} if /[\"\s]|^$/; $s; } @$cmd; _debug "cmd line: ", $cmd_line if _debugging; Win32::Process::Create( $process, $cmd->[0], $cmd_line, 1, ## Inherit handles NORMAL_PRIORITY_CLASS, ".", ) or croak "$!: Win32::Process::Create()"; for my $orig_fd ( keys %saved ) { IPC::Run::_dup2_rudely( $saved{$orig_fd}, $orig_fd ); IPC::Run::_close( $saved{$orig_fd} ); } return ( $process->GetProcessID(), $process ); } 1; =pod =back =head1 AUTHOR Barries Slaymaker . Funded by Perforce Software, Inc. =head1 COPYRIGHT Copyright 2001, Barrie Slaymaker, All Rights Reserved. You may use this under the terms of either the GPL 2.0 or the Artistic License. =cut IPC-Run-0.96/lib/IPC/Run/Win32IO.pm0000644000000000000000000004065113105336303014743 0ustar rootrootpackage IPC::Run::Win32IO; =pod =head1 NAME IPC::Run::Win32IO - helper routines for IPC::Run on Win32 platforms. =head1 SYNOPSIS use IPC::Run::Win32IO; # Exports all by default =head1 DESCRIPTION IPC::Run needs to use sockets to redirect subprocess I/O so that the select() loop will work on Win32. This seems to only work on WinNT and Win2K at this time, not sure if it will ever work on Win95 or Win98. If you have experience in this area, please contact me at barries@slaysys.com, thanks!. =head1 DESCRIPTION A specialized IO class used on Win32. =cut use strict; use Carp; use IO::Handle; use Socket; require POSIX; use vars qw{$VERSION}; BEGIN { $VERSION = '0.96'; } use Socket qw( IPPROTO_TCP TCP_NODELAY ); use Symbol; use Text::ParseWords; use Win32::Process; use IPC::Run::Debug qw( :default _debugging_level ); use IPC::Run::Win32Helper qw( _inherit _dont_inherit ); use Fcntl qw( O_TEXT O_RDONLY ); use base qw( IPC::Run::IO ); my @cleanup_fields; BEGIN { ## These fields will be set to undef in _cleanup to close ## the handles. @cleanup_fields = ( 'SEND_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize() 'RECV_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize() 'TEMP_FILE_NAME', ## The name of the temp file, needed for ## error reporting / debugging only. 'PARENT_HANDLE', ## The handle of the socket for the parent 'PUMP_SOCKET_HANDLE', ## The socket handle for the pump 'PUMP_PIPE_HANDLE', ## The anon pipe handle for the pump 'CHILD_HANDLE', ## The anon pipe handle for the child 'TEMP_FILE_HANDLE', ## The Win32 filehandle for the temp file ); } ## REMOVE OSFHandleOpen use Win32API::File qw( GetOsFHandle OsFHandleOpenFd OsFHandleOpen FdGetOsFHandle SetHandleInformation SetFilePointer HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE createFile WriteFile ReadFile CloseHandle FILE_ATTRIBUTE_TEMPORARY FILE_FLAG_DELETE_ON_CLOSE FILE_FLAG_WRITE_THROUGH FILE_BEGIN ); # FILE_ATTRIBUTE_HIDDEN # FILE_ATTRIBUTE_SYSTEM BEGIN { ## Force AUTOLOADED constants to be, well, constant by getting them ## to AUTOLOAD before compilation continues. Sigh. () = ( SOL_SOCKET, SO_REUSEADDR, IPPROTO_TCP, TCP_NODELAY, HANDLE_FLAG_INHERIT, INVALID_HANDLE_VALUE, ); } use constant temp_file_flags => ( FILE_ATTRIBUTE_TEMPORARY() | FILE_FLAG_DELETE_ON_CLOSE() | FILE_FLAG_WRITE_THROUGH() ); # FILE_ATTRIBUTE_HIDDEN() | # FILE_ATTRIBUTE_SYSTEM() | my $tmp_file_counter; my $tmp_dir; sub _cleanup { my IPC::Run::Win32IO $self = shift; my ($harness) = @_; $self->_recv_through_temp_file($harness) if $self->{RECV_THROUGH_TEMP_FILE}; CloseHandle( $self->{TEMP_FILE_HANDLE} ) if defined $self->{TEMP_FILE_HANDLE}; close( $self->{CHILD_HANDLE} ) if defined $self->{CHILD_HANDLE}; $self->{$_} = undef for @cleanup_fields; } sub _create_temp_file { my IPC::Run::Win32IO $self = shift; ## Create a hidden temp file that Win32 will delete when we close ## it. unless ( defined $tmp_dir ) { $tmp_dir = File::Spec->catdir( File::Spec->tmpdir, "IPC-Run.tmp" ); ## Trust in the user's umask. ## This could possibly be a security hole, perhaps ## we should offer an option. Hmmmm, really, people coding ## security conscious apps should audit this code and ## tell me how to make it better. Nice cop-out :). unless ( -d $tmp_dir ) { mkdir $tmp_dir or croak "$!: $tmp_dir"; } } $self->{TEMP_FILE_NAME} = File::Spec->catfile( ## File name is designed for easy sorting and not conflicting ## with other processes. This should allow us to use "t"runcate ## access in CreateFile in case something left some droppings ## around (which should never happen because we specify ## FLAG_DELETE_ON_CLOSE. ## heh, belt and suspenders are better than bug reports; God forbid ## that NT should ever crash before a temp file gets deleted! $tmp_dir, sprintf "Win32io-%06d-%08d", $$, $tmp_file_counter++ ); $self->{TEMP_FILE_HANDLE} = createFile( $self->{TEMP_FILE_NAME}, "trw", ## new, truncate, read, write { Flags => temp_file_flags, }, ) or croak "Can't create temporary file, $self->{TEMP_FILE_NAME}: $^E"; $self->{TFD} = OsFHandleOpenFd $self->{TEMP_FILE_HANDLE}, 0; $self->{FD} = undef; _debug "Win32 Optimizer: temp file (", $self->{KFD}, $self->{TYPE}, $self->{TFD}, ", fh ", $self->{TEMP_FILE_HANDLE}, "): ", $self->{TEMP_FILE_NAME} if _debugging_details; } sub _reset_temp_file_pointer { my $self = shift; SetFilePointer( $self->{TEMP_FILE_HANDLE}, 0, 0, FILE_BEGIN ) or confess "$^E seeking on (fd $self->{TFD}) $self->{TEMP_FILE_NAME} for kid's fd $self->{KFD}"; } sub _send_through_temp_file { my IPC::Run::Win32IO $self = shift; _debug "Win32 optimizer: optimizing " . " $self->{KFD} $self->{TYPE} temp file instead of ", ref $self->{SOURCE} || $self->{SOURCE} if _debugging_details; $self->_create_temp_file; if ( defined ${ $self->{SOURCE} } ) { my $bytes_written = 0; my $data_ref; if ( $self->binmode ) { $data_ref = $self->{SOURCE}; } else { my $data = ${ $self->{SOURCE} }; # Ugh, a copy. $data =~ s/(?{TEMP_FILE_HANDLE}, $$data_ref, 0, ## Write entire buffer $bytes_written, [], ## Not overlapped. ) or croak "$^E writing $self->{TEMP_FILE_NAME} for kid to read on fd $self->{KFD}"; _debug "Win32 optimizer: wrote $bytes_written to temp file $self->{TEMP_FILE_NAME}" if _debugging_data; $self->_reset_temp_file_pointer; } _debug "Win32 optimizer: kid to read $self->{KFD} from temp file on $self->{TFD}" if _debugging_details; } sub _init_recv_through_temp_file { my IPC::Run::Win32IO $self = shift; $self->_create_temp_file; } ## TODO: Use the Win32 API in the select loop to see if the file has grown ## and read it incrementally if it has. sub _recv_through_temp_file { my IPC::Run::Win32IO $self = shift; ## This next line kicks in if the run() never got to initting things ## and needs to clean up. return undef unless defined $self->{TEMP_FILE_HANDLE}; push @{ $self->{FILTERS} }, sub { my ( undef, $out_ref ) = @_; return undef unless defined $self->{TEMP_FILE_HANDLE}; my $r; my $s; ReadFile( $self->{TEMP_FILE_HANDLE}, $s, 999_999, ## Hmmm, should read the size. $r, [] ) or croak "$^E reading from $self->{TEMP_FILE_NAME}"; _debug "ReadFile( $self->{TFD} ) = $r chars '$s'" if _debugging_data; return undef unless $r; $s =~ s/\r\n/\n/g unless $self->binmode; my $pos = pos $$out_ref; $$out_ref .= $s; pos($out_ref) = $pos; return 1; }; my ($harness) = @_; $self->_reset_temp_file_pointer; 1 while $self->_do_filters($harness); pop @{ $self->{FILTERS} }; IPC::Run::_close( $self->{TFD} ); } =head1 SUBROUTINES =over =item poll Windows version of IPC::Run::IP::poll. =back =cut sub poll { my IPC::Run::Win32IO $self = shift; return if $self->{SEND_THROUGH_TEMP_FILE} || $self->{RECV_THROUGH_TEMP_FILE}; return $self->SUPER::poll(@_); } ## When threaded Perls get good enough, we should use threads here. ## The problem with threaded perls is that they dup() all sorts of ## filehandles and fds and don't allow sufficient control over ## closing off the ones we don't want. sub _spawn_pumper { my ( $stdin, $stdout, $debug_fd, $binmode, $child_label, @opts ) = @_; my ( $stdin_fd, $stdout_fd ) = ( fileno $stdin, fileno $stdout ); _debug "pumper stdin = ", $stdin_fd if _debugging_details; _debug "pumper stdout = ", $stdout_fd if _debugging_details; _inherit $stdin_fd, $stdout_fd, $debug_fd; my @I_options = map qq{"-I$_"}, @INC; my $cmd_line = join( " ", qq{"$^X"}, @I_options, qw(-MIPC::Run::Win32Pump -e 1 ), ## I'm using this clunky way of passing filehandles to the child process ## in order to avoid some kind of premature closure of filehandles ## problem I was having with VCP's test suite when passing them ## via CreateProcess. All of the ## REMOVE code is stuff I'd like ## to be rid of and the ## ADD code is what I'd like to use. FdGetOsFHandle($stdin_fd), ## REMOVE FdGetOsFHandle($stdout_fd), ## REMOVE FdGetOsFHandle($debug_fd), ## REMOVE $binmode ? 1 : 0, $$, $^T, _debugging_level, qq{"$child_label"}, @opts ); # open SAVEIN, "<&STDIN" or croak "$! saving STDIN"; #### ADD # open SAVEOUT, ">&STDOUT" or croak "$! saving STDOUT"; #### ADD # open SAVEERR, ">&STDERR" or croak "$! saving STDERR"; #### ADD # _dont_inherit \*SAVEIN; #### ADD # _dont_inherit \*SAVEOUT; #### ADD # _dont_inherit \*SAVEERR; #### ADD # open STDIN, "<&$stdin_fd" or croak "$! dup2()ing $stdin_fd (pumper's STDIN)"; #### ADD # open STDOUT, ">&$stdout_fd" or croak "$! dup2()ing $stdout_fd (pumper's STDOUT)"; #### ADD # open STDERR, ">&$debug_fd" or croak "$! dup2()ing $debug_fd (pumper's STDERR/debug_fd)"; #### ADD _debug "pump cmd line: ", $cmd_line if _debugging_details; my $process; Win32::Process::Create( $process, $^X, $cmd_line, 1, ## Inherit handles NORMAL_PRIORITY_CLASS, ".", ) or croak "$!: Win32::Process::Create()"; # open STDIN, "<&SAVEIN" or croak "$! restoring STDIN"; #### ADD # open STDOUT, ">&SAVEOUT" or croak "$! restoring STDOUT"; #### ADD # open STDERR, ">&SAVEERR" or croak "$! restoring STDERR"; #### ADD # close SAVEIN or croak "$! closing SAVEIN"; #### ADD # close SAVEOUT or croak "$! closing SAVEOUT"; #### ADD # close SAVEERR or croak "$! closing SAVEERR"; #### ADD close $stdin or croak "$! closing pumper's stdin in parent"; close $stdout or croak "$! closing pumper's stdout in parent"; # Don't close $debug_fd, we need it, as do other pumpers. # Pause a moment to allow the child to get up and running and emit # debug messages. This does not always work. # select undef, undef, undef, 1 if _debugging_details; _debug "_spawn_pumper pid = ", $process->GetProcessID if _debugging_data; } my $loopback = inet_aton "127.0.0.1"; my $tcp_proto = getprotobyname('tcp'); croak "$!: getprotobyname('tcp')" unless defined $tcp_proto; sub _socket { my ($server) = @_; $server ||= gensym; my $client = gensym; my $listener = gensym; socket $listener, PF_INET, SOCK_STREAM, $tcp_proto or croak "$!: socket()"; setsockopt $listener, SOL_SOCKET, SO_REUSEADDR, pack( "l", 0 ) or croak "$!: setsockopt()"; unless ( bind $listener, sockaddr_in( 0, $loopback ) ) { croak "Error binding: $!"; } my ($port) = sockaddr_in( getsockname($listener) ); _debug "win32 port = $port" if _debugging_details; listen $listener, my $queue_size = 1 or croak "$!: listen()"; { socket $client, PF_INET, SOCK_STREAM, $tcp_proto or croak "$!: socket()"; my $paddr = sockaddr_in( $port, $loopback ); connect $client, $paddr or croak "$!: connect()"; croak "$!: accept" unless defined $paddr; ## The windows "default" is SO_DONTLINGER, which should make ## sure all socket data goes through. I have my doubts based ## on experimentation, but nothing prompts me to set SO_LINGER ## at this time... setsockopt $client, IPPROTO_TCP, TCP_NODELAY, pack( "l", 0 ) or croak "$!: setsockopt()"; } { _debug "accept()ing on port $port" if _debugging_details; my $paddr = accept( $server, $listener ); croak "$!: accept()" unless defined $paddr; } _debug "win32 _socket = ( ", fileno $server, ", ", fileno $client, " ) on port $port" if _debugging_details; return ( $server, $client ); } sub _open_socket_pipe { my IPC::Run::Win32IO $self = shift; my ( $debug_fd, $parent_handle ) = @_; my $is_send_to_child = $self->dir eq "<"; $self->{CHILD_HANDLE} = gensym; $self->{PUMP_PIPE_HANDLE} = gensym; ( $self->{PARENT_HANDLE}, $self->{PUMP_SOCKET_HANDLE} ) = _socket $parent_handle; ## These binmodes seem to have no effect on Win2K, but just to be safe ## I do them. binmode $self->{PARENT_HANDLE} or die $!; binmode $self->{PUMP_SOCKET_HANDLE} or die $!; _debug "PUMP_SOCKET_HANDLE = ", fileno $self->{PUMP_SOCKET_HANDLE} if _debugging_details; ##my $buf; ##$buf = "write on child end of " . fileno( $self->{WRITE_HANDLE} ) . "\n\n\n\n\n"; ##POSIX::write(fileno $self->{WRITE_HANDLE}, $buf, length $buf) or warn "$! in syswrite"; ##$buf = "write on parent end of " . fileno( $self->{CHILD_HANDLE} ) . "\r\n"; ##POSIX::write(fileno $self->{CHILD_HANDLE},$buf, length $buf) or warn "$! in syswrite"; ## $self->{CHILD_HANDLE}->autoflush( 1 ); ## $self->{WRITE_HANDLE}->autoflush( 1 ); ## Now fork off a data pump and arrange to return the correct fds. if ($is_send_to_child) { pipe $self->{CHILD_HANDLE}, $self->{PUMP_PIPE_HANDLE} or croak "$! opening child pipe"; _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE} if _debugging_details; _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE} if _debugging_details; } else { pipe $self->{PUMP_PIPE_HANDLE}, $self->{CHILD_HANDLE} or croak "$! opening child pipe"; _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE} if _debugging_details; _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE} if _debugging_details; } ## These binmodes seem to have no effect on Win2K, but just to be safe ## I do them. binmode $self->{CHILD_HANDLE}; binmode $self->{PUMP_PIPE_HANDLE}; ## No child should ever see this. _dont_inherit $self->{PARENT_HANDLE}; ## We clear the inherit flag so these file descriptors are not inherited. ## It'll be dup()ed on to STDIN/STDOUT/STDERR before CreateProcess is ## called and *that* fd will be inheritable. _dont_inherit $self->{PUMP_SOCKET_HANDLE}; _dont_inherit $self->{PUMP_PIPE_HANDLE}; _dont_inherit $self->{CHILD_HANDLE}; ## Need to return $self so the HANDLEs don't get freed. ## Return $self, $parent_fd, $child_fd my ( $parent_fd, $child_fd ) = ( fileno $self->{PARENT_HANDLE}, fileno $self->{CHILD_HANDLE} ); ## Both PUMP_..._HANDLEs will be closed, no need to worry about ## inheritance. _debug "binmode on" if _debugging_data && $self->binmode; _spawn_pumper( $is_send_to_child ? ( $self->{PUMP_SOCKET_HANDLE}, $self->{PUMP_PIPE_HANDLE} ) : ( $self->{PUMP_PIPE_HANDLE}, $self->{PUMP_SOCKET_HANDLE} ), $debug_fd, $self->binmode, $child_fd . $self->dir . "pump" . $self->dir . $parent_fd, ); { my $foo; confess "PARENT_HANDLE no longer open" unless POSIX::read( $parent_fd, $foo, 0 ); } _debug "win32_fake_pipe = ( $parent_fd, $child_fd )" if _debugging_details; $self->{FD} = $parent_fd; $self->{TFD} = $child_fd; } sub _do_open { my IPC::Run::Win32IO $self = shift; if ( $self->{SEND_THROUGH_TEMP_FILE} ) { return $self->_send_through_temp_file(@_); } elsif ( $self->{RECV_THROUGH_TEMP_FILE} ) { return $self->_init_recv_through_temp_file(@_); } else { return $self->_open_socket_pipe(@_); } } 1; =pod =head1 AUTHOR Barries Slaymaker . Funded by Perforce Software, Inc. =head1 COPYRIGHT Copyright 2001, Barrie Slaymaker, All Rights Reserved. You may use this under the terms of either the GPL 2.0 or the Artistic License. =cut IPC-Run-0.96/lib/IPC/Run.pm0000644000000000000000000043467313105336303013624 0ustar rootrootpackage IPC::Run; use bytes; =pod =head1 NAME IPC::Run - system() and background procs w/ piping, redirs, ptys (Unix, Win32) =head1 SYNOPSIS ## First,a command to run: my @cat = qw( cat ); ## Using run() instead of system(): use IPC::Run qw( run timeout ); run \@cmd, \$in, \$out, \$err, timeout( 10 ) or die "cat: $?" # Can do I/O to sub refs and filenames, too: run \@cmd, '<', "in.txt", \&out, \&err or die "cat: $?" run \@cat, '<', "in.txt", '>>', "out.txt", '2>>', "err.txt"; # Redirecting using pseudo-terminals instead of pipes. run \@cat, 'pty>', \$out_and_err; ## Scripting subprocesses (like Expect): use IPC::Run qw( start pump finish timeout ); # Incrementally read from / write to scalars. # $in is drained as it is fed to cat's stdin, # $out accumulates cat's stdout # $err accumulates cat's stderr # $h is for "harness". my $h = start \@cat, \$in, \$out, \$err, timeout( 10 ); $in .= "some input\n"; pump $h until $out =~ /input\n/g; $in .= "some more input\n"; pump $h until $out =~ /\G.*more input\n/; $in .= "some final input\n"; finish $h or die "cat returned $?"; warn $err if $err; print $out; ## All of cat's output # Piping between children run \@cat, '|', \@gzip; # Multiple children simultaneously (run() blocks until all # children exit, use start() for background execution): run \@foo1, '&', \@foo2; # Calling \&set_up_child in the child before it executes the # command (only works on systems with true fork() & exec()) # exceptions thrown in set_up_child() will be propagated back # to the parent and thrown from run(). run \@cat, \$in, \$out, init => \&set_up_child; # Read from / write to file handles you open and close open IN, 'out.txt' or die $!; print OUT "preamble\n"; run \@cat, \*IN, \*OUT or die "cat returned $?"; print OUT "postamble\n"; close IN; close OUT; # Create pipes for you to read / write (like IPC::Open2 & 3). $h = start \@cat, 'pipe', \*OUT, '2>pipe', \*ERR or die "cat returned $?"; print IN "some input\n"; close IN; print , ; finish $h; # Mixing input and output modes run \@cat, 'in.txt', \&catch_some_out, \*ERR_LOG ); # Other redirection constructs run \@cat, '>&', \$out_and_err; run \@cat, '2>&1'; run \@cat, '0<&3'; run \@cat, '<&-'; run \@cat, '3<', \$in3; run \@cat, '4>', \$out4; # etc. # Passing options: run \@cat, 'in.txt', debug => 1; # Call this system's shell, returns TRUE on 0 exit code # THIS IS THE OPPOSITE SENSE OF system()'s RETURN VALUE run "cat a b c" or die "cat returned $?"; # Launch a sub process directly, no shell. Can't do redirection # with this form, it's here to behave like system() with an # inverted result. $r = run "cat a b c"; # Read from a file in to a scalar run io( "filename", 'r', \$recv ); run io( \*HANDLE, 'r', \$recv ); =head1 DESCRIPTION IPC::Run allows you to run and interact with child processes using files, pipes, and pseudo-ttys. Both system()-style and scripted usages are supported and may be mixed. Likewise, functional and OO API styles are both supported and may be mixed. Various redirection operators reminiscent of those seen on common Unix and DOS command lines are provided. Before digging in to the details a few LIMITATIONS are important enough to be mentioned right up front: =over =item Win32 Support Win32 support is working but B, but does pass all relevant tests on NT 4.0. See L. =item pty Support If you need pty support, IPC::Run should work well enough most of the time, but IO::Pty is being improved, and IPC::Run will be improved to use IO::Pty's new features when it is release. The basic problem is that the pty needs to initialize itself before the parent writes to the master pty, or the data written gets lost. So IPC::Run does a sleep(1) in the parent after forking to (hopefully) give the child a chance to run. This is a kludge that works well on non heavily loaded systems :(. ptys are not supported yet under Win32, but will be emulated... =item Debugging Tip You may use the environment variable C to see what's going on under the hood: $ IPCRUNDEBUG=basic myscript # prints minimal debugging $ IPCRUNDEBUG=data myscript # prints all data reads/writes $ IPCRUNDEBUG=details myscript # prints lots of low-level details $ IPCRUNDEBUG=gory myscript # (Win32 only) prints data moving through # the helper processes. =back We now return you to your regularly scheduled documentation. =head2 Harnesses Child processes and I/O handles are gathered in to a harness, then started and run until the processing is finished or aborted. =head2 run() vs. start(); pump(); finish(); There are two modes you can run harnesses in: run() functions as an enhanced system(), and start()/pump()/finish() allow for background processes and scripted interactions with them. When using run(), all data to be sent to the harness is set up in advance (though one can feed subprocesses input from subroutine refs to get around this limitation). The harness is run and all output is collected from it, then any child processes are waited for: run \@cmd, \< and C<$err> in our examples. Regular expressions can be used to wait for appropriate output in several ways. The C example in the previous section demonstrates how to pump() until some string appears in the output. Here's an example that uses C to fetch files from a remote server: $h = harness \@smbclient, \$in, \$out; $in = "cd /src\n"; $h->pump until $out =~ /^smb.*> \Z/m; die "error cding to /src:\n$out" if $out =~ "ERR"; $out = ''; $in = "mget *\n"; $h->pump until $out =~ /^smb.*> \Z/m; die "error retrieving files:\n$out" if $out =~ "ERR"; $in = "quit\n"; $h->finish; Notice that we carefully clear $out after the first command/response cycle? That's because IPC::Run does not delete $out when we continue, and we don't want to trip over the old output in the second command/response cycle. Say you want to accumulate all the output in $out and analyze it afterwards. Perl offers incremental regular expression matching using the C and pattern matching idiom and the C<\G> assertion. IPC::Run is careful not to disturb the current C value for scalars it appends data to, so we could modify the above so as not to destroy $out by adding a couple of C modifiers. The C keeps us from tripping over the previous prompt and the C keeps us from resetting the prior match position if the expected prompt doesn't materialize immediately: $h = harness \@smbclient, \$in, \$out; $in = "cd /src\n"; $h->pump until $out =~ /^smb.*> \Z/mgc; die "error cding to /src:\n$out" if $out =~ "ERR"; $in = "mget *\n"; $h->pump until $out =~ /^smb.*> \Z/mgc; die "error retrieving files:\n$out" if $out =~ "ERR"; $in = "quit\n"; $h->finish; analyze( $out ); When using this technique, you may want to preallocate $out to have plenty of memory or you may find that the act of growing $out each time new input arrives causes an C slowdown as $out grows. Say we expect no more than 10,000 characters of input at the most. To preallocate memory to $out, do something like: my $out = "x" x 10_000; $out = ""; C will allocate at least 10,000 characters' worth of space, then mark the $out as having 0 length without freeing all that yummy RAM. =head2 Timeouts and Timers More than likely, you don't want your subprocesses to run forever, and sometimes it's nice to know that they're going a little slowly. Timeouts throw exceptions after a some time has elapsed, timers merely cause pump() to return after some time has elapsed. Neither is reset/restarted automatically. Timeout objects are created by calling timeout( $interval ) and passing the result to run(), start() or harness(). The timeout period starts ticking just after all the child processes have been fork()ed or spawn()ed, and are polled for expiration in run(), pump() and finish(). If/when they expire, an exception is thrown. This is typically useful to keep a subprocess from taking too long. If a timeout occurs in run(), all child processes will be terminated and all file/pipe/ptty descriptors opened by run() will be closed. File descriptors opened by the parent process and passed in to run() are not closed in this event. If a timeout occurs in pump(), pump_nb(), or finish(), it's up to you to decide whether to kill_kill() all the children or to implement some more graceful fallback. No I/O will be closed in pump(), pump_nb() or finish() by such an exception (though I/O is often closed down in those routines during the natural course of events). Often an exception is too harsh. timer( $interval ) creates timer objects that merely prevent pump() from blocking forever. This can be useful for detecting stalled I/O or printing a soothing message or "." to pacify an anxious user. Timeouts and timers can both be restarted at any time using the timer's start() method (this is not the start() that launches subprocesses). To restart a timer, you need to keep a reference to the timer: ## Start with a nice long timeout to let smbclient connect. If ## pump or finish take too long, an exception will be thrown. my $h; eval { $h = harness \@smbclient, \$in, \$out, \$err, ( my $t = timeout 30 ); sleep 11; # No effect: timer not running yet start $h; $in = "cd /src\n"; pump $h until ! length $in; $in = "ls\n"; ## Now use a short timeout, since this should be faster $t->start( 5 ); pump $h until ! length $in; $t->start( 10 ); ## Give smbclient a little while to shut down. $h->finish; }; if ( $@ ) { my $x = $@; ## Preserve $@ in case another exception occurs $h->kill_kill; ## kill it gently, then brutally if need be, or just ## brutally on Win32. die $x; } Timeouts and timers are I checked once the subprocesses are shut down; they will not expire in the interval between the last valid process and when IPC::Run scoops up the processes' result codes, for instance. =head2 Spawning synchronization, child exception propagation start() pauses the parent until the child executes the command or CODE reference and propagates any exceptions thrown (including exec() failure) back to the parent. This has several pleasant effects: any exceptions thrown in the child, including exec() failure, come flying out of start() or run() as though they had occurred in the parent. This includes exceptions your code thrown from init subs. In this example: eval { run \@cmd, init => sub { die "blast it! foiled again!" }; }; print $@; the exception "blast it! foiled again" will be thrown from the child process (preventing the exec()) and printed by the parent. In situations like run \@cmd1, "|", \@cmd2, "|", \@cmd3; @cmd1 will be initted and exec()ed before @cmd2, and @cmd2 before @cmd3. This can save time and prevent oddball errors emitted by later commands when earlier commands fail to execute. Note that IPC::Run doesn't start any commands unless it can find the executables referenced by all commands. These executables must pass both the C<-f> and C<-x> tests described in L. Another nice effect is that init() subs can take their time doing things and there will be no problems caused by a parent continuing to execute before a child's init() routine is complete. Say the init() routine needs to open a socket or a temp file that the parent wants to connect to; without this synchronization, the parent will need to implement a retry loop to wait for the child to run, since often, the parent gets a lot of things done before the child's first timeslice is allocated. This is also quite necessary for pseudo-tty initialization, which needs to take place before the parent writes to the child via pty. Writes that occur before the pty is set up can get lost. A final, minor, nicety is that debugging output from the child will be emitted before the parent continues on, making for much clearer debugging output in complex situations. The only drawback I can conceive of is that the parent can't continue to operate while the child is being initted. If this ever becomes a problem in the field, we can implement an option to avoid this behavior, but I don't expect it to. B: executing CODE references isn't supported on Win32, see L for details. =head2 Syntax run(), start(), and harness() can all take a harness specification as input. A harness specification is either a single string to be passed to the systems' shell: run "echo 'hi there'"; or a list of commands, io operations, and/or timers/timeouts to execute. Consecutive commands must be separated by a pipe operator '|' or an '&'. External commands are passed in as array references, and, on systems supporting fork(), Perl code may be passed in as subs: run \@cmd; run \@cmd1, '|', \@cmd2; run \@cmd1, '&', \@cmd2; run \&sub1; run \&sub1, '|', \&sub2; run \&sub1, '&', \&sub2; '|' pipes the stdout of \@cmd1 the stdin of \@cmd2, just like a shell pipe. '&' does not. Child processes to the right of a '&' will have their stdin closed unless it's redirected-to. L objects may be passed in as well, whether or not child processes are also specified: run io( "infile", ">", \$in ), io( "outfile", "<", \$in ); as can L objects: run \@cmd, io( "outfile", "<", \$in ), timeout( 10 ); Commands may be followed by scalar, sub, or i/o handle references for redirecting child process input & output: run \@cmd, \undef, \$out; run \@cmd, \$in, \$out; run \@cmd1, \&in, '|', \@cmd2, \*OUT; run \@cmd1, \*IN, '|', \@cmd2, \&out; This is known as succinct redirection syntax, since run(), start() and harness(), figure out which file descriptor to redirect and how. File descriptor 0 is presumed to be an input for the child process, all others are outputs. The assumed file descriptor always starts at 0, unless the command is being piped to, in which case it starts at 1. To be explicit about your redirects, or if you need to do more complex things, there's also a redirection operator syntax: run \@cmd, '<', \undef, '>', \$out; run \@cmd, '<', \undef, '>&', \$out_and_err; run( \@cmd1, '<', \$in, '|', \@cmd2, \$out ); Operator syntax is required if you need to do something other than simple redirection to/from scalars or subs, like duping or closing file descriptors or redirecting to/from a named file. The operators are covered in detail below. After each \@cmd (or \&foo), parsing begins in succinct mode and toggles to operator syntax mode when an operator (ie plain scalar, not a ref) is seen. Once in operator syntax mode, parsing only reverts to succinct mode when a '|' or '&' is seen. In succinct mode, each parameter after the \@cmd specifies what to do with the next highest file descriptor. These File descriptor start with 0 (stdin) unless stdin is being piped to (C<'|', \@cmd>), in which case they start with 1 (stdout). Currently, being on the left of a pipe (C<\@cmd, \$out, \$err, '|'>) does I cause stdout to be skipped, though this may change since it's not as DWIMerly as it could be. Only stdin is assumed to be an input in succinct mode, all others are assumed to be outputs. If no piping or redirection is specified for a child, it will inherit the parent's open file handles as dictated by your system's close-on-exec behavior and the $^F flag, except that processes after a '&' will not inherit the parent's stdin. Also note that $^F does not affect file descriptors obtained via POSIX, since it only applies to full-fledged Perl file handles. Such processes will have their stdin closed unless it has been redirected-to. If you want to close a child processes stdin, you may do any of: run \@cmd, \undef; run \@cmd, \""; run \@cmd, '<&-'; run \@cmd, '0<&-'; Redirection is done by placing redirection specifications immediately after a command or child subroutine: run \@cmd1, \$in, '|', \@cmd2, \$out; run \@cmd1, '<', \$in, '|', \@cmd2, '>', \$out; If you omit the redirection operators, descriptors are counted starting at 0. Descriptor 0 is assumed to be input, all others are outputs. A leading '|' consumes descriptor 0, so this works as expected. run \@cmd1, \$in, '|', \@cmd2, \$out; The parameter following a redirection operator can be a scalar ref, a subroutine ref, a file name, an open filehandle, or a closed filehandle. If it's a scalar ref, the child reads input from or sends output to that variable: $in = "Hello World.\n"; run \@cat, \$in, \$out; print $out; Scalars used in incremental (start()/pump()/finish()) applications are treated as queues: input is removed from input scalers, resulting in them dwindling to '', and output is appended to output scalars. This is not true of harnesses run() in batch mode. It's usually wise to append new input to be sent to the child to the input queue, and you'll often want to zap output queues to '' before pumping. $h = start \@cat, \$in; $in = "line 1\n"; pump $h; $in .= "line 2\n"; pump $h; $in .= "line 3\n"; finish $h; The final call to finish() must be there: it allows the child process(es) to run to completion and waits for their exit values. =head1 OBSTINATE CHILDREN Interactive applications are usually optimized for human use. This can help or hinder trying to interact with them through modules like IPC::Run. Frequently, programs alter their behavior when they detect that stdin, stdout, or stderr are not connected to a tty, assuming that they are being run in batch mode. Whether this helps or hurts depends on which optimizations change. And there's often no way of telling what a program does in these areas other than trial and error and occasionally, reading the source. This includes different versions and implementations of the same program. All hope is not lost, however. Most programs behave in reasonably tractable manners, once you figure out what it's trying to do. Here are some of the issues you might need to be aware of. =over =item * fflush()ing stdout and stderr This lets the user see stdout and stderr immediately. Many programs undo this optimization if stdout is not a tty, making them harder to manage by things like IPC::Run. Many programs decline to fflush stdout or stderr if they do not detect a tty there. Some ftp commands do this, for instance. If this happens to you, look for a way to force interactive behavior, like a command line switch or command. If you can't, you will need to use a pseudo terminal ('pty>'). =item * false prompts Interactive programs generally do not guarantee that output from user commands won't contain a prompt string. For example, your shell prompt might be a '$', and a file named '$' might be the only file in a directory listing. This can make it hard to guarantee that your output parser won't be fooled into early termination of results. To help work around this, you can see if the program can alter it's prompt, and use something you feel is never going to occur in actual practice. You should also look for your prompt to be the only thing on a line: pump $h until $out =~ /^\s?\z/m; (use C<(?!\n)\Z> in place of C<\z> on older perls). You can also take the approach that IPC::ChildSafe takes and emit a command with known output after each 'real' command you issue, then look for this known output. See new_appender() and new_chunker() for filters that can help with this task. If it's not convenient or possibly to alter a prompt or use a known command/response pair, you might need to autodetect the prompt in case the local version of the child program is different then the one you tested with, or if the user has control over the look & feel of the prompt. =item * Refusing to accept input unless stdin is a tty. Some programs, for security reasons, will only accept certain types of input from a tty. su, notable, will not prompt for a password unless it's connected to a tty. If this is your situation, use a pseudo terminal ('pty>'). =item * Not prompting unless connected to a tty. Some programs don't prompt unless stdin or stdout is a tty. See if you can turn prompting back on. If not, see if you can come up with a command that you can issue after every real command and look for it's output, as IPC::ChildSafe does. There are two filters included with IPC::Run that can help with doing this: appender and chunker (see new_appender() and new_chunker()). =item * Different output format when not connected to a tty. Some commands alter their formats to ease machine parsability when they aren't connected to a pipe. This is actually good, but can be surprising. =back =head1 PSEUDO TERMINALS On systems providing pseudo terminals under /dev, IPC::Run can use IO::Pty (available on CPAN) to provide a terminal environment to subprocesses. This is necessary when the subprocess really wants to think it's connected to a real terminal. =head2 CAVEATS Pseudo-terminals are not pipes, though they are similar. Here are some differences to watch out for. =over =item Echoing Sending to stdin will cause an echo on stdout, which occurs before each line is passed to the child program. There is currently no way to disable this, although the child process can and should disable it for things like passwords. =item Shutdown IPC::Run cannot close a pty until all output has been collected. This means that it is not possible to send an EOF to stdin by half-closing the pty, as we can when using a pipe to stdin. This means that you need to send the child process an exit command or signal, or run() / finish() will time out. Be careful not to expect a prompt after sending the exit command. =item Command line editing Some subprocesses, notable shells that depend on the user's prompt settings, will reissue the prompt plus the command line input so far once for each character. =item '>pty>' means '&>pty>', not '1>pty>' The pseudo terminal redirects both stdout and stderr unless you specify a file descriptor. If you want to grab stderr separately, do this: start \@cmd, 'pty>', \$out, '2>', \$err; =item stdin, stdout, and stderr not inherited Child processes harnessed to a pseudo terminal have their stdin, stdout, and stderr completely closed before any redirection operators take effect. This casts of the bonds of the controlling terminal. This is not done when using pipes. Right now, this affects all children in a harness that has a pty in use, even if that pty would not affect a particular child. That's a bug and will be fixed. Until it is, it's best not to mix-and-match children. =back =head2 Redirection Operators Operator SHNP Description ======== ==== =========== <, N< SHN Redirects input to a child's fd N (0 assumed) >, N> SHN Redirects output from a child's fd N (1 assumed) >>, N>> SHN Like '>', but appends to scalars or named files >&, &> SHN Redirects stdout & stderr from a child process pty, N>pty S Like '>', but uses a pseudo-tty instead of a pipe N<&M Dups input fd N to input fd M M>&N Dups output fd N to input fd M N<&- Closes fd N pipe, N>pipe P Pipe opens H for caller to read, write, close. 'N' and 'M' are placeholders for integer file descriptor numbers. The terms 'input' and 'output' are from the child process's perspective. The SHNP field indicates what parameters an operator can take: S: \$scalar or \&function references. Filters may be used with these operators (and only these). H: \*HANDLE or IO::Handle for caller to open, and close N: "file name". P: \*HANDLE opened by IPC::Run as the parent end of a pipe, but read and written to and closed by the caller (like IPC::Open3). =over =item Redirecting input: [n]<, [n] below for more information. The : The handle returned is actually a socket handle, so you can use select() on it. =item Redirecting output: [n]>, [n]>>, [n]>&[m], [n]>pipe You can redirect any output the child emits to a scalar variable, subroutine, file handle, or file name. You can have &run truncate or append to named files or scalars. If you are redirecting stdin as well, or if the command is on the receiving end of a pipeline ('|'), you can omit the redirection operator: @ls = ( 'ls' ); run \@ls, \undef, \$out or die "ls returned $?"; run \@ls, \undef, \&out; ## Calls &out each time some output ## is received from the child's ## when undef is returned. run \@ls, \undef, '2>ls.err'; run \@ls, '2>', 'ls.err'; The two parameter form guarantees that the filename will not be interpreted as a redirection operator: run \@ls, '>', "&more"; run \@ls, '2>', ">foo\n"; You can pass file handles you've opened for writing: open( *OUT, ">out.txt" ); open( *ERR, ">err.txt" ); run \@cat, \*OUT, \*ERR; Passing a scalar reference and a code reference requires a little more work, but allows you to capture all of the output in a scalar or each piece of output by a callback: These two do the same things: run( [ 'ls' ], '2>', sub { $err_out .= $_[0] } ); does the same basic thing as: run( [ 'ls' ], '2>', \$err_out ); The subroutine will be called each time some data is read from the child. The >pipe operator is different in concept than the other '>' operators, although it's syntax is similar: $h = start \@cat, $in, '>pipe', \*OUT, '2>pipe', \*ERR; $in = "hello world\n"; finish $h; print ; print ; close OUT; close ERR; causes two pipe to be created, with one end attached to cat's stdout and stderr, respectively, and the other left open on OUT and ERR, so that the script can manually read(), select(), etc. on them. This is like the behavior of IPC::Open2 and IPC::Open3. B: The handle returned is actually a socket handle, so you can use select() on it. =item Duplicating output descriptors: >&m, n>&m This duplicates output descriptor number n (default is 1 if n is omitted) from descriptor number m. =item Duplicating input descriptors: <&m, n<&m This duplicates input descriptor number n (default is 0 if n is omitted) from descriptor number m =item Closing descriptors: <&-, 3<&- This closes descriptor number n (default is 0 if n is omitted). The following commands are equivalent: run \@cmd, \undef; run \@cmd, '<&-'; run \@cmd, ', >&, &>pipe, >pipe& The following pairs of commands are equivalent: run \@cmd, '>&', \$out; run \@cmd, '>', \$out, '2>&1'; run \@cmd, '>&', 'out.txt'; run \@cmd, '>', 'out.txt', '2>&1'; etc. File descriptor numbers are not permitted to the left or the right of these operators, and the '&' may occur on either end of the operator. The '&>pipe' and '>pipe&' variants behave like the '>pipe' operator, except that both stdout and stderr write to the created pipe. =item Redirection Filters Both input redirections and output redirections that use scalars or subs as endpoints may have an arbitrary number of filter subs placed between them and the child process. This is useful if you want to receive output in chunks, or if you want to massage each chunk of data sent to the child. To use this feature, you must use operator syntax: run( \@cmd '<', \&in_filter_2, \&in_filter_1, $in, '>', \&out_filter_1, \&in_filter_2, $out, ); This capability is not provided for IO handles or named files. Two filters are provided by IPC::Run: appender and chunker. Because these may take an argument, you need to use the constructor functions new_appender() and new_chunker() rather than using \& syntax: run( \@cmd '<', new_appender( "\n" ), $in, '>', new_chunker, $out, ); =back =head2 Just doing I/O If you just want to do I/O to a handle or file you open yourself, you may specify a filehandle or filename instead of a command in the harness specification: run io( "filename", '>', \$recv ); $h = start io( $io, '>', \$recv ); $h = harness \@cmd, '&', io( "file", '<', \$send ); =head2 Options Options are passed in as name/value pairs: run \@cat, \$in, debug => 1; If you pass the debug option, you may want to pass it in first, so you can see what parsing is going on: run debug => 1, \@cat, \$in; =over =item debug Enables debugging output in parent and child. Debugging info is emitted to the STDERR that was present when IPC::Run was first Ced (it's Ced out of the way so that it can be redirected in children without having debugging output emitted on it). =back =head1 RETURN VALUES harness() and start() return a reference to an IPC::Run harness. This is blessed in to the IPC::Run package, so you may make later calls to functions as members if you like: $h = harness( ... ); $h->start; $h->pump; $h->finish; $h = start( .... ); $h->pump; ... Of course, using method call syntax lets you deal with any IPC::Run subclasses that might crop up, but don't hold your breath waiting for any. run() and finish() return TRUE when all subcommands exit with a 0 result code. B. All routines raise exceptions (via die()) when error conditions are recognized. A non-zero command result is not treated as an error condition, since some commands are tests whose results are reported in their exit codes. =head1 ROUTINES =over =cut use strict; use Exporter (); use vars qw{$VERSION @ISA @FILTER_IMP @FILTERS @API @EXPORT_OK %EXPORT_TAGS}; BEGIN { $VERSION = '0.96'; @ISA = qw{ Exporter }; ## We use @EXPORT for the end user's convenience: there's only one function ## exported, it's homonymous with the module, it's an unusual name, and ## it can be suppressed by "use IPC::Run ();". @FILTER_IMP = qw( input_avail get_more_input ); @FILTERS = qw( new_appender new_chunker new_string_source new_string_sink ); @API = qw( run harness start pump pumpable finish signal kill_kill reap_nb io timer timeout close_terminal binary ); @EXPORT_OK = ( @API, @FILTER_IMP, @FILTERS, qw( Win32_MODE ) ); %EXPORT_TAGS = ( 'filter_imp' => \@FILTER_IMP, 'all' => \@EXPORT_OK, 'filters' => \@FILTERS, 'api' => \@API, ); } use strict; use IPC::Run::Debug; use Exporter; use Fcntl; use POSIX (); BEGIN { if ( $] < 5.008 ) { require Symbol; } } use Carp; use File::Spec (); use IO::Handle; require IPC::Run::IO; require IPC::Run::Timer; use constant Win32_MODE => $^O =~ /os2|Win32/i; BEGIN { if (Win32_MODE) { eval "use IPC::Run::Win32Helper; 1;" or ( $@ && die ) or die "$!"; } else { eval "use File::Basename; 1;" or die $!; } } sub input_avail(); sub get_more_input(); ############################################################################### ## ## Error constants, not too locale-dependent use vars qw( $_EIO $_EAGAIN ); use Errno qw( EIO EAGAIN ); BEGIN { local $!; $! = EIO; $_EIO = qr/^$!/; $! = EAGAIN; $_EAGAIN = qr/^$!/; } ## ## State machine states, set in $self->{STATE} ## ## These must be in ascending order numerically ## sub _newed() { 0 } sub _harnessed() { 1 } sub _finished() { 2 } ## _finished behave almost exactly like _harnessed sub _started() { 3 } ## ## Which fds have been opened in the parent. This may have extra fds, since ## we aren't all that rigorous about closing these off, but that's ok. This ## is used on Unixish OSs to close all fds in the child that aren't needed ## by that particular child. my %fds; ## There's a bit of hackery going on here. ## ## We want to have any code anywhere be able to emit ## debugging statements without knowing what harness the code is ## being called in/from, since we'd need to pass a harness around to ## everything. ## ## Thus, $cur_self was born. use vars qw( $cur_self ); sub _debug_fd { return fileno STDERR unless defined $cur_self; if ( _debugging && !defined $cur_self->{DEBUG_FD} ) { my $fd = select STDERR; $| = 1; select $fd; $cur_self->{DEBUG_FD} = POSIX::dup fileno STDERR; _debug("debugging fd is $cur_self->{DEBUG_FD}\n") if _debugging_details; } return fileno STDERR unless defined $cur_self->{DEBUG_FD}; return $cur_self->{DEBUG_FD}; } sub DESTROY { ## We absolutely do not want to do anything else here. We are likely ## to be in a child process and we don't want to do things like kill_kill ## ourself or cause other destruction. my IPC::Run $self = shift; POSIX::close $self->{DEBUG_FD} if defined $self->{DEBUG_FD}; $self->{DEBUG_FD} = undef; } ## ## Support routines (NOT METHODS) ## my %cmd_cache; sub _search_path { my ($cmd_name) = @_; if ( File::Spec->file_name_is_absolute($cmd_name) && -x $cmd_name ) { _debug "'", $cmd_name, "' is absolute" if _debugging_details; return $cmd_name; } my $dirsep = ( Win32_MODE ? '[/\\\\]' : $^O =~ /MacOS/ ? ':' : $^O =~ /VMS/ ? '[\[\]]' : '/' ); if ( Win32_MODE && ( $cmd_name =~ /$dirsep/ ) # && ( $cmd_name !~ /\..+$/ ) ## Only run if cmd_name has no extension? && ( $cmd_name !~ m!\.[^\\/\.]+$! ) ) { _debug "no extension(.exe), checking ENV{PATHEXT}" if _debugging; for ( split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE" ) { my $name = "$cmd_name$_"; $cmd_name = $name, last if -f $name && -x _; } _debug "cmd_name is now '$cmd_name'" if _debugging; } if ( $cmd_name =~ /($dirsep)/ ) { _debug "'$cmd_name' contains '$1'" if _debugging; croak "file not found: $cmd_name" unless -e $cmd_name; croak "not a file: $cmd_name" unless -f $cmd_name; croak "permission denied: $cmd_name" unless -x $cmd_name; return $cmd_name; } if ( exists $cmd_cache{$cmd_name} ) { _debug "'$cmd_name' found in cache: '$cmd_cache{$cmd_name}'" if _debugging; return $cmd_cache{$cmd_name} if -x $cmd_cache{$cmd_name}; _debug "'$cmd_cache{$cmd_name}' no longer executable, searching..." if _debugging; delete $cmd_cache{$cmd_name}; } my @searched_in; ## This next bit is Unix/Win32 specific, unfortunately. ## There's been some conversation about extending File::Spec to provide ## a universal interface to PATH, but I haven't seen it yet. my $re = Win32_MODE ? qr/;/ : qr/:/; LOOP: for ( split( $re, $ENV{PATH} || '', -1 ) ) { $_ = "." unless length $_; push @searched_in, $_; my $prospect = File::Spec->catfile( $_, $cmd_name ); my @prospects; @prospects = ( Win32_MODE && !( -f $prospect && -x _ ) ) ? map "$prospect$_", split /;/, $ENV{PATHEXT} || ".COM;.BAT;.EXE" : ($prospect); for my $found (@prospects) { if ( -f $found && -x _ ) { $cmd_cache{$cmd_name} = $found; last LOOP; } } } if ( exists $cmd_cache{$cmd_name} ) { _debug "'", $cmd_name, "' added to cache: '", $cmd_cache{$cmd_name}, "'" if _debugging_details; return $cmd_cache{$cmd_name}; } croak "Command '$cmd_name' not found in " . join( ", ", @searched_in ); } sub _empty($) { !( defined $_[0] && length $_[0] ) } ## 'safe' versions of otherwise fun things to do. See also IPC::Run::Win32Helper. sub _close { confess 'undef' unless defined $_[0]; my $fd = $_[0] =~ /^\d+$/ ? $_[0] : fileno $_[0]; my $r = POSIX::close $fd; $r = $r ? '' : " ERROR $!"; delete $fds{$fd}; _debug "close( $fd ) = " . ( $r || 0 ) if _debugging_details; } sub _dup { confess 'undef' unless defined $_[0]; my $r = POSIX::dup( $_[0] ); croak "$!: dup( $_[0] )" unless defined $r; $r = 0 if $r eq '0 but true'; _debug "dup( $_[0] ) = $r" if _debugging_details; $fds{$r} = 1; return $r; } sub _dup2_rudely { confess 'undef' unless defined $_[0] && defined $_[1]; my $r = POSIX::dup2( $_[0], $_[1] ); croak "$!: dup2( $_[0], $_[1] )" unless defined $r; $r = 0 if $r eq '0 but true'; _debug "dup2( $_[0], $_[1] ) = $r" if _debugging_details; $fds{$r} = 1; return $r; } sub _exec { confess 'undef passed' if grep !defined, @_; # exec @_ or croak "$!: exec( " . join( ', ', @_ ) . " )"; _debug 'exec()ing ', join " ", map "'$_'", @_ if _debugging_details; # { ## Commented out since we don't call this on Win32. # # This works around the bug where 5.6.1 complains # # "Can't exec ...: No error" after an exec on NT, where # # exec() is simulated and actually returns in Perl's C # # code, though Perl's &exec does not... # no warnings "exec"; # # # Just in case the no warnings workaround # # stops being a workaround, we don't want # # old values of $! causing spurious strerr() # # messages to appear in the "Can't exec" message # undef $!; exec { $_[0] } @_; # } # croak "$!: exec( " . join( ', ', map "'$_'", @_ ) . " )"; ## Fall through so $! can be reported to parent. } sub _sysopen { confess 'undef' unless defined $_[0] && defined $_[1]; _debug sprintf( "O_RDONLY=0x%02x ", O_RDONLY ), sprintf( "O_WRONLY=0x%02x ", O_WRONLY ), sprintf( "O_RDWR=0x%02x ", O_RDWR ), sprintf( "O_TRUNC=0x%02x ", O_TRUNC ), sprintf( "O_CREAT=0x%02x ", O_CREAT ), sprintf( "O_APPEND=0x%02x ", O_APPEND ), if _debugging_details; my $r = POSIX::open( $_[0], $_[1], 0644 ); croak "$!: open( $_[0], ", sprintf( "0x%03x", $_[1] ), " )" unless defined $r; _debug "open( $_[0], ", sprintf( "0x%03x", $_[1] ), " ) = $r" if _debugging_data; $fds{$r} = 1; return $r; } sub _pipe { ## Normal, blocking write for pipes that we read and the child writes, ## since most children expect writes to stdout to block rather than ## do a partial write. my ( $r, $w ) = POSIX::pipe; croak "$!: pipe()" unless defined $r; _debug "pipe() = ( $r, $w ) " if _debugging_details; $fds{$r} = $fds{$w} = 1; return ( $r, $w ); } sub _pipe_nb { ## For pipes that we write, unblock the write side, so we can fill a buffer ## and continue to select(). ## Contributed by Borislav Deianov , with minor ## bugfix on fcntl result by me. local ( *R, *W ); my $f = pipe( R, W ); croak "$!: pipe()" unless defined $f; my ( $r, $w ) = ( fileno R, fileno W ); _debug "pipe_nb pipe() = ( $r, $w )" if _debugging_details; unless (Win32_MODE) { ## POSIX::fcntl doesn't take fd numbers, so gotta use Perl's and ## then _dup the originals (which get closed on leaving this block) my $fres = fcntl( W, &F_SETFL, O_WRONLY | O_NONBLOCK ); croak "$!: fcntl( $w, F_SETFL, O_NONBLOCK )" unless $fres; _debug "fcntl( $w, F_SETFL, O_NONBLOCK )" if _debugging_details; } ( $r, $w ) = ( _dup($r), _dup($w) ); _debug "pipe_nb() = ( $r, $w )" if _debugging_details; return ( $r, $w ); } sub _pty { require IO::Pty; my $pty = IO::Pty->new(); croak "$!: pty ()" unless $pty; $pty->autoflush(); $pty->blocking(0) or croak "$!: pty->blocking ( 0 )"; _debug "pty() = ( ", $pty->fileno, ", ", $pty->slave->fileno, " )" if _debugging_details; $fds{ $pty->fileno } = $fds{ $pty->slave->fileno } = 1; return $pty; } sub _read { confess 'undef' unless defined $_[0]; my $s = ''; my $r = POSIX::read( $_[0], $s, 10_000 ); croak "$!: read( $_[0] )" if not($r) and $! != POSIX::EINTR(); $r ||= 0; _debug "read( $_[0] ) = $r chars '$s'" if _debugging_data; return $s; } ## A METHOD, not a function. sub _spawn { my IPC::Run $self = shift; my ($kid) = @_; _debug "opening sync pipe ", $kid->{PID} if _debugging_details; my $sync_reader_fd; ( $sync_reader_fd, $self->{SYNC_WRITER_FD} ) = _pipe; $kid->{PID} = fork(); croak "$! during fork" unless defined $kid->{PID}; unless ( $kid->{PID} ) { ## _do_kid_and_exit closes sync_reader_fd since it closes all unwanted and ## unloved fds. $self->_do_kid_and_exit($kid); } _debug "fork() = ", $kid->{PID} if _debugging_details; ## Wait for kid to get to it's exec() and see if it fails. _close $self->{SYNC_WRITER_FD}; my $sync_pulse = _read $sync_reader_fd; _close $sync_reader_fd; if ( !defined $sync_pulse || length $sync_pulse ) { if ( waitpid( $kid->{PID}, 0 ) >= 0 ) { $kid->{RESULT} = $?; } else { $kid->{RESULT} = -1; } $sync_pulse = "error reading synchronization pipe for $kid->{NUM}, pid $kid->{PID}" unless length $sync_pulse; croak $sync_pulse; } return $kid->{PID}; ## Wait for pty to get set up. This is a hack until we get synchronous ## selects. if ( keys %{ $self->{PTYS} } && $IO::Pty::VERSION < 0.9 ) { _debug "sleeping to give pty a chance to init, will fix when newer IO::Pty arrives."; sleep 1; } } sub _write { confess 'undef' unless defined $_[0] && defined $_[1]; my $r = POSIX::write( $_[0], $_[1], length $_[1] ); croak "$!: write( $_[0], '$_[1]' )" unless $r; _debug "write( $_[0], '$_[1]' ) = $r" if _debugging_data; return $r; } =pod =over =item run Run takes a harness or harness specification and runs it, pumping all input to the child(ren), closing the input pipes when no more input is available, collecting all output that arrives, until the pipes delivering output are closed, then waiting for the children to exit and reaping their result codes. You may think of C as being like start( ... )->finish(); , though there is one subtle difference: run() does not set \$input_scalars to '' like finish() does. If an exception is thrown from run(), all children will be killed off "gently", and then "annihilated" if they do not go gently (in to that dark night. sorry). If any exceptions are thrown, this does a L before propagating them. =cut use vars qw( $in_run ); ## No, not Enron;) sub run { local $in_run = 1; ## Allow run()-only optimizations. my IPC::Run $self = start(@_); my $r = eval { $self->{clear_ins} = 0; $self->finish; }; if ($@) { my $x = $@; $self->kill_kill; die $x; } return $r; } =pod =item signal ## To send it a specific signal by name ("USR1"): signal $h, "USR1"; $h->signal ( "USR1" ); If $signal is provided and defined, sends a signal to all child processes. Try not to send numeric signals, use C<"KILL"> instead of C<9>, for instance. Numeric signals aren't portable. Throws an exception if $signal is undef. This will I clean up the harness, C it if you kill it. Normally TERM kills a process gracefully (this is what the command line utility C does by default), INT is sent by one of the keys C<^C>, C or CDelE>, and C is used to kill a process and make it coredump. The C signal is often used to get a process to "restart", rereading config files, and C and C for really application-specific things. Often, running C (that's a lower case "L") on the command line will list the signals present on your operating system. B: The signal subsystem is not at all portable. We *may* offer to simulate C and C on some operating systems, submit code to me if you want this. B: Up to and including perl v5.6.1, doing almost anything in a signal handler could be dangerous. The most safe code avoids all mallocs and system calls, usually by preallocating a flag before entering the signal handler, altering the flag's value in the handler, and responding to the changed value in the main system: my $got_usr1 = 0; sub usr1_handler { ++$got_signal } $SIG{USR1} = \&usr1_handler; while () { sleep 1; print "GOT IT" while $got_usr1--; } Even this approach is perilous if ++ and -- aren't atomic on your system (I've never heard of this on any modern CPU large enough to run perl). =cut sub signal { my IPC::Run $self = shift; local $cur_self = $self; $self->_kill_kill_kill_pussycat_kill unless @_; Carp::cluck "Ignoring extra parameters passed to kill()" if @_ > 1; my ($signal) = @_; croak "Undefined signal passed to signal" unless defined $signal; for ( grep $_->{PID} && !defined $_->{RESULT}, @{ $self->{KIDS} } ) { _debug "sending $signal to $_->{PID}" if _debugging; kill $signal, $_->{PID} or _debugging && _debug "$! sending $signal to $_->{PID}"; } return; } =pod =item kill_kill ## To kill off a process: $h->kill_kill; kill_kill $h; ## To specify the grace period other than 30 seconds: kill_kill $h, grace => 5; ## To send QUIT instead of KILL if a process refuses to die: kill_kill $h, coup_d_grace => "QUIT"; Sends a C, waits for all children to exit for up to 30 seconds, then sends a C to any that survived the C. Will wait for up to 30 more seconds for the OS to successfully C the processes. The 30 seconds may be overridden by setting the C option, this overrides both timers. The harness is then cleaned up. The doubled name indicates that this function may kill again and avoids colliding with the core Perl C function. Returns a 1 if the C was sufficient, or a 0 if C was required. Throws an exception if C did not permit the children to be reaped. B: The grace period is actually up to 1 second longer than that given. This is because the granularity of C