In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/305ff1d4a79c10f61723b1d623e63193aa451a01?hp=28922db9cdcd7167db49e97fc5d4d16456ceff36>
- Log ----------------------------------------------------------------- commit 305ff1d4a79c10f61723b1d623e63193aa451a01 Merge: 28922db9cd d31614f579 Author: David Mitchell <[email protected]> Date: Tue Apr 18 13:14:10 2017 +0100 [MERGE] fix require's croak message RT #131098 This branch fixes two issues with the message produced when require croaks. First it mentioned @INC even when @INC wasn't scanned, and second it emitted the "you may need to install Foo::Bar module" hint even when the failed-to-load pathname wasn't reverse-mappable to a module name. commit d31614f579da61846a22a2eb69b1d0412c86d54f Author: David Mitchell <[email protected]> Date: Sun Apr 16 09:50:04 2017 +0100 emit require module name err hint only when valid RT #131098 The helpful "you may need to install" hint which 'require' sometimes includes in its error message these days (split across multiple lines for clarity): $ perl -e'require Foo::Bar' Can't locate Foo/Bar.pm in @INC (you may need to install the Foo::Bar module) (@INC contains: ... ) at ... is a bit over-enthusiastic when the pathname hasn't actually been derived from a module name: $ perl -e'require "Foo.+/%#Bar.pm"' Can't locate Foo.+%#Bar.pm in @INC (you may need to install the Foo.+::%#Bar module) (@INC contains: ... ) at ... This commit changes things so that the hint message is only emitted if the reverse-mapped module name is legal as a bareword: $ perl -e'require "Foo.+/%#Bar.pm"' Can't locate Foo.+%#Bar.pm in @INC (@INC contains: ... ) at ... M pp_ctl.c M t/op/require_errors.t commit 4b62894a4418bf61f306acb452472eb9fe79974e Author: David Mitchell <[email protected]> Date: Thu Apr 13 12:23:59 2017 +0100 require die msg: only mention @INC if used RT #131098 5.8.0 introduced a change which as an inadvertent side-effect caused this @INC-related require croak message: Can't locate foo in @INC (@INC contains: ...) at ... to be emitted even when foo is a non-searchable pathname (like /foo or ./foo) and @INC isn't used. This commit reverts the error message in these cases to be the simple Can't locate foo at ... M pp_ctl.c M t/op/require_errors.t commit 13e8e86634c636913120ec966070c3f59eedcb29 Author: David Mitchell <[email protected]> Date: Thu Apr 13 11:53:35 2017 +0100 S_require_file() : simplify an else if block change if (...) { ... } else { if (...) { ... } } to if (...) { ... } else if (...) { ... } Should make no functional difference M pp_ctl.c commit f0dea69ccb41c8ee0d9ed8ec7a0dc107daacde11 Author: David Mitchell <[email protected]> Date: Thu Apr 13 11:50:39 2017 +0100 better comment require() source. Add code more comments to S_require_file() and its helpder functions to better understand what's going on. M pp_ctl.c ----------------------------------------------------------------------- Summary of changes: pp_ctl.c | 115 ++++++++++++++++++++++++++++++++++++++------------ t/op/require_errors.t | 111 ++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 195 insertions(+), 31 deletions(-) diff --git a/pp_ctl.c b/pp_ctl.c index 3ad4c6568e..e75e151f81 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -3506,6 +3506,9 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) return TRUE; } +/* Return NULL if the file doesn't exist or isn't a file; + * else return PerlIO_openn(). + */ STATIC PerlIO * S_check_type_and_open(pTHX_ SV *name) @@ -3566,6 +3569,11 @@ S_check_type_and_open(pTHX_ SV *name) return retio; } +/* doopen_pm(): return the equivalent of PerlIO_openn() on the given name, + * but first check for bad names (\0) and non-files. + * Also if the filename ends in .pm and unless PERL_DISABLE_PMC, + * try loading Foo.pmc first. + */ #ifndef PERL_DISABLE_PMC STATIC PerlIO * S_doopen_pm(pTHX_ SV *name) @@ -3599,8 +3607,8 @@ S_doopen_pm(pTHX_ SV *name) # define doopen_pm(name) check_type_and_open(name) #endif /* !PERL_DISABLE_PMC */ -/* require doesn't search for absolute names, or when the name is - explicitly relative the current directory */ +/* require doesn't search in @INC for absolute names, or when the name is + explicitly relative the current directory: i.e. ./, ../ */ PERL_STATIC_INLINE bool S_path_is_searchable(const char *name) { @@ -3708,8 +3716,10 @@ S_require_file(pTHX_ SV *sv) int vms_unixname = 0; char *unixdir; #endif + /* tryname is the actual pathname (with @INC prefix) which was loaded. + * It's stored as a value in %INC, and used for error messages */ const char *tryname = NULL; - SV *namesv = NULL; + SV *namesv = NULL; /* SV equivalent of tryname */ const U8 gimme = GIMME_V; int filter_has_file = 0; PerlIO *tryrsfp = NULL; @@ -3780,14 +3790,20 @@ S_require_file(pTHX_ SV *sv) "Compilation failed in require", unixname); } + /*XXX OPf_KIDS should always be true? -dapm 4/2017 */ 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. - */ + /* Make sure that a bareword module name (e.g. ::Foo::Bar) + * doesn't map to a naughty pathname like /Foo/Bar.pm. + * Note that the parser will normally detect such errors + * at compile time before we reach here, but + * Perl_load_module() can fake up an identical optree + * without going near the parser, and being able to put + * anything as the bareword. So we include a duplicate set + * of checks here at runtime. + */ const STRLEN package_len = len - 3; const char slashdot[2] = {'/', '.'}; #ifdef DOSISH @@ -3823,13 +3839,22 @@ S_require_file(pTHX_ SV *sv) PERL_DTRACE_PROBE_FILE_LOADING(unixname); - /* prepare to compile file */ + /* Try to locate and open a file, possibly using @INC */ + /* with "/foo/bar.pm", "./foo.pm" and "../foo/bar.pm", try to load + * the file directly rather than via @INC ... */ if (!path_searchable) { /* At this point, name is SvPVX(sv) */ tryname = name; tryrsfp = doopen_pm(sv); } + + /* ... but if we fail, still search @INC for code references; + * these are applied even on on-searchable paths (except + * if we got EACESS). + * + * For searchable paths, just search @INC normally + */ if (!tryrsfp && !(errno == EACCES && !path_searchable)) { AV * const ar = GvAVn(PL_incgv); SSize_t i; @@ -3972,8 +3997,9 @@ S_require_file(pTHX_ SV *sv) filter_sub = NULL; } } - else { - if (path_searchable) { + else if (path_searchable) { + /* match against a plain @INC element (non-searchable + * paths are only matched against refs in @INC) */ const char *dir; STRLEN dirlen; @@ -4053,41 +4079,74 @@ S_require_file(pTHX_ SV *sv) */ break; } - } } } } } + + /* at this point we've ether opened a file (tryrsfp) or set errno */ + saved_errno = errno; /* sv_2mortal can realloc things */ sv_2mortal(namesv); if (!tryrsfp) { + /* we failed; croak if require() or return undef if do() */ if (op_is_require) { if(saved_errno == EMFILE || saved_errno == EACCES) { /* diag_listed_as: Can't locate %s */ DIE(aTHX_ "Can't locate %s: %s: %s", name, tryname, Strerror(saved_errno)); } else { - if (namesv) { /* did we lookup @INC? */ + if (path_searchable) { /* did we lookup @INC? */ AV * const ar = GvAVn(PL_incgv); SSize_t i; SV *const msg = newSVpvs_flags("", SVs_TEMP); SV *const inc = newSVpvs_flags("", SVs_TEMP); + const char *e = name + len - 3; /* possible .pm */ for (i = 0; i <= AvFILL(ar); i++) { sv_catpvs(inc, " "); sv_catsv(inc, *av_fetch(ar, i, TRUE)); } - if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) { - const char *c, *e = name + len - 3; - sv_catpv(msg, " (you may need to install the "); - for (c = name; c < e; c++) { - if (*c == '/') { - sv_catpvs(msg, "::"); - } - else { - sv_catpvn(msg, c, 1); - } - } - sv_catpv(msg, " module)"); + if (e > name && _memEQs(e, ".pm")) { + const char *c; + bool utf8 = cBOOL(SvUTF8(sv)); + + /* if the filename, when converted from "Foo/Bar.pm" + * form back to Foo::Bar form, makes a valid + * package name (i.e. parseable by C<require + * Foo::Bar>), then emit a hint. + * + * this loop is modelled after the one in + S_parse_ident */ + c = name; + while (c < e) { + if (utf8 && isIDFIRST_utf8_safe(c, e)) { + c += UTF8SKIP(c); + while (c < e && isIDCONT_utf8_safe( + (const U8*) c, (const U8*) e)) + c += UTF8SKIP(c); + } + else if (isWORDCHAR_A(*c)) { + while (c < e && isWORDCHAR_A(*c)) + c++; + } + else if (*c == '/') + c++; + else + break; + } + + if (c == e && isIDFIRST_lazy_if_safe(name, e, utf8)) { + sv_catpv(msg, " (you may need to install the "); + for (c = name; c < e; c++) { + if (*c == '/') { + sv_catpvs(msg, "::"); + } + else { + sv_catpvn(msg, c, 1); + } + } + sv_catpv(msg, " module)"); + } } else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) { sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)"); @@ -4109,8 +4168,8 @@ S_require_file(pTHX_ SV *sv) Stat_t st; PerlIO *io = NULL; dSAVE_ERRNO; - /* the complication is to match the logic from doopen_pm() so we don't treat do "sda1" as - a previously successful "do". + /* the complication is to match the logic from doopen_pm() so + * we don't treat do "sda1" as a previously successful "do". */ bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED) && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode) @@ -4133,7 +4192,7 @@ S_require_file(pTHX_ SV *sv) else SETERRNO(0, SS_NORMAL); - /* Assume success here to prevent recursive requirement. */ + /* Update %INC. Assume success here to prevent recursive requirement. */ /* name is never assigned to again, so len is still strlen(name) */ /* Check whether a hook in @INC has already filled %INC */ if (!hook_sv) { @@ -4146,6 +4205,8 @@ S_require_file(pTHX_ SV *sv) unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 ); } + /* Now parse the file */ + old_savestack_ix = PL_savestack_ix; SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tryname); diff --git a/t/op/require_errors.t b/t/op/require_errors.t index ca1622a807..2226c97130 100644 --- a/t/op/require_errors.t +++ b/t/op/require_errors.t @@ -9,7 +9,7 @@ BEGIN { use strict; use warnings; -plan(tests => 27); +plan(tests => 54); my $nonfile = tempfile(); @@ -25,10 +25,104 @@ for my $file ($nonfile, ' ') { "correct error message for require '$file'"; } -eval "require $nonfile"; +# Check that the "(you may need to install..) hint is included in the +# error message where (and only where) appropriate. +# +# Basically the hint should be issued for any filename where converting +# back from Foo/Bar.pm to Foo::Bar gives you a legal bare word which could +# follow "require" in source code. + +{ + + # may be any letter of an identifier + my $I = "\x{393}"; # "\N{GREEK CAPITAL LETTER GAMMA}" + # Continuation char: may only be 2nd+ letter of an identifier + my $C = "\x{387}"; # "\N{GREEK ANO TELEIA}" + + for my $test_data ( + # thing to require pathname in err mesg err includes hint? + [ "No::Such::Module1", "No/Such/Module1.pm", 1 ], + [ "'No/Such/Module1.pm'", "No/Such/Module1.pm", 1 ], + [ "_No::Such::Module1", "_No/Such/Module1.pm", 1 ], + [ "'_No/Such/Module1.pm'", "_No/Such/Module1.pm", 1 ], + [ "'No/Such./Module.pm'", "No/Such./Module.pm", 0 ], + [ "No::1Such::Module", "No/1Such/Module.pm", 1 ], + [ "'No/1Such/Module.pm'", "No/1Such/Module.pm", 1 ], + [ "1No::Such::Module", undef, 0 ], + [ "'1No/Such/Module.pm'", "1No/Such/Module.pm", 0 ], + + # utf8 variants + [ "No::Such${I}::Module1", "No/Such${I}/Module1.pm", 1 ], + [ "'No/Such${I}/Module1.pm'", "No/Such${I}/Module1.pm", 1 ], + [ "_No::Such${I}::Module1", "_No/Such${I}/Module1.pm", 1 ], + [ "'_No/Such${I}/Module1.pm'", "_No/Such${I}/Module1.pm", 1 ], + [ "'No/Such${I}./Module.pm'", "No/Such${I}./Module.pm", 0 ], + [ "No::1Such${I}::Module", "No/1Such${I}/Module.pm", 1 ], + [ "'No/1Such${I}/Module.pm'", "No/1Such${I}/Module.pm", 1 ], + [ "1No::Such${I}::Module", undef, 0 ], + [ "'1No/Such${I}/Module.pm'", "1No/Such${I}/Module.pm", 0 ], + + # utf8 with continuation char in 1st position + [ "No::${C}Such::Module1", undef, 0 ], + [ "'No/${C}Such/Module1.pm'", "No/${C}Such/Module1.pm", 0 ], + [ "_No::${C}Such::Module1", undef, 0 ], + [ "'_No/${C}Such/Module1.pm'", "_No/${C}Such/Module1.pm", 0 ], + [ "'No/${C}Such./Module.pm'", "No/${C}Such./Module.pm", 0 ], + [ "No::${C}1Such::Module", undef, 0 ], + [ "'No/${C}1Such/Module.pm'", "No/${C}1Such/Module.pm", 0 ], + [ "1No::${C}Such::Module", undef, 0 ], + [ "'1No/${C}Such/Module.pm'", "1No/${C}Such/Module.pm", 0 ], + + ) { + my ($require_arg, $err_path, $has_hint) = @$test_data; + + my $exp; + if (defined $err_path) { + $exp = "Can't locate $err_path in \@INC"; + if ($has_hint) { + my $hint = $err_path; + $hint =~ s{/}{::}g; + $hint =~ s/\.pm$//; + $exp .= " (you may need to install the $hint module)"; + } + $exp .= " (\@INC contains: @INC) at"; + } + else { + # undef implies a require which doesn't compile, + # rather than one which triggers a run-time error. + # We'll set exp to a suitable value later; + $exp = ""; + } + + my $err; + { + no warnings qw(syntax utf8); + if ($require_arg =~ /[^\x00-\xff]/) { + eval "require $require_arg"; + $err = $@; + utf8::decode($err); + } + else { + eval "require $require_arg"; + $err = $@; + } + } + + for ($err, $exp, $require_arg) { + s/([^\x00-\xff])/sprintf"\\x{%x}",ord($1)/ge; + } + if (length $exp) { + $exp = qr/^\Q$exp\E/; + } + else { + $exp = qr/syntax error at|Unrecognized character/; + } + like $err, $exp, + "err for require $require_arg"; + } +} + -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"; eval "require ::$nonfile"; @@ -168,3 +262,12 @@ like $@, qr/^Missing or undefined argument to require /; eval { do "" }; like $@, qr/^Missing or undefined argument to do /; + +# non-searchable pathnames shouldn't mention @INC in the error + +my $nonsearch = "./no_such_file.pm"; + +eval "require \"$nonsearch\""; + +like $@, qr/^Can't locate \Q$nonsearch\E at/, + "correct error message for require $nonsearch"; -- Perl5 Master Repository
