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);
+}
