In perl.git, the branch maint-5.22 has been updated <http://perl5.git.perl.org/perl.git/commitdiff/827757febaf3655a68382c7b0eb97361efe91cd8?hp=6bdc3976792cc460e8a374488a756ed5daffb4ba>
- Log ----------------------------------------------------------------- commit 827757febaf3655a68382c7b0eb97361efe91cd8 Author: Steve Hay <[email protected]> Date: Fri Jun 30 22:55:46 2017 +0100 perldelta - Update Modules section M pod/perldelta.pod commit 4fbd8d572ea3fce5eb815e84e2d78b6ec500ca96 Author: Steve Hay <[email protected]> Date: Fri Jun 30 22:54:58 2017 +0100 Update Module::CoreList M dist/Module-CoreList/lib/Module/CoreList.pm commit c9083e53009b13159318bfb5bdeb9c254059fcac Author: Steve Hay <[email protected]> Date: Fri Jun 30 22:50:06 2017 +0100 Bump base $VERSION M dist/base/lib/base.pm commit 2a9dbcbe25d4c43ed00a064e90d7b889a075653d Author: Steve Hay <[email protected]> Date: Fri Jun 30 22:06:45 2017 +0100 Update MANIFEST for previous commit M MANIFEST commit a93da9a38cdfa13bdadf40b8448d28d46065605a Author: Aristotle Pagaltzis <[email protected]> Date: Fri Jun 30 22:02:42 2017 +0100 wip (cherry picked from commit e85f59ba2fc88811307db2324875ef30770ed2cb) 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/Module-CoreList/lib/Module/CoreList.pm | 1 + 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 +++++++ pod/perldelta.pod | 4 ++ 7 files changed, 139 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 92238dc155..57300e038e 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2892,7 +2892,10 @@ 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/fields.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/Module-CoreList/lib/Module/CoreList.pm b/dist/Module-CoreList/lib/Module/CoreList.pm index 9ed2fbfb0b..9ab93ce6b5 100644 --- a/dist/Module-CoreList/lib/Module/CoreList.pm +++ b/dist/Module-CoreList/lib/Module/CoreList.pm @@ -14271,6 +14271,7 @@ for my $version ( sort { $a <=> $b } keys %released ) { 'Module::CoreList' => '5.20170715_22', 'Module::CoreList::TieHashDelta'=> '5.20170715_22', 'Module::CoreList::Utils'=> '5.20170715_22', + 'base' => '2.22_01', }, removed => { } diff --git a/dist/base/lib/base.pm b/dist/base/lib/base.pm index 5d1378786d..08b439a6d5 100644 --- a/dist/base/lib/base.pm +++ b/dist/base/lib/base.pm @@ -2,9 +2,14 @@ package base; use strict 'vars'; use vars qw($VERSION); -$VERSION = '2.22'; +$VERSION = '2.22_01'; $VERSION = eval $VERSION; +# 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 } @@ -90,13 +95,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; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 3b90e3c0b3..262a905b5e 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -126,6 +126,10 @@ XXX =item * +L<base> has been upgraded from version 2.22 to 2.22_01. + +=item * + L<Module::CoreList> has been upgraded from version 5.20170114_22 to 5.20170715_22. =item * -- Perl5 Master Repository
