├── MANIFEST.SKIP ├── .perltidyrc ├── .gitignore ├── eg ├── abuse │ ├── timers │ ├── broken_pipe_on_bad_executable_name │ ├── blocking_debug_with_sub_coprocess │ └── blocking_writes ├── run_daemon ├── synopsis_scripting ├── factorial_scalar ├── factorial_pipe ├── runsu ├── runsh └── factorial ├── t ├── autovivifyfh.t ├── run_stdin-callback-return-array.t ├── bogus.t ├── utf8.t ├── parallel.t ├── win32_newlines.t ├── windows_search_path.t ├── readonly.t ├── signal.t ├── autoflush.t ├── child_fd_inadvertently_closed.t ├── pump.t ├── kill_kill.t ├── parent_and_child_fds_match.t ├── result.t ├── adopt.t ├── timeout.t ├── eintr.t ├── win32_compile.t ├── filter.t ├── io.t ├── binmode.t ├── timer.t ├── harness.t ├── lib │ └── Test.pm └── pty.t ├── xt ├── 98_pod.t ├── 99_perl_minimum_version.t └── 98_pod_coverage.t ├── .github └── workflows │ ├── windows_installation.yml │ ├── macos.yml │ ├── windows.yml │ ├── bsd.yml │ └── linux.yml ├── cpanfile ├── MANIFEST ├── lib └── IPC │ └── Run │ ├── Win32Process.pm │ ├── Win32Pump.pm │ ├── Debug.pm │ ├── IO.pm │ ├── Win32IO.pm │ ├── Timer.pm │ └── Win32Helper.pm ├── Makefile.PL └── LICENSE /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | \.appveyor.cmd 2 | \.appveyor.yml 3 | \.gitignore 4 | \.perltidyrc 5 | \.travis.yml 6 | cpanfile 7 | \.git/ 8 | ^MANIFEST.bak 9 | ^MYMETA.json 10 | ^MYMETA.yml 11 | ^Makefile$ 12 | \.github/ 13 | -------------------------------------------------------------------------------- /.perltidyrc: -------------------------------------------------------------------------------- 1 | -l=400 2 | -i=4 3 | -dt=4 4 | -it=4 5 | -bar 6 | -nsfs 7 | -nolq 8 | --break-at-old-comma-breakpoints 9 | --format-skipping 10 | --format-skipping-begin='#\s*tidyoff' 11 | --format-skipping-end='#\s*tidyon' 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /Makefile 2 | /blib/ 3 | /pm_to_blib 4 | /IPC-Run-20* 5 | /.DS_Store 6 | /Makefile.old 7 | /cover_db/ 8 | /MYMETA.json 9 | /MYMETA.yml 10 | *.orig 11 | *.rej 12 | .svn 13 | META_new.json 14 | run.t.out 15 | /MANIFEST.bak -------------------------------------------------------------------------------- /eg/abuse/timers: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use IPC::Run qw( :all ); 5 | 6 | $IPC::Run::debug = 10; 7 | 8 | alarm 5; 9 | $SIG{ALRM} = sub { die "timeout never fired!" }; 10 | 11 | my $out; 12 | run [ $^X, '-e', 'sleep 10' ], ">", \$out, timeout 1; 13 | -------------------------------------------------------------------------------- /t/autovivifyfh.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use IPC::Run; 5 | use Test::More tests => 3; 6 | 7 | my $h = IPC::Run::start( [ $^X, '-le', 'for (1..10) { print $_ }' ], '>pipe', my $fh ); 8 | ok $h; 9 | my @content = <$fh>; 10 | is_deeply \@content, [ map { "$_\n" } (1..10) ]; 11 | ok $h->finish; 12 | -------------------------------------------------------------------------------- /eg/abuse/broken_pipe_on_bad_executable_name: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | ## Submitted by Dave Mitchell 4 | 5 | use IPC::Run qw(run timeout); 6 | 7 | $IPC::Run::debug = 10; 8 | 9 | warn "parent id=$$\n"; 10 | $res = run [ './nosuchfile', 0 ], \"foo", \$out, \$err; 11 | warn "running after 'run', 12 | pid=$$\n\$?=$?\nstderr=[[[[$err]]]]\nstdout=[[[[$out]]]]\n"; 13 | -------------------------------------------------------------------------------- /eg/run_daemon: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | ## An example of how to daemonize. See the IPC::Run LIMITATIONS section for 4 | ## some reasons why this can be a bit dangerous. 5 | 6 | use strict; 7 | 8 | use IPC::Run qw( run close_terminal ); 9 | 10 | run( 11 | sub { 12 | # ... your code here ... 13 | sleep 15; 14 | }, 15 | init => sub { 16 | close_terminal; 17 | exit if fork; 18 | } 19 | ); 20 | -------------------------------------------------------------------------------- /eg/synopsis_scripting: -------------------------------------------------------------------------------- 1 | use strict; 2 | 3 | my @cat = qw( cat ); 4 | my ( $in_q, $out_q, $err_q ); 5 | 6 | use IPC::Run qw( start pump finish timeout ); 7 | 8 | # Incrementally read from / write to scalars. Note that $in_q 9 | # is a queue that is drained as it is used. $h is for "harness". 10 | my $h = start \@cat, \$in_q, \$out_q, \$err_q, timeout(10), debug => 1; 11 | 12 | $in_q .= "some input\n"; 13 | pump $h until $out_q =~ /input\n/g; 14 | 15 | $in_q .= "some more input\n"; 16 | pump $h until $out_q =~ /\G.*more input\n/; 17 | 18 | $in_q .= "some final input\n"; 19 | finish $h or die "cat returned $?"; 20 | 21 | warn $err_q if $err_q; 22 | print $out_q ; ## All of cat's output 23 | 24 | -------------------------------------------------------------------------------- /xt/98_pod.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Test that the syntax of our POD documentation is valid 4 | use strict; 5 | use warnings; 6 | 7 | BEGIN { 8 | $| = 1; 9 | $^W = 1; 10 | } 11 | 12 | my @MODULES = ( 13 | 'Pod::Simple 3.07', 14 | 'Test::Pod 1.26', 15 | ); 16 | 17 | # Don't run tests during end-user installs 18 | use Test::More; 19 | 20 | # Load the testing modules 21 | foreach my $MODULE (@MODULES) { 22 | eval "use $MODULE"; 23 | if ($@) { 24 | $ENV{RELEASE_TESTING} 25 | ? die("Failed to load required release-testing module $MODULE") 26 | : plan( skip_all => "$MODULE not available for testing" ); 27 | } 28 | } 29 | 30 | all_pod_files_ok(); 31 | 32 | 1; 33 | -------------------------------------------------------------------------------- /xt/99_perl_minimum_version.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Test that our declared minimum Perl version matches our syntax 4 | use strict; 5 | use warnings; 6 | 7 | BEGIN { 8 | $| = 1; 9 | $^W = 1; 10 | } 11 | 12 | my @MODULES = ( 13 | 'Perl::MinimumVersion 1.20', 14 | 'Test::MinimumVersion 0.008', 15 | ); 16 | 17 | # Don't run tests during end-user installs 18 | use Test::More; 19 | 20 | # Load the testing modules 21 | foreach my $MODULE (@MODULES) { 22 | eval "use $MODULE"; 23 | if ($@) { 24 | $ENV{RELEASE_TESTING} 25 | ? die("Failed to load required release-testing module $MODULE") 26 | : plan( skip_all => "$MODULE not available for testing" ); 27 | } 28 | } 29 | 30 | all_minimum_version_from_metayml_ok(); 31 | 32 | 1; 33 | -------------------------------------------------------------------------------- /.github/workflows/windows_installation.yml: -------------------------------------------------------------------------------- 1 | name: Windows_Installation 2 | 3 | on: 4 | # Manual runs only. This test uses the CPAN version of IPC::Run, not Perl 5 | # code at the current commit. This test would fail even for a commit that, 6 | # once released, would lead to this test passing. 7 | workflow_dispatch: 8 | 9 | permissions: {} 10 | 11 | jobs: 12 | build: 13 | runs-on: windows-latest 14 | 15 | steps: 16 | - uses: actions/checkout@v4 17 | - name: Set up perl 18 | uses: shogo82148/actions-setup-perl@v1 19 | with: 20 | perl-version: '5.32' 21 | distribution: strawberry 22 | - run: perl -V 23 | - name: Uninstall and Install Module 24 | run: curl https://cpanmin.us | perl - --verbose --reinstall IPC::Run 25 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | # The cpanfile specification does not explicitly allow testing $^O or $]. cpanm 2 | # tolerates this, but other cpanfile consumers might not. 3 | if ( $^O ne 'MSWin32' ) { 4 | requires 'IO::Pty', '1.08'; # not entirely required; see Makefile.PL 5 | } 6 | else { 7 | requires 'Win32', '0.27'; 8 | requires 'Win32::Process', '0.14'; 9 | requires 'Win32::ShellQuote'; 10 | requires 'Win32API::File', '0.0901'; 11 | if ( $] >= 5.021006 ) { 12 | requires 'Win32API::File', '0.1203'; 13 | } 14 | } 15 | on 'test' => sub { 16 | requires 'Test::More', '0.47'; 17 | recommends 'Readonly'; 18 | }; 19 | on 'develop' => sub { 20 | requires 'Test::Pod::Coverage'; 21 | requires 'Pod::Simple'; 22 | requires 'Test::Pod'; 23 | requires 'Perl::MinimumVersion'; 24 | requires 'Test::MinimumVersion'; 25 | }; 26 | -------------------------------------------------------------------------------- /.github/workflows/macos.yml: -------------------------------------------------------------------------------- 1 | name: macos 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | tags-ignore: 8 | - '*' 9 | pull_request: 10 | workflow_dispatch: 11 | 12 | permissions: {} 13 | 14 | jobs: 15 | perl: 16 | env: 17 | PERL_USE_UNSAFE_INC: 0 18 | AUTHOR_TESTING: 1 19 | AUTOMATED_TESTING: 1 20 | RELEASE_TESTING: 0 21 | 22 | runs-on: macOS-latest 23 | 24 | steps: 25 | - uses: actions/checkout@v4 26 | - name: perl -V 27 | run: perl -V 28 | - name: uses install-with-cpm 29 | uses: perl-actions/install-with-cpm@stable 30 | with: 31 | cpanfile: "cpanfile" 32 | # IO-Tty-1.16 exceeded 60s default 33 | args: "--configure-timeout=600 --with-recommends --with-suggests" 34 | sudo: false 35 | - name: Makefile.PL 36 | run: perl Makefile.PL 37 | - name: make test 38 | run: make test 39 | -------------------------------------------------------------------------------- /eg/factorial_scalar: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | ## Demonstration of using a scalar to queue input to a child process 4 | 5 | use strict; 6 | 7 | use IPC::Run qw( start timeout ); 8 | 9 | die "usage: $0 \n\nwhere is a positive integer\n" unless @ARGV; 10 | my $i = shift; 11 | die "\$i must be > 0, not '$i'" unless $i =~ /^\d+$/ && $i > 0; 12 | 13 | my ( $in, $out ); 14 | 15 | my $h = start ['bc'], \$in, \$out, timeout(5); 16 | 17 | $in = "a = i = $i ; i\n"; 18 | 19 | while () { 20 | $out = ''; 21 | $h->pump until $out =~ s/.*?(\d+)\n/$1/g; 22 | print "bc said: $out\n"; 23 | if ( $out > $i ) { 24 | print "result = $out\n"; 25 | $in = undef; 26 | last; 27 | } 28 | elsif ( $out == '1' ) { 29 | ## End of calculation loop, get bc to output the result 30 | $in = "a\n"; 31 | } 32 | else { 33 | $in = "i = i - 1 ; a = a * i ; i\n"; 34 | } 35 | } 36 | 37 | $h->finish; 38 | -------------------------------------------------------------------------------- /.github/workflows/windows.yml: -------------------------------------------------------------------------------- 1 | name: windows 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | tags-ignore: 8 | - '*' 9 | pull_request: 10 | workflow_dispatch: 11 | 12 | permissions: {} 13 | 14 | jobs: 15 | perl: 16 | env: 17 | PERL_USE_UNSAFE_INC: 0 18 | AUTHOR_TESTING: 0 19 | AUTOMATED_TESTING: 1 20 | RELEASE_TESTING: 0 21 | 22 | runs-on: windows-latest 23 | 24 | strategy: 25 | fail-fast: false 26 | matrix: 27 | perl-version: [latest] 28 | 29 | steps: 30 | - uses: actions/checkout@v4 31 | - name: perl -V 32 | run: perl -V 33 | - name: uses install-with-cpm 34 | uses: perl-actions/install-with-cpm@stable 35 | with: 36 | cpanfile: "cpanfile" 37 | args: "--configure-timeout=600 --with-recommends --with-suggests" 38 | sudo: false 39 | - name: Makefile.PL 40 | run: perl Makefile.PL 41 | - name: make test 42 | run: make test 43 | -------------------------------------------------------------------------------- /eg/factorial_pipe: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | ## Demonstration using a pipe to send input to a child process 4 | 5 | use strict; 6 | 7 | use IPC::Run qw( start pump finish ); 8 | 9 | die "usage: $0 \n\nwhere is a positive integer\n" unless @ARGV; 10 | my $i = shift; 11 | die "\$i must be > 0, not '$i'" unless $i =~ /^\d+$/ && $i > 0; 12 | 13 | my $out; 14 | 15 | my $h = start ['bc'], '', \$out; 16 | my $tmp = select IN; 17 | $| = 1; 18 | select $tmp; 19 | 20 | print IN "a = i = $i ; i\n"; 21 | 22 | while () { 23 | $out = ''; 24 | pump $h until $out =~ s/.*?(\d+)\n/$1/g; 25 | print "bc said: $out\n"; 26 | 27 | if ( $out > $i ) { 28 | ## i! is always >i for i > 0 29 | print "result = ", $out, "\n"; 30 | close(IN); 31 | last; 32 | } 33 | elsif ( $out == '1' ) { 34 | ## End of calculation loop, get bc to output the result 35 | print IN "a\n"; 36 | } 37 | else { 38 | print IN "i = i - 1 ; a = a * i ; i\n"; 39 | } 40 | } 41 | 42 | finish $h ; 43 | -------------------------------------------------------------------------------- /eg/abuse/blocking_debug_with_sub_coprocess: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | ## Submitted by Blair Zajac 4 | 5 | ## Tests blocking when piping though a &sub coprocess. 6 | ## Fixed, now in test suite. 7 | 8 | $| = 1; 9 | 10 | use strict; 11 | use Carp; 12 | use Symbol; 13 | use IPC::Run 0.44 qw(start); 14 | 15 | print "My pid is $$\n"; 16 | 17 | my $out_fd = gensym; 18 | open( $out_fd, ">ZZZ.test" ) 19 | or die "$0: open: $!\n"; 20 | 21 | my $queue = ''; 22 | 23 | my @commands = ( 24 | [ [ 'cat', '-' ], \$queue, '|' ], 25 | [ ['cat'], '|' ], 26 | [ \&double, '>', $out_fd ] 27 | ); 28 | 29 | my $harness = start 'debug' => 10, map { @$_ } @commands; 30 | $harness 31 | or die "$0: harness\n"; 32 | 33 | close($out_fd) 34 | or die "$0: cannot close: $!\n"; 35 | 36 | for ( 1 .. 100 ) { 37 | $queue .= rand(100) . "\n"; 38 | $harness->pump; 39 | } 40 | $harness->finish 41 | or die "$0: finish\n"; 42 | 43 | exit 0; 44 | 45 | sub double { 46 | while () { 47 | s/\s+$//; 48 | print "$_ $_\n"; 49 | } 50 | } 51 | -------------------------------------------------------------------------------- /eg/runsu: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | ## Demonstration of chatting with a bash shell. 4 | 5 | use strict; 6 | 7 | use IPC::Run qw( start pump finish timeout ); 8 | 9 | $IPC::Run::debug = 10; 10 | 11 | my ( $in, $out ); 12 | 13 | die "usage: runsu " unless @ARGV; 14 | 15 | my $user = @ARGV > 1 ? shift : $ENV{USER} || $ENV{USERNAME}; 16 | my $passwd = shift; 17 | 18 | my $h = start( 19 | [ qw(su - ), $user ], 'pty>', \$out, 20 | timeout(5), 21 | ); 22 | 23 | pump $h until $out =~ /^password/im; 24 | 25 | $in = "$passwd\n"; 26 | 27 | ## Assume atomic prompt writes 28 | ## and that a non-word is the last char in the prompt. 29 | $out = ''; 30 | pump $h until $out =~ /([^\r\n\w]\s*)(?!\n)$/; 31 | my $prompt = $1; 32 | 33 | print "Detected prompt string = '$prompt'\n"; 34 | 35 | $prompt = quotemeta $prompt; 36 | 37 | for (qw( ls ps fOoBaR pwd )) { 38 | $in = $_ . "\n"; 39 | $out = ''; 40 | $h->timeout(5); # restart the timeout 41 | pump $h until $out =~ s/\A((?s:.*))(?=^.*?$prompt(?!\n)\Z)//m; 42 | print map { "su: $_\n" } split( /\n/m, $1 ); 43 | } 44 | 45 | $in = "exit\n"; 46 | finish $h ; 47 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | Changelog 2 | eg/abuse/blocking_debug_with_sub_coprocess 3 | eg/abuse/blocking_writes 4 | eg/abuse/broken_pipe_on_bad_executable_name 5 | eg/abuse/timers 6 | eg/factorial 7 | eg/factorial_pipe 8 | eg/factorial_scalar 9 | eg/run_daemon 10 | eg/runsh 11 | eg/runsu 12 | eg/synopsis_scripting 13 | lib/IPC/Run.pm 14 | lib/IPC/Run/Debug.pm 15 | lib/IPC/Run/IO.pm 16 | lib/IPC/Run/Timer.pm 17 | lib/IPC/Run/Win32Helper.pm 18 | lib/IPC/Run/Win32IO.pm 19 | lib/IPC/Run/Win32Process.pm 20 | lib/IPC/Run/Win32Pump.pm 21 | LICENSE 22 | Makefile.PL 23 | MANIFEST This list of files 24 | MANIFEST.SKIP 25 | README.md 26 | t/adopt.t 27 | t/autoflush.t 28 | t/autovivifyfh.t 29 | t/binmode.t 30 | t/bogus.t 31 | t/child_fd_inadvertently_closed.t 32 | t/eintr.t 33 | t/filter.t 34 | t/harness.t 35 | t/io.t 36 | t/kill_kill.t 37 | t/lib/Test.pm 38 | t/parallel.t 39 | t/parent_and_child_fds_match.t 40 | t/pty.t 41 | t/pump.t 42 | t/readonly.t 43 | t/result.t 44 | t/run.t 45 | t/run_stdin-callback-return-array.t 46 | t/signal.t 47 | t/timeout.t 48 | t/timer.t 49 | t/utf8.t 50 | t/win32_compile.t 51 | t/win32_newlines.t 52 | t/windows_search_path.t 53 | xt/98_pod.t 54 | xt/98_pod_coverage.t 55 | xt/99_perl_minimum_version.t 56 | -------------------------------------------------------------------------------- /t/run_stdin-callback-return-array.t: -------------------------------------------------------------------------------- 1 | # Demonstrate Perl IPC::Run stdin callback problem returning array 2 | # by David Paul Christensen dpchrist@holgerdanske.com 3 | # Public Domain 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use IPC::Run qw( run ); 9 | use Test::More tests => 9; 10 | 11 | my @cmd = ("true"); 12 | if ($^O eq 'MSWin32') { 13 | @cmd = ( $^X, '-e', 'exit 0' ); 14 | } 15 | our ( $i, @i ); 16 | my ( $in, @in ); 17 | 18 | ok( run( \@cmd ) == 1, "no callback" ); # 1 19 | ok( run( \@cmd, sub { return undef } ) == 1, "undef" ); # 2 20 | ok( run( \@cmd, sub { return "" } ) == 1, "empty string" ); # 3 21 | ok( run( \@cmd, sub { return () } ) == 1, "empty array" ); # 4 22 | ok( run( \@cmd, sub { return $i } ) == 1, "package scalar" ); # 5 23 | ok( run( \@cmd, sub { return $in } ) == 1, "lexical scalar" ); # 6 24 | ok( 25 | run( \@cmd, sub { my @a; return @a } ) == 1, 26 | "block lexical array" 27 | ); # 7 28 | ok( run( \@cmd, sub { return @i } ) == 1, "package array" ); # 8 29 | ok( run( \@cmd, sub { return @in } ) == 1, "lexical array" ); # 9 30 | -------------------------------------------------------------------------------- /t/bogus.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | bogus.t - test bogus file cases. 8 | 9 | =cut 10 | 11 | use strict; 12 | use warnings; 13 | 14 | BEGIN { 15 | $| = 1; 16 | $^W = 1; 17 | if ( $ENV{PERL_CORE} ) { 18 | chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; 19 | unshift @INC, 'lib', '../..'; 20 | $^X = '../../../t/' . $^X; 21 | } 22 | } 23 | 24 | use Test::More tests => 2; 25 | use IPC::Run qw( start ); 26 | 27 | SCOPE: { 28 | ## Older Test.pm's don't grok qr// in $expected. 29 | my $expected = 'file not found'; 30 | eval { start ["./bogus_really_bogus"] }; 31 | my $got = $@ =~ $expected ? $expected : $@ || ""; 32 | is( $got, $expected, "starting ./bogus_really_bogus" ); 33 | } 34 | 35 | SKIP: { 36 | if ( IPC::Run::Win32_MODE() ) { 37 | skip "Can't really exec() $^O", 1; 38 | } 39 | 40 | ## Older Test.pm's don't grok qr// in $expected. 41 | my $expected = 'exec failed'; 42 | my $h = eval { start( [ $^X, "-e", 1 ], _simulate_exec_failure => 1 ); }; 43 | my $got = $@ =~ $expected ? $expected : $@ || ""; 44 | is( $got, $expected, "starting $^X with simulated_exec_failure => 1" ); 45 | } 46 | -------------------------------------------------------------------------------- /eg/abuse/blocking_writes: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | ## Submitted by Borislav Deianov 4 | ## This stresses the blocking write to see if it blocks. 5 | 6 | use Fcntl; 7 | use IO::Pty; 8 | use IPC::Run qw(run); 9 | 10 | sub makecmd { 11 | return [ 12 | 'perl', '-e', 13 | ', print "\n" x ' . $_[0] . '; while(){last if /end/}' 14 | ]; 15 | } 16 | 17 | pipe R, W; 18 | fcntl( W, F_SETFL, O_NONBLOCK ); 19 | while ( syswrite( W, "\n", 1 ) ) { $pipebuf++ } 20 | print "pipe buffer size is $pipebuf\n"; 21 | $in = "\n" x ( $pipebuf * 3 ) . "end\n"; 22 | 23 | print "reading from scalar via pipe... "; 24 | run( makecmd( $pipebuf * 3 ), '<', \$in, '>', \$out ); 25 | print "done\n"; 26 | 27 | print "reading from code via pipe... "; 28 | run( makecmd( $pipebuf * 3 ), '<', sub { $t = $in; undef $in; $t }, '>', \$out ); 29 | print "done\n"; 30 | 31 | $pty = IO::Pty->new(); 32 | $pty->blocking(0); 33 | $slave = $pty->slave(); 34 | while ( $pty->syswrite( "\n", 1 ) ) { $ptybuf++ } 35 | print "pty buffer size is $ptybuf\n"; 36 | $in = "\n" x ( $ptybuf * 3 ) . "end\n"; 37 | 38 | print "reading via pty... "; 39 | run( makecmd( $ptybuf * 3 ), '', \$out ); 40 | print "done\n"; 41 | -------------------------------------------------------------------------------- /eg/runsh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | ## Demonstration of chatting with a bash shell. 4 | 5 | use strict; 6 | 7 | use IPC::Run qw( start pump finish timeout ); 8 | 9 | my ( $in, $out, $err ); 10 | 11 | my $h = start( 12 | [qw(sh -login -i )], \$in, \$out, \$err, 13 | debug => 0, 14 | timeout(5), 15 | ); 16 | 17 | ## The first thing we do is to convert the user's prompt. Normally, we would 18 | ## do a '' as the first command in the for () loop so we could detect errors 19 | ## that bash might emit on startup. In this case, we need to do this 20 | ## initialization first so that we have a prompt to look for so we know that 21 | ## it's ready to accept input. This is all because the startup scripts 22 | ## that bash runs set PS1, and we can't have that. 23 | $in = "PS1=' '\n"; 24 | 25 | ## bash prompts on stderr. Consume everything before the first 26 | ## (which is the second prompt bash issues). 27 | pump $h until $err =~ s/.*(?=^ (?!\n)\Z)//ms; 28 | 29 | for (qw( ls ps fOoBaR pwd )) { 30 | $in = $_ . "\n"; 31 | $out = ''; 32 | pump $h until $err =~ s/\A( .*)(?=^ (?!\n)\Z)//ms; 33 | print map { "sh err: $_\n" } split( /\n/m, $1 ); 34 | print map { "sh: $_\n" } split( /\n/m, $out ); 35 | } 36 | 37 | finish $h ; 38 | -------------------------------------------------------------------------------- /t/utf8.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | 3 | BEGIN { 4 | if ( $^O eq 'MSWin32' ) { 5 | plan skip_all => "no cat on Windows"; #and "cmd /C type con" reads from real STDIN 6 | } 7 | else { 8 | plan tests => 4; 9 | } 10 | } 11 | 12 | use strict; 13 | use warnings; 14 | use IPC::Run (); 15 | use Encode (); 16 | 17 | ##### data setup and sanity check 18 | my $unicode_string = "string\x{2026}"; 19 | my $byte_string = "string\xE2\x80\xA6"; 20 | 21 | ## make sure what we're doing doesn't incidentally change the data and that the data is what we expect 22 | my $x = Encode::decode_utf8($byte_string); 23 | isnt( $x, $byte_string, "Encode::decode_utf8() does not lvalue our bytes string var" ); 24 | is( $unicode_string, Encode::decode_utf8($byte_string), "byte string and unicode string same string as far as humans are concerned" ); 25 | 26 | ##### actual IPC::Run::run() tests 27 | my $bytes_out; 28 | 29 | ## Test using the byte string: "cat" should be transparent. 30 | IPC::Run::run( ["cat"], \$byte_string, \$bytes_out ); 31 | is( $bytes_out, $byte_string, "run() w/ byte string" ); 32 | 33 | ## Same test using the Unicode string 34 | IPC::Run::run( ["cat"], \$unicode_string, \$bytes_out ); 35 | is( Encode::decode_utf8($bytes_out), $unicode_string, "run() w/ unicode string" ); 36 | -------------------------------------------------------------------------------- /t/parallel.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | parallel.t - Test suite for running multiple processes in parallel. 8 | 9 | =cut 10 | 11 | use strict; 12 | use warnings; 13 | 14 | BEGIN { 15 | $| = 1; 16 | $^W = 1; 17 | if ( $ENV{PERL_CORE} ) { 18 | chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; 19 | unshift @INC, 'lib', '../..'; 20 | $^X = '../../../t/' . $^X; 21 | } 22 | } 23 | 24 | ## Handy to have when our output is intermingled with debugging output sent 25 | ## to the debugging fd. 26 | select STDERR; 27 | select STDOUT; 28 | 29 | BEGIN { 30 | use Test::More; 31 | if ( $^O eq 'MSWin32' ) { 32 | plan skip_all => 'Parallel tests are dangerous on MSWin32'; 33 | } 34 | else { 35 | plan tests => 6; 36 | } 37 | 38 | } 39 | use IPC::Run qw( start pump finish ); 40 | 41 | my $text1 = "Hello world 1\n"; 42 | my $text2 = "Hello world 2\n"; 43 | 44 | my @perl = ($^X); 45 | my @catter = ( @perl, '-pe1' ); 46 | 47 | my ( $h1, $h2 ); 48 | my ( $out1, $out2 ); 49 | $h1 = start \@catter, "<", \$text1, ">", \$out1; 50 | ok($h1); 51 | $h2 = start \@catter, "<", \$text2, ">", \$out2; 52 | ok($h2); 53 | pump $h1; 54 | ok(1); 55 | pump $h2; 56 | ok(1); 57 | finish $h1; 58 | ok(1); 59 | finish $h2; 60 | ok(1); 61 | -------------------------------------------------------------------------------- /t/win32_newlines.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use B 'perlstring'; 6 | 7 | sub lines { [ "ab", "\n", "\r", "\r\n", "\n\r" ] } 8 | 9 | BEGIN { 10 | if ( defined $ENV{IPC_SUB_PROCESS} ) { 11 | binmode STDIN, ":raw"; 12 | binmode STDERR, ":raw"; 13 | binmode STDOUT, ":raw"; 14 | print $ENV{IPC_SUB_PROCESS_REPORT_IN} 15 | ? perlstring do { local $/; } 16 | : lines->[ $ENV{IPC_SUB_INDEX} ]; 17 | exit; 18 | } 19 | } 20 | 21 | BEGIN { 22 | $| = 1; 23 | $^W = 1; 24 | } 25 | 26 | use Test::More; 27 | use IPC::Run 'run'; 28 | 29 | plan skip_all => 'Skipping when not on Win32' unless $^O eq 'MSWin32'; 30 | local $TODO = 'https://github.com/toddr/IPC-Run/issues/116'; 31 | plan tests => 10; 32 | 33 | $ENV{IPC_SUB_PROCESS} = 1; 34 | for my $i ( 0 .. $#{ lines() } ) { 35 | my $line = lines->[$i]; 36 | $ENV{IPC_SUB_INDEX} = $i; 37 | for my $report_in ( 1, 0 ) { 38 | $ENV{IPC_SUB_PROCESS_REPORT_IN} = $report_in; 39 | run [ $^X, __FILE__ ], "<", \$line, ">", \my $out; 40 | $out = perlstring $out if not $report_in; 41 | my $print_line = perlstring $line; 42 | is $out, $print_line, 43 | "$print_line - " . ( $report_in ? "child got clean input" : "parent received clean child output" ); 44 | } 45 | } 46 | -------------------------------------------------------------------------------- /t/windows_search_path.t: -------------------------------------------------------------------------------- 1 | #!perl -w 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More tests => 11; 7 | use IPC::Run; 8 | 9 | { 10 | no warnings; 11 | sub IPC::Run::Win32_MODE { 1 } 12 | } 13 | 14 | is( IPC::Run::Win32_MODE, 1, "We're win32 mode?" ); 15 | $^O = 'Win32'; 16 | 17 | # Proves that files in subdirs with . still work. 18 | mkdir '5.11.5'; 19 | my @tests = qw( 20 | ./temp ./temp.EXE 21 | .\\temp .\\temp.EXE 22 | ./5.11.5/temp ./5.11.5/temp.EXE 23 | ./5.11.5/temp ./5.11.5/temp.BAT 24 | ./5.11.5/temp ./5.11.5/temp.COM 25 | 26 | ); 27 | 28 | while (@tests) { 29 | my $path = shift @tests; 30 | my $result = shift @tests; 31 | 32 | touch($result); 33 | my $got = eval { IPC::Run::_search_path($path) }; 34 | 35 | # see https://github.com/toddr/IPC-Run/pull/155 conversation for details 36 | local $TODO = qq{on msys noacl mounts, "-x $result" is false} 37 | if $result =~ /BAT$/ && !-x $result; 38 | is( $@, '', "No error calling _search_path for '$path'" ); 39 | is( $got, $result, "Executable $result found" ); 40 | unlink $result; 41 | } 42 | 43 | exit; 44 | 45 | sub touch { 46 | my $file = shift; 47 | open( FH, ">$file" ) or die; 48 | print FH 1 or die; 49 | close FH or die; 50 | chmod( 0700, $file ) or die; 51 | } 52 | 53 | sub END { 54 | rmdir('5.11.5'); 55 | } 56 | -------------------------------------------------------------------------------- /t/readonly.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | # Test script to reproduce error: 4 | # Modification of a read-only value attempted at //ms/dist/perl5/PROJ/IPC-Run/0.79/lib/perl5/IPC/Run.pm line 1695 5 | # 6 | # Global $_ is set to a Readonly value when IPC::run() is called. 7 | # Note that in test below, $value (which is $_) is not actually passed to IPC::run() 8 | # 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use IPC::Run 'run'; 14 | use Test::More; 15 | 16 | $] > 5.014 or plan skip_all => q{IPC::Run doesn't support Readonly below 5.14}; 17 | 18 | BEGIN { 19 | eval 'use Readonly'; 20 | $INC{'Readonly.pm'} or plan skip_all => "Readonly is required for this test to work."; 21 | } 22 | 23 | my @lowercase = 'a' .. 'c'; 24 | Readonly::Array my @UPPERCASE => 'A' .. 'C'; 25 | Readonly my @MIXEDCASE => qw( X y Z ); 26 | 27 | run_echo($_) for ( @lowercase, @UPPERCASE, @MIXEDCASE ); 28 | 29 | done_testing(); 30 | exit; 31 | 32 | sub run_echo { 33 | my $value = shift; 34 | 35 | # my @args = ( '/bin/echo', $value ); 36 | my @args = ( '/bin/echo', 'hello' ); 37 | if ($^O eq 'MSWin32') { 38 | @args = ( $^X, '-e', 'print "hello\n"' ); 39 | } 40 | 41 | my $t = "test case '$value': '@args'"; 42 | note("Running $t"); 43 | 44 | my ( $in, $out, $err ); 45 | my $rv = run( [@args], \$in, \$out, \$err ) 46 | or die "Cannot run @args: $err"; 47 | ok( $rv, "Ran $t: OK" ); 48 | note($out); 49 | } 50 | -------------------------------------------------------------------------------- /t/signal.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | signal.t - Test suite IPC::Run->signal 8 | 9 | =cut 10 | 11 | use strict; 12 | use warnings; 13 | 14 | BEGIN { 15 | $| = 1; 16 | $^W = 1; 17 | if ( $ENV{PERL_CORE} ) { 18 | chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; 19 | unshift @INC, 'lib', '../..'; 20 | $^X = '../../../t/' . $^X; 21 | } 22 | } 23 | 24 | use Test::More; 25 | use IPC::Run qw( :filters :filter_imp start run ); 26 | 27 | require './t/lib/Test.pm'; 28 | IPC::Run::Test->import(); 29 | 30 | BEGIN { 31 | if ( IPC::Run::Win32_MODE() ) { 32 | plan skip_all => 'Skipping on Win32'; 33 | exit(0); 34 | } 35 | else { 36 | plan tests => 3; 37 | } 38 | } 39 | 40 | my @receiver = ( 41 | $^X, 42 | '-e', 43 | <<'END_RECEIVER', 44 | my $which = " "; 45 | sub s{ $which = $_[0] }; 46 | $SIG{$_}=\&s for (qw(USR1 USR2)); 47 | $| = 1; 48 | print "Ok\n"; 49 | for (1..10) { sleep 1; print $which, "\n" } 50 | END_RECEIVER 51 | ); 52 | 53 | my $h; 54 | my $out; 55 | 56 | $h = start \@receiver, \undef, \$out; 57 | pump $h until $out =~ /Ok/; 58 | ok 1; 59 | $out = ""; 60 | $h->signal("USR2"); 61 | pump $h; 62 | $h->signal("USR1"); 63 | pump $h; 64 | $h->signal("USR2"); 65 | pump $h; 66 | $h->signal("USR1"); 67 | pump $h; 68 | ok $out, "USR2\nUSR1\nUSR2\nUSR1\n"; 69 | $h->signal("TERM"); 70 | finish $h; 71 | ok(1); 72 | -------------------------------------------------------------------------------- /.github/workflows/bsd.yml: -------------------------------------------------------------------------------- 1 | name: BSDs 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | tags-ignore: 8 | - '*' 9 | pull_request: 10 | workflow_dispatch: 11 | 12 | permissions: {} 13 | 14 | jobs: 15 | BSDs: 16 | # Run BSDs using virtualization 17 | runs-on: ubuntu-latest 18 | 19 | strategy: 20 | fail-fast: false 21 | matrix: 22 | os: 23 | - name: freebsd 24 | version: '14.0' 25 | pkginstall: pkg install -y p5-ExtUtils-MakeMaker 26 | 27 | - name: openbsd 28 | version: '7.5' 29 | pkginstall: echo no packages required 30 | 31 | - name: netbsd 32 | version: '10.0' 33 | pkginstall: pkgin -y install perl || true 34 | steps: 35 | - uses: actions/checkout@v4 36 | with: 37 | submodules: recursive 38 | 39 | - name: Test on ${{ matrix.os.name }} 40 | uses: cross-platform-actions/action@b2e15da1e667187766fff4945d20b98ac7055576 # v0.24.0 41 | with: 42 | operating_system: ${{ matrix.os.name }} 43 | version: ${{ matrix.os.version }} 44 | shell: bash 45 | run: | 46 | sudo ${{ matrix.os.pkginstall }} 47 | /usr/sbin/pkg_info || true 48 | curl -L https://cpanmin.us | sudo perl - --notest --installdeps --with-configure --with-develop . 49 | perl Makefile.PL 50 | make 51 | prove -wlvmb t 52 | -------------------------------------------------------------------------------- /t/autoflush.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use IPC::Run; 5 | use Test::More tests => 4; 6 | 7 | if ( $^O !~ /Win32/ ) { 8 | STDOUT->autoflush(); 9 | my $flush = sprintf( "AUTOFLUSH %s: %d", select, $| ); 10 | is( $flush, "AUTOFLUSH main::STDOUT: 1", "Autoflush set" ); 11 | 12 | IPC::Run::run( [ $^X, '-V' ], '1>', "/dev/null", '2>', "/dev/null" ); 13 | 14 | $flush = sprintf( "AUTOFLUSH %s: %d", select, $| ); 15 | is( $flush, "AUTOFLUSH main::STDOUT: 1", "Autoflush still set" ); 16 | 17 | STDOUT->autoflush(0); 18 | $flush = sprintf( "AUTOFLUSH %s: %d", select, $| ); 19 | is( $flush, "AUTOFLUSH main::STDOUT: 0", "Autoflush unset" ); 20 | 21 | IPC::Run::run( [ $^X, '-V' ], '1>', "/dev/null", '2>', "/dev/null" ); 22 | 23 | $flush = sprintf( "AUTOFLUSH %s: %d", select, $| ); 24 | is( $flush, "AUTOFLUSH main::STDOUT: 0", "Autoflush still unset" ); 25 | } 26 | else { 27 | my $flush = sprintf( "AUTOFLUSH %s: %d", select, $| ); 28 | is( $flush, "AUTOFLUSH main::STDOUT: 1", "Autoflush set" ); 29 | 30 | IPC::Run::run( [ $^X, '-V' ], '1>', "/dev/null", '2>', "/dev/null" ); 31 | 32 | $flush = sprintf( "AUTOFLUSH %s: %d", select, $| ); 33 | is( $flush, "AUTOFLUSH main::STDOUT: 1", "Autoflush still set" ); 34 | 35 | { local $TODO = 'Seems to work on at least Strawberry Perl 5.20.0'; 36 | STDOUT->autoflush(0); 37 | $flush = sprintf( "AUTOFLUSH %s: %d", select, $| ); 38 | is( $flush, "AUTOFLUSH main::STDOUT: 1", "Unseting Autoflush on Windows doesn't work" ); 39 | } 40 | 41 | pass('Finished Windows test'); 42 | } 43 | -------------------------------------------------------------------------------- /t/child_fd_inadvertently_closed.t: -------------------------------------------------------------------------------- 1 | #! perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use IPC::Run 'run'; 8 | 9 | plan skip_all => "$^O does not allow redirection of file descriptors > 2" 10 | if IPC::Run::Win32_MODE(); 11 | plan tests => 1; 12 | 13 | use File::Temp; 14 | use IO::Handle; 15 | 16 | use POSIX (); 17 | 18 | # trigger IPC::Run bug where parent has $fd open 19 | # and child needs $fd & $fd+1 20 | 21 | my $error; 22 | 23 | sub parent { 24 | 25 | # dup stderr so we get some fd 26 | my $xfd = POSIX::dup( 2 ); 27 | die $! if $xfd == -1; 28 | 29 | my @fds = ( $xfd, $xfd + 1 ); 30 | 31 | # create input files to be attached to the fds 32 | my @tmp; 33 | @tmp[@fds] = map { 34 | my $tmp = File::Temp->new; 35 | $tmp->print( $_ ); 36 | $tmp->close; 37 | $tmp 38 | } @fds; 39 | 40 | 41 | # child reads from fds and make sure that 42 | # it can open them and that they're attached 43 | # to the files it expects. 44 | my $child = sub { 45 | 46 | for my $fd ( @fds ) { 47 | 48 | my $io = IO::Handle->new_from_fd( $fd, '<' ) 49 | or print( STDERR ( "error fdopening $fd\n" ) ), next; 50 | 51 | my $input = $io->getline; 52 | print STDERR "expected >$fd<. got >$input<\n" 53 | unless $fd eq $input; 54 | 55 | } 56 | 57 | 58 | }; 59 | 60 | run $child,( map { $_ . '<', $tmp[$_]->filename } @fds, ), '2>', \$error; 61 | 62 | POSIX::close $xfd; 63 | } 64 | 65 | parent; 66 | is ( $error, '', "child fd not closed" ) 67 | or note $error; 68 | -------------------------------------------------------------------------------- /xt/98_pod_coverage.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # Test that the syntax of our POD documentation is valid 4 | use strict; 5 | use warnings; 6 | 7 | BEGIN { 8 | $| = 1; 9 | $^W = 1; 10 | } 11 | 12 | my @MODULES = ( 13 | 'Test::Pod::Coverage 1.04', 14 | ); 15 | 16 | # Don't run tests during end-user installs 17 | use Test::More; 18 | 19 | # Load the testing modules 20 | foreach my $MODULE (@MODULES) { 21 | eval "use $MODULE"; 22 | if ($@) { 23 | $ENV{RELEASE_TESTING} 24 | ? die("Failed to load required release-testing module $MODULE") 25 | : plan( skip_all => "$MODULE not available for testing" ); 26 | } 27 | } 28 | plan tests => 8; 29 | 30 | #my $private_subs = { private => [qr/foo_fizz/]}; 31 | #pod_coverage_ok('IPC::Run', $private_subs, "Test IPC::Run that all modules are documented."); 32 | 33 | pod_coverage_ok( 'IPC::Run', "Test IPC::Run that all modules are documented." ); 34 | pod_coverage_ok( 'IPC::Run::Debug', "Test IPC::Run::Debug that all modules are documented." ); 35 | pod_coverage_ok( 'IPC::Run::IO', "Test IPC::Run::IO that all modules are documented." ); 36 | pod_coverage_ok( 'IPC::Run::Timer', "Test IPC::Run::Timer that all modules are documented." ); 37 | pod_coverage_ok( 'IPC::Run::Win32Process', "Test IPC::Run::Win32Process that all modules are documented." ); 38 | TODO: { 39 | local $TODO = "These modules are not fully documented yet."; 40 | pod_coverage_ok( 'IPC::Run::Win32Helper', "Test IPC::Run::Win32Helper that all modules are documented." ); 41 | pod_coverage_ok( 'IPC::Run::Win32IO', "Test IPC::Run::Win32IO that all modules are documented." ); 42 | pod_coverage_ok( 'IPC::Run::Win32Pump', "Test IPC::Run::Win32Pump that all modules are documented." ); 43 | } 44 | -------------------------------------------------------------------------------- /.github/workflows/linux.yml: -------------------------------------------------------------------------------- 1 | name: linux 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | tags-ignore: 8 | - '*' 9 | pull_request: 10 | workflow_dispatch: 11 | 12 | permissions: {} 13 | 14 | jobs: 15 | perl: 16 | runs-on: ubuntu-latest 17 | name: "perl ${{ matrix.perl-version }}" 18 | 19 | env: 20 | PERL_USE_UNSAFE_INC: 0 21 | AUTHOR_TESTING: 0 22 | AUTOMATED_TESTING: 1 23 | RELEASE_TESTING: 1 24 | 25 | strategy: 26 | fail-fast: false 27 | matrix: 28 | perl-version: [latest, "5.36", "5.34", "5.32", "5.30", "5.28", "5.26", "5.24", "5.22", "5.20", "5.18", "5.16", "5.14", "5.12", "5.10", "5.8"] 29 | 30 | container: 31 | image: perldocker/perl-tester:${{ matrix.perl-version }} 32 | 33 | steps: 34 | - uses: actions/checkout@v4 35 | - name: uses install-with-cpm 36 | uses: perl-actions/install-with-cpm@stable 37 | with: 38 | cpanfile: "cpanfile" 39 | args: "--configure-timeout=600 --with-recommends --with-suggests" 40 | sudo: false 41 | - run: perl Makefile.PL 42 | - run: make test 43 | 44 | xt: 45 | env: 46 | PERL_USE_UNSAFE_INC: 0 47 | AUTHOR_TESTING: 1 48 | AUTOMATED_TESTING: 1 49 | RELEASE_TESTING: 1 50 | 51 | runs-on: ubuntu-latest 52 | 53 | strategy: 54 | fail-fast: false 55 | 56 | container: 57 | image: perldocker/perl-tester:latest 58 | 59 | steps: 60 | - uses: actions/checkout@v4 61 | - name: perl -V 62 | run: perl -V 63 | - name: Install Dependencies 64 | run: cpm install --with-develop -g --show-build-log-on-failure 65 | - name: Makefile.PL 66 | run: | 67 | perl Makefile.PL 68 | mv MYMETA.json META.json 69 | mv MYMETA.yml META.yml 70 | - name: extended tests 71 | run: prove -lb xt/*.t 72 | -------------------------------------------------------------------------------- /eg/factorial: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | ## Demonstration of event-driven interaction with a subprocess 4 | 5 | ## Event driven programming is a pain. This code is not that readable 6 | ## and is not a good place to start, especially since few people (including 7 | ## me) are familiar with bc's nuances. 8 | 9 | use strict; 10 | 11 | use IPC::Run qw( run ); 12 | 13 | die "usage: $0 \n\nwhere is a positive integer\n" unless @ARGV; 14 | my $i = shift; 15 | die "\$i must be > 0, not '$i'" unless $i =~ /^\d+$/ && $i > 0; 16 | 17 | ## bc instructions to initialize two variables and print one out 18 | my $stdin_queue = "a = i = $i ; i\n"; 19 | 20 | ## Note the FALSE on failure result (opposite of system()). 21 | die $! unless run( 22 | ['bc'], 23 | sub { 24 | ## Consume all input and return it. This is used instead of a plain 25 | ## scalar because run() would close bc's stdin the first time the 26 | ## scalar emptied. 27 | my $r = $stdin_queue; 28 | $stdin_queue = ''; 29 | return $r; 30 | }, 31 | sub { 32 | my $out = shift; 33 | print "bc said: ", $out; 34 | 35 | if ( $out =~ s/.*?(\d+)\n/$1/g ) { 36 | ## Grab the number from bc. Assume all numbers are delivered in 37 | ## single chunks and all numbers are significant. 38 | if ( $out > $i ) { 39 | ## i! is always >i for i > 0 40 | print "result = ", $out, "\n"; 41 | $stdin_queue = undef; 42 | } 43 | elsif ( $out == '1' ) { 44 | ## End of calculation loop, get bc to output the result. 45 | $stdin_queue = "a\n"; 46 | } 47 | else { 48 | ## get bc to calculate the next iteration and print it out. 49 | $stdin_queue = "i = i - 1 ; a = a * i ; i\n"; 50 | } 51 | } 52 | }, 53 | ); 54 | -------------------------------------------------------------------------------- /t/pump.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | pump.t - Test suite for IPC::Run::run, etc. 8 | 9 | =cut 10 | 11 | use strict; 12 | use warnings; 13 | 14 | BEGIN { 15 | $| = 1; 16 | $^W = 1; 17 | if ( $ENV{PERL_CORE} ) { 18 | chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; 19 | unshift @INC, 'lib', '../..'; 20 | $^X = '../../../t/' . $^X; 21 | } 22 | } 23 | 24 | use Test::More tests => 27; 25 | use IPC::Run::Debug qw( _map_fds ); 26 | use IPC::Run qw( start pump finish timeout ); 27 | 28 | ## 29 | ## $^X is the path to the perl binary. This is used run all the subprocesses. 30 | ## 31 | my @echoer = ( $^X, '-pe', 'BEGIN { $| = 1 }' ); 32 | my $in; 33 | my $out; 34 | my $h; 35 | my $fd_map; 36 | 37 | $in = 'SHOULD BE UNCHANGED'; 38 | $out = 'REPLACE ME'; 39 | $? = 99; 40 | $fd_map = _map_fds; 41 | $h = start( \@echoer, \$in, \$out, timeout 5 ); 42 | ok( $h->isa('IPC::Run') ); 43 | is( $?, 99 ); 44 | is( $in, 'SHOULD BE UNCHANGED' ); 45 | is( $out, '' ); 46 | ok( $h->pumpable ); 47 | $in = ''; 48 | $? = 0; 49 | pump_nb $h for ( 1 .. 100 ); 50 | ok(1); 51 | is( $in, '' ); 52 | is( $out, '' ); 53 | ok( $h->pumpable ); 54 | $in = "hello\n"; 55 | $? = 0; 56 | pump $h until $out =~ /hello/; 57 | ok(1); 58 | ok( !$? ); 59 | is( $in, '' ); 60 | is( $out, "hello\n" ); 61 | ok( $h->pumpable ); 62 | $in = "world\n"; 63 | $? = 0; 64 | pump $h until $out =~ /world/; 65 | ok(1); 66 | ok( !$? ); 67 | is( $in, '' ); 68 | is( $out, "hello\nworld\n" ); 69 | ok( $h->pumpable ); 70 | 71 | ## Test \G pos() restoral 72 | $in = "hello\n"; 73 | $out = ""; 74 | $? = 0; 75 | pump $h until $out =~ /hello\n/g; 76 | ok(1); 77 | is pos($out), 6, "pos\$out"; 78 | $in = "world\n"; 79 | $? = 0; 80 | pump $h until $out =~ /\Gworld/gc; 81 | ok(1); 82 | ok( $h->finish ); 83 | ok( !$? ); 84 | is( _map_fds, $fd_map ); 85 | is( $out, "hello\nworld\n" ); 86 | ok( !$h->pumpable ); 87 | -------------------------------------------------------------------------------- /t/kill_kill.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | kill_kill.t - Test suite for IPC::Run->kill_kill 8 | 9 | =cut 10 | 11 | BEGIN { 12 | $| = 1; 13 | $^W = 1; 14 | if ( $ENV{PERL_CORE} ) { 15 | chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; 16 | unshift @INC, 'lib', '../..'; 17 | $^X = '../../../t/' . $^X; 18 | } 19 | } 20 | 21 | use strict; 22 | use warnings; 23 | use Test::More; 24 | use IPC::Run (); 25 | 26 | # Don't run this test script on Windows at all 27 | if ( IPC::Run::Win32_MODE() ) { 28 | plan( skip_all => 'Temporarily ignoring test failure on Win32' ); 29 | exit(0); 30 | } 31 | else { 32 | plan( tests => 2 ); 33 | } 34 | 35 | # Test 1 36 | SCOPE: { 37 | my $out; 38 | my $h = IPC::Run::start( 39 | [ 40 | $^X, 41 | '-e', 42 | '$|=1;print "running\n";sleep while 1', 43 | ], 44 | \undef, 45 | \$out 46 | ); 47 | 48 | # On most platforms, we don't need to wait to read the "running" message. 49 | # On NetBSD 10.0, not waiting led to us often issuing kill(kid, SIGTERM) 50 | # before the end of the child's exec(). Per https://gnats.netbsd.org/58268, 51 | # NetBSD then discarded the signal. 52 | pump $h until $out =~ /running/; 53 | my $needed = $h->kill_kill; 54 | ok( !$needed, 'Did not need kill_kill' ); 55 | } 56 | 57 | # Test 2 58 | SKIP: { 59 | if ( IPC::Run::Win32_MODE() ) { 60 | skip( "$^O does not support ignoring the TERM signal", 1 ); 61 | } 62 | 63 | my $out; 64 | my $h = IPC::Run::start( 65 | [ 66 | $^X, 67 | '-e', 68 | '$SIG{TERM}=sub{};$|=1;print "running\n";sleep while 1', 69 | ], 70 | \undef, 71 | \$out 72 | ); 73 | pump $h until $out =~ /running/; 74 | my $needed = $h->kill_kill( grace => 1 ); 75 | ok( $needed, 'Did need kill_kill' ); 76 | } 77 | -------------------------------------------------------------------------------- /t/parent_and_child_fds_match.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | # 3 | # Test a child process can use the fd if it happens to be the same number as it 4 | # was in the parent. 5 | 6 | use strict; 7 | use warnings; 8 | 9 | use Data::Dumper; 10 | use File::Temp qw( tempfile ); 11 | use IO::Handle (); 12 | use IPC::Run (); 13 | 14 | if (@ARGV > 0 && $ARGV[0] eq 'child') { 15 | exit(child()); 16 | } 17 | 18 | exit(parent()); 19 | 20 | sub child { 21 | my $fh = IO::Handle->new_from_fd(3, '+<'); 22 | die "new_from_fd(): $!" unless defined $fh; 23 | return 0; 24 | } 25 | 26 | sub parent { 27 | # Load at runtime to not involve the child's run in any tests. We could 28 | # alternatively move the child to its own program but it is easier to 29 | # re-run ourselves by using $0. 30 | require Test::More; 31 | Test::More->import; 32 | 33 | plan(skip_all => "$^O does not allow redirection of file descriptors > 2") 34 | if IPC::Run::Win32_MODE(); 35 | # We can't use done_testing() to account for number of tests as 5.8.9's 36 | # Test::More apparently doesn't support that. 37 | plan(tests => 3); 38 | 39 | # This is fd 3 since we have 0, 1, 2 taken by stdin, stdout, and stderr. 40 | my $fh = tempfile(); 41 | ok($fh, 'opened file'); 42 | 43 | my @command = ($^X, $0, 'child'); 44 | 45 | my $stdout = sub { note_output("stdout", $_); return; }; 46 | my $stderr = sub { note_output("stderr", $_); return; }; 47 | 48 | my $harness = IPC::Run::start( 49 | \@command, 50 | \undef, # fd 0 51 | $stdout, # fd 1 52 | $stderr, # fd 2 53 | $fh, # fd 3 54 | ); 55 | 56 | ok($harness, 'started process'); 57 | 58 | ok($harness->finish, 'child process exited with success status'); 59 | 60 | return 0; 61 | } 62 | 63 | sub note_output { 64 | my ($prefix, $rest) = @_; 65 | if (ref $rest) { 66 | note("$prefix: " . Dumper($rest)); 67 | return; 68 | } 69 | note("$prefix: $rest"); 70 | return; 71 | } 72 | -------------------------------------------------------------------------------- /t/result.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use IPC::Run qw( harness ); 5 | use Test::More tests => 12; 6 | 7 | my @perl = ($^X); 8 | my @exit0 = ( @perl, '-e', q{ exit 0 } ); 9 | my @exit42 = ( @perl, '-e', q{ exit 42 } ); 10 | my ( @cmds, @expect_full, $first_nonzero, $first_nonzero_full ); 11 | if (IPC::Run::Win32_MODE) { 12 | require IPC::Run::Win32Process; 13 | require Math::BigInt; 14 | 15 | # Perl exit() doesn't preserve these high exit codes, but cmd.exe does. 16 | my $exit_max_shifted = IPC::Run::Win32Process->new( 17 | $ENV{COMSPEC}, 18 | q{cmd.exe /c exit 16777215} 19 | ); 20 | my $exit_max = IPC::Run::Win32Process->new( 21 | $ENV{COMSPEC}, 22 | q{cmd.exe /c exit 4294967295} 23 | ); 24 | 25 | # Construct 0xFFFFFFFF00 in a way that works on !USE_64_BIT_INT builds. 26 | my $expect_exit_max = Math::BigInt->new(0xFFFFFFFF); 27 | $expect_exit_max->blsft(8); 28 | 29 | @cmds = ( \@exit0, '&', $exit_max, '&', $exit_max_shifted, '&', \@exit42 ); 30 | @expect_full = ( 0, $expect_exit_max, 0xFFFFFF00, 42 << 8 ); 31 | $first_nonzero = 0xFFFFFFFF; 32 | $first_nonzero_full = $expect_exit_max; 33 | } 34 | else { 35 | my @kill9 = ( @perl, '-e', q{ kill 'KILL', $$ } ); 36 | 37 | @cmds = ( \@exit0, '&', \@exit0, '&', \@kill9, '&', \@exit42 ); 38 | @expect_full = ( 0, 0, 9, 42 << 8 ); 39 | $first_nonzero = 42; 40 | $first_nonzero_full = 9; 41 | } 42 | my $h = harness(@cmds); 43 | $h->run; 44 | 45 | is_deeply( 46 | [ $h->results ], [ map { $_ >> 8 } @expect_full ], 47 | 'Results of all processes' 48 | ); 49 | is_deeply( 50 | [ $h->full_results ], \@expect_full, 51 | 'Full results of all processes' 52 | ); 53 | is( $h->result, $first_nonzero, 'First non-zero result' ); 54 | is( $h->full_result, $first_nonzero_full, 'First non-zero full result' ); 55 | foreach my $pos ( 0 .. $#expect_full ) { 56 | is( $h->result($pos), $expect_full[$pos] >> 8, "Result of process $pos" ); 57 | is( 58 | $h->full_result($pos), $expect_full[$pos], 59 | "Full result of process $pos" 60 | ); 61 | } 62 | -------------------------------------------------------------------------------- /t/adopt.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | adopt.t - Test suite for IPC::Run::adopt 8 | 9 | =cut 10 | 11 | use strict; 12 | use warnings; 13 | 14 | BEGIN { 15 | $| = 1; 16 | $^W = 1; 17 | if ( $ENV{PERL_CORE} ) { 18 | chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; 19 | unshift @INC, 'lib', '../..'; 20 | $^X = '../../../t/' . $^X; 21 | } 22 | } 23 | 24 | use Test::More skip_all => 'adopt not implemented yet'; 25 | 26 | # use Test::More tests => 29; 27 | use IPC::Run qw( start pump finish ); 28 | 29 | ## 30 | ## $^X is the path to the perl binary. This is used run all the subprocesses. 31 | ## 32 | my @echoer = ( $^X, '-pe', 'BEGIN { $| = 1 }' ); 33 | 34 | ## 35 | ## harness, pump, run 36 | ## 37 | SCOPE: { 38 | my $in = 'SHOULD BE UNCHANGED'; 39 | my $out = 'REPLACE ME'; 40 | $? = 99; 41 | my $fd_map = IPC::Run::_map_fds(); 42 | my $h = start( \@echoer, \$in, \$out ); 43 | ok( $h->isa('IPC::Run') ); 44 | ok( $?, 99 ); 45 | ok( $in, 'SHOULD BE UNCHANGED' ); 46 | ok( $out, '' ); 47 | ok( $h->pumpable ); 48 | $in = ''; 49 | $? = 0; 50 | pump_nb $h for ( 1 .. 100 ); 51 | ok(1); 52 | ok( $in, '' ); 53 | ok( $out, '' ); 54 | ok( $h->pumpable ); 55 | } 56 | 57 | SCOPE: { 58 | my $in = 'SHOULD BE UNCHANGED'; 59 | my $out = 'REPLACE ME'; 60 | $? = 99; 61 | my $fd_map = IPC::Run::_map_fds(); 62 | my $h = start( \@echoer, \$in, \$out ); 63 | ok( $h->isa('IPC::Run') ); 64 | ok( $?, 99 ); 65 | ok( $in, 'SHOULD BE UNCHANGED' ); 66 | ok( $out, '' ); 67 | ok( $h->pumpable ); 68 | $in = "hello\n"; 69 | $? = 0; 70 | pump $h until $out =~ /hello/; 71 | ok(1); 72 | ok( !$? ); 73 | ok( $in, '' ); 74 | ok( $out, "hello\n" ); 75 | ok( $h->pumpable ); 76 | $in = "world\n"; 77 | $? = 0; 78 | pump $h until $out =~ /world/; 79 | ok(1); 80 | ok( !$? ); 81 | ok( $in, '' ); 82 | ok( $out, "hello\nworld\n" ); 83 | ok( $h->pumpable ); 84 | warn "hi"; 85 | ok( $h->finish ); 86 | ok( !$? ); 87 | ok( IPC::Run::_map_fds(), $fd_map ); 88 | ok( $out, "hello\nworld\n" ); 89 | ok( !$h->pumpable ); 90 | } 91 | -------------------------------------------------------------------------------- /t/timeout.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | timeout.t - Test suite for IPC::Run timeouts 8 | 9 | =cut 10 | 11 | use strict; 12 | use warnings; 13 | 14 | BEGIN { 15 | $| = 1; 16 | $^W = 1; 17 | } 18 | 19 | ## Separate from run.t so run.t is not too slow. 20 | use Test::More; 21 | use IPC::Run qw( harness timeout ); 22 | 23 | plan tests => 26; 24 | 25 | my $h; 26 | my $t; 27 | my $in; 28 | my $out; 29 | my $started; 30 | 31 | $h = harness( [$^X], \$in, \$out, $t = timeout(1) ); 32 | ok( $h->isa('IPC::Run') ); 33 | ok( !!$t->is_reset ); 34 | ok( !$t->is_running ); 35 | ok( !$t->is_expired ); 36 | $started = time; 37 | $h->start; 38 | ok(1); 39 | ok( !$t->is_reset ); 40 | ok( !!$t->is_running ); 41 | ok( !$t->is_expired ); 42 | $in = ''; 43 | eval { $h->pump }; 44 | 45 | # Older perls' Test.pms don't know what to do with qr//s 46 | $@ =~ /IPC::Run: timeout/ ? ok(1) : is( $@, qr/IPC::Run: timeout/ ); 47 | 48 | SCOPE: { 49 | my $elapsed = time - $started; 50 | $elapsed >= 1 ? ok(1) : is( $elapsed, ">= 1" ); 51 | is( $t->interval, 1 ); 52 | ok( !$t->is_reset ); 53 | ok( !$t->is_running ); 54 | ok( !!$t->is_expired ); 55 | 56 | ## 57 | ## Starting from an expired state 58 | ## 59 | $started = time; 60 | $h->start; 61 | ok(1); 62 | ok( !$t->is_reset ); 63 | ok( !!$t->is_running ); 64 | ok( !$t->is_expired ); 65 | $in = ''; 66 | eval { $h->pump }; 67 | $@ =~ /IPC::Run: timeout/ ? ok(1) : is( $@, qr/IPC::Run: timeout/ ); 68 | ok( !$t->is_reset ); 69 | ok( !$t->is_running ); 70 | ok( !!$t->is_expired ); 71 | } 72 | 73 | SCOPE: { 74 | my $elapsed = time - $started; 75 | $elapsed >= 1 ? ok(1) : is( $elapsed, ">= 1" ); 76 | $h = harness( [$^X], \$in, \$out, timeout(1) ); 77 | $started = time; 78 | $h->start; 79 | $in = ''; 80 | eval { $h->pump }; 81 | $@ =~ /IPC::Run: timeout/ ? ok(1) : is( $@, qr/IPC::Run: timeout/ ); 82 | } 83 | 84 | SCOPE: { 85 | my $elapsed = time - $started; 86 | $elapsed >= 1 ? ok(1) : is( $elapsed, ">= 1" ); 87 | } 88 | 89 | { 90 | $h = harness( [ $^X, '-e', 'sleep 1' ], timeout(180), debug => 0 ); 91 | my $started_at = time; 92 | $h->start; 93 | $h->finish; 94 | my $finished_at = time; 95 | ok( $finished_at - $started_at <= 2, 'not too slow to reap' ) 96 | or diag( $finished_at - $started_at . " seconds passed" ); 97 | } 98 | -------------------------------------------------------------------------------- /t/eintr.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | eintr.t - Test select() and read() failing with EINTR 8 | 9 | =cut 10 | 11 | use strict; 12 | use warnings; 13 | 14 | BEGIN { 15 | $| = 1; 16 | $^W = 1; 17 | if ( $ENV{PERL_CORE} ) { 18 | chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; 19 | unshift @INC, 'lib', '../..'; 20 | $^X = '../../../t/' . $^X; 21 | } 22 | } 23 | 24 | use Test::More; 25 | use IPC::Run qw( start run ); 26 | 27 | my $got_usr1 = 0; 28 | $SIG{USR1} = sub { $got_usr1++ }; 29 | 30 | # Need the child to send a signal to this process in order to trigger 31 | # EINTR on select(), skip the test on platforms where we can't do that. 32 | my ( $in, $out, $err ) = ( '', '', '' ); 33 | run [ $^X, '-e', "kill 'USR1', $$" ], \$in, \$out, \$err; 34 | if ( $got_usr1 != 1 ) { 35 | plan skip_all => "can't deliver a signal on this platform"; 36 | } 37 | 38 | plan tests => 5; 39 | 40 | # A kid that will send SIGUSR1 to this process and then produce some output. 41 | my $kid_perl = qq[sleep 1; kill 'USR1', $$; sleep 1; print "foo\n"; sleep 180]; 42 | my @kid = ( $^X, '-e', "\$| = 1; $kid_perl" ); 43 | 44 | # If EINTR on select() is not handled properly then IPC::Run can think 45 | # that one or more kid output handles are ready for reads when they are 46 | # not, causing it to block until the kid exits. 47 | 48 | ( $in, $out, $err ) = ( '', '', '' ); 49 | my $harness = start \@kid, \$in, \$out, \$err; 50 | 51 | my $pump_started = time; 52 | $harness->pump; 53 | 54 | is $out, "foo\n", "got stdout on the first pump"; 55 | 56 | ok time - $pump_started < 180, "first pump didn't wait for kid exit"; 57 | 58 | is $got_usr1, 2, 'got USR1 from the kid'; 59 | 60 | $harness->kill_kill; 61 | $harness->finish; 62 | 63 | # Have kid send SIGUSR1 while we're in read of sync pipe. That pipe conveys any 64 | # exec failure to us. 65 | SKIP: { 66 | if ( IPC::Run::Win32_MODE() ) { 67 | skip "Can't really exec() $^O", 2; 68 | } 69 | 70 | my $expected = 'exec failed'; 71 | my $h = eval { 72 | start( 73 | [ $^X, "-e", 1 ], 74 | _sigusr1_after_fork => 1, 75 | _simulate_exec_failure => 1 76 | ); 77 | }; 78 | my $got = $@ =~ $expected ? $expected : $@ || ""; 79 | is $got_usr1, 3, 'got USR1 from the _simulate_exec_failure kid'; 80 | is( $got, $expected, "reported exec failure despite USR1" ); 81 | } 82 | -------------------------------------------------------------------------------- /lib/IPC/Run/Win32Process.pm: -------------------------------------------------------------------------------- 1 | package IPC::Run::Win32Process; 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | IPC::Run::Win32Process -- deliver nonstandard command lines via IPC::Run. 8 | 9 | =head1 SYNOPSIS 10 | 11 | use File::Spec (); 12 | use IPC::Run qw(run); 13 | use IPC::Run::Win32Process (); 14 | use Win32 (); 15 | 16 | $find_exe = File::Spec->catfile(Win32::GetFolderPath(Win32::CSIDL_SYSTEM), 17 | 'find.exe'); 18 | run(IPC::Run::Win32Process->new($ENV{COMSPEC}, q{cmd.exe /c echo ""}), 19 | '|', IPC::Run::Win32Process->new($find_exe, q{find_exe """"""}), 20 | '>', \$out); 21 | 22 | =head1 DESCRIPTION 23 | 24 | This class facilitates executing Windows programs that don't use L. 27 | Notable programs having nonstandard rules include F, F, 28 | and Cygwin programs called from non-Cygwin programs. IPC::Run will use the two 29 | strings, verbatim, as the lpApplicationName and lpCommandLine arguments of 30 | CreateProcessA(). This furnishes unfiltered control over the child process 31 | command line. 32 | 33 | =head1 FUNCTIONS & METHODS 34 | 35 | =over 36 | 37 | =cut 38 | 39 | use strict; 40 | use warnings; 41 | use Carp; 42 | 43 | use overload '""' => sub { 44 | my ($self) = @_; 45 | return join( 46 | '', 47 | 'IPC::Run::Win32Process(', 48 | $self->{lpApplicationName}, 49 | ', ', 50 | $self->{lpCommandLine}, 51 | ')' 52 | ); 53 | }; 54 | 55 | use vars qw{$VERSION}; 56 | 57 | BEGIN { 58 | $VERSION = '20250809.0'; 59 | } 60 | 61 | =item new 62 | 63 | IPC::Run::Win32Process->new( $lpApplicationName, $lpCommandLine ); 64 | IPC::Run::Win32Process->new( $ENV{COMSPEC}, q{cmd.exe /c echo ""} ); 65 | 66 | Constructor. 67 | 68 | =back 69 | 70 | =cut 71 | 72 | sub new { 73 | my ( $class, $lpApplicationName, $lpCommandLine ) = @_; 74 | $class = ref $class || $class; 75 | 76 | croak "missing lpApplicationName" if !defined $lpApplicationName; 77 | croak "missing lpCommandLine" if !defined $lpCommandLine; 78 | 79 | my IPC::Run::Win32Process $self = bless {}, $class; 80 | $self->{lpApplicationName} = $lpApplicationName; 81 | $self->{lpCommandLine} = $lpCommandLine; 82 | 83 | return $self; 84 | } 85 | 86 | 1; 87 | -------------------------------------------------------------------------------- /t/win32_compile.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | win32_compile.t - See if IPC::Run::Win32Helper compiles, even on Unix 8 | 9 | =cut 10 | 11 | use strict; 12 | use warnings; 13 | 14 | BEGIN { 15 | $| = 1; 16 | $^W = 1; 17 | if ( $ENV{PERL_CORE} ) { 18 | chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; 19 | unshift @INC, 'lib', '../..'; 20 | $^X = '../../../t/' . $^X; 21 | } 22 | } 23 | 24 | use Test::More; 25 | 26 | BEGIN { 27 | unless ( eval "require 5.006" ) { 28 | ## NOTE: I'm working around this here because I don't want this 29 | ## test to fail on non-Win32 systems with older Perls. Makefile.PL 30 | ## does the require 5.6.0 to protect folks on Windows. 31 | plan( skip_all => "perl5.00503's Socket.pm does not export IPPROTO_TCP" ); 32 | } 33 | 34 | if ( $^O eq 'android' ) { 35 | plan( skip_all => "android does not support getprotobyname()" ); 36 | } 37 | 38 | $INC{$_} = 1 for qw( 39 | Win32.pm Win32/Process.pm Win32/ShellQuote.pm Win32API/File.pm ); 40 | 41 | package Win32; 42 | 43 | use vars qw( @ISA @EXPORT ); 44 | 45 | @ISA = qw( Exporter ); 46 | @EXPORT = qw( 47 | CSIDL_SYSTEM 48 | ); 49 | 50 | eval "sub $_ {}" for @EXPORT; 51 | 52 | use Exporter; 53 | 54 | package Win32API::File; 55 | 56 | use vars qw( @ISA @EXPORT ); 57 | 58 | @ISA = qw( Exporter ); 59 | @EXPORT = qw( 60 | GetOsFHandle 61 | OsFHandleOpen 62 | OsFHandleOpenFd 63 | FdGetOsFHandle 64 | SetHandleInformation 65 | SetFilePointer 66 | 67 | HANDLE_FLAG_INHERIT 68 | 69 | createFile 70 | WriteFile 71 | ReadFile 72 | CloseHandle 73 | 74 | FILE_ATTRIBUTE_TEMPORARY 75 | FILE_FLAG_DELETE_ON_CLOSE 76 | FILE_FLAG_WRITE_THROUGH 77 | 78 | FILE_BEGIN 79 | ); 80 | 81 | eval "sub $_ { 1 }" for @EXPORT; 82 | 83 | use Exporter; 84 | 85 | package Win32::Process; 86 | 87 | use vars qw( @ISA @EXPORT ); 88 | 89 | @ISA = qw( Exporter ); 90 | @EXPORT = qw( 91 | NORMAL_PRIORITY_CLASS 92 | ); 93 | 94 | eval "sub $_ {}" for @EXPORT; 95 | 96 | use Exporter; 97 | } 98 | 99 | { 100 | use Socket (); 101 | no warnings 'redefine'; 102 | sub Socket::IPPROTO_TCP() { return } 103 | } 104 | 105 | package main; 106 | 107 | use IPC::Run::Win32Helper; 108 | use IPC::Run::Win32IO; 109 | 110 | plan( tests => 1 ); 111 | 112 | ok(1); 113 | -------------------------------------------------------------------------------- /t/filter.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | filter.t - Test suite for IPC::Run filter scaffolding 8 | 9 | =cut 10 | 11 | use strict; 12 | use warnings; 13 | 14 | BEGIN { 15 | $| = 1; 16 | $^W = 1; 17 | if ( $ENV{PERL_CORE} ) { 18 | chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; 19 | unshift @INC, 'lib', '../..'; 20 | $^X = '../../../t/' . $^X; 21 | } 22 | } 23 | 24 | use Test::More tests => 80; 25 | require './t/lib/Test.pm'; 26 | IPC::Run::Test->import(); 27 | use IPC::Run qw( :filters :filter_imp ); 28 | 29 | sub uc_filter { 30 | my ( $in_ref, $out_ref ) = @_; 31 | 32 | return input_avail && do { 33 | $$out_ref .= uc($$in_ref); 34 | $$in_ref = ''; 35 | 1; 36 | } 37 | } 38 | 39 | my $string; 40 | 41 | sub string_source { 42 | my ( $in_ref, $out_ref ) = @_; 43 | return undef unless defined $string; 44 | $$out_ref .= $string; 45 | $string = undef; 46 | return 1; 47 | } 48 | 49 | my $accum; 50 | 51 | sub accum { 52 | my ( $in_ref, $out_ref ) = @_; 53 | return input_avail && do { 54 | $accum .= $$in_ref; 55 | $$in_ref = ''; 56 | 1; 57 | }; 58 | } 59 | 60 | my $op; 61 | 62 | ## "import" the things we're testing. 63 | *_init_filters = \&IPC::Run::_init_filters; 64 | *_do_filters = \&IPC::Run::_do_filters; 65 | 66 | filter_tests( "filter_tests", "hello world", "hello world" ); 67 | filter_tests( "filter_tests []", [qq(hello world)], [qq(hello world)] ); 68 | filter_tests( "filter_tests [] 2", [qw(hello world)], [qw(hello world)] ); 69 | 70 | filter_tests( "uc_filter", "hello world", "HELLO WORLD", \&uc_filter ); 71 | 72 | filter_tests( 73 | "chunking_filter by lines 1", 74 | "hello 1\nhello 2\nhello 3", 75 | [ "hello 1\n", "hello 2\n", "hello 3" ], 76 | new_chunker 77 | ); 78 | 79 | filter_tests( 80 | "chunking_filter by lines 2", 81 | "hello 1\nhello 2\nhello 3", 82 | [ "hello 1\n", "hello 2\n", "hello 3" ], 83 | new_chunker 84 | ); 85 | 86 | filter_tests( 87 | "chunking_filter by lines 2", 88 | [ split( /(\s|\n)/, "hello 1\nhello 2\nhello 3" ) ], 89 | [ "hello 1\n", "hello 2\n", "hello 3" ], 90 | new_chunker 91 | ); 92 | 93 | filter_tests( 94 | "chunking_filter by an odd separator", 95 | "hello world", 96 | "hello world", 97 | new_chunker('odd separator') 98 | ); 99 | 100 | filter_tests( 101 | "chunking_filter 2", 102 | "hello world", 103 | [ 'hello world' =~ m/(.)/g ], 104 | new_chunker(qr/./) 105 | ); 106 | 107 | filter_tests( 108 | "appending_filter", 109 | [qw( 1 2 3 )], 110 | [qw( 1a 2a 3a )], 111 | new_appender("a") 112 | ); 113 | -------------------------------------------------------------------------------- /t/io.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | io.t - Test suite exercising IPC::Run::IO with IPC::Run::run. 8 | 9 | =cut 10 | 11 | use strict; 12 | use warnings; 13 | 14 | BEGIN { 15 | $| = 1; 16 | $^W = 1; 17 | if ( $ENV{PERL_CORE} ) { 18 | chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; 19 | unshift @INC, 'lib', '../..'; 20 | $^X = '../../../t/' . $^X; 21 | } 22 | } 23 | 24 | use Test::More tests => 14; 25 | use IPC::Run qw( :filters run io ); 26 | use IPC::Run::Debug qw( _map_fds ); 27 | 28 | my $text = "Hello World\n"; 29 | my $emitter_script = qq{print '$text'; print STDERR uc( '$text' )}; 30 | ## 31 | ## $^X is the path to the perl binary. This is used run all the subprocesses. 32 | ## 33 | my @perl = ($^X); 34 | my @emitter = ( @perl, '-e', $emitter_script ); 35 | 36 | my $recv; 37 | my $send; 38 | 39 | my $in_file = 'io.t.in'; 40 | my $out_file = 'io.t.out'; 41 | my $err_file = 'io.t.err'; 42 | 43 | my $io; 44 | my $r; 45 | 46 | my $fd_map; 47 | 48 | ## TODO: Test filters, etc. 49 | 50 | sub slurp($) { 51 | my ($f) = @_; 52 | open( S, "<$f" ) or return "$! '$f'"; 53 | my $r = join( '', ); 54 | close S or warn "$! closing '$f'"; 55 | return $r; 56 | } 57 | 58 | sub spit($$) { 59 | my ( $f, $s ) = @_; 60 | open( S, ">$f" ) or die "$! '$f'"; 61 | print S $s or die "$! '$f'"; 62 | close S or die "$! '$f'"; 63 | } 64 | 65 | sub wipe($) { 66 | my ($f) = @_; 67 | unlink $f or warn "$! unlinking '$f'" if -f $f; 68 | } 69 | 70 | $io = io( 'foo', '<', \$send ); 71 | ok $io->isa('IPC::Run::IO'); 72 | 73 | is( io( 'foo', '<', \$send )->mode, 'w' ); 74 | is( io( 'foo', '<<', \$send )->mode, 'wa' ); 75 | is( io( 'foo', '>', \$recv )->mode, 'r' ); 76 | is( io( 'foo', '>>', \$recv )->mode, 'ra' ); 77 | 78 | SKIP: { 79 | if ( IPC::Run::Win32_MODE() ) { 80 | skip( "$^O does not allow select() on non-sockets", 9 ); 81 | } 82 | 83 | ## 84 | ## Input from a file 85 | ## 86 | SCOPE: { 87 | spit $in_file, $text; 88 | $recv = 'REPLACE ME'; 89 | $fd_map = _map_fds; 90 | $r = run io( $in_file, '>', \$recv ); 91 | wipe $in_file; 92 | ok($r); 93 | } 94 | 95 | ok( !$? ); 96 | is( _map_fds, $fd_map ); 97 | is( $recv, $text ); 98 | 99 | ## 100 | ## Output to a file 101 | ## 102 | SCOPE: { 103 | wipe $out_file; 104 | $send = $text; 105 | $fd_map = _map_fds; 106 | $r = run io( $out_file, '<', \$send ); 107 | $recv = slurp $out_file; 108 | wipe $out_file; 109 | ok($r); 110 | } 111 | 112 | ok( !$? ); 113 | is( _map_fds, $fd_map ); 114 | is( $send, $text ); 115 | is( $recv, $text ); 116 | } 117 | -------------------------------------------------------------------------------- /t/binmode.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | binary.t - Test suite for IPC::Run binary functionality 8 | 9 | =cut 10 | 11 | use strict; 12 | use warnings; 13 | 14 | BEGIN { 15 | $| = 1; 16 | $^W = 1; 17 | if ( $ENV{PERL_CORE} ) { 18 | chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; 19 | unshift @INC, 'lib', '../..'; 20 | $^X = '../../../t/' . $^X; 21 | } 22 | } 23 | 24 | ## Handy to have when our output is intermingled with debugging output sent 25 | ## to the debugging fd. 26 | select STDERR; 27 | select STDOUT; 28 | 29 | use Test::More tests => 24; 30 | use IPC::Run qw( harness run binary ); 31 | 32 | sub Win32_MODE(); 33 | *Win32_MODE = \&IPC::Run::Win32_MODE; 34 | 35 | my $crlf_text = "Hello World\r\n"; 36 | 37 | my $text = $crlf_text; 38 | $text =~ s/\r//g if Win32_MODE; 39 | 40 | my $nl_text = $crlf_text; 41 | $nl_text =~ s/\r//g; 42 | 43 | my @perl = ($^X); 44 | 45 | my $emitter_script = q{ binmode STDOUT; print qq{Hello World\r\n} }; 46 | my @emitter = ( @perl, '-e', $emitter_script ); 47 | 48 | my $reporter_script = q{ binmode STDIN; $_ = join q{}, <>; s/([\000-\037])/sprintf qq{\\\\0x%02x}, ord $1/ge; print }; 49 | my @reporter = ( @perl, '-e', $reporter_script ); 50 | 51 | my $in; 52 | my $out; 53 | my $err; 54 | 55 | sub f($) { 56 | my $s = shift; 57 | $s =~ s/([\000-\027])/sprintf "\\0x%02x", ord $1/ge; 58 | $s; 59 | } 60 | 61 | ## Parsing tests 62 | is( eval { harness [], '>', binary, \$out } ? 1 : $@, 1 ); 63 | is( eval { harness [], '>', binary, "foo" } ? 1 : $@, 1 ); 64 | is( eval { harness [], '<', binary, \$in } ? 1 : $@, 1 ); 65 | is( eval { harness [], '<', binary, "foo" } ? 1 : $@, 1 ); 66 | 67 | ## Testing from-kid now so we can use it to test stdin later 68 | ok( run( \@emitter, ">", \$out ) ); 69 | is( f($out), f($text), "no binary" ); 70 | 71 | ok( run( \@emitter, ">", binary, \$out ) ); 72 | is( f($out), f($crlf_text), "out binary" ); 73 | 74 | ok( run( \@emitter, ">", binary(0), \$out ) ); 75 | is( f($out), f($text), "out binary 0" ); 76 | 77 | ok( run( \@emitter, ">", binary(1), \$out ) ); 78 | is( f($out), f($crlf_text), "out binary 1" ); 79 | 80 | ## Test to-kid 81 | ok( run( \@reporter, "<", \$nl_text, ">", \$out ) ); 82 | is( $out, "Hello World" . ( Win32_MODE ? "\\0x0d" : "" ) . "\\0x0a", "reporter < \\n" ); 83 | 84 | ok( run( \@reporter, "<", binary, \$nl_text, ">", \$out ) ); 85 | is( $out, "Hello World\\0x0a", "reporter < binary \\n" ); 86 | 87 | ok( run( \@reporter, "<", binary, \$crlf_text, ">", \$out ) ); 88 | is( $out, "Hello World\\0x0d\\0x0a", "reporter < binary \\r\\n" ); 89 | 90 | ok( run( \@reporter, "<", binary(0), \$nl_text, ">", \$out ) ); 91 | is( $out, "Hello World" . ( Win32_MODE ? "\\0x0d" : "" ) . "\\0x0a", "reporter < binary(0) \\n" ); 92 | 93 | ok( run( \@reporter, "<", binary(1), \$nl_text, ">", \$out ) ); 94 | is( $out, "Hello World\\0x0a", "reporter < binary(1) \\n" ); 95 | 96 | ok( run( \@reporter, "<", binary(1), \$crlf_text, ">", \$out ) ); 97 | is( $out, "Hello World\\0x0d\\0x0a", "reporter < binary(1) \\r\\n" ); 98 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use ExtUtils::MakeMaker; 5 | 6 | # Calculate the dependencies 7 | my %PREREQ_PM; 8 | if ( $^O ne 'MSWin32' ) { 9 | foreach ( eval { require IO::Pty; IO::Pty->VERSION } ) { 10 | s/_//g if defined $_; 11 | unless ( defined $_ ) { 12 | warn("WARNING: \"IO::Pty not found\".\nWARNING: 'pty>' will not work.\n\n"); 13 | last; 14 | } 15 | $PREREQ_PM{'IO::Pty'} = '1.08'; 16 | } 17 | } 18 | else { 19 | $PREREQ_PM{'Win32'} = '0.27'; 20 | $PREREQ_PM{'Win32::Process'} = '0.14'; 21 | $PREREQ_PM{'Win32::ShellQuote'} = 0; 22 | $PREREQ_PM{'Win32API::File'} = '0.0901'; 23 | if ( $] >= 5.021006 ) { 24 | $PREREQ_PM{'Win32API::File'} = '0.1203'; 25 | } 26 | if ( !eval "use Socket qw( IPPROTO_TCP TCP_NODELAY ); 1" ) { 27 | warn <<"TOHERE"; 28 | $@ 29 | IPC::Run on Win32 requires a recent Sockets.pm in order to handle more 30 | complex interactions with subprocesses. They are not needed for most 31 | casual uses of run(), but it is impossible to tell whether all uses of 32 | IPC::Run in your installed modules meet the requirements, so IPC::Run 33 | should not be installed on Win32 machines with older perls. 34 | 35 | TOHERE 36 | 37 | ## Die nicely in case some install manager cares about the canonical 38 | ## error message for this. Not that I've ever seen one, but those 39 | ## wacky CPANPLUSers might just do something cool in this case. 40 | ## Older perls' Socket.pm don't export IPPROTO_TCP 41 | require 5.006; 42 | ## Most of the time it's not needed (since IPC::Run tries not to 43 | ## use sockets), but the user is not likely to know what the hell 44 | ## went wrong running sb. else's program. 45 | 46 | ## If something really odd is happening... 47 | exit 1; 48 | } 49 | } 50 | 51 | if ( $] < 5.008001 ) { 52 | 53 | # need Scalar::Util::looks_like_number 54 | $PREREQ_PM{'Scalar::List::Utils'} = '1.10'; 55 | } 56 | 57 | WriteMakefile( 58 | NAME => 'IPC::Run', 59 | ABSTRACT => 'system() and background procs w/ piping, redirs, ptys (Unix, Win32)', 60 | AUTHOR => 'Barrie Slaymaker ', 61 | VERSION_FROM => 'lib/IPC/Run.pm', 62 | ( $ExtUtils::MakeMaker::VERSION >= 6.3002 ? ( 'LICENSE' => 'perl', ) : () ), 63 | PREREQ_PM => { 64 | 'Test::More' => '0.47', 65 | %PREREQ_PM, 66 | }, 67 | dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, 68 | clean => { FILES => 'IPC-Run-*' }, 69 | META_MERGE => { 70 | recommends => { 71 | 'IO::Pty' => '1.08', 72 | 'Readonly' => 0, 73 | }, 74 | build_requires => { 75 | 'Test::More' => 0, # For testing 76 | 'Readonly::Array' => 0, 77 | }, 78 | resources => { 79 | license => 'http://dev.perl.org/licenses/', 80 | bugtracker => 'https://github.com/toddr/IPC-Run/issues', 81 | repository => 'https://github.com/toddr/IPC-Run', 82 | } 83 | } 84 | ); 85 | 86 | sub MY::libscan { 87 | 88 | package MY; 89 | my $self = shift; 90 | my ($path) = @_; 91 | return '' if $path =~ m/\.sw[a-z]\z/msx; 92 | return '' unless length $self->SUPER::libscan($path); 93 | return $path; 94 | } 95 | -------------------------------------------------------------------------------- /t/timer.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | timer.t - Test suite for IPC::Run::Timer 8 | 9 | =cut 10 | 11 | use strict; 12 | use warnings; 13 | 14 | BEGIN { 15 | $| = 1; 16 | $^W = 1; 17 | } 18 | 19 | use Test::More; 20 | use IPC::Run qw( run ); 21 | use IPC::Run::Timer qw( :all ); 22 | 23 | plan tests => 77; 24 | 25 | 26 | my $t; 27 | my $started; 28 | 29 | $t = timer( 30 | 31 | # debug => 1, 32 | 1, 33 | ); 34 | is( ref $t, 'IPC::Run::Timer' ); 35 | 36 | is( $t->interval, 1 ); 37 | 38 | $t->interval(0); 39 | is( $t->interval, 0 ); 40 | $t->interval(0.1); 41 | ok( $t->interval > 0 ); 42 | $t->interval(1); 43 | ok( $t->interval >= 1 ); 44 | $t->interval(30); 45 | ok( $t->interval >= 30 ); 46 | $t->interval(30.1); 47 | ok( $t->interval > 30 ); 48 | $t->interval(30.1); 49 | ok( $t->interval <= 31 ); 50 | 51 | SKIP: { 52 | skip( "Perl below 5.8.9 doesn't seem to be able to handle infinity", 1 ) if ( $] < 5.008009 ); 53 | $t->interval('inf'); 54 | ok( $t->interval > 1000, "Infinity timer." ); 55 | } 56 | 57 | $t->interval("1:0"); 58 | is( $t->interval, 60 ); 59 | $t->interval("1:0:0"); 60 | is( $t->interval, 3600 ); 61 | $t->interval("1:1:1"); 62 | is( $t->interval, 3661 ); 63 | $t->interval("1:1:1.1"); 64 | ok( $t->interval > 3661 ); 65 | $t->interval("1:1:1.1"); 66 | ok( $t->interval <= 3662 ); 67 | $t->interval("1:1:1:1"); 68 | is( $t->interval, 90061 ); 69 | 70 | SCOPE: { 71 | eval { $t->interval("1:1:1:1:1") }; 72 | my $msg = 'IPC::Run: expected <= 4'; 73 | $@ =~ /$msg/ ? ok(1) : is( $@, $msg ); 74 | } 75 | 76 | SCOPE: { 77 | eval { $t->interval("foo") }; 78 | my $msg = 'IPC::Run: non-numeric'; 79 | $@ =~ /$msg/ ? ok(1) : is( $@, $msg ); 80 | } 81 | 82 | SCOPE: { 83 | eval { $t->interval("1foo1:9:bar:0") }; 84 | my $msg = 'IPC::Run: non-numeric'; 85 | $@ =~ /$msg/ ? ok(1) : is( $@, $msg ); 86 | } 87 | 88 | SCOPE: { 89 | eval { $t->interval("6:4:") }; 90 | my $msg = 'IPC::Run: non-numeric'; 91 | $@ =~ /$msg/ ? ok(1) : is( $@, $msg ); 92 | } 93 | 94 | $t->reset; 95 | $t->interval(5); 96 | $t->start( 1, 0 ); 97 | ok( !$t->is_expired ); 98 | ok( !!$t->is_running ); 99 | ok( !$t->is_reset ); 100 | ok( !!$t->check(0) ); 101 | ok( !$t->is_expired ); 102 | ok( !!$t->is_running ); 103 | ok( !$t->is_reset ); 104 | ok( !!$t->check(1) ); 105 | ok( !$t->is_expired ); 106 | ok( !!$t->is_running ); 107 | ok( !$t->is_reset ); 108 | ok( !$t->check(2) ); 109 | ok( !!$t->is_expired ); 110 | ok( !$t->is_running ); 111 | ok( !$t->is_reset ); 112 | ok( !$t->check(3) ); 113 | ok( !!$t->is_expired ); 114 | ok( !$t->is_running ); 115 | ok( !$t->is_reset ); 116 | 117 | ## Restarting from the expired state. 118 | 119 | $t->start( undef, 0 ); 120 | ok( !$t->is_expired ); 121 | ok( !!$t->is_running ); 122 | ok( !$t->is_reset ); 123 | ok( !!$t->check(0) ); 124 | ok( !$t->is_expired ); 125 | ok( !!$t->is_running ); 126 | ok( !$t->is_reset ); 127 | ok( !!$t->check(1) ); 128 | ok( !$t->is_expired ); 129 | ok( !!$t->is_running ); 130 | ok( !$t->is_reset ); 131 | ok( !$t->check(2) ); 132 | ok( !!$t->is_expired ); 133 | ok( !$t->is_running ); 134 | ok( !$t->is_reset ); 135 | ok( !$t->check(3) ); 136 | ok( !!$t->is_expired ); 137 | ok( !$t->is_running ); 138 | ok( !$t->is_reset ); 139 | 140 | ## Restarting while running 141 | 142 | $t->start( 1, 0 ); 143 | $t->start( undef, 0 ); 144 | ok( !$t->is_expired ); 145 | ok( !!$t->is_running ); 146 | ok( !$t->is_reset ); 147 | ok( !!$t->check(0) ); 148 | ok( !$t->is_expired ); 149 | ok( !!$t->is_running ); 150 | ok( !$t->is_reset ); 151 | ok( !!$t->check(1) ); 152 | ok( !$t->is_expired ); 153 | ok( !!$t->is_running ); 154 | ok( !$t->is_reset ); 155 | ok( !$t->check(2) ); 156 | ok( !!$t->is_expired ); 157 | ok( !$t->is_running ); 158 | ok( !$t->is_reset ); 159 | ok( !$t->check(3) ); 160 | ok( !!$t->is_expired ); 161 | ok( !$t->is_running ); 162 | ok( !$t->is_reset ); 163 | 164 | my $got; 165 | eval { 166 | $got = "timeout fired"; 167 | run [ $^X, '-e', 'sleep 180' ], timeout 1; 168 | $got = "timeout didn't fire"; 169 | }; 170 | is $got, "timeout fired", "timer firing in run()"; 171 | -------------------------------------------------------------------------------- /t/harness.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | harness.t - Test suite for IPC::Run::harness 8 | 9 | =cut 10 | 11 | use strict; 12 | use warnings; 13 | 14 | BEGIN { 15 | $| = 1; 16 | $^W = 1; 17 | if ( $ENV{PERL_CORE} ) { 18 | chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; 19 | unshift @INC, 'lib', '../..'; 20 | $^X = '../../../t/' . $^X; 21 | } 22 | } 23 | 24 | use Test::More tests => 120; 25 | use IPC::Run qw( harness ); 26 | 27 | my $f; 28 | 29 | sub expand_test { 30 | my ( $args, $expected ) = @_; 31 | my $h; 32 | my @out; 33 | my $i = 0; 34 | SCOPE: { 35 | $h = IPC::Run::harness(@$args); 36 | @out = @{ $h->{KIDS}->[0]->{OPS} }; 37 | is( 38 | scalar(@out), 39 | scalar(@$expected), 40 | join( ' ', @$args ) 41 | ); 42 | } 43 | 44 | foreach my $h (@$expected) { 45 | my $j = $i++; 46 | foreach ( sort keys %$h ) { 47 | my ( $key, $value ) = ( $_, $h->{$_} ); 48 | my $got = $out[$j]->{$key}; 49 | $got = @$got if ref $got eq 'ARRAY'; 50 | $got = '' unless defined $got; 51 | is( $got, $value, join( ' ', @$args ) . ": $j, $key" ); 52 | } 53 | } 54 | } 55 | 56 | expand_test( 57 | [ ['a'], qw( '<', SOURCE => 'b', KFD => 0, }, 60 | { TYPE => '<', SOURCE => 'c', KFD => 0, }, 61 | { TYPE => '<', SOURCE => 'd', KFD => 0, }, 62 | { TYPE => '<', SOURCE => 'e', KFD => 0, }, 63 | { TYPE => '<', SOURCE => 'f', KFD => 1, }, 64 | { TYPE => '<', SOURCE => 'g', KFD => 1, }, 65 | ] 66 | ); 67 | 68 | expand_test( 69 | [ ['a'], qw( >b > c 2>d 2> e >>f >> g 2>>h 2>> i) ], 70 | [ 71 | { TYPE => '>', DEST => 'b', KFD => 1, TRUNC => 1, }, 72 | { TYPE => '>', DEST => 'c', KFD => 1, TRUNC => 1, }, 73 | { TYPE => '>', DEST => 'd', KFD => 2, TRUNC => 1, }, 74 | { TYPE => '>', DEST => 'e', KFD => 2, TRUNC => 1, }, 75 | { TYPE => '>', DEST => 'f', KFD => 1, TRUNC => '', }, 76 | { TYPE => '>', DEST => 'g', KFD => 1, TRUNC => '', }, 77 | { TYPE => '>', DEST => 'h', KFD => 2, TRUNC => '', }, 78 | { TYPE => '>', DEST => 'i', KFD => 2, TRUNC => '', }, 79 | ] 80 | ); 81 | 82 | expand_test( 83 | [ ['a'], qw( >&b >& c &>d &> e ) ], 84 | [ 85 | { TYPE => '>', DEST => 'b', KFD => 1, TRUNC => 1, }, 86 | { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, 87 | { TYPE => '>', DEST => 'c', KFD => 1, TRUNC => 1, }, 88 | { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, 89 | { TYPE => '>', DEST => 'd', KFD => 1, TRUNC => 1, }, 90 | { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, 91 | { TYPE => '>', DEST => 'e', KFD => 1, TRUNC => 1, }, 92 | { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, 93 | ] 94 | ); 95 | 96 | expand_test( 97 | [ 98 | ['a'], 99 | '>&', sub { }, sub { }, \$f, 100 | '>', sub { }, sub { }, \$f, 101 | '<', sub { }, sub { }, \$f, 102 | ], 103 | [ 104 | { 105 | TYPE => '>', DEST => \$f, KFD => 1, TRUNC => 1, 106 | FILTERS => 2 107 | }, 108 | { TYPE => 'dup', KFD1 => 1, KFD2 => 2 }, 109 | { 110 | TYPE => '>', DEST => \$f, KFD => 1, TRUNC => 1, 111 | FILTERS => 2 112 | }, 113 | { 114 | TYPE => '<', SOURCE => \$f, KFD => 0, 115 | FILTERS => 3 116 | }, 117 | ] 118 | ); 119 | 120 | expand_test( 121 | [ ['a'], '<', \$f, '>', \$f ], 122 | [ 123 | { TYPE => '<', SOURCE => \$f, KFD => 0, }, 124 | { TYPE => '>', DEST => \$f, KFD => 1, }, 125 | ] 126 | ); 127 | 128 | expand_test( 129 | [ ['a'], 'pipe', \$f ], 130 | [ 131 | { TYPE => ' \$f, KFD => 0, }, 132 | { TYPE => '>pipe', DEST => \$f, KFD => 1, }, 133 | ] 134 | ); 135 | 136 | expand_test( 137 | [ ['a'], '', \$f ], 138 | [ 139 | { TYPE => ' \$f, KFD => 0, }, 140 | { TYPE => '>', DEST => \$f, KFD => 1, }, 141 | ] 142 | ); 143 | -------------------------------------------------------------------------------- /t/lib/Test.pm: -------------------------------------------------------------------------------- 1 | package IPC::Run::Test; 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use Exporter; 7 | use IPC::Run qw{ harness }; 8 | use IPC::Run::IO; 9 | 10 | use vars qw{@ISA @EXPORT}; 11 | 12 | BEGIN { 13 | @ISA = qw{ Exporter }; 14 | @EXPORT = qw{ filter_tests }; 15 | } 16 | 17 | ## This is not needed by most users. Should really move to IPC::Run::TestUtils 18 | #=item filter_tests 19 | # 20 | # my @tests = filter_tests( "foo", "in", "out", \&filter ); 21 | # $_->() for ( @tests ); 22 | # 23 | #This creates a list of test subs that can be used to test most filters 24 | #for basic functionality. The first parameter is the name of the 25 | #filter to be tested, the second is sample input, the third is the 26 | #test(s) to apply to the output(s), and the rest of the parameters are 27 | #the filters to be linked and tested. 28 | # 29 | #If the filter chain is to be fed multiple inputs in sequence, the second 30 | #parameter should be a reference to an array of those inputs: 31 | # 32 | # my @tests = filter_tests( "foo", [qw(1 2 3)], "123", \&filter ); 33 | # 34 | #If the filter chain should produce a sequence of outputs, then the 35 | #third parameter should be a reference to an array of those outputs: 36 | # 37 | # my @tests = filter_tests( 38 | # "foo", 39 | # "1\n\2\n", 40 | # [ qr/^1$/, qr/^2$/ ], 41 | # new_chunker 42 | # ); 43 | # 44 | #See t/run.t and t/filter.t for an example of this in practice. 45 | # 46 | #=cut 47 | 48 | ## 49 | ## Filter testing routines 50 | ## 51 | sub filter_tests($;@) { 52 | my ( $name, $in, $exp, @filters ) = @_; 53 | my @in = ref $in eq 'ARRAY' ? @$in : ($in); 54 | my @exp = ref $exp eq 'ARRAY' ? @$exp : ($exp); 55 | my IPC::Run::IO $op; 56 | my $output; 57 | my @input; 58 | my $in_count = 0; 59 | my @out; 60 | my $h; 61 | 62 | SCOPE: { 63 | $h = harness(); 64 | $op = IPC::Run::IO->_new_internal( 65 | '<', 0, 0, 0, undef, 66 | IPC::Run::new_string_sink( \$output ), 67 | @filters, 68 | IPC::Run::new_string_source( \@input ), 69 | ); 70 | $op->_init_filters; 71 | @input = (); 72 | $output = ''; 73 | is( 74 | !defined $op->_do_filters($h), 75 | 1, 76 | "$name didn't pass undef (EOF) through" 77 | ); 78 | } 79 | 80 | ## See if correctly does nothing on 0, (please try again) 81 | SCOPE: { 82 | $op->_init_filters; 83 | $output = ''; 84 | @input = (''); 85 | is( 86 | $op->_do_filters($h), 87 | 0, 88 | "$name didn't return 0 (please try again) when given a 0" 89 | ); 90 | } 91 | 92 | SCOPE: { 93 | @input = (''); 94 | is( 95 | $op->_do_filters($h), 96 | 0, 97 | "$name didn't return 0 (please try again) when given a second 0" 98 | ); 99 | } 100 | 101 | SCOPE: { 102 | for ( 1 .. 100 ) { 103 | last unless defined $op->_do_filters($h); 104 | } 105 | is( 106 | !defined $op->_do_filters($h), 107 | 1, 108 | "$name didn't return undef (EOF) after two 0s and an undef" 109 | ); 110 | } 111 | 112 | ## See if it can take @in and make @out 113 | SCOPE: { 114 | $op->_init_filters; 115 | $output = ''; 116 | @input = @in; 117 | while ( defined $op->_do_filters($h) && @input ) { 118 | if ( length $output ) { 119 | push @out, $output; 120 | $output = ''; 121 | } 122 | } 123 | if ( length $output ) { 124 | push @out, $output; 125 | $output = ''; 126 | } 127 | is( 128 | scalar @input, 129 | 0, 130 | "$name didn't consume its input" 131 | ); 132 | } 133 | 134 | SCOPE: { 135 | for ( 1 .. 100 ) { 136 | last unless defined $op->_do_filters($h); 137 | if ( length $output ) { 138 | push @out, $output; 139 | $output = ''; 140 | } 141 | } 142 | is( 143 | !defined $op->_do_filters($h), 144 | 1, 145 | "$name didn't return undef (EOF), tried 100 times" 146 | ); 147 | } 148 | 149 | SCOPE: { 150 | is( 151 | join( ', ', map "'$_'", @out ), 152 | join( ', ', map "'$_'", @exp ), 153 | $name 154 | ); 155 | } 156 | 157 | SCOPE: { 158 | ## Force the harness to be cleaned up. 159 | $h = undef; 160 | ok(1); 161 | } 162 | } 163 | 164 | 1; 165 | -------------------------------------------------------------------------------- /lib/IPC/Run/Win32Pump.pm: -------------------------------------------------------------------------------- 1 | package IPC::Run::Win32Pump; 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | IPC::Run::Win32Pump - helper processes to shovel data to/from parent, child 8 | 9 | =head1 SYNOPSIS 10 | 11 | Internal use only; see IPC::Run::Win32IO and best of luck to you. 12 | 13 | =head1 DESCRIPTION 14 | 15 | See L for details. This 16 | module is used in subprocesses that are spawned to shovel data to/from 17 | parent processes from/to their child processes. Where possible, pumps 18 | are optimized away. 19 | 20 | NOTE: This is not a real module: it's a script in module form, designed 21 | to be run like 22 | 23 | $^X -MIPC::Run::Win32Pumper -e 1 ... 24 | 25 | It parses a bunch of command line parameters from IPC::Run::Win32IO. 26 | 27 | =cut 28 | 29 | use strict; 30 | use warnings; 31 | use vars qw{$VERSION}; 32 | 33 | BEGIN { 34 | $VERSION = '20250809.0'; 35 | } 36 | 37 | use Win32API::File qw( 38 | OsFHandleOpen 39 | ); 40 | 41 | my ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label ); 42 | 43 | BEGIN { 44 | ( $stdin_fh, $stdout_fh, $debug_fh, $binmode, $parent_pid, $parent_start_time, $debug, $child_label ) = @ARGV; 45 | ## Rather than letting IPC::Run::Debug export all-0 constants 46 | ## when not debugging, we do it manually in order to not even 47 | ## load IPC::Run::Debug. 48 | if ($debug) { 49 | eval "use IPC::Run::Debug qw( :default _debug_init ); 1;" 50 | or die $@; 51 | } 52 | else { 53 | eval < 100; 107 | $msg =~ s/\n/\\n/g; 108 | $msg =~ s/\r/\\r/g; 109 | $msg =~ s/\t/\\t/g; 110 | $msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg; 111 | _debug sprintf( "%5d chars revc: ", $count ), $msg; 112 | } 113 | $total_count += $count; 114 | $buf =~ s/\r//g unless $binmode; 115 | if (_debugging_gory_details) { 116 | my $msg = "'$buf'"; 117 | substr( $msg, 100, -1 ) = '...' if length $msg > 100; 118 | $msg =~ s/\n/\\n/g; 119 | $msg =~ s/\r/\\r/g; 120 | $msg =~ s/\t/\\t/g; 121 | $msg =~ s/([\000-\037\177-\277])/sprintf "\0x%02x", ord $1/eg; 122 | _debug sprintf( "%5d chars sent: ", $count ), $msg; 123 | } 124 | print $buf; 125 | } 126 | 127 | _debug "Exiting, transferred $total_count chars" if _debugging_details; 128 | 129 | ## Perform a graceful socket shutdown. Windows defaults to SO_DONTLINGER, 130 | ## which should cause a "graceful shutdown in the background" on sockets. 131 | ## but that's only true if the process closes the socket manually, it 132 | ## seems; if the process exits and lets the OS clean up, the OS is not 133 | ## so kind. STDOUT is not always a socket, of course, but it won't hurt 134 | ## to close a pipe and may even help. With a closed source OS, who 135 | ## can tell? 136 | ## 137 | ## In any case, this close() is one of the main reasons we have helper 138 | ## processes; if the OS closed socket fds gracefully when an app exits, 139 | ## we'd just redirect the client directly to what is now the pump end 140 | ## of the socket. As it is, however, we need to let the client play with 141 | ## pipes, which don't have the abort-on-app-exit behavior, and then 142 | ## adapt to the sockets in the helper processes to allow the parent to 143 | ## select. 144 | ## 145 | ## Possible alternatives / improvements: 146 | ## 147 | ## 1) use helper threads instead of processes. I don't trust perl's threads 148 | ## as of 5.005 or 5.6 enough (which may be myopic of me). 149 | ## 150 | ## 2) figure out if/how to get at WaitForMultipleObjects() with pipe 151 | ## handles. May be able to take the Win32 handle and pass it to 152 | ## Win32::Event::wait_any, dunno. 153 | ## 154 | ## 3) Use Inline::C or a hand-tooled XS module to do helper threads. 155 | ## This would be faster than #1, but would require a ppm distro. 156 | ## 157 | close STDOUT; 158 | close STDERR; 159 | 160 | 1; 161 | 162 | =pod 163 | 164 | =head1 AUTHOR 165 | 166 | Barries Slaymaker . Funded by Perforce Software, Inc. 167 | 168 | =head1 COPYRIGHT 169 | 170 | Copyright 2001, Barrie Slaymaker, All Rights Reserved. 171 | 172 | You may use this under the terms of either the GPL 2.0 ir the Artistic License. 173 | 174 | =cut 175 | -------------------------------------------------------------------------------- /t/pty.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | pty.t - Test suite for IPC::Run's pty (pseudo-terminal) support 8 | 9 | =head1 DESCRIPTION 10 | 11 | This test suite starts off with a test that seems to cause a deadlock 12 | on freebsd: \@cmd, '', ..., '2>'... 13 | 14 | This seems to cause the child process entry in the process table to 15 | hang around after the child exits. Both output pipes are closed, but 16 | the PID is still valid so IPC::Run::finish() thinks it's still alive and 17 | the whole shebang deadlocks waiting for the child to exit. 18 | 19 | This is a very rare corner condition, so I'm not patching in a fix yet. 20 | One fix might be to hack IPC::Run to close the master pty when all outputs 21 | from the child are closed. That's a hack, not sure what to do about it. 22 | 23 | This problem needs to be reproduced in a standalone script and investigated 24 | further, but I have not the time. 25 | 26 | =cut 27 | 28 | use strict; 29 | use warnings; 30 | 31 | BEGIN { 32 | $| = 1; 33 | $^W = 1; 34 | if ( $ENV{PERL_CORE} ) { 35 | chdir '../lib/IPC/Run' if -d '../lib/IPC/Run'; 36 | unshift @INC, 'lib', '../..'; 37 | $^X = '../../../t/' . $^X; 38 | } 39 | } 40 | 41 | use Test::More; 42 | 43 | BEGIN { 44 | if ( eval { require IO::Pty; } ) { 45 | plan tests => 32; 46 | } 47 | else { 48 | plan skip_all => "IO::Pty not installed"; 49 | } 50 | } 51 | 52 | use IPC::Run::Debug qw( _map_fds ); 53 | use IPC::Run qw( start pump finish ); 54 | 55 | select STDERR; 56 | select STDOUT; 57 | 58 | sub pty_warn { 59 | warn "\nWARNING: $_[0].\nWARNING: 'pty>' $_[1] not work.\n\n"; 60 | } 61 | 62 | if ( $^O !~ /Win32/ ) { 63 | 64 | # my $min = 0.9; 65 | for ( eval { require IO::Pty; IO::Pty->VERSION } ) { 66 | s/_//g if defined; 67 | if ( !defined ) { 68 | pty_warn "IO::Pty not found", "will"; 69 | } 70 | elsif ( $_ == 0.02 ) { 71 | pty_warn "IO::Pty v$_ has spurious warnings, try 0.9 or later", "may"; 72 | } 73 | elsif ( $_ < 1.00 ) { 74 | pty_warn "IO::Pty 1.00 is strongly recommended", "may"; 75 | } 76 | } 77 | } 78 | 79 | diag("IO::Tty $IO::Tty::VERSION, IO::Pty $IO::Pty::VERSION"); 80 | 81 | my $echoer_script = <) { 85 | print STDERR uc \$_; 86 | print; 87 | last if /quit/; 88 | } 89 | TOHERE 90 | 91 | ## 92 | ## $^X is the path to the perl binary. This is used run all the subprocesses. 93 | ## 94 | my @echoer = ( $^X, '-e', $echoer_script ); 95 | my $in; 96 | my $out; 97 | my $err; 98 | my $h; 99 | my $r; 100 | my $fd_map; 101 | my $text = "hello world\n"; 102 | 103 | ## TODO: test lots of mixtures of pty's and pipes & files. Use run(). 104 | 105 | ## Older Perls can't ok( a, qr// ), so I manually do that here. 106 | my $exp; 107 | my $platform_skip = $^O =~ /(?:dragonfly|aix|freebsd|openbsd|netbsd|darwin)/ ? "$^O deadlocks on this test" : ""; 108 | 109 | # May force opening /var/lib/sss/mc/group on some systems (see 110 | # https://github.com/toddr/IPC-Run/issues/130) 111 | # OpenBSD libc devname(3) opens /var/run/dev.db and keeps it open. 112 | # As this would confuse open file descriptor checks, open it in 113 | # advance. 114 | {my $pty = IO::Pty->new} 115 | 116 | ## 117 | ## stdin only 118 | ## 119 | SKIP: { 120 | if ($platform_skip) { 121 | skip( $platform_skip, 9 ); 122 | } 123 | 124 | $out = 'REPLACE ME'; 125 | $? = 99; 126 | $fd_map = _map_fds; 127 | $h = start \@echoer, '', \$out, '2>', \$err; 128 | $in = "hello\n"; 129 | $? = 0; 130 | pump $h until $out =~ /hello/ && $err =~ /HELLO/; 131 | is( $out, "hello\n" ); 132 | $exp = qr/^HELLO\n(?!\n)$/; 133 | $err =~ $exp ? ok(1) : is( $err, $exp ); 134 | is( $in, '' ); 135 | $in = "world\n"; 136 | $? = 0; 137 | pump $h until $out =~ /world/ && $err =~ /WORLD/; 138 | is( $out, "hello\nworld\n" ); 139 | $exp = qr/^HELLO\nWORLD\n(?!\n)$/; 140 | $err =~ $exp ? ok(1) : is( $err, $exp ); 141 | is( $in, '' ); 142 | $in = "quit\n"; 143 | ok( $h->finish ); 144 | ok( !$? ); 145 | is( _map_fds, $fd_map ); 146 | } 147 | 148 | ## 149 | ## stdout, stderr 150 | ## 151 | $out = 'REPLACE ME'; 152 | $? = 99; 153 | $fd_map = _map_fds; 154 | $h = start \@echoer, \$in, '>pty>', \$out; 155 | $in = "hello\n"; 156 | $? = 0; 157 | pump $h until $out =~ /hello\r?\n/; 158 | ## We assume that the slave's write()s are atomic 159 | $exp = qr/^(?:hello\r?\n){2}(?!\n)$/i; 160 | $out =~ $exp ? ok(1) : is( $out, $exp ); 161 | is( $in, '' ); 162 | $in = "world\n"; 163 | $? = 0; 164 | pump $h until $out =~ /world\r?\n/; 165 | $exp = qr/^(?:hello\r?\n){2}(?:world\r?\n){2}(?!\n)$/i; 166 | $out =~ $exp ? ok(1) : is( $out, $exp ); 167 | is( $in, '' ); 168 | $in = "quit\n"; 169 | ok( $h->finish ); 170 | ok( !$? ); 171 | is( _map_fds, $fd_map ); 172 | ## 173 | ## stdout only 174 | ## 175 | $out = 'REPLACE ME'; 176 | $? = 99; 177 | $fd_map = _map_fds; 178 | $h = start \@echoer, \$in, '>pty>', \$out, '2>', \$err; 179 | $in = "hello\n"; 180 | $? = 0; 181 | pump $h until $out =~ /hello\r?\n/ && $err =~ /HELLO/; 182 | $exp = qr/^hello\r?\n(?!\n)$/; 183 | $out =~ $exp ? ok(1) : is( $out, $exp ); 184 | $exp = qr/^HELLO\n(?!\n)$/; 185 | $err =~ $exp ? ok(1) : is( $err, $exp ); 186 | is( $in, '' ); 187 | $in = "world\n"; 188 | $? = 0; 189 | pump $h until $out =~ /world\r?\n/ && $err =~ /WORLD/; 190 | $exp = qr/^hello\r?\nworld\r?\n(?!\n)$/; 191 | $out =~ $exp ? ok(1) : is( $out, $exp ); 192 | $exp = qr/^HELLO\nWORLD\n(?!\n)$/, 193 | $err =~ $exp ? ok(1) : is( $err, $exp ); 194 | is( $in, '' ); 195 | $in = "quit\n"; 196 | ok( $h->finish ); 197 | ok( !$? ); 198 | is( _map_fds, $fd_map ); 199 | ## 200 | ## stdin, stdout, stderr 201 | ## 202 | $out = 'REPLACE ME'; 203 | $? = 99; 204 | $fd_map = _map_fds; 205 | $h = start \@echoer, 'pty>', \$out; 206 | $in = "hello\n"; 207 | $? = 0; 208 | pump $h until $out =~ /hello.*hello.*hello\r?\n/is; 209 | ## We assume that the slave's write()s are atomic 210 | $exp = qr/^(?:hello\r?\n){3}(?!\n)$/i; 211 | $out =~ $exp ? ok(1) : is( $out, $exp ); 212 | is( $in, '' ); 213 | $in = "world\n"; 214 | $? = 0; 215 | pump $h until $out =~ /world.*world.*world\r?\n/is; 216 | $exp = qr/^(?:hello\r?\n){3}(?:world\r?\n){3}(?!\n)$/i; 217 | $out =~ $exp ? ok(1) : is( $out, $exp ); 218 | is( $in, '' ); 219 | $in = "quit\n"; 220 | ok( $h->finish ); 221 | ok( !$? ); 222 | is( _map_fds, $fd_map ); 223 | -------------------------------------------------------------------------------- /lib/IPC/Run/Debug.pm: -------------------------------------------------------------------------------- 1 | package IPC::Run::Debug; 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | IPC::Run::Debug - debugging routines for IPC::Run 8 | 9 | =head1 SYNOPSIS 10 | 11 | ## 12 | ## Environment variable usage 13 | ## 14 | ## To force debugging off and shave a bit of CPU and memory 15 | ## by compile-time optimizing away all debugging code in IPC::Run 16 | ## (debug => ...) options to IPC::Run will be ignored. 17 | export IPCRUNDEBUG=none 18 | 19 | ## To force debugging on (levels are from 0..10) 20 | export IPCRUNDEBUG=basic 21 | 22 | ## Leave unset or set to "" to compile in debugging support and 23 | ## allow runtime control of it using the debug option. 24 | 25 | =head1 DESCRIPTION 26 | 27 | Controls IPC::Run debugging. Debugging levels are now set by using words, 28 | but the numbers shown are still supported for backwards compatibility: 29 | 30 | 0 none disabled (special, see below) 31 | 1 basic what's running 32 | 2 data what's being sent/received 33 | 3 details what's going on in more detail 34 | 4 gory way too much detail for most uses 35 | 10 all use this when submitting bug reports 36 | noopts optimizations forbidden due to inherited STDIN 37 | 38 | The C level is special when the environment variable IPCRUNDEBUG 39 | is set to this the first time IPC::Run::Debug is loaded: it prevents 40 | the debugging code from being compiled in to the remaining IPC::Run modules, 41 | saving a bit of cpu. 42 | 43 | To do this in a script, here's a way that allows it to be overridden: 44 | 45 | BEGIN { 46 | unless ( defined $ENV{IPCRUNDEBUG} ) { 47 | eval 'local $ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"' 48 | or die $@; 49 | } 50 | } 51 | 52 | This should force IPC::Run to not be debuggable unless somebody sets 53 | the IPCRUNDEBUG flag; modify this formula to grep @ARGV if need be: 54 | 55 | BEGIN { 56 | unless ( grep /^--debug/, @ARGV ) { 57 | eval 'local $ENV{IPCRUNDEBUG} = "none"; require IPC::Run::Debug"' 58 | or die $@; 59 | } 60 | 61 | Both of those are untested. 62 | 63 | =cut 64 | 65 | ## We use @EXPORT for the end user's convenience: there's only one function 66 | ## exported, it's homonymous with the module, it's an unusual name, and 67 | ## it can be suppressed by "use IPC::Run ();". 68 | 69 | use strict; 70 | use warnings; 71 | use Exporter; 72 | use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS}; 73 | 74 | BEGIN { 75 | $VERSION = '20250809.0'; 76 | @ISA = qw( Exporter ); 77 | @EXPORT = qw( 78 | _debug 79 | _debug_desc_fd 80 | _debugging 81 | _debugging_data 82 | _debugging_details 83 | _debugging_gory_details 84 | _debugging_not_optimized 85 | _set_child_debug_name 86 | ); 87 | 88 | @EXPORT_OK = qw( 89 | _debug_init 90 | _debugging_level 91 | _map_fds 92 | ); 93 | %EXPORT_TAGS = ( 94 | default => \@EXPORT, 95 | all => [ @EXPORT, @EXPORT_OK ], 96 | ); 97 | } 98 | 99 | my $disable_debugging = defined $ENV{IPCRUNDEBUG} 100 | && ( !$ENV{IPCRUNDEBUG} 101 | || lc $ENV{IPCRUNDEBUG} eq "none" ); 102 | 103 | eval( $disable_debugging ? <<'STUBS' : <<'SUBS' ) or die $@; 104 | sub _map_fds() { "" } 105 | sub _debug {} 106 | sub _debug_desc_fd {} 107 | sub _debug_init {} 108 | sub _set_child_debug_name {} 109 | sub _debugging() { 0 } 110 | sub _debugging_level() { 0 } 111 | sub _debugging_data() { 0 } 112 | sub _debugging_details() { 0 } 113 | sub _debugging_gory_details() { 0 } 114 | sub _debugging_not_optimized() { 0 } 115 | 116 | 1; 117 | STUBS 118 | 119 | use POSIX (); 120 | use constant Win32_MODE => $^O =~ /os2|Win32/i; 121 | 122 | # Replace Win32API::File::INVALID_HANDLE_VALUE, which does not match the C ABI 123 | # on 64-bit builds (https://github.com/chorny/Win32API-File/issues/13). 124 | use constant C_ABI_INVALID_HANDLE_VALUE => length( pack 'P', undef ) == 4 125 | ? 0xffffffff 126 | : 0xffffffff << 32 | 0xffffffff; 127 | 128 | sub _fd_is_open { 129 | my ($fd) = @_; 130 | if (Win32_MODE) { 131 | # Many OS functions can crash on closed FDs. POSIX::close() can hang on 132 | # the read end of a pipe (https://github.com/Perl/perl5/issues/19963). 133 | # Borrow Gnulib's strategy. 134 | require Win32API::File; 135 | return Win32API::File::FdGetOsFHandle($fd) != C_ABI_INVALID_HANDLE_VALUE; 136 | } 137 | else { 138 | ## I'd like a quicker way (less user, cpu & especially sys and kernel 139 | ## calls) to detect open file descriptors. Let me know... 140 | ## Hmmm, could do a 0 length read and check for bad file descriptor... 141 | my $test_fd = POSIX::dup( $fd ); 142 | my $in_use = defined $test_fd; 143 | POSIX::close $test_fd if $in_use; 144 | return $in_use; 145 | } 146 | } 147 | 148 | sub _map_fds { 149 | my $map = ''; 150 | my $digit = 0; 151 | my $dummy; 152 | for my $fd (0..63) { 153 | $map .= _fd_is_open($fd) ? $digit : '-'; 154 | $digit = 0 if ++$digit > 9; 155 | } 156 | warn "No fds open???" unless $map =~ /\d/; 157 | $map =~ s/(.{1,12})-*$/$1/; 158 | return $map; 159 | } 160 | 161 | use vars qw( $parent_pid ); 162 | 163 | $parent_pid = $$; 164 | 165 | ## TODO: move debugging to its own module and make it compile-time 166 | ## optimizable. 167 | 168 | ## Give kid process debugging nice names 169 | my $debug_name; 170 | 171 | sub _set_child_debug_name { 172 | $debug_name = shift; 173 | } 174 | 175 | ## There's a bit of hackery going on here. 176 | ## 177 | ## We want to have any code anywhere be able to emit 178 | ## debugging statements without knowing what harness the code is 179 | ## being called in/from, since we'd need to pass a harness around to 180 | ## everything. 181 | ## 182 | ## Thus, $cur_self was born. 183 | # 184 | my %debug_levels = ( 185 | none => 0, 186 | basic => 1, 187 | data => 2, 188 | details => 3, 189 | gore => 4, 190 | gory_details => 4, 191 | "gory details" => 4, 192 | gory => 4, 193 | gorydetails => 4, 194 | all => 10, 195 | notopt => 0, 196 | ); 197 | 198 | my $warned; 199 | 200 | sub _debugging_level() { 201 | my $level = 0; 202 | 203 | $level = $IPC::Run::cur_self->{debug} || 0 204 | if $IPC::Run::cur_self 205 | && ( $IPC::Run::cur_self->{debug} || 0 ) >= $level; 206 | 207 | if ( defined $ENV{IPCRUNDEBUG} ) { 208 | my $v = $ENV{IPCRUNDEBUG}; 209 | $v = $debug_levels{lc $v} if $v =~ /[a-zA-Z]/; 210 | unless ( defined $v ) { 211 | $warned ||= warn "Unknown debug level $ENV{IPCRUNDEBUG}, assuming 'basic' (1)\n"; 212 | $v = 1; 213 | } 214 | $level = $v if $v > $level; 215 | } 216 | return $level; 217 | } 218 | 219 | sub _debugging_atleast($) { 220 | my $min_level = shift || 1; 221 | 222 | my $level = _debugging_level; 223 | 224 | return $level >= $min_level ? $level : 0; 225 | } 226 | 227 | sub _debugging() { _debugging_atleast 1 } 228 | sub _debugging_data() { _debugging_atleast 2 } 229 | sub _debugging_details() { _debugging_atleast 3 } 230 | sub _debugging_gory_details() { _debugging_atleast 4 } 231 | sub _debugging_not_optimized() { ( $ENV{IPCRUNDEBUG} || "" ) eq "notopt" } 232 | 233 | sub _debug_init { 234 | ## This routine is called only in spawned children to fake out the 235 | ## debug routines so they'll emit debugging info. 236 | $IPC::Run::cur_self = {}; 237 | ( $parent_pid, 238 | $^T, 239 | $IPC::Run::cur_self->{debug}, 240 | $IPC::Run::cur_self->{DEBUG_FD}, 241 | $debug_name 242 | ) = @_; 243 | } 244 | 245 | 246 | sub _debug { 247 | # return unless _debugging || _debugging_not_optimized; 248 | 249 | my $fd = defined &IPC::Run::_debug_fd 250 | ? IPC::Run::_debug_fd() 251 | : fileno STDERR; 252 | 253 | my $s; 254 | my $debug_id; 255 | $debug_id = join( 256 | " ", 257 | join( 258 | "", 259 | defined $IPC::Run::cur_self && defined $IPC::Run::cur_self->{ID} 260 | ? "#$IPC::Run::cur_self->{ID}" 261 | : (), 262 | "($$)", 263 | ), 264 | defined $debug_name && length $debug_name ? $debug_name : (), 265 | ); 266 | my $prefix = join( 267 | "", 268 | "IPC::Run", 269 | sprintf( " %04d", time - $^T ), 270 | ( _debugging_details ? ( " ", _map_fds ) : () ), 271 | length $debug_id ? ( " [", $debug_id, "]" ) : (), 272 | ": ", 273 | ); 274 | 275 | my $msg = join( '', map defined $_ ? $_ : "", @_ ); 276 | chomp $msg; 277 | $msg =~ s{^}{$prefix}gm; 278 | $msg .= "\n"; 279 | POSIX::write( $fd, $msg, length $msg ); 280 | } 281 | 282 | 283 | my @fd_descs = ( 'stdin', 'stdout', 'stderr' ); 284 | 285 | sub _debug_desc_fd { 286 | return unless _debugging; 287 | my $text = shift; 288 | my $op = pop; 289 | my $kid = $_[0]; 290 | 291 | Carp::carp join " ", caller(0), $text, $op if defined $op && UNIVERSAL::isa( $op, "IO::Pty" ); 292 | 293 | _debug( 294 | $text, 295 | ' ', 296 | ( defined $op->{FD} 297 | ? $op->{FD} < 3 298 | ? ( $fd_descs[$op->{FD}] ) 299 | : ( 'fd ', $op->{FD} ) 300 | : $op->{FD} 301 | ), 302 | ( defined $op->{KFD} 303 | ? ( 304 | ' (kid', 305 | ( defined $kid ? ( ' ', $kid->{NUM}, ) : () ), 306 | "'s ", 307 | ( $op->{KFD} < 3 308 | ? $fd_descs[$op->{KFD}] 309 | : defined $kid 310 | && defined $kid->{DEBUG_FD} 311 | && $op->{KFD} == $kid->{DEBUG_FD} 312 | ? ( 'debug (', $op->{KFD}, ')' ) 313 | : ( 'fd ', $op->{KFD} ) 314 | ), 315 | ')', 316 | ) 317 | : () 318 | ), 319 | ); 320 | } 321 | 322 | 1; 323 | 324 | SUBS 325 | 326 | =pod 327 | 328 | =head1 AUTHOR 329 | 330 | Barrie Slaymaker , with numerous suggestions by p5p. 331 | 332 | =cut 333 | -------------------------------------------------------------------------------- /lib/IPC/Run/IO.pm: -------------------------------------------------------------------------------- 1 | package IPC::Run::IO; 2 | 3 | =head1 NAME 4 | 5 | IPC::Run::IO -- I/O channels for IPC::Run. 6 | 7 | =head1 SYNOPSIS 8 | 9 | B 12 | 13 | use IPC::Run qw( io ); 14 | 15 | ## The sense of '>' and '<' is opposite of perl's open(), 16 | ## but agrees with IPC::Run. 17 | $io = io( "filename", '>', \$recv ); 18 | $io = io( "filename", 'r', \$recv ); 19 | 20 | ## Append to $recv: 21 | $io = io( "filename", '>>', \$recv ); 22 | $io = io( "filename", 'ra', \$recv ); 23 | 24 | $io = io( "filename", '<', \$send ); 25 | $io = io( "filename", 'w', \$send ); 26 | 27 | $io = io( "filename", '<<', \$send ); 28 | $io = io( "filename", 'wa', \$send ); 29 | 30 | ## Handles / IO objects that the caller opens: 31 | $io = io( \*HANDLE, '<', \$send ); 32 | 33 | $f = IO::Handle->new( ... ); # Any subclass of IO::Handle 34 | $io = io( $f, '<', \$send ); 35 | 36 | require IPC::Run::IO; 37 | $io = IPC::Run::IO->new( ... ); 38 | 39 | ## Then run(), harness(), or start(): 40 | run $io, ...; 41 | 42 | ## You can, of course, use io() or IPC::Run::IO->new() as an 43 | ## argument to run(), harness, or start(): 44 | run io( ... ); 45 | 46 | =head1 DESCRIPTION 47 | 48 | This class and module allows filehandles and filenames to be harnessed for 49 | I/O when used IPC::Run, independent of anything else IPC::Run is doing 50 | (except that errors & exceptions can affect all things that IPC::Run is 51 | doing). 52 | 53 | =head1 SUBCLASSING 54 | 55 | INCOMPATIBLE CHANGE: due to the awkwardness introduced in ripping pseudohashes 56 | out of Perl, this class I uses the fields pragma. 57 | 58 | =cut 59 | 60 | ## This class is also used internally by IPC::Run in a very intimate way, 61 | ## since this is a partial factoring of code from IPC::Run plus some code 62 | ## needed to do standalone channels. This factoring process will continue 63 | ## at some point. Don't know how far how fast. 64 | 65 | use strict; 66 | use warnings; 67 | use Carp; 68 | use Fcntl; 69 | use Symbol; 70 | 71 | use IPC::Run::Debug; 72 | use IPC::Run qw( Win32_MODE ); 73 | 74 | use vars qw{$VERSION}; 75 | 76 | BEGIN { 77 | $VERSION = '20250809.0'; 78 | if (Win32_MODE) { 79 | eval "use IPC::Run::Win32Helper; require IPC::Run::Win32IO; 1" 80 | or ( $@ && die ) 81 | or die "$!"; 82 | } 83 | } 84 | 85 | sub _empty($); 86 | *_empty = \&IPC::Run::_empty; 87 | 88 | =head1 SUBROUTINES 89 | 90 | =over 4 91 | 92 | =item new 93 | 94 | I think it takes >> or << along with some other data. 95 | 96 | TODO: Needs more thorough documentation. Patches welcome. 97 | 98 | =cut 99 | 100 | sub new { 101 | my $class = shift; 102 | $class = ref $class || $class; 103 | 104 | my ( $external, $type, $internal ) = ( shift, shift, pop ); 105 | 106 | croak "$class: '$_' is not a valid I/O operator" 107 | unless $type =~ /^(?:<>?)$/; 108 | 109 | my IPC::Run::IO $self = $class->_new_internal( $type, undef, undef, $internal, undef, @_ ); 110 | 111 | if ( !ref $external ) { 112 | $self->{FILENAME} = $external; 113 | } 114 | elsif ( ref $external eq 'GLOB' || UNIVERSAL::isa( $external, 'IO::Handle' ) ) { 115 | $self->{HANDLE} = $external; 116 | $self->{DONT_CLOSE} = 1; 117 | } 118 | else { 119 | croak "$class: cannot accept " . ref($external) . " to do I/O with"; 120 | } 121 | 122 | return $self; 123 | } 124 | 125 | ## IPC::Run uses this ctor, since it preparses things and needs more 126 | ## smarts. 127 | sub _new_internal { 128 | my $class = shift; 129 | $class = ref $class || $class; 130 | 131 | $class = "IPC::Run::Win32IO" 132 | if Win32_MODE && $class eq "IPC::Run::IO"; 133 | 134 | my IPC::Run::IO $self; 135 | $self = bless {}, $class; 136 | 137 | my ( $type, $kfd, $pty_id, $internal, $binmode, @filters ) = @_; 138 | 139 | # Older perls (<=5.00503, at least) don't do list assign to 140 | # pseudo-hashes well. 141 | $self->{TYPE} = $type; 142 | $self->{KFD} = $kfd; 143 | $self->{PTY_ID} = $pty_id; 144 | $self->binmode($binmode); 145 | $self->{FILTERS} = [@filters]; 146 | 147 | ## Add an adapter to the end of the filter chain (which is usually just the 148 | ## read/writer sub pushed by IPC::Run) to the DEST or SOURCE, if need be. 149 | if ( $self->op =~ />/ ) { 150 | croak "'$_' missing a destination" if _empty $internal; 151 | $self->{DEST} = $internal; 152 | if ( UNIVERSAL::isa( $self->{DEST}, 'CODE' ) ) { 153 | ## Put a filter on the end of the filter chain to pass the 154 | ## output on to the CODE ref. For SCALAR refs, the last 155 | ## filter in the chain writes directly to the scalar itself. See 156 | ## _init_filters(). For CODE refs, however, we need to adapt from 157 | ## the SCALAR to calling the CODE. 158 | unshift( 159 | @{ $self->{FILTERS} }, 160 | sub { 161 | my ($in_ref) = @_; 162 | 163 | return IPC::Run::input_avail() && do { 164 | $self->{DEST}->($$in_ref); 165 | $$in_ref = ''; 166 | 1; 167 | } 168 | } 169 | ); 170 | } 171 | } 172 | else { 173 | croak "'$_' missing a source" if _empty $internal; 174 | $self->{SOURCE} = $internal; 175 | if ( UNIVERSAL::isa( $internal, 'CODE' ) ) { 176 | push( 177 | @{ $self->{FILTERS} }, 178 | sub { 179 | my ( $in_ref, $out_ref ) = @_; 180 | return 0 if length $$out_ref; 181 | 182 | return undef 183 | if $self->{SOURCE_EMPTY}; 184 | 185 | my $in = $internal->(); 186 | unless ( defined $in ) { 187 | $self->{SOURCE_EMPTY} = 1; 188 | return undef; 189 | } 190 | return 0 unless length $in; 191 | $$out_ref = $in; 192 | 193 | return 1; 194 | } 195 | ); 196 | } 197 | elsif ( UNIVERSAL::isa( $internal, 'SCALAR' ) ) { 198 | push( 199 | @{ $self->{FILTERS} }, 200 | sub { 201 | my ( $in_ref, $out_ref ) = @_; 202 | return 0 if length $$out_ref; 203 | 204 | ## pump() clears auto_close_ins, finish() sets it. 205 | return $self->{HARNESS}->{auto_close_ins} ? undef : 0 206 | if IPC::Run::_empty ${ $self->{SOURCE} } 207 | || $self->{SOURCE_EMPTY}; 208 | 209 | $$out_ref = $$internal; 210 | eval { $$internal = '' } 211 | if $self->{HARNESS}->{clear_ins}; 212 | 213 | $self->{SOURCE_EMPTY} = $self->{HARNESS}->{auto_close_ins}; 214 | 215 | return 1; 216 | } 217 | ); 218 | } 219 | } 220 | 221 | return $self; 222 | } 223 | 224 | =item filename 225 | 226 | Gets/sets the filename. Returns the value after the name change, if 227 | any. 228 | 229 | =cut 230 | 231 | sub filename { 232 | my IPC::Run::IO $self = shift; 233 | $self->{FILENAME} = shift if @_; 234 | return $self->{FILENAME}; 235 | } 236 | 237 | =item init 238 | 239 | Does initialization required before this can be run. This includes open()ing 240 | the file, if necessary, and clearing the destination scalar if necessary. 241 | 242 | =cut 243 | 244 | sub init { 245 | my IPC::Run::IO $self = shift; 246 | 247 | $self->{SOURCE_EMPTY} = 0; 248 | ${ $self->{DEST} } = '' 249 | if $self->mode =~ /r/ && ref $self->{DEST} eq 'SCALAR'; 250 | 251 | $self->open if defined $self->filename; 252 | $self->{FD} = $self->fileno; 253 | 254 | if ( !$self->{FILTERS} ) { 255 | $self->{FBUFS} = undef; 256 | } 257 | else { 258 | @{ $self->{FBUFS} } = map { 259 | my $s = ""; 260 | \$s; 261 | } ( @{ $self->{FILTERS} }, '' ); 262 | 263 | $self->{FBUFS}->[0] = $self->{DEST} 264 | if $self->{DEST} && ref $self->{DEST} eq 'SCALAR'; 265 | push @{ $self->{FBUFS} }, $self->{SOURCE}; 266 | } 267 | 268 | return undef; 269 | } 270 | 271 | =item open 272 | 273 | If a filename was passed in, opens it. Determines if the handle is open 274 | via fileno(). Throws an exception on error. 275 | 276 | =cut 277 | 278 | my %open_flags = ( 279 | '>' => O_RDONLY, 280 | '>>' => O_RDONLY, 281 | '<' => O_WRONLY | O_CREAT | O_TRUNC, 282 | '<<' => O_WRONLY | O_CREAT | O_APPEND, 283 | ); 284 | 285 | sub open { 286 | my IPC::Run::IO $self = shift; 287 | 288 | croak "IPC::Run::IO: Can't open() a file with no name" 289 | unless defined $self->{FILENAME}; 290 | $self->{HANDLE} = gensym unless $self->{HANDLE}; 291 | 292 | _debug "opening '", $self->filename, "' mode '", $self->mode, "'" 293 | if _debugging_data; 294 | sysopen( 295 | $self->{HANDLE}, 296 | $self->filename, 297 | $open_flags{ $self->op }, 298 | ) or croak "IPC::Run::IO: $! opening '$self->{FILENAME}', mode '" . $self->mode . "'"; 299 | 300 | return undef; 301 | } 302 | 303 | =item open_pipe 304 | 305 | If this is a redirection IO object, this opens the pipe in a platform 306 | independent manner. 307 | 308 | =cut 309 | 310 | sub _do_open { 311 | my $self = shift; 312 | my ( $child_debug_fd, $parent_handle ) = @_; 313 | 314 | if ( $self->dir eq "<" ) { 315 | ( $self->{TFD}, $self->{FD} ) = IPC::Run::_pipe_nb; 316 | if ($parent_handle) { 317 | CORE::open $parent_handle, ">&=$self->{FD}" 318 | or croak "$! duping write end of pipe for caller"; 319 | } 320 | } 321 | else { 322 | ( $self->{FD}, $self->{TFD} ) = IPC::Run::_pipe; 323 | if ($parent_handle) { 324 | CORE::open $parent_handle, "<&=$self->{FD}" 325 | or croak "$! duping read end of pipe for caller"; 326 | } 327 | } 328 | } 329 | 330 | sub open_pipe { 331 | my IPC::Run::IO $self = shift; 332 | 333 | ## Hmmm, Maybe allow named pipes one day. But until then... 334 | croak "IPC::Run::IO: Can't pipe() when a file name has been set" 335 | if defined $self->{FILENAME}; 336 | 337 | $self->_do_open(@_); 338 | 339 | ## return ( child_fd, parent_fd ) 340 | return $self->dir eq "<" 341 | ? ( $self->{TFD}, $self->{FD} ) 342 | : ( $self->{FD}, $self->{TFD} ); 343 | } 344 | 345 | sub _cleanup { ## Called from Run.pm's _cleanup 346 | my $self = shift; 347 | undef $self->{FAKE_PIPE}; 348 | } 349 | 350 | =item close 351 | 352 | Closes the handle. Throws an exception on failure. 353 | 354 | 355 | =cut 356 | 357 | sub close { 358 | my IPC::Run::IO $self = shift; 359 | 360 | if ( defined $self->{HANDLE} ) { 361 | close $self->{HANDLE} 362 | or croak( 363 | "IPC::Run::IO: $! closing " 364 | . ( 365 | defined $self->{FILENAME} 366 | ? "'$self->{FILENAME}'" 367 | : "handle" 368 | ) 369 | ); 370 | } 371 | else { 372 | IPC::Run::_close( $self->{FD} ); 373 | } 374 | 375 | $self->{FD} = undef; 376 | 377 | return undef; 378 | } 379 | 380 | =item fileno 381 | 382 | Returns the fileno of the handle. Throws an exception on failure. 383 | 384 | 385 | =cut 386 | 387 | sub fileno { 388 | my IPC::Run::IO $self = shift; 389 | 390 | my $fd = fileno $self->{HANDLE}; 391 | croak( 392 | "IPC::Run::IO: $! " 393 | . ( 394 | defined $self->{FILENAME} 395 | ? "'$self->{FILENAME}'" 396 | : "handle" 397 | ) 398 | ) unless defined $fd; 399 | 400 | return $fd; 401 | } 402 | 403 | =item mode 404 | 405 | Returns the operator in terms of 'r', 'w', and 'a'. There is a state 406 | 'ra', unlike Perl's open(), which indicates that data read from the 407 | handle or file will be appended to the output if the output is a scalar. 408 | This is only meaningful if the output is a scalar, it has no effect if 409 | the output is a subroutine. 410 | 411 | The redirection operators can be a little confusing, so here's a reference 412 | table: 413 | 414 | > r Read from handle in to process 415 | < w Write from process out to handle 416 | >> ra Read from handle in to process, appending it to existing 417 | data if the destination is a scalar. 418 | << wa Write from process out to handle, appending to existing 419 | data if IPC::Run::IO opened a named file. 420 | 421 | =cut 422 | 423 | sub mode { 424 | my IPC::Run::IO $self = shift; 425 | 426 | croak "IPC::Run::IO: unexpected arguments for mode(): @_" if @_; 427 | 428 | ## TODO: Optimize this 429 | return ( $self->{TYPE} =~ /{TYPE} =~ /<<|>>/ ? 'a' : '' ); 430 | } 431 | 432 | =item op 433 | 434 | Returns the operation: '<', '>', '<<', '>>'. See L if you want 435 | to spell these 'r', 'w', etc. 436 | 437 | =cut 438 | 439 | sub op { 440 | my IPC::Run::IO $self = shift; 441 | 442 | croak "IPC::Run::IO: unexpected arguments for op(): @_" if @_; 443 | 444 | return $self->{TYPE}; 445 | } 446 | 447 | =item binmode 448 | 449 | Sets/gets whether this pipe is in binmode or not. No effect off of Win32 450 | OSs, of course, and on Win32, no effect after the harness is start()ed. 451 | 452 | =cut 453 | 454 | sub binmode { 455 | my IPC::Run::IO $self = shift; 456 | 457 | $self->{BINMODE} = shift if @_; 458 | 459 | return $self->{BINMODE}; 460 | } 461 | 462 | =item dir 463 | 464 | Returns the first character of $self->op. This is either "<" or ">". 465 | 466 | =cut 467 | 468 | sub dir { 469 | my IPC::Run::IO $self = shift; 470 | 471 | croak "IPC::Run::IO: unexpected arguments for dir(): @_" if @_; 472 | 473 | return substr $self->{TYPE}, 0, 1; 474 | } 475 | 476 | ## 477 | ## Filter Scaffolding 478 | ## 479 | #my $filter_op ; ## The op running a filter chain right now 480 | #my $filter_num; ## Which filter is being run right now. 481 | 482 | use vars ( 483 | '$filter_op', ## The op running a filter chain right now 484 | '$filter_num' ## Which filter is being run right now. 485 | ); 486 | 487 | sub _init_filters { 488 | my IPC::Run::IO $self = shift; 489 | 490 | confess "\$self not an IPC::Run::IO" unless UNIVERSAL::isa( $self, "IPC::Run::IO" ); 491 | $self->{FBUFS} = []; 492 | 493 | $self->{FBUFS}->[0] = $self->{DEST} 494 | if $self->{DEST} && ref $self->{DEST} eq 'SCALAR'; 495 | 496 | return unless $self->{FILTERS} && @{ $self->{FILTERS} }; 497 | 498 | push @{ $self->{FBUFS} }, map { 499 | my $s = ""; 500 | \$s; 501 | } ( @{ $self->{FILTERS} }, '' ); 502 | 503 | push @{ $self->{FBUFS} }, $self->{SOURCE}; 504 | } 505 | 506 | =item poll 507 | 508 | TODO: Needs confirmation that this is correct. Was previously undocumented. 509 | 510 | 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. 511 | 512 | =cut 513 | 514 | sub poll { 515 | my IPC::Run::IO $self = shift; 516 | my ($harness) = @_; 517 | 518 | if ( defined $self->{FD} ) { 519 | my $d = $self->dir; 520 | if ( $d eq "<" ) { 521 | if ( vec $harness->{WOUT}, $self->{FD}, 1 ) { 522 | _debug_desc_fd( "filtering data to", $self ) 523 | if _debugging_details; 524 | return $self->_do_filters($harness); 525 | } 526 | } 527 | elsif ( $d eq ">" ) { 528 | if ( vec $harness->{ROUT}, $self->{FD}, 1 ) { 529 | _debug_desc_fd( "filtering data from", $self ) 530 | if _debugging_details; 531 | return $self->_do_filters($harness); 532 | } 533 | } 534 | } 535 | return 0; 536 | } 537 | 538 | sub _do_filters { 539 | my IPC::Run::IO $self = shift; 540 | 541 | ( $self->{HARNESS} ) = @_; 542 | 543 | my ( $saved_op, $saved_num ) = ( $IPC::Run::filter_op, $IPC::Run::filter_num ); 544 | $IPC::Run::filter_op = $self; 545 | $IPC::Run::filter_num = -1; 546 | my $redos = 0; 547 | my $r; 548 | { 549 | $@ = ''; 550 | $r = eval { IPC::Run::get_more_input(); }; 551 | 552 | # Detect Resource temporarily unavailable and re-try 200 times (2 seconds), assuming select behaves (which it doesn't always? need ref) 553 | if ( ( $@ || '' ) =~ $IPC::Run::_EAGAIN && $redos++ < 200 ) { 554 | select( undef, undef, undef, 0.01 ); 555 | redo; 556 | } 557 | } 558 | ( $IPC::Run::filter_op, $IPC::Run::filter_num ) = ( $saved_op, $saved_num ); 559 | $self->{HARNESS} = undef; 560 | die "ack ", $@ if $@; 561 | return $r; 562 | } 563 | 564 | =back 565 | 566 | =head1 AUTHOR 567 | 568 | Barrie Slaymaker 569 | 570 | =head1 TODO 571 | 572 | Implement bidirectionality. 573 | 574 | =cut 575 | 576 | 1; 577 | -------------------------------------------------------------------------------- /lib/IPC/Run/Win32IO.pm: -------------------------------------------------------------------------------- 1 | package IPC::Run::Win32IO; 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | IPC::Run::Win32IO - helper routines for IPC::Run on Win32 platforms. 8 | 9 | =head1 SYNOPSIS 10 | 11 | use IPC::Run::Win32IO; # Exports all by default 12 | 13 | =head1 DESCRIPTION 14 | 15 | IPC::Run needs to use sockets to redirect subprocess I/O so that the select() 16 | loop will work on Win32. This seems to only work on WinNT and Win2K at this 17 | time, not sure if it will ever work on Win95 or Win98. If you have experience 18 | in this area, please contact me at barries@slaysys.com, thanks!. 19 | 20 | =head1 DESCRIPTION 21 | 22 | A specialized IO class used on Win32. 23 | 24 | =cut 25 | 26 | use strict; 27 | use warnings; 28 | use Carp; 29 | use IO::Handle; 30 | use Socket; 31 | require POSIX; 32 | 33 | use vars qw{$VERSION}; 34 | 35 | BEGIN { 36 | $VERSION = '20250809.0'; 37 | } 38 | 39 | use Socket qw( IPPROTO_TCP TCP_NODELAY ); 40 | use Symbol; 41 | use Text::ParseWords; 42 | use Win32::Process; 43 | use IPC::Run::Debug qw( :default _debugging_level ); 44 | use IPC::Run::Win32Helper qw( _inherit _dont_inherit ); 45 | use Fcntl qw( O_TEXT O_RDONLY ); 46 | 47 | use base qw( IPC::Run::IO ); 48 | my @cleanup_fields; 49 | 50 | BEGIN { 51 | ## These fields will be set to undef in _cleanup to close 52 | ## the handles. 53 | @cleanup_fields = ( 54 | 'SEND_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize() 55 | 'RECV_THROUGH_TEMP_FILE', ## Set by WinHelper::optimize() 56 | 'TEMP_FILE_NAME', ## The name of the temp file, needed for 57 | ## error reporting / debugging only. 58 | 59 | 'PARENT_HANDLE', ## The handle of the socket for the parent 60 | 'PUMP_SOCKET_HANDLE', ## The socket handle for the pump 61 | 'PUMP_PIPE_HANDLE', ## The anon pipe handle for the pump 62 | 'CHILD_HANDLE', ## The anon pipe handle for the child 63 | 64 | 'TEMP_FILE_HANDLE', ## The Win32 filehandle for the temp file 65 | ); 66 | } 67 | 68 | ## REMOVE OSFHandleOpen 69 | use Win32API::File qw( 70 | GetOsFHandle 71 | OsFHandleOpenFd 72 | OsFHandleOpen 73 | FdGetOsFHandle 74 | SetHandleInformation 75 | SetFilePointer 76 | HANDLE_FLAG_INHERIT 77 | 78 | createFile 79 | WriteFile 80 | ReadFile 81 | CloseHandle 82 | 83 | FILE_ATTRIBUTE_TEMPORARY 84 | FILE_FLAG_DELETE_ON_CLOSE 85 | FILE_FLAG_WRITE_THROUGH 86 | 87 | FILE_BEGIN 88 | ); 89 | 90 | # FILE_ATTRIBUTE_HIDDEN 91 | # FILE_ATTRIBUTE_SYSTEM 92 | 93 | BEGIN { 94 | ## Force AUTOLOADED constants to be, well, constant by getting them 95 | ## to AUTOLOAD before compilation continues. Sigh. 96 | () = ( 97 | SOL_SOCKET, 98 | SO_REUSEADDR, 99 | IPPROTO_TCP, 100 | TCP_NODELAY, 101 | HANDLE_FLAG_INHERIT, 102 | ); 103 | } 104 | 105 | use constant temp_file_flags => ( FILE_ATTRIBUTE_TEMPORARY() | FILE_FLAG_DELETE_ON_CLOSE() | FILE_FLAG_WRITE_THROUGH() ); 106 | 107 | # FILE_ATTRIBUTE_HIDDEN() | 108 | # FILE_ATTRIBUTE_SYSTEM() | 109 | my $tmp_file_counter; 110 | my $tmp_dir; 111 | 112 | sub _cleanup { 113 | my IPC::Run::Win32IO $self = shift; 114 | my ($harness) = @_; 115 | 116 | $self->_recv_through_temp_file($harness) 117 | if $self->{RECV_THROUGH_TEMP_FILE}; 118 | 119 | CloseHandle( $self->{TEMP_FILE_HANDLE} ) 120 | if defined $self->{TEMP_FILE_HANDLE}; 121 | 122 | close( $self->{CHILD_HANDLE} ) 123 | if defined $self->{CHILD_HANDLE}; 124 | 125 | $self->{$_} = undef for @cleanup_fields; 126 | } 127 | 128 | sub _create_temp_file { 129 | my IPC::Run::Win32IO $self = shift; 130 | 131 | ## Create a hidden temp file that Win32 will delete when we close 132 | ## it. 133 | unless ( defined $tmp_dir ) { 134 | $tmp_dir = File::Spec->catdir( File::Spec->tmpdir, "IPC-Run.tmp" ); 135 | 136 | ## Trust in the user's umask. 137 | ## This could possibly be a security hole, perhaps 138 | ## we should offer an option. Hmmmm, really, people coding 139 | ## security conscious apps should audit this code and 140 | ## tell me how to make it better. Nice cop-out :). 141 | unless ( -d $tmp_dir ) { 142 | mkdir $tmp_dir or croak "$!: $tmp_dir"; 143 | } 144 | } 145 | 146 | $self->{TEMP_FILE_NAME} = File::Spec->catfile( 147 | ## File name is designed for easy sorting and not conflicting 148 | ## with other processes. This should allow us to use "t"runcate 149 | ## access in CreateFile in case something left some droppings 150 | ## around (which should never happen because we specify 151 | ## FLAG_DELETE_ON_CLOSE. 152 | ## heh, belt and suspenders are better than bug reports; God forbid 153 | ## that NT should ever crash before a temp file gets deleted! 154 | $tmp_dir, sprintf "Win32io-%06d-%08d", $$, $tmp_file_counter++ 155 | ); 156 | 157 | $self->{TEMP_FILE_HANDLE} = createFile( 158 | $self->{TEMP_FILE_NAME}, 159 | "trw", ## new, truncate, read, write 160 | { 161 | Flags => temp_file_flags, 162 | }, 163 | ) or croak "Can't create temporary file, $self->{TEMP_FILE_NAME}: $^E"; 164 | 165 | $self->{TFD} = OsFHandleOpenFd $self->{TEMP_FILE_HANDLE}, 0; 166 | $self->{FD} = undef; 167 | 168 | _debug 169 | "Win32 Optimizer: temp file (", 170 | $self->{KFD}, 171 | $self->{TYPE}, 172 | $self->{TFD}, 173 | ", fh ", 174 | $self->{TEMP_FILE_HANDLE}, 175 | "): ", 176 | $self->{TEMP_FILE_NAME} 177 | if _debugging_details; 178 | } 179 | 180 | sub _reset_temp_file_pointer { 181 | my $self = shift; 182 | SetFilePointer( $self->{TEMP_FILE_HANDLE}, 0, 0, FILE_BEGIN ) 183 | or confess "$^E seeking on (fd $self->{TFD}) $self->{TEMP_FILE_NAME} for kid's fd $self->{KFD}"; 184 | } 185 | 186 | sub _send_through_temp_file { 187 | my IPC::Run::Win32IO $self = shift; 188 | 189 | _debug "Win32 optimizer: optimizing " . " $self->{KFD} $self->{TYPE} temp file instead of ", 190 | ref $self->{SOURCE} || $self->{SOURCE} 191 | if _debugging_details; 192 | 193 | $self->_create_temp_file; 194 | 195 | if ( defined ${ $self->{SOURCE} } ) { 196 | my $bytes_written = 0; 197 | my $data_ref; 198 | if ( $self->binmode ) { 199 | $data_ref = $self->{SOURCE}; 200 | } 201 | else { 202 | my $data = ${ $self->{SOURCE} }; # Ugh, a copy. 203 | $data =~ s/(?{TEMP_FILE_HANDLE}, 209 | $$data_ref, 210 | 0, ## Write entire buffer 211 | $bytes_written, 212 | [], ## Not overlapped. 213 | ) or croak "$^E writing $self->{TEMP_FILE_NAME} for kid to read on fd $self->{KFD}"; 214 | _debug "Win32 optimizer: wrote $bytes_written to temp file $self->{TEMP_FILE_NAME}" 215 | if _debugging_data; 216 | 217 | $self->_reset_temp_file_pointer; 218 | 219 | } 220 | 221 | _debug "Win32 optimizer: kid to read $self->{KFD} from temp file on $self->{TFD}" 222 | if _debugging_details; 223 | } 224 | 225 | sub _init_recv_through_temp_file { 226 | my IPC::Run::Win32IO $self = shift; 227 | 228 | $self->_create_temp_file; 229 | } 230 | 231 | ## TODO: Use the Win32 API in the select loop to see if the file has grown 232 | ## and read it incrementally if it has. 233 | sub _recv_through_temp_file { 234 | my IPC::Run::Win32IO $self = shift; 235 | 236 | ## This next line kicks in if the run() never got to initting things 237 | ## and needs to clean up. 238 | return undef unless defined $self->{TEMP_FILE_HANDLE}; 239 | 240 | push @{ $self->{FILTERS} }, sub { 241 | my ( undef, $out_ref ) = @_; 242 | 243 | return undef unless defined $self->{TEMP_FILE_HANDLE}; 244 | 245 | my $r; 246 | my $s; 247 | ReadFile( 248 | $self->{TEMP_FILE_HANDLE}, 249 | $s, 250 | 999_999, ## Hmmm, should read the size. 251 | $r, 252 | [] 253 | ) or croak "$^E reading from $self->{TEMP_FILE_NAME}"; 254 | 255 | _debug "ReadFile( $self->{TFD} ) = $r chars '$s'" if _debugging_data; 256 | 257 | return undef unless $r; 258 | 259 | $s =~ s/\r\n/\n/g unless $self->binmode; 260 | 261 | my $pos = pos $$out_ref; 262 | $$out_ref .= $s; 263 | pos($out_ref) = $pos; 264 | return 1; 265 | }; 266 | 267 | my ($harness) = @_; 268 | 269 | $self->_reset_temp_file_pointer; 270 | 271 | 1 while $self->_do_filters($harness); 272 | 273 | pop @{ $self->{FILTERS} }; 274 | 275 | IPC::Run::_close( $self->{TFD} ); 276 | } 277 | 278 | =head1 SUBROUTINES 279 | 280 | =over 281 | 282 | =item poll 283 | 284 | Windows version of IPC::Run::IP::poll. 285 | 286 | =back 287 | 288 | =cut 289 | 290 | sub poll { 291 | my IPC::Run::Win32IO $self = shift; 292 | 293 | return if $self->{SEND_THROUGH_TEMP_FILE} || $self->{RECV_THROUGH_TEMP_FILE}; 294 | 295 | return $self->SUPER::poll(@_); 296 | } 297 | 298 | ## When threaded Perls get good enough, we should use threads here. 299 | ## The problem with threaded perls is that they dup() all sorts of 300 | ## filehandles and fds and don't allow sufficient control over 301 | ## closing off the ones we don't want. 302 | 303 | sub _spawn_pumper { 304 | my ( $stdin, $stdout, $debug_fd, $binmode, $child_label, @opts ) = @_; 305 | my ( $stdin_fd, $stdout_fd ) = ( fileno $stdin, fileno $stdout ); 306 | 307 | _debug "pumper stdin = ", $stdin_fd if _debugging_details; 308 | _debug "pumper stdout = ", $stdout_fd if _debugging_details; 309 | _inherit $stdin_fd, $stdout_fd, $debug_fd; 310 | my @I_options = map qq{"-I$_"}, @INC; 311 | 312 | my $cmd_line = join( 313 | " ", 314 | qq{"$^X"}, 315 | @I_options, 316 | qw(-MIPC::Run::Win32Pump -e 1 ), 317 | ## I'm using this clunky way of passing filehandles to the child process 318 | ## in order to avoid some kind of premature closure of filehandles 319 | ## problem I was having with VCP's test suite when passing them 320 | ## via CreateProcess. All of the ## REMOVE code is stuff I'd like 321 | ## to be rid of and the ## ADD code is what I'd like to use. 322 | FdGetOsFHandle($stdin_fd), ## REMOVE 323 | FdGetOsFHandle($stdout_fd), ## REMOVE 324 | FdGetOsFHandle($debug_fd), ## REMOVE 325 | $binmode ? 1 : 0, 326 | $$, $^T, _debugging_level, qq{"$child_label"}, 327 | @opts 328 | ); 329 | 330 | # open SAVEIN, "<&STDIN" or croak "$! saving STDIN"; #### ADD 331 | # open SAVEOUT, ">&STDOUT" or croak "$! saving STDOUT"; #### ADD 332 | # open SAVEERR, ">&STDERR" or croak "$! saving STDERR"; #### ADD 333 | # _dont_inherit \*SAVEIN; #### ADD 334 | # _dont_inherit \*SAVEOUT; #### ADD 335 | # _dont_inherit \*SAVEERR; #### ADD 336 | # open STDIN, "<&$stdin_fd" or croak "$! dup2()ing $stdin_fd (pumper's STDIN)"; #### ADD 337 | # open STDOUT, ">&$stdout_fd" or croak "$! dup2()ing $stdout_fd (pumper's STDOUT)"; #### ADD 338 | # open STDERR, ">&$debug_fd" or croak "$! dup2()ing $debug_fd (pumper's STDERR/debug_fd)"; #### ADD 339 | 340 | _debug "pump cmd line: ", $cmd_line if _debugging_details; 341 | 342 | my $process; 343 | Win32::Process::Create( 344 | $process, 345 | $^X, 346 | $cmd_line, 347 | 1, ## Inherit handles 348 | NORMAL_PRIORITY_CLASS, 349 | ".", 350 | ) or croak "$!: Win32::Process::Create()"; 351 | 352 | # open STDIN, "<&SAVEIN" or croak "$! restoring STDIN"; #### ADD 353 | # open STDOUT, ">&SAVEOUT" or croak "$! restoring STDOUT"; #### ADD 354 | # open STDERR, ">&SAVEERR" or croak "$! restoring STDERR"; #### ADD 355 | # close SAVEIN or croak "$! closing SAVEIN"; #### ADD 356 | # close SAVEOUT or croak "$! closing SAVEOUT"; #### ADD 357 | # close SAVEERR or croak "$! closing SAVEERR"; #### ADD 358 | 359 | # In case of a sleep right here, need the IPC::Run::_close() treatment. 360 | IPC::Run::_close fileno($stdin); 361 | close $stdin; 362 | IPC::Run::_close fileno($stdout); 363 | close $stdout; 364 | 365 | # Don't close $debug_fd, we need it, as do other pumpers. 366 | 367 | # Pause a moment to allow the child to get up and running and emit 368 | # debug messages. This does not always work. 369 | # select undef, undef, undef, 1 if _debugging_details; 370 | 371 | _debug "_spawn_pumper pid = ", $process->GetProcessID 372 | if _debugging_data; 373 | } 374 | 375 | my $loopback = inet_aton "127.0.0.1"; 376 | my $tcp_proto = getprotobyname('tcp'); 377 | croak "$!: getprotobyname('tcp')" unless defined $tcp_proto; 378 | 379 | sub _socket { 380 | my ($server) = @_; 381 | $server ||= gensym; 382 | my $client = gensym; 383 | 384 | my $listener = gensym; 385 | socket $listener, PF_INET, SOCK_STREAM, $tcp_proto 386 | or croak "$!: socket()"; 387 | setsockopt $listener, SOL_SOCKET, SO_REUSEADDR, pack( "l", 0 ) 388 | or croak "$!: setsockopt()"; 389 | 390 | unless ( bind $listener, sockaddr_in( 0, $loopback ) ) { 391 | croak "Error binding: $!"; 392 | } 393 | 394 | my ($port) = sockaddr_in( getsockname($listener) ); 395 | 396 | _debug "win32 port = $port" if _debugging_details; 397 | 398 | listen $listener, my $queue_size = 1 399 | or croak "$!: listen()"; 400 | 401 | { 402 | socket $client, PF_INET, SOCK_STREAM, $tcp_proto 403 | or croak "$!: socket()"; 404 | 405 | my $paddr = sockaddr_in( $port, $loopback ); 406 | 407 | connect $client, $paddr 408 | or croak "$!: connect()"; 409 | 410 | croak "$!: accept" unless defined $paddr; 411 | 412 | ## The windows "default" is SO_DONTLINGER, which should make 413 | ## sure all socket data goes through. I have my doubts based 414 | ## on experimentation, but nothing prompts me to set SO_LINGER 415 | ## at this time... 416 | setsockopt $client, IPPROTO_TCP, TCP_NODELAY, pack( "l", 0 ) 417 | or croak "$!: setsockopt()"; 418 | } 419 | 420 | { 421 | _debug "accept()ing on port $port" if _debugging_details; 422 | my $paddr = accept( $server, $listener ); 423 | croak "$!: accept()" unless defined $paddr; 424 | } 425 | 426 | _debug "win32 _socket = ( ", fileno $server, ", ", fileno $client, " ) on port $port" 427 | if _debugging_details; 428 | return ( $server, $client ); 429 | } 430 | 431 | sub _open_socket_pipe { 432 | my IPC::Run::Win32IO $self = shift; 433 | my ( $debug_fd, $parent_handle ) = @_; 434 | 435 | my $is_send_to_child = $self->dir eq "<"; 436 | 437 | $self->{CHILD_HANDLE} = gensym; 438 | $self->{PUMP_PIPE_HANDLE} = gensym; 439 | 440 | ( 441 | $self->{PARENT_HANDLE}, 442 | $self->{PUMP_SOCKET_HANDLE} 443 | ) = _socket $parent_handle; 444 | 445 | ## These binmodes seem to have no effect on Win2K, but just to be safe 446 | ## I do them. 447 | binmode $self->{PARENT_HANDLE} or die $!; 448 | binmode $self->{PUMP_SOCKET_HANDLE} or die $!; 449 | 450 | _debug "PUMP_SOCKET_HANDLE = ", fileno $self->{PUMP_SOCKET_HANDLE} 451 | if _debugging_details; 452 | ##my $buf; 453 | ##$buf = "write on child end of " . fileno( $self->{WRITE_HANDLE} ) . "\n\n\n\n\n"; 454 | ##POSIX::write(fileno $self->{WRITE_HANDLE}, $buf, length $buf) or warn "$! in syswrite"; 455 | ##$buf = "write on parent end of " . fileno( $self->{CHILD_HANDLE} ) . "\r\n"; 456 | ##POSIX::write(fileno $self->{CHILD_HANDLE},$buf, length $buf) or warn "$! in syswrite"; 457 | ## $self->{CHILD_HANDLE}->autoflush( 1 ); 458 | ## $self->{WRITE_HANDLE}->autoflush( 1 ); 459 | 460 | ## Now fork off a data pump and arrange to return the correct fds. 461 | if ($is_send_to_child) { 462 | pipe $self->{CHILD_HANDLE}, $self->{PUMP_PIPE_HANDLE} 463 | or croak "$! opening child pipe"; 464 | _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE} 465 | if _debugging_details; 466 | _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE} 467 | if _debugging_details; 468 | } 469 | else { 470 | pipe $self->{PUMP_PIPE_HANDLE}, $self->{CHILD_HANDLE} 471 | or croak "$! opening child pipe"; 472 | _debug "CHILD_HANDLE = ", fileno $self->{CHILD_HANDLE} 473 | if _debugging_details; 474 | _debug "PUMP_PIPE_HANDLE = ", fileno $self->{PUMP_PIPE_HANDLE} 475 | if _debugging_details; 476 | } 477 | 478 | ## These binmodes seem to have no effect on Win2K, but just to be safe 479 | ## I do them. 480 | binmode $self->{CHILD_HANDLE}; 481 | binmode $self->{PUMP_PIPE_HANDLE}; 482 | 483 | ## No child should ever see this. 484 | _dont_inherit $self->{PARENT_HANDLE}; 485 | 486 | ## We clear the inherit flag so these file descriptors are not inherited. 487 | ## It'll be dup()ed on to STDIN/STDOUT/STDERR before CreateProcess is 488 | ## called and *that* fd will be inheritable. 489 | _dont_inherit $self->{PUMP_SOCKET_HANDLE}; 490 | _dont_inherit $self->{PUMP_PIPE_HANDLE}; 491 | _dont_inherit $self->{CHILD_HANDLE}; 492 | 493 | ## Need to return $self so the HANDLEs don't get freed. 494 | ## Return $self, $parent_fd, $child_fd 495 | my ( $parent_fd, $child_fd ) = ( 496 | fileno $self->{PARENT_HANDLE}, 497 | fileno $self->{CHILD_HANDLE} 498 | ); 499 | 500 | ## Both PUMP_..._HANDLEs will be closed, no need to worry about 501 | ## inheritance. 502 | _debug "binmode on" if _debugging_data && $self->binmode; 503 | _spawn_pumper( 504 | $is_send_to_child 505 | ? ( $self->{PUMP_SOCKET_HANDLE}, $self->{PUMP_PIPE_HANDLE} ) 506 | : ( $self->{PUMP_PIPE_HANDLE}, $self->{PUMP_SOCKET_HANDLE} ), 507 | $debug_fd, 508 | $self->binmode, 509 | $child_fd . $self->dir . "pump" . $self->dir . $parent_fd, 510 | ); 511 | 512 | { 513 | my $foo; 514 | confess "PARENT_HANDLE no longer open" 515 | unless POSIX::read( $parent_fd, $foo, 0 ); 516 | } 517 | 518 | _debug "win32_fake_pipe = ( $parent_fd, $child_fd )" 519 | if _debugging_details; 520 | 521 | $self->{FD} = $parent_fd; 522 | $self->{TFD} = $child_fd; 523 | } 524 | 525 | sub _do_open { 526 | my IPC::Run::Win32IO $self = shift; 527 | 528 | if ( $self->{SEND_THROUGH_TEMP_FILE} ) { 529 | return $self->_send_through_temp_file(@_); 530 | } 531 | elsif ( $self->{RECV_THROUGH_TEMP_FILE} ) { 532 | return $self->_init_recv_through_temp_file(@_); 533 | } 534 | else { 535 | return $self->_open_socket_pipe(@_); 536 | } 537 | } 538 | 539 | 1; 540 | 541 | =pod 542 | 543 | =head1 AUTHOR 544 | 545 | Barries Slaymaker . Funded by Perforce Software, Inc. 546 | 547 | =head1 COPYRIGHT 548 | 549 | Copyright 2001, Barrie Slaymaker, All Rights Reserved. 550 | 551 | You may use this under the terms of either the GPL 2.0 or the Artistic License. 552 | 553 | =cut 554 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | Terms of Perl itself 3 | 4 | a) the GNU General Public License as published by the Free 5 | Software Foundation; either version 1, or (at your option) any 6 | later version, or 7 | b) the "Artistic License" 8 | 9 | ---------------------------------------------------------------------------- 10 | 11 | GNU GENERAL PUBLIC LICENSE 12 | Version 2, June 1991 13 | 14 | Copyright (C) 1989, 1991 Free Software Foundation, Inc., 15 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 16 | Everyone is permitted to copy and distribute verbatim copies 17 | of this license document, but changing it is not allowed. 18 | 19 | Preamble 20 | 21 | The licenses for most software are designed to take away your 22 | freedom to share and change it. By contrast, the GNU General Public 23 | License is intended to guarantee your freedom to share and change free 24 | software--to make sure the software is free for all its users. This 25 | General Public License applies to most of the Free Software 26 | Foundation's software and to any other program whose authors commit to 27 | using it. (Some other Free Software Foundation software is covered by 28 | the GNU Lesser General Public License instead.) You can apply it to 29 | your programs, too. 30 | 31 | When we speak of free software, we are referring to freedom, not 32 | price. Our General Public Licenses are designed to make sure that you 33 | have the freedom to distribute copies of free software (and charge for 34 | this service if you wish), that you receive source code or can get it 35 | if you want it, that you can change the software or use pieces of it 36 | in new free programs; and that you know you can do these things. 37 | 38 | To protect your rights, we need to make restrictions that forbid 39 | anyone to deny you these rights or to ask you to surrender the rights. 40 | These restrictions translate to certain responsibilities for you if you 41 | distribute copies of the software, or if you modify it. 42 | 43 | For example, if you distribute copies of such a program, whether 44 | gratis or for a fee, you must give the recipients all the rights that 45 | you have. You must make sure that they, too, receive or can get the 46 | source code. And you must show them these terms so they know their 47 | rights. 48 | 49 | We protect your rights with two steps: (1) copyright the software, and 50 | (2) offer you this license which gives you legal permission to copy, 51 | distribute and/or modify the software. 52 | 53 | Also, for each author's protection and ours, we want to make certain 54 | that everyone understands that there is no warranty for this free 55 | software. If the software is modified by someone else and passed on, we 56 | want its recipients to know that what they have is not the original, so 57 | that any problems introduced by others will not reflect on the original 58 | authors' reputations. 59 | 60 | Finally, any free program is threatened constantly by software 61 | patents. We wish to avoid the danger that redistributors of a free 62 | program will individually obtain patent licenses, in effect making the 63 | program proprietary. To prevent this, we have made it clear that any 64 | patent must be licensed for everyone's free use or not licensed at all. 65 | 66 | The precise terms and conditions for copying, distribution and 67 | modification follow. 68 | 69 | GNU GENERAL PUBLIC LICENSE 70 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 71 | 72 | 0. This License applies to any program or other work which contains 73 | a notice placed by the copyright holder saying it may be distributed 74 | under the terms of this General Public License. The "Program", below, 75 | refers to any such program or work, and a "work based on the Program" 76 | means either the Program or any derivative work under copyright law: 77 | that is to say, a work containing the Program or a portion of it, 78 | either verbatim or with modifications and/or translated into another 79 | language. (Hereinafter, translation is included without limitation in 80 | the term "modification".) Each licensee is addressed as "you". 81 | 82 | Activities other than copying, distribution and modification are not 83 | covered by this License; they are outside its scope. The act of 84 | running the Program is not restricted, and the output from the Program 85 | is covered only if its contents constitute a work based on the 86 | Program (independent of having been made by running the Program). 87 | Whether that is true depends on what the Program does. 88 | 89 | 1. You may copy and distribute verbatim copies of the Program's 90 | source code as you receive it, in any medium, provided that you 91 | conspicuously and appropriately publish on each copy an appropriate 92 | copyright notice and disclaimer of warranty; keep intact all the 93 | notices that refer to this License and to the absence of any warranty; 94 | and give any other recipients of the Program a copy of this License 95 | along with the Program. 96 | 97 | You may charge a fee for the physical act of transferring a copy, and 98 | you may at your option offer warranty protection in exchange for a fee. 99 | 100 | 2. You may modify your copy or copies of the Program or any portion 101 | of it, thus forming a work based on the Program, and copy and 102 | distribute such modifications or work under the terms of Section 1 103 | above, provided that you also meet all of these conditions: 104 | 105 | a) You must cause the modified files to carry prominent notices 106 | stating that you changed the files and the date of any change. 107 | 108 | b) You must cause any work that you distribute or publish, that in 109 | whole or in part contains or is derived from the Program or any 110 | part thereof, to be licensed as a whole at no charge to all third 111 | parties under the terms of this License. 112 | 113 | c) If the modified program normally reads commands interactively 114 | when run, you must cause it, when started running for such 115 | interactive use in the most ordinary way, to print or display an 116 | announcement including an appropriate copyright notice and a 117 | notice that there is no warranty (or else, saying that you provide 118 | a warranty) and that users may redistribute the program under 119 | these conditions, and telling the user how to view a copy of this 120 | License. (Exception: if the Program itself is interactive but 121 | does not normally print such an announcement, your work based on 122 | the Program is not required to print an announcement.) 123 | 124 | These requirements apply to the modified work as a whole. If 125 | identifiable sections of that work are not derived from the Program, 126 | and can be reasonably considered independent and separate works in 127 | themselves, then this License, and its terms, do not apply to those 128 | sections when you distribute them as separate works. But when you 129 | distribute the same sections as part of a whole which is a work based 130 | on the Program, the distribution of the whole must be on the terms of 131 | this License, whose permissions for other licensees extend to the 132 | entire whole, and thus to each and every part regardless of who wrote it. 133 | 134 | Thus, it is not the intent of this section to claim rights or contest 135 | your rights to work written entirely by you; rather, the intent is to 136 | exercise the right to control the distribution of derivative or 137 | collective works based on the Program. 138 | 139 | In addition, mere aggregation of another work not based on the Program 140 | with the Program (or with a work based on the Program) on a volume of 141 | a storage or distribution medium does not bring the other work under 142 | the scope of this License. 143 | 144 | 3. You may copy and distribute the Program (or a work based on it, 145 | under Section 2) in object code or executable form under the terms of 146 | Sections 1 and 2 above provided that you also do one of the following: 147 | 148 | a) Accompany it with the complete corresponding machine-readable 149 | source code, which must be distributed under the terms of Sections 150 | 1 and 2 above on a medium customarily used for software interchange; or, 151 | 152 | b) Accompany it with a written offer, valid for at least three 153 | years, to give any third party, for a charge no more than your 154 | cost of physically performing source distribution, a complete 155 | machine-readable copy of the corresponding source code, to be 156 | distributed under the terms of Sections 1 and 2 above on a medium 157 | customarily used for software interchange; or, 158 | 159 | c) Accompany it with the information you received as to the offer 160 | to distribute corresponding source code. (This alternative is 161 | allowed only for noncommercial distribution and only if you 162 | received the program in object code or executable form with such 163 | an offer, in accord with Subsection b above.) 164 | 165 | The source code for a work means the preferred form of the work for 166 | making modifications to it. For an executable work, complete source 167 | code means all the source code for all modules it contains, plus any 168 | associated interface definition files, plus the scripts used to 169 | control compilation and installation of the executable. However, as a 170 | special exception, the source code distributed need not include 171 | anything that is normally distributed (in either source or binary 172 | form) with the major components (compiler, kernel, and so on) of the 173 | operating system on which the executable runs, unless that component 174 | itself accompanies the executable. 175 | 176 | If distribution of executable or object code is made by offering 177 | access to copy from a designated place, then offering equivalent 178 | access to copy the source code from the same place counts as 179 | distribution of the source code, even though third parties are not 180 | compelled to copy the source along with the object code. 181 | 182 | 4. You may not copy, modify, sublicense, or distribute the Program 183 | except as expressly provided under this License. Any attempt 184 | otherwise to copy, modify, sublicense or distribute the Program is 185 | void, and will automatically terminate your rights under this License. 186 | However, parties who have received copies, or rights, from you under 187 | this License will not have their licenses terminated so long as such 188 | parties remain in full compliance. 189 | 190 | 5. You are not required to accept this License, since you have not 191 | signed it. However, nothing else grants you permission to modify or 192 | distribute the Program or its derivative works. These actions are 193 | prohibited by law if you do not accept this License. Therefore, by 194 | modifying or distributing the Program (or any work based on the 195 | Program), you indicate your acceptance of this License to do so, and 196 | all its terms and conditions for copying, distributing or modifying 197 | the Program or works based on it. 198 | 199 | 6. Each time you redistribute the Program (or any work based on the 200 | Program), the recipient automatically receives a license from the 201 | original licensor to copy, distribute or modify the Program subject to 202 | these terms and conditions. You may not impose any further 203 | restrictions on the recipients' exercise of the rights granted herein. 204 | You are not responsible for enforcing compliance by third parties to 205 | this License. 206 | 207 | 7. If, as a consequence of a court judgment or allegation of patent 208 | infringement or for any other reason (not limited to patent issues), 209 | conditions are imposed on you (whether by court order, agreement or 210 | otherwise) that contradict the conditions of this License, they do not 211 | excuse you from the conditions of this License. If you cannot 212 | distribute so as to satisfy simultaneously your obligations under this 213 | License and any other pertinent obligations, then as a consequence you 214 | may not distribute the Program at all. For example, if a patent 215 | license would not permit royalty-free redistribution of the Program by 216 | all those who receive copies directly or indirectly through you, then 217 | the only way you could satisfy both it and this License would be to 218 | refrain entirely from distribution of the Program. 219 | 220 | If any portion of this section is held invalid or unenforceable under 221 | any particular circumstance, the balance of the section is intended to 222 | apply and the section as a whole is intended to apply in other 223 | circumstances. 224 | 225 | It is not the purpose of this section to induce you to infringe any 226 | patents or other property right claims or to contest validity of any 227 | such claims; this section has the sole purpose of protecting the 228 | integrity of the free software distribution system, which is 229 | implemented by public license practices. Many people have made 230 | generous contributions to the wide range of software distributed 231 | through that system in reliance on consistent application of that 232 | system; it is up to the author/donor to decide if he or she is willing 233 | to distribute software through any other system and a licensee cannot 234 | impose that choice. 235 | 236 | This section is intended to make thoroughly clear what is believed to 237 | be a consequence of the rest of this License. 238 | 239 | 8. If the distribution and/or use of the Program is restricted in 240 | certain countries either by patents or by copyrighted interfaces, the 241 | original copyright holder who places the Program under this License 242 | may add an explicit geographical distribution limitation excluding 243 | those countries, so that distribution is permitted only in or among 244 | countries not thus excluded. In such case, this License incorporates 245 | the limitation as if written in the body of this License. 246 | 247 | 9. The Free Software Foundation may publish revised and/or new versions 248 | of the General Public License from time to time. Such new versions will 249 | be similar in spirit to the present version, but may differ in detail to 250 | address new problems or concerns. 251 | 252 | Each version is given a distinguishing version number. If the Program 253 | specifies a version number of this License which applies to it and "any 254 | later version", you have the option of following the terms and conditions 255 | either of that version or of any later version published by the Free 256 | Software Foundation. If the Program does not specify a version number of 257 | this License, you may choose any version ever published by the Free Software 258 | Foundation. 259 | 260 | 10. If you wish to incorporate parts of the Program into other free 261 | programs whose distribution conditions are different, write to the author 262 | to ask for permission. For software which is copyrighted by the Free 263 | Software Foundation, write to the Free Software Foundation; we sometimes 264 | make exceptions for this. Our decision will be guided by the two goals 265 | of preserving the free status of all derivatives of our free software and 266 | of promoting the sharing and reuse of software generally. 267 | 268 | NO WARRANTY 269 | 270 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 271 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 272 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 273 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 274 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 275 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 276 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 277 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 278 | REPAIR OR CORRECTION. 279 | 280 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 281 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 282 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 283 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 284 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 285 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 286 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 287 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 288 | POSSIBILITY OF SUCH DAMAGES. 289 | 290 | END OF TERMS AND CONDITIONS 291 | 292 | How to Apply These Terms to Your New Programs 293 | 294 | If you develop a new program, and you want it to be of the greatest 295 | possible use to the public, the best way to achieve this is to make it 296 | free software which everyone can redistribute and change under these terms. 297 | 298 | To do so, attach the following notices to the program. It is safest 299 | to attach them to the start of each source file to most effectively 300 | convey the exclusion of warranty; and each file should have at least 301 | the "copyright" line and a pointer to where the full notice is found. 302 | 303 | 304 | Copyright (C) 305 | 306 | This program is free software; you can redistribute it and/or modify 307 | it under the terms of the GNU General Public License as published by 308 | the Free Software Foundation; either version 2 of the License, or 309 | (at your option) any later version. 310 | 311 | This program is distributed in the hope that it will be useful, 312 | but WITHOUT ANY WARRANTY; without even the implied warranty of 313 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 314 | GNU General Public License for more details. 315 | 316 | You should have received a copy of the GNU General Public License along 317 | with this program; if not, write to the Free Software Foundation, Inc., 318 | 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 319 | 320 | Also add information on how to contact you by electronic and paper mail. 321 | 322 | If the program is interactive, make it output a short notice like this 323 | when it starts in an interactive mode: 324 | 325 | Gnomovision version 69, Copyright (C) year name of author 326 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 327 | This is free software, and you are welcome to redistribute it 328 | under certain conditions; type `show c' for details. 329 | 330 | The hypothetical commands `show w' and `show c' should show the appropriate 331 | parts of the General Public License. Of course, the commands you use may 332 | be called something other than `show w' and `show c'; they could even be 333 | mouse-clicks or menu items--whatever suits your program. 334 | 335 | You should also get your employer (if you work as a programmer) or your 336 | school, if any, to sign a "copyright disclaimer" for the program, if 337 | necessary. Here is a sample; alter the names: 338 | 339 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 340 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 341 | 342 | , 1 April 1989 343 | Ty Coon, President of Vice 344 | 345 | This General Public License does not permit incorporating your program into 346 | proprietary programs. If your program is a subroutine library, you may 347 | consider it more useful to permit linking proprietary applications with the 348 | library. If this is what you want to do, use the GNU Lesser General 349 | Public License instead of this License. 350 | -------------------------------------------------------------------------------- /lib/IPC/Run/Timer.pm: -------------------------------------------------------------------------------- 1 | package IPC::Run::Timer; 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | IPC::Run::Timer -- Timer channels for IPC::Run. 8 | 9 | =head1 SYNOPSIS 10 | 11 | use IPC::Run qw( run timer timeout ); 12 | ## or IPC::Run::Timer ( timer timeout ); 13 | ## or IPC::Run::Timer ( :all ); 14 | 15 | ## A non-fatal timer: 16 | $t = timer( 5 ); # or... 17 | $t = IO::Run::Timer->new( 5 ); 18 | run $t, ...; 19 | 20 | ## A timeout (which is a timer that dies on expiry): 21 | $t = timeout( 5 ); # or... 22 | $t = IO::Run::Timer->new( 5, exception => "harness timed out" ); 23 | 24 | =head1 DESCRIPTION 25 | 26 | This class and module allows timers and timeouts to be created for use 27 | by IPC::Run. A timer simply expires when its time is up. A timeout 28 | is a timer that throws an exception when it expires. 29 | 30 | Timeouts are usually a bit simpler to use than timers: they throw an 31 | exception on expiration so you don't need to check them: 32 | 33 | ## Give @cmd 10 seconds to get started, then 5 seconds to respond 34 | my $t = timeout( 10 ); 35 | $h = start( 36 | \@cmd, \$in, \$out, 37 | $t, 38 | ); 39 | pump $h until $out =~ /prompt/; 40 | 41 | $in = "some stimulus"; 42 | $out = ''; 43 | $t->time( 5 ) 44 | pump $h until $out =~ /expected response/; 45 | 46 | You do need to check timers: 47 | 48 | ## Give @cmd 10 seconds to get started, then 5 seconds to respond 49 | my $t = timer( 10 ); 50 | $h = start( 51 | \@cmd, \$in, \$out, 52 | $t, 53 | ); 54 | pump $h until $t->is_expired || $out =~ /prompt/; 55 | 56 | $in = "some stimulus"; 57 | $out = ''; 58 | $t->time( 5 ) 59 | pump $h until $out =~ /expected response/ || $t->is_expired; 60 | 61 | Timers and timeouts that are reset get started by start() and 62 | pump(). Timers change state only in pump(). Since run() and 63 | finish() both call pump(), they act like pump() with respect to 64 | timers. 65 | 66 | Timers and timeouts have three states: reset, running, and expired. 67 | Setting the timeout value resets the timer, as does calling 68 | the reset() method. The start() method starts (or restarts) a 69 | timer with the most recently set time value, no matter what state 70 | it's in. 71 | 72 | =head2 Time values 73 | 74 | All time values are in seconds. Times may be any kind of perl number, 75 | e.g. as integer or floating point seconds, optionally preceded by 76 | punctuation-separated days, hours, and minutes. 77 | 78 | Examples: 79 | 80 | 1 1 second 81 | 1.1 1.1 seconds 82 | 60 60 seconds 83 | 1:0 1 minute 84 | 1:1 1 minute, 1 second 85 | 1:90 2 minutes, 30 seconds 86 | 1:2:3:4.5 1 day, 2 hours, 3 minutes, 4.5 seconds 87 | 'inf' the infinity perl special number (the timer never finishes) 88 | 89 | Absolute date/time strings are *not* accepted: year, month and 90 | day-of-month parsing is not available (patches welcome :-). 91 | 92 | =head2 Interval fudging 93 | 94 | When calculating an end time from a start time and an interval, IPC::Run::Timer 95 | instances add a little fudge factor. This is to ensure that no time will 96 | expire before the interval is up. 97 | 98 | First a little background. Time is sampled in discrete increments. We'll 99 | call the 100 | exact moment that the reported time increments from one interval to the 101 | next a tick, and the interval between ticks as the time period. Here's 102 | a diagram of three ticks and the periods between them: 103 | 104 | 105 | -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-... 106 | ^ ^ ^ 107 | |<--- period 0 ---->|<--- period 1 ---->| 108 | | | | 109 | tick 0 tick 1 tick 2 110 | 111 | To see why the fudge factor is necessary, consider what would happen 112 | when a timer with an interval of 1 second is started right at the end of 113 | period 0: 114 | 115 | 116 | -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-... 117 | ^ ^ ^ ^ 118 | | | | | 119 | | | | | 120 | tick 0 |tick 1 tick 2 121 | | 122 | start $t 123 | 124 | Assuming that check() is called many times per period, then the timer 125 | is likely to expire just after tick 1, since the time reported will have 126 | lept from the value '0' to the value '1': 127 | 128 | -0-0-0-0-0-0-0-0-0-0-1-1-1-1-1-1-1-1-1-1-2-... 129 | ^ ^ ^ ^ ^ 130 | | | | | | 131 | | | | | | 132 | tick 0 |tick 1| tick 2 133 | | | 134 | start $t | 135 | | 136 | check $t 137 | 138 | Adding a fudge of '1' in this example means that the timer is guaranteed 139 | not to expire before tick 2. 140 | 141 | The fudge is not added to an interval of '0'. 142 | 143 | This means that intervals guarantee a minimum interval. Given that 144 | the process running perl may be suspended for some period of time, or that 145 | it gets busy doing something time-consuming, there are no other guarantees on 146 | how long it will take a timer to expire. 147 | 148 | =head1 SUBCLASSING 149 | 150 | INCOMPATIBLE CHANGE: Due to the awkwardness introduced by ripping 151 | pseudohashes out of Perl, this class I uses the fields 152 | pragma. 153 | 154 | =head1 FUNCTIONS & METHODS 155 | 156 | =over 157 | 158 | =cut 159 | 160 | use strict; 161 | use warnings; 162 | use Carp; 163 | use Fcntl; 164 | use Symbol; 165 | use Exporter; 166 | use Scalar::Util (); 167 | use vars qw( $VERSION @ISA @EXPORT_OK %EXPORT_TAGS ); 168 | 169 | BEGIN { 170 | $VERSION = '20250809.0'; 171 | @ISA = qw( Exporter ); 172 | @EXPORT_OK = qw( 173 | check 174 | end_time 175 | exception 176 | expire 177 | interval 178 | is_expired 179 | is_reset 180 | is_running 181 | name 182 | reset 183 | start 184 | timeout 185 | timer 186 | ); 187 | 188 | %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); 189 | } 190 | 191 | require IPC::Run; 192 | use IPC::Run::Debug; 193 | 194 | ## 195 | ## Some helpers 196 | ## 197 | my $resolution = 1; 198 | 199 | sub _parse_time { 200 | for ( $_[0] ) { 201 | my $val; 202 | if ( not defined $_ ) { 203 | $val = $_; 204 | } 205 | else { 206 | my @f = split( /:/, $_, -1 ); 207 | if ( scalar @f > 4 ) { 208 | croak "IPC::Run: expected <= 4 elements in time string '$_'"; 209 | } 210 | for (@f) { 211 | if ( not Scalar::Util::looks_like_number($_) ) { 212 | croak "IPC::Run: non-numeric element '$_' in time string '$_'"; 213 | } 214 | } 215 | my ( $s, $m, $h, $d ) = reverse @f; 216 | $val = ( ( ( $d || 0 ) * 24 + ( $h || 0 ) ) * 60 + ( $m || 0 ) ) * 60 + ( $s || 0 ); 217 | } 218 | return $val; 219 | } 220 | } 221 | 222 | sub _calc_end_time { 223 | my IPC::Run::Timer $self = shift; 224 | my $interval = $self->interval; 225 | $interval += $resolution if $interval; 226 | $self->end_time( $self->start_time + $interval ); 227 | } 228 | 229 | =item timer 230 | 231 | A constructor function (not method) of IPC::Run::Timer instances: 232 | 233 | $t = timer( 5 ); 234 | $t = timer( 5, name => 'stall timer', debug => 1 ); 235 | 236 | $t = timer; 237 | $t->interval( 5 ); 238 | 239 | run ..., $t; 240 | run ..., $t = timer( 5 ); 241 | 242 | This convenience function is a shortened spelling of 243 | 244 | IPC::Run::Timer->new( ... ); 245 | 246 | . It returns a timer in the reset state with a given interval. 247 | 248 | If an exception is provided, it will be thrown when the timer notices that 249 | it has expired (in check()). The name is for debugging usage, if you plan on 250 | having multiple timers around. If no name is provided, a name like "timer #1" 251 | will be provided. 252 | 253 | =cut 254 | 255 | sub timer { 256 | return IPC::Run::Timer->new(@_); 257 | } 258 | 259 | =item timeout 260 | 261 | A constructor function (not method) of IPC::Run::Timer instances: 262 | 263 | $t = timeout( 5 ); 264 | $t = timeout( 5, exception => "kablooey" ); 265 | $t = timeout( 5, name => "stall", exception => "kablooey" ); 266 | 267 | $t = timeout; 268 | $t->interval( 5 ); 269 | 270 | run ..., $t; 271 | run ..., $t = timeout( 5 ); 272 | 273 | A This convenience function is a shortened spelling of 274 | 275 | IPC::Run::Timer->new( exception => "IPC::Run: timeout ...", ... ); 276 | 277 | . It returns a timer in the reset state that will throw an 278 | exception when it expires. 279 | 280 | Takes the same parameters as L, any exception passed in overrides 281 | the default exception. 282 | 283 | =cut 284 | 285 | sub timeout { 286 | my $t = IPC::Run::Timer->new(@_); 287 | $t->exception( "IPC::Run: timeout on " . $t->name ) 288 | unless defined $t->exception; 289 | return $t; 290 | } 291 | 292 | =item new 293 | 294 | IPC::Run::Timer->new() ; 295 | IPC::Run::Timer->new( 5 ) ; 296 | IPC::Run::Timer->new( 5, exception => 'kablooey' ) ; 297 | 298 | Constructor. See L for details. 299 | 300 | =cut 301 | 302 | my $timer_counter; 303 | 304 | sub new { 305 | my $class = shift; 306 | $class = ref $class || $class; 307 | 308 | my IPC::Run::Timer $self = bless {}, $class; 309 | 310 | $self->{STATE} = 0; 311 | $self->{DEBUG} = 0; 312 | $self->{NAME} = "timer #" . ++$timer_counter; 313 | 314 | while (@_) { 315 | my $arg = shift; 316 | if ( $arg eq 'exception' ) { 317 | $self->exception(shift); 318 | } 319 | elsif ( $arg eq 'name' ) { 320 | $self->name(shift); 321 | } 322 | elsif ( $arg eq 'debug' ) { 323 | $self->debug(shift); 324 | } 325 | else { 326 | $self->interval($arg); 327 | } 328 | } 329 | 330 | _debug $self->name . ' constructed' 331 | if $self->{DEBUG} || _debugging_details; 332 | 333 | return $self; 334 | } 335 | 336 | =item check 337 | 338 | check $t; 339 | check $t, $now; 340 | $t->check; 341 | 342 | Checks to see if a timer has expired since the last check. Has no effect 343 | on non-running timers. This will throw an exception if one is defined. 344 | 345 | IPC::Run::pump() calls this routine for any timers in the harness. 346 | 347 | You may pass in a version of now, which is useful in case you have 348 | it lying around or you want to check several timers with a consistent 349 | concept of the current time. 350 | 351 | Returns the time left before end_time or 0 if end_time is no longer 352 | in the future or the timer is not running 353 | (unless, of course, check() expire()s the timer and this 354 | results in an exception being thrown). 355 | 356 | Returns undef if the timer is not running on entry, 0 if check() expires it, 357 | and the time left if it's left running. 358 | 359 | =cut 360 | 361 | sub check { 362 | my IPC::Run::Timer $self = shift; 363 | return undef if !$self->is_running; 364 | return 0 if $self->is_expired; 365 | 366 | my ($now) = @_; 367 | $now = _parse_time($now); 368 | $now = time unless defined $now; 369 | 370 | _debug( "checking ", $self->name, " (end time ", $self->end_time, ") at ", $now ) if $self->{DEBUG} || _debugging_details; 371 | 372 | my $left = $self->end_time - $now; 373 | return $left if $left > 0; 374 | 375 | $self->expire; 376 | return 0; 377 | } 378 | 379 | =item debug 380 | 381 | Sets/gets the current setting of the debugging flag for this timer. This 382 | has no effect if debugging is not enabled for the current harness. 383 | 384 | =cut 385 | 386 | sub debug { 387 | my IPC::Run::Timer $self = shift; 388 | $self->{DEBUG} = shift if @_; 389 | return $self->{DEBUG}; 390 | } 391 | 392 | =item end_time 393 | 394 | $et = $t->end_time; 395 | $et = end_time $t; 396 | 397 | $t->end_time( time + 10 ); 398 | 399 | Returns the time when this timer will or did expire. Even if this time is 400 | in the past, the timer may not be expired, since check() may not have been 401 | called yet. 402 | 403 | Note that this end_time is not start_time($t) + interval($t), since some 404 | small extra amount of time is added to make sure that the timer does not 405 | expire before interval() elapses. If this were not so, then 406 | 407 | Changing end_time() while a timer is running will set the expiration time. 408 | Changing it while it is expired has no affect, since reset()ing a timer always 409 | clears the end_time(). 410 | 411 | =cut 412 | 413 | sub end_time { 414 | my IPC::Run::Timer $self = shift; 415 | if (@_) { 416 | $self->{END_TIME} = shift; 417 | _debug $self->name, ' end_time set to ', $self->{END_TIME} 418 | if $self->{DEBUG} > 2 || _debugging_details; 419 | } 420 | return $self->{END_TIME}; 421 | } 422 | 423 | =item exception 424 | 425 | $x = $t->exception; 426 | $t->exception( $x ); 427 | $t->exception( undef ); 428 | 429 | Sets/gets the exception to throw, if any. 'undef' means that no 430 | exception will be thrown. Exception does not need to be a scalar: you 431 | may ask that references be thrown. 432 | 433 | =cut 434 | 435 | sub exception { 436 | my IPC::Run::Timer $self = shift; 437 | if (@_) { 438 | $self->{EXCEPTION} = shift; 439 | _debug $self->name, ' exception set to ', $self->{EXCEPTION} 440 | if $self->{DEBUG} || _debugging_details; 441 | } 442 | return $self->{EXCEPTION}; 443 | } 444 | 445 | =item interval 446 | 447 | $i = interval $t; 448 | $i = $t->interval; 449 | $t->interval( $i ); 450 | 451 | Sets the interval. Sets the end time based on the start_time() and the 452 | interval (and a little fudge) if the timer is running. 453 | 454 | =cut 455 | 456 | sub interval { 457 | my IPC::Run::Timer $self = shift; 458 | if (@_) { 459 | $self->{INTERVAL} = _parse_time(shift); 460 | _debug $self->name, ' interval set to ', $self->{INTERVAL} 461 | if $self->{DEBUG} > 2 || _debugging_details; 462 | 463 | $self->_calc_end_time if $self->state; 464 | } 465 | return $self->{INTERVAL}; 466 | } 467 | 468 | =item expire 469 | 470 | expire $t; 471 | $t->expire; 472 | 473 | Sets the state to expired (undef). 474 | Will throw an exception if one 475 | is defined and the timer was not already expired. You can expire a 476 | reset timer without starting it. 477 | 478 | =cut 479 | 480 | sub expire { 481 | my IPC::Run::Timer $self = shift; 482 | if ( defined $self->state ) { 483 | _debug $self->name . ' expired' 484 | if $self->{DEBUG} || _debugging; 485 | 486 | $self->state(undef); 487 | croak $self->exception if $self->exception; 488 | } 489 | return undef; 490 | } 491 | 492 | =item is_running 493 | 494 | =cut 495 | 496 | sub is_running { 497 | my IPC::Run::Timer $self = shift; 498 | return $self->state ? 1 : 0; 499 | } 500 | 501 | =item is_reset 502 | 503 | =cut 504 | 505 | sub is_reset { 506 | my IPC::Run::Timer $self = shift; 507 | return defined $self->state && $self->state == 0; 508 | } 509 | 510 | =item is_expired 511 | 512 | =cut 513 | 514 | sub is_expired { 515 | my IPC::Run::Timer $self = shift; 516 | return !defined $self->state; 517 | } 518 | 519 | =item name 520 | 521 | Sets/gets this timer's name. The name is only used for debugging 522 | purposes so you can tell which freakin' timer is doing what. 523 | 524 | =cut 525 | 526 | sub name { 527 | my IPC::Run::Timer $self = shift; 528 | 529 | $self->{NAME} = shift if @_; 530 | return 531 | defined $self->{NAME} ? $self->{NAME} 532 | : defined $self->{EXCEPTION} ? 'timeout' 533 | : 'timer'; 534 | } 535 | 536 | =item reset 537 | 538 | reset $t; 539 | $t->reset; 540 | 541 | Resets the timer to the non-running, non-expired state and clears 542 | the end_time(). 543 | 544 | =cut 545 | 546 | sub reset { 547 | my IPC::Run::Timer $self = shift; 548 | $self->state(0); 549 | $self->end_time(undef); 550 | _debug $self->name . ' reset' 551 | if $self->{DEBUG} || _debugging; 552 | 553 | return undef; 554 | } 555 | 556 | =item start 557 | 558 | start $t; 559 | $t->start; 560 | start $t, $interval; 561 | start $t, $interval, $now; 562 | 563 | Starts or restarts a timer. This always sets the start_time. It sets the 564 | end_time based on the interval if the timer is running or if no end time 565 | has been set. 566 | 567 | You may pass an optional interval or current time value. 568 | 569 | Not passing a defined interval causes the previous interval setting to be 570 | re-used unless the timer is reset and an end_time has been set 571 | (an exception is thrown if no interval has been set). 572 | 573 | Not passing a defined current time value causes the current time to be used. 574 | 575 | Passing a current time value is useful if you happen to have a time value 576 | lying around or if you want to make sure that several timers are started 577 | with the same concept of start time. You might even need to lie to an 578 | IPC::Run::Timer, occasionally. 579 | 580 | =cut 581 | 582 | sub start { 583 | my IPC::Run::Timer $self = shift; 584 | 585 | my ( $interval, $now ) = map { _parse_time($_) } @_; 586 | $now = _parse_time($now); 587 | $now = time unless defined $now; 588 | 589 | $self->interval($interval) if defined $interval; 590 | 591 | ## start()ing a running or expired timer clears the end_time, so that the 592 | ## interval is used. So does specifying an interval. 593 | $self->end_time(undef) if !$self->is_reset || $interval; 594 | 595 | croak "IPC::Run: no timer interval or end_time defined for " . $self->name 596 | unless defined $self->interval || defined $self->end_time; 597 | 598 | $self->state(1); 599 | $self->start_time($now); 600 | ## The "+ 1" is in case the START_TIME was sampled at the end of a 601 | ## tick (which are one second long in this module). 602 | $self->_calc_end_time 603 | unless defined $self->end_time; 604 | 605 | _debug( 606 | $self->name, " started at ", $self->start_time, 607 | ", with interval ", $self->interval, ", end_time ", $self->end_time 608 | ) if $self->{DEBUG} || _debugging; 609 | return undef; 610 | } 611 | 612 | =item start_time 613 | 614 | Sets/gets the start time, in seconds since the epoch. Setting this manually 615 | is a bad idea, it's better to call L() at the correct time. 616 | 617 | =cut 618 | 619 | sub start_time { 620 | my IPC::Run::Timer $self = shift; 621 | if (@_) { 622 | $self->{START_TIME} = _parse_time(shift); 623 | _debug $self->name, ' start_time set to ', $self->{START_TIME} 624 | if $self->{DEBUG} > 2 || _debugging; 625 | } 626 | 627 | return $self->{START_TIME}; 628 | } 629 | 630 | =item state 631 | 632 | $s = state $t; 633 | $t->state( $s ); 634 | 635 | Get/Set the current state. Only use this if you really need to transfer the 636 | state to/from some variable. 637 | Use L, L, L, L, L, 638 | L. 639 | 640 | Note: Setting the state to 'undef' to expire a timer will not throw an 641 | exception. 642 | 643 | =back 644 | 645 | =cut 646 | 647 | sub state { 648 | my IPC::Run::Timer $self = shift; 649 | if (@_) { 650 | $self->{STATE} = shift; 651 | _debug $self->name, ' state set to ', $self->{STATE} 652 | if $self->{DEBUG} > 2 || _debugging; 653 | } 654 | return $self->{STATE}; 655 | } 656 | 657 | 1; 658 | 659 | =pod 660 | 661 | =head1 TODO 662 | 663 | use Time::HiRes; if it's present. 664 | 665 | Add detection and parsing of [[[HH:]MM:]SS formatted times and intervals. 666 | 667 | =head1 AUTHOR 668 | 669 | Barrie Slaymaker 670 | 671 | =cut 672 | -------------------------------------------------------------------------------- /lib/IPC/Run/Win32Helper.pm: -------------------------------------------------------------------------------- 1 | package IPC::Run::Win32Helper; 2 | 3 | =pod 4 | 5 | =head1 NAME 6 | 7 | IPC::Run::Win32Helper - helper routines for IPC::Run on Win32 platforms. 8 | 9 | =head1 SYNOPSIS 10 | 11 | use IPC::Run::Win32Helper; # Exports all by default 12 | 13 | =head1 DESCRIPTION 14 | 15 | IPC::Run needs to use sockets to redirect subprocess I/O so that the select() loop 16 | will work on Win32. This seems to only work on WinNT and Win2K at this time, not 17 | sure if it will ever work on Win95 or Win98. If you have experience in this area, please 18 | contact me at barries@slaysys.com, thanks!. 19 | 20 | =cut 21 | 22 | use strict; 23 | use warnings; 24 | use Carp; 25 | use IO::Handle; 26 | use vars qw{ $VERSION @ISA @EXPORT }; 27 | 28 | BEGIN { 29 | $VERSION = '20250809.0'; 30 | @ISA = qw( Exporter ); 31 | @EXPORT = qw( 32 | win32_spawn 33 | win32_parse_cmd_line 34 | _dont_inherit 35 | _inherit 36 | ); 37 | } 38 | 39 | require POSIX; 40 | 41 | use File::Spec (); 42 | use Text::ParseWords; 43 | use Win32 (); 44 | use Win32::Process; 45 | use Win32::ShellQuote (); 46 | use IPC::Run::Debug; 47 | use Win32API::File qw( 48 | FdGetOsFHandle 49 | SetHandleInformation 50 | HANDLE_FLAG_INHERIT 51 | ); 52 | 53 | # Replace Win32API::File::INVALID_HANDLE_VALUE, which does not match the C ABI 54 | # on 64-bit builds (https://github.com/chorny/Win32API-File/issues/13). 55 | use constant C_ABI_INVALID_HANDLE_VALUE => length( pack 'P', undef ) == 4 56 | ? 0xffffffff 57 | : 0xffffffff << 32 | 0xffffffff; 58 | 59 | ## Takes an fd or a GLOB ref, never never never a Win32 handle. 60 | sub _dont_inherit { 61 | for (@_) { 62 | next unless defined $_; 63 | my $fd = $_; 64 | $fd = fileno $fd if ref $fd; 65 | _debug "disabling inheritance of ", $fd if _debugging_details; 66 | my $osfh = FdGetOsFHandle $fd; 67 | 68 | # Contrary to documentation, $! has the failure reason 69 | # (https://github.com/chorny/Win32API-File/issues/14) 70 | croak "$!: FdGetOsFHandle( $fd )" 71 | if !defined $osfh || $osfh == C_ABI_INVALID_HANDLE_VALUE; 72 | 73 | SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 0 ); 74 | } 75 | } 76 | 77 | sub _inherit { #### REMOVE 78 | for (@_) { #### REMOVE 79 | next unless defined $_; #### REMOVE 80 | my $fd = $_; #### REMOVE 81 | $fd = fileno $fd if ref $fd; #### REMOVE 82 | _debug "enabling inheritance of ", $fd if _debugging_details; #### REMOVE 83 | my $osfh = FdGetOsFHandle $fd; #### REMOVE 84 | 85 | # Contrary to documentation, $! has the failure reason 86 | # (https://github.com/chorny/Win32API-File/issues/14) 87 | croak "$!: FdGetOsFHandle( $fd )" 88 | if !defined $osfh || $osfh == C_ABI_INVALID_HANDLE_VALUE; 89 | #### REMOVE 90 | SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, 1 ); #### REMOVE 91 | } #### REMOVE 92 | } #### REMOVE 93 | #### REMOVE 94 | #sub _inherit { 95 | # for ( @_ ) { 96 | # next unless defined $_; 97 | # my $osfh = GetOsFHandle $_; 98 | # croak $^E if ! defined $osfh || $osfh == INVALID_HANDLE_VALUE; 99 | # SetHandleInformation( $osfh, HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT ); 100 | # } 101 | #} 102 | 103 | =pod 104 | 105 | =head1 FUNCTIONS 106 | 107 | =over 108 | 109 | =item optimize() 110 | 111 | Most common incantations of C (I C, C, 112 | or C) now use temporary files to redirect input and output 113 | instead of pumper processes. 114 | 115 | Temporary files are used when sending to child processes if input is 116 | taken from a scalar with no filter subroutines. This is the only time 117 | we can assume that the parent is not interacting with the child's 118 | redirected input as it runs. 119 | 120 | Temporary files are used when receiving from children when output is 121 | to a scalar or subroutine with or without filters, but only if 122 | the child in question closes its inputs or takes input from 123 | unfiltered SCALARs or named files. Normally, a child inherits its STDIN 124 | from its parent; to close it, use "0<&-" or the C<< noinherit => 1 >> option. 125 | If data is sent to the child from CODE refs, filehandles or from 126 | scalars through filters than the child's outputs will not be optimized 127 | because C assumes the parent is interacting with the child. 128 | It is ok if the output is filtered or handled by a subroutine, however. 129 | 130 | This assumes that all named files are real files (as opposed to named 131 | pipes) and won't change; and that a process is not communicating with 132 | the child indirectly (through means not visible to IPC::Run). 133 | These can be an invalid assumptions, but are the 99% case. 134 | Write me if you need an option to enable or disable optimizations; I 135 | suspect it will work like the C modifier. 136 | 137 | To detect cases that you might want to optimize by closing inputs, try 138 | setting the C environment variable to the special C 139 | value: 140 | 141 | C:> set IPCRUNDEBUG=notopt 142 | C:> my_app_that_uses_IPC_Run.pl 143 | 144 | =item optimizer() rationalizations 145 | 146 | Only for that limited case can we be sure that it's ok to batch all the 147 | input in to a temporary file. If STDIN is from a SCALAR or from a named 148 | file or filehandle (again, only in C), then outputs to CODE refs 149 | are also assumed to be safe enough to batch through a temp file, 150 | otherwise only outputs to SCALAR refs are batched. This can cause a bit 151 | of grief if the parent process benefits from or relies on a bit of 152 | "early returns" coming in before the child program exits. As long as 153 | the output is redirected to a SCALAR ref, this will not be visible. 154 | When output is redirected to a subroutine or (deprecated) filters, the 155 | subroutine will not get any data until after the child process exits, 156 | and it is likely to get bigger chunks of data at once. 157 | 158 | The reason for the optimization is that, without it, "pumper" processes 159 | are used to overcome the inconsistencies of the Win32 API. We need to 160 | use anonymous pipes to connect to the child processes' stdin, stdout, 161 | and stderr, yet select() does not work on these. select() only works on 162 | sockets on Win32. So for each redirected child handle, there is 163 | normally a "pumper" process that connects to the parent using a 164 | socket--so the parent can select() on that fd--and to the child on an 165 | anonymous pipe--so the child can read/write a pipe. 166 | 167 | Using a socket to connect directly to the child (as at least one MSDN 168 | article suggests) seems to cause the trailing output from most children 169 | to be lost. I think this is because child processes rarely close their 170 | stdout and stderr explicitly, and the winsock dll does not seem to flush 171 | output when a process that uses it exits without explicitly closing 172 | them. 173 | 174 | Because of these pumpers and the inherent slowness of Win32 175 | CreateProcess(), child processes with redirects are quite slow to 176 | launch; so this routine looks for the very common case of 177 | reading/writing to/from scalar references in a run() routine and 178 | converts such reads and writes in to temporary file reads and writes. 179 | 180 | Such files are marked as FILE_ATTRIBUTE_TEMPORARY to increase speed and 181 | as FILE_FLAG_DELETE_ON_CLOSE so it will be cleaned up when the child 182 | process exits (for input files). The user's default permissions are 183 | used for both the temporary files and the directory that contains them, 184 | hope your Win32 permissions are secure enough for you. Files are 185 | created with the Win32API::File defaults of 186 | FILE_SHARE_READ|FILE_SHARE_WRITE. 187 | 188 | Setting the debug level to "details" or "gory" will give detailed 189 | information about the optimization process; setting it to "basic" or 190 | higher will tell whether or not a given call is optimized. Setting 191 | it to "notopt" will highlight those calls that aren't optimized. 192 | 193 | =cut 194 | 195 | sub optimize { 196 | my ($h) = @_; 197 | 198 | my @kids = @{ $h->{KIDS} }; 199 | 200 | my $saw_pipe; 201 | 202 | my ( $ok_to_optimize_outputs, $veto_output_optimization ); 203 | 204 | for my $kid (@kids) { 205 | ( $ok_to_optimize_outputs, $veto_output_optimization ) = () 206 | unless $saw_pipe; 207 | 208 | _debug "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over ok of non-SCALAR output optimization" 209 | if _debugging_details && $ok_to_optimize_outputs; 210 | _debug "Win32 optimizer: (kid $kid->{NUM}) STDIN piped, carrying over veto of non-SCALAR output optimization" 211 | if _debugging_details && $veto_output_optimization; 212 | 213 | if ( $h->{noinherit} && !$ok_to_optimize_outputs ) { 214 | _debug "Win32 optimizer: (kid $kid->{NUM}) STDIN not inherited from parent oking non-SCALAR output optimization" 215 | if _debugging_details && $ok_to_optimize_outputs; 216 | $ok_to_optimize_outputs = 1; 217 | } 218 | 219 | for ( @{ $kid->{OPS} } ) { 220 | if ( substr( $_->{TYPE}, 0, 1 ) eq "<" ) { 221 | if ( $_->{TYPE} eq "<" ) { 222 | if ( @{ $_->{FILTERS} } > 1 ) { 223 | ## Can't assume that the filters are idempotent. 224 | } 225 | elsif (ref $_->{SOURCE} eq "SCALAR" 226 | || ref $_->{SOURCE} eq "GLOB" 227 | || UNIVERSAL::isa( $_, "IO::Handle" ) ) { 228 | if ( $_->{KFD} == 0 ) { 229 | _debug 230 | "Win32 optimizer: (kid $kid->{NUM}) 0$_->{TYPE}", 231 | ref $_->{SOURCE}, 232 | ", ok to optimize outputs" 233 | if _debugging_details; 234 | $ok_to_optimize_outputs = 1; 235 | } 236 | $_->{SEND_THROUGH_TEMP_FILE} = 1; 237 | next; 238 | } 239 | elsif ( !ref $_->{SOURCE} && defined $_->{SOURCE} ) { 240 | if ( $_->{KFD} == 0 ) { 241 | _debug 242 | "Win32 optimizer: (kid $kid->{NUM}) 0<$_->{SOURCE}, ok to optimize outputs", 243 | if _debugging_details; 244 | $ok_to_optimize_outputs = 1; 245 | } 246 | next; 247 | } 248 | } 249 | _debug 250 | "Win32 optimizer: (kid $kid->{NUM}) ", 251 | $_->{KFD}, 252 | $_->{TYPE}, 253 | defined $_->{SOURCE} 254 | ? ref $_->{SOURCE} 255 | ? ref $_->{SOURCE} 256 | : $_->{SOURCE} 257 | : defined $_->{FILENAME} ? $_->{FILENAME} 258 | : "", 259 | @{ $_->{FILTERS} } > 1 ? " with filters" : (), 260 | ", VETOING output opt." 261 | if _debugging_details || _debugging_not_optimized; 262 | $veto_output_optimization = 1; 263 | } 264 | elsif ( $_->{TYPE} eq "close" && $_->{KFD} == 0 ) { 265 | $ok_to_optimize_outputs = 1; 266 | _debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&-, ok to optimize outputs" 267 | if _debugging_details; 268 | } 269 | elsif ( $_->{TYPE} eq "dup" && $_->{KFD2} == 0 ) { 270 | $veto_output_optimization = 1; 271 | _debug "Win32 optimizer: (kid $kid->{NUM}) saw 0<&$_->{KFD2}, VETOING output opt." 272 | if _debugging_details || _debugging_not_optimized; 273 | } 274 | elsif ( $_->{TYPE} eq "|" ) { 275 | $saw_pipe = 1; 276 | } 277 | } 278 | 279 | if ( !$ok_to_optimize_outputs && !$veto_output_optimization ) { 280 | _debug "Win32 optimizer: (kid $kid->{NUM}) child STDIN not redirected, VETOING non-SCALAR output opt." 281 | if _debugging_details || _debugging_not_optimized; 282 | $veto_output_optimization = 1; 283 | } 284 | 285 | if ( $ok_to_optimize_outputs && $veto_output_optimization ) { 286 | $ok_to_optimize_outputs = 0; 287 | _debug "Win32 optimizer: (kid $kid->{NUM}) non-SCALAR output optimizations VETOed" 288 | if _debugging_details || _debugging_not_optimized; 289 | } 290 | 291 | ## SOURCE/DEST ARRAY means it's a filter. 292 | ## TODO: think about checking to see if the final input/output of 293 | ## a filter chain (an ARRAY SOURCE or DEST) is a scalar...but 294 | ## we may be deprecating filters. 295 | 296 | for ( @{ $kid->{OPS} } ) { 297 | if ( $_->{TYPE} eq ">" ) { 298 | if ( 299 | ref $_->{DEST} eq "SCALAR" 300 | || ( 301 | ( 302 | @{ $_->{FILTERS} } > 1 303 | || ref $_->{DEST} eq "CODE" 304 | || ref $_->{DEST} eq "ARRAY" ## Filters? 305 | ) 306 | && ( $ok_to_optimize_outputs && !$veto_output_optimization ) 307 | ) 308 | ) { 309 | $_->{RECV_THROUGH_TEMP_FILE} = 1; 310 | next; 311 | } 312 | _debug 313 | "Win32 optimizer: NOT optimizing (kid $kid->{NUM}) ", 314 | $_->{KFD}, 315 | $_->{TYPE}, 316 | defined $_->{DEST} 317 | ? ref $_->{DEST} 318 | ? ref $_->{DEST} 319 | : $_->{SOURCE} 320 | : defined $_->{FILENAME} ? $_->{FILENAME} 321 | : "", 322 | @{ $_->{FILTERS} } ? " with filters" : (), 323 | if _debugging_details; 324 | } 325 | } 326 | } 327 | 328 | } 329 | 330 | =pod 331 | 332 | =item win32_parse_cmd_line 333 | 334 | @words = win32_parse_cmd_line( q{foo bar 'baz baz' "bat bat"} ); 335 | 336 | returns 4 words. This parses like the bourne shell (see 337 | the bit about shellwords() in L), assuming we're 338 | trying to be a little cross-platform here. The only difference is 339 | that "\" is *not* treated as an escape except when it precedes 340 | punctuation, since it's used all over the place in DOS path specs. 341 | 342 | TODO: strip caret escapes? 343 | 344 | TODO: use 345 | https://docs.microsoft.com/en-us/cpp/cpp/main-function-command-line-args#parsing-c-command-line-arguments 346 | 347 | TODO: globbing? probably not (it's unDOSish). 348 | 349 | TODO: shebang emulation? Probably, but perhaps that should be part 350 | of Run.pm so all spawned processes get the benefit. 351 | 352 | LIMITATIONS: shellwords dies silently on malformed input like 353 | 354 | a\" 355 | 356 | =cut 357 | 358 | sub win32_parse_cmd_line { 359 | my $line = shift; 360 | $line =~ s{(\\[\w\s])}{\\$1}g; 361 | return shellwords $line; 362 | } 363 | 364 | =pod 365 | 366 | =item win32_spawn 367 | 368 | Spawns a child process, possibly with STDIN, STDOUT, and STDERR (file descriptors 0, 1, and 2, respectively) redirected. 369 | 370 | B. 371 | 372 | Cannot redirect higher file descriptors due to lack of support for this in the 373 | Win32 environment. 374 | 375 | This can be worked around by marking a handle as inheritable in the 376 | parent (or leaving it marked; this is the default in perl), obtaining its 377 | Win32 handle with C or 378 | C and passing it to the child using the command 379 | line, the environment, or any other IPC mechanism (it's a plain old integer). 380 | The child can then use C or C and possibly 381 | C<&BAR">> or C<&$fd>> as need be. Ach, the pain! 382 | 383 | =cut 384 | 385 | sub _save { 386 | my ( $saved, $saved_as, $fd ) = @_; 387 | 388 | ## We can only save aside the original fds once. 389 | return if exists $saved->{$fd}; 390 | 391 | my $saved_fd = IPC::Run::_dup($fd); 392 | _dont_inherit $saved_fd; 393 | 394 | $saved->{$fd} = $saved_fd; 395 | $saved_as->{$saved_fd} = $fd; 396 | 397 | _dont_inherit $saved->{$fd}; 398 | } 399 | 400 | sub _dup2_gently { 401 | my ( $saved, $saved_as, $fd1, $fd2 ) = @_; 402 | _save $saved, $saved_as, $fd2; 403 | 404 | if ( exists $saved_as->{$fd2} ) { 405 | ## The target fd is colliding with a saved-as fd, gotta bump 406 | ## the saved-as fd to another fd. 407 | my $orig_fd = delete $saved_as->{$fd2}; 408 | my $saved_fd = IPC::Run::_dup($fd2); 409 | _dont_inherit $saved_fd; 410 | 411 | $saved->{$orig_fd} = $saved_fd; 412 | $saved_as->{$saved_fd} = $orig_fd; 413 | } 414 | _debug "moving $fd1 to kid's $fd2" if _debugging_details; 415 | IPC::Run::_dup2_rudely( $fd1, $fd2 ); 416 | } 417 | 418 | sub win32_spawn { 419 | my ( $cmd, $ops ) = @_; 420 | 421 | my ( $app, $cmd_line ); 422 | my $need_pct = 0; 423 | if ( UNIVERSAL::isa( $cmd, 'IPC::Run::Win32Process' ) ) { 424 | $app = $cmd->{lpApplicationName}; 425 | $cmd_line = $cmd->{lpCommandLine}; 426 | } 427 | elsif ( $cmd->[0] !~ /\.(bat|cmd) *$/i ) { 428 | $app = $cmd->[0]; 429 | $cmd_line = Win32::ShellQuote::quote_native(@$cmd); 430 | } 431 | else { 432 | # Batch file, so follow the batch-specific guidance of 433 | # https://docs.microsoft.com/en-us/windows/win32/api/processthreadsapi/nf-processthreadsapi-createprocessa 434 | # There's no one true way to locate cmd.exe. In the unlikely event that 435 | # %COMSPEC% is missing, fall back on a Windows API. We could search 436 | # %PATH% like _wsystem() does. That would be prone to security bugs, 437 | # and one fallback is enough. 438 | $app = ( 439 | $ENV{COMSPEC} 440 | || File::Spec->catfile( 441 | Win32::GetFolderPath(Win32::CSIDL_SYSTEM), 442 | 'cmd.exe' 443 | ) 444 | ); 445 | 446 | # Win32 rejects attempts to create files with names containing certain 447 | # characters. Ignore most, but reject the subset that might otherwise 448 | # cause us to execute the wrong file instead of failing cleanly. 449 | if ( $cmd->[0] =~ /["\r\n\0]/ ) { 450 | croak "invalid batch file name"; 451 | } 452 | 453 | # Make cmd.exe see the batch file name as quoted. Suppose we instead 454 | # used caret escapes, as we do for arguments. cmd.exe could then "break 455 | # the command token at the first occurrence of , ; or =" 456 | # (https://stackoverflow.com/a/4095133). 457 | my @parts = qq{"$cmd->[0]"}; 458 | 459 | # cmd.exe will strip escapes once when parsing our $cmd_line and again 460 | # where the batch file injects the argument via %*, %1, etc. Compensate 461 | # by adding one extra cmd_escape layer. 462 | if ( @$cmd > 1 ) { 463 | my @q = Win32::ShellQuote::quote_cmd( @{$cmd}[ 1 .. $#{$cmd} ] ); 464 | push @parts, map { Win32::ShellQuote::cmd_escape($_) } @q; 465 | } 466 | 467 | # One can't stop cmd.exe from expanding %var%, so inject each literal % 468 | # via an environment variable. Delete that variable before the real 469 | # child can see it. See 470 | # https://www.dostips.com/forum/viewtopic.php?f=3&t=10131 for more on 471 | # this technique and the limitations of alternatives. 472 | $cmd_line = join ' ', @parts; 473 | if ( $cmd_line =~ s/%/%ipcrunpct%/g ) { 474 | $cmd_line = qq{/c "set "ipcrunpct=" & $cmd_line"}; 475 | $need_pct = 1; 476 | } 477 | else { 478 | $cmd_line = qq{/c "$cmd_line"}; 479 | } 480 | } 481 | _debug "app: ", $app 482 | if _debugging; 483 | _debug "cmd line: ", $cmd_line 484 | if _debugging; 485 | 486 | ## NOTE: The debug pipe write handle is passed to pump processes as STDOUT. 487 | ## and is not to the "real" child process, since they would not know 488 | ## what to do with it...unlike Unix, we have no code executing in the 489 | ## child before the "real" child is exec()ed. 490 | 491 | my %saved; ## Map of parent's orig fd -> saved fd 492 | my %saved_as; ## Map of parent's saved fd -> orig fd, used to 493 | ## detect collisions between a KFD and the fd a 494 | ## parent's fd happened to be saved to. 495 | 496 | for my $op (@$ops) { 497 | _dont_inherit $op->{FD} if defined $op->{FD}; 498 | 499 | if ( defined $op->{KFD} && $op->{KFD} > 2 ) { 500 | ## TODO: Detect this in harness() 501 | ## TODO: enable temporary redirections if ever necessary, not 502 | ## sure why they would be... 503 | ## 4>&1 1>/dev/null 1>&4 4>&- 504 | croak "Can't redirect fd #", $op->{KFD}, " on Win32"; 505 | } 506 | 507 | ## This is very similar logic to IPC::Run::_do_kid_and_exit(). 508 | if ( defined $op->{TFD} ) { 509 | unless ( $op->{TFD} == $op->{KFD} ) { 510 | _dup2_gently \%saved, \%saved_as, $op->{TFD}, $op->{KFD}; 511 | _dont_inherit $op->{TFD}; 512 | } 513 | } 514 | elsif ( $op->{TYPE} eq "dup" ) { 515 | _dup2_gently \%saved, \%saved_as, $op->{KFD1}, $op->{KFD2} 516 | unless $op->{KFD1} == $op->{KFD2}; 517 | } 518 | elsif ( $op->{TYPE} eq "close" ) { 519 | _save \%saved, \%saved_as, $op->{KFD}; 520 | IPC::Run::_close( $op->{KFD} ); 521 | } 522 | elsif ( $op->{TYPE} eq "init" ) { 523 | ## TODO: detect this in harness() 524 | croak "init subs not allowed on Win32"; 525 | } 526 | } 527 | 528 | local $ENV{ipcrunpct} = '%' if $need_pct; 529 | my $process; 530 | Win32::Process::Create( 531 | $process, 532 | $app, 533 | $cmd_line, 534 | 1, ## Inherit handles 535 | 0, ## Inherit parent priority class. Was NORMAL_PRIORITY_CLASS 536 | ".", 537 | ) 538 | or do { 539 | my $err = Win32::FormatMessage( Win32::GetLastError() ); 540 | $err =~ s/\r?\n$//s; 541 | croak "$err: Win32::Process::Create()"; 542 | }; 543 | 544 | for my $orig_fd ( keys %saved ) { 545 | IPC::Run::_dup2_rudely( $saved{$orig_fd}, $orig_fd ); 546 | IPC::Run::_close( $saved{$orig_fd} ); 547 | } 548 | 549 | return ( $process->GetProcessID(), $process ); 550 | } 551 | 552 | 1; 553 | 554 | =pod 555 | 556 | =back 557 | 558 | =head1 AUTHOR 559 | 560 | Barries Slaymaker . Funded by Perforce Software, Inc. 561 | 562 | =head1 COPYRIGHT 563 | 564 | Copyright 2001, Barrie Slaymaker, All Rights Reserved. 565 | 566 | You may use this under the terms of either the GPL 2.0 or the Artistic License. 567 | 568 | =cut 569 | --------------------------------------------------------------------------------