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 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 = $ENV{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) = @_;
  74   my ($actual_stdout, $actual_stderr) = runperl_and_capture($env, $args);
  75   local $::Level = $::Level + 1;
  76   is ($stdout, $actual_stdout);
  77   is ($stderr, $actual_stderr);
  78 }
  79
  80 #  PERL5OPT    Command-line options (switches).  Switches in
  81 #                    this variable are taken as if they were on
  82 #                    every Perl command line.  Only the -[DIMUdmtw]
  83 #                    switches are allowed.  When running taint
  84 #                    checks (because the program was running setuid
  85 #                    or setgid, or the -T switch was used), this
  86 #                    variable is ignored.  If PERL5OPT begins with
  87 #                    -T, tainting will be enabled, and any
  88 #                    subsequent options ignored.
  89
  90 try({PERL5OPT => '-w'}, ['-e', '"print $::x"'],
  91     "",
  92     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}));
  93
  94 try({PERL5OPT => '-Mstrict'}, ['-I..\lib', '-e', '"print $::x"'],
  95     "", "");
  96
  97 try({PERL5OPT => '-Mstrict'}, ['-I..\lib', '-e', '"print $x"'],
  98     "",
  99     qq(Global symbol "\$x" requires explicit package name at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL}));
 100
 101 # Fails in 5.6.0
 102 try({PERL5OPT => '-Mstrict -w'}, ['-I..\lib', '-e', '"print $x"'],
 103     "",
 104     qq(Global symbol "\$x" requires explicit package name at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL}));
 105
 106 # Fails in 5.6.0
 107 try({PERL5OPT => '-w -Mstrict'}, ['-I..\lib', '-e', '"print $::x"'],
 108     "",
 109     <<ERROR
 110 Name "main::x" used only once: possible typo at -e line 1.
 111 Use of uninitialized value \$x in print at -e line 1.
 112 ERROR
 113     );
 114
 115 # Fails in 5.6.0
 116 try({PERL5OPT => '-w -Mstrict'}, ['-I..\lib', '-e', '"print $::x"'],
 117     "",
 118     <<ERROR
 119 Name "main::x" used only once: possible typo at -e line 1.
 120 Use of uninitialized value \$x in print at -e line 1.
 121 ERROR
 122     );
 123
 124 try({PERL5OPT => '-MExporter'}, ['-I..\lib', '-e0'],
 125     "",
 126     "");
 127
 128 # Fails in 5.6.0
 129 try({PERL5OPT => '-MExporter -MExporter'}, ['-I..\lib', '-e0'],
 130     "",
 131     "");
 132
 133 try({PERL5OPT => '-Mstrict -Mwarnings'},
 134     ['-I..\lib', '-e', '"print \"ok\" if $INC{\"strict.pm\"} and $INC{\"warnings.pm\"}"'],
 135     "ok",
 136     "");
 137
 138 open my $fh, ">", "Oooof.pm" or die "Can't write Oooof.pm: $!";
 139 print $fh "package Oooof; 1;\n";
 140 close $fh;
 141 END { 1 while unlink "Oooof.pm" }
 142
 143 try({PERL5OPT => '-I. -MOooof'},
 144     ['-e', '"print \"ok\" if $INC{\"Oooof.pm\"} eq \"Oooof.pm\""'],
 145     "ok",
 146     "");
 147
 148 try({PERL5OPT => '-w -w'},
 149     ['-e', '"print $ENV{PERL5OPT}"'],
 150     '-w -w',
 151     '');
 152
 153 try({PERL5OPT => '-t'},
 154     ['-e', '"print ${^TAINT}"'],
 155     '-1',
 156     '');
 157
 158 try({PERL5OPT => '-W'},
 159     ['-I..\lib','-e', '"local $^W = 0;  no warnings;  print $x"'],
 160     '',
 161     <<ERROR
 162 Name "main::x" used only once: possible typo at -e line 1.
 163 Use of uninitialized value \$x in print at -e line 1.
 164 ERROR
 165 );
 166
 167 try({PERLLIB => "foobar$Config{path_sep}42"},
 168     ['-e', '"print grep { $_ eq \"foobar\" } @INC"'],
 169     'foobar',
 170     '');
 171
 172 try({PERLLIB => "foobar$Config{path_sep}42"},
 173     ['-e', '"print grep { $_ eq \"42\" } @INC"'],
 174     '42',
 175     '');
 176
 177 try({PERL5LIB => "foobar$Config{path_sep}42"},
 178     ['-e', '"print grep { $_ eq \"foobar\" } @INC"'],
 179     'foobar',
 180     '');
 181
 182 try({PERL5LIB => "foobar$Config{path_sep}42"},
 183     ['-e', '"print grep { $_ eq \"42\" } @INC"'],
 184     '42',
 185     '');
 186
 187 try({PERL5LIB => "foo",
 188      PERLLIB => "bar"},
 189     ['-e', '"print grep { $_ eq \"foo\" } @INC"'],
 190     'foo',
 191     '');
 192
 193 try({PERL5LIB => "foo",
 194      PERLLIB => "bar"},
 195     ['-e', '"print grep { $_ eq \"bar\" } @INC"'],
 196     '',
 197     '');
 198
 199 # Tests for S_incpush_use_sep():
 200
 201 my @dump_inc = ('-e', '"print \"$_\n\" foreach @INC"');
 202
 203 my ($out, $err) = runperl_and_capture({}, [@dump_inc]);
 204
 205 is ($err, '', 'No errors when determining @INC');
 206
 207 my @default_inc = split /\n/, $out;
 208
 209 is ($default_inc[-1], '.', '. is last in @INC');
 210
 211 my $sep = $Config{path_sep};
 212 my @test_cases = (
 213          ['nothing', ''],
 214          ['something', 'zwapp', 'zwapp'],
 215          ['two things', "zwapp${sep}bam", 'zwapp', 'bam'],
 216          ['two things, ::', "zwapp${sep}${sep}bam", 'zwapp', 'bam'],
 217          [': at start', "${sep}zwapp", 'zwapp'],
 218          [': at end', "zwapp${sep}", 'zwapp'],
 219          [':: sandwich ::', "${sep}${sep}zwapp${sep}${sep}", 'zwapp'],
 220          [':', "${sep}"],
 221          ['::', "${sep}${sep}"],
 222          [':::', "${sep}${sep}${sep}"],
 223          ['two things and :', "zwapp${sep}bam${sep}", 'zwapp', 'bam'],
 224          [': and two things', "${sep}zwapp${sep}bam", 'zwapp', 'bam'],
 225          [': two things :', "${sep}zwapp${sep}bam${sep}", 'zwapp', 'bam'],
 226          ['three things', "zwapp${sep}bam${sep}${sep}owww",
 227           'zwapp', 'bam', 'owww'],
 228 );
 229
 230 # This block added to verify fix for RT #87322
 231 if ($::os_id == 2 and $::os_major == 6) {    # Vista, Server 2008 (incl R2), 7
 232   my @big_perl5lib = ('z' x 16) x 2049;
 233     push @testcases, [
 234         'enough items so PERL5LIB val is longer than 32k',
 235         join($sep, @big_perl5lib), @big_perl5lib,
 236     ];
 237 }
 238
 239 foreach ( @testcases ) {
 240   my ($name, $lib, @expect) = @$_;
 241   push @expect, @default_inc;
 242
 243   ($out, $err) = runperl_and_capture({PERL5LIB => $lib}, [@dump_inc]);
 244
 245   is ($err, '', "No errors when determining \@INC for $name");
 246
 247   my @inc = split /\n/, $out;
 248
 249   is (scalar @inc, scalar @expect,
 250       "expected number of elements in \@INC for $name");
 251
 252   is ("@inc", "@expect", "expected elements in \@INC for $name");
 253 }