diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | pod/perldelta.pod | 27 | ||||
| -rw-r--r-- | t/win32/runenv.t | 250 | ||||
| -rw-r--r-- | win32/win32.c | 36 |
4 files changed, 308 insertions, 6 deletions
@@ -5176,6 +5176,7 @@ t/uni/tr_sjis.t See if Unicode tr/// in sjis works t/uni/tr_utf8.t See if Unicode tr/// in utf8 works t/uni/upper.t See if Unicode casing works t/uni/write.t See if Unicode formats work +t/win32/runenv.t Test if Win* perl honors its env variables t/win32/system.t See if system works in Win* t/win32/system_tests Test runner for system.t t/x2p/s2p.t See if s2p/psed work diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 639bce52c4..e0414082a3 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -532,6 +532,12 @@ and if calling C<dtrace> actually lets you instrument code. This generally requires being run as root, so this test file is primarily intended for use by the dtrace subcommittee of p5p. +=item * + +F<t/win32/runenv.t> was added to test aspects of Perl's environment +variable handling on MSWin32 platforms. Previously, such tests were +skipped on MSWin32 platforms. + =back =head1 Platform Support @@ -575,9 +581,26 @@ and compilation changes or changes in portability/compatibility. However, changes within modules for platforms should generally be listed in the L</Modules and Pragmata> section. -=over 4 +=head3 Windows -=item XXX-some-platform +=over + +=item * + +On Windows 7, 2008 and Vista, C<@INC> is now always properly populated +based on the value of PERL5LIB set in the environment. Previously, +values of PERL5LIB longer than 32766 bytes were skipped when C<@INC> +was being populated. Tests for environment handling were +also added (see L</Testing> section). Fixes +L<RT #87322|https://rt.perl.org/rt3/Public/Bug/Display.html?id=87322>. + +=back + +=head3 XXX-some-platform + +=over + +=item * XXX diff --git a/t/win32/runenv.t b/t/win32/runenv.t new file mode 100644 index 0000000000..2576168646 --- /dev/null +++ b/t/win32/runenv.t @@ -0,0 +1,250 @@ +#!./perl +# +# Tests for Perl run-time environment variable settings +# Clone of t/run/runenv.t but without the forking, and with cmd.exe-friendly -e syntax. +# +# $PERL5OPT, $PERL5LIB, etc. + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + require File::Temp; import File::Temp qw/:POSIX/; + + require Win32; + ($::os_id, $::os_major) = ( Win32::GetOSVersion() )[ 4, 1 ]; + if ($::os_id == 2 and $::os_major == 6) { # Vista, Server 2008 (incl R2), 7 + $::tests = 43; + } + else { + $::tests = 42; + } + + require './test.pl'; +} + +plan tests => $::tests; + +my $PERL = $ENV{PERL} || '.\perl'; +my $NL = $/; + +delete $ENV{PERLLIB}; +delete $ENV{PERL5LIB}; +delete $ENV{PERL5OPT}; + + +# Run perl with specified environment and arguments, return (STDOUT, STDERR) +sub runperl_and_capture { + my ($env, $args) = @_; + + # Clear out old env + local %ENV = %ENV; + delete $ENV{PERLLIB}; + delete $ENV{PERL5LIB}; + delete $ENV{PERL5OPT}; + + # Populate with our desired env + for my $k (keys %$env) { + $ENV{$k} = $env->{$k}; + } + + # This is slightly expensive, but this is more reliable than + # trying to emulate fork(), and we still get STDERR and STDOUT individually. + my $stderr_cache = tmpnam(); + my $stdout = `$PERL @$args 2>$stderr_cache`; + my $stderr = ''; + if (-s $stderr_cache) { + open(my $stderr_cache_fh, "<", $stderr_cache) + or die "Could not retrieve STDERR output: $!"; + while ( defined(my $s_line = <$stderr_cache_fh>) ) { + $stderr .= $s_line; + } + close $stderr_cache_fh; + unlink $stderr_cache; + } + + return ($stdout, $stderr); +} + +sub try { + my ($env, $args, $stdout, $stderr) = @_; + my ($actual_stdout, $actual_stderr) = runperl_and_capture($env, $args); + local $::Level = $::Level + 1; + is ($stdout, $actual_stdout); + is ($stderr, $actual_stderr); +} + +# PERL5OPT Command-line options (switches). Switches in +# this variable are taken as if they were on +# every Perl command line. Only the -[DIMUdmtw] +# switches are allowed. When running taint +# checks (because the program was running setuid +# or setgid, or the -T switch was used), this +# variable is ignored. If PERL5OPT begins with +# -T, tainting will be enabled, and any +# subsequent options ignored. + +try({PERL5OPT => '-w'}, ['-e', '"print $::x"'], + "", + 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})); + +try({PERL5OPT => '-Mstrict'}, ['-I..\lib', '-e', '"print $::x"'], + "", ""); + +try({PERL5OPT => '-Mstrict'}, ['-I..\lib', '-e', '"print $x"'], + "", + qq(Global symbol "\$x" requires explicit package name at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL})); + +# Fails in 5.6.0 +try({PERL5OPT => '-Mstrict -w'}, ['-I..\lib', '-e', '"print $x"'], + "", + qq(Global symbol "\$x" requires explicit package name at -e line 1.${NL}Execution of -e aborted due to compilation errors.${NL})); + +# Fails in 5.6.0 +try({PERL5OPT => '-w -Mstrict'}, ['-I..\lib', '-e', '"print $::x"'], + "", + <<ERROR +Name "main::x" used only once: possible typo at -e line 1. +Use of uninitialized value \$x in print at -e line 1. +ERROR + ); + +# Fails in 5.6.0 +try({PERL5OPT => '-w -Mstrict'}, ['-I..\lib', '-e', '"print $::x"'], + "", + <<ERROR +Name "main::x" used only once: possible typo at -e line 1. +Use of uninitialized value \$x in print at -e line 1. +ERROR + ); + +try({PERL5OPT => '-MExporter'}, ['-I..\lib', '-e0'], + "", + ""); + +# Fails in 5.6.0 +try({PERL5OPT => '-MExporter -MExporter'}, ['-I..\lib', '-e0'], + "", + ""); + +try({PERL5OPT => '-Mstrict -Mwarnings'}, + ['-I..\lib', '-e', '"print \"ok\" if $INC{\"strict.pm\"} and $INC{\"warnings.pm\"}"'], + "ok", + ""); + +open my $fh, ">", "Oooof.pm" or die "Can't write Oooof.pm: $!"; +print $fh "package Oooof; 1;\n"; +close $fh; +END { 1 while unlink "Oooof.pm" } + +try({PERL5OPT => '-I. -MOooof'}, + ['-e', '"print \"ok\" if $INC{\"Oooof.pm\"} eq \"Oooof.pm\""'], + "ok", + ""); + +try({PERL5OPT => '-w -w'}, + ['-e', '"print $ENV{PERL5OPT}"'], + '-w -w', + ''); + +try({PERL5OPT => '-t'}, + ['-e', '"print ${^TAINT}"'], + '-1', + ''); + +try({PERL5OPT => '-W'}, + ['-I..\lib','-e', '"local $^W = 0; no warnings; print $x"'], + '', + <<ERROR +Name "main::x" used only once: possible typo at -e line 1. +Use of uninitialized value \$x in print at -e line 1. +ERROR +); + +try({PERLLIB => "foobar$Config{path_sep}42"}, + ['-e', '"print grep { $_ eq \"foobar\" } @INC"'], + 'foobar', + ''); + +try({PERLLIB => "foobar$Config{path_sep}42"}, + ['-e', '"print grep { $_ eq \"42\" } @INC"'], + '42', + ''); + +try({PERL5LIB => "foobar$Config{path_sep}42"}, + ['-e', '"print grep { $_ eq \"foobar\" } @INC"'], + 'foobar', + ''); + +try({PERL5LIB => "foobar$Config{path_sep}42"}, + ['-e', '"print grep { $_ eq \"42\" } @INC"'], + '42', + ''); + +try({PERL5LIB => "foo", + PERLLIB => "bar"}, + ['-e', '"print grep { $_ eq \"foo\" } @INC"'], + 'foo', + ''); + +try({PERL5LIB => "foo", + PERLLIB => "bar"}, + ['-e', '"print grep { $_ eq \"bar\" } @INC"'], + '', + ''); + +# Tests for S_incpush_use_sep(): + +my @dump_inc = ('-e', '"print \"$_\n\" foreach @INC"'); + +my ($out, $err) = runperl_and_capture({}, [@dump_inc]); + +is ($err, '', 'No errors when determining @INC'); + +my @default_inc = split /\n/, $out; + +is ($default_inc[-1], '.', '. is last in @INC'); + +my $sep = $Config{path_sep}; +my @test_cases = ( + ['nothing', ''], + ['something', 'zwapp', 'zwapp'], + ['two things', "zwapp${sep}bam", 'zwapp', 'bam'], + ['two things, ::', "zwapp${sep}${sep}bam", 'zwapp', 'bam'], + [': at start', "${sep}zwapp", 'zwapp'], + [': at end', "zwapp${sep}", 'zwapp'], + [':: sandwich ::', "${sep}${sep}zwapp${sep}${sep}", 'zwapp'], + [':', "${sep}"], + ['::', "${sep}${sep}"], + [':::', "${sep}${sep}${sep}"], + ['two things and :', "zwapp${sep}bam${sep}", 'zwapp', 'bam'], + [': and two things', "${sep}zwapp${sep}bam", 'zwapp', 'bam'], + [': two things :', "${sep}zwapp${sep}bam${sep}", 'zwapp', 'bam'], + ['three things', "zwapp${sep}bam${sep}${sep}owww", + 'zwapp', 'bam', 'owww'], +); + +# This block added to verify fix for RT #87322 +if ($::os_id == 2 and $::os_major == 6) { # Vista, Server 2008 (incl R2), 7 + my @big_perl5lib = ('z' x 16) x 2049; + push @testcases, [ + 'enough items so PERL5LIB val is longer than 32k', + join($sep, @big_perl5lib), @big_perl5lib, + ]; +} + +foreach ( @testcases ) { + my ($name, $lib, @expect) = @$_; + push @expect, @default_inc; + + ($out, $err) = runperl_and_capture({PERL5LIB => $lib}, [@dump_inc]); + + is ($err, '', "No errors when determining \@INC for $name"); + + my @inc = split /\n/, $out; + + is (scalar @inc, scalar @expect, + "expected number of elements in \@INC for $name"); + + is ("@inc", "@expect", "expected elements in \@INC for $name"); +} diff --git a/win32/win32.c b/win32/win32.c index cffd2b5bca..e67a7352be 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -1693,6 +1693,7 @@ win32_getenv(const char *name) dTHX; DWORD needlen; SV *curitem = NULL; + DWORD last_err; needlen = GetEnvironmentVariableA(name,NULL,0); if (needlen != 0) { @@ -1705,10 +1706,37 @@ win32_getenv(const char *name) SvCUR_set(curitem, needlen); } else { - /* allow any environment variables that begin with 'PERL' - to be stored in the registry */ - if (strncmp(name, "PERL", 4) == 0) - (void)get_regstr(name, &curitem); + last_err = GetLastError(); + if (last_err == ERROR_NOT_ENOUGH_MEMORY) { + /* It appears the variable is in the env, but the Win32 API + doesn't have a canned way of getting it. So we fall back to + grabbing the whole env and pulling this value out if possible */ + char *envv = GetEnvironmentStrings(); + char *cur = envv; + STRLEN len; + while (*cur) { + char *end = strchr(cur,'='); + if (end && end != cur) { + *end = '\0'; + if (!strcmp(cur,name)) { + curitem = sv_2mortal(newSVpv(end+1,0)); + *end = '='; + break; + } + *end = '='; + cur = end + strlen(end+1)+2; + } + else if ((len = strlen(cur))) + cur += len+1; + } + FreeEnvironmentStrings(envv); + } + else { + /* last ditch: allow any environment variables that begin with 'PERL' + to be obtained from the registry, if found there */ + if (strncmp(name, "PERL", 4) == 0) + (void)get_regstr(name, &curitem); + } } if (curitem && SvCUR(curitem)) return SvPVX(curitem); |