[perl5.git] / cpan / IPC-Cmd / t / 01_IPC-Cmd.t

## IPC::Cmd test suite ###

BEGIN { chdir 't' if -d 't' };

use strict;
use lib qw[../lib];
use File::Spec;
use Test::More 'no_plan';

my $Class       = 'IPC::Cmd';
my $AClass      = $Class . '::TimeOut';
my @Funcs       = qw[run can_run QUOTE run_forked];
my @Meths       = qw[can_use_ipc_run can_use_ipc_open3 can_capture_buffer can_use_run_forked];
my $IsWin32     = $^O eq 'MSWin32';
my $Verbose     = @ARGV ? 1 : 0;

use_ok( $Class,         $_ ) for @Funcs;
can_ok( $Class,         $_ ) for @Funcs, @Meths;
can_ok( __PACKAGE__,    $_ ) for @Funcs;

my $Have_IPC_Run    = $Class->can_use_ipc_run   || 0;
my $Have_IPC_Open3  = $Class->can_use_ipc_open3 || 0;

diag("IPC::Run: $Have_IPC_Run   IPC::Open3: $Have_IPC_Open3")
    unless exists $ENV{'PERL_CORE'};

local $IPC::Cmd::VERBOSE = $Verbose;
local $IPC::Cmd::VERBOSE = $Verbose;
local $IPC::Cmd::DEBUG   = $Verbose;
local $IPC::Cmd::DEBUG   = $Verbose;


### run tests in various configurations, based on what modules we have
my @Prefs = ( );
push @Prefs, [ $Have_IPC_Run, $Have_IPC_Open3 ] if $Have_IPC_Run; 

### run this config twice to ensure FD restores work properly
push @Prefs, [ 0,             $Have_IPC_Open3 ],     
             [ 0,             $Have_IPC_Open3 ] if $Have_IPC_Open3;

### run this config twice to ensure FD restores work properly
### these are the system() tests;
push @Prefs, [ 0,             0 ],  [ 0,             0 ];     


### can_run tests
{
    ok( can_run("$^X"),                q[Found 'perl' in your path] );
    ok( !can_run('10283lkjfdalskfjaf'), q[Not found non-existent binary] );
}

