Commit | Line | Data |
---|---|---|
4ea8f8fb MS |
1 | #!./perl |
2 | # | |
3 | # Tests for Perl run-time environment variable settings | |
4 | # | |
5 | # $PERL5OPT, $PERL5LIB, etc. | |
6 | ||
7 | BEGIN { | |
8 | chdir 't' if -d 't'; | |
9 | @INC = '../lib'; | |
e069d1ca | 10 | require Config; import Config; |
9c8416b2 NC |
11 | require './test.pl'; |
12 | skip_all_without_config('d_fork'); | |
4ea8f8fb MS |
13 | } |
14 | ||
8c07e7b8 | 15 | plan tests => 106; |
659ca9ea | 16 | |
2d90ac95 NC |
17 | my $STDOUT = tempfile(); |
18 | my $STDERR = tempfile(); | |
463c96de | 19 | my $PERL = './perl'; |
4ea8f8fb MS |
20 | my $FAILURE_CODE = 119; |
21 | ||
a0704631 SF |
22 | delete $ENV{PERLLIB}; |
23 | delete $ENV{PERL5LIB}; | |
24 | delete $ENV{PERL5OPT}; | |
3e63457f | 25 | delete $ENV{PERL_USE_UNSAFE_INC}; |
a0704631 | 26 | |
4ea8f8fb | 27 | |
b01f2fb2 | 28 | # Run perl with specified environment and arguments, return (STDOUT, STDERR) |
d5226c4c NC |
29 | sub runperl_and_capture { |
30 | local *F; | |
31 | my ($env, $args) = @_; | |
4ea8f8fb | 32 | |
cd4e750a IZ |
33 | local %ENV = %ENV; |
34 | delete $ENV{PERLLIB}; | |
35 | delete $ENV{PERL5LIB}; | |
36 | delete $ENV{PERL5OPT}; | |
3e63457f | 37 | delete $ENV{PERL_USE_UNSAFE_INC}; |
4ea8f8fb MS |
38 | my $pid = fork; |
39 | return (0, "Couldn't fork: $!") unless defined $pid; # failure | |
40 | if ($pid) { # parent | |
4ea8f8fb MS |
41 | wait; |
42 | return (0, "Failure in child.\n") if ($?>>8) == $FAILURE_CODE; | |
43 | ||
62a1213a NC |
44 | open my $stdout, '<', $STDOUT |
45 | or return (0, "Couldn't read $STDOUT file: $!"); | |
46 | open my $stderr, '<', $STDERR | |
47 | or return (0, "Couldn't read $STDERR file: $!"); | |
48 | local $/; | |
49 | # Empty file with <$stderr> returns nothing in list context | |
50 | # (because there are no lines) Use scalar to force it to '' | |
51 | return (scalar <$stdout>, scalar <$stderr>); | |
4ea8f8fb MS |
52 | } else { # child |
53 | for my $k (keys %$env) { | |
54 | $ENV{$k} = $env->{$k}; | |
55 | } | |
62a1213a NC |
56 | open STDOUT, '>', $STDOUT or exit $FAILURE_CODE; |
57 | open STDERR, '>', $STDERR and do { exec $PERL, @$args }; | |
39214b38 | 58 | # it did not work: |
4ea8f8fb MS |
59 | print STDOUT "IWHCWJIHCI\cNHJWCJQWKJQJWCQW\n"; |
60 | exit $FAILURE_CODE; | |
b01f2fb2 | 61 | } |
4ea8f8fb MS |
62 | } |
63 | ||
64 | sub try { | |
b01f2fb2 NC |
65 | my ($env, $args, $stdout, $stderr) = @_; |
66 | my ($actual_stdout, $actual_stderr) = runperl_and_capture($env, $args); | |
16570ae7 | 67 | local $::Level = $::Level + 1; |
39214b38 JK |
68 | my @envpairs = (); |
69 | for my $k (sort keys %$env) { | |
70 | push @envpairs, "$k => $env->{$k}"; | |
71 | } | |
72 | my $label = join(',' => (@envpairs, @$args)); | |
7dc86639 | 73 | if (ref $stdout) { |
39214b38 | 74 | ok ( $actual_stdout =~/$stdout/, $label . ' stdout' ); |
7dc86639 | 75 | } else { |
39214b38 | 76 | is ( $actual_stdout, $stdout, $label . ' stdout' ); |
7dc86639 YO |
77 | } |
78 | if (ref $stderr) { | |
39214b38 | 79 | ok ( $actual_stderr =~/$stderr/, $label . ' stderr' ); |
7dc86639 | 80 | } else { |
39214b38 | 81 | is ( $actual_stderr, $stderr, $label . ' stderr' ); |
7dc86639 | 82 | } |
4ea8f8fb MS |
83 | } |
84 | ||
85 | # PERL5OPT Command-line options (switches). Switches in | |
86 | # this variable are taken as if they were on | |
1c4db469 | 87 | # every Perl command line. Only the -[DIMUdmtw] |
4ea8f8fb MS |
88 | # switches are allowed. When running taint |
89 | # checks (because the program was running setuid | |
90 | # or setgid, or the -T switch was used), this | |
91 | # variable is ignored. If PERL5OPT begins with | |
92 | # -T, tainting will be enabled, and any | |
93 | # subsequent options ignored. | |
94 | ||
659ca9ea | 95 | try({PERL5OPT => '-w'}, ['-e', 'print $::x'], |
4ea8f8fb | 96 | "", |
29489e7c | 97 | qq{Name "main::x" used only once: possible typo at -e line 1.\nUse of uninitialized value \$x in print at -e line 1.\n}); |
4ea8f8fb | 98 | |
2e13e92e | 99 | try({PERL5OPT => '-Mstrict'}, ['-I../lib', '-e', 'print $::x'], |
4ea8f8fb MS |
100 | "", ""); |
101 | ||
2e13e92e | 102 | try({PERL5OPT => '-Mstrict'}, ['-I../lib', '-e', 'print $x'], |
4ea8f8fb | 103 | "", |
d8c6310a | 104 | qq{Global symbol "\$x" requires explicit package name (did you forget to declare "my \$x"?) at -e line 1.\nExecution of -e aborted due to compilation errors.\n}); |
4ea8f8fb MS |
105 | |
106 | # Fails in 5.6.0 | |
2e13e92e | 107 | try({PERL5OPT => '-Mstrict -w'}, ['-I../lib', '-e', 'print $x'], |
4ea8f8fb | 108 | "", |
d8c6310a | 109 | qq{Global symbol "\$x" requires explicit package name (did you forget to declare "my \$x"?) at -e line 1.\nExecution of -e aborted due to compilation errors.\n}); |
4ea8f8fb MS |
110 | |
111 | # Fails in 5.6.0 | |
2e13e92e | 112 | try({PERL5OPT => '-w -Mstrict'}, ['-I../lib', '-e', 'print $::x'], |
4ea8f8fb MS |
113 | "", |
114 | <<ERROR | |
115 | Name "main::x" used only once: possible typo at -e line 1. | |
29489e7c | 116 | Use of uninitialized value \$x in print at -e line 1. |
4ea8f8fb MS |
117 | ERROR |
118 | ); | |
119 | ||
120 | # Fails in 5.6.0 | |
2e13e92e | 121 | try({PERL5OPT => '-w -Mstrict'}, ['-I../lib', '-e', 'print $::x'], |
4ea8f8fb MS |
122 | "", |
123 | <<ERROR | |
124 | Name "main::x" used only once: possible typo at -e line 1. | |
29489e7c | 125 | Use of uninitialized value \$x in print at -e line 1. |
4ea8f8fb MS |
126 | ERROR |
127 | ); | |
128 | ||
2e13e92e | 129 | try({PERL5OPT => '-MExporter'}, ['-I../lib', '-e0'], |
4ea8f8fb MS |
130 | "", |
131 | ""); | |
132 | ||
133 | # Fails in 5.6.0 | |
2e13e92e | 134 | try({PERL5OPT => '-MExporter -MExporter'}, ['-I../lib', '-e0'], |
4ea8f8fb MS |
135 | "", |
136 | ""); | |
137 | ||
659ca9ea | 138 | try({PERL5OPT => '-Mstrict -Mwarnings'}, |
2e13e92e | 139 | ['-I../lib', '-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'], |
4ea8f8fb MS |
140 | "ok", |
141 | ""); | |
142 | ||
c0a22fcc Z |
143 | open my $fh, ">", "tmpOooof.pm" or die "Can't write tmpOooof.pm: $!"; |
144 | print $fh "package tmpOooof; 1;\n"; | |
62a1213a | 145 | close $fh; |
c0a22fcc | 146 | END { 1 while unlink "tmpOooof.pm" } |
e63be746 | 147 | |
c0a22fcc Z |
148 | try({PERL5OPT => '-I. -MtmpOooof'}, |
149 | ['-e', 'print "ok" if $INC{"tmpOooof.pm"} eq "tmpOooof.pm"'], | |
e63be746 RGS |
150 | "ok", |
151 | ""); | |
152 | ||
c0a22fcc Z |
153 | try({PERL5OPT => '-I./ -MtmpOooof'}, |
154 | ['-e', 'print "ok" if $INC{"tmpOooof.pm"} eq "tmpOooof.pm"'], | |
e63be746 RGS |
155 | "ok", |
156 | ""); | |
157 | ||
659ca9ea JH |
158 | try({PERL5OPT => '-w -w'}, |
159 | ['-e', 'print $ENV{PERL5OPT}'], | |
160 | '-w -w', | |
161 | ''); | |
27dd2420 | 162 | |
1c4db469 RGS |
163 | try({PERL5OPT => '-t'}, |
164 | ['-e', 'print ${^TAINT}'], | |
9aa05f58 | 165 | '-1', |
1c4db469 RGS |
166 | ''); |
167 | ||
2b622f1a | 168 | try({PERL5OPT => '-W'}, |
2e13e92e | 169 | ['-I../lib','-e', 'local $^W = 0; no warnings; print $x'], |
2b622f1a MS |
170 | '', |
171 | <<ERROR | |
172 | Name "main::x" used only once: possible typo at -e line 1. | |
173 | Use of uninitialized value \$x in print at -e line 1. | |
174 | ERROR | |
175 | ); | |
176 | ||
cd4e750a | 177 | try({PERLLIB => "foobar$Config{path_sep}42"}, |
574c798a SR |
178 | ['-e', 'print grep { $_ eq "foobar" } @INC'], |
179 | 'foobar', | |
180 | ''); | |
181 | ||
cd4e750a | 182 | try({PERLLIB => "foobar$Config{path_sep}42"}, |
574c798a SR |
183 | ['-e', 'print grep { $_ eq "42" } @INC'], |
184 | '42', | |
185 | ''); | |
186 | ||
cd4e750a | 187 | try({PERL5LIB => "foobar$Config{path_sep}42"}, |
574c798a SR |
188 | ['-e', 'print grep { $_ eq "foobar" } @INC'], |
189 | 'foobar', | |
190 | ''); | |
191 | ||
cd4e750a | 192 | try({PERL5LIB => "foobar$Config{path_sep}42"}, |
574c798a SR |
193 | ['-e', 'print grep { $_ eq "42" } @INC'], |
194 | '42', | |
195 | ''); | |
196 | ||
a0704631 SF |
197 | try({PERL5LIB => "foo", |
198 | PERLLIB => "bar"}, | |
199 | ['-e', 'print grep { $_ eq "foo" } @INC'], | |
200 | 'foo', | |
201 | ''); | |
202 | ||
203 | try({PERL5LIB => "foo", | |
204 | PERLLIB => "bar"}, | |
205 | ['-e', 'print grep { $_ eq "bar" } @INC'], | |
206 | '', | |
207 | ''); | |
208 | ||
95309d6b TC |
209 | SKIP: |
210 | { | |
211 | skip "NO_PERL_HASH_SEED_DEBUG set", 4 | |
212 | if $Config{ccflags} =~ /-DNO_PERL_HASH_SEED_DEBUG\b/; | |
213 | ||
214 | try({PERL_HASH_SEED_DEBUG => 1}, | |
215 | ['-e','1'], | |
216 | '', | |
217 | qr/HASH_FUNCTION =/); | |
218 | ||
219 | try({PERL_HASH_SEED_DEBUG => 1}, | |
220 | ['-e','1'], | |
221 | '', | |
222 | qr/HASH_SEED =/); | |
223 | } | |
7dc86639 | 224 | |
95309d6b TC |
225 | SKIP: |
226 | { | |
227 | skip "NO_PERL_HASH_ENV or NO_PERL_HASH_SEED_DEBUG set", 16 | |
228 | if $Config{ccflags} =~ /-DNO_PERL_HASH_ENV\b/ || | |
229 | $Config{ccflags} =~ /-DNO_PERL_HASH_SEED_DEBUG\b/; | |
230 | ||
231 | # special case, seed "0" implies disabled hash key traversal randomization | |
232 | try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "0"}, | |
233 | ['-e','1'], | |
234 | '', | |
235 | qr/PERTURB_KEYS = 0/); | |
236 | ||
237 | # check that setting it to a different value with the same logical value | |
238 | # triggers the normal "deterministic mode". | |
239 | try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "0x0"}, | |
240 | ['-e','1'], | |
241 | '', | |
242 | qr/PERTURB_KEYS = 2/); | |
243 | ||
244 | try({PERL_HASH_SEED_DEBUG => 1, PERL_PERTURB_KEYS => "0"}, | |
245 | ['-e','1'], | |
246 | '', | |
247 | qr/PERTURB_KEYS = 0/); | |
248 | ||
249 | try({PERL_HASH_SEED_DEBUG => 1, PERL_PERTURB_KEYS => "1"}, | |
250 | ['-e','1'], | |
251 | '', | |
252 | qr/PERTURB_KEYS = 1/); | |
253 | ||
254 | try({PERL_HASH_SEED_DEBUG => 1, PERL_PERTURB_KEYS => "2"}, | |
255 | ['-e','1'], | |
256 | '', | |
257 | qr/PERTURB_KEYS = 2/); | |
258 | ||
259 | try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "12345678"}, | |
260 | ['-e','1'], | |
261 | '', | |
262 | qr/HASH_SEED = 0x12345678/); | |
263 | ||
264 | try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "12"}, | |
265 | ['-e','1'], | |
266 | '', | |
267 | qr/HASH_SEED = 0x12000000/); | |
268 | ||
269 | try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "123456789"}, | |
270 | ['-e','1'], | |
271 | '', | |
272 | qr/HASH_SEED = 0x12345678/); | |
273 | ||
274 | # Test that PERL_PERTURB_KEYS works as expected. We check that we get the same | |
275 | # results if we use PERL_PERTURB_KEYS = 0 or 2 and we reuse the seed from previous run. | |
276 | my @print_keys = ( '-e', '@_{"A".."Z"}=(); print keys %_'); | |
277 | for my $mode ( 0,1, 2 ) { # disabled and deterministic respectively | |
278 | my %base_opts = ( PERL_PERTURB_KEYS => $mode, PERL_HASH_SEED_DEBUG => 1 ), | |
279 | my ($out, $err) = runperl_and_capture( { %base_opts }, [ @print_keys ]); | |
280 | if ($err=~/HASH_SEED = (0x[a-f0-9]+)/) { | |
281 | my $seed = $1; | |
282 | my($out2, $err2) = runperl_and_capture( { %base_opts, PERL_HASH_SEED => $seed }, [ @print_keys ]); | |
283 | if ( $mode == 1 ) { | |
284 | isnt ($out,$out2,"PERL_PERTURB_KEYS = $mode results in different key order with the same key"); | |
285 | } else { | |
286 | is ($out,$out2,"PERL_PERTURB_KEYS = $mode allows one to recreate a random hash"); | |
287 | } | |
288 | is ($err,$err2,"Got the same debug output when we set PERL_HASH_SEED and PERL_PERTURB_KEYS"); | |
a2098e20 | 289 | } |
a2098e20 YO |
290 | } |
291 | } | |
292 | ||
72533a49 NC |
293 | # Tests for S_incpush_use_sep(): |
294 | ||
295 | my @dump_inc = ('-e', 'print "$_\n" foreach @INC'); | |
296 | ||
297 | my ($out, $err) = runperl_and_capture({}, [@dump_inc]); | |
298 | ||
299 | is ($err, '', 'No errors when determining @INC'); | |
300 | ||
301 | my @default_inc = split /\n/, $out; | |
302 | ||
772973e0 | 303 | SKIP: { |
8c07e7b8 | 304 | skip_if_miniperl("under miniperl", 3); |
e7ced07a DIM |
305 | if ($Config{default_inc_excludes_dot}) { |
306 | ok !(grep { $_ eq '.' } @default_inc), '. is not in @INC'; | |
8c07e7b8 DIM |
307 | ($out, $err) = runperl_and_capture({ PERL_USE_UNSAFE_INC => 1 }, [@dump_inc]); |
308 | ||
309 | is ($err, '', 'No errors when determining unsafe @INC'); | |
310 | ||
311 | my @unsafe_inc = split /\n/, $out; | |
312 | ||
313 | ok (eq_array([@unsafe_inc], [@default_inc, '.']), '. last in unsafe @INC') | |
314 | or diag 'Unsafe @INC is: ', @unsafe_inc; | |
e7ced07a DIM |
315 | } |
316 | else { | |
317 | is ($default_inc[-1], '.', '. is last in @INC'); | |
8c07e7b8 | 318 | skip('Not testing unsafe @INC when it includes . by default', 2); |
e7ced07a | 319 | } |
772973e0 | 320 | } |
72533a49 NC |
321 | |
322 | my $sep = $Config{path_sep}; | |
323 | foreach (['nothing', ''], | |
324 | ['something', 'zwapp', 'zwapp'], | |
325 | ['two things', "zwapp${sep}bam", 'zwapp', 'bam'], | |
326 | ['two things, ::', "zwapp${sep}${sep}bam", 'zwapp', 'bam'], | |
327 | [': at start', "${sep}zwapp", 'zwapp'], | |
328 | [': at end', "zwapp${sep}", 'zwapp'], | |
329 | [':: sandwich ::', "${sep}${sep}zwapp${sep}${sep}", 'zwapp'], | |
330 | [':', "${sep}"], | |
331 | ['::', "${sep}${sep}"], | |
332 | [':::', "${sep}${sep}${sep}"], | |
333 | ['two things and :', "zwapp${sep}bam${sep}", 'zwapp', 'bam'], | |
334 | [': and two things', "${sep}zwapp${sep}bam", 'zwapp', 'bam'], | |
335 | [': two things :', "${sep}zwapp${sep}bam${sep}", 'zwapp', 'bam'], | |
336 | ['three things', "zwapp${sep}bam${sep}${sep}owww", | |
337 | 'zwapp', 'bam', 'owww'], | |
338 | ) { | |
339 | my ($name, $lib, @expect) = @$_; | |
340 | push @expect, @default_inc; | |
341 | ||
342 | ($out, $err) = runperl_and_capture({PERL5LIB => $lib}, [@dump_inc]); | |
343 | ||
344 | is ($err, '', "No errors when determining \@INC for $name"); | |
345 | ||
346 | my @inc = split /\n/, $out; | |
347 | ||
72533a49 NC |
348 | is (scalar @inc, scalar @expect, |
349 | "expected number of elements in \@INC for $name"); | |
350 | ||
351 | is ("@inc", "@expect", "expected elements in \@INC for $name"); | |
352 | } | |
353 | ||
574c798a | 354 | # PERL5LIB tests with included arch directories still missing |