1b39c5158Smillert## IPC::Cmd test suite ### 2b39c5158Smillert 3b39c5158SmillertBEGIN { chdir 't' if -d 't' }; 4b39c5158Smillert 5b39c5158Smillertuse strict; 6b39c5158Smillertuse lib qw[../lib]; 7b39c5158Smillertuse File::Spec; 8b39c5158Smillertuse Test::More 'no_plan'; 9b39c5158Smillert 10b39c5158Smillertmy $Class = 'IPC::Cmd'; 11b39c5158Smillertmy $AClass = $Class . '::TimeOut'; 12b39c5158Smillertmy @Funcs = qw[run can_run QUOTE run_forked]; 13b39c5158Smillertmy @Meths = qw[can_use_ipc_run can_use_ipc_open3 can_capture_buffer can_use_run_forked]; 14b39c5158Smillertmy $IsWin32 = $^O eq 'MSWin32'; 15b39c5158Smillertmy $Verbose = @ARGV ? 1 : 0; 16b39c5158Smillert 17b39c5158Smillertuse_ok( $Class, $_ ) for @Funcs; 18b39c5158Smillertcan_ok( $Class, $_ ) for @Funcs, @Meths; 19b39c5158Smillertcan_ok( __PACKAGE__, $_ ) for @Funcs; 20b39c5158Smillert 21b39c5158Smillertmy $Have_IPC_Run = $Class->can_use_ipc_run || 0; 22b39c5158Smillertmy $Have_IPC_Open3 = $Class->can_use_ipc_open3 || 0; 23b39c5158Smillert 24b39c5158Smillertdiag("IPC::Run: $Have_IPC_Run IPC::Open3: $Have_IPC_Open3") 25b39c5158Smillert unless exists $ENV{'PERL_CORE'}; 26b39c5158Smillert 27b39c5158Smillertlocal $IPC::Cmd::VERBOSE = $Verbose; 28b39c5158Smillertlocal $IPC::Cmd::VERBOSE = $Verbose; 29b39c5158Smillertlocal $IPC::Cmd::DEBUG = $Verbose; 30b39c5158Smillertlocal $IPC::Cmd::DEBUG = $Verbose; 31b39c5158Smillert 32b39c5158Smillert 33b39c5158Smillert### run tests in various configurations, based on what modules we have 34b39c5158Smillertmy @Prefs = ( ); 35b39c5158Smillertpush @Prefs, [ $Have_IPC_Run, $Have_IPC_Open3 ] if $Have_IPC_Run; 36b39c5158Smillert 37b39c5158Smillert### run this config twice to ensure FD restores work properly 38b39c5158Smillertpush @Prefs, [ 0, $Have_IPC_Open3 ], 39b39c5158Smillert [ 0, $Have_IPC_Open3 ] if $Have_IPC_Open3; 40b39c5158Smillert 41b39c5158Smillert### run this config twice to ensure FD restores work properly 42b39c5158Smillert### these are the system() tests; 43b39c5158Smillertpush @Prefs, [ 0, 0 ], [ 0, 0 ]; 44b39c5158Smillert 45b39c5158Smillert 46b39c5158Smillert### can_run tests 47b39c5158Smillert{ 48b39c5158Smillert ok( can_run("$^X"), q[Found 'perl' in your path] ); 49*898184e3Ssthen ok( !can_run('10283lkjfdalskfjaf'), q[Not found non-existent binary] ); 50b39c5158Smillert} 51b39c5158Smillert 52b39c5158Smillert{ ### list of commands and regexes matching output 53b39c5158Smillert ### XXX use " everywhere when using literal strings as commands for 54b39c5158Smillert ### portability, especially on win32 55b39c5158Smillert my $map = [ 56b39c5158Smillert # command # output regex # buffer 57b39c5158Smillert 58b39c5158Smillert ### run tests that print only to stdout 59b39c5158Smillert [ "$^X -v", qr/larry\s+wall/i, 3, ], 60b39c5158Smillert [ [$^X, '-v'], qr/larry\s+wall/i, 3, ], 61b39c5158Smillert 62b39c5158Smillert ### pipes 63b39c5158Smillert [ "$^X -eprint+424 | $^X -neprint+split+2", qr/44/, 3, ], 64b39c5158Smillert [ [$^X,qw[-eprint+424 |], $^X, qw|-neprint+split+2|], 65b39c5158Smillert qr/44/, 3, ], 66b39c5158Smillert ### whitespace 67b39c5158Smillert [ [$^X, '-eprint+shift', q|a b a|], qr/a b a/, 3, ], 68b39c5158Smillert [ qq[$^X -eprint+shift "a b a"], qr/a b a/, 3, ], 69b39c5158Smillert 70b39c5158Smillert ### whitespace + pipe 71b39c5158Smillert [ [$^X, '-eprint+shift', q|a b a|, q[|], $^X, qw[-neprint+split+b] ], 72b39c5158Smillert qr/a a/, 3, ], 73b39c5158Smillert [ qq[$^X -eprint+shift "a b a" | $^X -neprint+split+b], 74b39c5158Smillert qr/a a/, 3, ], 75b39c5158Smillert 76b39c5158Smillert ### run tests that print only to stderr 77b39c5158Smillert [ "$^X -ewarn+42", qr/^42 /, 4, ], 78b39c5158Smillert [ [$^X, '-ewarn+42'], qr/^42 /, 4, ], 79b39c5158Smillert ]; 80b39c5158Smillert 81b39c5158Smillert ### extended test in developer mode 82b39c5158Smillert ### test if gzip | tar works 83b39c5158Smillert if( $Verbose ) { 84b39c5158Smillert my $gzip = can_run('gzip'); 85b39c5158Smillert my $tar = can_run('tar'); 86b39c5158Smillert 87b39c5158Smillert if( $gzip and $tar ) { 88b39c5158Smillert push @$map, 89b39c5158Smillert [ [$gzip, qw[-cdf src/x.tgz |], $tar, qw[-tf -]], 90b39c5158Smillert qr/a/, 3, ]; 91b39c5158Smillert } 92b39c5158Smillert } 93b39c5158Smillert 94*898184e3Ssthen ### for each configuration 95b39c5158Smillert for my $pref ( @Prefs ) { 96b39c5158Smillert 97b39c5158Smillert local $IPC::Cmd::USE_IPC_RUN = !!$pref->[0]; 98b39c5158Smillert local $IPC::Cmd::USE_IPC_RUN = !!$pref->[0]; 99b39c5158Smillert local $IPC::Cmd::USE_IPC_OPEN3 = !!$pref->[1]; 100b39c5158Smillert local $IPC::Cmd::USE_IPC_OPEN3 = !!$pref->[1]; 101b39c5158Smillert 102b39c5158Smillert ### for each command 103b39c5158Smillert for my $aref ( @$map ) { 104b39c5158Smillert my $cmd = $aref->[0]; 105b39c5158Smillert my $regex = $aref->[1]; 106b39c5158Smillert my $index = $aref->[2]; 107b39c5158Smillert 108b39c5158Smillert my $pp_cmd = ref $cmd ? "Array: @$cmd" : "Scalar: $cmd"; 109b39c5158Smillert $pp_cmd .= " (IPC::Run: $pref->[0] IPC::Open3: $pref->[1])"; 110b39c5158Smillert 111b39c5158Smillert diag( "Running '$pp_cmd'") if $Verbose; 112b39c5158Smillert 113b39c5158Smillert ### in scalar mode 114b39c5158Smillert { my $buffer; 115b39c5158Smillert my $ok = run( command => $cmd, buffer => \$buffer ); 116b39c5158Smillert 117*898184e3Ssthen ok( $ok, "Ran '$pp_cmd' command successfully" ); 118b39c5158Smillert 119b39c5158Smillert SKIP: { 120b39c5158Smillert skip "No buffers available", 1 121b39c5158Smillert unless $Class->can_capture_buffer; 122b39c5158Smillert 123b39c5158Smillert like( $buffer, $regex, 124b39c5158Smillert " Buffer matches $regex -- ($pp_cmd)" ); 125b39c5158Smillert } 126b39c5158Smillert } 127b39c5158Smillert 128b39c5158Smillert ### in list mode 129b39c5158Smillert { diag( "Running list mode" ) if $Verbose; 130b39c5158Smillert my @list = run( command => $cmd ); 131b39c5158Smillert 132b39c5158Smillert ok( $list[0], "Ran '$pp_cmd' successfully" ); 133b39c5158Smillert ok( !$list[1], " No error code set -- ($pp_cmd)" ); 134b39c5158Smillert 135b39c5158Smillert my $list_length = $Class->can_capture_buffer ? 5 : 2; 136b39c5158Smillert is( scalar(@list), $list_length, 137b39c5158Smillert " Output list has $list_length entries -- ($pp_cmd)" ); 138b39c5158Smillert 139b39c5158Smillert SKIP: { 140b39c5158Smillert skip "No buffers available", 6 141b39c5158Smillert unless $Class->can_capture_buffer; 142b39c5158Smillert 143b39c5158Smillert ### the last 3 entries from the RV, are they array refs? 144b39c5158Smillert isa_ok( $list[$_], 'ARRAY' ) for 2..4; 145b39c5158Smillert 146b39c5158Smillert like( "@{$list[2]}", $regex, 147b39c5158Smillert " Combined buffer matches $regex -- ($pp_cmd)" ); 148b39c5158Smillert 149b39c5158Smillert like( "@{$list[$index]}", qr/$regex/, 150b39c5158Smillert " Proper buffer($index) matches $regex -- ($pp_cmd)" ); 151b39c5158Smillert is( scalar( @{$list[ $index==3 ? 4 : 3 ]} ), 0, 152b39c5158Smillert " Other buffer empty -- ($pp_cmd)" ); 153b39c5158Smillert } 154b39c5158Smillert } 155b39c5158Smillert } 156b39c5158Smillert } 157b39c5158Smillert} 158b39c5158Smillert 159b39c5158Smillertunless ( IPC::Cmd->can_use_run_forked ) { 160b39c5158Smillert ok(1, "run_forked not available on this platform"); 161b39c5158Smillert exit; 162b39c5158Smillert} 163b39c5158Smillert 164b39c5158Smillert{ 165b39c5158Smillert my $cmd = "echo out ; echo err >&2 ; sleep 4"; 166b39c5158Smillert my $r = run_forked($cmd, {'timeout' => 1}); 167b39c5158Smillert 168b39c5158Smillert ok(ref($r) eq 'HASH', "executed: $cmd"); 169b39c5158Smillert ok($r->{'timeout'} eq 1, "timed out"); 170b39c5158Smillert ok($r->{'stdout'}, "stdout: " . $r->{'stdout'}); 171b39c5158Smillert ok($r->{'stderr'}, "stderr: " . $r->{'stderr'}); 172b39c5158Smillert} 173b39c5158Smillert 174b39c5158Smillert 175*898184e3Ssthen# try discarding the out+err 176*898184e3Ssthen{ 177*898184e3Ssthen my $out; 178*898184e3Ssthen my $cmd = "echo out ; echo err >&2"; 179*898184e3Ssthen my $r = run_forked( 180*898184e3Ssthen $cmd, 181*898184e3Ssthen { discard_output => 1, 182*898184e3Ssthen stderr_handler => sub { $out .= shift }, 183*898184e3Ssthen stdout_handler => sub { $out .= shift } 184*898184e3Ssthen }); 185*898184e3Ssthen 186*898184e3Ssthen ok(ref($r) eq 'HASH', "executed: $cmd"); 187*898184e3Ssthen ok(!$r->{'stdout'}, "stdout discarded"); 188*898184e3Ssthen ok(!$r->{'stderr'}, "stderr discarded"); 189*898184e3Ssthen ok($out =~ m/out/, "stdout handled"); 190*898184e3Ssthen ok($out =~ m/err/, "stderr handled"); 191*898184e3Ssthen} 192*898184e3Ssthen 193*898184e3Ssthen 194b39c5158Smillert__END__ 195b39c5158Smillert### special call to check that output is interleaved properly 196b39c5158Smillert{ my $cmd = [$^X, File::Spec->catfile( qw[src output.pl] ) ]; 197b39c5158Smillert 198*898184e3Ssthen ### for each configuration 199b39c5158Smillert for my $pref ( @Prefs ) { 200b39c5158Smillert diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" ) 201b39c5158Smillert if $Verbose; 202b39c5158Smillert 203b39c5158Smillert local $IPC::Cmd::USE_IPC_RUN = $pref->[0]; 204b39c5158Smillert local $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1]; 205b39c5158Smillert 206b39c5158Smillert my @list = run( command => $cmd, buffer => \my $buffer ); 207b39c5158Smillert ok( $list[0], "Ran @{$cmd} successfully" ); 208b39c5158Smillert ok( !$list[1], " No errorcode set" ); 209b39c5158Smillert SKIP: { 210b39c5158Smillert skip "No buffers available", 3 unless $Class->can_capture_buffer; 211b39c5158Smillert 212b39c5158Smillert TODO: { 213b39c5158Smillert local $TODO = qq[Can't interleave input/output buffers yet]; 214b39c5158Smillert 215b39c5158Smillert is( "@{$list[2]}",'1 2 3 4'," Combined output as expected" ); 216b39c5158Smillert is( "@{$list[3]}", '1 3', " STDOUT as expected" ); 217b39c5158Smillert is( "@{$list[4]}", '2 4', " STDERR as expected" ); 218b39c5158Smillert 219b39c5158Smillert } 220b39c5158Smillert } 221b39c5158Smillert } 222b39c5158Smillert} 223b39c5158Smillert 224b39c5158Smillert 225b39c5158Smillert 226b39c5158Smillert### test failures 227*898184e3Ssthen{ ### for each configuration 228b39c5158Smillert for my $pref ( @Prefs ) { 229b39c5158Smillert diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" ) 230b39c5158Smillert if $Verbose; 231b39c5158Smillert 232b39c5158Smillert local $IPC::Cmd::USE_IPC_RUN = $pref->[0]; 233b39c5158Smillert local $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1]; 234b39c5158Smillert 235b39c5158Smillert my ($ok,$err) = run( command => "$^X -edie" ); 236b39c5158Smillert ok( !$ok, "Non-zero exit caught" ); 237b39c5158Smillert ok( $err, " Error '$err'" ); 238b39c5158Smillert } 239b39c5158Smillert} 240b39c5158Smillert 241b39c5158Smillert### timeout tests 242b39c5158Smillert{ my $timeout = 1; 243b39c5158Smillert for my $pref ( @Prefs ) { 244b39c5158Smillert diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" ) 245b39c5158Smillert if $Verbose; 246b39c5158Smillert 247b39c5158Smillert local $IPC::Cmd::USE_IPC_RUN = $pref->[0]; 248b39c5158Smillert local $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1]; 249b39c5158Smillert 250b39c5158Smillert ### -X to quiet the 'sleep without parens is ambiguous' warning 251b39c5158Smillert my ($ok,$err) = run( command => "$^X -Xesleep+4", timeout => $timeout ); 252b39c5158Smillert ok( !$ok, "Timeout caught" ); 253b39c5158Smillert ok( $err, " Error stored" ); 254b39c5158Smillert ok( not(ref($err)), " Error string is not a reference" ); 255b39c5158Smillert like( $err,qr/^$AClass/," Error '$err' mentions $AClass" ); 256b39c5158Smillert } 257b39c5158Smillert} 258b39c5158Smillert 259