X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9d7f88ddd9ec1f324b7625b5481fe9d2002a2554..c630fe624c165b4be52d3bdfb4d8e719da52a022:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index a43e629..c4aa30e 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,6 +1,7 @@ /* pp_ctl.c * - * Copyright (c) 1991-2002, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 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. @@ -16,12 +17,23 @@ * 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)) @@ -58,6 +70,7 @@ PP(pp_regcreset) /* 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; } @@ -69,14 +82,41 @@ PP(pp_regcomp) 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); @@ -97,7 +137,7 @@ PP(pp_regcomp) memNE(PM_GETRE(pm)->precomp, t, len)) { if (PM_GETRE(pm)) { - ReREFCNT_dec(PM_GETRE(pm)); + ReREFCNT_dec(PM_GETRE(pm)); PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */ } if (PL_op->op_flags & OPf_SPECIAL) @@ -156,9 +196,16 @@ PP(pp_substcont) register char *m = cx->sb_m; 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); + PM_SETRE(pm,rx); + } rxres_restore(&cx->sb_rxres, rx); - PL_reg_match_utf8 = SvUTF8(cx->sb_targ) ? 1 : 0; + RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ)); if (cx->sb_iters++) { I32 saviters = cx->sb_iters; @@ -178,21 +225,33 @@ PP(pp_substcont) { SV *targ = cx->sb_targ; - 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); - (void)SvOOK_off(targ); - Safefree(SvPVX(targ)); - SvPVX(targ) = SvPVX(dstr); +#ifdef PERL_COPY_ON_WRITE + if (SvIsCOW(targ)) { + sv_force_normal_flags(targ, SV_COW_DROP_PV); + } else +#endif + { + SvPV_free(targ); + } + 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); - PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); + PUSHs(sv_2mortal(newSViv(saviters - 1))); (void)SvPOK_only_UTF8(targ); TAINT_IF(cx->sb_rxtainted); @@ -200,6 +259,7 @@ PP(pp_substcont) SvTAINT(targ); LEAVE_SCOPE(cx->sb_oldsave); + ReREFCNT_dec(rx); POPSUBST(cx); RETURNOP(pm->op_next); } @@ -213,8 +273,12 @@ PP(pp_substcont) cx->sb_strend = s + (cx->sb_strend - m); } cx->sb_m = m = rx->startp[0] + orig; - if (m > s) - sv_catpvn(dstr, s, m-s); + if (m > s) { + if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ)) + sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv); + else + sv_catpvn(dstr, s, m-s); + } cx->sb_s = rx->endp[0] + orig; { /* Update the pos() information. */ SV *sv = cx->sb_targ; @@ -231,6 +295,8 @@ PP(pp_substcont) sv_pos_b2u(sv, &i); mg->mg_len = i; } + if (old != rx) + ReREFCNT_inc(rx); cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); rxres_save(&cx->sb_rxres, rx); RETURNOP(pm->op_pmreplstart); @@ -243,7 +309,11 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) U32 i; if (!p || p[1] < rx->nparens) { +#ifdef PERL_COPY_ON_WRITE + i = 7 + rx->nparens * 2; +#else i = 6 + rx->nparens * 2; +#endif if (!p) New(501, p, i, UV); else @@ -254,6 +324,11 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); RX_MATCH_COPIED_off(rx); +#ifdef PERL_COPY_ON_WRITE + *p++ = PTR2UV(rx->saved_copy); + rx->saved_copy = Nullsv; +#endif + *p++ = rx->nparens; *p++ = PTR2UV(rx->subbeg); @@ -270,11 +345,17 @@ Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) UV *p = (UV*)*rsp; U32 i; - if (RX_MATCH_COPIED(rx)) - Safefree(rx->subbeg); + RX_MATCH_COPY_FREE(rx); RX_MATCH_COPIED_set(rx, *p); *p++ = 0; +#ifdef PERL_COPY_ON_WRITE + if (rx->saved_copy) + SvREFCNT_dec (rx->saved_copy); + rx->saved_copy = INT2PTR(SV*,*p); + *p++ = 0; +#endif + rx->nparens = *p++; rx->subbeg = INT2PTR(char*,*p++); @@ -292,6 +373,11 @@ Perl_rxres_free(pTHX_ void **rsp) if (p) { Safefree(INT2PTR(char*,*p)); +#ifdef PERL_COPY_ON_WRITE + if (p[1]) { + SvREFCNT_dec (INT2PTR(SV*,p[1])); + } +#endif Safefree(p); *rsp = Null(void*); } @@ -301,7 +387,7 @@ PP(pp_formline) { dSP; dMARK; dORIGMARK; register SV *tmpForm = *++MARK; - register U16 *fpc; + register U32 *fpc; register char *t; register char *f; register char *s; @@ -318,31 +404,40 @@ PP(pp_formline) NV value; bool gotsome = FALSE; STRLEN len; - STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1; - bool item_is_utf = FALSE; + 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)) + targ_is_utf8 = TRUE; t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */ t += len; f = SvPV(tmpForm, len); /* 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; @@ -362,7 +457,8 @@ PP(pp_formline) 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); @@ -378,6 +474,21 @@ PP(pp_formline) case FF_LITERAL: arg = *fpc++; + if (targ_is_utf8 && !SvUTF8(tmpForm)) { + SvCUR_set(PL_formtarget, t - SvPVX(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)); + *t = '\0'; + sv_utf8_upgrade(PL_formtarget); + SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); + t = SvEND(PL_formtarget); + targ_is_utf8 = TRUE; + } while (arg--) *t++ = *f++; break; @@ -422,13 +533,13 @@ PP(pp_formline) break; s++; } - item_is_utf = TRUE; + item_is_utf8 = TRUE; itemsize = s - item; sv_pos_b2u(sv, &itemsize); break; } } - item_is_utf = FALSE; + item_is_utf8 = FALSE; if (itemsize > fieldsize) itemsize = fieldsize; send = chophere = s + itemsize; @@ -454,6 +565,7 @@ PP(pp_formline) while (s < send) { if (*s == '\r') { itemsize = s - item; + chophere = s; break; } if (*s++ & ~31) @@ -483,16 +595,17 @@ PP(pp_formline) itemsize = chophere - item; sv_pos_b2u(sv, &itemsize); } - item_is_utf = TRUE; + item_is_utf8 = TRUE; break; } } - item_is_utf = FALSE; + item_is_utf8 = FALSE; if (itemsize <= fieldsize) { send = chophere = s + itemsize; while (s < send) { if (*s == '\r') { itemsize = s - item; + chophere = s; break; } if (*s++ & ~31) @@ -543,7 +656,15 @@ PP(pp_formline) case FF_ITEM: arg = itemsize; s = item; - if (item_is_utf) { + if (item_is_utf8) { + if (!targ_is_utf8) { + SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + *t = '\0'; + sv_utf8_upgrade(PL_formtarget); + SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); + t = SvEND(PL_formtarget); + targ_is_utf8 = TRUE; + } while (arg--) { if (UTF8_IS_CONTINUED(*s)) { STRLEN skip = UTF8SKIP(s); @@ -569,6 +690,21 @@ PP(pp_formline) } break; } + if (targ_is_utf8 && !item_is_utf8) { + SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + *t = '\0'; + sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv); + for (; t < SvEND(PL_formtarget); t++) { +#ifdef EBCDIC + int ch = *t; + if (iscntrl(ch)) +#else + if (!(*t & ~31)) +#endif + *t = ' '; + } + break; + } while (arg--) { #ifdef EBCDIC int ch = *t++ = *s++; @@ -587,70 +723,76 @@ PP(pp_formline) 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; - item_is_utf = FALSE; /* XXX is this correct? */ + if ((item_is_utf8 = DO_UTF8(sv))) + itemsize = sv_len_utf8(sv); if (itemsize) { + bool chopped = FALSE; gotsome = TRUE; - send = s + itemsize; + send = s + len; + chophere = s + itemsize; while (s < send) { if (*s++ == '\n') { - if (s == send) - itemsize--; - else - lines++; + if (oneline) { + chopped = TRUE; + chophere = s; + break; + } else { + if (s == send) { + itemsize--; + chopped = TRUE; + } else + lines++; + } } } SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); - sv_catpvn(PL_formtarget, item, itemsize); + if (targ_is_utf8) + SvUTF8_on(PL_formtarget); + 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); t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); + if (item_is_utf8) + targ_is_utf8 = TRUE; } 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--) @@ -659,31 +801,22 @@ PP(pp_formline) } 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 == ' ') ; @@ -703,6 +836,8 @@ PP(pp_formline) if (strnEQ(linemark, linemark - arg, arg)) DIE(aTHX_ "Runaway format"); } + if (targ_is_utf8) + SvUTF8_on(PL_formtarget); FmLINES(PL_formtarget) = lines; SP = ORIGMARK; RETURNOP(cLISTOP->op_first); @@ -742,6 +877,8 @@ PP(pp_formline) case FF_END: *t = '\0'; SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget)); + if (targ_is_utf8) + SvUTF8_on(PL_formtarget); FmLINES(PL_formtarget) += lines; SP = ORIGMARK; RETPUSHYES; @@ -751,7 +888,7 @@ PP(pp_formline) PP(pp_grepstart) { - dSP; + dVAR; dSP; SV *src; if (PL_stack_base + *PL_markstack_ptr == SP) { @@ -766,14 +903,19 @@ PP(pp_grepstart) 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) @@ -788,7 +930,8 @@ PP(pp_mapstart) PP(pp_mapwhile) { - dSP; + dVAR; dSP; + I32 gimme = GIMME_V; I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */ I32 count; I32 shift; @@ -799,7 +942,7 @@ PP(pp_mapwhile) ++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 @@ -825,7 +968,7 @@ PP(pp_mapwhile) * irrelevant. --jhi */ if (shift < count) shift = count; /* Avoid shifting too often --Ben Tilly */ - + EXTEND(SP,shift); src = SP; dst = (SP += shift); @@ -836,14 +979,24 @@ PP(pp_mapwhile) } /* 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 */ @@ -852,8 +1005,15 @@ PP(pp_mapwhile) (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; @@ -868,7 +1028,10 @@ PP(pp_mapwhile) /* 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); } @@ -896,9 +1059,9 @@ PP(pp_flip) 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)); } @@ -906,10 +1069,10 @@ PP(pp_flip) 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); @@ -928,31 +1091,35 @@ PP(pp_flip) } } +/* 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(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); @@ -1015,40 +1182,35 @@ PP(pp_flop) /* Control. */ +static const char * const context_name[] = { + "pseudo-block", + "subroutine", + "eval", + "loop", + "substitution", + "block", + "format" +}; + 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: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s", - OP_NAME(PL_op)); - break; case CXt_SUB: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s", - OP_NAME(PL_op)); - break; case CXt_FORMAT: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s", - OP_NAME(PL_op)); - break; case CXt_EVAL: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s", - OP_NAME(PL_op)); - break; case CXt_NULL: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s", - OP_NAME(PL_op)); - return -1; + Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", + context_name[CxTYPE(cx)], OP_NAME(PL_op)); + if (CxTYPE(cx) == CXt_NULL) + return -1; + break; case CXt_LOOP: if (!cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) { @@ -1073,9 +1235,7 @@ Perl_dowantarray(pTHX) I32 Perl_block_gimme(pTHX) { - I32 cxix; - - cxix = dopoptosub(cxstack_ix); + const I32 cxix = dopoptosub(cxstack_ix); if (cxix < 0) return G_VOID; @@ -1096,9 +1256,7 @@ Perl_block_gimme(pTHX) 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)) @@ -1117,9 +1275,8 @@ STATIC I32 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; @@ -1137,9 +1294,8 @@ STATIC I32 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; @@ -1155,35 +1311,20 @@ STATIC I32 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: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s", - OP_NAME(PL_op)); - break; case CXt_SUB: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s", - OP_NAME(PL_op)); - break; case CXt_FORMAT: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s", - OP_NAME(PL_op)); - break; case CXt_EVAL: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s", - OP_NAME(PL_op)); - break; case CXt_NULL: if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s", - OP_NAME(PL_op)); - return -1; + Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", + context_name[CxTYPE(cx)], OP_NAME(PL_op)); + if ((CxTYPE(cx)) == CXt_NULL) + return -1; + break; case CXt_LOOP: DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); return i; @@ -1195,12 +1336,11 @@ S_dopoptoloop(pTHX_ I32 startingblock) 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. */ @@ -1241,23 +1381,21 @@ Perl_qerror(pTHX_ SV *err) } 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,""); else if (SvCUR(err) >= sizeof(prefix)+msglen-1) { @@ -1280,8 +1418,6 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) sv_setpvn(ERRSV, message, msglen); } } - else - message = SvPVx(ERRSV, msglen); while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) @@ -1292,12 +1428,15 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) if (cxix >= 0) { I32 optype; + register PERL_CONTEXT *cx; if (cxix < cxstack_ix) dounwind(cxix); POPBLOCK(cx,PL_curpm); if (CxTYPE(cx) != CXt_EVAL) { + if (!message) + message = SvPVx(ERRSV, msglen); PerlIO_write(Perl_error_log, "panic: die ", 11); PerlIO_write(Perl_error_log, message, msglen); my_exit(1); @@ -1317,40 +1456,21 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) 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(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; @@ -1425,7 +1545,7 @@ PP(pp_caller) PERL_SI *top_si = PL_curstackinfo; I32 dbcxix; I32 gimme; - char *stashname; + const char *stashname; SV *sv; I32 count = 0; @@ -1446,7 +1566,8 @@ PP(pp_caller) } 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--) @@ -1459,7 +1580,8 @@ PP(pp_caller) 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]; } @@ -1534,7 +1656,7 @@ PP(pp_caller) && 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; @@ -1562,8 +1684,18 @@ PP(pp_caller) (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) mask = newSVpvn(WARN_NONEstring, WARNsize) ; else if (old_warnings == pWARN_ALL || - (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) - mask = newSVpvn(WARN_ALLstring, WARNsize) ; + (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { + /* Get the bit mask for $warnings::Bits{all}, because + * it could have been extended by warnings::register */ + SV **bits_all; + HV *bits = get_hv("warnings::Bits", FALSE); + if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) { + mask = newSVsv(*bits_all); + } + else { + mask = newSVpvn(WARN_ALLstring, WARNsize) ; + } + } else mask = newSVsv(old_warnings); PUSHs(sv_2mortal(mask)); @@ -1574,7 +1706,7 @@ PP(pp_caller) PP(pp_reset) { dSP; - char *tmps; + const char *tmps; STRLEN n_a; if (MAXARG < 1) @@ -1595,12 +1727,14 @@ PP(pp_lineseq) 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; FREETMPS; - if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) + if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */ + || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) { dSP; register CV *cv; @@ -1627,11 +1761,10 @@ PP(pp_dbstate) hasargs = 0; SPAGAIN; - push_return(PL_op->op_next); PUSHBLOCK(cx, CXt_SUB, SP); - PUSHSUB(cx); + 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)); } @@ -1646,7 +1779,7 @@ PP(pp_scope) PP(pp_enteriter) { - dSP; dMARK; + dVAR; dSP; dMARK; register PERL_CONTEXT *cx; I32 gimme = GIMME_V; SV **svp; @@ -1659,6 +1792,11 @@ PP(pp_enteriter) 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); @@ -1690,26 +1828,37 @@ PP(pp_enteriter) cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) { dPOPss; - 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) && - *SvPVX(cx->blk_loop.iterary) != '0')) - { - 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; @@ -1717,7 +1866,7 @@ PP(pp_enteriter) PP(pp_enterloop) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; I32 gimme = GIMME_V; @@ -1733,7 +1882,7 @@ PP(pp_enterloop) PP(pp_leaveloop) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; I32 gimme; SV **newsp; @@ -1773,7 +1922,7 @@ PP(pp_leaveloop) PP(pp_return) { - dSP; dMARK; + dVAR; dSP; dMARK; I32 cxix; register PERL_CONTEXT *cx; bool popsub2 = FALSE; @@ -1783,6 +1932,7 @@ PP(pp_return) PMOP *newpm; I32 optype = 0; SV *sv; + OP *retop; if (PL_curstackinfo->si_type == PERLSI_SORT) { if (cxstack_ix == PL_sortcxix @@ -1806,11 +1956,14 @@ PP(pp_return) 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(); @@ -1820,11 +1973,12 @@ PP(pp_return) /* 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); - DIE(aTHX_ "%s did not return a true value", SvPVX(nsv)); + 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"); @@ -1865,24 +2019,25 @@ PP(pp_return) } PL_stack_sp = newsp; + LEAVE; /* Stack values are safe: */ if (popsub2) { + cxstack_ix--; POPSUB(cx,sv); /* release CV and @_ ... */ } else sv = Nullsv; PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVE; LEAVESUB(sv); if (clear_errsv) sv_setpv(ERRSV,""); - return pop_return(); + return retop; } PP(pp_last) { - dSP; + dVAR; dSP; I32 cxix; register PERL_CONTEXT *cx; I32 pop2 = 0; @@ -1908,6 +2063,7 @@ PP(pp_last) dounwind(cxix); POPBLOCK(cx,newpm); + cxstack_ix++; /* temporarily protect top context */ mark = newsp; switch (CxTYPE(cx)) { case CXt_LOOP: @@ -1917,15 +2073,15 @@ PP(pp_last) 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"); @@ -1949,6 +2105,8 @@ PP(pp_last) SP = newsp; PUTBACK; + LEAVE; + cxstack_ix--; /* Stack values are safe: */ switch (pop2) { case CXt_LOOP: @@ -1961,13 +2119,13 @@ PP(pp_last) } PL_curpm = newpm; /* ... and pop $1 et al */ - LEAVE; LEAVESUB(sv); return nextop; } PP(pp_next) { + dVAR; I32 cxix; register PERL_CONTEXT *cx; I32 inner; @@ -1996,6 +2154,7 @@ PP(pp_next) PP(pp_redo) { + dVAR; I32 cxix; register PERL_CONTEXT *cx; I32 oldsave; @@ -2016,21 +2175,23 @@ PP(pp_redo) TOPBLOCK(cx); oldsave = PL_scopestack[PL_scopestack_ix - 1]; LEAVE_SCOPE(oldsave); + FREETMPS; return cx->blk_loop.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); if (o->op_type == OP_LEAVE || o->op_type == OP_SCOPE || o->op_type == OP_LEAVELOOP || + o->op_type == OP_LEAVESUB || o->op_type == OP_LEAVETRY) { *ops++ = cUNOPo->op_first; @@ -2048,11 +2209,15 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit) for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if (kid == PL_lastgotoprobe) continue; - if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && - (ops == opstack || - (ops[-1]->op_type != OP_NEXTSTATE && - ops[-1]->op_type != OP_DBSTATE))) - *ops++ = kid; + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) { + if (ops == opstack) + *ops++ = kid; + else if (ops[-1]->op_type == OP_NEXTSTATE || + ops[-1]->op_type == OP_DBSTATE) + ops[-1] = kid; + else + *ops++ = kid; + } if ((o = dofindlabel(kid, label, ops, oplimit))) return o; } @@ -2069,17 +2234,16 @@ PP(pp_dump) 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; @@ -2092,12 +2256,13 @@ PP(pp_goto) 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))) @@ -2108,12 +2273,14 @@ PP(pp_goto) goto retry; tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, Nullch); - DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr)); + DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr); } DIE(aTHX_ "Goto undefined subroutine"); } /* First do some returnish stuff. */ + (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */ + FREETMPS; cxix = dopoptosub(cxstack_ix); if (cxix < 0) DIE(aTHX_ "Can't goto subroutine outside a subroutine"); @@ -2122,21 +2289,20 @@ PP(pp_goto) TOPBLOCK(cx); if (CxREALEVAL(cx)) DIE(aTHX_ "Can't goto subroutine from an eval-string"); - mark = PL_stack_sp; 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; @@ -2147,11 +2313,11 @@ PP(pp_goto) 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); @@ -2160,7 +2326,13 @@ PP(pp_goto) /* Now do some callish stuff. */ SAVETMPS; + SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ if (CvXSUB(cv)) { + if (reified) { + I32 index; + for (index=0; indexblk_sub.retop; } else { AV* padlist = CvPADLIST(cv); @@ -2208,7 +2381,7 @@ PP(pp_goto) 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) @@ -2220,24 +2393,29 @@ PP(pp_goto) 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); @@ -2251,11 +2429,15 @@ PP(pp_goto) */ 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 @@ -2284,6 +2466,7 @@ PP(pp_goto) if (label && *label) { OP *gotoprobe = 0; bool leaving_eval = FALSE; + bool in_block = FALSE; PERL_CONTEXT *last_eval_cx = 0; /* find label */ @@ -2295,7 +2478,7 @@ PP(pp_goto) switch (CxTYPE(cx)) { case CXt_EVAL: leaving_eval = TRUE; - if (CxREALEVAL(cx)) { + if (!CxTRYBLOCK(cx)) { gotoprobe = (last_eval_cx ? last_eval_cx->blk_eval.old_eval_root : PL_eval_root); @@ -2309,9 +2492,10 @@ PP(pp_goto) case CXt_SUBST: continue; case CXt_BLOCK: - if (ix) + if (ix) { gotoprobe = cx->blk_oldcop->op_sibling; - else + in_block = TRUE; + } else gotoprobe = PL_main_root; break; case CXt_SUB: @@ -2368,7 +2552,8 @@ PP(pp_goto) if (*enterops && enterops[1]) { OP *oldop = PL_op; - for (ix = 1; enterops[ix]; ix++) { + ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; + for (; enterops[ix]; ix++) { PL_op = enterops[ix]; /* Eventually we may want to stack the needed arguments * for each op. For now, we punt on the hard ones. */ @@ -2463,9 +2648,9 @@ PP(pp_cswitch) 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 const char *s = SvPVX(sv); + register const char *send = SvPVX(sv) + SvCUR(sv); + register const char *t; register I32 line = 1; while (s && s < send) { @@ -2484,14 +2669,6 @@ S_save_lines(pTHX_ AV *array, SV *sv) } } -#ifdef PERL_FLEXIBLE_EXCEPTIONS -STATIC void * -S_docatch_body(pTHX_ va_list args) -{ - return docatch_body(); -} -#endif - STATIC void * S_docatch_body(pTHX) { @@ -2503,9 +2680,7 @@ STATIC OP * 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 @@ -2513,37 +2688,32 @@ S_docatch(pTHX_ OP *o) #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; @@ -2553,16 +2723,16 @@ S_docatch(pTHX_ OP *o) } 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 */ @@ -2572,13 +2742,15 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) char tbuf[TYPE_DIGITS(long) + 12 + 10]; char *tmpbuf = tbuf; char *safestr; + int runtime; + CV* runcv = Nullcv; /* initialise to avoid compiler warnings */ ENTER; lex_start(sv); SAVETMPS; /* switch to eval mode */ - if (PL_curcop == &PL_compiling) { + if (IN_PERL_COMPILETIME) { SAVECOPSTASH_FREE(&PL_compiling); CopSTASH_set(&PL_compiling, PL_curstash); } @@ -2608,14 +2780,22 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) #else SAVEVPTR(PL_op); #endif - PL_hints &= HINT_UTF8; + + /* we get here either during compilation, or via pp_regcomp at runtime */ + 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); - rop = doeval(G_SCALAR, startop); + + if (runtime) + rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); + else + rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); POPBLOCK(cx,PL_curpm); POPEVAL(cx); @@ -2625,7 +2805,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) /* 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; @@ -2633,14 +2813,59 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp) return rop; } + +/* +=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 in the scope of the debugger itself). + +=cut +*/ + +CV* +Perl_find_runcv(pTHX_ U32 *db_seqp) +{ + PERL_SI *si; + + 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--) { + 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 */ + if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) { + *db_seqp = cx->blk_oldcop->cop_seq; + continue; + } + return cv; + } + else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) + return PL_compcv; + } + } + return PL_main_cv; +} + + +/* Compile a require/do, an eval '', or a /(?{...})/. + * In the last case, startop is non-null, and contains the address of + * a pointer that should be set to the just-compiled code. + * outside is the lexically enclosing CV (if any) that invoked us. + */ + /* With USE_5005THREADS, eval_owner must be held on entry to doeval */ STATIC OP * -S_doeval(pTHX_ int gimme, OP** startop) +S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) { - dSP; + dVAR; dSP; OP *saveop = PL_op; - CV *caller; - I32 i; PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE) ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL)) @@ -2648,17 +2873,6 @@ S_doeval(pTHX_ int gimme, OP** startop) PUSHMARK(SP); - caller = PL_compcv; - for (i = cxstack_ix - 1; i >= 0; i--) { - PERL_CONTEXT *cx = &cxstack[i]; - if (CxTYPE(cx) == CXt_EVAL) - break; - else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { - caller = cx->blk_sub.cv; - break; - } - } - SAVESPTR(PL_compcv); PL_compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)PL_compcv, SVt_PVCV); @@ -2666,15 +2880,13 @@ S_doeval(pTHX_ int gimme, OP** startop) assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); cxstack[cxstack_ix].blk_eval.cv = PL_compcv; + CvOUTSIDE_SEQ(PL_compcv) = seq; + CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside); + /* set up a scratch pad */ CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); - if (!saveop || - (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE)) - { - CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller); - } SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ @@ -2700,12 +2912,11 @@ S_doeval(pTHX_ int gimme, OP** startop) else sv_setpv(ERRSV,""); 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); @@ -2715,17 +2926,19 @@ S_doeval(pTHX_ int gimme, OP** startop) 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(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); @@ -2733,7 +2946,7 @@ S_doeval(pTHX_ int gimme, OP** startop) (*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"); } @@ -2743,11 +2956,18 @@ S_doeval(pTHX_ int gimme, OP** startop) CopLINE_set(&PL_compiling, 0); if (startop) { *startop = PL_eval_root; - SvREFCNT_dec(CvOUTSIDE(PL_compcv)); - CvOUTSIDE(PL_compcv) = Nullcv; } 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); @@ -2779,14 +2999,15 @@ S_doeval(pTHX_ int gimme, OP** startop) } STATIC PerlIO * -S_doopen_pmc(pTHX_ const char *name, const char *mode) +S_doopen_pm(pTHX_ const char *name, const char *mode) { +#ifndef PERL_DISABLE_PMC 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) { @@ -2808,11 +3029,14 @@ S_doopen_pmc(pTHX_ const char *name, const char *mode) fp = PerlIO_open(name, mode); } return fp; +#else + return PerlIO_open(name, mode); +#endif /* !PERL_DISABLE_PMC */ } PP(pp_require) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; SV *sv; char *name; @@ -2832,81 +3056,37 @@ PP(pp_require) 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 */ if (path_is_absolute(name)) { tryname = name; - tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); + tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE); } #ifdef MACOS_TRADITIONAL if (!tryrsfp) { @@ -2915,7 +3095,7 @@ PP(pp_require) MacPerl_CanonDir(name, newname, 1); if (path_is_absolute(newname)) { tryname = newname; - tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE); + tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE); } } #endif @@ -3016,6 +3196,7 @@ PP(pp_require) PERL_SCRIPT_MODE); } } + SP--; } PUTBACK; @@ -3058,19 +3239,33 @@ PP(pp_require) 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); - tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE); + tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') tryname += 2; @@ -3155,9 +3350,9 @@ PP(pp_require) } /* 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); @@ -3168,8 +3363,8 @@ PP(pp_require) encoding = PL_encoding; PL_encoding = Nullsv; - op = DOCATCH(doeval(gimme, NULL)); - + op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq)); + /* Restore encoding. */ PL_encoding = encoding; @@ -3183,7 +3378,7 @@ PP(pp_dofile) PP(pp_entereval) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; dPOPss; I32 gimme = GIMME_V, was = PL_sub_generation; @@ -3192,6 +3387,8 @@ PP(pp_entereval) char *safestr; STRLEN len; OP *ret; + CV* runcv; + U32 seq; if (!SvPV(sv,len)) RETPUSHUNDEF; @@ -3239,17 +3436,23 @@ PP(pp_entereval) PL_compiling.cop_io = newSVsv(PL_curcop->cop_io); SAVEFREESV(PL_compiling.cop_io); } + /* special case: an eval '' executed within the DB package gets lexically + * placed in the first non-DB CV rather than the current CV - this + * allows the debugger to execute code, find lexicals etc, in the + * scope of the code being debugged. Passing &seq gets find_runcv + * 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 */ if (PERLDB_LINE && PL_curstash != PL_debstash) save_lines(CopFILEAV(&PL_compiling), PL_linestr); PUTBACK; - ret = doeval(gimme, NULL); + ret = doeval(gimme, NULL, runcv, seq); if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */ && ret != PL_op->op_next) { /* Successive compilation. */ strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ @@ -3259,19 +3462,19 @@ PP(pp_entereval) 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) @@ -3313,7 +3516,7 @@ PP(pp_leaveeval) /* 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); - retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv)); + retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv); /* die_where() did LEAVE, or we won't be here */ } else { @@ -3327,16 +3530,16 @@ PP(pp_leaveeval) PP(pp_entertry) { - dSP; + dVAR; dSP; register PERL_CONTEXT *cx; 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,""); @@ -3346,18 +3549,16 @@ PP(pp_entertry) 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) @@ -3389,10 +3590,10 @@ PP(pp_leavetry) LEAVE; sv_setpv(ERRSV,""); - RETURNOP(retop); + RETURN; } -STATIC void +STATIC OP * S_doparseform(pTHX_ SV *sv) { STRLEN len; @@ -3403,16 +3604,26 @@ S_doparseform(pTHX_ SV *sv) 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; + 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"); - New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */ + /* estimate the buffer size needed */ + for (base = s; s <= send; s++) { + if (*s == '\n' || *s == '@' || *s == '^') + maxops += 10; + } + s = base; + base = Nullch; + + New(804, fops, maxops, U32); fpc = fops; if (s < send) { @@ -3439,8 +3650,12 @@ S_doparseform(pTHX_ SV *sv) 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; @@ -3496,8 +3711,12 @@ S_doparseform(pTHX_ SV *sv) *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; @@ -3505,9 +3724,7 @@ S_doparseform(pTHX_ SV *sv) while (*s == '#') s++; if (*s == '.') { - char *f; - s++; - f = s; + const char * const f = ++s; while (*s == '#') s++; arg |= 256 + (s - f); @@ -3515,6 +3732,7 @@ S_doparseform(pTHX_ SV *sv) *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; @@ -3523,9 +3741,7 @@ S_doparseform(pTHX_ SV *sv) while (*s == '#') s++; if (*s == '.') { - char *f; - s++; - f = s; + const char * const f = ++s; while (*s == '#') s++; arg |= 256 + (s - f); @@ -3533,6 +3749,7 @@ S_doparseform(pTHX_ SV *sv) *fpc++ = s - base; /* fieldsize for FETCH */ *fpc++ = FF_0DECIMAL; *fpc++ = (U16)arg; + unchopnum |= ! ischop; } else { I32 prespace = 0; @@ -3575,22 +3792,56 @@ S_doparseform(pTHX_ SV *sv) } *fpc++ = FF_END; + assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */ arg = fpc - fops; { /* 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); GV *filter_child_proc = (GV *)IoFMT_GV(datasv); @@ -3661,7 +3912,7 @@ run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) /* 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 @@ -3676,3 +3927,13 @@ S_path_is_absolute(pTHX_ char *name) else return FALSE; } + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * vim: shiftwidth=4: +*/