t/win32/runenv.t

   1 #!./perl
   2 #
   3 # Tests for Perl run-time environment variable settings
   4 # Clone of t/run/runenv.t but without the forking, and with cmd.exe-friendly -e syntax.
   5 #
   6 # $PERL5OPT, $PERL5LIB, etc.
   7
   8 BEGIN {
   9     chdir 't' if -d 't';
  10     @INC = '../lib';
  11     require Config; import Config;
  12     require File::Temp; import File::Temp qw/:POSIX/;
  13
  14     require Win32;
  15     ($::os_id, $::os_major) = ( Win32::GetOSVersion() )[ 4, 1 ];
  16     if ($::os_id == 2 and $::os_major == 6) {    # Vista, Server 2008 (incl R2), 7
  17         $::tests = 45;
  18     }
  19     else {
  20         $::tests = 42;
  21     }
  22
  23     require './test.pl';
  24 }
  25
  26 skip_all "requires compilation with PERL_IMPLICIT_SYS"
  27   unless $Config{ccflags} =~/(?:\A|\s)-DPERL_IMPLICIT_SYS\b/;
  28
  29 plan tests => $::tests;
  30
  31 my $PERL = '.\perl';
  32 my $NL = $/;
  33
  34 delete $ENV{PERLLIB};
  35 delete $ENV{PERL5LIB};
  36 delete $ENV{PERL5OPT};
  37
  38
  39 # Run perl with specified environment and arguments, return (STDOUT, STDERR)
  40 sub runperl_and_capture {
  41   my ($env, $args) = @_;
  42
  43   # Clear out old env
  44   local %ENV = %ENV;
  45   delete $ENV{PERLLIB};
  46   delete $ENV{PERL5LIB};
  47   delete $ENV{PERL5OPT};
  48
  49   # Populate with our desired env
  50   for my $k (keys %$env) {
  51      $ENV{$k} = $env->{$k};
  52   }
  53
  54   # This is slightly expensive, but this is more reliable than
  55   # trying to emulate fork(), and we still get STDERR and STDOUT individually.
  56   my $stderr_cache = tmpnam();
  57   my $stdout = `$PERL @$args 2>$stderr_cache`;
  58   my $stderr = '';
  59   if (-s $stderr_cache) {
  60     open(my $stderr_cache_fh, "<", $stderr_cache)
  61       or die "Could not retrieve STDERR output: $!";
  62     while ( defined(my $s_line = <$stderr_cache_fh>) ) {
  63       $stderr .= $s_line;
  64     }
  65     close $stderr_cache_fh;
  66     unlink $stderr_cache;
  67   }
  68
  69   return ($stdout, $stderr);
  70 }
  71
  72 sub try {
  73   my ($env, $args, $stdout, $stderr, $name) = @_;
  74   my ($actual_stdout, $actual_stderr) = runperl_and_capture($env, $args);
  75   $name ||= "";
  76   local $::Level = $::Level + 1;
  77   is $actual_stdout, $stdout, "$name - stdout";
  78   is $actual_stderr, $stderr, "$name - stderr";
  79 }
  80
  81 #  PERL5OPT    Command-line options (switches).  Switches in
  82 #                    this variable are taken as if they were on
  83 #                    every Perl command line.  Only the -[DIMUdmtw]
  84 #                    switches are allowed.  When running taint
  85 #                    checks (because the program was running setuid
  86 #                    or setgid, or the -T switch was used), this
  87 #                    variable is ignored.  If PERL5OPT begins with
  88 #                    -T, tainting will be enabled, and any
  89 #                    subsequent options ignored.
  90
  91 try({PERL5OPT => '-w'}, ['-e', '"print $::x"'],
  92     "",
  93     qq(Name "main::x" used only once: possible typo at -e line 1.${NL}Use of uninitialized value \$x in print at -e line 1.${NL}));
  94
  95 try({PERL5OPT => '-Mstrict'}, ['-I..\lib', '-e', '"print $::x"'],
  96     "", "");
  97
  98 try({PERL5OPT => '-Mstrict'}, ['-I..\lib', '-e', '"print $x"'],
  99     "",
 100     qq(Global symbol "\$x" requires explicit package name (did you forget to declare "my \$x"?) at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL}));
 101
 102 # Fails in 5.6.0
 103 try({PERL5OPT => '-Mstrict -w'}, ['-I..\lib', '-e', '"print $x"'],
 104     "",
 105     qq(Global symbol "\$x" requires explicit package name (did you forget to declare "my \$x"?) at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL}));
 106
 107 # Fails in 5.6.0
 108 try({PERL5OPT => '-w -Mstrict'}, ['-I..\lib', '-e', '"print $::x"'],
 109     "",
 110     <<ERROR
 111 Name "main::x" used only once: possible typo at -e line 1.
 112 Use of uninitialized value \$x in print at -e line 1.
 113 ERROR
 114     );
 115
 116 # Fails in 5.6.0
 117 try({PERL5OPT => '-w -Mstrict'}, ['-I..\lib', '-e', '"print $::x"'],
 118     "",
 119     <<ERROR
 120 Name "main::x" used only once: possible typo at -e line 1.
 121 Use of uninitialized value \$x in print at -e line 1.
 122 ERROR
 123     );
 124
 125 try({PERL5OPT => '-MExporter'}, ['-I..\lib', '-e0'],
 126     "",
 127     "");
 128
 129 # Fails in 5.6.0
 130 try({PERL5OPT => '-MExporter -MExporter'}, ['-I..\lib', '-e0'],
 131     "",
 132     "");
 133
 134 try({PERL5OPT => '-Mstrict -Mwarnings'},
 135     ['-I..\lib', '-e', '"print \"ok\" if $INC{\"strict.pm\"} and $INC{\"warnings.pm\"}"'],
 136     "ok",
 137     "");
 138
 139 open my $fh, ">", "Oooof.pm" or die "Can't write Oooof.pm: $!";
 140 print $fh "package Oooof; 1;\n";
 141 close $fh;
 142 END { 1 while unlink "Oooof.pm" }
 143
 144 try({PERL5OPT => '-I. -MOooof'},
 145     ['-e', '"print \"ok\" if $INC{\"Oooof.pm\"} eq \"Oooof.pm\""'],
 146     "ok",
 147     "");
 148
 149 try({PERL5OPT => '-w -w'},
 150     ['-e', '"print $ENV{PERL5OPT}"'],
 151     '-w -w',
 152     '');
 153
 154 try({PERL5OPT => '-t'},
 155     ['-e', '"print ${^TAINT}"'],
 156     '-1',
 157     '');
 158
 159 try({PERL5OPT => '-W'},
 160     ['-I..\lib','-e', '"local $^W = 0;  no warnings;  print $x"'],
 161     '',
 162     <<ERROR
 163 Name "main::x" used only once: possible typo at -e line 1.
 164 Use of uninitialized value \$x in print at -e line 1.
 165 ERROR
 166 );
 167
 168 try({PERLLIB => "foobar$Config{path_sep}42"},
 169     ['-e', '"print grep { $_ eq \"foobar\" } @INC"'],
 170     'foobar',
 171     '');
 172
 173 try({PERLLIB => "foobar$Config{path_sep}42"},
 174     ['-e', '"print grep { $_ eq \"42\" } @INC"'],
 175     '42',
 176     '');
 177
 178 try({PERL5LIB => "foobar$Config{path_sep}42"},
 179     ['-e', '"print grep { $_ eq \"foobar\" } @INC"'],
 180     'foobar',
 181     '');
 182
 183 try({PERL5LIB => "foobar$Config{path_sep}42"},
 184     ['-e', '"print grep { $_ eq \"42\" } @INC"'],
 185     '42',
 186     '');
 187
 188 try({PERL5LIB => "foo",
 189      PERLLIB => "bar"},
 190     ['-e', '"print grep { $_ eq \"foo\" } @INC"'],
 191     'foo',
 192     '');
 193
 194 try({PERL5LIB => "foo",
 195      PERLLIB => "bar"},
 196     ['-e', '"print grep { $_ eq \"bar\" } @INC"'],
 197     '',
 198     '');
 199
 200 {
 201     # 131665
 202     # crashes without the fix
 203     my $longname = "X" x 2048;
 204     try({ $longname => 1 },
 205         [ '-e', '"print q/ok/"' ],
 206         'ok', '',
 207         'very long env var names' );
 208 }
 209
 210 # Tests for S_incpush_use_sep():
 211
 212 my @dump_inc = ('-e', '"print \"$_\n\" foreach @INC"');
 213
 214 my ($out, $err) = runperl_and_capture({}, [@dump_inc]);
 215
 216 is ($err, '', 'No errors when determining @INC');
 217
 218 my @default_inc = split /\n/, $out;
 219
 220 if ($Config{default_inc_excludes_dot}) {
 221     ok !(grep { $_ eq '.' } @default_inc), '. is not in @INC';
 222 }
 223 else {
 224     is ($default_inc[-1], '.', '. is last in @INC');
 225 }
 226
 227 my $sep = $Config{path_sep};
 228 my @test_cases = (
 229          ['nothing', ''],
 230          ['something', 'zwapp', 'zwapp'],
 231          ['two things', "zwapp${sep}bam", 'zwapp', 'bam'],
 232          ['two things, ::', "zwapp${sep}${sep}bam", 'zwapp', 'bam'],
 233          [': at start', "${sep}zwapp", 'zwapp'],
 234          [': at end', "zwapp${sep}", 'zwapp'],
 235          [':: sandwich ::', "${sep}${sep}zwapp${sep}${sep}", 'zwapp'],
 236          [':', "${sep}"],
 237          ['::', "${sep}${sep}"],
 238          [':::', "${sep}${sep}${sep}"],
 239          ['two things and :', "zwapp${sep}bam${sep}", 'zwapp', 'bam'],
 240          [': and two things', "${sep}zwapp${sep}bam", 'zwapp', 'bam'],
 241          [': two things :', "${sep}zwapp${sep}bam${sep}", 'zwapp', 'bam'],
 242          ['three things', "zwapp${sep}bam${sep}${sep}owww",
 243           'zwapp', 'bam', 'owww'],
 244 );
 245
 246 # This block added to verify fix for RT #87322
 247 if ($::os_id == 2 and $::os_major == 6) {    # Vista, Server 2008 (incl R2), 7
 248   my @big_perl5lib = ('z' x 16) x 2049;
 249     push @testcases, [
 250         'enough items so PERL5LIB val is longer than 32k',
 251         join($sep, @big_perl5lib), @big_perl5lib,
 252     ];
 253 }
 254
 255 foreach ( @testcases ) {
 256   my ($name, $lib, @expect) = @$_;
 257   push @expect, @default_inc;
 258
 259   ($out, $err) = runperl_and_capture({PERL5LIB => $lib}, [@dump_inc]);
 260
 261   is ($err, '', "No errors when determining \@INC for $name");
 262
 263   my @inc = split /\n/, $out;
 264
 265   is (scalar @inc, scalar @expect,
 266       "expected number of elements in \@INC for $name");
 267
 268   is ("@inc", "@expect", "expected elements in \@INC for $name");
 269 }