In perl.git, the branch ap/baseincguard has been updated <http://perl5.git.perl.org/perl.git/commitdiff/52098917ad8ff2b432090b47362e12a9f01a5722?hp=f94344e85705ef634122789f9aabed978591894a>
discards f94344e85705ef634122789f9aabed978591894a (commit) - Log ----------------------------------------------------------------- commit 52098917ad8ff2b432090b47362e12a9f01a5722 Author: Aristotle Pagaltzis <[email protected]> Date: Sat Oct 29 03:14:57 2016 +0200 base: only hide $INC[-1] . from optional loads ----------------------------------------------------------------------- Summary of changes: dist/base/lib/base.pm | 56 ++++++++++++++++++++------------ dist/base/t/incdot.t | 36 ++++++++++++-------- dist/base/t/lib/BaseIncDoubleExtender.pm | 2 +- dist/base/t/lib/BaseIncExtender.pm | 2 +- 4 files changed, 60 insertions(+), 36 deletions(-) diff --git a/dist/base/lib/base.pm b/dist/base/lib/base.pm index d7d2645..7faabea 100644 --- a/dist/base/lib/base.pm +++ b/dist/base/lib/base.pm @@ -7,10 +7,8 @@ $VERSION = '2.24'; $VERSION =~ tr/_//d; # simplest way to avoid indexing of the package: no package statement -sub base::__inc_scope_guard::DESTROY { - my $noop = $_[0][0]; - ref $_ and $_ == $noop and $_ = '.' for @INC; -} +sub base::__inc::unhook { @INC = grep !(ref $_ eq 'CODE' && $_ == $_[0]), @INC } +sub base::__inc::scope_guard::DESTROY { base::__inc::unhook $_ for @{$_[0]} } # constant.pm is slow sub SUCCESS () { 1 } @@ -103,11 +101,41 @@ sub import { { local $SIG{__DIE__}; my $fn = _module_to_filename($base); - my $success = eval { - my $incdot = $INC[-1] eq '.' && %{"$base\::"} # only if optional - && bless [ $INC[-1] = sub {()} ], 'base::__inc_scope_guard'; + my $dot_hidden; + eval { + my $inc_guard; + if ($INC[-1] eq '.' && %{"$base\::"}) { + # So: the package already exists => this an optional load + # And: there is a . at the end of @INC => we want to hide it + # However: we only want to hide it during our *own* `require` + # (i.e. without affecting recursive `require`s). + # To achieve this overal effect, we use two hooks: + # - The rear hook is placed just before the . and serves + # to hide it just before @INC traversal would reach it, + # by removing itself from @INC, causing the . to be skipped. + # - The front hook is placed at the front of @INC and serves + # to remove the rear hook if itâs ever reached twice. + # During the initial @INC traversal (by our own `require`) + # it does nothing. + my ($reentrant, $front_hook, $rear_hook); + unshift @INC, $front_hook = sub { base::__inc::unhook $rear_hook if $reentrant++; () }; + splice @INC, -1, 0, $rear_hook = sub { ++$dot_hidden, &base::__inc::unhook; () }; + $inc_guard = bless [ $front_hook, $rear_hook ], 'base::__inc::scope_guard'; + } require $fn }; + if ($dot_hidden && grep -e && !( -d _ || -b _ ), $fn, $fn.'c') { + require Carp; + Carp::croak(<<ERROR); +Base class package "$base" is not empty but "$fn" exists in the current directory. + To help avoid security issues, base.pm now refuses to load optional modules + from the current working directory when it is the last entry in \@INC. + If your software worked on previous versions of Perl, the best solution + is to use FindBin to detect the path properly and to add that path to + \@INC. As a last resort, you can re-enable looking in the current working + directory by adding "use lib '.'" to your code. +ERROR + } # Only ignore "Can't locate" errors from our eval require. # Other fatal errors (syntax etc) must be reported. # @@ -118,7 +146,7 @@ sub import { # see [perl #118561] die if $@ && $@ !~ /^Can't locate \Q$fn\E .*? at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/s || $@ =~ /Compilation failed in require at .* line [0-9]+(?:, <[^>]*> (?:line|chunk) [0-9]+)?\.\n\z/; - if (!%{"$base\::"}) { + unless (%{"$base\::"}) { require Carp; local $" = " "; Carp::croak(<<ERROR); @@ -127,18 +155,6 @@ Base class package "$base" is empty. or make that module available in \@INC (\@INC contains: @INC). ERROR } - elsif (!$success && $INC[-1] eq '.' && -e $fn) { - require Carp; - Carp::croak(<<ERROR); -Base class package "$base" is not empty but "$fn" exists in the current directory. - To help avoid security issues, base.pm now refuses to load optional modules - from the current working directory when it is the last entry in \@INC. - If your software worked on previous versions of Perl, the best solution - is to use FindBin to detect the path properly and to add that path to - \@INC. As a last resort, you can re-enable looking in the current working - directory by adding "use lib '.'" to your code. -ERROR - } $sigdie = $SIG{__DIE__} || undef; } # Make sure a global $SIG{__DIE__} makes it out of the localization. diff --git a/dist/base/t/incdot.t b/dist/base/t/incdot.t index 39eb84f..aa8032f 100644 --- a/dist/base/t/incdot.t +++ b/dist/base/t/incdot.t @@ -1,38 +1,46 @@ #!/usr/bin/perl -w use strict; -use Test::More tests => 13; # one test is in each BaseInc* itself +use Test::More tests => 7; # one test is in each BaseInc* itself -use lib 't/lib'; +sub rendered_comparison { + my ( $got, $expected ) = @_; + push @$got, ( '(missing)' ) x ( @$expected - @$got ) if @$got < @$expected; + push @$expected, ( '(should not exist)' ) x ( @$got - @$expected ) if @$got > @$expected; + join "\n", map +( "got [$_] " . $got->[$_], 'expected'.(' ' x length).$expected->[$_] ), 0 .. $#$got; +} + +my $hook; +use lib 't/lib', $hook = sub {()}; # make it look like an older perl BEGIN { push @INC, '.' if $INC[-1] ne '.' } +my @expected; BEGIN { @expected = @INC } + use base 'BaseIncChecker'; BEGIN { @t::lib::Dummy::ISA = (); # make it look like an optional load - ok !eval("use base 't::lib::Dummy'"), 'loading optional modules from . fails'; - like $@, qr!Base class package "t::lib::Dummy" is not empty but "t/lib/Dummy\.pm" exists in the current directory\.!, - '... with a proper error message'; + my $success = eval q{use base 't::lib::Dummy'}, my $err = $@; + ok !$success, 'loading optional modules from . fails'; + is_deeply \@INC, \@expected, '... without changes to @INC' + or diag rendered_comparison [@INC], [@expected]; } -BEGIN { @BaseIncExtender::ISA = () } # make it look like an optional load use base 'BaseIncExtender'; BEGIN { - is $INC[0], 't/lib/blahblah', 'modules loaded by base can prepend entries to @INC'; - is $INC[1], 't/lib', 'previously prepended additional @INC entry remains'; - is $INC[-1], '.', 'dot still at end @INC after using base'; + unshift @expected, 't/lib/blahblah'; + is_deeply \@INC, \@expected, 'modules loaded by base can prepend entries to @INC' + or diag rendered_comparison [@INC], [@expected]; } BEGIN { @BaseIncDoubleExtender::ISA = () } # make it look like an optional load use base 'BaseIncDoubleExtender'; BEGIN { - is $INC[0], 't/lib/blahdeblah', 'modules loaded by base can prepend entries to @INC'; - is $INC[1], 't/lib/blahblah', 'previously prepended additional @INC entry remains'; - is $INC[2], 't/lib', 'previously prepended additional @INC entry remains'; - is $INC[-2], '.', 'dot still at previous end of @INC after using base'; - is $INC[-1], 't/lib/on-end', 'modules loaded by base can append entries to @INC'; + @expected = ( 't/lib/blahdeblah', @expected, 't/lib/on-end' ); + is_deeply \@INC, \@expected, 'modules loaded by base can extend @INC at both ends' + or diag rendered_comparison [@INC], [@expected]; } diff --git a/dist/base/t/lib/BaseIncDoubleExtender.pm b/dist/base/t/lib/BaseIncDoubleExtender.pm index 86d88c3..b28d75b 100644 --- a/dist/base/t/lib/BaseIncDoubleExtender.pm +++ b/dist/base/t/lib/BaseIncDoubleExtender.pm @@ -1,6 +1,6 @@ package BaseIncDoubleExtender; -BEGIN { ::ok( $INC[-1] ne '.', 'no trailing dot in @INC during optional module load from base' ) } +BEGIN { ::ok( $INC[-1] eq '.', 'trailing dot remains in @INC during optional module load from base' ) } use lib 't/lib/blahdeblah'; diff --git a/dist/base/t/lib/BaseIncExtender.pm b/dist/base/t/lib/BaseIncExtender.pm index 2e4e97b..8d89d13 100644 --- a/dist/base/t/lib/BaseIncExtender.pm +++ b/dist/base/t/lib/BaseIncExtender.pm @@ -1,6 +1,6 @@ package BaseIncExtender; -BEGIN { ::ok( $INC[-1] ne '.', 'no trailing dot in @INC during optional module load from base' ) } +BEGIN { ::ok( $INC[-1] eq '.', 'trailing dot remains in @INC during optional module load from base' ) } use lib 't/lib/blahblah'; -- Perl5 Master Repository
