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