t/run/runenv.t

   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';
  10     require Config; import Config;
  11     require './test.pl';
  12     skip_all_without_config('d_fork');
  13 }
  14
  15 plan tests => 106;
  16
  17 my $STDOUT = tempfile();
  18 my $STDERR = tempfile();
  19 my $PERL = './perl';
  20 my $FAILURE_CODE = 119;
  21
  22 delete $ENV{PERLLIB};
  23 delete $ENV{PERL5LIB};
  24 delete $ENV{PERL5OPT};
  25 delete $ENV{PERL_USE_UNSAFE_INC};
  26
  27
  28 # Run perl with specified environment and arguments, return (STDOUT, STDERR)
  29 sub runperl_and_capture {
  30   local *F;
  31   my ($env, $args) = @_;
  32
  33   local %ENV = %ENV;
  34   delete $ENV{PERLLIB};
  35   delete $ENV{PERL5LIB};
  36   delete $ENV{PERL5OPT};
  37   delete $ENV{PERL_USE_UNSAFE_INC};
  38   my $pid = fork;
  39   return (0, "Couldn't fork: $!") unless defined $pid;   # failure
  40   if ($pid) {                   # parent
  41     wait;
  42     return (0, "Failure in child.\n") if ($?>>8) == $FAILURE_CODE;
  43
  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>);
  52   } else {                      # child
  53     for my $k (keys %$env) {
  54       $ENV{$k} = $env->{$k};
  55     }
  56     open STDOUT, '>', $STDOUT or exit $FAILURE_CODE;
  57     open STDERR, '>', $STDERR and do { exec $PERL, @$args };
  58     # it did not work:
  59     print STDOUT "IWHCWJIHCI\cNHJWCJQWKJQJWCQW\n";
  60     exit $FAILURE_CODE;
  61   }
  62 }
  63
  64 sub try {
  65   my ($env, $args, $stdout, $stderr) = @_;
  66   my ($actual_stdout, $actual_stderr) = runperl_and_capture($env, $args);
  67   local $::Level = $::Level + 1;
  68   my @envpairs = ();
  69   for my $k (sort keys %$env) {
  70     push @envpairs, "$k => $env->{$k}";
  71   }
  72   my $label = join(',' => (@envpairs, @$args));
  73   if (ref $stdout) {
  74     ok ( $actual_stdout =~/$stdout/, $label . ' stdout' );
  75   } else {
  76     is ( $actual_stdout, $stdout, $label . ' stdout' );
  77   }
  78   if (ref $stderr) {
  79     ok ( $actual_stderr =~/$stderr/, $label . ' stderr' );
  80   } else {
  81     is ( $actual_stderr, $stderr, $label . ' stderr' );
  82   }
  83 }
  84
  85 #  PERL5OPT    Command-line options (switches).  Switches in
  86 #                    this variable are taken as if they were on
  87 #                    every Perl command line.  Only the -[DIMUdmtw]
  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
  95 try({PERL5OPT => '-w'}, ['-e', 'print $::x'],
  96     "",
  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});
  98
  99 try({PERL5OPT => '-Mstrict'}, ['-I../lib', '-e', 'print $::x'],
 100     "", "");
 101
 102 try({PERL5OPT => '-Mstrict'}, ['-I../lib', '-e', 'print $x'],
 103     "",
 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});
 105
 106 # Fails in 5.6.0
 107 try({PERL5OPT => '-Mstrict -w'}, ['-I../lib', '-e', 'print $x'],
 108     "",
 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});
 110
 111 # Fails in 5.6.0
 112 try({PERL5OPT => '-w -Mstrict'}, ['-I../lib', '-e', 'print $::x'],
 113     "",
 114     <<ERROR
 115 Name "main::x" used only once: possible typo at -e line 1.
 116 Use of uninitialized value \$x in print at -e line 1.
 117 ERROR
 118     );
 119
 120 # Fails in 5.6.0
 121 try({PERL5OPT => '-w -Mstrict'}, ['-I../lib', '-e', 'print $::x'],
 122     "",
 123     <<ERROR
 124 Name "main::x" used only once: possible typo at -e line 1.
 125 Use of uninitialized value \$x in print at -e line 1.
 126 ERROR
 127     );
 128
 129 try({PERL5OPT => '-MExporter'}, ['-I../lib', '-e0'],
 130     "",
 131     "");
 132
 133 # Fails in 5.6.0
 134 try({PERL5OPT => '-MExporter -MExporter'}, ['-I../lib', '-e0'],
 135     "",
 136     "");
 137
 138 try({PERL5OPT => '-Mstrict -Mwarnings'},
 139     ['-I../lib', '-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'],
 140     "ok",
 141     "");
 142
 143 open my $fh, ">", "tmpOooof.pm" or die "Can't write tmpOooof.pm: $!";
 144 print $fh "package tmpOooof; 1;\n";
 145 close $fh;
 146 END { 1 while unlink "tmpOooof.pm" }
 147
 148 try({PERL5OPT => '-I. -MtmpOooof'},
 149     ['-e', 'print "ok" if $INC{"tmpOooof.pm"} eq "tmpOooof.pm"'],
 150     "ok",
 151     "");
 152
 153 try({PERL5OPT => '-I./ -MtmpOooof'},
 154     ['-e', 'print "ok" if $INC{"tmpOooof.pm"} eq "tmpOooof.pm"'],
 155     "ok",
 156     "");
 157
 158 try({PERL5OPT => '-w -w'},
 159     ['-e', 'print $ENV{PERL5OPT}'],
 160     '-w -w',
 161     '');
 162
 163 try({PERL5OPT => '-t'},
 164     ['-e', 'print ${^TAINT}'],
 165     '-1',
 166     '');
 167
 168 try({PERL5OPT => '-W'},
 169     ['-I../lib','-e', 'local $^W = 0;  no warnings;  print $x'],
 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
 177 try({PERLLIB => "foobar$Config{path_sep}42"},
 178     ['-e', 'print grep { $_ eq "foobar" } @INC'],
 179     'foobar',
 180     '');
 181
 182 try({PERLLIB => "foobar$Config{path_sep}42"},
 183     ['-e', 'print grep { $_ eq "42" } @INC'],
 184     '42',
 185     '');
 186
 187 try({PERL5LIB => "foobar$Config{path_sep}42"},
 188     ['-e', 'print grep { $_ eq "foobar" } @INC'],
 189     'foobar',
 190     '');
 191
 192 try({PERL5LIB => "foobar$Config{path_sep}42"},
 193     ['-e', 'print grep { $_ eq "42" } @INC'],
 194     '42',
 195     '');
 196
 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
 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 }
 224
 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");
 289         }
 290     }
 291 }
 292
 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
 303 SKIP: {
 304   skip_if_miniperl("under miniperl", 3);
 305 if ($Config{default_inc_excludes_dot}) {
 306     ok !(grep { $_ eq '.' } @default_inc), '. is not in @INC';
 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;
 315 }
 316 else {
 317     is ($default_inc[-1], '.', '. is last in @INC');
 318     skip('Not testing unsafe @INC when it includes . by default', 2);
 319 }
 320 }
 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
 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
 354 # PERL5LIB tests with included arch directories still missing