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 => 104;
  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
  26
  27 # Run perl with specified environment and arguments, return (STDOUT, STDERR)
  28 sub 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
  62 sub 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
  93 try({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
  97 try({PERL5OPT => '-Mstrict'}, ['-I../lib', '-e', 'print $::x'],
  98     "", "");
  99
 100 try({PERL5OPT => '-Mstrict'}, ['-I../lib', '-e', 'print $x'],
 101     "",
 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});
 103
 104 # Fails in 5.6.0
 105 try({PERL5OPT => '-Mstrict -w'}, ['-I../lib', '-e', 'print $x'],
 106     "",
 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});
 108
 109 # Fails in 5.6.0
 110 try({PERL5OPT => '-w -Mstrict'}, ['-I../lib', '-e', 'print $::x'],
 111     "",
 112     <<ERROR
 113 Name "main::x" used only once: possible typo at -e line 1.
 114 Use of uninitialized value \$x in print at -e line 1.
 115 ERROR
 116     );
 117
 118 # Fails in 5.6.0
 119 try({PERL5OPT => '-w -Mstrict'}, ['-I../lib', '-e', 'print $::x'],
 120     "",
 121     <<ERROR
 122 Name "main::x" used only once: possible typo at -e line 1.
 123 Use of uninitialized value \$x in print at -e line 1.
 124 ERROR
 125     );
 126
 127 try({PERL5OPT => '-MExporter'}, ['-I../lib', '-e0'],
 128     "",
 129     "");
 130
 131 # Fails in 5.6.0
 132 try({PERL5OPT => '-MExporter -MExporter'}, ['-I../lib', '-e0'],
 133     "",
 134     "");
 135
 136 try({PERL5OPT => '-Mstrict -Mwarnings'},
 137     ['-I../lib', '-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'],
 138     "ok",
 139     "");
 140
 141 open my $fh, ">", "Oooof.pm" or die "Can't write Oooof.pm: $!";
 142 print $fh "package Oooof; 1;\n";
 143 close $fh;
 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
 156 try({PERL5OPT => '-w -w'},
 157     ['-e', 'print $ENV{PERL5OPT}'],
 158     '-w -w',
 159     '');
 160
 161 try({PERL5OPT => '-t'},
 162     ['-e', 'print ${^TAINT}'],
 163     '-1',
 164     '');
 165
 166 try({PERL5OPT => '-W'},
 167     ['-I../lib','-e', 'local $^W = 0;  no warnings;  print $x'],
 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
 175 try({PERLLIB => "foobar$Config{path_sep}42"},
 176     ['-e', 'print grep { $_ eq "foobar" } @INC'],
 177     'foobar',
 178     '');
 179
 180 try({PERLLIB => "foobar$Config{path_sep}42"},
 181     ['-e', 'print grep { $_ eq "42" } @INC'],
 182     '42',
 183     '');
 184
 185 try({PERL5LIB => "foobar$Config{path_sep}42"},
 186     ['-e', 'print grep { $_ eq "foobar" } @INC'],
 187     'foobar',
 188     '');
 189
 190 try({PERL5LIB => "foobar$Config{path_sep}42"},
 191     ['-e', 'print grep { $_ eq "42" } @INC'],
 192     '42',
 193     '');
 194
 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
 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
 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
 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/);
 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
 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
 288 if ($Config{default_inc_excludes_dot}) {
 289     ok !(grep { $_ eq '.' } @default_inc), '. is not in @INC';
 290 }
 291 else {
 292     is ($default_inc[-1], '.', '. is last in @INC');
 293 }
 294
 295 my $sep = $Config{path_sep};
 296 foreach (['nothing', ''],
 297          ['something', 'zwapp', 'zwapp'],
 298          ['two things', "zwapp${sep}bam", 'zwapp', 'bam'],
 299          ['two things, ::', "zwapp${sep}${sep}bam", 'zwapp', 'bam'],
 300          [': at start', "${sep}zwapp", 'zwapp'],
 301          [': at end', "zwapp${sep}", 'zwapp'],
 302          [':: sandwich ::', "${sep}${sep}zwapp${sep}${sep}", 'zwapp'],
 303          [':', "${sep}"],
 304          ['::', "${sep}${sep}"],
 305          [':::', "${sep}${sep}${sep}"],
 306          ['two things and :', "zwapp${sep}bam${sep}", 'zwapp', 'bam'],
 307          [': and two things', "${sep}zwapp${sep}bam", 'zwapp', 'bam'],
 308          [': two things :', "${sep}zwapp${sep}bam${sep}", 'zwapp', 'bam'],
 309          ['three things', "zwapp${sep}bam${sep}${sep}owww",
 310           'zwapp', 'bam', 'owww'],
 311         ) {
 312   my ($name, $lib, @expect) = @$_;
 313   push @expect, @default_inc;
 314
 315   ($out, $err) = runperl_and_capture({PERL5LIB => $lib}, [@dump_inc]);
 316
 317   is ($err, '', "No errors when determining \@INC for $name");
 318
 319   my @inc = split /\n/, $out;
 320
 321   is (scalar @inc, scalar @expect,
 322       "expected number of elements in \@INC for $name");
 323
 324   is ("@inc", "@expect", "expected elements in \@INC for $name");
 325 }
 326
 327 # PERL5LIB tests with included arch directories still missing