{   ### list of commands and regexes matching output 
    ### XXX use " everywhere when using literal strings as commands for
    ### portability, especially on win32
    my $map = [
        # command                                    # output regex     # buffer

        ### run tests that print only to stdout
        [ "$^X -v",                                  qr/larry\s+wall/i, 3, ],
        [ [$^X, '-v'],                               qr/larry\s+wall/i, 3, ],

        ### pipes
        [ "$^X -eprint+424 | $^X -neprint+split+2",  qr/44/,            3, ],
        [ [$^X,qw[-eprint+424 |], $^X, qw|-neprint+split+2|], 
                                                     qr/44/,            3, ],
        ### whitespace
        [ [$^X, '-eprint+shift', q|a b a|],          qr/a b a/,         3, ],
        [ qq[$^X -eprint+shift "a b a"],             qr/a b a/,         3, ],

        ### whitespace + pipe
        [ [$^X, '-eprint+shift', q|a b a|, q[|], $^X, qw[-neprint+split+b] ],
                                                     qr/a  a/,          3, ],
        [ qq[$^X -eprint+shift "a b a" | $^X -neprint+split+b],
                                                     qr/a  a/,          3, ],

        ### run tests that print only to stderr
        [ "$^X -ewarn+42",                           qr/^42 /,          4, ],
        [ [$^X, '-ewarn+42'],                        qr/^42 /,          4, ],
    ];

    ### extended test in developer mode
    ### test if gzip | tar works
    if( $Verbose ) {   
        my $gzip = can_run('gzip');
        my $tar  = can_run('tar');
        
        if( $gzip and $tar ) {
            push @$map,
                [ [$gzip, qw[-cdf src/x.tgz |], $tar, qw[-tf -]],     
                                                       qr/a/,           3, ];
        }
    }        

    ### for each configuration
    for my $pref ( @Prefs ) {

        local $IPC::Cmd::USE_IPC_RUN    = !!$pref->[0];
        local $IPC::Cmd::USE_IPC_RUN    = !!$pref->[0];
        local $IPC::Cmd::USE_IPC_OPEN3  = !!$pref->[1];
        local $IPC::Cmd::USE_IPC_OPEN3  = !!$pref->[1];

        ### for each command
        for my $aref ( @$map ) {
            my $cmd    = $aref->[0];
            my $regex  = $aref->[1];
            my $index  = $aref->[2];

            my $pp_cmd = ref $cmd ? "Array: @$cmd" : "Scalar: $cmd";
            $pp_cmd .= " (IPC::Run: $pref->[0] IPC::Open3: $pref->[1])";

            diag( "Running '$pp_cmd'") if $Verbose;

            ### in scalar mode
            {   my $buffer;
                my $ok = run( command => $cmd, buffer => \$buffer );

                ok( $ok,        "Ran '$pp_cmd' command successfully" );
                
                SKIP: {
                    skip "No buffers available", 1 
                                unless $Class->can_capture_buffer;
                    
                    like( $buffer, $regex,  
                                "   Buffer matches $regex -- ($pp_cmd)" );
                }
            }
                
            ### in list mode                
            {   diag( "Running list mode" ) if $Verbose;
                my @list = run( command => $cmd );

                ok( $list[0],   "Ran '$pp_cmd' successfully" );
                ok( !$list[1],  "   No error code set -- ($pp_cmd)" );

                my $list_length = $Class->can_capture_buffer ? 5 : 2;
                is( scalar(@list), $list_length,
                                "   Output list has $list_length entries -- ($pp_cmd)" );

                SKIP: {
                    skip "No buffers available", 6 
                                unless $Class->can_capture_buffer;
                    
                    ### the last 3 entries from the RV, are they array refs?
                    isa_ok( $list[$_], 'ARRAY' ) for 2..4;

                    like( "@{$list[2]}", $regex,
                                "   Combined buffer matches $regex -- ($pp_cmd)" );

                    like( "@{$list[$index]}", qr/$regex/,
                            "   Proper buffer($index) matches $regex -- ($pp_cmd)" );
                    is( scalar( @{$list[ $index==3 ? 4 : 3 ]} ), 0,
                                    "   Other buffer empty -- ($pp_cmd)" );
                }
            }
        }
    }
}

unless ( IPC::Cmd->can_use_run_forked ) {
  ok(1, "run_forked not available on this platform");
  exit;
}

{
  my $cmd = "echo out ; echo err >&2 ; sleep 4";
  my $r = run_forked($cmd, {'timeout' => 1});

  ok(ref($r) eq 'HASH', "executed: $cmd");
  ok($r->{'timeout'} eq 1, "timed out");
  ok($r->{'stdout'}, "stdout: " . $r->{'stdout'});
  ok($r->{'stderr'}, "stderr: " . $r->{'stderr'});
}


# try discarding the out+err
{
  my $out;
  my $cmd = "echo out ; echo err >&2";
  my $r = run_forked(
        $cmd,
    {   discard_output => 1,
        stderr_handler => sub { $out .= shift },
        stdout_handler => sub { $out .= shift }
    });

  ok(ref($r) eq 'HASH', "executed: $cmd");
  ok(!$r->{'stdout'}, "stdout discarded");
  ok(!$r->{'stderr'}, "stderr discarded");
  ok($out =~ m/out/, "stdout handled");
  ok($out =~ m/err/, "stderr handled");
}

    
__END__
### special call to check that output is interleaved properly
{   my $cmd     = [$^X, File::Spec->catfile( qw[src output.pl] ) ];

    ### for each configuration
    for my $pref ( @Prefs ) {
        diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
            if $Verbose;

        local $IPC::Cmd::USE_IPC_RUN    = $pref->[0];
        local $IPC::Cmd::USE_IPC_OPEN3  = $pref->[1];

        my @list    = run( command => $cmd, buffer => \my $buffer );
        ok( $list[0],                   "Ran @{$cmd} successfully" );
        ok( !$list[1],                  "   No errorcode set" );
        SKIP: {
            skip "No buffers available", 3 unless $Class->can_capture_buffer;

            TODO: {
                local $TODO = qq[Can't interleave input/output buffers yet];

                is( "@{$list[2]}",'1 2 3 4',"   Combined output as expected" );
                is( "@{$list[3]}", '1 3',   "   STDOUT as expected" );
                is( "@{$list[4]}", '2 4',   "   STDERR as expected" );
            
            }
        }
    }        
}


### test failures
{   ### for each configuration
    for my $pref ( @Prefs ) {
        diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
            if $Verbose;

        local $IPC::Cmd::USE_IPC_RUN    = $pref->[0];
        local $IPC::Cmd::USE_IPC_OPEN3  = $pref->[1];

        my ($ok,$err) = run( command => "$^X -edie" );
        ok( !$ok,               "Non-zero exit caught" );
        ok( $err,               "   Error '$err'" );
    }
}   

### timeout tests
{   my $timeout = 1;
    for my $pref ( @Prefs ) {
        diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
            if $Verbose;

        local $IPC::Cmd::USE_IPC_RUN    = $pref->[0];
        local $IPC::Cmd::USE_IPC_OPEN3  = $pref->[1];

        ### -X to quiet the 'sleep without parens is ambiguous' warning
        my ($ok,$err) = run( command => "$^X -Xesleep+4", timeout => $timeout );
        ok( !$ok,               "Timeout caught" );
        ok( $err,               "   Error stored" );
        ok( not(ref($err)),     "   Error string is not a reference" );
        like( $err,qr/^$AClass/,"   Error '$err' mentions $AClass" );
    }
}
Commit	Line	Data
0d4ddeff RGS	1	## IPC::Cmd test suite ###
	2
	3	BEGIN { chdir 't' if -d 't' };
	4
	5	use strict;
	6	use lib qw[../lib];
bdd3a62b	7	use File::Spec;
0d4ddeff RGS	8	use Test::More 'no_plan';
0d4ddeff RGS	9
bdd3a62b JB	10	my $Class = 'IPC::Cmd';
bdd3a62b JB	11	my $AClass = $Class . '::TimeOut';
0c2c01a4 CBW	12	my @Funcs = qw[run can_run QUOTE run_forked];
0c2c01a4 CBW	13	my @Meths = qw[can_use_ipc_run can_use_ipc_open3 can_capture_buffer can_use_run_forked];
bdd3a62b JB	14	my $IsWin32 = $^O eq 'MSWin32';
bdd3a62b JB	15	my $Verbose = @ARGV ? 1 : 0;
0d4ddeff RGS	16
	17	use_ok( $Class, $_ ) for @Funcs;
	18	can_ok( $Class, $_ ) for @Funcs, @Meths;
	19	can_ok( __PACKAGE__, $_ ) for @Funcs;
	20
bdd3a62b JB	21	my $Have_IPC_Run = $Class->can_use_ipc_run \|\| 0;
	22	my $Have_IPC_Open3 = $Class->can_use_ipc_open3 \|\| 0;
	23
495650dc	24	diag("IPC::Run: $Have_IPC_Run IPC::Open3: $Have_IPC_Open3")
2b78b771	25	unless exists $ENV{'PERL_CORE'};
bdd3a62b JB	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;
0d4ddeff	31
0d4ddeff RGS	32
0d4ddeff RGS	33	### run tests in various configurations, based on what modules we have
bdd3a62b JB	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
0d4ddeff RGS	45
	46	### can_run tests
	47	{
47fe3251	48	ok( can_run("$^X"), q[Found 'perl' in your path] );
ccf86ece	49	ok( !can_run('10283lkjfdalskfjaf'), q[Not found non-existent binary] );
0d4ddeff RGS	50	}
0d4ddeff RGS	51
bdd3a62b JB	52	{ ### list of commands and regexes matching output
	53	### XXX use " everywhere when using literal strings as commands for
	54	### portability, especially on win32
0d4ddeff	55	my $map = [
bdd3a62b JB	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, ],
0d4ddeff RGS	79	];
0d4ddeff RGS	80
bdd3a62b JB	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
ccf86ece	94	### for each configuration
0d4ddeff	95	for my $pref ( @Prefs ) {
0d4ddeff	96
bdd3a62b JB	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];
0d4ddeff RGS	101
	102	### for each command
	103	for my $aref ( @$map ) {
bdd3a62b JB	104	my $cmd = $aref->[0];
	105	my $regex = $aref->[1];
	106	my $index = $aref->[2];
0d4ddeff	107
bdd3a62b JB	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;
0d4ddeff RGS	112
0d4ddeff RGS	113	### in scalar mode
bdd3a62b	114	{ my $buffer;
0d4ddeff RGS	115	my $ok = run( command => $cmd, buffer => \$buffer );
0d4ddeff RGS	116
ccf86ece	117	ok( $ok, "Ran '$pp_cmd' command successfully" );
0d4ddeff RGS	118
	119	SKIP: {
	120	skip "No buffers available", 1
	121	unless $Class->can_capture_buffer;
	122
	123	like( $buffer, $regex,
bdd3a62b	124	" Buffer matches $regex -- ($pp_cmd)" );
0d4ddeff RGS	125	}
	126	}
	127
	128	### in list mode
	129	{ diag( "Running list mode" ) if $Verbose;
	130	my @list = run( command => $cmd );
bdd3a62b JB	131
	132	ok( $list[0], "Ran '$pp_cmd' successfully" );
	133	ok( !$list[1], " No error code set -- ($pp_cmd)" );
0d4ddeff RGS	134
	135	my $list_length = $Class->can_capture_buffer ? 5 : 2;
	136	is( scalar(@list), $list_length,
bdd3a62b	137	" Output list has $list_length entries -- ($pp_cmd)" );
0d4ddeff RGS	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,
bdd3a62b	147	" Combined buffer matches $regex -- ($pp_cmd)" );
0d4ddeff	148
bdd3a62b JB	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)" );
0d4ddeff RGS	153	}
	154	}
	155	}
	156	}
	157	}
0c2c01a4 CBW	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
4d239afe RGS	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
0c2c01a4	193
bdd3a62b JB	194	__END__
	195	### special call to check that output is interleaved properly
	196	{ my $cmd = [$^X, File::Spec->catfile( qw[src output.pl] ) ];
0d4ddeff	197
ccf86ece	198	### for each configuration
cce6d045 JB	199	for my $pref ( @Prefs ) {
	200	diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
	201	if $Verbose;
	202
bdd3a62b JB	203	local $IPC::Cmd::USE_IPC_RUN = $pref->[0];
bdd3a62b JB	204	local $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1];
cce6d045	205
bdd3a62b JB	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;
cce6d045	211
bdd3a62b JB	212	TODO: {
bdd3a62b JB	213	local $TODO = qq[Can't interleave input/output buffers yet];
cce6d045	214
bdd3a62b JB	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
cce6d045 JB	219	}
cce6d045 JB	220	}
bdd3a62b	221	}
cce6d045	222	}
0d4ddeff	223
bdd3a62b JB	224
bdd3a62b JB	225
0d4ddeff	226	### test failures
ccf86ece	227	{ ### for each configuration
0d4ddeff RGS	228	for my $pref ( @Prefs ) {
	229	diag( "Running config: IPC::Run: $pref->[0] IPC::Open3: $pref->[1]" )
	230	if $Verbose;
	231
bdd3a62b JB	232	local $IPC::Cmd::USE_IPC_RUN = $pref->[0];
bdd3a62b JB	233	local $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1];
0d4ddeff	234
bdd3a62b JB	235	my ($ok,$err) = run( command => "$^X -edie" );
	236	ok( !$ok, "Non-zero exit caught" );
	237	ok( $err, " Error '$err'" );
0d4ddeff	238	}
bdd3a62b	239	}
0d4ddeff	240
bdd3a62b JB	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;
0d4ddeff	246
bdd3a62b JB	247	local $IPC::Cmd::USE_IPC_RUN = $pref->[0];
bdd3a62b JB	248	local $IPC::Cmd::USE_IPC_OPEN3 = $pref->[1];
0d4ddeff	249
bdd3a62b JB	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" );
0d4ddeff	256	}
bdd3a62b	257	}
0d4ddeff	258