}
- if (TAINTING_get && TAINT_get) {
+ assert(TAINTING_get || !TAINT_get);
+ if (TAINT_get) {
SvTAINTED_on((SV*)new_re);
RX_TAINT_on(new_re);
}
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;
{
dSP; dMARK;
PERL_CONTEXT *cx;
- I32 gimme;
- SV **newsp;
- PMOP *newpm;
- 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);
- /* 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");
- }
- 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);
+ }
cx = &cxstack[cxix];
- if (CxTYPE(cx) == CXt_SUB
- || (CxTYPE(cx) == CXt_EVAL))
- {
- SV **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;
- }
+ 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;
}
- if (CxTYPE(cx) == CXt_EVAL)
- return CxTRYBLOCK(cx)
- ? Perl_pp_leavetry(aTHX)
- : Perl_pp_leaveeval(aTHX);
- /* fall through to a normal sub exit */
- return CvLVALUE(cx->blk_sub.cv)
- ? Perl_pp_leavesublv(aTHX)
- : Perl_pp_leavesub(aTHX);
+ else
+ PL_stack_sp = oldsp;
}
- POPBLOCK(cx,newpm);
+ /* fall through to a normal exit */
switch (CxTYPE(cx)) {
+ case CXt_EVAL:
+ 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 (gimme == G_SCALAR)
- *++newsp = (MARK < SP) ? sv_mortalcopy(*SP) : &PL_sv_undef;
- else if (gimme == G_ARRAY) {
- while (++MARK <= SP) {
- *++newsp = sv_mortalcopy(*MARK);
- TAINT_NOT; /* Each item is independent */
- }
- }
- PL_stack_sp = newsp;
-
- LEAVE;
-
- PL_curpm = newpm; /* ... and pop $1 et al */
-
- return retop;
}
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) {
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);