1#!./perl 2# 3# Tests for Perl run-time environment variable settings 4# 5# $PERL5OPT, $PERL5LIB, etc. 6 7BEGIN { 8 chdir 't' if -d 't'; 9 @INC = '../lib'; 10 require Config; import Config; 11 require './test.pl'; 12 skip_all_without_config('d_fork'); 13} 14 15plan tests => 104; 16 17my $STDOUT = tempfile(); 18my $STDERR = tempfile(); 19my $PERL = './perl'; 20my $FAILURE_CODE = 119; 21 22delete $ENV{PERLLIB}; 23delete $ENV{PERL5LIB}; 24delete $ENV{PERL5OPT}; 25 26 27# Run perl with specified environment and arguments, return (STDOUT, STDERR) 28sub runperl_and_capture { 29 local *F; 30 my ($env, $args) = @_; 31 32 local %ENV = %ENV; 33 delete $ENV{PERLLIB}; 34 delete $ENV{PERL5LIB}; 35 delete $ENV{PERL5OPT}; 36 my $pid = fork; 37 return (0, "Couldn't fork: $!") unless defined $pid; # failure 38 if ($pid) { # parent 39 wait; 40 return (0, "Failure in child.\n") if ($?>>8) == $FAILURE_CODE; 41 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>); 50 } else { # child 51 for my $k (keys %$env) { 52 $ENV{$k} = $env->{$k}; 53 } 54 open STDOUT, '>', $STDOUT or exit $FAILURE_CODE; 55 open STDERR, '>', $STDERR and do { exec $PERL, @$args }; 56 # it did not work: 57 print STDOUT "IWHCWJIHCI\cNHJWCJQWKJQJWCQW\n"; 58 exit $FAILURE_CODE; 59 } 60} 61 62sub try { 63 my ($env, $args, $stdout, $stderr) = @_; 64 my ($actual_stdout, $actual_stderr) = runperl_and_capture($env, $args); 65 local $::Level = $::Level + 1; 66 my @envpairs = (); 67 for my $k (sort keys %$env) { 68 push @envpairs, "$k => $env->{$k}"; 69 } 70 my $label = join(',' => (@envpairs, @$args)); 71 if (ref $stdout) { 72 ok ( $actual_stdout =~/$stdout/, $label . ' stdout' ); 73 } else { 74 is ( $actual_stdout, $stdout, $label . ' stdout' ); 75 } 76 if (ref $stderr) { 77 ok ( $actual_stderr =~/$stderr/, $label . ' stderr' ); 78 } else { 79 is ( $actual_stderr, $stderr, $label . ' stderr' ); 80 } 81} 82 83# PERL5OPT Command-line options (switches). Switches in 84# this variable are taken as if they were on 85# every Perl command line. Only the -[DIMUdmtw] 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 93try({PERL5OPT => '-w'}, ['-e', 'print $::x'], 94 "", 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}); 96 97try({PERL5OPT => '-Mstrict'}, ['-I../lib', '-e', 'print $::x'], 98 "", ""); 99 100try({PERL5OPT => '-Mstrict'}, ['-I../lib', '-e', 'print $x'], 101 "", 102 qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n}); 103 104# Fails in 5.6.0 105try({PERL5OPT => '-Mstrict -w'}, ['-I../lib', '-e', 'print $x'], 106 "", 107 qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n}); 108 109# Fails in 5.6.0 110try({PERL5OPT => '-w -Mstrict'}, ['-I../lib', '-e', 'print $::x'], 111 "", 112 <<ERROR 113Name "main::x" used only once: possible typo at -e line 1. 114Use of uninitialized value \$x in print at -e line 1. 115ERROR 116 ); 117 118# Fails in 5.6.0 119try({PERL5OPT => '-w -Mstrict'}, ['-I../lib', '-e', 'print $::x'], 120 "", 121 <<ERROR 122Name "main::x" used only once: possible typo at -e line 1. 123Use of uninitialized value \$x in print at -e line 1. 124ERROR 125 ); 126 127try({PERL5OPT => '-MExporter'}, ['-I../lib', '-e0'], 128 "", 129 ""); 130 131# Fails in 5.6.0 132try({PERL5OPT => '-MExporter -MExporter'}, ['-I../lib', '-e0'], 133 "", 134 ""); 135 136try({PERL5OPT => '-Mstrict -Mwarnings'}, 137 ['-I../lib', '-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'], 138 "ok", 139 ""); 140 141open my $fh, ">", "Oooof.pm" or die "Can't write Oooof.pm: $!"; 142print $fh "package Oooof; 1;\n"; 143close $fh; 144END { 1 while unlink "Oooof.pm" } 145 146try({PERL5OPT => '-I. -MOooof'}, 147 ['-e', 'print "ok" if $INC{"Oooof.pm"} eq "Oooof.pm"'], 148 "ok", 149 ""); 150 151try({PERL5OPT => '-I./ -MOooof'}, 152 ['-e', 'print "ok" if $INC{"Oooof.pm"} eq "Oooof.pm"'], 153 "ok", 154 ""); 155 156try({PERL5OPT => '-w -w'}, 157 ['-e', 'print $ENV{PERL5OPT}'], 158 '-w -w', 159 ''); 160 161try({PERL5OPT => '-t'}, 162 ['-e', 'print ${^TAINT}'], 163 '-1', 164 ''); 165 166try({PERL5OPT => '-W'}, 167 ['-I../lib','-e', 'local $^W = 0; no warnings; print $x'], 168 '', 169 <<ERROR 170Name "main::x" used only once: possible typo at -e line 1. 171Use of uninitialized value \$x in print at -e line 1. 172ERROR 173); 174 175try({PERLLIB => "foobar$Config{path_sep}42"}, 176 ['-e', 'print grep { $_ eq "foobar" } @INC'], 177 'foobar', 178 ''); 179 180try({PERLLIB => "foobar$Config{path_sep}42"}, 181 ['-e', 'print grep { $_ eq "42" } @INC'], 182 '42', 183 ''); 184 185try({PERL5LIB => "foobar$Config{path_sep}42"}, 186 ['-e', 'print grep { $_ eq "foobar" } @INC'], 187 'foobar', 188 ''); 189 190try({PERL5LIB => "foobar$Config{path_sep}42"}, 191 ['-e', 'print grep { $_ eq "42" } @INC'], 192 '42', 193 ''); 194 195try({PERL5LIB => "foo", 196 PERLLIB => "bar"}, 197 ['-e', 'print grep { $_ eq "foo" } @INC'], 198 'foo', 199 ''); 200 201try({PERL5LIB => "foo", 202 PERLLIB => "bar"}, 203 ['-e', 'print grep { $_ eq "bar" } @INC'], 204 '', 205 ''); 206 207try({PERL_HASH_SEED_DEBUG => 1}, 208 ['-e','1'], 209 '', 210 qr/HASH_FUNCTION =/); 211 212try({PERL_HASH_SEED_DEBUG => 1}, 213 ['-e','1'], 214 '', 215 qr/HASH_SEED =/); 216 217# special case, seed "0" implies disabled hash key traversal randomization 218try({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". 225try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "0x0"}, 226 ['-e','1'], 227 '', 228 qr/PERTURB_KEYS = 2/); 229 230try({PERL_HASH_SEED_DEBUG => 1, PERL_PERTURB_KEYS => "0"}, 231 ['-e','1'], 232 '', 233 qr/PERTURB_KEYS = 0/); 234 235try({PERL_HASH_SEED_DEBUG => 1, PERL_PERTURB_KEYS => "1"}, 236 ['-e','1'], 237 '', 238 qr/PERTURB_KEYS = 1/); 239 240try({PERL_HASH_SEED_DEBUG => 1, PERL_PERTURB_KEYS => "2"}, 241 ['-e','1'], 242 '', 243 qr/PERTURB_KEYS = 2/); 244 245try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "12345678"}, 246 ['-e','1'], 247 '', 248 qr/HASH_SEED = 0x12345678/); 249 250try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "12"}, 251 ['-e','1'], 252 '', 253 qr/HASH_SEED = 0x12000000/); 254 255try({PERL_HASH_SEED_DEBUG => 1, PERL_HASH_SEED => "123456789"}, 256 ['-e','1'], 257 '', 258 qr/HASH_SEED = 0x12345678/); 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. 262my @print_keys = ( '-e', '@_{"A".."Z"}=(); print keys %_'); 263for 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 278# Tests for S_incpush_use_sep(): 279 280my @dump_inc = ('-e', 'print "$_\n" foreach @INC'); 281 282my ($out, $err) = runperl_and_capture({}, [@dump_inc]); 283 284is ($err, '', 'No errors when determining @INC'); 285 286my @default_inc = split /\n/, $out; 287 288is ($default_inc[-1], '.', '. is last in @INC'); 289 290my $sep = $Config{path_sep}; 291foreach (['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 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 322# PERL5LIB tests with included arch directories still missing 323