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
86
|
#!/usr/bin/perl -w
# Test that @INC is propogated from the harness process to the test
# process.
use strict;
use lib 't/lib';
sub has_crazy_patch {
my $sentinel = 'blirpzoffle';
local $ENV{PERL5LIB} = $sentinel;
my $command = join ' ',
map {qq{"$_"}} ( $^X, '-e', 'print join q(:), @INC' );
my $path = `$command`;
my @got = ( $path =~ /($sentinel)/g );
return @got > 1;
}
use Test::More (
$^O eq 'VMS' ? ( skip_all => 'VMS' )
: has_crazy_patch() ? ( skip_all => 'Incompatible @INC patch' )
: ( tests => 2 )
);
use Data::Dumper;
use Test::Harness;
# Change @INC so we ensure it's preserved.
use lib 'wibble';
# TODO: Disabled until we find out why it's breaking on Windows. It's
# not strictly a TODO because it seems pretty likely that it's a Windows
# problem rather than a problem with Test::Harness.
# Put a stock directory near the beginning.
# use lib $INC[$#INC-2];
my $inc = Data::Dumper->new( [ \@INC ] )->Terse(1)->Purity(1)->Dump;
my $taint_inc
= Data::Dumper->new( [ [ grep { $_ ne '.' } @INC ] ] )->Terse(1)->Purity(1)
->Dump;
# The tail of @INC is munged during core testing. We're only *really*
# interested in whether 'wibble' makes it anyway.
my $cmp_slice = $ENV{PERL_CORE} ? '[0..1]' : '';
my $test_template = <<'END';
#!/usr/bin/perl %s
use Test::More tests => 2;
sub _strip_dups {
my %%dups;
# Drop '.' which sneaks in on some platforms
my @r = grep { $_ ne '.' } grep { !$dups{$_}++ } @_;
return @r%s;
}
# Make sure we did something sensible with PERL5LIB
like $ENV{PERL5LIB}, qr{wibble};
is_deeply(
[_strip_dups(@INC)],
[_strip_dups(@{%s})],
'@INC propagated to test'
) or do {
diag join ",\n", _strip_dups(@INC);
diag '-----------------';
diag join ",\n", _strip_dups(@{%s});
};
END
open TEST, ">inc_check.t.tmp";
printf TEST $test_template, '', $cmp_slice, $inc, $inc;
close TEST;
open TEST, ">inc_check_taint.t.tmp";
printf TEST $test_template, '-T', $cmp_slice, $taint_inc, $taint_inc;
close TEST;
END { 1 while unlink 'inc_check_taint.t.tmp', 'inc_check.t.tmp'; }
for my $test ( 'inc_check_taint.t.tmp', 'inc_check.t.tmp' ) {
my ( $tot, $failed ) = Test::Harness::execute_tests( tests => [$test] );
is $tot->{bad}, 0;
}
1;
|
