From 1fcb0052e32fe8c260e83b2ece033e2ca2f30a92 Mon Sep 17 00:00:00 2001 From: Phil Monsen Date: Mon, 18 Jul 2011 22:16:55 -0500 Subject: [PATCH] Fixes to allow win32 Perl to properly handle PERL5LIB. On Windows Vista, 7 and 2008, the win32 API call GetEnvironmentVariableA() does not return environment values with string length of greater than 32766, even though such variables are supported in the environment. This consequently caused @INC not to be populated for such values of PERL5LIB on those OSes, as reported in RT #87322. This commit reworks the code so that GetEnvironmentStrings() is called if GetEnvironmentVariableA() indicates the requested value is set in the environmtn. The old fallback of consulting the registry for variables beginning with "PERL" is retained, but as a last-ditch fallback rather than the only recourse. A new test file, t/win32/runenv.t has been added to validate that the new behavior is working properly, as well as that general environment variable handling is in accordance with expectations, since t/run/runenv.t does not run on Win* platforms. The new test file is essentially a non-forking clone of t/run/runenv.t, with modifications to test cases to run properly on Win* platforms, and with a new test case to test the new behavior. --- MANIFEST | 1 + pod/perldelta.pod | 27 +++++- t/win32/runenv.t | 250 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ win32/win32.c | 36 +++++++- 4 files changed, 308 insertions(+), 6 deletions(-) create mode 100644 t/win32/runenv.t diff --git a/MANIFEST b/MANIFEST index 4360dba..ced11f8 100644 --- a/MANIFEST +++ b/MANIFEST @@ -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 639bce5..e041408 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -532,6 +532,12 @@ and if calling C 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 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 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 section). Fixes +L. + +=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 0000000..2576168 --- /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"'], + "", + < '-w -Mstrict'}, ['-I..\lib', '-e', '"print $::x"'], + "", + < '-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"'], + '', + < "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 cffd2b5..e67a735 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); -- 1.8.3.1