From 014d8912d3969aa3286cad4fe79ee5d596668309 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Sat, 2 Jul 2016 22:56:51 -0700
Subject: [PATCH] =?UTF-8?q?Don=E2=80=99t=20let=20XSLoader=20load=20relative=20?=
 =?UTF-8?q?paths?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

[rt.cpan.org #115808]

The logic in XSLoader for determining the library goes like this:

    my $c = () = split(/::/,$caller,-1);
    $modlibname =~ s,[\\/][^\\/]+$,, while $c--;    # Q&D basename
    my $file = "$modlibname/auto/$modpname/$modfname.bundle";

(That last line varies by platform.)

$caller is the calling package.  $modlibname is the calling file.  It
removes as many path segments from $modlibname as there are segments
in $caller.  So if you have List/MoreUtils/XS.pm calling XSLoader from
the List::MoreUtils package, the $modlibname will end up containing
the path in @INC where XS.pm was found, following by "/List".  Usually
the fallback to Dynaloader::bootstrap_inherit, which does an @INC
search, makes things Just Work.

But List/MoreUtils/XS.pm actually calls XSLoader::load from
inside a string eval.  That means the path ends up being
"(eval 1)/auto/List/MoreUtils/MoreUtils.bundle".

So if someone creates a directory named ‘(eval 1)’ with a
naughty binary file in it, it will be loaded if a script
using List::MoreUtils is run in the parent directory.  See
<https://rt.cpan.org/Ticket/Display.html?id=115808>.

This commit makes XSLoader fall back to Dynaloader’s @INC search if
the calling file has a relative path.

diff --git a/dist/XSLoader/XSLoader_pm.PL b/dist/XSLoader/XSLoader_pm.PL
index 8a8852e..046ae0e 100644
--- a/dist/XSLoader/XSLoader_pm.PL
+++ b/dist/XSLoader/XSLoader_pm.PL
@@ -91,6 +91,8 @@ print OUT <<'EOT';
     my $modpname = join('/',@modparts);
     my $c = () = split(/::/,$caller,-1);
     $modlibname =~ s,[\\/][^\\/]+$,, while $c--;    # Q&D basename
+    # Avoid relative paths
+    goto \&XSLoader::bootstrap_inherit unless $modlibname =~ m|^[\\/]|;
 EOT
 
 my $dl_dlext = quotemeta($Config::Config{'dlext'});
diff --git a/dist/XSLoader/t/XSLoader.t b/dist/XSLoader/t/XSLoader.t
index 2ff11fe..9fd0586 100644
--- a/dist/XSLoader/t/XSLoader.t
+++ b/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 + 9;
+plan tests => keys(%modules) * 3 + 10;
 
 # Try to load the module
 use_ok( 'XSLoader' );
@@ -114,6 +114,8 @@ SKIP: {
 
   skip "Cannot find $peek_file", 1
     unless $module_path;
+  skip "Cannot test with relative path", 1
+    unless $module_path =~ m|^[\\/]|;
 
   # [perl #122455]
   # die instead of falling back to DynaLoader
@@ -125,3 +127,28 @@ XSLoader::load("Devel::Peek");
 EOS
     or ::diag $@;
 }
+
+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." . quotemeta($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);
+}