ext/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];
  13 my @Meths       = qw[can_use_ipc_run can_use_ipc_open3 can_capture_buffer];
  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-existant 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 configuarion
  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 succesfully" );
 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 __END__
 159 ### special call to check that output is interleaved properly
 160 {   my $cmd     = [$^X, File::Spec->catfile( qw[src output.pl] ) ];
 161
 162     ### for each configuarion
 163     for my $pref ( @Prefs ) {
 164         diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
 165             if $Verbose;
 166
 167         local $IPC::Cmd::USE_IPC_RUN    = $pref->[0];
 168         local $IPC::Cmd::USE_IPC_OPEN3  = $pref->[1];
 169
 170         my @list    = run( command => $cmd, buffer => \my $buffer );
 171         ok( $list[0],                   "Ran @{$cmd} successfully" );
 172         ok( !$list[1],                  "   No errorcode set" );
 173         SKIP: {
 174             skip "No buffers available", 3 unless $Class->can_capture_buffer;
 175
 176             TODO: {
 177                 local $TODO = qq[Can't interleave input/output buffers yet];
 178
 179                 is( "@{$list[2]}",'1 2 3 4',"   Combined output as expected" );
 180                 is( "@{$list[3]}", '1 3',   "   STDOUT as expected" );
 181                 is( "@{$list[4]}", '2 4',   "   STDERR as expected" );
 182
 183             }
 184         }
 185     }
 186 }
 187
 188
 189
 190 ### test failures
 191 {   ### for each configuarion
 192     for my $pref ( @Prefs ) {
 193         diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
 194             if $Verbose;
 195
 196         local $IPC::Cmd::USE_IPC_RUN    = $pref->[0];
 197         local $IPC::Cmd::USE_IPC_OPEN3  = $pref->[1];
 198
 199         my ($ok,$err) = run( command => "$^X -edie" );
 200         ok( !$ok,               "Non-zero exit caught" );
 201         ok( $err,               "   Error '$err'" );
 202     }
 203 }
 204
 205 ### timeout tests
 206 {   my $timeout = 1;
 207     for my $pref ( @Prefs ) {
 208         diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
 209             if $Verbose;
 210
 211         local $IPC::Cmd::USE_IPC_RUN    = $pref->[0];
 212         local $IPC::Cmd::USE_IPC_OPEN3  = $pref->[1];
 213
 214         ### -X to quiet the 'sleep without parens is ambiguous' warning
 215         my ($ok,$err) = run( command => "$^X -Xesleep+4", timeout => $timeout );
 216         ok( !$ok,               "Timeout caught" );
 217         ok( $err,               "   Error stored" );
 218         ok( not(ref($err)),     "   Error string is not a reference" );
 219         like( $err,qr/^$AClass/,"   Error '$err' mentions $AClass" );
 220     }
 221 }
 222
 223
 224