From 12a52157658e56796eb1ede38a2715f62242490f Mon Sep 17 00:00:00 2001
From: Aristotle Pagaltzis <pagaltzis@gmx.de>
Date: Mon, 13 Feb 2017 01:28:14 +0100
Subject: 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
<xsawyerx@cpan.org>, 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)

[ backported to Debian 5.20 by Niko Tyni, patch description from
 http://perl5.git.perl.org/perl.git/commit/2d156e07f936ea4f8ce46dee5ade17fe19dbbf29
]

Origin: backport, http://perl5.git.perl.org/perl.git/commit/1afa2890005f3acdb5794bc9ec34dfd0a7e54c28
Patch-Name: debian/CVE-2016-1238/base-pm-amends-pt2.diff
---
 MANIFEST                            |  1 +
 dist/base/lib/base.pm               | 55 +++++++++++++++++++++++++++++++++++--
 dist/base/t/incdot.t                | 55 +++++++++++++++++++++++++++++++++++++
 dist/base/t/lib/BaseIncMandatory.pm |  9 ++++++
 dist/base/t/lib/BaseIncOptional.pm  | 13 +++++++++
 5 files changed, 131 insertions(+), 2 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 3032f8d856..550dbcc6e5 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2918,6 +2918,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;