}
}
+/* also used for: pp_mapstart() */
PP(pp_grepstart)
{
dSP;
-/* undef or delete the $INC{namesv} entry, then croak.
- * require0 indicates that the require didn't return a true value */
+/* pop a CXt_EVAL context and in addition, if it was a require then
+ * based on action:
+ * 0: do nothing extra;
+ * 1: undef $INC{$name}; croak "$name did not return a true value";
+ * 2: delete $INC{$name}; croak "$errsv: Compilation failed in require"
+ */
static void
-S_undo_inc_then_croak(pTHX_ SV *namesv, SV *err, bool require0)
+S_pop_eval_context_maybe_croak(pTHX_ PERL_CONTEXT *cx, SV *errsv, int action)
{
- const char *fmt;
- HV *inc_hv = GvHVn(PL_incgv);
- I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
- const char *key = SvPVX_const(namesv);
+ SV *namesv = NULL; /* init to avoid dumb compiler warning */
+ bool do_croak;
- if (require0) {
- (void)hv_delete(inc_hv, key, klen, G_DISCARD);
- fmt = "%"SVf" did not return a true value";
- err = namesv;
- }
- else {
- (void)hv_store(inc_hv, key, klen, &PL_sv_undef, 0);
- fmt = "%"SVf"Compilation failed in require";
- err = err ? err : newSVpvs_flags("Unknown error\n", SVs_TEMP);
+ CX_LEAVE_SCOPE(cx);
+ do_croak = action && (CxOLD_OP_TYPE(cx) == OP_REQUIRE);
+ if (do_croak) {
+ /* keep namesv alive after cx_popeval() */
+ namesv = cx->blk_eval.old_namesv;
+ cx->blk_eval.old_namesv = NULL;
+ sv_2mortal(namesv);
}
+ cx_popeval(cx);
+ cx_popblock(cx);
+ CX_POP(cx);
+
+ if (do_croak) {
+ const char *fmt;
+ HV *inc_hv = GvHVn(PL_incgv);
+ I32 klen = SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv);
+ const char *key = SvPVX_const(namesv);
- Perl_croak(aTHX_ fmt, SVfARG(err));
+ if (action == 1) {
+ (void)hv_delete(inc_hv, key, klen, G_DISCARD);
+ 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";
+ if (!errsv)
+ errsv = newSVpvs_flags("Unknown error\n", SVs_TEMP);
+ }
+
+ Perl_croak(aTHX_ fmt, SVfARG(errsv));
+ }
}
+/* die_unwind(): this is the final destination for the various croak()
+ * functions. If we're in an eval, unwind the context and other stacks
+ * back to the top-most CXt_EVAL and set $@ to msv; otherwise print msv
+ * to STDERR and initiate an exit. Note that if the CXt_EVAL popped back
+ * to is a require the exception will be rethrown, as requires don't
+ * actually trap exceptions.
+ */
+
void
Perl_die_unwind(pTHX_ SV *msv)
{
- SV *exceptsv = sv_mortalcopy(msv);
+ SV *exceptsv = msv;
U8 in_eval = PL_in_eval;
PERL_ARGS_ASSERT_DIE_UNWIND;
if (in_eval) {
I32 cxix;
+ exceptsv = sv_2mortal(SvREFCNT_inc_simple_NN(exceptsv));
+
/*
* Historically, perl used to set ERRSV ($@) early in the die
* process and rely on it not getting clobbered during unwinding.
* perls 5.13.{1..7} which had late setting of $@ without this
* early-setting hack.
*/
- if (!(in_eval & EVAL_KEEPERR)) {
- SvTEMP_off(exceptsv);
- sv_setsv(ERRSV, exceptsv);
- }
+ if (!(in_eval & EVAL_KEEPERR))
+ sv_setsv_flags(ERRSV, exceptsv,
+ (SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL));
if (in_eval & EVAL_KEEPERR) {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %"SVf,
}
if (cxix >= 0) {
- SV *namesv = NULL;
PERL_CONTEXT *cx;
SV **oldsp;
U8 gimme;
*++oldsp = &PL_sv_undef;
PL_stack_sp = oldsp;
- CX_LEAVE_SCOPE(cx);
- cx_popeval(cx);
- cx_popblock(cx);
restartjmpenv = cx->blk_eval.cur_top_env;
- restartop = cx->blk_eval.retop;
- if (CxOLD_OP_TYPE(cx) == OP_REQUIRE)
- namesv = cx->blk_eval.old_namesv;
- CX_POP(cx);
-
- if (namesv) {
- /* note that unlike pp_entereval, pp_require isn't
- * supposed to trap errors. So now that we've popped the
- * EVAL that pp_require pushed, process the error message
- * and rethrow the error */
- S_undo_inc_then_croak(aTHX_ namesv, exceptsv, FALSE);
- NOT_REACHED; /* NOTREACHED */
- }
+ restartop = cx->blk_eval.retop;
+ /* 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
+ * croak(exceptsv). This is all handled by the call below when
+ * action == 2.
+ */
+ S_pop_eval_context_maybe_croak(aTHX_ cx, exceptsv, 2);
if (!(in_eval & EVAL_KEEPERR))
sv_setsv(ERRSV, exceptsv);
assert(CxTYPE(cx) == CXt_BLOCK);
if (PL_op->op_flags & OPf_SPECIAL)
- cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
+ /* fake block should preserve $1 et al; e.g. /(...)/ while ...; */
+ cx->blk_oldpm = PL_curpm;
oldsp = PL_stack_base + cx->blk_oldsp;
gimme = cx->blk_gimme;
*
* Any changes made to this function may need to be copied to pp_leavesub
* and vice-versa.
+ *
+ * also tail-called by pp_return
*/
PP(pp_leavesublv)
}
/* There are contexts that need popping. Doing this may free the
- * return value(s), so preserve them first, e.g. popping the plain
+ * return value(s), so preserve them first: e.g. popping the plain
* loop here would free $x:
* sub f { { my $x = 1; return $x } }
* We may also need to shift the args down; for example,
* for (1,2) { return 3,4 }
- * leaves 1,2,3,4 on the stack. Both these actions can be done by
- * leave_adjust_stacks(). By calling it with and lvalue "pass
- * all" action, we just bump the ref count and mortalise the args
- * that need it, do a FREETMPS. The "scan the args and maybe copy
- * them" process will be repeated by whoever we tail-call (e.g.
- * pp_leaveeval), where any copying etc will be done. That is to
- * say, in this code path two scans of the args will be done; the
- * first just shifts and preserves; the second is the "real" arg
- * processing, based on the type of return.
+ * leaves 1,2,3,4 on the stack. Both these actions will be done by
+ * leave_adjust_stacks(), along with freeing any temps. Note that
+ * whoever we tail-call (e.g. pp_leaveeval) will also call
+ * leave_adjust_stacks(); however, the second call is likely to
+ * just see a bunch of SvTEMPs with a ref count of 1, and so just
+ * pass them through, rather than copying them again. So this
+ * isn't as inefficient as it sounds.
*/
cx = &cxstack[cxix];
PUTBACK;
yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
if (yystatus || PL_parser->error_count || !PL_eval_root) {
- SV *namesv = NULL; /* initialise to avoid compiler warning */
PERL_CONTEXT *cx;
SV *errsv;
}
SP = PL_stack_base + POPMARK; /* pop original mark */
cx = CX_CUR();
- CX_LEAVE_SCOPE(cx);
- cx_popeval(cx);
- cx_popblock(cx);
- if (in_require)
- namesv = cx->blk_eval.old_namesv;
- CX_POP(cx);
+ assert(CxTYPE(cx) == CXt_EVAL);
+ /* pop the CXt_EVAL, and if was a require, croak */
+ S_pop_eval_context_maybe_croak(aTHX_ cx, ERRSV, 2);
}
- errsv = ERRSV;
- if (in_require) {
- if (yystatus == 3) {
- cx = CX_CUR();
- assert(CxTYPE(cx) == CXt_EVAL);
- namesv = cx->blk_eval.old_namesv;
- }
- S_undo_inc_then_croak(aTHX_ namesv, errsv, FALSE);
- NOT_REACHED; /* NOTREACHED */
- }
+ /* die_unwind() re-croaks when in require, having popped the
+ * require EVAL context. So we should never catch a require
+ * exception here */
+ assert(!in_require);
+ errsv = ERRSV;
if (!*(SvPV_nolen_const(errsv)))
sv_setpvs(errsv, "Compilation error");
}
-/* 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;
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);
if (!IS_SAFE_PATHNAME(name, len, "require")) {
DIE(aTHX_ "Can't locate %s: %s",
- pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
- SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
+ pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
+ NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
Strerror(ENOENT));
}
TAINT_PROPER("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);
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. */
}
}
+
+/* also tail-called by pp_return */
+
PP(pp_leaveeval)
{
SV **oldsp;
U8 gimme;
PERL_CONTEXT *cx;
OP *retop;
- SV *namesv = NULL;
+ int failed;
CV *evalcv;
- /* grab this value before cx_popeval restores old PL_in_eval */
- bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
+ bool keep;
PERL_ASYNC_CHECK();
gimme = cx->blk_gimme;
/* did require return a false value? */
- if ( CxOLD_OP_TYPE(cx) == OP_REQUIRE
- && !(gimme == G_SCALAR
+ failed = CxOLD_OP_TYPE(cx) == OP_REQUIRE
+ && !(gimme == G_SCALAR
? SvTRUE(*PL_stack_sp)
- : PL_stack_sp > oldsp)
- )
- namesv = cx->blk_eval.old_namesv;
+ : PL_stack_sp > oldsp);
if (gimme == G_VOID)
PL_stack_sp = oldsp;
*/
PL_curcop = cx->blk_oldcop;
- CX_LEAVE_SCOPE(cx);
- cx_popeval(cx);
- cx_popblock(cx);
+ /* grab this value before cx_popeval restores the old PL_in_eval */
+ keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
retop = cx->blk_eval.retop;
evalcv = cx->blk_eval.cv;
- CX_POP(cx);
-
#ifdef DEBUGGING
assert(CvDEPTH(evalcv) == 1);
#endif
CvDEPTH(evalcv) = 0;
- if (namesv) { /* require returned false */
- /* Unassume the success we assumed earlier. */
- S_undo_inc_then_croak(aTHX_ namesv, NULL, TRUE);
- NOT_REACHED; /* NOTREACHED */
- }
+ /* pop the CXt_EVAL, and if a require failed, croak */
+ S_pop_eval_context_maybe_croak(aTHX_ cx, NULL, failed);
if (!keep)
CLEAR_ERRSV();
return DOCATCH(PL_op->op_next);
}
+
+/* also tail-called by pp_return */
+
PP(pp_leavetry)
{
SV **oldsp;
https://perl5.git.perl.org / perl5.git / blobdiff