}
- if (TAINTING_get && TAINT_get) {
+ assert(TAINTING_get || !TAINT_get);
+ if (TAINT_get) {
SvTAINTED_on((SV*)new_re);
RX_TAINT_on(new_re);
}
SV * const sv
= (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
MAGIC *mg;
+
+ /* the string being matched against may no longer be a string,
+ * e.g. $_=0; s/.../$_++/ge */
+
+ if (!SvPOK(sv))
+ SvPV_force_nomg_nolen(sv);
+
if (!(mg = mg_find_mglob(sv))) {
mg = sv_magicext_mglob(sv);
}
- assert(SvPOK(sv));
MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
}
if (old != rx)
{
Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
int len;
- DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
#ifdef USE_QUADMATH
{
dSP;
SV *src;
- if (PL_stack_base + *PL_markstack_ptr == SP) {
+ if (PL_stack_base + TOPMARK == SP) {
(void)POPMARK;
if (GIMME_V == G_SCALAR)
mXPUSHi(0);
RETURNOP(PL_op->op_next->op_next);
}
- PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
+ PL_stack_sp = PL_stack_base + TOPMARK + 1;
Perl_pp_pushmark(aTHX); /* push dst */
Perl_pp_pushmark(aTHX); /* push src */
ENTER_with_name("grep"); /* enter outer scope */
SAVETMPS;
- if (PL_op->op_private & OPpGREP_LEX)
- SAVESPTR(PAD_SVl(PL_op->op_targ));
- else
- SAVE_DEFSV;
+ SAVE_DEFSV;
ENTER_with_name("grep_item"); /* enter inner scope */
SAVEVPTR(PL_curpm);
- src = PL_stack_base[*PL_markstack_ptr];
+ src = PL_stack_base[TOPMARK];
if (SvPADTMP(src)) {
- src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
+ src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
PL_tmps_floor++;
}
SvTEMP_off(src);
- if (PL_op->op_private & OPpGREP_LEX)
- PAD_SVl(PL_op->op_targ) = src;
- else
- DEFSV_set(src);
+ DEFSV_set(src);
PUTBACK;
if (PL_op->op_type == OP_MAPSTART)
{
dSP;
const I32 gimme = GIMME_V;
- I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
+ I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
I32 count;
I32 shift;
SV** src;
LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
- if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
+ if (PL_markstack_ptr[-1] > TOPMARK) {
(void)POPMARK; /* pop top */
LEAVE_with_name("grep"); /* exit outer scope */
(void)POPMARK; /* pop dst */
SP = PL_stack_base + POPMARK; /* pop original mark */
if (gimme == G_SCALAR) {
- if (PL_op->op_private & OPpGREP_LEX) {
- SV* sv = sv_newmortal();
- sv_setiv(sv, items);
- PUSHs(sv);
- }
- else {
dTARGET;
XPUSHi(items);
- }
}
else if (gimme == G_ARRAY)
SP += items;
src = sv_mortalcopy(src);
}
SvTEMP_off(src);
- if (PL_op->op_private & OPpGREP_LEX)
- PAD_SVl(PL_op->op_targ) = src;
- else
- DEFSV_set(src);
+ DEFSV_set(src);
RETURNOP(cLOGOP->op_other);
}
/* The wraparound of signed integers is undefined
* behavior, but here we aim for count >=1, and
* negative count is just wrong. */
- if (n < 1)
+ if (n < 1
+#if IVSIZE > Size_t_size
+ || n > SSize_t_MAX
+#endif
+ )
overflow = TRUE;
}
if (overflow)
Perl_block_gimme(pTHX)
{
const I32 cxix = dopoptosub(cxstack_ix);
+ U8 gimme;
if (cxix < 0)
return G_VOID;
- switch (cxstack[cxix].blk_gimme) {
- case G_VOID:
- return G_VOID;
- case G_SCALAR:
- return G_SCALAR;
- case G_ARRAY:
- return G_ARRAY;
- default:
- Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
- }
- NOT_REACHED; /* NOTREACHED */
+ gimme = (cxstack[cxix].blk_gimme & G_WANT);
+ if (!gimme)
+ Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
+ return gimme;
}
+
I32
Perl_is_lvalue_sub(pTHX)
{
cx->blk_sub.retop, TRUE);
if (!lcop)
lcop = cx->blk_oldcop;
- mPUSHi((I32)CopLINE(lcop));
+ mPUSHu(CopLINE(lcop));
if (!has_arg)
RETURN;
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
*svp = newSV(0);
itervar = (void *)gv;
- save_aliased_sv(gv);
}
else {
SV * const sv = POPs;
return NORMAL;
}
-STATIC void
-S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
- PERL_CONTEXT *cx, PMOP *newpm)
+
+/* This duplicates most of pp_leavesub, but with additional code to handle
+ * return args in lvalue context. It was forked from pp_leavesub to
+ * avoid slowing down that function any further.
+ *
+ * Any changes made to this function may need to be copied to pp_leavesub
+ * and vice-versa.
+ */
+
+PP(pp_leavesublv)
{
- const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
+ dSP;
+ SV **newsp;
+ SV **mark;
+ PMOP *newpm;
+ I32 gimme;
+ PERL_CONTEXT *cx;
+ SV *sv;
+ bool ref;
+ const char *what = NULL;
+
+ if (CxMULTICALL(&cxstack[cxstack_ix])) {
+ /* entry zero of a stack is always PL_sv_undef, which
+ * simplifies converting a '()' return into undef in scalar context */
+ assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
+ return 0;
+ }
+
+ POPBLOCK(cx,newpm);
+ cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
+ TAINT_NOT;
+
+ mark = newsp + 1;
+
+ ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
if (gimme == G_SCALAR) {
if (CxLVAL(cx) && !ref) { /* Leave it as it is if we can. */
SV *sv;
- const char *what = NULL;
- if (MARK < SP) {
- assert(MARK+1 == SP);
+ if (MARK <= SP) {
+ assert(MARK == SP);
if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
!SvSMAGICAL(TOPs)) {
what =
/* sub:lvalue{} will take us here. */
what = "undef";
}
+ croak:
LEAVE;
- cxstack_ix--;
POPSUB(cx,sv);
+ cxstack_ix--;
PL_curpm = newpm;
LEAVESUB(sv);
Perl_croak(aTHX_
"Can't return %s from lvalue subroutine", what
);
}
- if (MARK < SP) {
+ if (MARK <= SP) {
copy_sv:
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
if (!SvPADTMP(*SP)) {
- *++newsp = SvREFCNT_inc(*SP);
+ *MARK = SvREFCNT_inc(*SP);
FREETMPS;
- sv_2mortal(*newsp);
+ sv_2mortal(*MARK);
}
else {
/* FREETMPS could clobber it */
SV *sv = SvREFCNT_inc(*SP);
FREETMPS;
- *++newsp = sv_mortalcopy(sv);
+ *MARK = sv_mortalcopy(sv);
SvREFCNT_dec(sv);
}
}
else
- *++newsp =
+ *MARK =
SvPADTMP(*SP)
? sv_mortalcopy(*SP)
: !SvTEMP(*SP)
: *SP;
}
else {
- EXTEND(newsp,1);
- *++newsp = &PL_sv_undef;
+ MEXTEND(MARK, 0);
+ *MARK = &PL_sv_undef;
}
+ SP = MARK;
+
if (CxLVAL(cx) & OPpDEREF) {
SvGETMAGIC(TOPs);
if (!SvOK(TOPs)) {
else if (gimme == G_ARRAY) {
assert (!(CxLVAL(cx) & OPpDEREF));
if (ref || !CxLVAL(cx))
- while (++MARK <= SP)
- *++newsp =
+ for (; MARK <= SP; MARK++)
+ *MARK =
SvFLAGS(*MARK) & SVs_PADTMP
? sv_mortalcopy(*MARK)
: SvTEMP(*MARK)
? *MARK
: sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
- else while (++MARK <= SP) {
+ else for (; MARK <= SP; MARK++) {
if (*MARK != &PL_sv_undef
&& (SvPADTMP(*MARK) || SvREADONLY(*MARK))
) {
- const bool ro = cBOOL( SvREADONLY(*MARK) );
- SV *sv;
/* Might be flattened array after $#array = */
- PUTBACK;
- LEAVE;
- cxstack_ix--;
- POPSUB(cx,sv);
- PL_curpm = newpm;
- LEAVESUB(sv);
- /* diag_listed_as: Can't return %s from lvalue subroutine */
- Perl_croak(aTHX_
- "Can't return a %s from lvalue subroutine",
- ro ? "readonly value" : "temporary");
+ what = SvREADONLY(*MARK)
+ ? "a readonly value" : "a temporary";
+ goto croak;
}
- else
- *++newsp =
- SvTEMP(*MARK)
- ? *MARK
- : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
+ else if (!SvTEMP(*MARK))
+ *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
}
}
- PL_stack_sp = newsp;
+ PUTBACK;
+
+ LEAVE;
+ POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
+ cxstack_ix--;
+ PL_curpm = newpm; /* ... and pop $1 et al */
+ LEAVESUB(sv);
+
+ return cx->blk_sub.retop;
}
+
PP(pp_return)
{
dSP; dMARK;
PERL_CONTEXT *cx;
- bool popsub2 = FALSE;
- bool clear_errsv = FALSE;
- bool lval = FALSE;
- I32 gimme;
- SV **newsp;
- PMOP *newpm;
- I32 optype = 0;
- SV *namesv;
- SV *sv;
- OP *retop = NULL;
-
+ SV **oldsp;
const I32 cxix = dopoptosub(cxstack_ix);
- if (cxix < 0) {
- if (CxMULTICALL(cxstack)) { /* In this case we must be in a
- * sort block, which is a CXt_NULL
- * not a CXt_SUB */
- dounwind(0);
- PL_stack_base[1] = *PL_stack_sp;
- PL_stack_sp = PL_stack_base + 1;
- return 0;
- }
- else
- DIE(aTHX_ "Can't return outside a subroutine");
- }
- if (cxix < cxstack_ix)
+ assert(cxstack_ix >= 0);
+ if (cxix < cxstack_ix) {
+ if (cxix < 0) {
+ if (CxMULTICALL(cxstack)) { /* In this case we must be in a
+ * sort block, which is a CXt_NULL
+ * not a CXt_SUB */
+ dounwind(0);
+ /* if we were in list context, we would have to splice out
+ * any junk before the return args, like we do in the general
+ * pp_return case, e.g.
+ * sub f { for (junk1, junk2) { return arg1, arg2 }}
+ */
+ assert(cxstack[0].blk_gimme == G_SCALAR);
+ return 0;
+ }
+ else
+ DIE(aTHX_ "Can't return outside a subroutine");
+ }
dounwind(cxix);
+ }
- if (CxMULTICALL(&cxstack[cxix])) {
- gimme = cxstack[cxix].blk_gimme;
- if (gimme == G_VOID)
- PL_stack_sp = PL_stack_base;
- else if (gimme == G_SCALAR) {
- PL_stack_base[1] = *PL_stack_sp;
- PL_stack_sp = PL_stack_base + 1;
- }
- return 0;
+ cx = &cxstack[cxix];
+
+ oldsp = PL_stack_base + cx->blk_oldsp;
+ if (oldsp != MARK) {
+ /* Handle extra junk on the stack. For example,
+ * for (1,2) { return 3,4 }
+ * leaves 1,2,3,4 on the stack. In list context we
+ * have to splice out the 1,2; In scalar context for
+ * for (1,2) { return }
+ * we need to set sp = oldsp so that pp_leavesub knows
+ * to push &PL_sv_undef onto the stack.
+ * Note that in pp_return we only do the extra processing
+ * required to handle junk; everything else we leave to
+ * pp_leavesub.
+ */
+ SSize_t nargs = SP - MARK;
+ if (nargs) {
+ if (cx->blk_gimme == G_ARRAY) {
+ /* shift return args to base of call stack frame */
+ Move(MARK + 1, oldsp + 1, nargs, SV*);
+ PL_stack_sp = oldsp + nargs;
+ }
+ }
+ else
+ PL_stack_sp = oldsp;
}
- POPBLOCK(cx,newpm);
+ /* fall through to a normal exit */
switch (CxTYPE(cx)) {
- case CXt_SUB:
- popsub2 = TRUE;
- lval = !!CvLVALUE(cx->blk_sub.cv);
- retop = cx->blk_sub.retop;
- cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
- break;
case CXt_EVAL:
- if (!(PL_in_eval & EVAL_KEEPERR))
- clear_errsv = TRUE;
- POPEVAL(cx);
- namesv = cx->blk_eval.old_namesv;
- retop = cx->blk_eval.retop;
- if (CxTRYBLOCK(cx))
- break;
- if (optype == OP_REQUIRE &&
- (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
- {
- /* Unassume the success we assumed earlier. */
- (void)hv_delete(GvHVn(PL_incgv),
- SvPVX_const(namesv),
- SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
- G_DISCARD);
- DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
- }
- break;
+ return CxTRYBLOCK(cx)
+ ? Perl_pp_leavetry(aTHX)
+ : Perl_pp_leaveeval(aTHX);
+ case CXt_SUB:
+ return CvLVALUE(cx->blk_sub.cv)
+ ? Perl_pp_leavesublv(aTHX)
+ : Perl_pp_leavesub(aTHX);
case CXt_FORMAT:
- retop = cx->blk_sub.retop;
- POPFORMAT(cx);
- break;
+ return Perl_pp_leavewrite(aTHX);
default:
DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
}
-
- TAINT_NOT;
- if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
- else {
- if (gimme == G_SCALAR) {
- if (MARK < SP) {
- if (popsub2) {
- if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
- if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
- && !SvMAGICAL(TOPs)) {
- *++newsp = SvREFCNT_inc(*SP);
- FREETMPS;
- sv_2mortal(*newsp);
- }
- else {
- sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
- FREETMPS;
- *++newsp = sv_mortalcopy(sv);
- SvREFCNT_dec(sv);
- }
- }
- else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
- && !SvMAGICAL(*SP)) {
- *++newsp = *SP;
- }
- else
- *++newsp = sv_mortalcopy(*SP);
- }
- else
- *++newsp = sv_mortalcopy(*SP);
- }
- else
- *++newsp = &PL_sv_undef;
- }
- else if (gimme == G_ARRAY) {
- while (++MARK <= SP) {
- *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
- && !SvGMAGICAL(*MARK)
- ? *MARK : sv_mortalcopy(*MARK);
- TAINT_NOT; /* Each item is independent */
- }
- }
- PL_stack_sp = newsp;
- }
-
- LEAVE;
- /* Stack values are safe: */
- if (popsub2) {
- cxstack_ix--;
- POPSUB(cx,sv); /* release CV and @_ ... */
- }
- else
- sv = NULL;
- PL_curpm = newpm; /* ... and pop $1 et al */
-
- LEAVESUB(sv);
- if (clear_errsv) {
- CLEAR_ERRSV();
- }
- return retop;
}
-/* This duplicates parts of pp_leavesub, so that it can share code with
- * pp_return */
-PP(pp_leavesublv)
-{
- dSP;
- SV **newsp;
- PMOP *newpm;
- I32 gimme;
- PERL_CONTEXT *cx;
- SV *sv;
-
- if (CxMULTICALL(&cxstack[cxstack_ix]))
- return 0;
-
- POPBLOCK(cx,newpm);
- cxstack_ix++; /* temporarily protect top context */
-
- TAINT_NOT;
-
- S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
-
- LEAVE;
- POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
- cxstack_ix--;
- PL_curpm = newpm; /* ... and pop $1 et al */
-
- LEAVESUB(sv);
- return cx->blk_sub.retop;
-}
static I32
S_unwind_loop(pTHX_ const char * const opname)
PP(pp_last)
{
PERL_CONTEXT *cx;
- I32 pop2 = 0;
I32 gimme;
- I32 optype;
OP *nextop = NULL;
SV **newsp;
PMOP *newpm;
- SV *sv = NULL;
S_unwind_loop(aTHX_ "last");
POPBLOCK(cx,newpm);
cxstack_ix++; /* temporarily protect top context */
- switch (CxTYPE(cx)) {
- case CXt_LOOP_LAZYIV:
- case CXt_LOOP_LAZYSV:
- case CXt_LOOP_FOR:
- case CXt_LOOP_PLAIN:
- pop2 = CxTYPE(cx);
- newsp = PL_stack_base + cx->blk_loop.resetsp;
- nextop = cx->blk_loop.my_op->op_lastop->op_next;
- break;
- case CXt_SUB:
- pop2 = CXt_SUB;
- nextop = cx->blk_sub.retop;
- break;
- case CXt_EVAL:
- POPEVAL(cx);
- nextop = cx->blk_eval.retop;
- break;
- case CXt_FORMAT:
- POPFORMAT(cx);
- nextop = cx->blk_sub.retop;
- break;
- default:
- DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
- }
+ assert(
+ CxTYPE(cx) == CXt_LOOP_LAZYIV
+ || CxTYPE(cx) == CXt_LOOP_LAZYSV
+ || CxTYPE(cx) == CXt_LOOP_FOR
+ || CxTYPE(cx) == CXt_LOOP_PLAIN
+ );
+ newsp = PL_stack_base + cx->blk_loop.resetsp;
+ nextop = cx->blk_loop.my_op->op_lastop->op_next;
TAINT_NOT;
PL_stack_sp = newsp;
LEAVE;
cxstack_ix--;
/* Stack values are safe: */
- switch (pop2) {
- case CXt_LOOP_LAZYIV:
- case CXt_LOOP_PLAIN:
- case CXt_LOOP_LAZYSV:
- case CXt_LOOP_FOR:
- POPLOOP(cx); /* release loop vars ... */
- LEAVE;
- break;
- case CXt_SUB:
- POPSUB(cx,sv); /* release CV and @_ ... */
- break;
- }
+ POPLOOP(cx); /* release loop vars ... */
+ LEAVE;
PL_curpm = newpm; /* ... and pop $1 et al */
- LEAVESUB(sv);
- PERL_UNUSED_VAR(optype);
PERL_UNUSED_VAR(gimme);
return nextop;
}
}
/* We donate this refcount later to the callee’s pad. */
SvREFCNT_inc_simple_void(arg);
- if (CxTYPE(cx) == CXt_SUB &&
- !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
- SvREFCNT_dec(cx->blk_sub.cv);
+ if (CxTYPE(cx) == CXt_SUB) {
+ CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
+ SvREFCNT_dec_NN(cx->blk_sub.cv);
+ }
oldsave = PL_scopestack[PL_scopestack_ix - 1];
LEAVE_SCOPE(oldsave);
cx->blk_sub.olddepth = CvDEPTH(cv);
CvDEPTH(cv)++;
- if (CvDEPTH(cv) < 2)
- SvREFCNT_inc_simple_void_NN(cv);
- else {
+ SvREFCNT_inc_simple_void_NN(cv);
+ if (CvDEPTH(cv) > 1) {
if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
sub_crush_depth(cv);
pad_push(padlist, CvDEPTH(cv));
3 is used for a die caught by an inner eval - continue inner loop
-See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
+See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
establish a local jmpenv to handle exception traps.
=cut
=for apidoc find_runcv
Locate the CV corresponding to the currently executing sub or eval.
-If db_seqp is non_null, skip CVs that are in the DB package and populate
-*db_seqp with the cop sequence number at the point that the DB:: code was
+If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
+C<*db_seqp> with the cop sequence number at the point that the DB:: code was
entered. (This allows debuggers to eval in the scope of the breakpoint
rather than in the scope of the debugger itself.)
/* checking here captures a reasonable error message when
* PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
* user gets a confusing message about looking for the .pmc file
- * rather than for the .pm file.
+ * rather than for the .pm file so do the check in S_doopen_pm when
+ * PMC is on instead of here. S_doopen_pm calls this func.
* This check prevents a \0 in @INC causing problems.
*/
+#ifdef PERL_DISABLE_PMC
if (!IS_SAFE_PATHNAME(p, len, "require"))
return NULL;
+#endif
/* on Win32 stat is expensive (it does an open() and close() twice and
a couple other IO calls), the open will fail with a dir on its own with
}
#endif
-#if !defined(PERLIO_IS_STDIO)
retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
-#else
- retio = PerlIO_open(p, PERL_SCRIPT_MODE);
-#endif
#ifdef WIN32
/* EACCES stops the INC search early in pp_require to implement
feature RT #113422 */
if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
SV *const pmcsv = sv_newmortal();
- Stat_t pmcstat;
+ PerlIO * pmcio;
SvSetSV_nosteal(pmcsv,name);
sv_catpvs(pmcsv, "c");
- if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
- return check_type_and_open(pmcsv);
+ pmcio = check_type_and_open(pmcsv);
+ if (pmcio)
+ return pmcio;
}
return check_type_and_open(name);
}
/* prepare to compile string */
- if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
+ if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
else {
/* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
if (doeval(gimme, runcv, seq, saved_hh)) {
if (was != PL_breakable_sub_gen /* Some subs defined here. */
- ? (PERLDB_LINE || PERLDB_SAVESRC)
+ ? PERLDB_LINE_OR_SAVESRC
: PERLDB_SAVESRC_NOSUBS) {
/* Retain the filegv we created. */
} else if (!saved_delete) {
/* We have already left the scope set up earlier thanks to the LEAVE
in doeval(). */
if (was != PL_breakable_sub_gen /* Some subs defined here. */
- ? (PERLDB_LINE || PERLDB_SAVESRC)
+ ? PERLDB_LINE_OR_SAVESRC
: PERLDB_SAVESRC_INVALID) {
/* Retain the filegv we created. */
} else if (!saved_delete) {
I32 gimme;
PERL_CONTEXT *cx;
OP *retop;
- const U8 save_flags = PL_op -> op_flags;
I32 optype;
SV *namesv;
CV *evalcv;
+ /* grab this value before POPEVAL restores old PL_in_eval */
+ bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
PERL_ASYNC_CHECK();
POPBLOCK(cx,newpm);
}
else {
LEAVE_with_name("eval");
- if (!(save_flags & OPf_SPECIAL)) {
+ if (!keep)
CLEAR_ERRSV();
- }
}
RETURNOP(retop);
I32 gimme;
PERL_CONTEXT *cx;
I32 optype;
+ OP *retop;
PERL_ASYNC_CHECK();
POPBLOCK(cx,newpm);
+ retop = cx->blk_eval.retop;
POPEVAL(cx);
PERL_UNUSED_VAR(optype);
LEAVE_with_name("eval_scope");
CLEAR_ERRSV();
- RETURN;
+ RETURNOP(retop);
}
PP(pp_entergiven)
ENTER_with_name("given");
SAVETMPS;
- if (PL_op->op_targ) {
- SAVEPADSVANDMORTALIZE(PL_op->op_targ);
- SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
- PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
- }
- else {
- SAVE_DEFSV;
- DEFSV_set(POPs);
- }
+ assert(!PL_op->op_targ); /* used to be set for lexical $_ */
+ SAVE_DEFSV;
+ DEFSV_set(POPs);
PUSHBLOCK(cx, CXt_GIVEN, SP);
PUSHGIVEN(cx);
}
SP -= 2; /* Pop the values */
-
+ PUTBACK;
/* ~~ undef */
if (!SvOK(e)) {
RETPUSHYES;
}
- if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
+ if (SvROK(e) && SvOBJECT(SvRV(e)) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n"));
Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
}
- if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
+ if (SvROK(d) && SvOBJECT(SvRV(d)) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
object_on_left = TRUE;
/* ~~ sub */
(void) hv_iterinit(hv);
while ( (he = hv_iternext(hv)) ) {
DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n"));
+ PUTBACK;
if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
+ SPAGAIN;
(void) hv_iterinit(hv);
destroy_matcher(matcher);
RETPUSHYES;
}
+ SPAGAIN;
}
destroy_matcher(matcher);
RETPUSHNO;
for(i = 0; i <= this_len; ++i) {
SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n"));
+ PUTBACK;
if (svp && matcher_matches_sv(matcher, *svp)) {
+ SPAGAIN;
destroy_matcher(matcher);
RETPUSHYES;
}
+ SPAGAIN;
}
destroy_matcher(matcher);
RETPUSHNO;
}
else {
PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
+ bool result;
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n"));
PUTBACK;
- PUSHs(matcher_matches_sv(matcher, d)
- ? &PL_sv_yes
- : &PL_sv_no);
+ result = matcher_matches_sv(matcher, d);
+ SPAGAIN;
+ PUSHs(result ? &PL_sv_yes : &PL_sv_no);
destroy_matcher(matcher);
RETURN;
}
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff