diff options
author | Father Chrysostomos <sprout@cpan.org> | 2016-07-02 22:56:51 -0700 |
---|---|---|
committer | Steve Hay <steve.m.hay@googlemail.com> | 2016-07-21 21:30:48 +0100 |
commit | 7099cb3d4b19649244b3ff4171da683abbd5e2bd (patch) | |
tree | 99c862646b940881ae2c2e990cae18a9836caa20 | |
parent | 7682ed29a1a27848f952c4d878fd57f25b603d57 (diff) | |
download | perl-7099cb3d4b19649244b3ff4171da683abbd5e2bd.tar.gz |
Don’t let XSLoader load relative paths
[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 Foo/Bar/XS.pm calling XSLoader from the
Foo::Bar package, the $modlibname will end up containing the path in
@INC where XS.pm was found, followed by "/Foo". Usually the fallback
to Dynaloader::bootstrap_inherit, which does an @INC search, makes
things Just Work.
But if our hypothetical Foo/Bar/XS.pm actually calls
XSLoader::load from inside a string eval, then path ends up being
"(eval 1)/auto/Foo/Bar/Bar.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 Foo::Bar is run
in the parent directory.
This commit makes XSLoader fall back to Dynaloader’s @INC search if
the calling file has a relative path that is not found in @INC.
(cherry picked from commit 08e3451d7b3b714ad63a27f1b9c2a23ee75d15ee)
-rw-r--r-- | dist/XSLoader/XSLoader_pm.PL | 25 | ||||
-rw-r--r-- | dist/XSLoader/t/XSLoader.t | 27 |
2 files changed, 51 insertions, 1 deletions
diff --git a/dist/XSLoader/XSLoader_pm.PL b/dist/XSLoader/XSLoader_pm.PL index 8a8852e85a..749f72da4b 100644 --- a/dist/XSLoader/XSLoader_pm.PL +++ b/dist/XSLoader/XSLoader_pm.PL @@ -91,6 +91,31 @@ print OUT <<'EOT'; my $modpname = join('/',@modparts); my $c = () = split(/::/,$caller,-1); $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/dist/XSLoader/t/XSLoader.t b/dist/XSLoader/t/XSLoader.t index 2ff11fe5c3..1e86faa9ed 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' ); @@ -125,3 +125,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.$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); +} |