From: millert <millert@openbsd.org>
Date: Thu, 7 Jul 2016 19:16:15 +0000 (+0000)
Subject: Apply http://perl5.git.perl.org/perl.git/commitdiff/08e3451d7
X-Git-Url: http://artulab.com/gitweb/?a=commitdiff_plain;h=ce05b15023b4496916b670a7243aebccdf266ff4;p=openbsd

Apply perl5.git.perl.org/perl.git/commitdiff/08e3451d7
This fixes a bug where XSLoader could try to load from a subdir
of the cwd when called via eval.  OK afresh1@
---

diff --git a/gnu/usr.bin/perl/dist/XSLoader/XSLoader_pm.PL b/gnu/usr.bin/perl/dist/XSLoader/XSLoader_pm.PL
index e382058a04d..c4940055958 100644
--- a/gnu/usr.bin/perl/dist/XSLoader/XSLoader_pm.PL
+++ b/gnu/usr.bin/perl/dist/XSLoader/XSLoader_pm.PL
@@ -86,6 +86,31 @@ print OUT <<'EOT';
     my $modpname = join('/',@modparts);
     my $c = @modparts;
     $modlibname =~ s,[\\/][^\\/]+$,, while $c--;    # Q&D basename
+    # Does this look like a relative path?
+    if ($modlibname !~ m|^[\\/]|) {
+        # Someone may have a #line directive that changes the file name, or
+        # may be calling XSLoader::load from inside a string eval.  We cer-
+        # tainly do not want to go loading some code that is not in @INC,
+        # as it could be untrusted.
+        #
+        # We could just fall back to DynaLoader here, but then the rest of
+        # this function would go untested in the perl core, since all @INC
+        # paths are relative during testing.  That would be a time bomb
+        # waiting to happen, since bugs could be introduced into the code.
+        #
+        # So look through @INC to see if $modlibname is in it.  A rela-
+        # tive $modlibname is not a common occurrence, so this block is
+        # not hot code.
+        FOUND: {
+            for (@INC) {
+                if ($_ eq $modlibname) {
+                    last FOUND;
+                }
+            }
+            # Not found.  Fall back to DynaLoader.
+            goto \&XSLoader::bootstrap_inherit;
+        }
+    }
 EOT
 
 my $dl_dlext = quotemeta($Config::Config{'dlext'});
diff --git a/gnu/usr.bin/perl/dist/XSLoader/t/XSLoader.t b/gnu/usr.bin/perl/dist/XSLoader/t/XSLoader.t
index 20ca32bb46f..d254f199f9b 100755
--- a/gnu/usr.bin/perl/dist/XSLoader/t/XSLoader.t
+++ b/gnu/usr.bin/perl/dist/XSLoader/t/XSLoader.t
@@ -33,7 +33,7 @@ my %modules = (
     'Time::HiRes'=> q| ::can_ok( 'Time::HiRes' => 'usleep'  ) |,  # 5.7.3
 );
 
-plan tests => keys(%modules) * 3 + 8;
+plan tests => keys(%modules) * 3 + 9;
 
 # Try to load the module
 use_ok( 'XSLoader' );
@@ -96,3 +96,28 @@ SKIP: {
     like $@, "/^Invalid version format/",
         'correct error msg for invalid versions';
 }
+
+SKIP: {
+  skip "File::Path not available", 1
+    unless eval { require File::Path };
+  my $name = "phooo$$";
+  File::Path::make_path("$name/auto/Foo/Bar");
+  open my $fh,
+    ">$name/auto/Foo/Bar/Bar.$Config::Config{'dlext'}";
+  close $fh;
+  my $fell_back;
+  local *XSLoader::bootstrap_inherit = sub {
+    $fell_back++;
+    # Break out of the calling subs
+    goto the_test;
+  };
+  eval <<END;
+#line 1 $name
+package Foo::Bar;
+XSLoader::load("Foo::Bar");
+END
+ the_test:
+  ok $fell_back,
+    'XSLoader will not load relative paths based on (caller)[1]';
+  File::Path::remove_tree($name);
+}