xref: /openbsd-src/gnu/usr.bin/perl/cpan/IPC-Cmd/t/01_IPC-Cmd.t (revision 898184e3e61f9129feb5978fad5a8c6865f00b92)
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