In perl.git, the branch maint-5.26 has been updated <http://perl5.git.perl.org/perl.git/commitdiff/71952815d7bf35e0fdc12571d0edbcd32ce77e04?hp=95388f2eb27e74cdbfb715c0097f16aeba4e6e4e>
- Log ----------------------------------------------------------------- commit 71952815d7bf35e0fdc12571d0edbcd32ce77e04 Author: Steve Hay <[email protected]> Date: Tue Jul 25 17:21:03 2017 +0100 Update MANIFEST and bump base $VERSION for previous commit (cherry picked from commit f1820d8248083f4ae01a30baeb564afb143537c3) M MANIFEST M dist/base/lib/base.pm commit a77da413199c4fd2fff89ca0d93014c4a32673c2 Author: Aristotle Pagaltzis <[email protected]> Date: Mon Feb 13 01:28:14 2017 +0100 Limit dotless-INC effect on base.pm with guard: This introduces a more refined and accurate solution for removing '.' from @INC while reducing the false positives. The following explanation is roughly what is avaiable in the code comments. If you stumble upon this and feel like the commit message or the comments are not helpful enough, please introduce another commit that adds more explanation or improve the code comments (or both). Using if ($INC[-1] eq '.' && %{"$base\::"}) We decide that: The package already exists => this an optional load And: there is a dot 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 nested require()s). So we add a hook to @INC whose job is to hide the dot, but which first checks checks the callstack depth, because within nested require()s the callstack is deeper. Since CORE::GLOBAL::require makes it unknowable in advance what the exact relevant callstack depth will be, we have to record it inside a hook. So we put another hook just for that at the front of @INC, where it's guaranteed to run -- immediately. The dot-hiding hook does its job by sitting directly in front of the dot and removing itself from @INC when reached. This causes the dot to move up one index in @INC, causing the loop inside pp_require() to skip it. Loaded coded may disturb this precise arrangement, but that's OK because the hook is inert by that time. It is only active during the top-level require(), when @INC is in our control. The only possible gotcha is if other hooks already in @INC modify @INC in some way during that initial require(). Note that this jiggery hookery works just fine recursively: if a module loaded via base.pm uses base.pm itself, there will be one pair of hooks in @INC per base::import call frame, but the pairs from different nestings do not interfere with each other. (cherry picked from commit 571931bfa1120564fe207965f9ec2ea0f8bbbb8a) [This is a forward-port, with improved commit message by Sawyer X <[email protected]>, of the commit that was cherry-picked into maint-5.22 and maint-5.24 as commits a93da9a38c and 1afa289000 respectively.] (cherry picked from commit fa71f6670dda393818d17f2f3bd2bee165347849) M MANIFEST M dist/base/lib/base.pm A dist/base/t/incdot.t A dist/base/t/lib/BaseIncMandatory.pm A dist/base/t/lib/BaseIncOptional.pm ----------------------------------------------------------------------- Summary of changes: MANIFEST | 3 ++ dist/base/lib/base.pm | 57 +++++++++++++++++++++++++++++++++++-- dist/base/t/incdot.t | 55 +++++++++++++++++++++++++++++++++++ dist/base/t/lib/BaseIncMandatory.pm | 9 ++++++ dist/base/t/lib/BaseIncOptional.pm | 13 +++++++++ 5 files changed, 134 insertions(+), 3 deletions(-) create mode 100644 dist/base/t/incdot.t create mode 100644 dist/base/t/lib/BaseIncMandatory.pm create mode 100644 dist/base/t/lib/BaseIncOptional.pm diff --git a/MANIFEST b/MANIFEST index 0a3757ea3b..c6bad9bbac 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3234,7 +3234,10 @@ dist/base/t/fields.t See if fields work dist/base/t/fields-5_6_0.t See if fields work dist/base/t/fields-5_8_0.t See if fields work dist/base/t/fields-base.t See if fields work +dist/base/t/incdot.t Test how base.pm handles '.' in @INC dist/base/t/isa.t See if base's behaviour doesn't change +dist/base/t/lib/BaseIncMandatory.pm Test module for base.pm +dist/base/t/lib/BaseIncOptional.pm Test module for base.pm dist/base/t/lib/Broken.pm Test module for base.pm dist/base/t/lib/Dummy.pm Test module for base.pm dist/base/t/lib/HasSigDie.pm Module for testing base.pm diff --git a/dist/base/lib/base.pm b/dist/base/lib/base.pm index 8bc332e2dd..017574eaff 100644 --- a/dist/base/lib/base.pm +++ b/dist/base/lib/base.pm @@ -3,9 +3,14 @@ package base; use strict 'vars'; use vars qw($VERSION); -$VERSION = '2.25'; +$VERSION = '2.26'; $VERSION =~ tr/_//d; +# simplest way to avoid indexing of the package: no package statement +sub base::__inc::unhook { @INC = grep !(ref eq 'CODE' && $_ == $_[0]), @INC } +# instance is blessed array of coderefs to be removed from @INC at scope exit +sub base::__inc::scope_guard::DESTROY { base::__inc::unhook $_ for @{$_[0]} } + # constant.pm is slow sub SUCCESS () { 1 } @@ -91,13 +96,59 @@ sub import { next if grep $_->isa($base), ($inheritor, @bases); - # Following blocks help isolate $SIG{__DIE__} changes + # Following blocks help isolate $SIG{__DIE__} and @INC changes { my $sigdie; { local $SIG{__DIE__}; my $fn = _module_to_filename($base); - eval { require $fn }; + my $dot_hidden; + eval { + my $guard; + if ($INC[-1] eq '.' && %{"$base\::"}) { + # So: the package already exists => this an optional load + # And: there is a dot 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 nested require()s). + # So we add a hook to @INC whose job is to hide the dot, but which + # first checks checks the callstack depth, because within nested + # require()s the callstack is deeper. + # Since CORE::GLOBAL::require makes it unknowable in advance what + # the exact relevant callstack depth will be, we have to record it + # inside a hook. So we put another hook just for that at the front + # of @INC, where it's guaranteed to run -- immediately. + # The dot-hiding hook does its job by sitting directly in front of + # the dot and removing itself from @INC when reached. This causes + # the dot to move up one index in @INC, causing the loop inside + # pp_require() to skip it. + # Loaded coded may disturb this precise arrangement, but that's OK + # because the hook is inert by that time. It is only active during + # the top-level require(), when @INC is in our control. The only + # possible gotcha is if other hooks already in @INC modify @INC in + # some way during that initial require(). + # Note that this jiggery hookery works just fine recursively: if + # a module loaded via base.pm uses base.pm itself, there will be + # one pair of hooks in @INC per base::import call frame, but the + # pairs from different nestings do not interfere with each other. + my $lvl; + unshift @INC, sub { return if defined $lvl; 1 while defined caller ++$lvl; () }; + splice @INC, -1, 0, sub { return if defined caller $lvl; ++$dot_hidden, &base::__inc::unhook; () }; + $guard = bless [ @INC[0,-2] ], 'base::__inc::scope_guard'; + } + require $fn + }; + if ($dot_hidden && (my @fn = grep -e && !( -d _ || -b _ ), $fn.'c', $fn)) { + require Carp; + Carp::croak(<<ERROR); +Base class package "$base" is not empty but "$fn[0]" 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. # diff --git a/dist/base/t/incdot.t b/dist/base/t/incdot.t new file mode 100644 index 0000000000..412b2feefb --- /dev/null +++ b/dist/base/t/incdot.t @@ -0,0 +1,55 @@ +#!/usr/bin/perl -w + +use strict; + +####################################################################### + +sub array_diff { + 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 ", ' All differences:', ( + map +( "got [$_] " . $got->[$_], 'expected'.(' ' x length).$expected->[$_] ), + grep $got->[$_] ne $expected->[$_], + 0 .. $#$got + ); +} + +####################################################################### + +use Test::More tests => 8; # some extra tests in t/lib/BaseInc* + +use lib 't/lib', sub {()}; + +# make it look like an older perl +BEGIN { push @INC, '.' if $INC[-1] ne '.' } + +BEGIN { + my $x = sub { CORE::require $_[0] }; + my $y = sub { &$x }; + my $z = sub { &$y }; + *CORE::GLOBAL::require = $z; +} + +my @expected; BEGIN { @expected = @INC } + +use base 'BaseIncMandatory'; + +BEGIN { + @t::lib::Dummy::ISA = (); # make it look like an optional load + my $success = eval q{use base 't::lib::Dummy'}, my $err = $@; + ok !$success, 'loading optional modules from . using base.pm fails'; + is_deeply \@INC, \@expected, '... without changes to @INC' + or diag array_diff [@INC], [@expected]; + like $err, qr!Base class package "t::lib::Dummy" is not empty but "t/lib/Dummy\.pm" exists in the current directory\.!, + '... and the proper error message'; +} + +BEGIN { @BaseIncOptional::ISA = () } # make it look like an optional load +use base 'BaseIncOptional'; + +BEGIN { + @expected = ( 't/lib/on-head', @expected, 't/lib/on-tail' ); + is_deeply \@INC, \@expected, 'modules loaded by base can extend @INC at both ends' + or diag array_diff [@INC], [@expected]; +} diff --git a/dist/base/t/lib/BaseIncMandatory.pm b/dist/base/t/lib/BaseIncMandatory.pm new file mode 100644 index 0000000000..9e0718c60e --- /dev/null +++ b/dist/base/t/lib/BaseIncMandatory.pm @@ -0,0 +1,9 @@ +package BaseIncMandatory; + +BEGIN { package main; + is $INC[-1], '.', 'trailing dot remains in @INC during mandatory module load from base'; + ok eval('require t::lib::Dummy'), '... and modules load fine from .' or diag "$@"; + delete $INC{'t/lib/Dummy.pm'}; +} + +1; diff --git a/dist/base/t/lib/BaseIncOptional.pm b/dist/base/t/lib/BaseIncOptional.pm new file mode 100644 index 0000000000..e5bf0174ef --- /dev/null +++ b/dist/base/t/lib/BaseIncOptional.pm @@ -0,0 +1,13 @@ +package BaseIncOptional; + +BEGIN { package main; + is $INC[-1], '.', 'trailing dot remains in @INC during optional module load from base'; + ok eval('require t::lib::Dummy'), '... and modules load fine from .' or diag "$@"; + delete $INC{'t/lib/Dummy.pm'}; +} + +use lib 't/lib/on-head'; + +push @INC, 't/lib/on-tail'; + +1; -- Perl5 Master Repository
