This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix typos (spelling errors) in cpan/IPC-Cmd/*.
[perl5.git] / cpan / IPC-Cmd / t / 01_IPC-Cmd.t
1 ## IPC::Cmd test suite ###
2
3 BEGIN { chdir 't' if -d 't' };
4
5 use strict;
6 use lib qw[../lib];
7 use File::Spec;
8 use Test::More 'no_plan';
9
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;
16
17 use_ok( $Class,         $_ ) for @Funcs;
18 can_ok( $Class,         $_ ) for @Funcs, @Meths;
19 can_ok( __PACKAGE__,    $_ ) for @Funcs;
20
21 my $Have_IPC_Run    = $Class->can_use_ipc_run   || 0;
22 my $Have_IPC_Open3  = $Class->can_use_ipc_open3 || 0;
23
24 diag("IPC::Run: $Have_IPC_Run   IPC::Open3: $Have_IPC_Open3")
25     unless exists $ENV{'PERL_CORE'};
26
27 local $IPC::Cmd::VERBOSE = $Verbose;
28 local $IPC::Cmd::VERBOSE = $Verbose;
29 local $IPC::Cmd::DEBUG   = $Verbose;
30 local $IPC::Cmd::DEBUG   = $Verbose;
31
32
33 ### run tests in various configurations, based on what modules we have
34 my @Prefs = ( );
35 push @Prefs, [ $Have_IPC_Run, $Have_IPC_Open3 ] if $Have_IPC_Run; 
36
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;
40
41 ### run this config twice to ensure FD restores work properly
42 ### these are the system() tests;
43 push @Prefs, [ 0,             0 ],  [ 0,             0 ];     
44
45
46 ### can_run tests
47 {
48     ok( can_run("$^X"),                q[Found 'perl' in your path] );
49     ok( !can_run('10283lkjfdalskfjaf'), q[Not found non-existent binary] );
50 }
51
52 {   ### list of commands and regexes matching output 
53     ### XXX use " everywhere when using literal strings as commands for
54     ### portability, especially on win32
55     my $map = [
56         # command                                    # output regex     # buffer
57
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, ],
61
62         ### pipes
63         [ "$^X -eprint+424 | $^X -neprint+split+2",  qr/44/,            3, ],
64         [ [$^X,qw[-eprint+424 |], $^X, qw|-neprint+split+2|], 
65                                                      qr/44/,            3, ],
66         ### whitespace
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, ],
69
70         ### whitespace + pipe
71         [ [$^X, '-eprint+shift', q|a b a|, q[|], $^X, qw[-neprint+split+b] ],
72                                                      qr/a  a/,          3, ],
73         [ qq[$^X -eprint+shift "a b a" | $^X -neprint+split+b],
74                                                      qr/a  a/,          3, ],
75
76         ### run tests that print only to stderr
77         [ "$^X -ewarn+42",                           qr/^42 /,          4, ],
78         [ [$^X, '-ewarn+42'],                        qr/^42 /,          4, ],
79     ];
80
81     ### extended test in developer mode
82     ### test if gzip | tar works
83     if( $Verbose ) {   
84         my $gzip = can_run('gzip');
85         my $tar  = can_run('tar');
86         
87         if( $gzip and $tar ) {
88             push @$map,
89                 [ [$gzip, qw[-cdf src/x.tgz |], $tar, qw[-tf -]],     
90                                                        qr/a/,           3, ];
91         }
92     }        
93
94     ### for each configuration
95     for my $pref ( @Prefs ) {
96
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];
101
102         ### for each command
103         for my $aref ( @$map ) {
104             my $cmd    = $aref->[0];
105             my $regex  = $aref->[1];
106             my $index  = $aref->[2];
107
108             my $pp_cmd = ref $cmd ? "Array: @$cmd" : "Scalar: $cmd";
109             $pp_cmd .= " (IPC::Run: $pref->[0] IPC::Open3: $pref->[1])";
110
111             diag( "Running '$pp_cmd'") if $Verbose;
112
113             ### in scalar mode
114             {   my $buffer;
115                 my $ok = run( command => $cmd, buffer => \$buffer );
116
117                 ok( $ok,        "Ran '$pp_cmd' command successfully" );
118                 
119                 SKIP: {
120                     skip "No buffers available", 1 
121                                 unless $Class->can_capture_buffer;
122                     
123                     like( $buffer, $regex,  
124                                 "   Buffer matches $regex -- ($pp_cmd)" );
125                 }
126             }
127                 
128             ### in list mode                
129             {   diag( "Running list mode" ) if $Verbose;
130                 my @list = run( command => $cmd );
131
132                 ok( $list[0],   "Ran '$pp_cmd' successfully" );
133                 ok( !$list[1],  "   No error code set -- ($pp_cmd)" );
134
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)" );
138
139                 SKIP: {
140                     skip "No buffers available", 6 
141                                 unless $Class->can_capture_buffer;
142                     
143                     ### the last 3 entries from the RV, are they array refs?
144                     isa_ok( $list[$_], 'ARRAY' ) for 2..4;
145
146                     like( "@{$list[2]}", $regex,
147                                 "   Combined buffer matches $regex -- ($pp_cmd)" );
148
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)" );
153                 }
154             }
155         }
156     }
157 }
158
159 unless ( IPC::Cmd->can_use_run_forked ) {
160   ok(1, "run_forked not available on this platform");
161   exit;
162 }
163
164 {
165   my $cmd = "echo out ; echo err >&2 ; sleep 4";
166   my $r = run_forked($cmd, {'timeout' => 1});
167
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'});
172 }
173
174
175 # try discarding the out+err
176 {
177   my $out;
178   my $cmd = "echo out ; echo err >&2";
179   my $r = run_forked(
180         $cmd,
181     {   discard_output => 1,
182         stderr_handler => sub { $out .= shift },
183         stdout_handler => sub { $out .= shift }
184     });
185
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");
191 }
192
193     
194 __END__
195 ### special call to check that output is interleaved properly
196 {   my $cmd     = [$^X, File::Spec->catfile( qw[src output.pl] ) ];
197
198     ### for each configuration
199     for my $pref ( @Prefs ) {
200         diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
201             if $Verbose;
202
203         local $IPC::Cmd::USE_IPC_RUN    = $pref->[0];
204         local $IPC::Cmd::USE_IPC_OPEN3  = $pref->[1];
205
206         my @list    = run( command => $cmd, buffer => \my $buffer );
207         ok( $list[0],                   "Ran @{$cmd} successfully" );
208         ok( !$list[1],                  "   No errorcode set" );
209         SKIP: {
210             skip "No buffers available", 3 unless $Class->can_capture_buffer;
211
212             TODO: {
213                 local $TODO = qq[Can't interleave input/output buffers yet];
214
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" );
218             
219             }
220         }
221     }        
222 }
223
224
225
226 ### test failures
227 {   ### for each configuration
228     for my $pref ( @Prefs ) {
229         diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
230             if $Verbose;
231
232         local $IPC::Cmd::USE_IPC_RUN    = $pref->[0];
233         local $IPC::Cmd::USE_IPC_OPEN3  = $pref->[1];
234
235         my ($ok,$err) = run( command => "$^X -edie" );
236         ok( !$ok,               "Non-zero exit caught" );
237         ok( $err,               "   Error '$err'" );
238     }
239 }   
240
241 ### timeout tests
242 {   my $timeout = 1;
243     for my $pref ( @Prefs ) {
244         diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
245             if $Verbose;
246
247         local $IPC::Cmd::USE_IPC_RUN    = $pref->[0];
248         local $IPC::Cmd::USE_IPC_OPEN3  = $pref->[1];
249
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" );
256     }
257 }    
258