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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
|
#!./perl
#
# Tests for Perl run-time environment variable settings
#
# $PERL5OPT, $PERL5LIB, etc.
BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
unless ($Config{'d_fork'}) {
print "1..0 # Skip: no fork\n";
exit 0;
}
}
use Test;
plan tests => 15;
my $STDOUT = './results-0';
my $STDERR = './results-1';
my $PERL = './perl';
my $FAILURE_CODE = 119;
# Run perl with specified environment and arguments returns a list.
# First element is true if Perl's stdout and stderr match the
# supplied $stdout and $stderr argument strings exactly.
# second element is an explanation of the failure
sub runperl {
local *F;
my ($env, $args, $stdout, $stderr) = @_;
unshift @$args, '-I../lib';
$stdout = '' unless defined $stdout;
$stderr = '' unless defined $stderr;
my $pid = fork;
return (0, "Couldn't fork: $!") unless defined $pid; # failure
if ($pid) { # parent
my ($actual_stdout, $actual_stderr);
wait;
return (0, "Failure in child.\n") if ($?>>8) == $FAILURE_CODE;
open F, "< $STDOUT" or return (0, "Couldn't read $STDOUT file");
{ local $/; $actual_stdout = <F> }
open F, "< $STDERR" or return (0, "Couldn't read $STDERR file");
{ local $/; $actual_stderr = <F> }
if ($actual_stdout ne $stdout) {
return (0, "Stdout mismatch: expected [$stdout], saw [$actual_stdout]");
} elsif ($actual_stderr ne $stderr) {
return (0, "Stderr mismatch: expected [$stderr], saw [$actual_stderr]");
} else {
return 1; # success
}
} else { # child
for my $k (keys %$env) {
$ENV{$k} = $env->{$k};
}
open STDOUT, "> $STDOUT" or exit $FAILURE_CODE;
open STDERR, "> $STDERR" or it_didnt_work();
{ exec $PERL, @$args }
it_didnt_work();
}
}
sub it_didnt_work {
print STDOUT "IWHCWJIHCI\cNHJWCJQWKJQJWCQW\n";
exit $FAILURE_CODE;
}
sub try {
my ($success, $reason) = runperl(@_);
$reason =~ s/\n/\\n/g if defined $reason;
ok( !!$success, 1, $reason );
}
# PERL5OPT Command-line options (switches). Switches in
# this variable are taken as if they were on
# every Perl command line. Only the -[DIMUdmtw]
# switches are allowed. When running taint
# checks (because the program was running setuid
# or setgid, or the -T switch was used), this
# variable is ignored. If PERL5OPT begins with
# -T, tainting will be enabled, and any
# subsequent options ignored.
try({PERL5OPT => '-w'}, ['-e', 'print $::x'],
"",
qq{Name "main::x" used only once: possible typo at -e line 1.\nUse of uninitialized value in print at -e line 1.\n});
try({PERL5OPT => '-Mstrict'}, ['-e', 'print $::x'],
"", "");
try({PERL5OPT => '-Mstrict'}, ['-e', 'print $x'],
"",
qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
# Fails in 5.6.0
try({PERL5OPT => '-Mstrict -w'}, ['-e', 'print $x'],
"",
qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
# Fails in 5.6.0
try({PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
"",
<<ERROR
Name "main::x" used only once: possible typo at -e line 1.
Use of uninitialized value in print at -e line 1.
ERROR
);
# Fails in 5.6.0
try({PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
"",
<<ERROR
Name "main::x" used only once: possible typo at -e line 1.
Use of uninitialized value in print at -e line 1.
ERROR
);
try({PERL5OPT => '-MExporter'}, ['-e0'],
"",
"");
# Fails in 5.6.0
try({PERL5OPT => '-MExporter -MExporter'}, ['-e0'],
"",
"");
try({PERL5OPT => '-Mstrict -Mwarnings'},
['-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'],
"ok",
"");
try({PERL5OPT => '-w -w'},
['-e', 'print $ENV{PERL5OPT}'],
'-w -w',
'');
try({PERL5OPT => '-t'},
['-e', 'print ${^TAINT}'],
'1',
'');
try({PERLLIB => "foobar:42"},
['-e', 'print grep { $_ eq "foobar" } @INC'],
'foobar',
'');
try({PERLLIB => "foobar:42"},
['-e', 'print grep { $_ eq "42" } @INC'],
'42',
'');
try({PERL5LIB => "foobar:42"},
['-e', 'print grep { $_ eq "foobar" } @INC'],
'foobar',
'');
try({PERL5LIB => "foobar:42"},
['-e', 'print grep { $_ eq "42" } @INC'],
'42',
'');
# PERL5LIB tests with included arch directories still missing
END {
1 while unlink $STDOUT;
1 while unlink $STDERR;
}
|
