X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/51787acf7725ae7cd885f261996c34c0c59a0a3e..fac71630f045e7ab325b37548d59b6558735e5c3:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 155349e..d465a9e 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -34,7 +34,8 @@ #define PERL_IN_PP_CTL_C #include "perl.h" -#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) +#define RUN_PP_CATCHABLY(thispp) \ + STMT_START { if (CATCH_GET) return docatch(thispp); } STMT_END #define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) @@ -104,18 +105,6 @@ PP(pp_regcomp) assert (re != (REGEXP*) &PL_sv_undef); eng = re ? RX_ENGINE(re) : current_re_engine(); - /* - In the below logic: these are basically the same - check if this regcomp is part of a split. - - (PL_op->op_pmflags & PMf_split ) - (PL_op->op_next->op_type == OP_PUSHRE) - - We could add a new mask for this and copy the PMf_split, if we did - some bit definition fiddling first. - - For now we leave this - */ - new_re = (eng->op_comp ? eng->op_comp : &Perl_re_op_compile @@ -171,13 +160,25 @@ PP(pp_regcomp) RX_TAINT_on(new_re); } + /* handle the empty pattern */ + if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) { + if (PL_curpm == PL_reg_curpm) { + if (PL_curpm_under) { + if (PL_curpm_under == PL_reg_curpm) { + Perl_croak(aTHX_ "Infinite recursion via empty pattern"); + } else { + pm = PL_curpm_under; + } + } + } else { + pm = PL_curpm; + } + } + #if !defined(USE_ITHREADS) /* can't change the optree at runtime either */ /* PMf_KEEP is handled differently under threads to avoid these problems */ - if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) - pm = PL_curpm; if (pm->op_pmflags & PMf_KEEP) { - pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ cLOGOP->op_first->op_next = PL_op->op_next; } #endif @@ -490,6 +491,7 @@ PP(pp_formline) U8 *source; /* source of bytes to append */ STRLEN to_copy; /* how may bytes to append */ char trans; /* what chars to translate */ + bool copied_form = FALSE; /* have we duplicated the form? */ mg = doparseform(tmpForm); @@ -504,6 +506,8 @@ PP(pp_formline) SvTAINTED_on(PL_formtarget); if (DO_UTF8(PL_formtarget)) targ_is_utf8 = TRUE; + /* this is an initial estimate of how much output buffer space + * to allocate. It may be exceeded later */ linemax = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1); t = SvGROW(PL_formtarget, len + linemax + 1); /* XXX from now onwards, SvCUR(PL_formtarget) is invalid */ @@ -687,6 +691,23 @@ PP(pp_formline) case FF_CHOP: /* (for ^*) chop the current item */ if (sv != &PL_sv_no) { const char *s = chophere; + if (!copied_form && + ((sv == tmpForm || SvSMAGICAL(sv)) + || (SvGMAGICAL(tmpForm) && !sv_only_taint_gmagic(tmpForm))) ) { + /* sv and tmpForm are either the same SV, or magic might allow modification + of tmpForm when sv is modified, so copy */ + SV *newformsv = sv_mortalcopy(formsv); + U32 *new_compiled; + + f = SvPV_nolen(newformsv) + (f - SvPV_nolen(formsv)); + Newx(new_compiled, mg->mg_len / sizeof(U32), U32); + memcpy(new_compiled, mg->mg_ptr, mg->mg_len); + SAVEFREEPV(new_compiled); + fpc = new_compiled + (fpc - (U32*)mg->mg_ptr); + formsv = newformsv; + + copied_form = TRUE; + } if (chopspace) { while (isSPACE(*s)) s++; @@ -748,6 +769,7 @@ PP(pp_formline) if (targ_is_utf8 && !item_is_utf8) { source = tmp = bytes_to_utf8(source, &to_copy); + grow = to_copy; } else { if (item_is_utf8 && !targ_is_utf8) { U8 *s; @@ -927,6 +949,7 @@ PP(pp_formline) } } +/* also used for: pp_mapstart() */ PP(pp_grepstart) { dSP; @@ -1150,7 +1173,7 @@ PP(pp_flip) RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } } - sv_setpvs(TARG, ""); + SvPVCLEAR(TARG); SETs(targ); RETURN; } @@ -1221,6 +1244,8 @@ PP(pp_flop) const char * const tmps = SvPV_nomg_const(right, len); SV *sv = newSVpvn_flags(lpv, llen, SvUTF8(left)|SVs_TEMP); + if (DO_UTF8(right) && IN_UNI_8_BIT) + len = sv_len_utf8_nomg(right); while (!SvNIOKp(sv) && SvCUR(sv) <= len) { XPUSHs(sv); if (strEQ(SvPVX_const(sv),tmps)) @@ -1529,6 +1554,12 @@ Perl_dounwind(pTHX_ I32 cxix) switch (CxTYPE(cx)) { case CXt_SUBST: CX_POPSUBST(cx); + /* CXt_SUBST is not a block context type, so skip the + * cx_popblock(cx) below */ + if (cxstack_ix == cxix + 1) { + cxstack_ix--; + return; + } break; case CXt_SUB: cx_popsub(cx); @@ -1572,7 +1603,7 @@ Perl_qerror(pTHX_ SV *err) if (PL_in_eval) { if (PL_in_eval & EVAL_KEEPERR) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf, + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf, SVfARG(err)); } else @@ -1581,7 +1612,7 @@ Perl_qerror(pTHX_ SV *err) else if (PL_errors) sv_catsv(PL_errors, err); else - Perl_warn(aTHX_ "%"SVf, SVfARG(err)); + Perl_warn(aTHX_ "%" SVf, SVfARG(err)); if (PL_parser) ++PL_parser->error_count; } @@ -1621,12 +1652,12 @@ S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action) if (action == 1) { (void)hv_delete(inc_hv, key, klen, G_DISCARD); - fmt = "%"SVf" did not return a true value"; + fmt = "%" SVf " did not return a true value"; errsv = namesv; } else { (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0); - fmt = "%"SVf"Compilation failed in require"; + fmt = "%" SVf "Compilation failed in require"; if (!errsv) errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP); } @@ -1654,7 +1685,13 @@ Perl_die_unwind(pTHX_ SV *msv) if (in_eval) { I32 cxix; - exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv)); + /* We need to keep this SV alive through all the stack unwinding + * and FREETMPSing below, while ensuing that it doesn't leak + * if we call out to something which then dies (e.g. sub STORE{die} + * when unlocalising a tied var). So we do a dance with + * mortalising and SAVEFREEing. + */ + sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv)); /* * Historically, perl used to set ERRSV ($@) early in the die @@ -1690,7 +1727,7 @@ Perl_die_unwind(pTHX_ SV *msv) (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL)); if (in_eval & EVAL_KEEPERR) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf, + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %" SVf, SVfARG(exceptsv)); } @@ -1723,6 +1760,24 @@ Perl_die_unwind(pTHX_ SV *msv) restartjmpenv = cx->blk_eval.cur_top_env; restartop = cx->blk_eval.retop; + + /* We need a FREETMPS here to avoid late-called destructors + * clobbering $@ *after* we set it below, e.g. + * sub DESTROY { eval { die "X" } } + * eval { my $x = bless []; die $x = 0, "Y" }; + * is($@, "Y") + * Here the clearing of the $x ref mortalises the anon array, + * which needs to be freed *before* $& is set to "Y", + * otherwise it gets overwritten with "X". + * + * However, the FREETMPS will clobber exceptsv, so preserve it + * on the savestack for now. + */ + SAVEFREESV(SvREFCNT_inc_simple_NN(exceptsv)); + FREETMPS; + /* now we're about to pop the savestack, so re-mortalise it */ + sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv)); + /* Note that unlike pp_entereval, pp_require isn't supposed to * trap errors. So if we're a require, after we pop the * CXt_EVAL that pp_require pushed, rethrow the error with @@ -2247,21 +2302,21 @@ PP(pp_leaveloop) { PERL_CONTEXT *cx; U8 gimme; + SV **base; SV **oldsp; - SV **mark; cx = CX_CUR(); assert(CxTYPE_is_LOOP(cx)); - mark = PL_stack_base + cx->blk_oldsp; - oldsp = CxTYPE(cx) == CXt_LOOP_LIST + oldsp = PL_stack_base + cx->blk_oldsp; + base = CxTYPE(cx) == CXt_LOOP_LIST ? PL_stack_base + cx->blk_loop.state_u.stack.basesp - : mark; + : oldsp; gimme = cx->blk_gimme; if (gimme == G_VOID) - PL_stack_sp = oldsp; + PL_stack_sp = base; else - leave_adjust_stacks(MARK, oldsp, gimme, + leave_adjust_stacks(oldsp, base, gimme, PL_op->op_private & OPpLVALUE ? 3 : 1); CX_LEAVE_SCOPE(cx); @@ -2521,7 +2576,7 @@ S_unwind_loop(pTHX) cxix = dopoptolabel(label, label_len, label_flags); if (cxix < 0) /* diag_listed_as: Label not found for "last %s" */ - Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"", + Perl_croak(aTHX_ "Label not found for \"%s %" SVf "\"", OP_NAME(PL_op), SVfARG(PL_op->op_flags & OPf_STACKED && !SvGMAGICAL(TOPp1s) @@ -2707,7 +2762,7 @@ PP(pp_goto) continue; tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, NULL); - DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr)); + DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr)); } DIE(aTHX_ "Goto undefined subroutine"); } @@ -2778,7 +2833,7 @@ PP(pp_goto) if (gv) { SV * const tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, NULL); - DIE(aTHX_ "Goto undefined subroutine &%"SVf"", + DIE(aTHX_ "Goto undefined subroutine &%" SVf, SVfARG(tmpstr)); } DIE(aTHX_ "Goto undefined subroutine"); @@ -2919,6 +2974,7 @@ PP(pp_goto) OP *gotoprobe = NULL; bool leaving_eval = FALSE; bool in_block = FALSE; + bool pseudo_block = FALSE; PERL_CONTEXT *last_eval_cx = NULL; /* find label */ @@ -2957,11 +3013,9 @@ PP(pp_goto) gotoprobe = PL_main_root; break; case CXt_SUB: - if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) { - gotoprobe = CvROOT(cx->blk_sub.cv); - break; - } - /* FALLTHROUGH */ + gotoprobe = CvROOT(cx->blk_sub.cv); + pseudo_block = cBOOL(CxMULTICALL(cx)); + break; case CXt_FORMAT: case CXt_NULL: DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); @@ -2990,10 +3044,12 @@ PP(pp_goto) break; } } + if (pseudo_block) + DIE(aTHX_ "Can't \"goto\" out of a pseudo block"); PL_lastgotoprobe = gotoprobe; } if (!retop) - DIE(aTHX_ "Can't find label %"UTF8f, + DIE(aTHX_ "Can't find label %" UTF8f, UTF8fARG(label_flags, label_len, label)); /* if we're leaving an eval, check before we pop any frames @@ -3128,23 +3184,18 @@ establish a local jmpenv to handle exception traps. =cut */ STATIC OP * -S_docatch(pTHX_ OP *o) +S_docatch(pTHX_ Perl_ppaddr_t firstpp) { int ret; OP * const oldop = PL_op; dJMPENV; -#ifdef DEBUGGING assert(CATCH_GET == TRUE); -#endif - PL_op = o; JMPENV_PUSH(ret); switch (ret) { case 0: - assert(cxstack_ix >= 0); - assert(CxTYPE(CX_CUR()) == CXt_EVAL); - CX_CUR()->blk_eval.cur_top_env = PL_top_env; + PL_op = firstpp(aTHX); redo_body: CALLRUNOPS(aTHX); break; @@ -3353,7 +3404,7 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh) } else { PL_hints = saveop->op_private & OPpEVAL_COPHH - ? oldcurcop->cop_hints : saveop->op_targ; + ? oldcurcop->cop_hints : (U32)saveop->op_targ; /* making 'use re eval' not be in scope when compiling the * qr/mabye_has_runtime_code_block/ ensures that we don't get @@ -3475,6 +3526,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) @@ -3535,6 +3589,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) @@ -3568,8 +3627,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) { @@ -3607,7 +3666,7 @@ S_require_version(pTHX_ SV *sv) 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", + DIE(aTHX_ "Perls since %" SVf " too modern--this is %" SVf ", stopped", SVfARG(sv_2mortal(vnormal(sv))), SVfARG(sv_2mortal(vnormal(PL_patchlevel))) ); @@ -3628,8 +3687,8 @@ S_require_version(pTHX_ SV *sv) || 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", + DIE(aTHX_ "Perl %" SVf " required--this is only " + "%" SVf ", stopped", SVfARG(sv_2mortal(vnormal(req))), SVfARG(sv_2mortal(vnormal(PL_patchlevel))) ); @@ -3646,8 +3705,8 @@ S_require_version(pTHX_ SV *sv) (int)first, (int)second); upg_version(hintsv, TRUE); - DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)" - "--this is only %"SVf", stopped", + 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))) @@ -3664,7 +3723,7 @@ S_require_version(pTHX_ SV *sv) * the second form */ static OP * -S_require_file(pTHX_ SV *const sv) +S_require_file(pTHX_ SV *sv) { dVAR; dSP; @@ -3677,8 +3736,10 @@ S_require_file(pTHX_ SV *const 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; @@ -3690,20 +3751,28 @@ S_require_file(pTHX_ SV *const sv) int saved_errno; bool path_searchable; I32 old_savestack_ix; + const bool op_is_require = PL_op->op_type == OP_REQUIRE; + const char *const op_name = op_is_require ? "require" : "do"; + + assert(op_is_require || PL_op->op_type == OP_DOFILE); if (!SvOK(sv)) - DIE(aTHX_ "Missing or undefined argument to require"); + DIE(aTHX_ "Missing or undefined argument to %s", op_name); name = SvPV_nomg_const(sv, len); if (!(name && len > 0 && *name)) - DIE(aTHX_ "Missing or undefined argument to require"); + DIE(aTHX_ "Missing or undefined argument to %s", op_name); - if (!IS_SAFE_PATHNAME(name, len, "require")) { + if (!IS_SAFE_PATHNAME(name, len, op_name)) { + if (!op_is_require) { + CLEAR_ERRSV(); + RETPUSHUNDEF; + } DIE(aTHX_ "Can't locate %s: %s", pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2, NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0), Strerror(ENOENT)); } - TAINT_PROPER("require"); + TAINT_PROPER(op_name); path_searchable = path_is_searchable(name); @@ -3730,7 +3799,7 @@ S_require_file(pTHX_ SV *const sv) unixname = (char *) name; unixlen = len; } - if (PL_op->op_type == OP_REQUIRE) { + if (op_is_require) { SV * const * const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); if ( svp ) { @@ -3741,14 +3810,20 @@ S_require_file(pTHX_ SV *const 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 @@ -3761,7 +3836,7 @@ S_require_file(pTHX_ SV *const sv) 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); + 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\""); @@ -3784,13 +3859,22 @@ S_require_file(pTHX_ SV *const 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; @@ -3816,7 +3900,7 @@ S_require_file(pTHX_ SV *const sv) SvGETMAGIC(loader); } - Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", + Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s", PTR2UV(SvRV(dirsv)), name); tryname = SvPVX_const(namesv); tryrsfp = NULL; @@ -3933,8 +4017,9 @@ S_require_file(pTHX_ SV *const 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; @@ -3945,7 +4030,7 @@ S_require_file(pTHX_ SV *const sv) dirlen = 0; } - if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require")) + if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", op_name)) continue; #ifdef VMS if ((unixdir = @@ -3996,7 +4081,7 @@ S_require_file(pTHX_ SV *const sv) } # endif #endif - TAINT_PROPER("require"); + TAINT_PROPER(op_name); tryname = SvPVX_const(namesv); tryrsfp = doopen_pm(namesv); if (tryrsfp) { @@ -4014,41 +4099,74 @@ S_require_file(pTHX_ SV *const 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) { - if (PL_op->op_type == OP_REQUIRE) { + /* 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), 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?)"); @@ -4065,14 +4183,36 @@ S_require_file(pTHX_ SV *const sv) } DIE(aTHX_ "Can't locate %s", name); } - - CLEAR_ERRSV(); - RETPUSHUNDEF; + else { +#ifdef DEFAULT_INC_EXCLUDES_DOT + 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". + */ + bool do_warn = namesv && ckWARN_d(WARN_DEPRECATED) + && PerlLIO_stat(name, &st) == 0 && !S_ISDIR(st.st_mode) && !S_ISBLK(st.st_mode) + && (io = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &sv)) != NULL; + if (io) + PerlIO_close(io); + + RESTORE_ERRNO; + if (do_warn) { + Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), + "do \"%s\" failed, '.' is no longer in @INC; " + "did you mean do \"./%s\"?", + name, name); + } +#endif + CLEAR_ERRSV(); + RETPUSHUNDEF; + } } 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) { @@ -4085,6 +4225,8 @@ S_require_file(pTHX_ SV *const 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); @@ -4105,6 +4247,7 @@ S_require_file(pTHX_ SV *const sv) } /* switch to eval mode */ + assert(!CATCH_GET); cx = cx_pushblock(CXt_EVAL, gimme, SP, old_savestack_ix); cx_pusheval(cx, PL_op->op_next, newSVpv(name, 0)); @@ -4114,7 +4257,7 @@ S_require_file(pTHX_ SV *const sv) PUTBACK; if (doeval_compile(gimme, NULL, PL_curcop->cop_seq, NULL)) - op = DOCATCH(PL_eval_start); + op = PL_eval_start; else op = PL_op->op_next; @@ -4128,13 +4271,17 @@ S_require_file(pTHX_ SV *const sv) 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); + RUN_PP_CATCHABLY(Perl_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); + } } @@ -4155,18 +4302,28 @@ PP(pp_entereval) dSP; PERL_CONTEXT *cx; SV *sv; - const U8 gimme = GIMME_V; - const U32 was = PL_breakable_sub_gen; + U8 gimme; + U32 was; char tbuf[TYPE_DIGITS(long) + 12]; - bool saved_delete = FALSE; - char *tmpbuf = tbuf; + bool saved_delete; + char *tmpbuf; STRLEN len; CV* runcv; - U32 seq, lex_flags = 0; - HV *saved_hh = NULL; - const bool bytes = PL_op->op_private & OPpEVAL_BYTES; + U32 seq, lex_flags; + HV *saved_hh; + bool bytes; I32 old_savestack_ix; + RUN_PP_CATCHABLY(Perl_pp_entereval); + + gimme = GIMME_V; + was = PL_breakable_sub_gen; + saved_delete = FALSE; + tmpbuf = tbuf; + lex_flags = 0; + saved_hh = NULL; + bytes = PL_op->op_private & OPpEVAL_BYTES; + if (PL_op->op_private & OPpEVAL_HAS_HH) { saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); } @@ -4215,7 +4372,7 @@ PP(pp_entereval) if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { SV * const temp_sv = sv_newmortal(); - Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]", + Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%" IVdf "]", (unsigned long)++PL_evalseq, CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); tmpbuf = SvPVX(temp_sv); @@ -4234,6 +4391,7 @@ PP(pp_entereval) * to do the dirty work for us */ runcv = find_runcv(&seq); + assert(!CATCH_GET); cx = cx_pushblock((CXt_EVAL|CXp_REAL), gimme, SP, old_savestack_ix); cx_pusheval(cx, PL_op->op_next, NULL); @@ -4263,7 +4421,7 @@ PP(pp_entereval) char *const safestr = savepvn(tmpbuf, len); SAVEDELETE(PL_defstash, safestr, len); } - return DOCATCH(PL_eval_start); + return PL_eval_start; } else { /* We have already left the scope set up earlier thanks to the LEAVE in doeval_compile(). */ @@ -4305,8 +4463,11 @@ PP(pp_leaveeval) ? SvTRUE(*PL_stack_sp) : PL_stack_sp > oldsp); - if (gimme == G_VOID) + if (gimme == G_VOID) { PL_stack_sp = oldsp; + /* free now to avoid late-called destructors clobbering $@ */ + FREETMPS; + } else leave_adjust_stacks(oldsp, oldsp, gimme, 0); @@ -4374,8 +4535,11 @@ Perl_create_eval_scope(pTHX_ OP *retop, U32 flags) PP(pp_entertry) { + RUN_PP_CATCHABLY(Perl_pp_entertry); + + assert(!CATCH_GET); create_eval_scope(cLOGOP->op_other->op_next, 0); - return DOCATCH(PL_op->op_next); + return PL_op->op_next; } @@ -4395,8 +4559,11 @@ PP(pp_leavetry) oldsp = PL_stack_base + cx->blk_oldsp; gimme = cx->blk_gimme; - if (gimme == G_VOID) + if (gimme == G_VOID) { PL_stack_sp = oldsp; + /* free now to avoid late-called destructors clobbering $@ */ + FREETMPS; + } else leave_adjust_stacks(oldsp, oldsp, gimme, 1); CX_LEAVE_SCOPE(cx); @@ -5136,7 +5303,7 @@ S_doparseform(pTHX_ SV *sv) SV *old = mg->mg_obj; if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv)) && len == SvCUR(old) - && strnEQ(SvPVX(old), SvPVX(sv), len) + && strnEQ(SvPVX(old), s, len) ) { DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n")); return mg;