Validate the 'require Bare::Word' pathname.

At runtime in require, validate the generated filename after translation
of '::' to '/' (and possible conversion from VMS to Unix format) to keep
the code simpler.  Reject empty module names, module names starting with
'/' or '.'  (ie absolute paths, hidden files, and '..'), and module names
containing NUL bytes or '/.' (ie hidden files and '..').

Add a test for Perl_load_module(), and check that it now rejects module
names which fall foul of the above rules.

Most of these can't trigger for a sinple bareword require since the
illegal module name will already have been rejected during parsing. However,
the Perl_load_module() fakes up a rquire optree including a bareword
OP_CONST, which *isn't* restricted by the lexer.

Note that this doesn't apply to non-bareword pathnames: these are both
unaffected:

    require "/foo/bar.pm";
    $x =  "/foo/bar.pm"; require $x;

[ This is cherry-picked from a branch Nicholas wrote 4 years ago, but
which was never merged. I've kept the body of the diff the same, modulo
rebasing, but re-worded the commit title and message.
Only one test was changed: the final one in load-module.t, since a
\0 in a pathname is now trapped earlier and gives a "can't locate" error
instead. For the same reason, it also required the addition of
"no warnings 'syscalls';".
- DAPM ]

4 files changed, 69 insertions, 1 deletions

diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index 875579e20e..334b9e3e15 100644
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -5,7 +5,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '0.80';
+our $VERSION = '0.81';
 
 require XSLoader;
 
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 4d41654926..f175acd68d 100644
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -4183,6 +4183,18 @@ test_sv_catpvf(SV *fmtsv)
         sv = sv_2mortal(newSVpvn("", 0));
         sv_catpvf(sv, fmt, 5, 6, 7, 8);
 
+void
+load_module(flags, name, ...)
+    U32 flags
+    SV *name
+CODE:
+    if (items == 2) {
+	Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), NULL);
+    } else if (items == 3) {
+	Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), SvREFCNT_inc(ST(2)));
+    } else
+        Perl_croak(aTHX_ "load_module can't yet support %lu items", items);
+
 MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
 
 int
diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL
index 5b4d100659..c06fac6f22 100644
--- a/ext/XS-APItest/Makefile.PL
+++ b/ext/XS-APItest/Makefile.PL
@@ -27,6 +27,7 @@ my @names = (qw(HV_DELETE HV_DISABLE_UVAR_XKEY HV_FETCH_ISSTORE
 		IS_NUMBER_IN_UV IS_NUMBER_GREATER_THAN_UV_MAX
 		IS_NUMBER_NOT_INT IS_NUMBER_NEG IS_NUMBER_INFINITY
 		IS_NUMBER_NAN IS_NUMBER_TRAILING PERL_SCAN_TRAILING
+		PERL_LOADMOD_DENY PERL_LOADMOD_NOIMPORT PERL_LOADMOD_IMPORT_OPS
 		),
 	     {name=>"G_WANT", default=>["IV", "G_ARRAY|G_VOID"]});
 
diff --git a/ext/XS-APItest/t/load-module.t b/ext/XS-APItest/t/load-module.t
new file mode 100644
index 0000000000..303025fd29
--- /dev/null
+++ b/ext/XS-APItest/t/load-module.t
@@ -0,0 +1,55 @@
+#!perl -w
+use strict;
+
+use Test::More;
+use XS::APItest;
+
+# This isn't complete yet. In particular, we don't test import lists, or
+# the other flags. But it's better than nothing.
+
+is($INC{'less.pm'}, undef, "less isn't loaded");
+load_module(PERL_LOADMOD_NOIMPORT, 'less');
+like($INC{'less.pm'}, qr!(?:\A|/)lib/less\.pm\z!, "less is now loaded");
+
+delete $INC{'less.pm'};
+delete $::{'less::'};
+
+is(eval { load_module(PERL_LOADMOD_NOIMPORT, 'less', 1); 1}, undef,
+   "expect load_module() to fail");
+like($@, qr/less version 1 required--this is only version 0\./,
+     'with the correct error message');
+
+is(eval { load_module(PERL_LOADMOD_NOIMPORT, 'less', 0.03); 1}, 1,
+   "expect load_module() not to fail");
+
+for (["", qr!\ABareword in require maps to empty filename!],
+     ["::", qr!\ABareword in require maps to empty filename!],
+     ["::::", qr!\ABareword in require maps to disallowed filename "/\.pm"!],
+     ["::/", qr!\ABareword in require maps to disallowed filename "/\.pm"!],
+     ["::/WOOSH", qr!\ABareword in require maps to disallowed filename "/WOOSH\.pm"!],
+     [".WOOSH", qr!\ABareword in require maps to disallowed filename "\.WOOSH\.pm"!],
+     ["::.WOOSH", qr!\ABareword in require maps to disallowed filename "\.WOOSH\.pm"!],
+     ["WOOSH::.sock", qr!\ABareword in require contains "/\."!],
+     ["::WOOSH::.sock", qr!\ABareword in require contains "/\."!],
+     ["::WOOSH/.sock", qr!\ABareword in require contains "/\."!],
+     ["::WOOSH/..sock", qr!\ABareword in require contains "/\."!],
+     ["::WOOSH/../sock", qr!\ABareword in require contains "/\."!],
+     ["::WOOSH::..::sock", qr!\ABareword in require contains "/\."!],
+     ["::WOOSH::.::sock", qr!\ABareword in require contains "/\."!],
+     ["::WOOSH::./sock", qr!\ABareword in require contains "/\."!],
+     ["::WOOSH/./sock", qr!\ABareword in require contains "/\."!],
+     ["::WOOSH/.::sock", qr!\ABareword in require contains "/\."!],
+     ["::WOOSH/..::sock", qr!\ABareword in require contains "/\."!],
+     ["::WOOSH::../sock", qr!\ABareword in require contains "/\."!],
+     ["::WOOSH::../..::sock", qr!\ABareword in require contains "/\."!],
+     ["::WOOSH\0sock", qr!\ACan't locate WOOSH\\0sock.pm:!],
+    ) {
+    my ($module, $error) = @$_;
+    my $module2 = $module; # load_module mangles its first argument
+    no warnings 'syscalls';
+    is(eval { load_module(PERL_LOADMOD_NOIMPORT, $module); 1}, undef,
+       "expect load_module() for '$module2' to fail");
+    like($@, $error);
+}
+
+done_testing();