author | Vladimir Marek <Vladimir.Marek@oracle.com> |
Tue, 19 Jul 2016 15:22:15 +0200 | |
changeset 6442 | f900f128dbb9 |
permissions | -rw-r--r-- |
6442
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
1 |
From 08e3451d7b3b714ad63a27f1b9c2a23ee75d15ee Mon Sep 17 00:00:00 2001 |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
2 |
From: Father Chrysostomos <[email protected]> |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
3 |
Date: Sat, 2 Jul 2016 22:56:51 -0700 |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
4 |
Subject: [PATCH] =?utf8?q?Don=E2=80=99t=20let=20XSLoader=20load=20relative?= |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
5 |
=?utf8?q?=20paths?= |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
6 |
MIME-Version: 1.0 |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
7 |
Content-Type: text/plain; charset=utf8 |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
8 |
Content-Transfer-Encoding: 8bit |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
9 |
|
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
10 |
[rt.cpan.org #115808] |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
11 |
|
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
12 |
The logic in XSLoader for determining the library goes like this: |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
13 |
|
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
14 |
my $c = () = split(/::/,$caller,-1); |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
15 |
$modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
16 |
my $file = "$modlibname/auto/$modpname/$modfname.bundle"; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
17 |
|
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
18 |
(That last line varies by platform.) |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
19 |
|
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
20 |
$caller is the calling package. $modlibname is the calling file. It |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
21 |
removes as many path segments from $modlibname as there are segments |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
22 |
in $caller. So if you have Foo/Bar/XS.pm calling XSLoader from the |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
23 |
Foo::Bar package, the $modlibname will end up containing the path in |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
24 |
@INC where XS.pm was found, followed by "/Foo". Usually the fallback |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
25 |
to Dynaloader::bootstrap_inherit, which does an @INC search, makes |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
26 |
things Just Work. |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
27 |
|
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
28 |
But if our hypothetical Foo/Bar/XS.pm actually calls |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
29 |
XSLoader::load from inside a string eval, then path ends up being |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
30 |
"(eval 1)/auto/Foo/Bar/Bar.bundle". |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
31 |
|
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
32 |
So if someone creates a directory named â(eval 1)â with a naughty |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
33 |
binary file in it, it will be loaded if a script using Foo::Bar is run |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
34 |
in the parent directory. |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
35 |
|
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
36 |
This commit makes XSLoader fall back to Dynaloaderâs @INC search if |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
37 |
the calling file has a relative path that is not found in @INC. |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
38 |
--- |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
39 |
dist/XSLoader/XSLoader_pm.PL | 25 +++++++++++++++++++++++++ |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
40 |
dist/XSLoader/t/XSLoader.t | 27 ++++++++++++++++++++++++++- |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
41 |
2 files changed, 51 insertions(+), 1 deletion(-) |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
42 |
|
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
43 |
--- perl-5.12.5/dist/XSLoader/XSLoader_pm.PL.old |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
44 |
+++ perl-5.12.5/dist/XSLoader/XSLoader_pm.PL |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
45 |
@@ -74,6 +74,31 @@ |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
46 |
my $modlibname = (caller())[1]; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
47 |
my $c = @modparts; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
48 |
$modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
49 |
+ # Does this look like a relative path? |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
50 |
+ if ($modlibname !~ m|^[\\/]|) { |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
51 |
+ # Someone may have a #line directive that changes the file name, or |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
52 |
+ # may be calling XSLoader::load from inside a string eval. We cer- |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
53 |
+ # tainly do not want to go loading some code that is not in @INC, |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
54 |
+ # as it could be untrusted. |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
55 |
+ # |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
56 |
+ # We could just fall back to DynaLoader here, but then the rest of |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
57 |
+ # this function would go untested in the perl core, since all @INC |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
58 |
+ # paths are relative during testing. That would be a time bomb |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
59 |
+ # waiting to happen, since bugs could be introduced into the code. |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
60 |
+ # |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
61 |
+ # So look through @INC to see if $modlibname is in it. A rela- |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
62 |
+ # tive $modlibname is not a common occurrence, so this block is |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
63 |
+ # not hot code. |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
64 |
+ FOUND: { |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
65 |
+ for (@INC) { |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
66 |
+ if ($_ eq $modlibname) { |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
67 |
+ last FOUND; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
68 |
+ } |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
69 |
+ } |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
70 |
+ # Not found. Fall back to DynaLoader. |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
71 |
+ goto \&XSLoader::bootstrap_inherit; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
72 |
+ } |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
73 |
+ } |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
74 |
my $file = "$modlibname/auto/$modpname/$modfname.$dl_dlext"; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
75 |
|
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
76 |
# print STDERR "XSLoader::load for $module ($file)\n" if $dl_debug; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
77 |
--- perl-5.12.5/dist/XSLoader/t/XSLoader.t.old |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
78 |
+++ perl-5.12.5/dist/XSLoader/t/XSLoader.t |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
79 |
@@ -30,7 +30,7 @@ |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
80 |
'Time::HiRes'=> q| ::can_ok( 'Time::HiRes' => 'usleep' ) |, # 5.7.3 |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
81 |
); |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
82 |
|
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
83 |
-plan tests => keys(%modules) * 3 + 5; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
84 |
+plan tests => keys(%modules) * 3 + 6; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
85 |
|
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
86 |
# Try to load the module |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
87 |
use_ok( 'XSLoader' ); |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
88 |
@@ -76,3 +76,27 @@ |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
89 |
} |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
90 |
} |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
91 |
|
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
92 |
+SKIP: { |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
93 |
+ skip "File::Path not available", 1 |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
94 |
+ unless eval { require File::Path }; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
95 |
+ my $name = "phooo$$"; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
96 |
+ File::Path::make_path("$name/auto/Foo/Bar"); |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
97 |
+ open my $fh, |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
98 |
+ ">$name/auto/Foo/Bar/Bar.$Config::Config{'dlext'}"; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
99 |
+ close $fh; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
100 |
+ my $fell_back; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
101 |
+ local *XSLoader::bootstrap_inherit = sub { |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
102 |
+ $fell_back++; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
103 |
+ # Break out of the calling subs |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
104 |
+ goto the_test; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
105 |
+ }; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
106 |
+ eval <<END; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
107 |
+#line 1 $name |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
108 |
+package Foo::Bar; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
109 |
+XSLoader::load("Foo::Bar"); |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
110 |
+END |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
111 |
+ the_test: |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
112 |
+ ok $fell_back, |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
113 |
+ 'XSLoader will not load relative paths based on (caller)[1]'; |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
114 |
+ File::Path::remove_tree($name); |
f900f128dbb9
23856628 problem in UTILITY/PERL
Vladimir Marek <Vladimir.Marek@oracle.com>
parents:
diff
changeset
|
115 |
+} |