In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/8135baed8e5671abf0e9d8b55233259df5729c87?hp=da7cf1cc7cedc01f35ceb6724e8260c3b0ee0d12>
- Log ----------------------------------------------------------------- commit 8135baed8e5671abf0e9d8b55233259df5729c87 Merge: da7cf1c 09cfff4 Author: David Mitchell <[email protected]> Date: Tue May 10 11:16:00 2016 +0100 [MERGE] disallow 'require ::Foo::Bar' etc commit 09cfff44b722bf8a2467d7467da8dd4a8cfa4b45 Author: David Mitchell <[email protected]> Date: Tue May 10 10:48:18 2016 +0100 load-module.t: re-indent and add some comments. No functional changes. M ext/XS-APItest/t/load-module.t commit 5bad2b3959332943ca48f8b4f44af83effad4314 Author: David Mitchell <[email protected]> Date: Sat Mar 19 20:16:22 2016 +0000 make 'require ::Foo::Bar' die Originally, 'require ::Foo::Bar' would try to load /Foo/Bar.pm. The previous commit changed it so that ::Foo::Bar mapped to Foo::Bar, and so loaded Foo/Bar.pm in the @INC path. This commit takes the different approach of, instead of mapping, making any bareword require that starts with '::' into an error instead. It introduces a new error message: $ perl -e'require ::Foo::Bar' Bareword in require must not start with a double-colon: "::Foo::Bar" $ See the thread at: http://www.nntp.perl.org/group/perl.perl5.porters/2012/07/msg189909.html ( I originally used '"::"' rather than 'a double-colon', but that made the message a bit unpenetrable: Bareword in require must not start with "::": "::Foo::Bar" ) M ext/XS-APItest/t/load-module.t M op.c M pod/perldiag.pod M t/comp/require.t M t/op/require_errors.t commit a52f2cced5b51a96e90a2604111245e6096dae5b Author: Nicholas Clark <[email protected]> Date: Wed Jun 27 23:34:04 2012 +0200 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 ] M MANIFEST M ext/XS-APItest/APItest.pm M ext/XS-APItest/APItest.xs M ext/XS-APItest/Makefile.PL A ext/XS-APItest/t/load-module.t M op.c M pod/perldiag.pod M pp_ctl.c commit 614273add497cd4fbed447fdad84ef323b226b18 Author: Nicholas Clark <[email protected]> Date: Thu Jun 28 22:35:20 2012 +0200 Treat require ::foo::bar; the same as foo::bar; [ This is cherry-picked from a branch Nicholas wrote 4 years ago, but which was never merged. In the meantime it was agreed that 'require ::foo' should die instead of doing 'require foo'; but I've pulled it in anyway as an interim commit, to make later cherry-picks easier. The die will come in a later commit. ] M op.c M t/comp/require.t M t/op/require_errors.t commit 9cdec1363fe2fdf6139eb2e9c013baeb2d0e0c29 Author: David Mitchell <[email protected]> Date: Sat Mar 19 15:24:49 2016 +0000 reindent S_require_version() Whitespace-only change. M pp_ctl.c commit 5fb413889777319544fb826f2cd3d8e78459b0a8 Author: David Mitchell <[email protected]> Date: Sat Mar 19 15:16:50 2016 +0000 Split the guts of pp_require into two static fns S_require_version() and S_require_file() do the 'require 5.010001' and 'require Foo::Bar' actions respectively. This makes it clear that pp_require is effectively 2 disjoint functions, and that all the local variables previously declared at the start of pp_require actually belong exclusively to the file loading functionality. This is based on a patch by Nicholas from 4 years ago, except that I did the split from scratch since pp_require has been touched quite a bit since then. This commit splits it in such a way that the diff is kept as small as possible. The next commit will re-indent. M pp_ctl.c ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + ext/XS-APItest/APItest.pm | 2 +- ext/XS-APItest/APItest.xs | 12 +++ ext/XS-APItest/Makefile.PL | 1 + ext/XS-APItest/t/load-module.t | 66 ++++++++++++++ op.c | 6 ++ pod/perldiag.pod | 17 ++++ pp_ctl.c | 189 +++++++++++++++++++++++++++-------------- t/comp/require.t | 8 +- t/op/require_errors.t | 9 +- 10 files changed, 243 insertions(+), 68 deletions(-) create mode 100644 ext/XS-APItest/t/load-module.t diff --git a/MANIFEST b/MANIFEST index 1602cdd..e007a0d 100644 --- a/MANIFEST +++ b/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 diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index 875579e..334b9e3 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 4d41654..f175acd 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 5b4d100..c06fac6 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 0000000..78189f8 --- /dev/null +++ b/ext/XS-APItest/t/load-module.t @@ -0,0 +1,66 @@ +#!perl -w +use strict; + +# Test the load_module() core API function. +# +# Note that this function can be passed arbitrary and illegal module +# names which would already have been caught if a require statement had +# been compiled. So check that load_module() can catch such bad things. + +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"); + +# +# Check for illegal module names + +for (["", qr!\ABareword in require maps to empty filename!], + ["::", qr!\ABareword in require must not start with a double-colon: "::"!], + ["::::", qr!\ABareword in require must not start with a double-colon: "::::"!], + ["::/", qr!\ABareword in require must not start with a double-colon: "::/!], + ["/", qr!\ABareword in require maps to disallowed filename "/\.pm"!], + ["::/WOOSH", qr!\ABareword in require must not start with a double-colon: "::/WOOSH!], + [".WOOSH", qr!\ABareword in require maps to disallowed filename "\.WOOSH\.pm"!], + ["::.WOOSH", qr!\ABareword in require must not start with a double-colon: "::.WOOSH!], + ["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, "check expected error for $module2"); +} + +done_testing(); diff --git a/op.c b/op.c index 4b6b227..93205fe 100644 --- a/op.c +++ b/op.c @@ -10628,6 +10628,12 @@ Perl_ck_require(pTHX_ OP *o) s = SvPVX(sv); len = SvCUR(sv); end = s + len; + /* treat ::foo::bar as foo::bar */ + if (len >= 2 && s[0] == ':' && s[1] == ':') + DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s); + if (s == end) + DIE(aTHX_ "Bareword in require maps to empty filename"); + for (; s < end; s++) { if (*s == ':' && s[1] == ':') { *s = '/'; diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 084db56..b949729 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -532,6 +532,23 @@ 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 in require must not start with a double-colon: "%s" + +(F) In C<require Bare::Word>, the bareword is not allowed to start with a +double-colon. Write C<require ::Foo::Bar> as C<require Foo::Bar> instead. + =item Bareword "%s" not allowed while "strict subs" in use (F) With "strict subs" in use, a bareword is only allowed as a diff --git a/pp_ctl.c b/pp_ctl.c index 99ff59a..423691c 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -3582,13 +3582,80 @@ S_path_is_searchable(const char *name) } -/* also used for: pp_dofile() */ +/* implement 'require 5.010001' */ -PP(pp_require) +static OP * +S_require_version(pTHX_ SV *sv) { - dSP; + dVAR; dSP; + + sv = sv_2mortal(new_version(sv)); + if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0)) + upg_version(PL_patchlevel, TRUE); + if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { + if ( vcmp(sv,PL_patchlevel) <= 0 ) + DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped", + SVfARG(sv_2mortal(vnormal(sv))), + SVfARG(sv_2mortal(vnormal(PL_patchlevel))) + ); + } + else { + if ( vcmp(sv,PL_patchlevel) > 0 ) { + I32 first = 0; + AV *lav; + SV * const req = SvRV(sv); + SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE); + + /* get the left hand term */ + lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE))); + + first = SvIV(*av_fetch(lav,0,0)); + if ( first > (int)PERL_REVISION /* probably 'use 6.0' */ + || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */ + || av_tindex(lav) > 1 /* FP with > 3 digits */ + || strstr(SvPVX(pv),".0") /* FP with leading 0 */ + ) { + DIE(aTHX_ "Perl %"SVf" required--this is only " + "%"SVf", stopped", + SVfARG(sv_2mortal(vnormal(req))), + SVfARG(sv_2mortal(vnormal(PL_patchlevel))) + ); + } + else { /* probably 'use 5.10' or 'use 5.8' */ + SV *hintsv; + I32 second = 0; + + if (av_tindex(lav)>=1) + second = SvIV(*av_fetch(lav,1,0)); + + second /= second >= 600 ? 100 : 10; + hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0", + (int)first, (int)second); + upg_version(hintsv, TRUE); + + DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)" + "--this is only %"SVf", stopped", + SVfARG(sv_2mortal(vnormal(req))), + SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))), + SVfARG(sv_2mortal(vnormal(PL_patchlevel))) + ); + } + } + } + + RETPUSHYES; +} + +/* Handle C<require Foo::Bar>, C<require "Foo/Bar.pm"> and C<do "Foo.pm">. + * The first form will have already been converted at compile time to + * the second form */ + +static OP * +S_require_file(pTHX_ SV *const sv) +{ + dVAR; dSP; + PERL_CONTEXT *cx; - SV *sv; const char *name; STRLEN len; char * unixname; @@ -3611,65 +3678,6 @@ PP(pp_require) bool path_searchable; I32 old_savestack_ix; - sv = POPs; - SvGETMAGIC(sv); - if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) { - sv = sv_2mortal(new_version(sv)); - if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0)) - upg_version(PL_patchlevel, TRUE); - if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { - if ( vcmp(sv,PL_patchlevel) <= 0 ) - DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped", - SVfARG(sv_2mortal(vnormal(sv))), - SVfARG(sv_2mortal(vnormal(PL_patchlevel))) - ); - } - else { - if ( vcmp(sv,PL_patchlevel) > 0 ) { - I32 first = 0; - AV *lav; - SV * const req = SvRV(sv); - SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE); - - /* get the left hand term */ - lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE))); - - first = SvIV(*av_fetch(lav,0,0)); - if ( first > (int)PERL_REVISION /* probably 'use 6.0' */ - || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */ - || av_tindex(lav) > 1 /* FP with > 3 digits */ - || strstr(SvPVX(pv),".0") /* FP with leading 0 */ - ) { - DIE(aTHX_ "Perl %"SVf" required--this is only " - "%"SVf", stopped", - SVfARG(sv_2mortal(vnormal(req))), - SVfARG(sv_2mortal(vnormal(PL_patchlevel))) - ); - } - else { /* probably 'use 5.10' or 'use 5.8' */ - SV *hintsv; - I32 second = 0; - - if (av_tindex(lav)>=1) - second = SvIV(*av_fetch(lav,1,0)); - - second /= second >= 600 ? 100 : 10; - hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0", - (int)first, (int)second); - upg_version(hintsv, TRUE); - - DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)" - "--this is only %"SVf", stopped", - SVfARG(sv_2mortal(vnormal(req))), - SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))), - SVfARG(sv_2mortal(vnormal(PL_patchlevel))) - ); - } - } - } - - RETPUSHYES; - } if (!SvOK(sv)) DIE(aTHX_ "Missing or undefined argument to require"); name = SvPV_nomg_const(sv, len); @@ -3719,6 +3727,46 @@ PP(pp_require) 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); @@ -4062,6 +4110,21 @@ PP(pp_require) return op; } + +/* also used for: pp_dofile() */ + +PP(pp_require) +{ + dSP; + SV *sv = POPs; + SvGETMAGIC(sv); + PUTBACK; + return ((SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) + ? S_require_version(aTHX_ sv) + : S_require_file(aTHX_ sv); +} + + /* This is a op added to hold the hints hash for pp_entereval. The hash can be modified by the code being eval'ed, so we return a copy instead. */ diff --git a/t/comp/require.t b/t/comp/require.t index b3e4995..c4889bb 100644 --- a/t/comp/require.t +++ b/t/comp/require.t @@ -34,7 +34,7 @@ if (grep -e, @files_to_delete) { my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0; my $Is_UTF8 = (${^OPEN} || "") =~ /:utf8/; -my $total_tests = 57; +my $total_tests = 58; if ($Is_EBCDIC || $Is_UTF8) { $total_tests -= 3; } print "1..$total_tests\n"; @@ -203,7 +203,11 @@ $foo = eval q{require bleah}; delete $INC{"bleah.pm"}; ++$::i; eval q{return require bleah}; delete $INC{"bleah.pm"}; ++$::i; $foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i; @foo = eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i; - eval {require bleah}; + eval {require bleah}; delete $INC{"bleah.pm"}; ++$::i; + +eval 'require ::bleah;'; +print "# $@\nnot " unless $@ =~ /^Bareword in require must not start with a double-colon:/; +print "ok ", $i," - require ::bleah is banned\n"; # Test for fix of RT #24404 : "require $scalar" may load a directory my $r = "threads"; diff --git a/t/op/require_errors.t b/t/op/require_errors.t index 3d3d027..3744f14 100644 --- a/t/op/require_errors.t +++ b/t/op/require_errors.t @@ -8,7 +8,7 @@ BEGIN { use strict; use warnings; -plan(tests => 17); +plan(tests => 18); my $nonfile = tempfile(); @@ -29,7 +29,12 @@ for my $file ($nonfile, ' ') { eval "require $nonfile"; like $@, qr/^Can't locate $nonfile\.pm in \@INC \(you may need to install the $nonfile module\) \(\@INC contains: @INC\) at/, - "correct error message for require $nonfile"; + "correct error message for require $nonfile"; + +eval "require ::$nonfile"; + +like $@, qr/^Bareword in require must not start with a double-colon:/, + "correct error message for require ::$nonfile"; eval { require "$nonfile.ph"; -- Perl5 Master Repository
