/* pp_ctl.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* And whither then? I cannot say.
*/
+/* This file contains control-oriented pp ("push/pop") functions that
+ * execute the opcodes that make up a perl program. A typical pp function
+ * expects to find its arguments on the stack, and usually pushes its
+ * results onto the stack, hence the 'pp' terminology. Each OP structure
+ * contains a pointer to the relevant pp_foo() function.
+ *
+ * Control-oriented means things like pp_enteriter() and pp_next(), which
+ * alter the flow of control of the program.
+ */
+
+
#include "EXTERN.h"
#define PERL_IN_PP_CTL_C
#include "perl.h"
#ifndef WORD_ALIGN
-#define WORD_ALIGN sizeof(U16)
+#define WORD_ALIGN sizeof(U32)
#endif
#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
/* XXXX Should store the old value to allow for tie/overload - and
restore in regcomp, where marked with XXXX. */
PL_reginterp_cnt = 0;
+ TAINT_NOT;
return NORMAL;
}
SV *tmpstr;
STRLEN len;
MAGIC *mg = Null(MAGIC*);
-
- tmpstr = POPs;
/* prevent recompiling under /o and ithreads. */
#if defined(USE_ITHREADS)
- if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
- RETURN;
+ if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
+ if (PL_op->op_flags & OPf_STACKED) {
+ dMARK;
+ SP = MARK;
+ }
+ else
+ (void)POPs;
+ RETURN;
+ }
#endif
+ if (PL_op->op_flags & OPf_STACKED) {
+ /* multiple args; concatentate them */
+ dMARK; dORIGMARK;
+ tmpstr = PAD_SV(ARGTARG);
+ sv_setpvn(tmpstr, "", 0);
+ while (++MARK <= SP) {
+ if (PL_amagic_generation) {
+ SV *sv;
+ if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
+ (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
+ {
+ sv_setsv(tmpstr, sv);
+ continue;
+ }
+ }
+ sv_catsv(tmpstr, *MARK);
+ }
+ SvSETMAGIC(tmpstr);
+ SP = ORIGMARK;
+ }
+ else
+ tmpstr = POPs;
if (SvROK(tmpstr)) {
SV *sv = SvRV(tmpstr);
char *orig = cx->sb_orig;
register REGEXP *rx = cx->sb_rx;
SV *nsv = Nullsv;
-
- {
- REGEXP *old = PM_GETRE(pm);
- if(old != rx) {
- if(old)
- ReREFCNT_dec(old);
+ REGEXP *old = PM_GETRE(pm);
+ if(old != rx) {
+ if(old)
+ ReREFCNT_dec(old);
PM_SETRE(pm,rx);
- }
}
rxres_restore(&cx->sb_rxres, rx);
RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
if (cx->sb_iters++) {
- I32 saviters = cx->sb_iters;
+ const I32 saviters = cx->sb_iters;
if (cx->sb_iters > cx->sb_maxiters)
DIE(aTHX_ "Substitution loop");
{
SV *targ = cx->sb_targ;
- if (DO_UTF8(dstr) && !SvUTF8(targ))
- sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
- else
- sv_catpvn(dstr, s, cx->sb_strend - s);
+ assert(cx->sb_strend >= s);
+ if(cx->sb_strend > s) {
+ if (DO_UTF8(dstr) && !SvUTF8(targ))
+ sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
+ else
+ sv_catpvn(dstr, s, cx->sb_strend - s);
+ }
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
#ifdef PERL_COPY_ON_WRITE
} else
#endif
{
- (void)SvOOK_off(targ);
- if (SvLEN(targ))
- Safefree(SvPVX(targ));
+ SvPV_free(targ);
}
- SvPVX(targ) = SvPVX(dstr);
+ SvPV_set(targ, SvPVX(dstr));
SvCUR_set(targ, SvCUR(dstr));
SvLEN_set(targ, SvLEN(dstr));
if (DO_UTF8(dstr))
SvUTF8_on(targ);
- SvPVX(dstr) = 0;
+ SvPV_set(dstr, (char*)0);
sv_free(dstr);
TAINT_IF(cx->sb_rxtainted & 1);
}
cx->sb_m = m = rx->startp[0] + orig;
if (m > s) {
- if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
+ if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
else
sv_catpvn(dstr, s, m-s);
sv_pos_b2u(sv, &i);
mg->mg_len = i;
}
- ReREFCNT_inc(rx);
+ if (old != rx)
+ ReREFCNT_inc(rx);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
rxres_save(&cx->sb_rxres, rx);
RETURNOP(pm->op_pmreplstart);
{
dSP; dMARK; dORIGMARK;
register SV *tmpForm = *++MARK;
- register U16 *fpc;
+ register U32 *fpc;
register char *t;
register char *f;
register char *s;
NV value;
bool gotsome = FALSE;
STRLEN len;
- STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
+ STRLEN fudge = SvPOK(tmpForm)
+ ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
bool item_is_utf8 = FALSE;
bool targ_is_utf8 = FALSE;
SV * nsv = Nullsv;
+ OP * parseres = 0;
+ const char *fmt;
+ bool oneline;
if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
if (SvREADONLY(tmpForm)) {
SvREADONLY_off(tmpForm);
- doparseform(tmpForm);
+ parseres = doparseform(tmpForm);
SvREADONLY_on(tmpForm);
}
else
- doparseform(tmpForm);
+ parseres = doparseform(tmpForm);
+ if (parseres)
+ return parseres;
}
SvPV_force(PL_formtarget, len);
if (DO_UTF8(PL_formtarget))
/* need to jump to the next word */
s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
- fpc = (U16*)s;
+ fpc = (U32*)s;
for (;;) {
DEBUG_f( {
- char *name = "???";
+ const char *name = "???";
arg = -1;
switch (*fpc) {
case FF_LITERAL: arg = fpc[1]; name = "LITERAL"; break;
case FF_MORE: name = "MORE"; break;
case FF_LINEMARK: name = "LINEMARK"; break;
case FF_END: name = "END"; break;
- case FF_0DECIMAL: name = "0DECIMAL"; break;
+ case FF_0DECIMAL: name = "0DECIMAL"; break;
+ case FF_LINESNGL: name = "LINESNGL"; break;
}
if (arg >= 0)
PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
case FF_LITERAL:
arg = *fpc++;
if (targ_is_utf8 && !SvUTF8(tmpForm)) {
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
t = SvEND(PL_formtarget);
break;
}
if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
sv_utf8_upgrade(PL_formtarget);
SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
while (s < send) {
if (*s == '\r') {
itemsize = s - item;
+ chophere = s;
break;
}
if (*s++ & ~31)
while (s < send) {
if (*s == '\r') {
itemsize = s - item;
+ chophere = s;
break;
}
if (*s++ & ~31)
s = item;
if (item_is_utf8) {
if (!targ_is_utf8) {
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
sv_utf8_upgrade(PL_formtarget);
SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
break;
}
if (targ_is_utf8 && !item_is_utf8) {
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
*t = '\0';
sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
for (; t < SvEND(PL_formtarget); t++) {
#ifdef EBCDIC
- int ch = *t++ = *s++;
+ int ch = *t;
if (iscntrl(ch))
#else
if (!(*t & ~31))
s++;
}
sv_chop(sv,s);
+ SvSETMAGIC(sv);
break;
+ case FF_LINESNGL:
+ chopspace = 0;
+ oneline = TRUE;
+ goto ff_line;
case FF_LINEGLOB:
+ oneline = FALSE;
+ ff_line:
item = s = SvPV(sv, len);
itemsize = len;
if ((item_is_utf8 = DO_UTF8(sv)))
- itemsize = sv_len_utf8(sv);
+ itemsize = sv_len_utf8(sv);
if (itemsize) {
bool chopped = FALSE;
gotsome = TRUE;
send = s + len;
+ chophere = s + itemsize;
while (s < send) {
if (*s++ == '\n') {
- if (s == send) {
- itemsize--;
+ if (oneline) {
chopped = TRUE;
+ chophere = s;
+ break;
+ } else {
+ if (s == send) {
+ itemsize--;
+ chopped = TRUE;
+ } else
+ lines++;
}
- else
- lines++;
}
}
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
if (targ_is_utf8)
SvUTF8_on(PL_formtarget);
- sv_catsv(PL_formtarget, sv);
+ if (oneline) {
+ SvCUR_set(sv, chophere - item);
+ sv_catsv(PL_formtarget, sv);
+ SvCUR_set(sv, itemsize);
+ } else
+ sv_catsv(PL_formtarget, sv);
if (chopped)
SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
}
break;
+ case FF_0DECIMAL:
+ arg = *fpc++;
+#if defined(USE_LONG_DOUBLE)
+ fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
+#else
+ fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
+#endif
+ goto ff_dec;
case FF_DECIMAL:
- /* If the field is marked with ^ and the value is undefined,
- blank it out. */
arg = *fpc++;
- if ((arg & 512) && !SvOK(sv)) {
- arg = fieldsize;
- while (arg--)
- *t++ = ' ';
- break;
- }
- gotsome = TRUE;
- value = SvNV(sv);
- /* Formats aren't yet marked for locales, so assume "yes". */
- {
- STORE_NUMERIC_STANDARD_SET_LOCAL();
#if defined(USE_LONG_DOUBLE)
- if (arg & 256) {
- sprintf(t, "%#*.*" PERL_PRIfldbl,
- (int) fieldsize, (int) arg & 255, value);
- } else {
- sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
- }
+ fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
#else
- if (arg & 256) {
- sprintf(t, "%#*.*f",
- (int) fieldsize, (int) arg & 255, value);
- } else {
- sprintf(t, "%*.0f",
- (int) fieldsize, value);
- }
+ fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
#endif
- RESTORE_NUMERIC_STANDARD();
- }
- t += fieldsize;
- break;
-
- case FF_0DECIMAL:
+ ff_dec:
/* If the field is marked with ^ and the value is undefined,
blank it out. */
- arg = *fpc++;
if ((arg & 512) && !SvOK(sv)) {
arg = fieldsize;
while (arg--)
}
gotsome = TRUE;
value = SvNV(sv);
+ /* overflow evidence */
+ if (num_overflow(value, fieldsize, arg)) {
+ arg = fieldsize;
+ while (arg--)
+ *t++ = '#';
+ break;
+ }
/* Formats aren't yet marked for locales, so assume "yes". */
{
STORE_NUMERIC_STANDARD_SET_LOCAL();
-#if defined(USE_LONG_DOUBLE)
- if (arg & 256) {
- sprintf(t, "%#0*.*" PERL_PRIfldbl,
- (int) fieldsize, (int) arg & 255, value);
-/* is this legal? I don't have long doubles */
- } else {
- sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
- }
-#else
- if (arg & 256) {
- sprintf(t, "%#0*.*f",
- (int) fieldsize, (int) arg & 255, value);
- } else {
- sprintf(t, "%0*.0f",
- (int) fieldsize, value);
- }
-#endif
+ sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
RESTORE_NUMERIC_STANDARD();
}
t += fieldsize;
break;
-
+
case FF_NEWLINE:
f++;
while (t-- > linemark && *t == ' ') ;
if (gotsome) {
if (arg) { /* repeat until fields exhausted? */
*t = '\0';
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
lines += FmLINES(PL_formtarget);
if (lines == 200) {
arg = t - linemark;
}
s = t - 3;
if (strnEQ(s," ",3)) {
- while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
+ while (s > SvPVX_const(PL_formtarget) && isSPACE(s[-1]))
s--;
}
*s++ = '.';
case FF_END:
*t = '\0';
- SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
+ SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
if (targ_is_utf8)
SvUTF8_on(PL_formtarget);
FmLINES(PL_formtarget) += lines;
PP(pp_grepstart)
{
- dSP;
+ dVAR; dSP;
SV *src;
if (PL_stack_base + *PL_markstack_ptr == SP) {
ENTER; /* enter outer scope */
SAVETMPS;
- /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
- SAVESPTR(DEFSV);
+ if (PL_op->op_private & OPpGREP_LEX)
+ SAVESPTR(PAD_SVl(PL_op->op_targ));
+ else
+ SAVE_DEFSV;
ENTER; /* enter inner scope */
SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
SvTEMP_off(src);
- DEFSV = src;
+ if (PL_op->op_private & OPpGREP_LEX)
+ PAD_SVl(PL_op->op_targ) = src;
+ else
+ DEFSV = src;
PUTBACK;
if (PL_op->op_type == OP_MAPSTART)
PP(pp_mapwhile)
{
- dSP;
+ dVAR; dSP;
+ const I32 gimme = GIMME_V;
I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
I32 count;
I32 shift;
++PL_markstack_ptr[-1];
/* if there are new items, push them into the destination list */
- if (items) {
+ if (items && gimme != G_VOID) {
/* might need to make room back there first */
if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
/* XXX this implementation is very pessimal because the stack
* irrelevant. --jhi */
if (shift < count)
shift = count; /* Avoid shifting too often --Ben Tilly */
-
+
EXTEND(SP,shift);
src = SP;
dst = (SP += shift);
}
/* copy the new items down to the destination list */
dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
- while (items-- > 0)
- *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
+ if (gimme == G_ARRAY) {
+ while (items-- > 0)
+ *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
+ }
+ else {
+ /* scalar context: we don't care about which values map returns
+ * (we use undef here). And so we certainly don't want to do mortal
+ * copies of meaningless values. */
+ while (items-- > 0) {
+ (void)POPs;
+ *dst-- = &PL_sv_undef;
+ }
+ }
}
LEAVE; /* exit inner scope */
/* All done yet? */
if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
- I32 gimme = GIMME_V;
(void)POPMARK; /* pop top */
LEAVE; /* exit outer scope */
(void)POPMARK; /* pop dst */
SP = PL_stack_base + POPMARK; /* pop original mark */
if (gimme == G_SCALAR) {
- dTARGET;
- XPUSHi(items);
+ 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]];
SvTEMP_off(src);
- DEFSV = src;
+ if (PL_op->op_private & OPpGREP_LEX)
+ PAD_SVl(PL_op->op_targ) = src;
+ else
+ DEFSV = src;
RETURNOP(cLOGOP->op_other);
}
else {
dTOPss;
SV *targ = PAD_SV(PL_op->op_targ);
- int flip = 0;
+ int flip = 0;
- if (PL_op->op_private & OPpFLIP_LINENUM) {
+ if (PL_op->op_private & OPpFLIP_LINENUM) {
if (GvIO(PL_last_in_gv)) {
flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
}
GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
}
- } else {
- flip = SvTRUE(sv);
- }
- if (flip) {
+ } else {
+ flip = SvTRUE(sv);
+ }
+ if (flip) {
sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
if (PL_op->op_flags & OPf_SPECIAL) {
sv_setiv(targ, 1);
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
}
}
- sv_setpv(TARG, "");
+ sv_setpvn(TARG, "", 0);
SETs(targ);
RETURN;
}
}
+/* This code tries to decide if "$left .. $right" should use the
+ magical string increment, or if the range is numeric (we make
+ an exception for .."0" [#18165]). AMS 20021031. */
+
+#define RANGE_IS_NUMERIC(left,right) ( \
+ SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
+ SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
+ (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
+ looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
+ && (!SvOK(right) || looks_like_number(right))))
+
PP(pp_flop)
{
dSP;
if (GIMME == G_ARRAY) {
dPOPPOPssrl;
- register I32 i, j;
+ register IV i, j;
register SV *sv;
- I32 max;
+ IV max;
if (SvGMAGICAL(left))
mg_get(left);
if (SvGMAGICAL(right))
mg_get(right);
- /* This code tries to decide if "$left .. $right" should use the
- magical string increment, or if the range is numeric (we make
- an exception for .."0" [#18165]). AMS 20021031. */
-
- if (SvNIOKp(left) || !SvPOKp(left) ||
- SvNIOKp(right) || !SvPOKp(right) ||
- (looks_like_number(left) && *SvPVX(left) != '0' &&
- looks_like_number(right)))
- {
- if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
+ if (RANGE_IS_NUMERIC(left,right)) {
+ if ((SvOK(left) && SvNV(left) < IV_MIN) ||
+ (SvOK(right) && SvNV(right) > IV_MAX))
DIE(aTHX_ "Range iterator outside integer range");
i = SvIV(left);
max = SvIV(right);
else {
SV *final = sv_mortalcopy(right);
STRLEN len, n_a;
- char *tmps = SvPV(final, len);
+ const char *tmps = SvPV(final, len);
sv = sv_mortalcopy(left);
SvPV_force(sv,n_a);
while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
XPUSHs(sv);
- if (strEQ(SvPVX(sv),tmps))
+ if (strEQ(SvPVX_const(sv),tmps))
break;
sv = sv_2mortal(newSVsv(sv));
sv_inc(sv);
/* Control. */
-static char *context_name[] = {
+static const char * const context_name[] = {
"pseudo-block",
"subroutine",
"eval",
};
STATIC I32
-S_dopoptolabel(pTHX_ char *label)
+S_dopoptolabel(pTHX_ const char *label)
{
register I32 i;
- register PERL_CONTEXT *cx;
for (i = cxstack_ix; i >= 0; i--) {
- cx = &cxstack[i];
+ register const PERL_CONTEXT *cx = &cxstack[i];
switch (CxTYPE(cx)) {
case CXt_SUBST:
case CXt_SUB:
I32
Perl_dowantarray(pTHX)
{
- I32 gimme = block_gimme();
+ const I32 gimme = block_gimme();
return (gimme == G_VOID) ? G_SCALAR : gimme;
}
I32
Perl_block_gimme(pTHX)
{
- I32 cxix;
-
- cxix = dopoptosub(cxstack_ix);
+ const I32 cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
return G_VOID;
I32
Perl_is_lvalue_sub(pTHX)
{
- I32 cxix;
-
- cxix = dopoptosub(cxstack_ix);
+ const I32 cxix = dopoptosub(cxstack_ix);
assert(cxix >= 0); /* We should only be called from inside subs */
if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
{
I32 i;
- register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
- cx = &cxstk[i];
+ register const PERL_CONTEXT *cx = &cxstk[i];
switch (CxTYPE(cx)) {
default:
continue;
S_dopoptoeval(pTHX_ I32 startingblock)
{
I32 i;
- register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
- cx = &cxstack[i];
+ register const PERL_CONTEXT *cx = &cxstack[i];
switch (CxTYPE(cx)) {
default:
continue;
S_dopoptoloop(pTHX_ I32 startingblock)
{
I32 i;
- register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
- cx = &cxstack[i];
+ register const PERL_CONTEXT *cx = &cxstack[i];
switch (CxTYPE(cx)) {
case CXt_SUBST:
case CXt_SUB:
void
Perl_dounwind(pTHX_ I32 cxix)
{
- register PERL_CONTEXT *cx;
I32 optype;
while (cxstack_ix > cxix) {
SV *sv;
- cx = &cxstack[cxstack_ix];
+ register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
(long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
/* Note: we don't need to restore the base context info till the end. */
}
OP *
-Perl_die_where(pTHX_ char *message, STRLEN msglen)
+Perl_die_where(pTHX_ const char *message, STRLEN msglen)
{
+ dVAR;
STRLEN n_a;
- IO *io;
- MAGIC *mg;
if (PL_in_eval) {
I32 cxix;
- register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
if (message) {
if (PL_in_eval & EVAL_KEEPERR) {
- static char prefix[] = "\t(in cleanup) ";
+ static const char prefix[] = "\t(in cleanup) ";
SV *err = ERRSV;
- char *e = Nullch;
+ const char *e = Nullch;
if (!SvPOK(err))
- sv_setpv(err,"");
+ sv_setpvn(err,"",0);
else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
e = SvPV(err, n_a);
e += n_a - msglen;
sv_catpvn(err, prefix, sizeof(prefix)-1);
sv_catpvn(err, message, msglen);
if (ckWARN(WARN_MISC)) {
- STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
- Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
+ const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
+ Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
}
}
}
if (cxix >= 0) {
I32 optype;
+ register PERL_CONTEXT *cx;
if (cxix < cxstack_ix)
dounwind(cxix);
PL_curcop = cx->blk_oldcop;
if (optype == OP_REQUIRE) {
- char* msg = SvPVx(ERRSV, n_a);
+ const char* msg = SvPVx(ERRSV, n_a);
+ SV *nsv = cx->blk_eval.old_namesv;
+ (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
+ &PL_sv_undef, 0);
DIE(aTHX_ "%sCompilation failed in require",
*msg ? msg : "Unknown error\n");
}
- return pop_return();
+ assert(CxTYPE(cx) == CXt_EVAL);
+ return cx->blk_eval.retop;
}
}
if (!message)
message = SvPVx(ERRSV, msglen);
- /* if STDERR is tied, print to it instead */
- if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
- && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
- dSP; ENTER;
- PUSHMARK(SP);
- XPUSHs(SvTIED_obj((SV*)io, mg));
- XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
- PUTBACK;
- call_method("PRINT", G_SCALAR);
- LEAVE;
- }
- else {
-#ifdef USE_SFIO
- /* SFIO can really mess with your errno */
- int e = errno;
-#endif
- PerlIO *serr = Perl_error_log;
-
- PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
- (void)PerlIO_flush(serr);
-#ifdef USE_SFIO
- errno = e;
-#endif
- }
+ write_to_stderr(message, msglen);
my_failure_exit();
/* NOTREACHED */
return 0;
register PERL_CONTEXT *cx;
register PERL_CONTEXT *ccstack = cxstack;
PERL_SI *top_si = PL_curstackinfo;
- I32 dbcxix;
I32 gimme;
- char *stashname;
- SV *sv;
+ const char *stashname;
I32 count = 0;
if (MAXARG)
}
RETURN;
}
- if (PL_DBsub && cxix >= 0 &&
+ /* caller() should not report the automatic calls to &DB::sub */
+ if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
count++;
if (!count--)
cx = &ccstack[cxix];
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- dbcxix = dopoptosub_at(ccstack, cxix - 1);
+ const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
field below is defined for any cx. */
- if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
+ /* caller() should not report the automatic calls to &DB::sub */
+ if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
cx = &ccstack[dbcxix];
}
GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
/* So is ccstack[dbcxix]. */
if (isGV(cvgv)) {
- sv = NEWSV(49, 0);
+ SV * const sv = NEWSV(49, 0);
gv_efullname3(sv, cvgv, Nullch);
PUSHs(sv_2mortal(sv));
PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
&& CopSTASH_eq(PL_curcop, PL_debstash))
{
AV *ary = cx->blk_sub.argarray;
- int off = AvARRAY(ary) - AvALLOC(ary);
+ const int off = AvARRAY(ary) - AvALLOC(ary);
if (!PL_dbargs) {
GV* tmpgv;
PP(pp_reset)
{
dSP;
- char *tmps;
+ const char *tmps;
STRLEN n_a;
if (MAXARG < 1)
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;
dSP;
register CV *cv;
register PERL_CONTEXT *cx;
- I32 gimme = G_ARRAY;
+ const I32 gimme = G_ARRAY;
U8 hasargs;
GV *gv;
hasargs = 0;
SPAGAIN;
- push_return(PL_op->op_next);
PUSHBLOCK(cx, CXt_SUB, SP);
PUSHSUB_DB(cx);
+ cx->blk_sub.retop = PL_op->op_next;
CvDEPTH(cv)++;
- (void)SvREFCNT_inc(cv);
PAD_SET_CUR(CvPADLIST(cv),1);
RETURNOP(CvSTART(cv));
}
PP(pp_enteriter)
{
- dSP; dMARK;
+ dVAR; dSP; dMARK;
register PERL_CONTEXT *cx;
- I32 gimme = GIMME_V;
+ const I32 gimme = GIMME_V;
SV **svp;
U32 cxtype = CXt_LOOP;
#ifdef USE_ITHREADS
SAVETMPS;
if (PL_op->op_targ) {
+ 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);
+ }
#ifndef USE_ITHREADS
svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
SAVESPTR(*svp);
cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
dPOPss;
- /* See comment in pp_flop() */
- if (SvNIOKp(sv) || !SvPOKp(sv) ||
- SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
- (looks_like_number(sv) && *SvPVX(sv) != '0' &&
- looks_like_number((SV*)cx->blk_loop.iterary)))
- {
- if (SvNV(sv) < IV_MIN ||
- SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
- DIE(aTHX_ "Range iterator outside integer range");
- cx->blk_loop.iterix = SvIV(sv);
- cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
+ SV *right = (SV*)cx->blk_loop.iterary;
+ if (RANGE_IS_NUMERIC(sv,right)) {
+ if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
+ (SvOK(right) && SvNV(right) >= IV_MAX))
+ DIE(aTHX_ "Range iterator outside integer range");
+ cx->blk_loop.iterix = SvIV(sv);
+ cx->blk_loop.itermax = SvIV(right);
}
- else
+ else {
+ STRLEN n_a;
cx->blk_loop.iterlval = newSVsv(sv);
+ (void) SvPV_force(cx->blk_loop.iterlval,n_a);
+ (void) SvPV(right,n_a);
+ }
+ }
+ else if (PL_op->op_private & OPpITER_REVERSED) {
+ cx->blk_loop.itermax = -1;
+ cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
+
}
}
else {
cx->blk_loop.iterary = PL_curstack;
AvFILLp(PL_curstack) = SP - PL_stack_base;
- cx->blk_loop.iterix = MARK - PL_stack_base;
+ if (PL_op->op_private & OPpITER_REVERSED) {
+ cx->blk_loop.itermax = MARK - PL_stack_base;
+ cx->blk_loop.iterix = cx->blk_oldsp;
+ }
+ else {
+ cx->blk_loop.iterix = MARK - PL_stack_base;
+ }
}
RETURN;
PP(pp_enterloop)
{
- dSP;
+ dVAR; dSP;
register PERL_CONTEXT *cx;
- I32 gimme = GIMME_V;
+ const I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
PP(pp_leaveloop)
{
- dSP;
+ dVAR; dSP;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
SV **mark;
POPBLOCK(cx,newpm);
+ assert(CxTYPE(cx) == CXt_LOOP);
mark = newsp;
newsp = PL_stack_base + cx->blk_loop.resetsp;
PP(pp_return)
{
- dSP; dMARK;
+ dVAR; dSP; dMARK;
I32 cxix;
register PERL_CONTEXT *cx;
bool popsub2 = FALSE;
PMOP *newpm;
I32 optype = 0;
SV *sv;
+ OP *retop;
if (PL_curstackinfo->si_type == PERLSI_SORT) {
if (cxstack_ix == PL_sortcxix
switch (CxTYPE(cx)) {
case CXt_SUB:
popsub2 = TRUE;
+ 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);
+ retop = cx->blk_eval.retop;
if (CxTRYBLOCK(cx))
break;
lex_end();
{
/* Unassume the success we assumed earlier. */
SV *nsv = cx->blk_eval.old_namesv;
- (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
+ (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
DIE(aTHX_ "%"SVf" did not return a true value", nsv);
}
break;
case CXt_FORMAT:
POPFORMAT(cx);
+ retop = cx->blk_sub.retop;
break;
default:
DIE(aTHX_ "panic: return");
LEAVE;
/* Stack values are safe: */
if (popsub2) {
+ cxstack_ix--;
POPSUB(cx,sv); /* release CV and @_ ... */
}
else
LEAVESUB(sv);
if (clear_errsv)
- sv_setpv(ERRSV,"");
- return pop_return();
+ sv_setpvn(ERRSV,"",0);
+ return retop;
}
PP(pp_last)
{
- dSP;
+ dVAR; dSP;
I32 cxix;
register PERL_CONTEXT *cx;
I32 pop2 = 0;
dounwind(cxix);
POPBLOCK(cx,newpm);
+ cxstack_ix++; /* temporarily protect top context */
mark = newsp;
switch (CxTYPE(cx)) {
case CXt_LOOP:
break;
case CXt_SUB:
pop2 = CXt_SUB;
- nextop = pop_return();
+ nextop = cx->blk_sub.retop;
break;
case CXt_EVAL:
POPEVAL(cx);
- nextop = pop_return();
+ nextop = cx->blk_eval.retop;
break;
case CXt_FORMAT:
POPFORMAT(cx);
- nextop = pop_return();
+ nextop = cx->blk_sub.retop;
break;
default:
DIE(aTHX_ "panic: last");
PUTBACK;
LEAVE;
+ cxstack_ix--;
/* Stack values are safe: */
switch (pop2) {
case CXt_LOOP:
PP(pp_next)
{
+ dVAR;
I32 cxix;
register PERL_CONTEXT *cx;
I32 inner;
TOPBLOCK(cx);
if (PL_scopestack_ix < inner)
leave_scope(PL_scopestack[PL_scopestack_ix]);
+ PL_curcop = cx->blk_oldcop;
return cx->blk_loop.next_op;
}
PP(pp_redo)
{
+ dVAR;
I32 cxix;
register PERL_CONTEXT *cx;
I32 oldsave;
+ OP* redo_op;
if (PL_op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
if (cxix < cxstack_ix)
dounwind(cxix);
+ redo_op = cxstack[cxix].blk_loop.redo_op;
+ if (redo_op->op_type == OP_ENTER) {
+ /* pop one less context to avoid $x being freed in while (my $x..) */
+ cxstack_ix++;
+ assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
+ redo_op = redo_op->op_next;
+ }
+
TOPBLOCK(cx);
oldsave = PL_scopestack[PL_scopestack_ix - 1];
LEAVE_SCOPE(oldsave);
- return cx->blk_loop.redo_op;
+ FREETMPS;
+ PL_curcop = cx->blk_oldcop;
+ return redo_op;
}
STATIC OP *
-S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
+S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
{
OP *kid = Nullop;
OP **ops = opstack;
- static char too_deep[] = "Target of goto is too deeply nested";
+ static const char too_deep[] = "Target of goto is too deeply nested";
if (ops >= oplimit)
Perl_croak(aTHX_ too_deep);
PP(pp_goto)
{
- dSP;
+ dVAR; dSP;
OP *retop = 0;
I32 ix;
register PERL_CONTEXT *cx;
#define GOTO_DEPTH 64
OP *enterops[GOTO_DEPTH];
- char *label;
- int do_dump = (PL_op->op_type == OP_DUMP);
- static char must_have_label[] = "goto must have label";
+ const char *label = 0;
+ const bool do_dump = (PL_op->op_type == OP_DUMP);
+ static const char must_have_label[] = "goto must have label";
- label = 0;
if (PL_op->op_flags & OPf_STACKED) {
SV *sv = POPs;
STRLEN n_a;
SV** mark;
I32 items = 0;
I32 oldsave;
+ bool reified = 0;
retry:
if (!CvROOT(cv) && !CvXSUB(cv)) {
- GV *gv = CvGV(cv);
- GV *autogv;
+ const GV * const gv = CvGV(cv);
if (gv) {
+ GV *autogv;
SV *tmpstr;
/* autoloaded stub? */
if (cv != GvCV(gv) && (cv = GvCV(gv)))
}
/* First do some returnish stuff. */
- SvREFCNT_inc(cv); /* avoid premature free during unwind */
+ (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
FREETMPS;
cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
if (cxix < cxstack_ix)
dounwind(cxix);
TOPBLOCK(cx);
- if (CxREALEVAL(cx))
- DIE(aTHX_ "Can't goto subroutine from an eval-string");
- mark = PL_stack_sp;
+ SPAGAIN;
+ if (CxTYPE(cx) == CXt_EVAL) {
+ if (CxREALEVAL(cx))
+ DIE(aTHX_ "Can't goto subroutine from an eval-string");
+ else
+ DIE(aTHX_ "Can't goto subroutine from an eval-block");
+ }
if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
/* put @_ back onto stack */
AV* av = cx->blk_sub.argarray;
-
+
items = AvFILLp(av) + 1;
- PL_stack_sp++;
- EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
- Copy(AvARRAY(av), PL_stack_sp, items, SV*);
- PL_stack_sp += items;
+ EXTEND(SP, items+1); /* @_ could have been extended. */
+ Copy(AvARRAY(av), SP + 1, items, SV*);
SvREFCNT_dec(GvAV(PL_defgv));
GvAV(PL_defgv) = cx->blk_sub.savearray;
+ CLEAR_ARGARRAY(av);
/* abandon @_ if it got reified */
if (AvREAL(av)) {
- (void)sv_2mortal((SV*)av); /* delay until return */
+ reified = 1;
+ SvREFCNT_dec(av);
av = newAV();
av_extend(av, items-1);
- AvFLAGS(av) = AVf_REIFY;
+ AvREIFY_only(av);
PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
}
- else
- CLEAR_ARGARRAY(av);
}
else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */
AV* av;
av = GvAV(PL_defgv);
items = AvFILLp(av) + 1;
- PL_stack_sp++;
- EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
- Copy(AvARRAY(av), PL_stack_sp, items, SV*);
- PL_stack_sp += items;
+ EXTEND(SP, items+1); /* @_ could have been extended. */
+ Copy(AvARRAY(av), SP + 1, items, SV*);
}
+ mark = SP;
+ SP += items;
if (CxTYPE(cx) == CXt_SUB &&
!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
SvREFCNT_dec(cx->blk_sub.cv);
SAVETMPS;
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
if (CvXSUB(cv)) {
+ OP* retop = cx->blk_sub.retop;
+ if (reified) {
+ I32 index;
+ for (index=0; index<items; index++)
+ sv_2mortal(SP[-index]);
+ }
#ifdef PERL_XSUB_OLDSTYLE
if (CvOLDSTYLE(cv)) {
I32 (*fp3)(int,int,int);
SV **newsp;
I32 gimme;
- PL_stack_sp--; /* There is no cv arg. */
+ /* XS subs don't have a CxSUB, so pop it */
+ POPBLOCK(cx, PL_curpm);
/* Push a mark for the start of arglist */
PUSHMARK(mark);
+ PUTBACK;
(void)(*CvXSUB(cv))(aTHX_ cv);
- /* Pop the current context like a decent sub should */
- POPBLOCK(cx, PL_curpm);
- /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
}
LEAVE;
- return pop_return();
+ return retop;
}
else {
AV* padlist = CvPADLIST(cv);
else {
if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
sub_crush_depth(cv);
- pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
+ pad_push(padlist, CvDEPTH(cv));
}
PAD_SET_CUR(padlist, CvDEPTH(cv));
if (cx->blk_sub.hasargs)
GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
- ++mark;
if (items >= AvMAX(av) + 1) {
ary = AvALLOC(av);
if (AvARRAY(av) != ary) {
AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- SvPVX(av) = (char*)ary;
+ SvPV_set(av, (char*)ary);
}
if (items >= AvMAX(av) + 1) {
AvMAX(av) = items - 1;
Renew(ary,items+1,SV*);
AvALLOC(av) = ary;
- SvPVX(av) = (char*)ary;
+ SvPV_set(av, (char*)ary);
}
}
+ ++mark;
Copy(mark,AvARRAY(av),items,SV*);
AvFILLp(av) = items - 1;
assert(!AvREAL(av));
+ if (reified) {
+ /* transfer 'ownership' of refcnts to new @_ */
+ AvREAL_on(av);
+ AvREIFY_off(av);
+ }
while (items--) {
if (*mark)
SvTEMP_off(*mark);
*/
SV *sv = GvSV(PL_DBsub);
CV *gotocv;
-
+
+ save_item(sv);
if (PERLDB_SUB_NN) {
- SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
+ int type = SvTYPE(sv);
+ if (type < SVt_PVIV && type != SVt_IV)
+ sv_upgrade(sv, SVt_PVIV);
+ (void)SvIOK_on(sv);
+ SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
} else {
- save_item(sv);
gv_efullname3(sv, CvGV(cv), Nullch);
}
if ( PERLDB_GOTO
PP(pp_nswitch)
{
dSP;
- NV value = SvNVx(GvSV(cCOP->cop_gv));
+ const NV value = SvNVx(GvSV(cCOP->cop_gv));
register I32 match = I_32(value);
if (value < 0.0) {
STATIC void
S_save_lines(pTHX_ AV *array, SV *sv)
{
- register char *s = SvPVX(sv);
- register char *send = SvPVX(sv) + SvCUR(sv);
- register char *t;
- register I32 line = 1;
+ const char *s = SvPVX_const(sv);
+ const char *send = SvPVX_const(sv) + SvCUR(sv);
+ I32 line = 1;
while (s && s < send) {
+ const char *t;
SV *tmpstr = NEWSV(85,0);
sv_upgrade(tmpstr, SVt_PVMG);
}
}
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-S_docatch_body(pTHX_ va_list args)
-{
- return docatch_body();
-}
-#endif
-
STATIC void *
S_docatch_body(pTHX)
{
S_docatch(pTHX_ OP *o)
{
int ret;
- OP *oldop = PL_op;
- OP *retop;
- volatile PERL_SI *cursi = PL_curstackinfo;
+ OP * const oldop = PL_op;
dJMPENV;
#ifdef DEBUGGING
#endif
PL_op = o;
- /* Normally, the leavetry at the end of this block of ops will
- * pop an op off the return stack and continue there. By setting
- * the op to Nullop, we force an exit from the inner runops()
- * loop. DAPM.
- */
- retop = pop_return();
- push_return(Nullop);
-
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- redo_body:
- CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
-#else
JMPENV_PUSH(ret);
-#endif
switch (ret) {
case 0:
-#ifndef PERL_FLEXIBLE_EXCEPTIONS
+ assert(cxstack_ix >= 0);
+ assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
+ cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
redo_body:
docatch_body();
-#endif
break;
case 3:
/* die caught by an inner eval - continue inner loop */
- if (PL_restartop && cursi == PL_curstackinfo) {
+
+ /* NB XXX we rely on the old popped CxEVAL still being at the top
+ * of the stack; the way die_where() currently works, this
+ * assumption is valid. In theory The cur_top_env value should be
+ * returned in another global, the way retop (aka PL_restartop)
+ * is. */
+ assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
+
+ if (PL_restartop
+ && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
+ {
PL_op = PL_restartop;
PL_restartop = 0;
goto redo_body;
}
- /* a die in this eval - continue in outer loop */
- if (!PL_restartop)
- break;
/* FALL THROUGH */
default:
JMPENV_POP;
}
JMPENV_POP;
PL_op = oldop;
- return retop;
+ return Nullop;
}
OP *
-Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
+Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
/* sv Text to convert to OP tree. */
/* startop op_free() this to undo. */
/* code Short string id of the caller. */
{
- dSP; /* Make POPBLOCK work. */
+ dVAR; dSP; /* Make POPBLOCK work. */
PERL_CONTEXT *cx;
SV **newsp;
I32 gimme = 0; /* SUSPECT - INITIALZE TO WHAT? NI-S */
SAVETMPS;
/* switch to eval mode */
- if (PL_curcop == &PL_compiling) {
+ if (IN_PERL_COMPILETIME) {
SAVECOPSTASH_FREE(&PL_compiling);
CopSTASH_set(&PL_compiling, PL_curstash);
}
#else
SAVEVPTR(PL_op);
#endif
- PL_hints &= HINT_UTF8;
/* we get here either during compilation, or via pp_regcomp at runtime */
- runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
+ runtime = IN_PERL_RUNTIME;
if (runtime)
runcv = find_runcv(NULL);
PL_op = &dummy;
PL_op->op_type = OP_ENTEREVAL;
PL_op->op_flags = 0; /* Avoid uninit warning. */
- PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
+ PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
PUSHEVAL(cx, 0, Nullgv);
if (runtime)
/* XXX DAPM do this properly one year */
*padp = (AV*)SvREFCNT_inc(PL_comppad);
LEAVE;
- if (PL_curcop == &PL_compiling)
+ if (IN_PERL_COMPILETIME)
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
#ifdef OP_IN_REGISTER
op = PL_opsave;
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 in the scope of the debuger itself).
+than in in the scope of the debugger itself).
=cut
*/
CV*
Perl_find_runcv(pTHX_ U32 *db_seqp)
{
- I32 ix;
PERL_SI *si;
- PERL_CONTEXT *cx;
if (db_seqp)
*db_seqp = PL_curcop->cop_seq;
for (si = PL_curstackinfo; si; si = si->si_prev) {
+ I32 ix;
for (ix = si->si_cxix; ix >= 0; ix--) {
- cx = &(si->si_cxstack[ix]);
+ const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
CV *cv = cx->blk_sub.cv;
/* skip DB:: code */
STATIC OP *
S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
{
- dSP;
+ dVAR; dSP;
OP *saveop = PL_op;
PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
if (saveop && saveop->op_flags & OPf_SPECIAL)
PL_in_eval |= EVAL_KEEPERR;
else
- sv_setpv(ERRSV,"");
+ sv_setpvn(ERRSV,"",0);
if (yyparse() || PL_error_count || !PL_eval_root) {
- SV **newsp;
- I32 gimme;
- PERL_CONTEXT *cx;
+ SV **newsp; /* Used by POPBLOCK. */
+ PERL_CONTEXT *cx = &cxstack[cxstack_ix];
I32 optype = 0; /* Might be reset by POPEVAL. */
STRLEN n_a;
-
+
PL_op = saveop;
if (PL_eval_root) {
op_free(PL_eval_root);
if (!startop) {
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
- pop_return();
}
lex_end();
LEAVE;
if (optype == OP_REQUIRE) {
- char* msg = SvPVx(ERRSV, n_a);
+ const char* msg = SvPVx(ERRSV, n_a);
+ SV *nsv = cx->blk_eval.old_namesv;
+ (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
+ &PL_sv_undef, 0);
DIE(aTHX_ "%sCompilation failed in require",
*msg ? msg : "Unknown error\n");
}
else if (startop) {
- char* msg = SvPVx(ERRSV, n_a);
+ const char* msg = SvPVx(ERRSV, n_a);
POPBLOCK(cx,PL_curpm);
POPEVAL(cx);
(*msg ? msg : "Unknown error\n"));
}
else {
- char* msg = SvPVx(ERRSV, n_a);
+ const char* msg = SvPVx(ERRSV, n_a);
if (!*msg) {
sv_setpv(ERRSV, "Compilation error");
}
*startop = PL_eval_root;
} else
SAVEFREEOP(PL_eval_root);
- if (gimme & G_VOID)
+
+ /* Set the context for this new optree.
+ * If the last op is an OP_REQUIRE, force scalar context.
+ * Otherwise, propagate the context from the eval(). */
+ if (PL_eval_root->op_type == OP_LEAVEEVAL
+ && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
+ && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
+ == OP_REQUIRE)
+ scalar(PL_eval_root);
+ else if (gimme & G_VOID)
scalarvoid(PL_eval_root);
else if (gimme & G_ARRAY)
list(PL_eval_root);
S_doopen_pm(pTHX_ const char *name, const char *mode)
{
#ifndef PERL_DISABLE_PMC
- STRLEN namelen = strlen(name);
+ const STRLEN namelen = strlen(name);
PerlIO *fp;
if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
- char *pmc = SvPV_nolen(pmcsv);
+ const char * const pmc = SvPV_nolen(pmcsv);
Stat_t pmstat;
Stat_t pmcstat;
if (PerlLIO_stat(pmc, &pmcstat) < 0) {
PP(pp_require)
{
- dSP;
+ dVAR; dSP;
register PERL_CONTEXT *cx;
SV *sv;
char *name;
char *tryname = Nullch;
SV *namesv = Nullsv;
SV** svp;
- I32 gimme = GIMME_V;
+ const I32 gimme = GIMME_V;
PerlIO *tryrsfp = 0;
- STRLEN n_a;
int filter_has_file = 0;
GV *filter_child_proc = 0;
SV *filter_state = 0;
OP *op;
sv = POPs;
- if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
- if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
- UV rev = 0, ver = 0, sver = 0;
- STRLEN len;
- U8 *s = (U8*)SvPVX(sv);
- U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
- if (s < end) {
- rev = utf8n_to_uvchr(s, end - s, &len, 0);
- s += len;
- if (s < end) {
- ver = utf8n_to_uvchr(s, end - s, &len, 0);
- s += len;
- if (s < end)
- sver = utf8n_to_uvchr(s, end - s, &len, 0);
- }
- }
- if (PERL_REVISION < rev
- || (PERL_REVISION == rev
- && (PERL_VERSION < ver
- || (PERL_VERSION == ver
- && PERL_SUBVERSION < sver))))
- {
- DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
- "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
- PERL_VERSION, PERL_SUBVERSION);
- }
- if (ckWARN(WARN_PORTABLE))
+ if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
+ if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) /* require v5.6.1 */
Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
"v-string in use/require non-portable");
+
+ sv = new_version(sv);
+ if (!sv_derived_from(PL_patchlevel, "version"))
+ (void *)upg_version(PL_patchlevel);
+ if ( vcmp(sv,PL_patchlevel) > 0 )
+ DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
+ vstringify(sv), vstringify(PL_patchlevel));
+
RETPUSHYES;
- }
- else if (!SvPOKp(sv)) { /* require 5.005_03 */
- if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
- + ((NV)PERL_SUBVERSION/(NV)1000000)
- + 0.00000099 < SvNV(sv))
- {
- NV nrev = SvNV(sv);
- UV rev = (UV)nrev;
- NV nver = (nrev - rev) * 1000;
- UV ver = (UV)(nver + 0.0009);
- NV nsver = (nver - ver) * 1000;
- UV sver = (UV)(nsver + 0.0009);
-
- /* help out with the "use 5.6" confusion */
- if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
- DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
- " (did you mean v%"UVuf".%03"UVuf"?)--"
- "this is only v%d.%d.%d, stopped",
- rev, ver, sver, rev, ver/100,
- PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
- }
- else {
- DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
- "this is only v%d.%d.%d, stopped",
- rev, ver, sver, PERL_REVISION, PERL_VERSION,
- PERL_SUBVERSION);
- }
- }
- RETPUSHYES;
- }
}
name = SvPV(sv, len);
if (!(name && len > 0 && *name))
DIE(aTHX_ "Null filename used");
TAINT_PROPER("require");
if (PL_op->op_type == OP_REQUIRE &&
- (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
- *svp != &PL_sv_undef)
- RETPUSHYES;
+ (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
+ if (*svp != &PL_sv_undef)
+ RETPUSHYES;
+ else
+ DIE(aTHX_ "Compilation failed in require");
+ }
/* prepare to compile file */
PERL_SCRIPT_MODE);
}
}
+ SP--;
}
PUTBACK;
|| (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
#endif
) {
+ STRLEN n_a;
char *dir = SvPVx(dirsv, n_a);
#ifdef MACOS_TRADITIONAL
char buf1[256];
MacPerl_CanonDir(name, buf2, 1);
Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
#else
-#ifdef VMS
+# ifdef VMS
char *unixdir;
if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
continue;
sv_setpv(namesv, unixdir);
sv_catpv(namesv, unixname);
-#else
+# else
+# ifdef SYMBIAN
+ if (PL_origfilename[0] &&
+ PL_origfilename[1] == ':' &&
+ !(dir[0] && dir[1] == ':'))
+ Perl_sv_setpvf(aTHX_ namesv,
+ "%c:%s\\%s",
+ PL_origfilename[0],
+ dir, name);
+ else
+ Perl_sv_setpvf(aTHX_ namesv,
+ "%s\\%s",
+ dir, name);
+# else
Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
-#endif
+# endif
+# endif
#endif
TAINT_PROPER("require");
tryname = SvPVX(namesv);
AV *ar = GvAVn(PL_incgv);
I32 i;
sv_catpvn(msg, " in @INC", 8);
- if (instr(SvPVX(msg), ".h "))
+ if (instr(SvPVX_const(msg), ".h "))
sv_catpv(msg, " (change .h to .ph maybe?)");
- if (instr(SvPVX(msg), ".ph "))
+ if (instr(SvPVX_const(msg), ".ph "))
sv_catpv(msg, " (did you run h2ph?)");
sv_catpv(msg, " (@INC contains:");
for (i = 0; i <= AvFILL(ar); i++) {
- char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
+ STRLEN n_a;
+ const char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
sv_catsv(msg, dirmsgsv);
}
}
/* switch to eval mode */
- push_return(PL_op->op_next);
PUSHBLOCK(cx, CXt_EVAL, SP);
PUSHEVAL(cx, name, Nullgv);
+ cx->blk_eval.retop = PL_op->op_next;
SAVECOPLINE(&PL_compiling);
CopLINE_set(&PL_compiling, 0);
PL_encoding = Nullsv;
op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
-
+
/* Restore encoding. */
PL_encoding = encoding;
PP(pp_entereval)
{
- dSP;
+ dVAR; dSP;
register PERL_CONTEXT *cx;
dPOPss;
- I32 gimme = GIMME_V, was = PL_sub_generation;
+ const I32 gimme = GIMME_V, was = PL_sub_generation;
char tbuf[TYPE_DIGITS(long) + 12];
char *tmpbuf = tbuf;
char *safestr;
* to do the dirty work for us */
runcv = find_runcv(&seq);
- push_return(PL_op->op_next);
PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
PUSHEVAL(cx, 0, Nullgv);
+ cx->blk_eval.retop = PL_op->op_next;
/* prepare to compile string */
PP(pp_leaveeval)
{
- dSP;
+ dVAR; dSP;
register SV **mark;
SV **newsp;
PMOP *newpm;
I32 gimme;
register PERL_CONTEXT *cx;
OP *retop;
- U8 save_flags = PL_op -> op_flags;
+ const U8 save_flags = PL_op -> op_flags;
I32 optype;
POPBLOCK(cx,newpm);
POPEVAL(cx);
- retop = pop_return();
+ retop = cx->blk_eval.retop;
TAINT_NOT;
if (gimme == G_VOID)
{
/* Unassume the success we assumed earlier. */
SV *nsv = cx->blk_eval.old_namesv;
- (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
+ (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
/* die_where() did LEAVE, or we won't be here */
}
else {
LEAVE;
if (!(save_flags & OPf_SPECIAL))
- sv_setpv(ERRSV,"");
+ sv_setpvn(ERRSV,"",0);
}
RETURNOP(retop);
PP(pp_entertry)
{
- dSP;
+ dVAR; dSP;
register PERL_CONTEXT *cx;
- I32 gimme = GIMME_V;
+ const I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
- push_return(cLOGOP->op_other->op_next);
PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
PUSHEVAL(cx, 0, 0);
+ cx->blk_eval.retop = cLOGOP->op_other->op_next;
PL_in_eval = EVAL_INEVAL;
- sv_setpv(ERRSV,"");
+ sv_setpvn(ERRSV,"",0);
PUTBACK;
return DOCATCH(PL_op->op_next);
}
PP(pp_leavetry)
{
- dSP;
+ dVAR; dSP;
register SV **mark;
SV **newsp;
PMOP *newpm;
- OP* retop;
I32 gimme;
register PERL_CONTEXT *cx;
I32 optype;
POPBLOCK(cx,newpm);
POPEVAL(cx);
- retop = pop_return();
TAINT_NOT;
if (gimme == G_VOID)
PL_curpm = newpm; /* Don't pop $1 et al till now */
LEAVE;
- sv_setpv(ERRSV,"");
- RETURNOP(retop);
+ sv_setpvn(ERRSV,"",0);
+ RETURN;
}
-STATIC void
+STATIC OP *
S_doparseform(pTHX_ SV *sv)
{
STRLEN len;
bool noblank = FALSE;
bool repeat = FALSE;
bool postspace = FALSE;
- U16 *fops;
- register U16 *fpc;
- U16 *linepc = 0;
+ U32 *fops;
+ register U32 *fpc;
+ U32 *linepc = 0;
register I32 arg;
bool ischop;
- int maxops = 2; /* FF_LINEMARK + FF_END) */
+ bool unchopnum = FALSE;
+ int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
if (len == 0)
Perl_croak(aTHX_ "Null picture in formline");
s = base;
base = Nullch;
- New(804, fops, maxops, U16);
+ New(804, fops, maxops, U32);
fpc = fops;
if (s < send) {
case ' ': case '\t':
skipspaces++;
continue;
-
- case '\n': case 0:
+ case 0:
+ if (s < send) {
+ skipspaces = 0;
+ continue;
+ } /* else FALL THROUGH */
+ case '\n':
arg = s - base;
skipspaces++;
arg -= skipspaces;
*fpc++ = FF_FETCH;
if (*s == '*') {
s++;
- *fpc++ = 0;
- *fpc++ = FF_LINEGLOB;
+ *fpc++ = 2; /* skip the @* or ^* */
+ if (ischop) {
+ *fpc++ = FF_LINESNGL;
+ *fpc++ = FF_CHOP;
+ } else
+ *fpc++ = FF_LINEGLOB;
}
else if (*s == '#' || (*s == '.' && s[1] == '#')) {
arg = ischop ? 512 : 0;
while (*s == '#')
s++;
if (*s == '.') {
- char *f;
- s++;
- f = s;
+ const char * const f = ++s;
while (*s == '#')
s++;
arg |= 256 + (s - f);
*fpc++ = s - base; /* fieldsize for FETCH */
*fpc++ = FF_DECIMAL;
*fpc++ = (U16)arg;
+ unchopnum |= ! ischop;
}
else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
arg = ischop ? 512 : 0;
while (*s == '#')
s++;
if (*s == '.') {
- char *f;
- s++;
- f = s;
+ const char * const f = ++s;
while (*s == '#')
s++;
arg |= 256 + (s - f);
*fpc++ = s - base; /* fieldsize for FETCH */
*fpc++ = FF_0DECIMAL;
*fpc++ = (U16)arg;
+ unchopnum |= ! ischop;
}
else {
I32 prespace = 0;
{ /* need to jump to the next word */
int z;
z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
- SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
+ SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
s = SvPVX(sv) + SvCUR(sv) + z;
}
- Copy(fops, s, arg, U16);
+ Copy(fops, s, arg, U32);
Safefree(fops);
sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
SvCOMPILED_on(sv);
+
+ if (unchopnum && repeat)
+ DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
+ return 0;
+}
+
+
+STATIC bool
+S_num_overflow(NV value, I32 fldsize, I32 frcsize)
+{
+ /* Can value be printed in fldsize chars, using %*.*f ? */
+ NV pwr = 1;
+ NV eps = 0.5;
+ bool res = FALSE;
+ int intsize = fldsize - (value < 0 ? 1 : 0);
+
+ if (frcsize & 256)
+ intsize--;
+ frcsize &= 255;
+ intsize -= frcsize;
+
+ while (intsize--) pwr *= 10.0;
+ while (frcsize--) eps /= 10.0;
+
+ if( value >= 0 ){
+ if (value + eps >= pwr)
+ res = TRUE;
+ } else {
+ if (value - eps <= -pwr)
+ res = TRUE;
+ }
+ return res;
}
static I32
run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
{
+ dVAR;
SV *datasv = FILTER_DATA(idx);
- int filter_has_file = IoLINES(datasv);
+ const int filter_has_file = IoLINES(datasv);
GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
SV *filter_state = (SV *)IoTOP_GV(datasv);
SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
/* perhaps someone can come up with a better name for
this? it is not really "absolute", per se ... */
static bool
-S_path_is_absolute(pTHX_ char *name)
+S_path_is_absolute(pTHX_ const char *name)
{
if (PERL_FILE_IS_ABSOLUTE(name)
#ifdef MACOS_TRADITIONAL
else
return FALSE;
}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */