1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use File::Spec;
use Test::More;
plan skip_all => "Not adapted to perl core" if $ENV{PERL_CORE};
plan skip_all => "Not installing prove" if -e "t/SKIP-PROVE";
plan tests => 5;
my $blib = File::Spec->catfile( File::Spec->curdir, "blib" );
my $blib_lib = File::Spec->catfile( $blib, "lib" );
my $blib_arch = File::Spec->catfile( $blib, "arch" );
my $prove = File::Spec->catfile( $blib, "script", "prove" );
CAPITAL_TAINT: {
local $ENV{PROVE_SWITCHES};
local $/ = undef;
my @actual = qx/$prove -Ifirst -D -I second -Ithird -Tvdb/;
my @expected = ( "# \$Test::Harness::Switches: -T -I$blib_arch -I$blib_lib -Ifirst -Isecond -Ithird\n" );
array_match_ok( \@actual, \@expected, "Capital taint flags OK" );
}
LOWERCASE_TAINT: {
local $ENV{PROVE_SWITCHES};
local $/ = undef;
my @actual = qx/$prove -dD -Ifirst -I second -t -Ithird -vb/;
my @expected = ( "# \$Test::Harness::Switches: -t -I$blib_arch -I$blib_lib -Ifirst -Isecond -Ithird\n" );
array_match_ok( \@actual, \@expected, "Lowercase taint OK" );
}
PROVE_SWITCHES: {
local $ENV{PROVE_SWITCHES} = "-dvb -I fark";
local $/ = undef;
my @actual = qx/$prove -Ibork -Dd/;
my @expected = ( "# \$Test::Harness::Switches: -I$blib_arch -I$blib_lib -Ifark -Ibork\n" );
array_match_ok( \@actual, \@expected, "PROVE_SWITCHES OK" );
}
PROVE_SWITCHES_L: {
local $/ = undef;
my @actual = qx/$prove -l -Ibongo -Dd/;
my @expected = ( "# \$Test::Harness::Switches: -Ilib -Ibongo\n" );
array_match_ok( \@actual, \@expected, "PROVE_SWITCHES OK" );
}
PROVE_SWITCHES_LB: {
local $/ = undef;
my @actual = qx/$prove -lb -Dd/;
my @expected = ( "# \$Test::Harness::Switches: -Ilib -I$blib_arch -I$blib_lib\n" );
array_match_ok( \@actual, \@expected, "PROVE_SWITCHES OK" );
}
sub array_match_ok {
my $actual = shift;
my $expected = shift;
my $message = shift;
my $n = 0;
my @actual = @$actual;
my @expected = @$expected;
while ( @actual && @expected ) {
return ok( 0, "Differs at element $n: $message" ) if shift @actual ne shift @expected;
++$n;
}
return ok( 0, "Too many actual: $message" ) if @actual;
return ok( 0, "Too many expected: $message" ) if @expected;
return ok( 1, $message );
}
|
