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 ]

1 files changed, 40 insertions, 0 deletions

diff --git a/pp_ctl.c b/pp_ctl.c
index aa29e94e67..423691cad2 100644
--- a/pp_ctl.c
+++ b/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);