From 08e3451d7b3b714ad63a27f1b9c2a23ee75d15ee Mon Sep 17 00:00:00 2001

From: Father Chrysostomos <sprout@cpan.org>

Date: Sat, 2 Jul 2016 22:56:51 -0700

Subject: [PATCH 1/4] =?UTF-8?q?Don=E2=80=99t=20let=20XSLoader=20load=20rel?=

 =?UTF-8?q?ative=20paths?=

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 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.

---

 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 8a8852e..749f72d 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 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 <

+#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.5.5

From 5993d6620f29d22b0a72701f4f0fdacff3d25460 Mon Sep 17 00:00:00 2001

From: Father Chrysostomos <sprout@cpan.org>

Date: Sat, 2 Jul 2016 22:57:46 -0700

Subject: [PATCH 2/4] Increase $XSLoader::VERSION to 0.22

---

 dist/XSLoader/XSLoader_pm.PL | 2 +-

 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/dist/XSLoader/XSLoader_pm.PL b/dist/XSLoader/XSLoader_pm.PL

index 749f72d..7e24b83 100644

--- a/dist/XSLoader/XSLoader_pm.PL

+++ b/dist/XSLoader/XSLoader_pm.PL

@@ -11,7 +11,7 @@ print OUT <<'EOT';

 package XSLoader;

-$VERSION = "0.21";

+$VERSION = "0.22";

 #use strict;

-- 

2.5.5

From a651dcdf6a9151150dcf0fb6b18849d3e39b0811 Mon Sep 17 00:00:00 2001

From: Father Chrysostomos <sprout@cpan.org>

Date: Mon, 4 Jul 2016 08:48:57 -0700

Subject: [PATCH 3/4] Fix XSLoader to recognize drive letters

Commit 08e3451d made XSLoader confirm that the file path it got

from (caller)[2] was in @INC if it looked like a relative path.

Not taking drive letters into account, it made that @INC search

mandatory on Windows and some other systems.  It still worked, but

was slightly slower.

---

 dist/XSLoader/XSLoader_pm.PL | 14 +++++++++++++-

 1 file changed, 13 insertions(+), 1 deletion(-)

diff --git a/dist/XSLoader/XSLoader_pm.PL b/dist/XSLoader/XSLoader_pm.PL

index 7e24b83..2efb99e 100644

--- a/dist/XSLoader/XSLoader_pm.PL

+++ b/dist/XSLoader/XSLoader_pm.PL

@@ -91,8 +91,20 @@ print OUT <<'EOT';

     my $modpname = join('/',@modparts);

     my $c = () = split(/::/,$caller,-1);

     $modlibname =~ s,[\\/][^\\/]+$,, while $c--;    # Q&D basename

+EOT

+

+my $to_print = <<'EOT';

     # Does this look like a relative path?

-    if ($modlibname !~ m|^[\\/]|) {

+    if ($modlibname !~ m{regexp}) {

+EOT

+

+$to_print =~ s~regexp~

+    $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'amigaos'

+        ? '^(?:[A-Za-z]:)?[\\\/]' # Optional drive letter

+        : '^/'

+~e;

+

+print OUT $to_print, <<'EOT';

         # 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,

-- 

2.5.5

From ae635bbffa4769051671b9832a7472b9d977c198 Mon Sep 17 00:00:00 2001

From: =?UTF-8?q?S=C3=A9bastien=20Aperghis-Tramoni?= <sebastien@aperghis.net>

Date: Tue, 5 Jul 2016 14:53:08 -0700

Subject: [PATCH 4/4] Synchronize blead with CPAN XSLoader 0.22

---

 dist/XSLoader/XSLoader_pm.PL | 2 +-

 dist/XSLoader/t/XSLoader.t   | 4 ++--

 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/dist/XSLoader/XSLoader_pm.PL b/dist/XSLoader/XSLoader_pm.PL

index 2efb99e..09f9d4b 100644

--- a/dist/XSLoader/XSLoader_pm.PL

+++ b/dist/XSLoader/XSLoader_pm.PL

@@ -255,7 +255,7 @@ XSLoader - Dynamically load C libraries into Perl code

 =head1 VERSION

-Version 0.17

+Version 0.22

 =head1 SYNOPSIS

diff --git a/dist/XSLoader/t/XSLoader.t b/dist/XSLoader/t/XSLoader.t

index 1e86faa..d3538b8 100644

--- a/dist/XSLoader/t/XSLoader.t

+++ b/dist/XSLoader/t/XSLoader.t

@@ -130,7 +130,7 @@ SKIP: {

   skip "File::Path not available", 1

     unless eval { require File::Path };

   my $name = "phooo$$";

-  File::Path::make_path("$name/auto/Foo/Bar");

+  File::Path::mkpath("$name/auto/Foo/Bar");

   open my $fh,

     ">$name/auto/Foo/Bar/Bar.$Config::Config{'dlext'}";

   close $fh;

@@ -148,5 +148,5 @@ END

  the_test:

   ok $fell_back,

     'XSLoader will not load relative paths based on (caller)[1]';

-  File::Path::remove_tree($name);

+  File::Path::rmtree($name);

 }

-- 

2.5.5