1 ## IPC::Cmd test suite ###
3 BEGIN { chdir 't' if -d 't' };
8 use Test::More 'no_plan';
10 my $Class = 'IPC::Cmd';
11 my $AClass = $Class . '::TimeOut';
12 my @Funcs = qw[run can_run QUOTE run_forked];
13 my @Meths = qw[can_use_ipc_run can_use_ipc_open3 can_capture_buffer can_use_run_forked];
14 my $IsWin32 = $^O eq 'MSWin32';
15 my $Verbose = @ARGV ? 1 : 0;
17 use_ok( $Class, $_ ) for @Funcs;
18 can_ok( $Class, $_ ) for @Funcs, @Meths;
19 can_ok( __PACKAGE__, $_ ) for @Funcs;
21 my $Have_IPC_Run = $Class->can_use_ipc_run || 0;
22 my $Have_IPC_Open3 = $Class->can_use_ipc_open3 || 0;
24 diag("IPC::Run: $Have_IPC_Run IPC::Open3: $Have_IPC_Open3")
25 unless exists $ENV{'PERL_CORE'};
27 local $IPC::Cmd::VERBOSE = $Verbose;
28 local $IPC::Cmd::VERBOSE = $Verbose;
29 local $IPC::Cmd::DEBUG = $Verbose;
30 local $IPC::Cmd::DEBUG = $Verbose;
33 ### run tests in various configurations, based on what modules we have
35 push @Prefs, [ $Have_IPC_Run, $Have_IPC_Open3 ] if $Have_IPC_Run;
37 ### run this config twice to ensure FD restores work properly
38 push @Prefs, [ 0, $Have_IPC_Open3 ],
39 [ 0, $Have_IPC_Open3 ] if $Have_IPC_Open3;
41 ### run this config twice to ensure FD restores work properly
42 ### these are the system() tests;
43 push @Prefs, [ 0, 0 ], [ 0, 0 ];
48 ok( can_run("$^X"), q[Found 'perl' in your path] );
49 ok( !can_run('10283lkjfdalskfjaf'), q[Not found non-existent binary] );
52 { ### list of commands and regexes matching output
53 ### XXX use " everywhere when using literal strings as commands for
54 ### portability, especially on win32
56 # command # output regex # buffer
58 ### run tests that print only to stdout
59 [ "$^X -v", qr/larry\s+wall/i, 3, ],
60 [ [$^X, '-v'], qr/larry\s+wall/i, 3, ],
63 [ "$^X -eprint+424 | $^X -neprint+split+2", qr/44/, 3, ],
64 [ [$^X,qw[-eprint+424 |], $^X, qw|-neprint+split+2|],
67 [ [$^X, '-eprint+shift', q|a b a|], qr/a b a/, 3, ],
68 [ qq[$^X -eprint+shift "a b a"], qr/a b a/, 3, ],
71 [ [$^X, '-eprint+shift', q|a b a|, q[|], $^X, qw[-neprint+split+b] ],
73 [ qq[$^X -eprint+shift "a b a" | $^X -neprint+split+b],
76 ### run tests that print only to stderr
77 [ "$^X -ewarn+42", qr/^42 /, 4, ],
78 [ [$^X, '-ewarn+42'], qr/^42 /, 4, ],
81 ### extended test in developer mode
82 ### test if gzip | tar works
84 my $gzip = can_run('gzip');
85 my $tar = can_run('tar');
87 if( $gzip and $tar ) {
89 [ [$gzip, qw[-cdf src/x.tgz |], $tar, qw[-tf -]],
94 ### for each configuration
95 for my $pref ( @Prefs ) {
97 local $IPC::Cmd::USE_IPC_RUN = !!$pref->[0];
98 local $IPC::Cmd::USE_IPC_RUN = !!$pref->[0];
99 local $IPC::Cmd::USE_IPC_OPEN3 = !!$pref->[1];
100 local $IPC::Cmd::USE_IPC_OPEN3 = !!$pref->[1];
103 for my $aref ( @$map ) {
104 my $cmd = $aref->[0];
105 my $regex = $aref->[1];
106 my $index = $aref->[2];
108 my $pp_cmd = ref $cmd ? "Array: @$cmd" : "Scalar: $cmd";
109 $pp_cmd .= " (IPC::Run: $pref->[0] IPC::Open3: $pref->[1])";
111 diag( "Running '$pp_cmd'") if $Verbose;
115 my $ok = run( command => $cmd, buffer => \$buffer );
117 ok( $ok, "Ran '$pp_cmd' command successfully" );
120 skip "No buffers available", 1
121 unless $Class->can_capture_buffer;
123 like( $buffer, $regex,
124 " Buffer matches $regex -- ($pp_cmd)" );
129 { diag( "Running list mode" ) if $Verbose;
130 my @list = run( command => $cmd );
132 ok( $list[0], "Ran '$pp_cmd' successfully" );
133 ok( !$list[1], " No error code set -- ($pp_cmd)" );
135 my $list_length = $Class->can_capture_buffer ? 5 : 2;
136 is( scalar(@list), $list_length,
137 " Output list has $list_length entries -- ($pp_cmd)" );
140 skip "No buffers available", 6
141 unless $Class->can_capture_buffer;
143 ### the last 3 entries from the RV, are they array refs?
144 isa_ok( $list[$_], 'ARRAY' ) for 2..4;
146 like( "@{$list[2]}", $regex,
147 " Combined buffer matches $regex -- ($pp_cmd)" );
149 like( "@{$list[$index]}", qr/$regex/,
150 " Proper buffer($index) matches $regex -- ($pp_cmd)" );
151 is( scalar( @{$list[ $index==3 ? 4 : 3 ]} ), 0,
152 " Other buffer empty -- ($pp_cmd)" );
159 unless ( IPC::Cmd->can_use_run_forked ) {
160 ok(1, "run_forked not available on this platform");
165 my $cmd = "echo out ; echo err >&2 ; sleep 4";
166 my $r = run_forked($cmd, {'timeout' => 1});
168 ok(ref($r) eq 'HASH', "executed: $cmd");
169 ok($r->{'timeout'} eq 1, "timed out");
170 ok($r->{'stdout'}, "stdout: " . $r->{'stdout'});
171 ok($r->{'stderr'}, "stderr: " . $r->{'stderr'});
175 # try discarding the out+err
178 my $cmd = "echo out ; echo err >&2";
181 { discard_output => 1,
182 stderr_handler => sub { $out .= shift },
183 stdout_handler => sub { $out .= shift }
186 ok(ref($r) eq 'HASH', "executed: $cmd");
187 ok(!$r->{'stdout'}, "stdout discarded");
188 ok(!$r->{'stderr'}, "stderr discarded");
189 ok($out =~ m/out/, "stdout handled");
190 ok($out =~ m/err/, "stderr handled");
195 ### special call to check that output is interleaved properly
196 { my $cmd = [$^X, File::Spec->catfile( qw[src output.pl] ) ];
198 ### for each configuration
199 for my $pref ( @Prefs ) {
200 diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
203 local $IPC::Cmd::USE_IPC_RUN = $pref->[0];
204 local $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1];
206 my @list = run( command => $cmd, buffer => \my $buffer );
207 ok( $list[0], "Ran @{$cmd} successfully" );
208 ok( !$list[1], " No errorcode set" );
210 skip "No buffers available", 3 unless $Class->can_capture_buffer;
213 local $TODO = qq[Can't interleave input/output buffers yet];
215 is( "@{$list[2]}",'1 2 3 4'," Combined output as expected" );
216 is( "@{$list[3]}", '1 3', " STDOUT as expected" );
217 is( "@{$list[4]}", '2 4', " STDERR as expected" );
227 { ### for each configuration
228 for my $pref ( @Prefs ) {
229 diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
232 local $IPC::Cmd::USE_IPC_RUN = $pref->[0];
233 local $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1];
235 my ($ok,$err) = run( command => "$^X -edie" );
236 ok( !$ok, "Non-zero exit caught" );
237 ok( $err, " Error '$err'" );
243 for my $pref ( @Prefs ) {
244 diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
247 local $IPC::Cmd::USE_IPC_RUN = $pref->[0];
248 local $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1];
250 ### -X to quiet the 'sleep without parens is ambiguous' warning
251 my ($ok,$err) = run( command => "$^X -Xesleep+4", timeout => $timeout );
252 ok( !$ok, "Timeout caught" );
253 ok( $err, " Error stored" );
254 ok( not(ref($err)), " Error string is not a reference" );
255 like( $err,qr/^$AClass/," Error '$err' mentions $AClass" );