| From 7cedaa8bc2ca9e63369d0e2d4c4c23af9febb93a Mon Sep 17 00:00:00 2001 |
| From: Father Chrysostomos <sprout@cpan.org> |
| Date: Sat, 2 Jul 2016 22:56:51 -0700 |
| Subject: [PATCH] perl: fix CVE-2016-6185 |
| MIME-Version: 1.0 |
| |
| 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. |
| |
| Backport patch from http://perl5.git.perl.org/perl.git/commitdiff/08e3451d7 |
| |
| Upstream-Status: Backport |
| CVE: CVE-2016-6185 |
| Signed-off-by: Mingli Yu <Mingli.Yu@windriver.com> |
| --- |
| dist/XSLoader/XSLoader_pm.PL | 25 +++++++++++++++++++++++++ |
| dist/XSLoader/t/XSLoader.t | 27 ++++++++++++++++++++++++++- |
| 2 files changed, 51 insertions(+), 1 deletion(-) |
| |
| diff --git a/dist/XSLoader/XSLoader_pm.PL b/dist/XSLoader/XSLoader_pm.PL |
| index 668411d..778e46b 100644 |
| --- a/dist/XSLoader/XSLoader_pm.PL |
| +++ b/dist/XSLoader/XSLoader_pm.PL |
| @@ -104,6 +104,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 2ff11fe..1e86faa 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); |
| +} |
| -- |
| 2.8.1 |
| |