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 ]

Author: nwc10

MANIFEST

@@ -3987,6 +3987,7 @@ ext/XS-APItest/t/labelconst.aux	auxiliary file for label test
 ext/XS-APItest/t/labelconst.t	test recursive descent label parsing
 ext/XS-APItest/t/labelconst_utf8.aux	auxiliary file for label test in UTF-8
 ext/XS-APItest/t/lexsub.t	Test XS registration of lexical subs
+ext/XS-APItest/t/load-module.t	test load_module()
 ext/XS-APItest/t/locale.t	test locale-related things
 ext/XS-APItest/t/loopblock.t	test recursive descent block parsing
 ext/XS-APItest/t/looprest.t	test recursive descent statement-sequence parsing

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;
 

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

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"]});
 

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();

op.c

@@ -10633,6 +10633,8 @@ Perl_ck_require(pTHX_ OP *o)
                 Move(s+2, s, len - 2, char);
                 end -= 2;
             }
+            if (s == end)
+                DIE(aTHX_ "Bareword in require maps to empty filename");
 
 	    for (; s < end; s++) {
 		if (*s == ':' && s[1] == ':') {

pod/perldiag.pod

@@ -532,6 +532,17 @@ a bareword:
 
 The C<strict> pragma is useful in avoiding such errors.
 
+=item Bareword in require contains "%s"
+
+=item Bareword in require maps to empty filename
+
+=item Bareword in require maps to disallowed filename "%s"
+
+(F) The bareword form of require has been invoked with a filename which could
+not have been generated by a valid bareword permitted by the parser. You
+shouldn't be able to get this error from Perl code, but XS code may throw it
+if it passes an invalid module name to C<Perl_load_module>.
+
 =item Bareword "%s" not allowed while "strict subs" in use
 
 (F) With "strict subs" in use, a bareword is only allowed as a

pp_ctl.c

@@ -3727,6 +3727,46 @@ S_require_file(pTHX_ SV *const sv)
 		DIE(aTHX_ "Attempt to reload %s aborted.\n"
 			    "Compilation failed in require", unixname);
 	}
+
+        if (PL_op->op_flags & OPf_KIDS) {
+            SVOP * const kid = (SVOP*)cUNOP->op_first;
+
+            if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+                /* require foo (or use foo) with a bareword.
+                   Perl_load_module fakes up the identical optree, but its
+                   arguments aren't restricted by the parser to real barewords.
+                */
+                const STRLEN package_len = len - 3;
+                const char slashdot[2] = {'/', '.'};
+#ifdef DOSISH
+                const char backslashdot[2] = {'\\', '.'};
+#endif
+
+                /* Disallow *purported* barewords that map to absolute
+                   filenames, filenames relative to the current or parent
+                   directory, or (*nix) hidden filenames.  Also sanity check
+                   that the generated filename ends .pm  */
+                if (!path_searchable || len < 3 || name[0] == '.'
+                    || !memEQ(name + package_len, ".pm", 3))
+                    DIE(aTHX_ "Bareword in require maps to disallowed filename \"%"SVf"\"", sv);
+                if (memchr(name, 0, package_len)) {
+                    /* diag_listed_as: Bareword in require contains "%s" */
+                    DIE(aTHX_ "Bareword in require contains \"\\0\"");
+                }
+                if (ninstr(name, name + package_len, slashdot,
+                           slashdot + sizeof(slashdot))) {
+                    /* diag_listed_as: Bareword in require contains "%s" */
+                    DIE(aTHX_ "Bareword in require contains \"/.\"");
+                }
+#ifdef DOSISH
+                if (ninstr(name, name + package_len, backslashdot,
+                           backslashdot + sizeof(backslashdot))) {
+                    /* diag_listed_as: Bareword in require contains "%s" */
+                    DIE(aTHX_ "Bareword in require contains \"\\.\"");
+                }
+#endif
+            }
+        }
     }
 
     PERL_DTRACE_PROBE_FILE_LOADING(unixname);