PP(pp_wantarray)
{
- dVAR;
dSP;
I32 cxix;
const PERL_CONTEXT *cx;
PP(pp_regcreset)
{
- dVAR;
TAINT_NOT;
return NORMAL;
}
PP(pp_regcomp)
{
- dVAR;
dSP;
PMOP *pm = (PMOP*)cLOGOP->op_other;
SV **args;
const bool was_tainted = TAINT_get;
if (pm->op_flags & OPf_STACKED)
lhs = args[-1];
- else if (pm->op_private & OPpTARGET_MY)
+ else if (pm->op_targ)
lhs = PAD_SV(pm->op_targ);
else lhs = DEFSV;
SvGETMAGIC(lhs);
modified by get-magic), to avoid incorrectly setting the
RXf_TAINTED flag with RX_TAINT_on further down. */
TAINT_set(was_tainted);
-#if NO_TAINT_SUPPORT
+#ifdef NO_TAINT_SUPPORT
PERL_UNUSED_VAR(was_tainted);
#endif
}
}
-#ifndef INCOMPLETE_TAINTS
- if (TAINTING_get && TAINT_get) {
+ assert(TAINTING_get || !TAINT_get);
+ if (TAINT_get) {
SvTAINTED_on((SV*)new_re);
RX_TAINT_on(new_re);
}
-#endif
#if !defined(USE_ITHREADS)
/* can't change the optree at runtime either */
PP(pp_substcont)
{
- dVAR;
dSP;
PERL_CONTEXT *cx = &cxstack[cxstack_ix];
PMOP * const pm = (PMOP*) cLOGOP->op_other;
rxres_restore(&cx->sb_rxres, rx);
if (cx->sb_iters++) {
- const I32 saviters = cx->sb_iters;
+ const SSize_t saviters = cx->sb_iters;
if (cx->sb_iters > cx->sb_maxiters)
DIE(aTHX_ "Substitution loop");
POPSUBST(cx);
PERL_ASYNC_CHECK();
RETURNOP(pm->op_next);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
}
cx->sb_iters = saviters;
}
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(dstr));
- MgBYTEPOS_set(mg, sv, SvPVX(dstr), m - orig);
+ MgBYTEPOS_set(mg, sv, SvPVX(sv), m - orig);
}
if (old != rx)
(void)ReREFCNT_inc(rx);
PP(pp_formline)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
SV * const tmpForm = *++MARK;
SV *formsv; /* contains text of original format */
U32 *fpc; /* format ops program counter */
I32 arg;
SV *sv = NULL; /* current item */
const char *item = NULL;/* string value of current item */
- I32 itemsize = 0; /* length of current item, possibly truncated */
+ I32 itemsize = 0; /* length (chars) of item, possibly truncated */
+ I32 itembytes = 0; /* as itemsize, but length in bytes */
I32 fieldsize = 0; /* width of current field */
I32 lines = 0; /* number of lines that have been output */
bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */
STRLEN linemark = 0; /* pos of start of line in output */
NV value;
bool gotsome = FALSE; /* seen at least one non-blank item on this line */
- STRLEN len;
+ STRLEN len; /* length of current sv */
STRLEN linemax; /* estimate of output size in bytes */
bool item_is_utf8 = FALSE;
bool targ_is_utf8 = FALSE;
PerlIO_printf(Perl_debug_log, "%-16s\n", name);
} );
switch (*fpc++) {
- case FF_LINEMARK:
+ case FF_LINEMARK: /* start (or end) of a line */
linemark = t - SvPVX(PL_formtarget);
lines++;
gotsome = FALSE;
break;
- case FF_LITERAL:
+ case FF_LITERAL: /* append <arg> literal chars */
to_copy = *fpc++;
source = (U8 *)f;
f += to_copy;
item_is_utf8 = targ_is_utf8 ? !!DO_UTF8(formsv) : !!SvUTF8(formsv);
goto append;
- case FF_SKIP:
+ case FF_SKIP: /* skip <arg> chars in format */
f += *fpc++;
break;
- case FF_FETCH:
+ case FF_FETCH: /* get next item and set field size to <arg> */
arg = *fpc++;
f += arg;
fieldsize = arg;
SvTAINTED_on(PL_formtarget);
break;
- case FF_CHECKNL:
+ case FF_CHECKNL: /* find max len of item (up to \n) that fits field */
{
- const char *send;
const char *s = item = SvPV_const(sv, len);
- itemsize = len;
- if (DO_UTF8(sv)) {
- itemsize = sv_len_utf8(sv);
- if (itemsize != (I32)len) {
- I32 itembytes;
- if (itemsize > fieldsize) {
- itemsize = fieldsize;
- itembytes = itemsize;
- sv_pos_u2b(sv, &itembytes, 0);
- }
- else
- itembytes = len;
- send = chophere = s + itembytes;
- while (s < send) {
- if (! isCNTRL(*s))
- gotsome = TRUE;
- else if (*s == '\n')
- break;
- s++;
- }
- item_is_utf8 = TRUE;
- itemsize = s - item;
- sv_pos_b2u(sv, &itemsize);
- break;
- }
- }
- item_is_utf8 = FALSE;
- if (itemsize > fieldsize)
- itemsize = fieldsize;
- send = chophere = s + itemsize;
- while (s < send) {
- if (! isCNTRL(*s))
- gotsome = TRUE;
- else if (*s == '\n')
- break;
- s++;
- }
- itemsize = s - item;
+ const char *send = s + len;
+
+ itemsize = 0;
+ item_is_utf8 = DO_UTF8(sv);
+ while (s < send) {
+ if (!isCNTRL(*s))
+ gotsome = TRUE;
+ else if (*s == '\n')
+ break;
+
+ if (item_is_utf8)
+ s += UTF8SKIP(s);
+ else
+ s++;
+ itemsize++;
+ if (itemsize == fieldsize)
+ break;
+ }
+ itembytes = s - item;
+ chophere = s;
break;
}
- case FF_CHECKCHOP:
+ case FF_CHECKCHOP: /* like CHECKNL, but up to highest split point */
{
const char *s = item = SvPV_const(sv, len);
- itemsize = len;
- if (DO_UTF8(sv)) {
- itemsize = sv_len_utf8(sv);
- if (itemsize != (I32)len) {
- I32 itembytes;
- if (itemsize <= fieldsize) {
- const char *send = chophere = s + itemsize;
- while (s < send) {
- if (*s == '\r') {
- itemsize = s - item;
- chophere = s;
- break;
- }
- if (! isCNTRL(*s))
- gotsome = TRUE;
- s++;
- }
- }
- else {
- const char *send;
- itemsize = fieldsize;
- itembytes = itemsize;
- sv_pos_u2b(sv, &itembytes, 0);
- send = chophere = s + itembytes;
- while (s < send || (s == send && isSPACE(*s))) {
- if (isSPACE(*s)) {
- if (chopspace)
- chophere = s;
- if (*s == '\r')
- break;
- }
- else {
- if (! isCNTRL(*s))
- gotsome = TRUE;
- if (strchr(PL_chopset, *s))
- chophere = s + 1;
- }
- s++;
- }
- itemsize = chophere - item;
- sv_pos_b2u(sv, &itemsize);
- }
- item_is_utf8 = TRUE;
- break;
- }
- }
- item_is_utf8 = FALSE;
- if (itemsize <= fieldsize) {
- const char *const send = chophere = s + itemsize;
- while (s < send) {
- if (*s == '\r') {
- itemsize = s - item;
- chophere = s;
- break;
- }
- if (! isCNTRL(*s))
- gotsome = TRUE;
+ const char *send = s + len;
+ I32 size = 0;
+
+ chophere = NULL;
+ item_is_utf8 = DO_UTF8(sv);
+ while (s < send) {
+ /* look for a legal split position */
+ if (isSPACE(*s)) {
+ if (*s == '\r') {
+ chophere = s;
+ itemsize = size;
+ break;
+ }
+ if (chopspace) {
+ /* provisional split point */
+ chophere = s;
+ itemsize = size;
+ }
+ /* we delay testing fieldsize until after we've
+ * processed the possible split char directly
+ * following the last field char; so if fieldsize=3
+ * and item="a b cdef", we consume "a b", not "a".
+ * Ditto further down.
+ */
+ if (size == fieldsize)
+ break;
+ }
+ else {
+ if (strchr(PL_chopset, *s)) {
+ /* provisional split point */
+ /* for a non-space split char, we include
+ * the split char; hence the '+1' */
+ chophere = s + 1;
+ itemsize = size;
+ }
+ if (size == fieldsize)
+ break;
+ if (!isCNTRL(*s))
+ gotsome = TRUE;
+ }
+
+ if (item_is_utf8)
+ s += UTF8SKIP(s);
+ else
s++;
- }
- }
- else {
- const char *send;
- itemsize = fieldsize;
- send = chophere = s + itemsize;
- while (s < send || (s == send && isSPACE(*s))) {
- if (isSPACE(*s)) {
- if (chopspace)
- chophere = s;
- if (*s == '\r')
- break;
- }
- else {
- if (! isCNTRL(*s))
- gotsome = TRUE;
- if (strchr(PL_chopset, *s))
- chophere = s + 1;
- }
- s++;
- }
- itemsize = chophere - item;
- }
+ size++;
+ }
+ if (!chophere || s == send) {
+ chophere = s;
+ itemsize = size;
+ }
+ itembytes = chophere - item;
+
break;
}
- case FF_SPACE:
+ case FF_SPACE: /* append padding space (diff of field, item size) */
arg = fieldsize - itemsize;
if (arg) {
fieldsize -= arg;
}
break;
- case FF_HALFSPACE:
+ case FF_HALFSPACE: /* like FF_SPACE, but only append half as many */
arg = fieldsize - itemsize;
if (arg) {
arg /= 2;
}
break;
- case FF_ITEM:
- to_copy = itemsize;
+ case FF_ITEM: /* append a text item, while blanking ctrl chars */
+ to_copy = itembytes;
source = (U8 *)item;
trans = 1;
- if (item_is_utf8) {
- /* convert to_copy from chars to bytes */
- U8 *s = source;
- while (to_copy--)
- s += UTF8SKIP(s);
- to_copy = s - source;
- }
goto append;
- case FF_CHOP:
- {
+ case FF_CHOP: /* (for ^*) chop the current item */
+ if (sv != &PL_sv_no) {
const char *s = chophere;
if (chopspace) {
while (isSPACE(*s))
s++;
}
- sv_chop(sv,s);
+ if (SvPOKp(sv))
+ sv_chop(sv,s);
+ else
+ /* tied, overloaded or similar strangeness.
+ * Do it the hard way */
+ sv_setpvn(sv, s, len - (s-item));
SvSETMAGIC(sv);
break;
}
- case FF_LINESNGL:
+ case FF_LINESNGL: /* process ^* */
chopspace = 0;
- case FF_LINEGLOB:
+ /* FALLTHROUGH */
+
+ case FF_LINEGLOB: /* process @* */
{
const bool oneline = fpc[-1] == FF_LINESNGL;
const char *s = item = SvPV_const(sv, len);
const char *const send = s + len;
item_is_utf8 = DO_UTF8(sv);
+ chophere = s + len;
if (!len)
break;
trans = 0;
gotsome = TRUE;
- chophere = s + len;
source = (U8 *) s;
to_copy = len;
while (s < send) {
if (*s++ == '\n') {
if (oneline) {
- to_copy = s - SvPVX_const(sv) - 1;
+ to_copy = s - item - 1;
chophere = s;
break;
} else {
break;
}
- case FF_0DECIMAL:
+ case FF_0DECIMAL: /* like FF_DECIMAL but for 0### */
arg = *fpc++;
-#if defined(USE_LONG_DOUBLE)
- fmt = (const char *)
- ((arg & FORM_NUM_POINT) ?
- "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
-#else
fmt = (const char *)
- ((arg & FORM_NUM_POINT) ?
- "%#0*.*f" : "%0*.*f");
-#endif
+ ((arg & FORM_NUM_POINT) ? "%#0*.*" NVff : "%0*.*" NVff);
goto ff_dec;
- case FF_DECIMAL:
+
+ case FF_DECIMAL: /* do @##, ^##, where <arg>=(precision|flags) */
arg = *fpc++;
-#if defined(USE_LONG_DOUBLE)
fmt = (const char *)
- ((arg & FORM_NUM_POINT) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
-#else
- fmt = (const char *)
- ((arg & FORM_NUM_POINT) ? "%#*.*f" : "%*.*f");
-#endif
+ ((arg & FORM_NUM_POINT) ? "%#*.*" NVff : "%*.*" NVff);
ff_dec:
/* If the field is marked with ^ and the value is undefined,
blank it out. */
}
/* Formats aren't yet marked for locales, so assume "yes". */
{
- STORE_NUMERIC_STANDARD_SET_LOCAL();
- arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
- my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
- RESTORE_NUMERIC_STANDARD();
+ Size_t max = SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget));
+ int len;
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
+ arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
+#ifdef USE_QUADMATH
+ {
+ const char* qfmt = quadmath_format_single(fmt);
+ int len;
+ if (!qfmt)
+ Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
+ len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
+ if (len == -1)
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+ if (qfmt != fmt)
+ Safefree(fmt);
+ }
+#else
+ /* we generate fmt ourselves so it is safe */
+ GCC_DIAG_IGNORE(-Wformat-nonliteral);
+ len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
+ GCC_DIAG_RESTORE;
+#endif
+ PERL_MY_SNPRINTF_POST_GUARD(len, max);
+ RESTORE_LC_NUMERIC();
}
t += fieldsize;
break;
- case FF_NEWLINE:
+ case FF_NEWLINE: /* delete trailing spaces, then append \n */
f++;
while (t-- > (SvPVX(PL_formtarget) + linemark) && *t == ' ') ;
t++;
*t++ = '\n';
break;
- case FF_BLANK:
+ case FF_BLANK: /* for arg==0: do '~'; for arg>0 : do '~~' */
arg = *fpc++;
if (gotsome) {
if (arg) { /* repeat until fields exhausted? */
}
break;
- case FF_MORE:
+ case FF_MORE: /* replace long end of string with '...' */
{
const char *s = chophere;
const char *send = item + len;
}
break;
}
- case FF_END:
+
+ case FF_END: /* tidy up, then return */
end:
assert(t < SvPVX_const(PL_formtarget) + SvLEN(PL_formtarget));
*t = '\0';
PP(pp_grepstart)
{
- dVAR; dSP;
+ 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];
- if (SvPADTMP(src) && !IS_PADGV(src)) {
- src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
+ src = PL_stack_base[TOPMARK];
+ if (SvPADTMP(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)
PP(pp_mapwhile)
{
- dVAR; dSP;
+ 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;
/* set $_ to the new source item */
src = PL_stack_base[PL_markstack_ptr[-1]];
- if (SvPADTMP(src) && !IS_PADGV(src)) src = sv_mortalcopy(src);
+ if (SvPADTMP(src)) {
+ 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);
}
PP(pp_range)
{
- dVAR;
- if (GIMME == G_ARRAY)
+ if (GIMME_V == G_ARRAY)
return NORMAL;
if (SvTRUEx(PAD_SV(PL_op->op_targ)))
return cLOGOP->op_other;
PP(pp_flip)
{
- dVAR;
dSP;
- if (GIMME == G_ARRAY) {
+ if (GIMME_V == G_ARRAY) {
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
}
else {
PP(pp_flop)
{
- dVAR; dSP;
+ dSP;
- if (GIMME == G_ARRAY) {
+ if (GIMME_V == G_ARRAY) {
dPOPPOPssrl;
SvGETMAGIC(left);
SvGETMAGIC(right);
if (RANGE_IS_NUMERIC(left,right)) {
- IV i, j;
- IV max;
+ IV i, j, n;
if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
(SvOK(right) && (SvIOK(right)
? SvIsUV(right) && SvUV(right) > IV_MAX
: SvNV_nomg(right) > IV_MAX)))
DIE(aTHX_ "Range iterator outside integer range");
i = SvIV_nomg(left);
- max = SvIV_nomg(right);
- if (max >= i) {
- j = max - i + 1;
- if (j > SSize_t_MAX)
- Perl_croak(aTHX_ "Out of memory during list extend");
- EXTEND_MORTAL(j);
- EXTEND(SP, j);
+ j = SvIV_nomg(right);
+ if (j >= i) {
+ /* Dance carefully around signed max. */
+ bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
+ if (!overflow) {
+ n = j - i + 1;
+ /* 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 IVSIZE > Size_t_size
+ || n > SSize_t_MAX
+#endif
+ )
+ overflow = TRUE;
+ }
+ if (overflow)
+ Perl_croak(aTHX_ "Out of memory during list extend");
+ EXTEND_MORTAL(n);
+ EXTEND(SP, n);
}
else
- j = 0;
- while (j--) {
- SV * const sv = sv_2mortal(newSViv(i++));
+ n = 0;
+ while (n--) {
+ SV * const sv = sv_2mortal(newSViv(i));
PUSHs(sv);
+ if (n) /* avoid incrementing above IV_MAX */
+ i++;
}
}
else {
STATIC I32
S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
{
- dVAR;
I32 i;
PERL_ARGS_ASSERT_DOPOPTOLABEL;
I32
Perl_dowantarray(pTHX)
{
- dVAR;
const I32 gimme = block_gimme();
return (gimme == G_VOID) ? G_SCALAR : gimme;
}
I32
Perl_block_gimme(pTHX)
{
- dVAR;
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);
- assert(0); /* NOTREACHED */
- return 0;
- }
+ 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)
{
- dVAR;
const I32 cxix = dopoptosub(cxstack_ix);
assert(cxix >= 0); /* We should only be called from inside subs */
I32
Perl_was_lvalue_sub(pTHX)
{
- dVAR;
const I32 cxix = dopoptosub(cxstack_ix-1);
assert(cxix >= 0); /* We should only be called from inside subs */
STATIC I32
S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
{
- dVAR;
I32 i;
PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
+#ifndef DEBUGGING
+ PERL_UNUSED_CONTEXT;
+#endif
for (i = startingblock; i >= 0; i--) {
const PERL_CONTEXT * const cx = &cxstk[i];
* code block. Hide this faked entry from the world. */
if (cx->cx_type & CXp_SUB_RE_FAKE)
continue;
+ /* FALLTHROUGH */
case CXt_EVAL:
case CXt_FORMAT:
DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
STATIC I32
S_dopoptoeval(pTHX_ I32 startingblock)
{
- dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
const PERL_CONTEXT *cx = &cxstack[i];
STATIC I32
S_dopoptoloop(pTHX_ I32 startingblock)
{
- dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
const PERL_CONTEXT * const cx = &cxstack[i];
return i;
}
+/* find the next GIVEN or FOR loop context block */
+
STATIC I32
-S_dopoptogiven(pTHX_ I32 startingblock)
+S_dopoptogivenfor(pTHX_ I32 startingblock)
{
- dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
const PERL_CONTEXT *cx = &cxstack[i];
default:
continue;
case CXt_GIVEN:
- DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found given at cx=%ld)\n", (long)i));
return i;
case CXt_LOOP_PLAIN:
assert(!CxFOREACHDEF(cx));
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
if (CxFOREACHDEF(cx)) {
- DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
+ DEBUG_l( Perl_deb(aTHX_ "(dopoptogivenfor(): found foreach at cx=%ld)\n", (long)i));
return i;
}
}
STATIC I32
S_dopoptowhen(pTHX_ I32 startingblock)
{
- dVAR;
I32 i;
for (i = startingblock; i >= 0; i--) {
const PERL_CONTEXT *cx = &cxstack[i];
void
Perl_dounwind(pTHX_ I32 cxix)
{
- dVAR;
I32 optype;
if (!PL_curstackinfo) /* can happen if die during thread cloning */
return;
while (cxstack_ix > cxix) {
- SV *sv;
PERL_CONTEXT *cx = &cxstack[cxstack_ix];
DEBUG_CX("UNWIND"); \
/* Note: we don't need to restore the base context info till the end. */
POPSUBST(cx);
continue; /* not break */
case CXt_SUB:
- POPSUB(cx,sv);
- LEAVESUB(sv);
+ POPSUB(cx);
break;
case CXt_EVAL:
POPEVAL(cx);
break;
+ case CXt_BLOCK:
+ POPBASICBLK(cx);
+ break;
case CXt_LOOP_LAZYIV:
case CXt_LOOP_LAZYSV:
case CXt_LOOP_FOR:
case CXt_LOOP_PLAIN:
POPLOOP(cx);
break;
+ case CXt_WHEN:
+ POPWHEN(cx);
+ break;
+ case CXt_GIVEN:
+ POPGIVEN(cx);
+ break;
case CXt_NULL:
break;
case CXt_FORMAT:
void
Perl_qerror(pTHX_ SV *err)
{
- dVAR;
-
PERL_ARGS_ASSERT_QERROR;
if (PL_in_eval) {
void
Perl_die_unwind(pTHX_ SV *msv)
{
- dVAR;
SV *exceptsv = sv_mortalcopy(msv);
U8 in_eval = PL_in_eval;
PERL_ARGS_ASSERT_DIE_UNWIND;
if (in_eval) {
I32 cxix;
- I32 gimme;
/*
* Historically, perl used to set ERRSV ($@) early in the die
SV *namesv;
PERL_CONTEXT *cx;
SV **newsp;
+ I32 gimme;
+#ifdef DEBUGGING
COP *oldcop;
+#endif
JMPENV *restartjmpenv;
OP *restartop;
if (cxix < cxstack_ix)
dounwind(cxix);
- POPBLOCK(cx,PL_curpm);
+ cx = &cxstack[cxstack_ix];
+ assert(CxTYPE(cx) == CXt_EVAL);
+ newsp = PL_stack_base + cx->blk_oldsp;
+ gimme = cx->blk_gimme;
+
+ if (gimme == G_SCALAR)
+ *++newsp = &PL_sv_undef;
+ PL_stack_sp = newsp;
+
+
if (CxTYPE(cx) != CXt_EVAL) {
STRLEN msglen;
const char* message = SvPVx_const(exceptsv, msglen);
PerlIO_write(Perl_error_log, message, msglen);
my_exit(1);
}
+
+ POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
+#ifdef DEBUGGING
oldcop = cx->blk_oldcop;
+#endif
restartjmpenv = cx->blk_eval.cur_top_env;
restartop = cx->blk_eval.retop;
- if (gimme == G_SCALAR)
- *++newsp = &PL_sv_undef;
- PL_stack_sp = newsp;
-
- LEAVE;
-
- /* LEAVE could clobber PL_curcop (see save_re_context())
- * XXX it might be better to find a way to avoid messing with
- * PL_curcop in save_re_context() instead, but this is a more
- * minimal fix --GSAR */
- PL_curcop = oldcop;
-
if (optype == OP_REQUIRE) {
+ assert (PL_curcop == oldcop);
(void)hv_store(GvHVn(PL_incgv),
SvPVX_const(namesv),
SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
PL_restartjmpenv = restartjmpenv;
PL_restartop = restartop;
JMPENV_JUMP(3);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
}
}
write_to_stderr(exceptsv);
my_failure_exit();
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
}
PP(pp_xor)
{
- dVAR; dSP; dPOPTOPssrl;
+ dSP; dPOPTOPssrl;
if (SvTRUE(left) != SvTRUE(right))
RETSETYES;
else
}
/*
+
+=head1 CV Manipulation Functions
+
=for apidoc caller_cx
-The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
+The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
returned C<PERL_CONTEXT> structure can be interrogated to find all the
-information returned to Perl by C<caller>. Note that XSUBs don't get a
+information returned to Perl by C<caller>. Note that XSUBs don't get a
stack frame, so C<caller_cx(0, NULL)> will return information for the
immediately-surrounding Perl code.
This function skips over the automatic calls to C<&DB::sub> made on the
-behalf of the debugger. If the stack frame requested was a sub called by
+behalf of the debugger. If the stack frame requested was a sub called by
C<DB::sub>, the return value will be the frame for the call to
C<DB::sub>, since that has the correct line number/etc. for the call
-site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
+site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
frame for the sub call itself.
=cut
PP(pp_caller)
{
- dVAR;
dSP;
const PERL_CONTEXT *cx;
const PERL_CONTEXT *dbcx;
- I32 gimme;
+ I32 gimme = GIMME_V;
const HEK *stash_hek;
I32 count = 0;
bool has_arg = MAXARG && TOPs;
cx = caller_cx(count + !!(PL_op->op_private & OPpOFFBYONE), &dbcx);
if (!cx) {
- if (GIMME != G_ARRAY) {
+ if (gimme != G_ARRAY) {
EXTEND(SP, 1);
RETPUSHUNDEF;
}
stash_hek = SvTYPE(CopSTASH(cx->blk_oldcop)) == SVt_PVHV
? HvNAME_HEK((HV*)CopSTASH(cx->blk_oldcop))
: NULL;
- if (GIMME != G_ARRAY) {
+ if (gimme != G_ARRAY) {
EXTEND(SP, 1);
if (!stash_hek)
PUSHs(&PL_sv_undef);
PUSHTARG;
}
mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
- lcop = closest_cop(cx->blk_oldcop, cx->blk_oldcop->op_sibling,
+ lcop = closest_cop(cx->blk_oldcop, OpSIBLING(cx->blk_oldcop),
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) {
- GV * const cvgv = CvGV(dbcx->blk_sub.cv);
/* So is ccstack[dbcxix]. */
- if (cvgv && isGV(cvgv)) {
- SV * const sv = newSV(0);
- gv_efullname3(sv, cvgv, NULL);
- mPUSHs(sv);
+ if (CvHASGV(dbcx->blk_sub.cv)) {
+ PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
PUSHs(boolSV(CxHASARGS(cx)));
}
else {
if (CxTYPE(cx) == CXt_EVAL) {
/* eval STRING */
if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
- PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
- SvCUR(cx->blk_eval.cur_text)-2,
- SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
+ SV *cur_text = cx->blk_eval.cur_text;
+ if (SvCUR(cur_text) >= 2) {
+ PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
+ SvUTF8(cur_text)|SVs_TEMP));
+ }
+ else {
+ /* I think this is will always be "", but be sure */
+ PUSHs(sv_2mortal(newSVsv(cur_text)));
+ }
+
PUSHs(&PL_sv_no);
}
/* require */
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
&& CopSTASH_eq(PL_curcop, PL_debstash))
{
- AV * const ary = cx->blk_sub.argarray;
+ /* slot 0 of the pad contains the original @_ */
+ AV * const ary = MUTABLE_AV(AvARRAY(MUTABLE_AV(
+ PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
+ cx->blk_sub.olddepth+1]))[0]);
const SSize_t off = AvARRAY(ary) - AvALLOC(ary);
Perl_init_dbargs(aTHX);
PP(pp_reset)
{
- dVAR;
dSP;
const char * tmps;
STRLEN len = 0;
PP(pp_dbstate)
{
- dVAR;
PL_curcop = (COP*)PL_op;
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
PERL_ASYNC_CHECK();
if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
- || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
+ || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
{
dSP;
PERL_CONTEXT *cx;
const I32 gimme = G_ARRAY;
- U8 hasargs;
GV * const gv = PL_DBgv;
CV * cv = NULL;
/* don't do recursive DB::DB call */
return NORMAL;
- ENTER;
- SAVETMPS;
-
- SAVEI32(PL_debug);
- SAVESTACK_POS();
- PL_debug = 0;
- hasargs = 0;
- SPAGAIN;
-
if (CvISXSUB(cv)) {
+ ENTER;
+ SAVEI32(PL_debug);
+ PL_debug = 0;
+ SAVESTACK_POS();
+ SAVETMPS;
PUSHMARK(SP);
(void)(*CvXSUB(cv))(aTHX_ cv);
FREETMPS;
return NORMAL;
}
else {
+ U8 hasargs = 0;
PUSHBLOCK(cx, CXt_SUB, SP);
PUSHSUB_DB(cx);
cx->blk_sub.retop = PL_op->op_next;
+ cx->cx_u.cx_blk.blku_old_savestack_ix = PL_savestack_ix;
+
+ SAVEI32(PL_debug);
+ PL_debug = 0;
+ SAVESTACK_POS();
CvDEPTH(cv)++;
if (CvDEPTH(cv) >= 2) {
PERL_STACK_OVERFLOW_CHECK();
pad_push(CvPADLIST(cv), CvDEPTH(cv));
}
- SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
RETURNOP(CvSTART(cv));
}
return NORMAL;
}
-STATIC SV **
-S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
+/* S_leave_common: Common code that many functions in this file use on
+ scope exit.
+
+ Process the return args on the stack in the range (mark+1..PL_stack_sp)
+ based on context, with any final args starting at newsp+1.
+ Args are mortal copied (or mortalied if lvalue) unless its safe to use
+ as-is, based on whether it has the specified flags. Note that most
+ callers specify flags as (SVs_PADTMP|SVs_TEMP), while leaveeval skips
+ SVs_PADTMP since its optree gets immediately freed, freeing its padtmps
+ at the same time.
+
+ Also, taintedness is cleared.
+*/
+
+STATIC void
+S_leave_common(pTHX_ SV **newsp, SV **mark, I32 gimme,
+ U32 flags, bool lvalue)
{
- bool padtmp = 0;
- PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
+ dSP;
+ PERL_ARGS_ASSERT_LEAVE_COMMON;
- if (flags & SVs_PADTMP) {
- flags &= ~SVs_PADTMP;
- padtmp = 1;
- }
+ TAINT_NOT;
if (gimme == G_SCALAR) {
if (MARK < SP)
- *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
- ? *SP : sv_mortalcopy(*SP);
+ *++newsp = (SvFLAGS(*SP) & flags)
+ ? *SP
+ : lvalue
+ ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
+ : sv_mortalcopy(*SP);
else {
- /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
- MARK = newsp;
- MEXTEND(MARK, 1);
- *++MARK = &PL_sv_undef;
- return MARK;
+ EXTEND(newsp, 1);
+ *++newsp = &PL_sv_undef;
}
}
else if (gimme == G_ARRAY) {
/* in case LEAVE wipes old return values */
while (++MARK <= SP) {
- if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
+ if (SvFLAGS(*MARK) & flags)
*++newsp = *MARK;
else {
- *++newsp = sv_mortalcopy(*MARK);
+ *++newsp = lvalue
+ ? sv_2mortal(SvREFCNT_inc_simple_NN(*MARK))
+ : sv_mortalcopy(*MARK);
TAINT_NOT; /* Each item is independent */
}
}
* point with SP == newsp. */
}
- return newsp;
+ PL_stack_sp = newsp;
}
+
PP(pp_enter)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
- ENTER_with_name("block");
-
- SAVETMPS;
PUSHBLOCK(cx, CXt_BLOCK, SP);
+ PUSHBASICBLK(cx);
RETURN;
}
PP(pp_leave)
{
- dVAR; dSP;
PERL_CONTEXT *cx;
SV **newsp;
PMOP *newpm;
cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */
}
- POPBLOCK(cx,newpm);
+ cx = &cxstack[cxstack_ix];
+ assert(CxTYPE(cx) == CXt_BLOCK);
+ newsp = PL_stack_base + cx->blk_oldsp;
+ gimme = cx->blk_gimme;
+
+ if (gimme == G_VOID)
+ PL_stack_sp = newsp;
+ else
+ leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP,
+ PL_op->op_private & OPpLVALUE);
- gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
+ POPBLOCK(cx,newpm);
+ POPBASICBLK(cx);
- TAINT_NOT;
- SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
PL_curpm = newpm; /* Don't pop $1 et al till now */
- LEAVE_with_name("block");
+ return NORMAL;
+}
- RETURN;
+static bool
+S_outside_integer(pTHX_ SV *sv)
+{
+ if (SvOK(sv)) {
+ const NV nv = SvNV_nomg(sv);
+ if (Perl_isinfnan(nv))
+ return TRUE;
+#ifdef NV_PRESERVES_UV
+ if (nv < (NV)IV_MIN || nv > (NV)IV_MAX)
+ return TRUE;
+#else
+ if (nv <= (NV)IV_MIN)
+ return TRUE;
+ if ((nv > 0) &&
+ ((nv > (NV)UV_MAX ||
+ SvUV_nomg(sv) > (UV)IV_MAX)))
+ return TRUE;
+#endif
+ }
+ return FALSE;
}
PP(pp_enteriter)
{
- dVAR; dSP; dMARK;
+ dSP; dMARK;
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
- void *itervar; /* location of the iteration variable */
+ void *itervarp; /* GV or pad slot of the iteration variable */
+ SV *itersave; /* the old var in the iterator var slot */
U8 cxtype = CXt_LOOP_FOR;
- ENTER_with_name("loop1");
- SAVETMPS;
-
if (PL_op->op_targ) { /* "my" variable */
+ itervarp = &PAD_SVl(PL_op->op_targ);
+ itersave = *(SV**)itervarp;
+ assert(itersave);
if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
- SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
- SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
- SVs_PADSTALE, SVs_PADSTALE);
+ /* the SV currently in the pad slot is never live during
+ * iteration (the slot is always aliased to one of the items)
+ * so it's always stale */
+ SvPADSTALE_on(itersave);
}
- SAVEPADSVANDMORTALIZE(PL_op->op_targ);
-#ifdef USE_ITHREADS
- itervar = PL_comppad;
-#else
- itervar = &PAD_SVl(PL_op->op_targ);
-#endif
+ SvREFCNT_inc_simple_void_NN(itersave);
+ cxtype |= CXp_FOR_PAD;
}
- else { /* symbol table variable */
- GV * const gv = MUTABLE_GV(POPs);
- SV** svp = &GvSV(gv);
- save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
- *svp = newSV(0);
- itervar = (void *)gv;
+ else {
+ SV * const sv = POPs;
+ itervarp = (void *)sv;
+ if (LIKELY(isGV(sv))) { /* symbol table variable */
+ SV** svp = &GvSV(sv);
+ itersave = *svp;
+ if (LIKELY(itersave))
+ SvREFCNT_inc_simple_void_NN(itersave);
+ else
+ *svp = newSV(0);
+ cxtype |= CXp_FOR_GV;
+ }
+ else { /* LV ref: for \$foo (...) */
+ assert(SvTYPE(sv) == SVt_PVMG);
+ assert(SvMAGIC(sv));
+ assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
+ itersave = NULL;
+ cxtype |= CXp_FOR_LVREF;
+ }
}
if (PL_op->op_private & OPpITER_DEF)
cxtype |= CXp_FOR_DEF;
- ENTER_with_name("loop2");
-
PUSHBLOCK(cx, cxtype, SP);
- PUSHLOOP_FOR(cx, itervar, MARK);
+ PUSHLOOP_FOR(cx, itervarp, itersave, MARK);
if (PL_op->op_flags & OPf_STACKED) {
SV *maybe_ary = POPs;
if (SvTYPE(maybe_ary) != SVt_PVAV) {
dPOPss;
SV * const right = maybe_ary;
+ if (UNLIKELY(cxtype & CXp_FOR_LVREF))
+ DIE(aTHX_ "Assigned value is not a reference");
SvGETMAGIC(sv);
SvGETMAGIC(right);
if (RANGE_IS_NUMERIC(sv,right)) {
/* Make sure that no-one re-orders cop.h and breaks our
assumptions */
assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
-#ifdef NV_PRESERVES_UV
- if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
- (SvNV_nomg(sv) > (NV)IV_MAX)))
- ||
- (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
- (SvNV_nomg(right) < (NV)IV_MIN))))
-#else
- if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
- ||
- ((SvNV_nomg(sv) > 0) &&
- ((SvUV_nomg(sv) > (UV)IV_MAX) ||
- (SvNV_nomg(sv) > (NV)UV_MAX)))))
- ||
- (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
- ||
- ((SvNV_nomg(right) > 0) &&
- ((SvUV_nomg(right) > (UV)IV_MAX) ||
- (SvNV_nomg(right) > (NV)UV_MAX))
- ))))
-#endif
+ if (S_outside_integer(aTHX_ sv) ||
+ S_outside_integer(aTHX_ right))
DIE(aTHX_ "Range iterator outside integer range");
cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
PP(pp_enterloop)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
- ENTER_with_name("loop1");
- SAVETMPS;
- ENTER_with_name("loop2");
-
PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
PUSHLOOP_PLAIN(cx, SP);
PP(pp_leaveloop)
{
- dVAR; dSP;
PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PMOP *newpm;
SV **mark;
- POPBLOCK(cx,newpm);
+ cx = &cxstack[cxstack_ix];
assert(CxTYPE_is_LOOP(cx));
- mark = newsp;
+ mark = PL_stack_base + cx->blk_oldsp;
newsp = PL_stack_base + cx->blk_loop.resetsp;
+ gimme = cx->blk_gimme;
- TAINT_NOT;
- SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
- PUTBACK;
+ if (gimme == G_VOID)
+ PL_stack_sp = newsp;
+ else
+ leave_common(newsp, MARK, gimme, SVs_PADTMP|SVs_TEMP,
+ PL_op->op_private & OPpLVALUE);
+ POPBLOCK(cx,newpm);
POPLOOP(cx); /* Stack values are safe: release loop vars ... */
PL_curpm = newpm; /* ... and pop $1 et al */
- LEAVE_with_name("loop2");
- LEAVE_with_name("loop1");
-
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;
+ bool ref;
+ const char *what = NULL;
+
+ cx = &cxstack[cxstack_ix];
+ assert(CxTYPE(cx) == CXt_SUB);
+
+ if (CxMULTICALL(cx)) {
+ /* 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;
+ }
+
+ newsp = PL_stack_base + cx->blk_oldsp;
+ gimme = cx->blk_gimme;
+ 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 ((SvPADTMP(TOPs) ||
- (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
- == SVf_READONLY
- ) &&
+ if (MARK <= SP) {
+ if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
!SvSMAGICAL(TOPs)) {
what =
SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
/* sub:lvalue{} will take us here. */
what = "undef";
}
- LEAVE;
+ croak:
+ POPSUB(cx);
cxstack_ix--;
- POPSUB(cx,sv);
- PL_curpm = newpm;
- LEAVESUB(sv);
+ PL_curpm = cx->blk_oldpm;
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)
- || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
- == SVf_READONLY
- )
+ && (SvPADTMP(*MARK) || 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",
- SvREADONLY(TOPs) ? "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;
+
+ POPBLOCK(cx,newpm);
+ cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
+ POPSUB(cx); /* Stack values are safe: release CV and @_ ... */
+ cxstack_ix--;
+ PL_curpm = newpm; /* ... and pop $1 et al */
+
+ return cx->blk_sub.retop;
}
+
PP(pp_return)
{
- dVAR; dSP; dMARK;
+ 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;
-
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))
+ DIE(aTHX_ "Can't return outside a subroutine");
+ /* We must be in a sort block, which is a CXt_NULL not a
+ * CXt_SUB. Handle specially. */
+ if (cxstack_ix > 0) {
+ /* See comment below about context popping. Since we know
+ * we're scalar and not lvalue, we can preserve the return
+ * value in a simpler fashion than there. */
+ SV *sv = *SP;
+ assert(cxstack[0].blk_gimme == G_SCALAR);
+ if ( (sp != PL_stack_base)
+ && !(SvFLAGS(sv) & (SVs_TEMP|SVs_PADTMP))
+ )
+ *SP = sv_mortalcopy(sv);
+ dounwind(0);
+ }
+ /* caller responsible for popping cxstack[0] */
+ return 0;
+ }
+
+ /* There are contexts that need popping. Doing this may free the
+ * 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_common(). By calling it with lvalue=TRUE, we just bump
+ * the ref count and mortalise the args that need it. 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.
+ */
+ cx = &cxstack[cxix];
+ PUTBACK;
+ leave_common(PL_stack_base + cx->blk_oldsp, MARK,
+ cx->blk_gimme, SVs_TEMP|SVs_PADTMP, TRUE);
+ SPAGAIN;
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;
+ }
+ else {
+ /* Like in the branch above, we need to handle any extra junk on
+ * the stack. But because we're not also popping extra contexts, we
+ * don't have to worry about prematurely freeing args. So we just
+ * need to do the bare minimum to handle junk, and leave the main
+ * arg processing in the function we tail call, e.g. pp_leavesub.
+ * In list context we have to splice out the junk; in scalar
+ * context we can leave as-is (pp_leavesub will later return the
+ * top stack element). But for an empty arg list, e.g.
+ * for (1,2) { return }
+ * we need to set sp = oldsp so that pp_leavesub knows to push
+ * &PL_sv_undef onto the stack.
+ */
+ SV **oldsp;
+ cx = &cxstack[cxix];
+ oldsp = PL_stack_base + cx->blk_oldsp;
+ if (oldsp != MARK) {
+ 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)
-{
- dVAR; 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)
{
- dVAR;
I32 cxix;
if (PL_op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
PP(pp_last)
{
- dVAR;
PERL_CONTEXT *cx;
- I32 pop2 = 0;
- I32 gimme;
- I32 optype;
OP *nextop = NULL;
- SV **newsp;
PMOP *newpm;
- SV **mark;
- SV *sv = NULL;
S_unwind_loop(aTHX_ "last");
POPBLOCK(cx,newpm);
cxstack_ix++; /* temporarily protect top context */
- mark = newsp;
- 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
+ );
+ PL_stack_sp = PL_stack_base + cx->blk_loop.resetsp;
+ nextop = cx->blk_loop.my_op->op_lastop->op_next;
TAINT_NOT;
- PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme,
- pop2 == CXt_SUB ? SVs_TEMP : 0);
- 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 ... */
PL_curpm = newpm; /* ... and pop $1 et al */
- LEAVESUB(sv);
- PERL_UNUSED_VAR(optype);
- PERL_UNUSED_VAR(gimme);
return nextop;
}
PP(pp_next)
{
- dVAR;
PERL_CONTEXT *cx;
- const I32 inner = PL_scopestack_ix;
S_unwind_loop(aTHX_ "next");
- /* clear off anything above the scope we're re-entering, but
- * save the rest until after a possible continue block */
TOPBLOCK(cx);
- if (PL_scopestack_ix < inner)
- leave_scope(PL_scopestack[PL_scopestack_ix]);
PL_curcop = cx->blk_oldcop;
PERL_ASYNC_CHECK();
return (cx)->blk_loop.my_op->op_nextop;
PP(pp_redo)
{
- dVAR;
const I32 cxix = S_unwind_loop(aTHX_ "redo");
PERL_CONTEXT *cx;
- I32 oldsave;
OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
if (redo_op->op_type == OP_ENTER) {
}
TOPBLOCK(cx);
- oldsave = PL_scopestack[PL_scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
+ CX_LEAVE_SCOPE(cx);
FREETMPS;
PL_curcop = cx->blk_oldcop;
PERL_ASYNC_CHECK();
STATIC OP *
S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
{
- dVAR;
OP **ops = opstack;
static const char* const too_deep = "Target of goto is too deeply nested";
if (o->op_flags & OPf_KIDS) {
OP *kid;
/* First try all the kids at this level, since that's likeliest. */
- for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
STRLEN kid_label_len;
U32 kid_label_flags;
return kid;
}
}
- for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
+ for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
if (kid == PL_lastgotoprobe)
continue;
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
return 0;
}
-PP(pp_goto) /* also pp_dump */
+
+/* also used for: pp_dump() */
+
+PP(pp_goto)
{
dVAR; dSP;
OP *retop = NULL;
SV * const sv = POPs;
SvGETMAGIC(sv);
- /* This egregious kludge implements goto &subroutine */
if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
+ /* This egregious kludge implements goto &subroutine */
I32 cxix;
PERL_CONTEXT *cx;
CV *cv = MUTABLE_CV(SvRV(sv));
AV *arg = GvAV(PL_defgv);
- I32 oldsave;
- retry:
- if (!CvROOT(cv) && !CvXSUB(cv)) {
+ while (!CvROOT(cv) && !CvXSUB(cv)) {
const GV * const gv = CvGV(cv);
if (gv) {
GV *autogv;
SV *tmpstr;
/* autoloaded stub? */
if (cv != GvCV(gv) && (cv = GvCV(gv)))
- goto retry;
+ continue;
autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
GvNAMELEN(gv),
GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
if (autogv && (cv = GvCV(autogv)))
- goto retry;
+ continue;
tmpstr = sv_newmortal();
gv_efullname3(tmpstr, gv, NULL);
DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
DIE(aTHX_ "Goto undefined subroutine");
}
- /* First do some returnish stuff. */
- SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
- FREETMPS;
cxix = dopoptosub(cxstack_ix);
- if (cxix < cxstack_ix) {
- if (cxix < 0) {
- SvREFCNT_dec(cv);
- DIE(aTHX_ "Can't goto subroutine outside a subroutine");
- }
- dounwind(cxix);
+ if (cxix < 0) {
+ DIE(aTHX_ "Can't goto subroutine outside a subroutine");
}
- TOPBLOCK(cx);
- SPAGAIN;
+ cx = &cxstack[cxix];
/* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
if (CxTYPE(cx) == CXt_EVAL) {
- SvREFCNT_dec(cv);
if (CxREALEVAL(cx))
/* diag_listed_as: Can't goto subroutine from an eval-%s */
DIE(aTHX_ "Can't goto subroutine from an eval-string");
DIE(aTHX_ "Can't goto subroutine from an eval-block");
}
else if (CxMULTICALL(cx))
- {
- SvREFCNT_dec(cv);
DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
- }
+
+ /* First do some returnish stuff. */
+
+ SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
+ FREETMPS;
+ if (cxix < cxstack_ix) {
+ dounwind(cxix);
+ }
+ TOPBLOCK(cx);
+ SPAGAIN;
+
+ /* partial unrolled POPSUB(): */
+
+ /* protect @_ during save stack unwind. */
+ if (arg)
+ SvREFCNT_inc_NN(sv_2mortal(MUTABLE_SV(arg)));
+
+ assert(PL_scopestack_ix == cx->blk_oldscopesp);
+ CX_LEAVE_SCOPE(cx);
+
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
- AV* av = cx->blk_sub.argarray;
-
- /* abandon the original @_ if it got reified or if it is
- the same as the current @_ */
- if (AvREAL(av) || av == arg) {
- SvREFCNT_dec(av);
- av = newAV();
- AvREIFY_only(av);
- PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
- }
+ AV* av = MUTABLE_AV(PAD_SVl(0));
+ assert(AvARRAY(MUTABLE_AV(
+ PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
+ CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
+
+ /* we are going to donate the current @_ from the old sub
+ * to the new sub. This first part of the donation puts a
+ * new empty AV in the pad[0] slot of the old sub,
+ * unless pad[0] and @_ differ (e.g. if the old sub did
+ * local *_ = []); in which case clear the old pad[0]
+ * array in the usual way */
+ if (av == arg || AvREAL(av))
+ clear_defarray(av, av == arg);
else CLEAR_ARGARRAY(av);
}
- /* 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);
- oldsave = PL_scopestack[PL_scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
+
+ /* don't restore PL_comppad here. It won't be needed if the
+ * sub we're going to is non-XS, but restoring it early then
+ * croaking (e.g. the "Goto undefined subroutine" below)
+ * means the CX block gets processed again in dounwind,
+ * but this time with the wrong PL_comppad */
/* A destructor called during LEAVE_SCOPE could have undefined
* our precious cv. See bug #99850. */
if (!CvROOT(cv) && !CvXSUB(cv)) {
const GV * const gv = CvGV(cv);
- SvREFCNT_dec(arg);
if (gv) {
SV * const tmpstr = sv_newmortal();
gv_efullname3(tmpstr, gv, NULL);
DIE(aTHX_ "Goto undefined subroutine");
}
+ if (CxTYPE(cx) == CXt_SUB) {
+ CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth;
+ SvREFCNT_dec_NN(cx->blk_sub.cv);
+ }
+
/* Now do some callish stuff. */
- SAVETMPS;
- SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
if (CvISXSUB(cv)) {
- OP* const retop = cx->blk_sub.retop;
- SV **newsp;
- I32 gimme;
const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
- const bool m = arg ? SvRMAGICAL(arg) : 0;
+ const bool m = arg ? cBOOL(SvRMAGICAL(arg)) : 0;
SV** mark;
- PERL_UNUSED_VAR(newsp);
- PERL_UNUSED_VAR(gimme);
+ ENTER;
+ SAVETMPS;
+ SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
/* put GvAV(defgv) back onto stack */
if (items) {
}
}
SP += items;
- SvREFCNT_dec(arg);
if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
/* Restore old @_ */
- arg = GvAV(PL_defgv);
- GvAV(PL_defgv) = cx->blk_sub.savearray;
- SvREFCNT_dec(arg);
+ POP_SAVEARRAY();
}
- /* XS subs don't have a CxSUB, so pop it */
- POPBLOCK(cx, PL_curpm);
+ retop = cx->blk_sub.retop;
+ PL_comppad = cx->blk_sub.prevcomppad;
+ PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
+
+ /* XS subs don't have a CXt_SUB, so pop it;
+ * this is a POPBLOCK(), less all the stuff we already did
+ * for TOPBLOCK() earlier */
+ PL_curcop = cx->blk_oldcop;
+ cxstack_ix--;
+
/* Push a mark for the start of arglist */
PUSHMARK(mark);
PUTBACK;
(void)(*CvXSUB(cv))(aTHX_ cv);
LEAVE;
- PERL_ASYNC_CHECK();
- return retop;
+ goto _return;
}
else {
PADLIST * const padlist = CvPADLIST(cv);
+
+ SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
+
+ /* partial unrolled PUSHSUB(): */
+
cx->blk_sub.cv = cv;
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));
}
PL_curcop = cx->blk_oldcop;
- SAVECOMPPAD();
PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
if (CxHASARGS(cx))
{
- CX_CURPAD_SAVE(cx->blk_sub);
-
- /* cx->blk_sub.argarray has no reference count, so we
- need something to hang on to our argument array so
- that cx->blk_sub.argarray does not end up pointing
- to freed memory as the result of undef *_. So put
- it in the callee’s pad, donating our refer-
- ence count. */
- SvREFCNT_dec(PAD_SVl(0));
- PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
+ /* second half of donating @_ from the old sub to the
+ * new sub: abandon the original pad[0] AV in the
+ * new sub, and replace it with the donated @_.
+ * pad[0] takes ownership of the extra refcount
+ * we gave arg earlier */
+ if (arg) {
+ SvREFCNT_dec(PAD_SVl(0));
+ PAD_SVl(0) = (SV *)arg;
+ SvREFCNT_inc_simple_void_NN(arg);
+ }
/* GvAV(PL_defgv) might have been modified on scope
- exit, so restore it. */
+ exit, so point it at arg again. */
if (arg != GvAV(PL_defgv)) {
AV * const av = GvAV(PL_defgv);
GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
SvREFCNT_dec(av);
}
}
- else SvREFCNT_dec(arg);
+
if (PERLDB_SUB) { /* Checking curstash breaks DProf. */
Perl_get_db_sub(aTHX_ NULL, cv);
if (PERLDB_GOTO) {
}
}
}
- PERL_ASYNC_CHECK();
- RETURNOP(CvSTART(cv));
+ retop = CvSTART(cv);
+ goto putback_return;
}
}
else {
case CXt_LOOP_PLAIN:
case CXt_GIVEN:
case CXt_WHEN:
- gotoprobe = cx->blk_oldcop->op_sibling;
+ gotoprobe = OpSIBLING(cx->blk_oldcop);
break;
case CXt_SUBST:
continue;
case CXt_BLOCK:
if (ix) {
- gotoprobe = cx->blk_oldcop->op_sibling;
+ gotoprobe = OpSIBLING(cx->blk_oldcop);
in_block = TRUE;
} else
gotoprobe = PL_main_root;
gotoprobe = CvROOT(cx->blk_sub.cv);
break;
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case CXt_FORMAT:
case CXt_NULL:
DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
break;
}
if (gotoprobe) {
+ OP *sibl1, *sibl2;
+
retop = dofindlabel(gotoprobe, label, label_len, label_flags,
enterops, enterops + GOTO_DEPTH);
if (retop)
break;
- if (gotoprobe->op_sibling &&
- gotoprobe->op_sibling->op_type == OP_UNSTACK &&
- gotoprobe->op_sibling->op_sibling) {
- retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
+ if ( (sibl1 = OpSIBLING(gotoprobe)) &&
+ sibl1->op_type == OP_UNSTACK &&
+ (sibl2 = OpSIBLING(sibl1)))
+ {
+ retop = dofindlabel(sibl2,
label, label_len, label_flags, enterops,
enterops + GOTO_DEPTH);
if (retop)
/* pop unwanted frames */
if (ix < cxstack_ix) {
- I32 oldsave;
-
if (ix < 0)
- ix = 0;
+ DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
dounwind(ix);
TOPBLOCK(cx);
- oldsave = PL_scopestack[PL_scopestack_ix];
- LEAVE_SCOPE(oldsave);
}
/* push wanted frames */
PL_do_undump = FALSE;
}
+ putback_return:
+ PL_stack_sp = sp;
+ _return:
PERL_ASYNC_CHECK();
- RETURNOP(retop);
+ return retop;
}
PP(pp_exit)
{
- dVAR;
dSP;
I32 anum;
else {
anum = SvIVx(POPs);
#ifdef VMS
- if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
+ if (anum == 1
+ && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
anum = 0;
- VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
+ VMSISH_HUSHED =
+ VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
#endif
}
PL_exit_flags |= PERL_EXIT_EXPECTED;
-#ifdef PERL_MAD
- /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
- if (anum || !(PL_minus_c && PL_madskills))
- my_exit(anum);
-#else
my_exit(anum);
-#endif
PUSHs(&PL_sv_undef);
RETURN;
}
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
STATIC OP *
S_docatch(pTHX_ OP *o)
{
- dVAR;
int ret;
OP * const oldop = PL_op;
dJMPENV;
PL_restartop = 0;
goto redo_body;
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
default:
JMPENV_POP;
PL_op = oldop;
JMPENV_JUMP(ret);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
}
JMPENV_POP;
PL_op = oldop;
=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
-entered. (allows debuggers to eval in the scope of the breakpoint rather
-than in the scope of the debugger itself).
+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.)
=cut
*/
CV *
Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
{
- dVAR;
PERL_SI *si;
int level = 0;
switch (cond) {
case FIND_RUNCV_padid_eq:
if (!CvPADLIST(cv)
- || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
+ || CvPADLIST(cv)->xpadl_id != (U32)arg)
continue;
return cv;
case FIND_RUNCV_level_eq:
default:
JMPENV_POP;
JMPENV_JUMP(ret);
- assert(0); /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
}
JMPENV_POP;
return ret;
STATIC bool
S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
{
- dVAR; dSP;
+ dSP;
OP * const saveop = PL_op;
bool clear_hints = saveop->op_type != OP_ENTEREVAL;
COP * const oldcurcop = PL_curcop;
/* set up a scratch pad */
- CvPADLIST(evalcv) = pad_new(padnew_SAVE);
+ CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
- if (!PL_madskills)
- SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
+ SAVEMORTALIZESV(evalcv); /* must remain until end of current statement */
/* make sure we compile in the right package */
PL_unitcheckav = newAV();
SAVEFREESV(PL_unitcheckav);
-#ifdef PERL_MAD
- SAVEBOOL(PL_madskills);
- PL_madskills = 0;
-#endif
ENTER_with_name("evalcomp");
SAVESPTR(PL_compcv);
yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
if (yystatus || PL_parser->error_count || !PL_eval_root) {
- SV **newsp; /* Used by POPBLOCK. */
PERL_CONTEXT *cx;
I32 optype; /* Used by POPEVAL. */
SV *namesv;
cx = NULL;
namesv = NULL;
- PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(optype);
/* note that if yystatus == 3, then the EVAL CX block has already
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
- /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
- LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE. */
}
errsv = ERRSV;
{
Stat_t st;
STRLEN len;
+ PerlIO * retio;
const char *p = SvPV_const(name, len);
int st_rc;
/* 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
+ errno EACCES, so only do a stat to separate a dir from a real EACCES
+ caused by user perms */
+#ifndef WIN32
+ /* we use the value of errno later to see how stat() or open() failed.
+ * We don't want it set if the stat succeeded but we still failed,
+ * such as if the name exists, but is a directory */
+ errno = 0;
st_rc = PerlLIO_stat(p, &st);
if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
return NULL;
}
+#endif
-#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
- return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
-#else
- return PerlIO_open(p, PERL_SCRIPT_MODE);
+ retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
+#ifdef WIN32
+ /* EACCES stops the INC search early in pp_require to implement
+ feature RT #113422 */
+ if(!retio && errno == EACCES) { /* exists but probably a directory */
+ int eno;
+ st_rc = PerlLIO_stat(p, &st);
+ if (st_rc >= 0) {
+ if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
+ eno = 0;
+ else
+ eno = EACCES;
+ errno = eno;
+ }
+ }
#endif
+ return retio;
}
#ifndef PERL_DISABLE_PMC
if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
SV *const pmcsv = sv_newmortal();
- Stat_t pmcstat;
+ PerlIO * pmcio;
SvSetSV_nosteal(pmcsv,name);
- sv_catpvn(pmcsv, "c", 1);
+ 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);
}
#endif /* !PERL_DISABLE_PMC */
/* require doesn't search for absolute names, or when the name is
- explicity relative the current directory */
+ explicitly relative the current directory */
PERL_STATIC_INLINE bool
S_path_is_searchable(const char *name)
{
return TRUE;
}
+
+/* also used for: pp_dofile() */
+
PP(pp_require)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
SV *sv;
const char *name;
STRLEN unixlen;
#ifdef VMS
int vms_unixname = 0;
- char *unixnamebuf;
char *unixdir;
- char *unixdirbuf;
#endif
const char *tryname = NULL;
SV *namesv = NULL;
SV *filter_state = NULL;
SV *filter_sub = NULL;
SV *hook_sv = NULL;
- SV *encoding;
OP *op;
int saved_errno;
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))
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_len(lav) > 1 /* FP with > 3 digits */
+ || av_tindex(lav) > 1 /* FP with > 3 digits */
|| strstr(SvPVX(pv),".0") /* FP with leading 0 */
) {
DIE(aTHX_ "Perl %"SVf" required--this is only "
SV *hintsv;
I32 second = 0;
- if (av_len(lav)>=1)
+ if (av_tindex(lav)>=1)
second = SvIV(*av_fetch(lav,1,0));
second /= second >= 600 ? 100 : 10;
RETPUSHYES;
}
- name = SvPV_const(sv, len);
+ if (!SvOK(sv))
+ DIE(aTHX_ "Missing or undefined argument to require");
+ name = SvPV_nomg_const(sv, len);
if (!(name && len > 0 && *name))
- DIE(aTHX_ "Null filename used");
+ DIE(aTHX_ "Missing or undefined argument to require");
+
if (!IS_SAFE_PATHNAME(name, len, "require")) {
DIE(aTHX_ "Can't locate %s: %s",
pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
* name can be translated to UNIX.
*/
- if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
- && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
+ if ((unixname =
+ tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
+ != NULL) {
unixlen = strlen(unixname);
vms_unixname = 1;
}
if (vms_unixname)
#endif
{
+ SV *nsv = sv;
namesv = newSV_type(SVt_PV);
for (i = 0; i <= AvFILL(ar); i++) {
SV * const dirsv = *av_fetch(ar, i, TRUE);
- if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
- mg_get(dirsv);
+ SvGETMAGIC(dirsv);
if (SvROK(dirsv)) {
int count;
SV **svp;
SV *loader = dirsv;
if (SvTYPE(SvRV(loader)) == SVt_PVAV
- && !sv_isobject(loader))
+ && !SvOBJECT(SvRV(loader)))
{
loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
+ SvGETMAGIC(loader);
}
Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
tryname = SvPVX_const(namesv);
tryrsfp = NULL;
+ if (SvPADTMP(nsv)) {
+ nsv = sv_newmortal();
+ SvSetSV_nosteal(nsv,sv);
+ }
+
ENTER_with_name("call_INC");
SAVETMPS;
EXTEND(SP, 2);
PUSHMARK(SP);
PUSHs(dirsv);
- PUSHs(sv);
+ PUSHs(nsv);
PUTBACK;
+ if (SvGMAGICAL(loader)) {
+ SV *l = sv_newmortal();
+ sv_setsv_nomg(l, loader);
+ loader = l;
+ }
if (sv_isobject(loader))
count = call_method("INC", G_ARRAY);
else
SP--;
}
+ /* FREETMPS may free our filter_cache */
+ SvREFCNT_inc_simple_void(filter_cache);
+
PUTBACK;
FREETMPS;
LEAVE_with_name("call_INC");
+ /* Now re-mortalize it. */
+ sv_2mortal(filter_cache);
+
/* Adjust file name if the hook has set an %INC entry.
This needs to happen after the FREETMPS above. */
svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
filter_has_file = 0;
filter_cache = NULL;
if (filter_state) {
- SvREFCNT_dec(filter_state);
+ SvREFCNT_dec_NN(filter_state);
filter_state = NULL;
}
if (filter_sub) {
- SvREFCNT_dec(filter_sub);
+ SvREFCNT_dec_NN(filter_sub);
filter_sub = NULL;
}
}
STRLEN dirlen;
if (SvOK(dirsv)) {
- dir = SvPV_const(dirsv, dirlen);
+ dir = SvPV_nomg_const(dirsv, dirlen);
} else {
dir = "";
dirlen = 0;
}
+ if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
+ continue;
#ifdef VMS
- if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
- || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
+ if ((unixdir =
+ tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
+ == NULL)
continue;
sv_setpv(namesv, unixdir);
sv_catpv(namesv, unixname);
/* Avoid '<dir>//<file>' */
if (!dirlen || *(tmp-1) != '/') {
*tmp++ = '/';
+ } else {
+ /* So SvCUR_set reports the correct length below */
+ dirlen--;
}
/* name came from an SV, so it will have a '\0' at the
if (PL_op->op_type == OP_REQUIRE) {
if(saved_errno == EMFILE || saved_errno == EACCES) {
/* diag_listed_as: Can't locate %s */
- DIE(aTHX_ "Can't locate %s: %s", name, Strerror(saved_errno));
+ DIE(aTHX_ "Can't locate %s: %s: %s",
+ name, tryname, Strerror(saved_errno));
} else {
if (namesv) { /* did we lookup @INC? */
AV * const ar = GvAVn(PL_incgv);
sv_catpv(msg, " (you may need to install the ");
for (c = name; c < e; c++) {
if (*c == '/') {
- sv_catpvn(msg, "::", 2);
+ sv_catpvs(msg, "::");
}
else {
sv_catpvn(msg, c, 1);
unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
}
- ENTER_with_name("eval");
- SAVETMPS;
+ old_savestack_ix = PL_savestack_ix;
SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tryname);
lex_start(NULL, tryrsfp, 0);
/* switch to eval mode */
PUSHBLOCK(cx, CXt_EVAL, SP);
PUSHEVAL(cx, name);
+ cx->cx_u.cx_blk.blku_old_savestack_ix = old_savestack_ix;
cx->blk_eval.retop = PL_op->op_next;
SAVECOPLINE(&PL_compiling);
PUTBACK;
- /* Store and reset encoding. */
- encoding = PL_encoding;
- PL_encoding = NULL;
-
if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
op = DOCATCH(PL_eval_start);
else
op = PL_op->op_next;
- /* Restore encoding. */
- PL_encoding = encoding;
-
LOADED_FILE_PROBE(unixname);
return op;
PP(pp_hintseval)
{
- dVAR;
dSP;
mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
RETURN;
PP(pp_entereval)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
SV *sv;
const I32 gimme = GIMME_V;
U32 seq, lex_flags = 0;
HV *saved_hh = NULL;
const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
+ I32 old_savestack_ix;
if (PL_op->op_private & OPpEVAL_HAS_HH) {
saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
TAINT_IF(SvTAINTED(sv));
TAINT_PROPER("eval");
- ENTER_with_name("eval");
+ old_savestack_ix = PL_savestack_ix;
+
lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
? LEX_IGNORE_UTF8_HINTS
: bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
)
);
- SAVETMPS;
/* switch to eval mode */
PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
PUSHEVAL(cx, 0);
+ cx->cx_u.cx_blk.blku_old_savestack_ix = old_savestack_ix;
cx->blk_eval.retop = PL_op->op_next;
/* 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) {
PP(pp_leaveeval)
{
- dVAR; dSP;
+ dSP;
SV **newsp;
PMOP *newpm;
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();
+
+ cx = &cxstack[cxstack_ix];
+ assert(CxTYPE(cx) == CXt_EVAL);
+ newsp = PL_stack_base + cx->blk_oldsp;
+ gimme = cx->blk_gimme;
+
+ if (gimme != G_VOID) {
+ PUTBACK;
+ leave_common(newsp, newsp, gimme, SVs_TEMP, FALSE);
+ SPAGAIN;
+ }
POPBLOCK(cx,newpm);
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
retop = cx->blk_eval.retop;
evalcv = cx->blk_eval.cv;
- TAINT_NOT;
- SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
- gimme, SVs_TEMP);
PL_curpm = newpm; /* Don't pop $1 et al till now */
#ifdef DEBUGGING
SvPVX_const(namesv),
SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
G_DISCARD);
- retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
- SVfARG(namesv));
+ Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
+ NOT_REACHED; /* NOTREACHED */
/* die_unwind() did LEAVE, or we won't be here */
}
else {
- LEAVE_with_name("eval");
- if (!(save_flags & OPf_SPECIAL)) {
+ if (!keep)
CLEAR_ERRSV();
- }
}
RETURNOP(retop);
void
Perl_delete_eval_scope(pTHX)
{
- SV **newsp;
PMOP *newpm;
- I32 gimme;
PERL_CONTEXT *cx;
I32 optype;
POPBLOCK(cx,newpm);
POPEVAL(cx);
PL_curpm = newpm;
- LEAVE_with_name("eval_scope");
- PERL_UNUSED_VAR(newsp);
- PERL_UNUSED_VAR(gimme);
PERL_UNUSED_VAR(optype);
}
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
- ENTER_with_name("eval_scope");
- SAVETMPS;
-
PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
PUSHEVAL(cx, 0);
+ cx->cx_u.cx_blk.blku_old_savestack_ix = PL_savestack_ix;
PL_in_eval = EVAL_INEVAL;
if (flags & G_KEEPERR)
PP(pp_entertry)
{
- dVAR;
PERL_CONTEXT * const cx = create_eval_scope(0);
cx->blk_eval.retop = cLOGOP->op_other->op_next;
return DOCATCH(PL_op->op_next);
PP(pp_leavetry)
{
- dVAR; dSP;
SV **newsp;
PMOP *newpm;
I32 gimme;
PERL_CONTEXT *cx;
I32 optype;
+ OP *retop;
PERL_ASYNC_CHECK();
+
+ cx = &cxstack[cxstack_ix];
+ assert(CxTYPE(cx) == CXt_EVAL);
+ newsp = PL_stack_base + cx->blk_oldsp;
+ gimme = cx->blk_gimme;
+
+ if (gimme == G_VOID)
+ PL_stack_sp = newsp;
+ else
+ leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE);
POPBLOCK(cx,newpm);
+ retop = cx->blk_eval.retop;
POPEVAL(cx);
PERL_UNUSED_VAR(optype);
- TAINT_NOT;
- SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
PL_curpm = newpm; /* Don't pop $1 et al till now */
- LEAVE_with_name("eval_scope");
CLEAR_ERRSV();
- RETURN;
+ return retop;
}
PP(pp_entergiven)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
+ SV *origsv = DEFSV;
+ SV *newsv = POPs;
- 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 $_ */
+ GvSV(PL_defgv) = SvREFCNT_inc(newsv);
PUSHBLOCK(cx, CXt_GIVEN, SP);
- PUSHGIVEN(cx);
+ PUSHGIVEN(cx, origsv);
RETURN;
}
PP(pp_leavegiven)
{
- dVAR; dSP;
PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PMOP *newpm;
PERL_UNUSED_CONTEXT;
+ cx = &cxstack[cxstack_ix];
+ assert(CxTYPE(cx) == CXt_GIVEN);
+ newsp = PL_stack_base + cx->blk_oldsp;
+ gimme = cx->blk_gimme;
+
+ if (gimme == G_VOID)
+ PL_stack_sp = newsp;
+ else
+ leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE);
POPBLOCK(cx,newpm);
+ POPGIVEN(cx);
assert(CxTYPE(cx) == CXt_GIVEN);
- TAINT_NOT;
- SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
PL_curpm = newpm; /* Don't pop $1 et al till now */
- LEAVE_with_name("given");
- RETURN;
+ return NORMAL;
}
/* Helper routines used by pp_smartmatch */
STATIC PMOP *
S_make_matcher(pTHX_ REGEXP *re)
{
- dVAR;
PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
PERL_ARGS_ASSERT_MAKE_MATCHER;
STATIC bool
S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
{
- dVAR;
dSP;
+ bool result;
PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
PUTBACK;
(void) Perl_pp_match(aTHX);
SPAGAIN;
- return (SvTRUEx(POPs));
+ result = SvTRUEx(POPs);
+ PUTBACK;
+
+ return result;
}
STATIC void
S_destroy_matcher(pTHX_ PMOP *matcher)
{
- dVAR;
-
PERL_ARGS_ASSERT_DESTROY_MATCHER;
PERL_UNUSED_ARG(matcher);
STATIC OP *
S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
{
- dVAR;
dSP;
bool object_on_left = FALSE;
}
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 */
SSize_t i;
bool andedresults = TRUE;
AV *av = (AV*) SvRV(d);
- const I32 len = av_len(av);
+ const I32 len = av_tindex(av);
DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n"));
if (len == -1)
RETPUSHYES;
/* Check that the key-sets are identical */
HE *he;
HV *other_hv = MUTABLE_HV(SvRV(d));
- bool tied = FALSE;
- bool other_tied = FALSE;
+ bool tied;
+ bool other_tied;
U32 this_key_count = 0,
other_key_count = 0;
HV *hv = MUTABLE_HV(SvRV(e));
DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n"));
/* Tied hashes don't know how many keys they have. */
- if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
- tied = TRUE;
- }
- else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
- HV * const temp = other_hv;
- other_hv = hv;
- hv = temp;
- tied = TRUE;
+ tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
+ other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
+ if (!tied ) {
+ if(other_tied) {
+ /* swap HV sides */
+ HV * const temp = other_hv;
+ other_hv = hv;
+ hv = temp;
+ tied = TRUE;
+ other_tied = FALSE;
+ }
+ else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
+ RETPUSHNO;
}
- if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
- other_tied = TRUE;
-
- if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
- RETPUSHNO;
/* The hashes have the same number of keys, so it suffices
to check that one is a subset of the other. */
}
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
AV * const other_av = MUTABLE_AV(SvRV(d));
- const SSize_t other_len = av_len(other_av) + 1;
+ const SSize_t other_len = av_tindex(other_av) + 1;
SSize_t i;
HV *hv = MUTABLE_HV(SvRV(e));
(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;
}
else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
AV * const other_av = MUTABLE_AV(SvRV(e));
- const SSize_t other_len = av_len(other_av) + 1;
+ const SSize_t other_len = av_tindex(other_av) + 1;
SSize_t i;
DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n"));
if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
AV *other_av = MUTABLE_AV(SvRV(d));
DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n"));
- if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
+ if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
RETPUSHNO;
else {
SSize_t i;
- const SSize_t other_len = av_len(other_av);
+ const SSize_t other_len = av_tindex(other_av);
if (NULL == seen_this) {
seen_this = newHV();
sm_regex_array:
{
PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
- const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
+ const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
SSize_t i;
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 if (!SvOK(d)) {
/* undef ~~ array */
- const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
+ const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
SSize_t i;
DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n"));
sm_any_array:
{
SSize_t i;
- const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
+ const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n"));
for (i = 0; i <= this_len; ++i) {
}
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;
}
PP(pp_enterwhen)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
const I32 gimme = GIMME_V;
if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
RETURNOP(cLOGOP->op_other->op_next);
- ENTER_with_name("when");
- SAVETMPS;
-
PUSHBLOCK(cx, CXt_WHEN, SP);
PUSHWHEN(cx);
PP(pp_leavewhen)
{
- dVAR; dSP;
I32 cxix;
PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
- PMOP *newpm;
- cxix = dopoptogiven(cxstack_ix);
+ cx = &cxstack[cxstack_ix];
+ assert(CxTYPE(cx) == CXt_WHEN);
+ gimme = cx->blk_gimme;
+
+ cxix = dopoptogivenfor(cxstack_ix);
if (cxix < 0)
/* diag_listed_as: Can't "when" outside a topicalizer */
DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
- POPBLOCK(cx,newpm);
- assert(CxTYPE(cx) == CXt_WHEN);
-
- TAINT_NOT;
- SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
- PL_curpm = newpm; /* pop $1 et al */
-
- LEAVE_with_name("when");
-
- if (cxix < cxstack_ix)
- dounwind(cxix);
+ newsp = PL_stack_base + cx->blk_oldsp;
+ if (gimme == G_VOID)
+ PL_stack_sp = newsp;
+ else
+ leave_common(newsp, newsp, gimme, SVs_PADTMP|SVs_TEMP, FALSE);
+ /* pop the WHEN, BLOCK and anything else before the GIVEN/FOR */
+ assert(cxix < cxstack_ix);
+ dounwind(cxix);
cx = &cxstack[cxix];
if (CxFOREACH(cx)) {
- /* clear off anything above the scope we're re-entering */
- I32 inner = PL_scopestack_ix;
-
+ /* emulate pp_next. Note that any stack(s) cleanup will be
+ * done by the pp_unstack which op_nextop should point to */
TOPBLOCK(cx);
- if (PL_scopestack_ix < inner)
- leave_scope(PL_scopestack[PL_scopestack_ix]);
PL_curcop = cx->blk_oldcop;
-
- PERL_ASYNC_CHECK();
return cx->blk_loop.my_op->op_nextop;
}
else {
PERL_ASYNC_CHECK();
- RETURNOP(cx->blk_givwhen.leave_op);
+ assert(cx->blk_givwhen.leave_op->op_type == OP_LEAVEGIVEN);
+ return cx->blk_givwhen.leave_op;
}
}
PP(pp_continue)
{
- dVAR; dSP;
+ dSP;
I32 cxix;
PERL_CONTEXT *cx;
- I32 gimme;
- SV **newsp;
PMOP *newpm;
- PERL_UNUSED_VAR(gimme);
cxix = dopoptowhen(cxstack_ix);
if (cxix < 0)
POPBLOCK(cx,newpm);
assert(CxTYPE(cx) == CXt_WHEN);
+ POPWHEN(cx);
- SP = newsp;
+ SP = PL_stack_base + cx->blk_oldsp;
PL_curpm = newpm; /* pop $1 et al */
- LEAVE_with_name("when");
RETURNOP(cx->blk_givwhen.leave_op->op_next);
}
PP(pp_break)
{
- dVAR;
I32 cxix;
PERL_CONTEXT *cx;
- cxix = dopoptogiven(cxstack_ix);
+ cxix = dopoptogivenfor(cxstack_ix);
if (cxix < 0)
DIE(aTHX_ "Can't \"break\" outside a given block");
s++;
}
noblank = TRUE;
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case ' ': case '\t':
skipspaces++;
continue;
static I32
S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
{
- dVAR;
SV * const datasv = FILTER_DATA(idx);
const int filter_has_file = IoLINES(datasv);
SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
umaxlen = maxlen;
/* I was having segfault trouble under Linux 2.2.5 after a
- parse error occured. (Had to hack around it with a test
+ parse error occurred. (Had to hack around it with a test
for PL_parser->error_count == 0.) Solaris doesn't segfault --
not sure where the trouble is yet. XXX */
}
/*
- * 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