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