wip

(cherry picked from commit e85f59ba2fc88811307db2324875ef30770ed2cb)

5 files changed, 131 insertions, 2 deletions

diff --git a/MANIFEST b/MANIFEST
index 92238dc155..cf61cc2aa5 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2892,6 +2892,7 @@ 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/Broken.pm	Test module for base.pm
 dist/base/t/lib/Dummy.pm	Test module for base.pm
diff --git a/dist/base/lib/base.pm b/dist/base/lib/base.pm
index 5d1378786d..85d87e1161 100644
--- a/dist/base/lib/base.pm
+++ b/dist/base/lib/base.pm
@@ -5,6 +5,11 @@ use vars qw($VERSION);
 $VERSION = '2.22';
 $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;