In perl.git, the branch ap/baseincguard has been updated <http://perl5.git.perl.org/perl.git/commitdiff/3c3b8f48d3485ebd0d31cc5c6ea398c72fb46338?hp=5fe1b9d21db4c145c4f1050cdf35e6ff25e6edcd>
discards 5fe1b9d21db4c145c4f1050cdf35e6ff25e6edcd (commit) - Log ----------------------------------------------------------------- commit 3c3b8f48d3485ebd0d31cc5c6ea398c72fb46338 Author: Aristotle Pagaltzis <[email protected]> Date: Sat Oct 29 09:14:07 2016 +0200 base: only hide $INC[-1] . from optional loads ----------------------------------------------------------------------- Summary of changes: dist/base/lib/base.pm | 39 +++++++++++++++++++------------------ dist/base/t/incdot.t | 4 ++-- dist/base/t/lib/BaseIncMandatory.pm | 3 ++- dist/base/t/lib/BaseIncOptional.pm | 4 +--- 4 files changed, 25 insertions(+), 25 deletions(-) diff --git a/dist/base/lib/base.pm b/dist/base/lib/base.pm index 01f9beb457..bc43e5918e 100644 --- a/dist/base/lib/base.pm +++ b/dist/base/lib/base.pm @@ -8,7 +8,7 @@ $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 remove from @INC at scope exit +# 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 @@ -109,24 +109,25 @@ sub import { # 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 recursive require()s). - # To achieve this overal effect, we use two hooks: - # - A rear hook, which intercepts @INC traversal before the dot is - # reached by sitting immediately in front of the dot. It hides - # the dot by removing itself from @INC, which moves the dot up - # by one index, which causes it to be skipped. - # - A front hook, which sits at the front of @INC and does nothing - # until itâs reached twice, which must be a recursive require. - # If that happens, it removes the rear hook from @INC to keep - # the dot visible. - # Note that this setup works recursively: if a module loaded via - # base.pm itself uses base.pm, there will be one layer of hooks - # in @INC per base::import call frame, and they do not interfere - # with each other. - 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 if $reentrant == 1; () }; - $guard = bless [ $front_hook, $rear_hook ], 'base::__inc::scope_guard'; + # (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. + # The way the hook hides the dot is by sitting directly in front + # of the dot and removing itself from @INC. This causes the dot + # to move up by one index in @INC, which causes the for(;;) loop + # inside pp_require() to skip it. + # Relying on this careful positioning is fine because the hook is + # only active during the top-level require() where @INC is in our + # control. After that the hook is inert, so breaking its placement + # has no effect. + # Note that this setup works fine recursively: if a module loaded + # via base.pm itself uses base.pm, there will be one hook in @INC + # per base::import call frame, but they do not affect each other. + my $lvl = 0; 1 while defined caller ++$lvl; + my $hook = sub { ++$dot_hidden, &base::__inc::unhook unless defined caller 1+$lvl; () }; + $guard = bless [ $hook ], 'base::__inc::scope_guard'; + splice @INC, -1, 0, $hook; } require $fn }; diff --git a/dist/base/t/incdot.t b/dist/base/t/incdot.t index 38d9eb7a29..d5e1ecbebe 100644 --- a/dist/base/t/incdot.t +++ b/dist/base/t/incdot.t @@ -17,7 +17,7 @@ sub array_diff { ####################################################################### -use Test::More tests => 10; # some extra tests in t/lib/BaseInc* +use Test::More tests => 8; # some extra tests in t/lib/BaseInc* use lib 't/lib', sub {()}; @@ -31,7 +31,7 @@ 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 . fails'; + 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\.!, diff --git a/dist/base/t/lib/BaseIncMandatory.pm b/dist/base/t/lib/BaseIncMandatory.pm index cc299eeb0d..9e0718c60e 100644 --- a/dist/base/t/lib/BaseIncMandatory.pm +++ b/dist/base/t/lib/BaseIncMandatory.pm @@ -2,7 +2,8 @@ package BaseIncMandatory; BEGIN { package main; is $INC[-1], '.', 'trailing dot remains in @INC during mandatory module load from base'; - is 0+(grep ref eq 'CODE', @INC), 1, '... and no extra hook is present'; + 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 index 50f30464c9..e5bf0174ef 100644 --- a/dist/base/t/lib/BaseIncOptional.pm +++ b/dist/base/t/lib/BaseIncOptional.pm @@ -2,10 +2,8 @@ package BaseIncOptional; BEGIN { package main; is $INC[-1], '.', 'trailing dot remains in @INC during optional module load from base'; - is 0+(grep ref eq 'CODE', @INC), 3, '... but the expected extra hooks'; + ok eval('require t::lib::Dummy'), '... and modules load fine from .' or diag "$@"; delete $INC{'t/lib/Dummy.pm'}; - ok eval('require t::lib::Dummy'), '... however they do not prevent loading modules from .' or diag "$@"; - isnt 0+(grep ref eq 'CODE', @INC), 3, '... which auto-removes the dot-hiding hook'; } use lib 't/lib/on-head'; -- Perl5 Master Repository
