X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=0eb513f9a354ff366d12a605f72487e125e64498;hb=f747ebd621ca5f8cd5605b35b81db4ac486f68f9;hp=983a7605f46cd65be983fb05b80768a1e527fed4;hpb=cf525c36fb4613d400e7bd3733f96430dee2d396;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 983a760..0eb513f 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,7 +1,7 @@ /* pp_ctl.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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. @@ -9,12 +9,14 @@ */ /* - * Now far ahead the Road has gone, - * And I must follow, if I can, - * Pursuing it with eager feet, - * Until it joins some larger way - * Where many paths and errands meet. - * And whither then? I cannot say. + * Now far ahead the Road has gone, + * And I must follow, if I can, + * Pursuing it with eager feet, + * Until it joins some larger way + * Where many paths and errands meet. + * And whither then? I cannot say. + * + * [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] */ /* This file contains control-oriented pp ("push/pop") functions that @@ -38,10 +40,11 @@ #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) -static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen); +#define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) PP(pp_wantarray) { + dVAR; dSP; I32 cxix; EXTEND(SP, 1); @@ -60,13 +63,9 @@ PP(pp_wantarray) } } -PP(pp_regcmaybe) -{ - return NORMAL; -} - PP(pp_regcreset) { + dVAR; /* XXXX Should store the old value to allow for tie/overload - and restore in regcomp, where marked with XXXX. */ PL_reginterp_cnt = 0; @@ -76,10 +75,11 @@ PP(pp_regcreset) PP(pp_regcomp) { + dVAR; dSP; register PMOP *pm = (PMOP*)cLOGOP->op_other; SV *tmpstr; - MAGIC *mg = Null(MAGIC*); + REGEXP *re = NULL; /* prevent recompiling under /o and ithreads. */ #if defined(USE_ITHREADS) @@ -97,7 +97,7 @@ PP(pp_regcomp) /* multiple args; concatentate them */ dMARK; dORIGMARK; tmpstr = PAD_SV(ARGTARG); - sv_setpvn(tmpstr, "", 0); + sv_setpvs(tmpstr, ""); while (++MARK <= SP) { if (PL_amagic_generation) { SV *sv; @@ -117,76 +117,95 @@ PP(pp_regcomp) tmpstr = POPs; if (SvROK(tmpstr)) { - SV *sv = SvRV(tmpstr); - if(SvMAGICAL(sv)) - mg = mg_find(sv, PERL_MAGIC_qr); + SV * const sv = SvRV(tmpstr); + if (SvTYPE(sv) == SVt_REGEXP) + re = (REGEXP*) sv; } - if (mg) { - regexp *re = (regexp *)mg->mg_obj; + if (re) { + re = reg_temp_copy(re); ReREFCNT_dec(PM_GETRE(pm)); - PM_SETRE(pm, ReREFCNT_inc(re)); + PM_SETRE(pm, re); } else { STRLEN len; - const char *t = SvPV_const(tmpstr, len); + const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : ""; + re = PM_GETRE(pm); + assert (re != (REGEXP*) &PL_sv_undef); /* Check against the last compiled regexp. */ - if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp || - PM_GETRE(pm)->prelen != (I32)len || - memNE(PM_GETRE(pm)->precomp, t, len)) + if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len || + memNE(RX_PRECOMP(re), t, len)) { - if (PM_GETRE(pm)) { - ReREFCNT_dec(PM_GETRE(pm)); - PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */ + const regexp_engine *eng = re ? RX_ENGINE(re) : NULL; + U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME; + if (re) { + ReREFCNT_dec(re); +#ifdef USE_ITHREADS + PM_SETRE(pm, (REGEXP*) &PL_sv_undef); +#else + PM_SETRE(pm, NULL); /* crucial if regcomp aborts */ +#endif + } else if (PL_curcop->cop_hints_hash) { + SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0, + "regcomp", 7, 0, 0); + if (ptr && SvIOK(ptr) && SvIV(ptr)) + eng = INT2PTR(regexp_engine*,SvIV(ptr)); } + if (PL_op->op_flags & OPf_SPECIAL) PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ - pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */ - if (DO_UTF8(tmpstr)) - pm->op_pmdynflags |= PMdf_DYN_UTF8; - else { - pm->op_pmdynflags &= ~PMdf_DYN_UTF8; - if (pm->op_pmdynflags & PMdf_UTF8) - t = (char*)bytes_to_utf8((U8*)t, &len); + if (DO_UTF8(tmpstr)) { + assert (SvUTF8(tmpstr)); + } else if (SvUTF8(tmpstr)) { + /* Not doing UTF-8, despite what the SV says. Is this only if + we're trapped in use 'bytes'? */ + /* Make a copy of the octet sequence, but without the flag on, + as the compiler now honours the SvUTF8 flag on tmpstr. */ + STRLEN len; + const char *const p = SvPV(tmpstr, len); + tmpstr = newSVpvn_flags(p, len, SVs_TEMP); } - PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm)); - if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8)) - Safefree(t); + + if (eng) + PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags)); + else + PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags)); + PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed inside tie/overload accessors. */ } } + + re = PM_GETRE(pm); #ifndef INCOMPLETE_TAINTS if (PL_tainting) { if (PL_tainted) - pm->op_pmdynflags |= PMdf_TAINTED; + RX_EXTFLAGS(re) |= RXf_TAINTED; else - pm->op_pmdynflags &= ~PMdf_TAINTED; + RX_EXTFLAGS(re) &= ~RXf_TAINTED; } #endif - if (!PM_GETRE(pm)->prelen && PL_curpm) + if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm) pm = PL_curpm; - else if (strEQ("\\s+", PM_GETRE(pm)->precomp)) - pm->op_pmflags |= PMf_WHITE; - else - pm->op_pmflags &= ~PMf_WHITE; - /* XXX runtime compiled output needs to move to the pad */ + +#if !defined(USE_ITHREADS) + /* can't change the optree at runtime either */ + /* PMf_KEEP is handled differently under threads to avoid these problems */ if (pm->op_pmflags & PMf_KEEP) { pm->op_private &= ~OPpRUNTIME; /* no point compiling again */ -#if !defined(USE_ITHREADS) - /* XXX can't change the optree at runtime either */ cLOGOP->op_first->op_next = PL_op->op_next; -#endif } +#endif RETURN; } PP(pp_substcont) { + dVAR; dSP; register PERL_CONTEXT *cx = &cxstack[cxstack_ix]; register PMOP * const pm = (PMOP*) cLOGOP->op_other; @@ -195,12 +214,12 @@ PP(pp_substcont) register char *m = cx->sb_m; char *orig = cx->sb_orig; register REGEXP * const rx = cx->sb_rx; - SV *nsv = Nullsv; + SV *nsv = NULL; REGEXP *old = PM_GETRE(pm); if(old != rx) { if(old) ReREFCNT_dec(old); - PM_SETRE(pm,rx); + PM_SETRE(pm,ReREFCNT_inc(rx)); } rxres_restore(&cx->sb_rxres, rx); @@ -216,13 +235,13 @@ PP(pp_substcont) sv_catsv(dstr, POPs); /* Are we done */ - if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig, + if (CxONCE(cx) || !CALLREGEXEC(rx, s, cx->sb_strend, orig, s == m, cx->sb_targ, NULL, ((cx->sb_rflags & REXEC_COPY_STR) ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST)))) { - SV *targ = cx->sb_targ; + SV * const targ = cx->sb_targ; assert(cx->sb_strend >= s); if(cx->sb_strend > s) { @@ -246,11 +265,10 @@ PP(pp_substcont) SvLEN_set(targ, SvLEN(dstr)); if (DO_UTF8(dstr)) SvUTF8_on(targ); - SvPV_set(dstr, (char*)0); - sv_free(dstr); + SvPV_set(dstr, NULL); TAINT_IF(cx->sb_rxtainted & 1); - PUSHs(sv_2mortal(newSViv(saviters - 1))); + mPUSHi(saviters - 1); (void)SvPOK_only_UTF8(targ); TAINT_IF(cx->sb_rxtainted); @@ -258,47 +276,45 @@ PP(pp_substcont) SvTAINT(targ); LEAVE_SCOPE(cx->sb_oldsave); - ReREFCNT_dec(rx); POPSUBST(cx); RETURNOP(pm->op_next); } cx->sb_iters = saviters; } - if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) { + if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) { m = s; s = orig; - cx->sb_orig = orig = rx->subbeg; + cx->sb_orig = orig = RX_SUBBEG(rx); s = orig + (m - s); cx->sb_strend = s + (cx->sb_strend - m); } - cx->sb_m = m = rx->startp[0] + orig; + cx->sb_m = m = RX_OFFS(rx)[0].start + orig; 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; + cx->sb_s = RX_OFFS(rx)[0].end + orig; { /* Update the pos() information. */ - SV *sv = cx->sb_targ; + SV * const sv = cx->sb_targ; MAGIC *mg; - I32 i; - if (SvTYPE(sv) < SVt_PVMG) - SvUPGRADE(sv, SVt_PVMG); + SvUPGRADE(sv, SVt_PVMG); if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { - sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0); - mg = mg_find(sv, PERL_MAGIC_regex_global); +#ifdef PERL_OLD_COPY_ON_WRITE + if (SvIsCOW(sv)) + sv_force_normal_flags(sv, 0); +#endif + mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, + NULL, 0); } - i = m - orig; - if (DO_UTF8(sv)) - sv_pos_b2u(sv, &i); - mg->mg_len = i; + mg->mg_len = m - orig; } if (old != rx) (void)ReREFCNT_inc(rx); cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); rxres_save(&cx->sb_rxres, rx); - RETURNOP(pm->op_pmreplstart); + RETURNOP(pm->op_pmstashstartu.op_pmreplstart); } void @@ -307,11 +323,14 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) UV *p = (UV*)*rsp; U32 i; - if (!p || p[1] < rx->nparens) { + PERL_ARGS_ASSERT_RXRES_SAVE; + PERL_UNUSED_CONTEXT; + + if (!p || p[1] < RX_NPARENS(rx)) { #ifdef PERL_OLD_COPY_ON_WRITE - i = 7 + rx->nparens * 2; + i = 7 + RX_NPARENS(rx) * 2; #else - i = 6 + rx->nparens * 2; + i = 6 + RX_NPARENS(rx) * 2; #endif if (!p) Newx(p, i, UV); @@ -320,62 +339,68 @@ Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx) *rsp = (void*)p; } - *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch); + *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL); RX_MATCH_COPIED_off(rx); #ifdef PERL_OLD_COPY_ON_WRITE - *p++ = PTR2UV(rx->saved_copy); - rx->saved_copy = Nullsv; + *p++ = PTR2UV(RX_SAVED_COPY(rx)); + RX_SAVED_COPY(rx) = NULL; #endif - *p++ = rx->nparens; + *p++ = RX_NPARENS(rx); - *p++ = PTR2UV(rx->subbeg); - *p++ = (UV)rx->sublen; - for (i = 0; i <= rx->nparens; ++i) { - *p++ = (UV)rx->startp[i]; - *p++ = (UV)rx->endp[i]; + *p++ = PTR2UV(RX_SUBBEG(rx)); + *p++ = (UV)RX_SUBLEN(rx); + for (i = 0; i <= RX_NPARENS(rx); ++i) { + *p++ = (UV)RX_OFFS(rx)[i].start; + *p++ = (UV)RX_OFFS(rx)[i].end; } } -void -Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx) +static void +S_rxres_restore(pTHX_ void **rsp, REGEXP *rx) { UV *p = (UV*)*rsp; U32 i; + PERL_ARGS_ASSERT_RXRES_RESTORE; + PERL_UNUSED_CONTEXT; + RX_MATCH_COPY_FREE(rx); RX_MATCH_COPIED_set(rx, *p); *p++ = 0; #ifdef PERL_OLD_COPY_ON_WRITE - if (rx->saved_copy) - SvREFCNT_dec (rx->saved_copy); - rx->saved_copy = INT2PTR(SV*,*p); + if (RX_SAVED_COPY(rx)) + SvREFCNT_dec (RX_SAVED_COPY(rx)); + RX_SAVED_COPY(rx) = INT2PTR(SV*,*p); *p++ = 0; #endif - rx->nparens = *p++; + RX_NPARENS(rx) = *p++; - rx->subbeg = INT2PTR(char*,*p++); - rx->sublen = (I32)(*p++); - for (i = 0; i <= rx->nparens; ++i) { - rx->startp[i] = (I32)(*p++); - rx->endp[i] = (I32)(*p++); + RX_SUBBEG(rx) = INT2PTR(char*,*p++); + RX_SUBLEN(rx) = (I32)(*p++); + for (i = 0; i <= RX_NPARENS(rx); ++i) { + RX_OFFS(rx)[i].start = (I32)(*p++); + RX_OFFS(rx)[i].end = (I32)(*p++); } } -void -Perl_rxres_free(pTHX_ void **rsp) +static void +S_rxres_free(pTHX_ void **rsp) { - UV *p = (UV*)*rsp; + UV * const p = (UV*)*rsp; + + PERL_ARGS_ASSERT_RXRES_FREE; + PERL_UNUSED_CONTEXT; if (p) { #ifdef PERL_POISON void *tmp = INT2PTR(char*,*p); Safefree(tmp); if (*p) - Poison(*p, 1, sizeof(*p)); + PoisonFree(*p, 1, sizeof(*p)); #else Safefree(INT2PTR(char*,*p)); #endif @@ -385,37 +410,36 @@ Perl_rxres_free(pTHX_ void **rsp) } #endif Safefree(p); - *rsp = Null(void*); + *rsp = NULL; } } PP(pp_formline) { - dSP; dMARK; dORIGMARK; - register SV *tmpForm = *++MARK; + dVAR; dSP; dMARK; dORIGMARK; + register SV * const tmpForm = *++MARK; register U32 *fpc; register char *t; const char *f; register I32 arg; - register SV *sv = Nullsv; - const char *item = Nullch; + register SV *sv = NULL; + const char *item = NULL; I32 itemsize = 0; I32 fieldsize = 0; I32 lines = 0; - bool chopspace = (strchr(PL_chopset, ' ') != Nullch); - const char *chophere = Nullch; - char *linemark = Nullch; + bool chopspace = (strchr(PL_chopset, ' ') != NULL); + const char *chophere = NULL; + char *linemark = NULL; NV value; bool gotsome = FALSE; STRLEN len; - STRLEN fudge = SvPOK(tmpForm) + const 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; + SV * nsv = NULL; + OP * parseres = NULL; const char *fmt; - bool oneline; if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { if (SvREADONLY(tmpForm)) { @@ -481,13 +505,13 @@ PP(pp_formline) *t = '\0'; sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv); t = SvEND(PL_formtarget); + f += arg; break; } if (!targ_is_utf8 && DO_UTF8(tmpForm)) { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; - sv_utf8_upgrade(PL_formtarget); - SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); + sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1); t = SvEND(PL_formtarget); targ_is_utf8 = TRUE; } @@ -670,8 +694,8 @@ PP(pp_formline) if (!targ_is_utf8) { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; - sv_utf8_upgrade(PL_formtarget); - SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); + sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, + fudge + 1); t = SvEND(PL_formtarget); targ_is_utf8 = TRUE; } @@ -731,7 +755,7 @@ PP(pp_formline) { const char *s = chophere; if (chopspace) { - while (*s && isSPACE(*s)) + while (isSPACE(*s)) s++; } sv_chop(sv,s); @@ -741,51 +765,76 @@ PP(pp_formline) case FF_LINESNGL: chopspace = 0; - oneline = TRUE; - goto ff_line; case FF_LINEGLOB: - oneline = FALSE; - ff_line: { + const bool oneline = fpc[-1] == FF_LINESNGL; const char *s = item = SvPV_const(sv, len); + item_is_utf8 = DO_UTF8(sv); itemsize = len; - if ((item_is_utf8 = DO_UTF8(sv))) - itemsize = sv_len_utf8(sv); if (itemsize) { - bool chopped = FALSE; + STRLEN to_copy = itemsize; const char *const send = s + len; + const U8 *source = (const U8 *) s; + U8 *tmp = NULL; + gotsome = TRUE; chophere = s + itemsize; while (s < send) { if (*s++ == '\n') { if (oneline) { - chopped = TRUE; + to_copy = s - SvPVX_const(sv) - 1; chophere = s; break; } else { if (s == send) { itemsize--; - chopped = TRUE; + to_copy--; } else lines++; } } } - SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); - 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); + if (targ_is_utf8 && !item_is_utf8) { + source = tmp = bytes_to_utf8(source, &to_copy); + SvCUR_set(PL_formtarget, + t - SvPVX_const(PL_formtarget)); + } else { + if (item_is_utf8 && !targ_is_utf8) { + /* Upgrade targ to UTF8, and then we reduce it to + a problem we have a simple solution for. */ + SvCUR_set(PL_formtarget, + t - SvPVX_const(PL_formtarget)); + targ_is_utf8 = TRUE; + /* Don't need get magic. */ + sv_utf8_upgrade_nomg(PL_formtarget); + } else { + SvCUR_set(PL_formtarget, + t - SvPVX_const(PL_formtarget)); + } + + /* Easy. They agree. */ + assert (item_is_utf8 == targ_is_utf8); + } + SvGROW(PL_formtarget, + SvCUR(PL_formtarget) + to_copy + fudge + 1); t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); - if (item_is_utf8) - targ_is_utf8 = TRUE; + + Copy(source, t, to_copy, char); + t += to_copy; + SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy); + if (item_is_utf8) { + if (SvGMAGICAL(sv)) { + /* Mustn't call sv_pos_b2u() as it does a second + mg_get(). Is this a bug? Do we need a _flags() + variant? */ + itemsize = utf8_length(source, source + itemsize); + } else { + sv_pos_b2u(sv, &itemsize); + } + assert(!tmp); + } else if (tmp) { + Safefree(tmp); + } } break; } @@ -793,17 +842,23 @@ PP(pp_formline) case FF_0DECIMAL: arg = *fpc++; #if defined(USE_LONG_DOUBLE) - fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl; + fmt = (const char *) + ((arg & 256) ? + "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl); #else - fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f"; + fmt = (const char *) + ((arg & 256) ? + "%#0*.*f" : "%0*.*f"); #endif goto ff_dec; case FF_DECIMAL: arg = *fpc++; #if defined(USE_LONG_DOUBLE) - fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl; + fmt = (const char *) + ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl); #else - fmt = (arg & 256) ? "%#*.*f" : "%*.*f"; + fmt = (const char *) + ((arg & 256) ? "%#*.*f" : "%*.*f"); #endif ff_dec: /* If the field is marked with ^ and the value is undefined, @@ -826,7 +881,7 @@ PP(pp_formline) /* Formats aren't yet marked for locales, so assume "yes". */ { STORE_NUMERIC_STANDARD_SET_LOCAL(); - sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value); + my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value); RESTORE_NUMERIC_STANDARD(); } t += fieldsize; @@ -869,7 +924,7 @@ PP(pp_formline) const char *s = chophere; const char *send = item + len; if (chopspace) { - while (*s && isSPACE(*s) && s < send) + while (isSPACE(*s) && (s < send)) s++; } if (s < send) { @@ -911,7 +966,7 @@ PP(pp_grepstart) if (PL_stack_base + *PL_markstack_ptr == SP) { (void)POPMARK; if (GIMME_V == G_SCALAR) - XPUSHs(sv_2mortal(newSViv(0))); + mXPUSHi(0); RETURNOP(PL_op->op_next->op_next); } PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; @@ -932,7 +987,7 @@ PP(pp_grepstart) if (PL_op->op_private & OPpGREP_LEX) PAD_SVl(PL_op->op_targ) = src; else - DEFSV = src; + DEFSV_set(src); PUTBACK; if (PL_op->op_type == OP_MAPSTART) @@ -940,11 +995,6 @@ PP(pp_grepstart) return ((LOGOP*)PL_op->op_next)->op_other; } -PP(pp_mapstart) -{ - DIE(aTHX_ "panic: mapstart"); /* uses grepstart */ -} - PP(pp_mapwhile) { dVAR; dSP; @@ -1048,7 +1098,7 @@ PP(pp_mapwhile) if (PL_op->op_private & OPpGREP_LEX) PAD_SVl(PL_op->op_targ) = src; else - DEFSV = src; + DEFSV_set(src); RETURNOP(cLOGOP->op_other); } @@ -1058,6 +1108,7 @@ PP(pp_mapwhile) PP(pp_range) { + dVAR; if (GIMME == G_ARRAY) return NORMAL; if (SvTRUEx(PAD_SV(PL_op->op_targ))) @@ -1068,6 +1119,7 @@ PP(pp_range) PP(pp_flip) { + dVAR; dSP; if (GIMME == G_ARRAY) { @@ -1075,7 +1127,7 @@ PP(pp_flip) } else { dTOPss; - SV *targ = PAD_SV(PL_op->op_targ); + SV * const targ = PAD_SV(PL_op->op_targ); int flip = 0; if (PL_op->op_private & OPpFLIP_LINENUM) { @@ -1083,8 +1135,9 @@ PP(pp_flip) flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); } else { - GV *gv = gv_fetchpv(".", TRUE, SVt_PV); - if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv)); + GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV); + if (gv && GvSV(gv)) + flip = SvIV(sv) == SvIV(GvSV(gv)); } } else { flip = SvTRUE(sv); @@ -1102,7 +1155,7 @@ PP(pp_flip) RETURNOP(((LOGOP*)cUNOP->op_first)->op_other); } } - sv_setpvn(TARG, "", 0); + sv_setpvs(TARG, ""); SETs(targ); RETURN; } @@ -1121,15 +1174,13 @@ PP(pp_flip) PP(pp_flop) { - dSP; + dVAR; dSP; if (GIMME == G_ARRAY) { dPOPPOPssrl; - if (SvGMAGICAL(left)) - mg_get(left); - if (SvGMAGICAL(right)) - mg_get(right); + SvGETMAGIC(left); + SvGETMAGIC(right); if (RANGE_IS_NUMERIC(left,right)) { register IV i, j; @@ -1152,9 +1203,9 @@ PP(pp_flop) } } else { - SV *final = sv_mortalcopy(right); + SV * const final = sv_mortalcopy(right); STRLEN len; - const char *tmps = SvPV_const(final, len); + const char * const tmps = SvPV_const(final, len); SV *sv = sv_mortalcopy(left); SvPV_force_nolen(sv); @@ -1178,7 +1229,7 @@ PP(pp_flop) flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)); } else { - GV * const gv = gv_fetchpv(".", TRUE, SVt_PV); + GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV); if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv)); } } @@ -1188,7 +1239,7 @@ PP(pp_flop) if (flop) { sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0); - sv_catpvn(targ, "E0", 2); + sv_catpvs(targ, "E0"); } SETs(targ); } @@ -1200,19 +1251,27 @@ PP(pp_flop) static const char * const context_name[] = { "pseudo-block", + NULL, /* CXt_WHEN never actually needs "block" */ + NULL, /* CXt_BLOCK never actually needs "block" */ + NULL, /* CXt_GIVEN never actually needs "block" */ + NULL, /* CXt_LOOP_FOR never actually needs "loop" */ + NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */ + NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */ + NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */ "subroutine", + "format", "eval", - "loop", "substitution", - "block", - "format" }; STATIC I32 S_dopoptolabel(pTHX_ const char *label) { + dVAR; register I32 i; + PERL_ARGS_ASSERT_DOPOPTOLABEL; + for (i = cxstack_ix; i >= 0; i--) { register const PERL_CONTEXT * const cx = &cxstack[i]; switch (CxTYPE(cx)) { @@ -1227,10 +1286,13 @@ S_dopoptolabel(pTHX_ const char *label) if (CxTYPE(cx) == CXt_NULL) return -1; break; - case CXt_LOOP: - if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) { + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: + if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) { DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n", - (long)i, cx->blk_loop.label)); + (long)i, CxLABEL(cx))); continue; } DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label)); @@ -1240,9 +1302,12 @@ S_dopoptolabel(pTHX_ const char *label) return i; } + + I32 Perl_dowantarray(pTHX) { + dVAR; const I32 gimme = block_gimme(); return (gimme == G_VOID) ? G_SCALAR : gimme; } @@ -1250,6 +1315,7 @@ Perl_dowantarray(pTHX) I32 Perl_block_gimme(pTHX) { + dVAR; const I32 cxix = dopoptosub(cxstack_ix); if (cxix < 0) return G_VOID; @@ -1271,25 +1337,24 @@ Perl_block_gimme(pTHX) I32 Perl_is_lvalue_sub(pTHX) { + dVAR; 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)) - return cxstack[cxix].blk_sub.lval; + if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv)) + return CxLVAL(cxstack + cxix); else return 0; } STATIC I32 -S_dopoptosub(pTHX_ I32 startingblock) -{ - return dopoptosub_at(cxstack, startingblock); -} - -STATIC I32 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) { + dVAR; I32 i; + + PERL_ARGS_ASSERT_DOPOPTOSUB_AT; + for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT * const cx = &cxstk[i]; switch (CxTYPE(cx)) { @@ -1308,6 +1373,7 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock) STATIC I32 S_dopoptoeval(pTHX_ I32 startingblock) { + dVAR; I32 i; for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT *cx = &cxstack[i]; @@ -1325,6 +1391,7 @@ S_dopoptoeval(pTHX_ I32 startingblock) STATIC I32 S_dopoptoloop(pTHX_ I32 startingblock) { + dVAR; I32 i; for (i = startingblock; i >= 0; i--) { register const PERL_CONTEXT * const cx = &cxstack[i]; @@ -1340,7 +1407,10 @@ S_dopoptoloop(pTHX_ I32 startingblock) if ((CxTYPE(cx)) == CXt_NULL) return -1; break; - case CXt_LOOP: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i)); return i; } @@ -1348,9 +1418,56 @@ S_dopoptoloop(pTHX_ I32 startingblock) return i; } +STATIC I32 +S_dopoptogiven(pTHX_ I32 startingblock) +{ + dVAR; + I32 i; + for (i = startingblock; i >= 0; i--) { + register const PERL_CONTEXT *cx = &cxstack[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_GIVEN: + DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i)); + return i; + case CXt_LOOP_PLAIN: + assert(!CxFOREACHDEF(cx)); + break; + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + if (CxFOREACHDEF(cx)) { + DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i)); + return i; + } + } + } + return i; +} + +STATIC I32 +S_dopoptowhen(pTHX_ I32 startingblock) +{ + dVAR; + I32 i; + for (i = startingblock; i >= 0; i--) { + register const PERL_CONTEXT *cx = &cxstack[i]; + switch (CxTYPE(cx)) { + default: + continue; + case CXt_WHEN: + DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i)); + return i; + } + } + return i; +} + void Perl_dounwind(pTHX_ I32 cxix) { + dVAR; I32 optype; while (cxstack_ix > cxix) { @@ -1370,7 +1487,10 @@ Perl_dounwind(pTHX_ I32 cxix) case CXt_EVAL: POPEVAL(cx); break; - case CXt_LOOP: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: POPLOOP(cx); break; case CXt_NULL: @@ -1387,13 +1507,18 @@ Perl_dounwind(pTHX_ I32 cxix) void Perl_qerror(pTHX_ SV *err) { + dVAR; + + PERL_ARGS_ASSERT_QERROR; + if (PL_in_eval) sv_catsv(ERRSV, err); else if (PL_errors) sv_catsv(PL_errors, err); else - Perl_warn(aTHX_ "%"SVf, err); - ++PL_error_count; + Perl_warn(aTHX_ "%"SVf, SVfARG(err)); + if (PL_parser) + ++PL_parser->error_count; } OP * @@ -1409,15 +1534,15 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) if (PL_in_eval & EVAL_KEEPERR) { static const char prefix[] = "\t(in cleanup) "; SV * const err = ERRSV; - const char *e = Nullch; + const char *e = NULL; if (!SvPOK(err)) - sv_setpvn(err,"",0); + sv_setpvs(err,""); else if (SvCUR(err) >= sizeof(prefix)+msglen-1) { STRLEN len; e = SvPV_const(err, len); e += len - msglen; if (*e != *message || strNE(e,message)) - e = Nullch; + e = NULL; } if (!e) { SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen); @@ -1425,7 +1550,8 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) sv_catpvn(err, message, msglen); if (ckWARN(WARN_MISC)) { const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; - Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start); + Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", + SvPVX_const(err)+start); } } } @@ -1453,7 +1579,7 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) if (CxTYPE(cx) != CXt_EVAL) { if (!message) message = SvPVx_const(ERRSV, msglen); - PerlIO_write(Perl_error_log, "panic: die ", 11); + PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11); PerlIO_write(Perl_error_log, message, msglen); my_exit(1); } @@ -1472,7 +1598,7 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) PL_curcop = cx->blk_oldcop; if (optype == OP_REQUIRE) { - const char* msg = SvPVx_nolen_const(ERRSV); + const char* const msg = SvPVx_nolen_const(ERRSV); SV * const nsv = cx->blk_eval.old_namesv; (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), &PL_sv_undef, 0); @@ -1494,66 +1620,16 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) PP(pp_xor) { - dSP; dPOPTOPssrl; + dVAR; dSP; dPOPTOPssrl; if (SvTRUE(left) != SvTRUE(right)) RETSETYES; else RETSETNO; } -PP(pp_andassign) -{ - dSP; - if (!SvTRUE(TOPs)) - RETURN; - else - RETURNOP(cLOGOP->op_other); -} - -PP(pp_orassign) -{ - dSP; - if (SvTRUE(TOPs)) - RETURN; - else - RETURNOP(cLOGOP->op_other); -} - -PP(pp_dorassign) -{ - dSP; - register SV* sv; - - sv = TOPs; - if (!sv || !SvANY(sv)) { - RETURNOP(cLOGOP->op_other); - } - - switch (SvTYPE(sv)) { - case SVt_PVAV: - if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) - RETURN; - break; - case SVt_PVHV: - if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) - RETURN; - break; - case SVt_PVCV: - if (CvROOT(sv) || CvXSUB(sv)) - RETURN; - break; - default: - if (SvGMAGICAL(sv)) - mg_get(sv); - if (SvOK(sv)) - RETURN; - } - - RETURNOP(cLOGOP->op_other); -} - PP(pp_caller) { + dVAR; dSP; register I32 cxix = dopoptosub(cxstack_ix); register const PERL_CONTEXT *cx; @@ -1612,48 +1688,48 @@ PP(pp_caller) RETURN; } - EXTEND(SP, 10); + EXTEND(SP, 11); if (!stashname) PUSHs(&PL_sv_undef); else - PUSHs(sv_2mortal(newSVpv(stashname, 0))); - PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0))); - PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop)))); + mPUSHs(newSVpv(stashname, 0)); + mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0)); + mPUSHi((I32)CopLINE(cx->blk_oldcop)); if (!MAXARG) RETURN; if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { - GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv); + GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv); /* So is ccstack[dbcxix]. */ if (isGV(cvgv)) { - SV * const sv = NEWSV(49, 0); - gv_efullname3(sv, cvgv, Nullch); - PUSHs(sv_2mortal(sv)); - PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); + SV * const sv = newSV(0); + gv_efullname3(sv, cvgv, NULL); + mPUSHs(sv); + PUSHs(boolSV(CxHASARGS(cx))); } else { - PUSHs(sv_2mortal(newSVpvn("(unknown)",9))); - PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); + PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP)); + PUSHs(boolSV(CxHASARGS(cx))); } } else { - PUSHs(sv_2mortal(newSVpvn("(eval)",6))); - PUSHs(sv_2mortal(newSViv(0))); + PUSHs(newSVpvs_flags("(eval)", SVs_TEMP)); + mPUSHi(0); } gimme = (I32)cx->blk_gimme; if (gimme == G_VOID) PUSHs(&PL_sv_undef); else - PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY))); + PUSHs(boolSV((gimme & G_WANT) == G_ARRAY)); if (CxTYPE(cx) == CXt_EVAL) { /* eval STRING */ - if (cx->blk_eval.old_op_type == OP_ENTEREVAL) { + if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) { PUSHs(cx->blk_eval.cur_text); PUSHs(&PL_sv_no); } /* require */ else if (cx->blk_eval.old_namesv) { - PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv))); + mPUSHs(newSVsv(cx->blk_eval.old_namesv)); PUSHs(&PL_sv_yes); } /* eval BLOCK (try blocks have old_namesv == 0) */ @@ -1666,17 +1742,15 @@ PP(pp_caller) PUSHs(&PL_sv_undef); PUSHs(&PL_sv_undef); } - if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs + if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx) && CopSTASH_eq(PL_curcop, PL_debstash)) { AV * const ary = cx->blk_sub.argarray; const int off = AvARRAY(ary) - AvALLOC(ary); if (!PL_dbargs) { - GV* tmpgv; - PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE, - SVt_PVAV))); - GvMULTI_on(tmpgv); + PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI, + SVt_PVAV))); AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ } @@ -1688,11 +1762,10 @@ PP(pp_caller) /* XXX only hints propagated via op_private are currently * visible (others are not easily accessible, since they * use the global PL_hints) */ - PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private & - HINT_PRIVATE_MASK))); + mPUSHi(CopHINTS_get(cx->blk_oldcop)); { SV * mask ; - SV * old_warnings = cx->blk_oldcop->cop_warnings ; + STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ; if (old_warnings == pWARN_NONE || (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) @@ -1702,8 +1775,8 @@ PP(pp_caller) /* 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))) { + HV * const bits = get_hv("warnings::Bits", 0); + if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) { mask = newSVsv(*bits_all); } else { @@ -1711,31 +1784,28 @@ PP(pp_caller) } } else - mask = newSVsv(old_warnings); - PUSHs(sv_2mortal(mask)); + mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]); + mPUSHs(mask); } + + PUSHs(cx->blk_oldcop->cop_hints_hash ? + sv_2mortal(newRV_noinc( + MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_ + cx->blk_oldcop->cop_hints_hash)))) + : &PL_sv_undef); RETURN; } PP(pp_reset) { + dVAR; dSP; - const char *tmps; - - if (MAXARG < 1) - tmps = ""; - else - tmps = POPpconstx; + const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx; sv_reset(tmps, CopSTASH(PL_curcop)); PUSHs(&PL_sv_yes); RETURN; } -PP(pp_lineseq) -{ - return NORMAL; -} - /* like pp_nextstate, but used instead when the debugger is active */ PP(pp_dbstate) @@ -1750,14 +1820,12 @@ PP(pp_dbstate) || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace)) { dSP; - register CV *cv; register PERL_CONTEXT *cx; const I32 gimme = G_ARRAY; U8 hasargs; - GV *gv; + GV * const gv = PL_DBgv; + register CV * const cv = GvCV(gv); - gv = PL_DBgv; - cv = GvCV(gv); if (!cv) DIE(aTHX_ "No DB::DB routine defined"); @@ -1774,32 +1842,38 @@ PP(pp_dbstate) hasargs = 0; SPAGAIN; - PUSHBLOCK(cx, CXt_SUB, SP); - PUSHSUB_DB(cx); - cx->blk_sub.retop = PL_op->op_next; - CvDEPTH(cv)++; - SAVECOMPPAD(); - PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); - RETURNOP(CvSTART(cv)); + if (CvISXSUB(cv)) { + CvDEPTH(cv)++; + PUSHMARK(SP); + (void)(*CvXSUB(cv))(aTHX_ cv); + CvDEPTH(cv)--; + FREETMPS; + LEAVE; + return NORMAL; + } + else { + PUSHBLOCK(cx, CXt_SUB, SP); + PUSHSUB_DB(cx); + cx->blk_sub.retop = PL_op->op_next; + CvDEPTH(cv)++; + SAVECOMPPAD(); + PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1); + RETURNOP(CvSTART(cv)); + } } else return NORMAL; } -PP(pp_scope) -{ - return NORMAL; -} - PP(pp_enteriter) { dVAR; dSP; dMARK; register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; SV **svp; - U32 cxtype = CXt_LOOP; + U8 cxtype = CXt_LOOP_FOR; #ifdef USE_ITHREADS - void *iterdata; + PAD *iterdata; #endif ENTER; @@ -1811,70 +1885,111 @@ PP(pp_enteriter) SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ), SVs_PADSTALE, SVs_PADSTALE); } + SAVEPADSVANDMORTALIZE(PL_op->op_targ); #ifndef USE_ITHREADS svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */ - SAVESPTR(*svp); #else - SAVEPADSV(PL_op->op_targ); - iterdata = INT2PTR(void*, PL_op->op_targ); - cxtype |= CXp_PADVAR; + iterdata = NULL; #endif } else { - GV *gv = (GV*)POPs; + GV * const gv = MUTABLE_GV(POPs); svp = &GvSV(gv); /* symbol table variable */ SAVEGENERICSV(*svp); - *svp = NEWSV(0,0); + *svp = newSV(0); #ifdef USE_ITHREADS - iterdata = (void*)gv; + iterdata = (PAD*)gv; #endif } + if (PL_op->op_private & OPpITER_DEF) + cxtype |= CXp_FOR_DEF; + ENTER; PUSHBLOCK(cx, cxtype, SP); #ifdef USE_ITHREADS - PUSHLOOP(cx, iterdata, MARK); + PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ); #else - PUSHLOOP(cx, svp, MARK); + PUSHLOOP_FOR(cx, svp, MARK, 0); #endif if (PL_op->op_flags & OPf_STACKED) { - cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); - if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) { + SV *maybe_ary = POPs; + if (SvTYPE(maybe_ary) != SVt_PVAV) { dPOPss; - SV *right = (SV*)cx->blk_loop.iterary; + SV * const right = maybe_ary; + SvGETMAGIC(sv); + SvGETMAGIC(right); if (RANGE_IS_NUMERIC(sv,right)) { - if ((SvOK(sv) && SvNV(sv) < IV_MIN) || - (SvOK(right) && SvNV(right) >= IV_MAX)) + cx->cx_type &= ~CXTYPEMASK; + cx->cx_type |= CXt_LOOP_LAZYIV; + /* Make sure that no-one re-orders cop.h and breaks our + assumptions */ + assert(CxTYPE(cx) == CXt_LOOP_LAZYIV); +#ifdef NV_PRESERVES_UV + if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) || + (SvNV(sv) > (NV)IV_MAX))) + || + (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) || + (SvNV(right) < (NV)IV_MIN)))) +#else + if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN) + || + ((SvNV(sv) > 0) && + ((SvUV(sv) > (UV)IV_MAX) || + (SvNV(sv) > (NV)UV_MAX))))) + || + (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN) + || + ((SvNV(right) > 0) && + ((SvUV(right) > (UV)IV_MAX) || + (SvNV(right) > (NV)UV_MAX)))))) +#endif DIE(aTHX_ "Range iterator outside integer range"); - cx->blk_loop.iterix = SvIV(sv); - cx->blk_loop.itermax = SvIV(right); + cx->blk_loop.state_u.lazyiv.cur = SvIV(sv); + cx->blk_loop.state_u.lazyiv.end = SvIV(right); #ifdef DEBUGGING /* for correct -Dstv display */ cx->blk_oldsp = sp - PL_stack_base; #endif } else { - cx->blk_loop.iterlval = newSVsv(sv); - (void) SvPV_force_nolen(cx->blk_loop.iterlval); + cx->cx_type &= ~CXTYPEMASK; + cx->cx_type |= CXt_LOOP_LAZYSV; + /* Make sure that no-one re-orders cop.h and breaks our + assumptions */ + assert(CxTYPE(cx) == CXt_LOOP_LAZYSV); + cx->blk_loop.state_u.lazysv.cur = newSVsv(sv); + cx->blk_loop.state_u.lazysv.end = right; + SvREFCNT_inc(right); + (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur); + /* This will do the upgrade to SVt_PV, and warn if the value + is uninitialised. */ (void) SvPV_nolen_const(right); + /* Doing this avoids a check every time in pp_iter in pp_hot.c + to replace !SvOK() with a pointer to "". */ + if (!SvOK(right)) { + SvREFCNT_dec(right); + cx->blk_loop.state_u.lazysv.end = &PL_sv_no; + } } } - else if (PL_op->op_private & OPpITER_REVERSED) { - cx->blk_loop.itermax = -1; - cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary); - + else /* SvTYPE(maybe_ary) == SVt_PVAV */ { + cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary); + SvREFCNT_inc(maybe_ary); + cx->blk_loop.state_u.ary.ix = + (PL_op->op_private & OPpITER_REVERSED) ? + AvFILL(cx->blk_loop.state_u.ary.ary) + 1 : + -1; } } - else { - cx->blk_loop.iterary = PL_curstack; - AvFILLp(PL_curstack) = SP - PL_stack_base; + else { /* iterating over items on the stack */ + cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */ if (PL_op->op_private & OPpITER_REVERSED) { - cx->blk_loop.itermax = MARK - PL_stack_base; - cx->blk_loop.iterix = cx->blk_oldsp; + cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1; } else { - cx->blk_loop.iterix = MARK - PL_stack_base; + cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base; } } @@ -1891,8 +2006,8 @@ PP(pp_enterloop) SAVETMPS; ENTER; - PUSHBLOCK(cx, CXt_LOOP, SP); - PUSHLOOP(cx, 0, SP); + PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP); + PUSHLOOP_PLAIN(cx, SP); RETURN; } @@ -1907,13 +2022,13 @@ PP(pp_leaveloop) SV **mark; POPBLOCK(cx,newpm); - assert(CxTYPE(cx) == CXt_LOOP); + assert(CxTYPE_is_LOOP(cx)); mark = newsp; newsp = PL_stack_base + cx->blk_loop.resetsp; TAINT_NOT; if (gimme == G_VOID) - ; /* do nothing */ + NOOP; else if (gimme == G_SCALAR) { if (mark < SP) *++newsp = sv_mortalcopy(*SP); @@ -1941,7 +2056,6 @@ PP(pp_leaveloop) PP(pp_return) { dVAR; dSP; dMARK; - I32 cxix; register PERL_CONTEXT *cx; bool popsub2 = FALSE; bool clear_errsv = FALSE; @@ -1952,24 +2066,34 @@ PP(pp_return) SV *sv; OP *retop; - if (PL_curstackinfo->si_type == PERLSI_SORT) { - if (cxstack_ix == PL_sortcxix - || dopoptosub(cxstack_ix) <= PL_sortcxix) - { - if (cxstack_ix > PL_sortcxix) - dounwind(PL_sortcxix); - AvARRAY(PL_curstack)[1] = *SP; + const I32 cxix = dopoptosub(cxstack_ix); + + if (cxix < 0) { + if (CxMULTICALL(cxstack)) { /* In this case we must be in a + * sort block, which is a CXt_NULL + * not a CXt_SUB */ + dounwind(0); + PL_stack_base[1] = *PL_stack_sp; PL_stack_sp = PL_stack_base + 1; return 0; } + else + DIE(aTHX_ "Can't return outside a subroutine"); } - - cxix = dopoptosub(cxstack_ix); - if (cxix < 0) - DIE(aTHX_ "Can't return outside a subroutine"); if (cxix < cxstack_ix) dounwind(cxix); + if (CxMULTICALL(&cxstack[cxix])) { + gimme = cxstack[cxix].blk_gimme; + if (gimme == G_VOID) + PL_stack_sp = PL_stack_base; + else if (gimme == G_SCALAR) { + PL_stack_base[1] = *PL_stack_sp; + PL_stack_sp = PL_stack_base + 1; + } + return 0; + } + POPBLOCK(cx,newpm); switch (CxTYPE(cx)) { case CXt_SUB: @@ -1991,7 +2115,7 @@ PP(pp_return) /* Unassume the success we assumed earlier. */ SV * const nsv = cx->blk_eval.old_namesv; (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); - DIE(aTHX_ "%"SVf" did not return a true value", nsv); + DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv)); } break; case CXt_FORMAT: @@ -2044,12 +2168,13 @@ PP(pp_return) POPSUB(cx,sv); /* release CV and @_ ... */ } else - sv = Nullsv; + sv = NULL; PL_curpm = newpm; /* ... and pop $1 et al */ LEAVESUB(sv); - if (clear_errsv) - sv_setpvn(ERRSV,"",0); + if (clear_errsv) { + CLEAR_ERRSV(); + } return retop; } @@ -2065,7 +2190,7 @@ PP(pp_last) SV **newsp; PMOP *newpm; SV **mark; - SV *sv = Nullsv; + SV *sv = NULL; if (PL_op->op_flags & OPf_SPECIAL) { @@ -2085,10 +2210,13 @@ PP(pp_last) cxstack_ix++; /* temporarily protect top context */ mark = newsp; switch (CxTYPE(cx)) { - case CXt_LOOP: - pop2 = CXt_LOOP; + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: + pop2 = CxTYPE(cx); newsp = PL_stack_base + cx->blk_loop.resetsp; - nextop = cx->blk_loop.last_op->op_next; + nextop = cx->blk_loop.my_op->op_lastop->op_next; break; case CXt_SUB: pop2 = CXt_SUB; @@ -2128,7 +2256,10 @@ PP(pp_last) cxstack_ix--; /* Stack values are safe: */ switch (pop2) { - case CXt_LOOP: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_PLAIN: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: POPLOOP(cx); /* release loop vars ... */ LEAVE; break; @@ -2171,7 +2302,7 @@ PP(pp_next) if (PL_scopestack_ix < inner) leave_scope(PL_scopestack[PL_scopestack_ix]); PL_curcop = cx->blk_oldcop; - return cx->blk_loop.next_op; + return CX_LOOP_NEXTOP_GET(cx); } PP(pp_redo) @@ -2195,7 +2326,7 @@ PP(pp_redo) if (cxix < cxstack_ix) dounwind(cxix); - redo_op = cxstack[cxix].blk_loop.redo_op; + redo_op = cxstack[cxix].blk_loop.my_op->op_redoop; if (redo_op->op_type == OP_ENTER) { /* pop one less context to avoid $x being freed in while (my $x..) */ cxstack_ix++; @@ -2214,9 +2345,12 @@ PP(pp_redo) STATIC OP * S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) { + dVAR; OP **ops = opstack; static const char too_deep[] = "Target of goto is too deeply nested"; + PERL_ARGS_ASSERT_DOFINDLABEL; + if (ops >= oplimit) Perl_croak(aTHX_ too_deep); if (o->op_type == OP_LEAVE || @@ -2235,7 +2369,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) /* First try all the kids at this level, since that's likeliest. */ for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) && - kCOP->cop_label && strEQ(kCOP->cop_label, label)) + CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label)) return kid; } for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { @@ -2258,21 +2392,15 @@ S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit) return 0; } -PP(pp_dump) -{ - return pp_goto(); - /*NOTREACHED*/ -} - PP(pp_goto) { dVAR; dSP; - OP *retop = 0; + OP *retop = NULL; I32 ix; register PERL_CONTEXT *cx; #define GOTO_DEPTH 64 OP *enterops[GOTO_DEPTH]; - const char *label = 0; + const char *label = NULL; const bool do_dump = (PL_op->op_type == OP_DUMP); static const char must_have_label[] = "goto must have label"; @@ -2283,7 +2411,7 @@ PP(pp_goto) if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { I32 cxix; register PERL_CONTEXT *cx; - CV* cv = (CV*)SvRV(sv); + CV *cv = MUTABLE_CV(SvRV(sv)); SV** mark; I32 items = 0; I32 oldsave; @@ -2303,14 +2431,14 @@ PP(pp_goto) if (autogv && (cv = GvCV(autogv))) goto retry; tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, gv, Nullch); - DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr); + gv_efullname3(tmpstr, gv, NULL); + DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr)); } DIE(aTHX_ "Goto undefined subroutine"); } /* First do some returnish stuff. */ - (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */ + SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */ FREETMPS; cxix = dopoptosub(cxstack_ix); if (cxix < 0) @@ -2326,7 +2454,9 @@ PP(pp_goto) else DIE(aTHX_ "Can't goto subroutine from an eval-block"); } - if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) { + else if (CxMULTICALL(cx)) + DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)"); + if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { /* put @_ back onto stack */ AV* av = cx->blk_sub.argarray; @@ -2343,10 +2473,10 @@ PP(pp_goto) av = newAV(); av_extend(av, items-1); AvREIFY_only(av); - PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av); + PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av); } } - else if (CvXSUB(cv)) { /* put GvAV(defgv) back onto stack */ + else if (CvISXSUB(cv)) { /* put GvAV(defgv) back onto stack */ AV* const av = GvAV(PL_defgv); items = AvFILLp(av) + 1; EXTEND(SP, items+1); /* @_ could have been extended. */ @@ -2363,87 +2493,65 @@ PP(pp_goto) /* Now do some callish stuff. */ SAVETMPS; SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ - if (CvXSUB(cv)) { - OP* retop = cx->blk_sub.retop; + if (CvISXSUB(cv)) { + OP* const retop = cx->blk_sub.retop; + SV **newsp; + I32 gimme; if (reified) { I32 index; for (index=0; index mark) { - SP[1] = SP[0]; - SP--; - } - fp3 = (I32(*)(int,int,int))CvXSUB(cv); - items = (*fp3)(CvXSUBANY(cv).any_i32, - mark - PL_stack_base + 1, - items); - SP = PL_stack_base + items; - } - else -#endif /* PERL_XSUB_OLDSTYLE */ - { - SV **newsp; - I32 gimme; - /* 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); - /* Put these at the bottom since the vars are set but not used */ - PERL_UNUSED_VAR(newsp); - PERL_UNUSED_VAR(gimme); - } + /* 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); LEAVE; return retop; } else { - AV* padlist = CvPADLIST(cv); + AV* const padlist = CvPADLIST(cv); if (CxTYPE(cx) == CXt_EVAL) { - PL_in_eval = cx->blk_eval.old_in_eval; + PL_in_eval = CxOLD_IN_EVAL(cx); PL_eval_root = cx->blk_eval.old_eval_root; cx->cx_type = CXt_SUB; - cx->blk_sub.hasargs = 0; } cx->blk_sub.cv = cv; - cx->blk_sub.olddepth = (U16)CvDEPTH(cv); + cx->blk_sub.olddepth = CvDEPTH(cv); CvDEPTH(cv)++; if (CvDEPTH(cv) < 2) - (void)SvREFCNT_inc(cv); + SvREFCNT_inc_simple_void_NN(cv); else { - if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) + if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)) sub_crush_depth(cv); pad_push(padlist, CvDEPTH(cv)); } SAVECOMPPAD(); PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); - if (cx->blk_sub.hasargs) + if (CxHASARGS(cx)) { - AV* av = (AV*)PAD_SVl(0); - SV** ary; + AV *const av = MUTABLE_AV(PAD_SVl(0)); cx->blk_sub.savearray = GvAV(PL_defgv); - GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); + GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av)); CX_CURPAD_SAVE(cx->blk_sub); cx->blk_sub.argarray = av; if (items >= AvMAX(av) + 1) { - ary = AvALLOC(av); + SV **ary = AvALLOC(av); if (AvARRAY(av) != ary) { AvMAX(av) += AvARRAY(av) - AvALLOC(av); - SvPV_set(av, (char*)ary); + AvARRAY(av) = ary; } if (items >= AvMAX(av) + 1) { AvMAX(av) = items - 1; Renew(ary,items+1,SV*); AvALLOC(av) = ary; - SvPV_set(av, (char*)ary); + AvARRAY(av) = ary; } } ++mark; @@ -2462,28 +2570,14 @@ PP(pp_goto) } } if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ - /* - * We do not care about using sv to call CV; - * it's for informational purposes only. - */ - SV * const sv = GvSV(PL_DBsub); - CV *gotocv; - - save_item(sv); - if (PERLDB_SUB_NN) { - const 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 { - gv_efullname3(sv, CvGV(cv), Nullch); - } - if ( PERLDB_GOTO - && (gotocv = get_cv("DB::goto", FALSE)) ) { - PUSHMARK( PL_stack_sp ); - call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG); - PL_stack_sp--; + Perl_get_db_sub(aTHX_ NULL, cv); + if (PERLDB_GOTO) { + CV * const gotocv = get_cvs("DB::goto", 0); + if (gotocv) { + PUSHMARK( PL_stack_sp ); + call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG); + PL_stack_sp--; + } } } RETURNOP(CvSTART(cv)); @@ -2503,14 +2597,14 @@ PP(pp_goto) label = cPVOP->op_pv; if (label && *label) { - OP *gotoprobe = 0; + OP *gotoprobe = NULL; bool leaving_eval = FALSE; bool in_block = FALSE; - PERL_CONTEXT *last_eval_cx = 0; + PERL_CONTEXT *last_eval_cx = NULL; /* find label */ - PL_lastgotoprobe = 0; + PL_lastgotoprobe = NULL; *enterops = 0; for (ix = cxstack_ix; ix >= 0; ix--) { cx = &cxstack[ix]; @@ -2525,7 +2619,12 @@ PP(pp_goto) break; } /* else fall through */ - case CXt_LOOP: + case CXt_LOOP_LAZYIV: + case CXt_LOOP_LAZYSV: + case CXt_LOOP_FOR: + case CXt_LOOP_PLAIN: + case CXt_GIVEN: + case CXt_WHEN: gotoprobe = cx->blk_oldcop->op_sibling; break; case CXt_SUBST: @@ -2538,7 +2637,7 @@ PP(pp_goto) gotoprobe = PL_main_root; break; case CXt_SUB: - if (CvDEPTH(cx->blk_sub.cv)) { + if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) { gotoprobe = CvROOT(cx->blk_sub.cv); break; } @@ -2590,7 +2689,7 @@ PP(pp_goto) /* push wanted frames */ if (*enterops && enterops[1]) { - OP *oldop = PL_op; + OP * const oldop = PL_op; ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1; for (; enterops[ix]; ix++) { PL_op = enterops[ix]; @@ -2622,6 +2721,7 @@ PP(pp_goto) PP(pp_exit) { + dVAR; dSP; I32 anum; @@ -2636,51 +2736,17 @@ PP(pp_exit) #endif } PL_exit_flags |= PERL_EXIT_EXPECTED; +#ifdef PERL_MAD + /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */ + if (anum || !(PL_minus_c && PL_madskills)) + my_exit(anum); +#else my_exit(anum); +#endif PUSHs(&PL_sv_undef); RETURN; } -#ifdef NOTYET -PP(pp_nswitch) -{ - dSP; - const NV value = SvNVx(GvSV(cCOP->cop_gv)); - register I32 match = I_32(value); - - if (value < 0.0) { - if (((NV)match) > value) - --match; /* was fractional--truncate other way */ - } - match -= cCOP->uop.scop.scop_offset; - if (match < 0) - match = 0; - else if (match > cCOP->uop.scop.scop_max) - match = cCOP->uop.scop.scop_max; - PL_op = cCOP->uop.scop.scop_next[match]; - RETURNOP(PL_op); -} - -PP(pp_cswitch) -{ - dSP; - register I32 match; - - if (PL_multiline) - PL_op = PL_op->op_next; /* can't assume anything */ - else { - match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255; - match -= cCOP->uop.scop.scop_offset; - if (match < 0) - match = 0; - else if (match > cCOP->uop.scop.scop_max) - match = cCOP->uop.scop.scop_max; - PL_op = cCOP->uop.scop.scop_next[match]; - } - RETURNOP(PL_op); -} -#endif - /* Eval. */ STATIC void @@ -2690,12 +2756,13 @@ S_save_lines(pTHX_ AV *array, SV *sv) const char * const send = SvPVX_const(sv) + SvCUR(sv); I32 line = 1; + PERL_ARGS_ASSERT_SAVE_LINES; + while (s && s < send) { const char *t; - SV * const tmpstr = NEWSV(85,0); + SV * const tmpstr = newSV_type(SVt_PVMG); - sv_upgrade(tmpstr, SVt_PVMG); - t = strchr(s, '\n'); + t = (const char *)memchr(s, '\n', send - s); if (t) t++; else @@ -2707,16 +2774,10 @@ S_save_lines(pTHX_ AV *array, SV *sv) } } -STATIC void -S_docatch_body(pTHX) -{ - CALLRUNOPS(aTHX); - return; -} - STATIC OP * S_docatch(pTHX_ OP *o) { + dVAR; int ret; OP * const oldop = PL_op; dJMPENV; @@ -2733,7 +2794,7 @@ S_docatch(pTHX_ OP *o) assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL); cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env; redo_body: - docatch_body(); + CALLRUNOPS(aTHX); break; case 3: /* die caught by an inner eval - continue inner loop */ @@ -2761,7 +2822,7 @@ S_docatch(pTHX_ OP *o) } JMPENV_POP; PL_op = oldop; - return Nullop; + return NULL; } OP * @@ -2770,21 +2831,24 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) /* startop op_free() this to undo. */ /* code Short string id of the caller. */ { + /* FIXME - how much of this code is common with pp_entereval? */ dVAR; dSP; /* Make POPBLOCK work. */ PERL_CONTEXT *cx; SV **newsp; I32 gimme = G_VOID; I32 optype; OP dummy; - OP *rop; char tbuf[TYPE_DIGITS(long) + 12 + 10]; char *tmpbuf = tbuf; char *safestr; int runtime; - CV* runcv = Nullcv; /* initialise to avoid compiler warnings */ + CV* runcv = NULL; /* initialise to avoid compiler warnings */ + STRLEN len; + + PERL_ARGS_ASSERT_SV_COMPILE_2OP; ENTER; - lex_start(sv); + lex_start(sv, NULL, FALSE); SAVETMPS; /* switch to eval mode */ @@ -2798,9 +2862,11 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) code, (unsigned long)++PL_evalseq, CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); tmpbuf = SvPVX(sv); + len = SvCUR(sv); } else - sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq); + len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code, + (unsigned long)++PL_evalseq); SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); SAVECOPLINE(&PL_compiling); @@ -2810,8 +2876,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) (i.e. before run-time proper). To work around the coredump that ensues, we always turn GvMULTI_on for any globals that were introduced within evals. See force_ident(). GSAR 96-10-12 */ - safestr = savepv(tmpbuf); - SAVEDELETE(PL_defstash, safestr, strlen(safestr)); + safestr = savepvn(tmpbuf, len); + SAVEDELETE(PL_defstash, safestr, len); SAVEHINTS(); #ifdef OP_IN_REGISTER PL_opsave = op; @@ -2828,12 +2894,12 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) PL_op->op_type = OP_ENTEREVAL; PL_op->op_flags = 0; /* Avoid uninit warning. */ PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP); - PUSHEVAL(cx, 0, Nullgv); + PUSHEVAL(cx, 0); if (runtime) - rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); + (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq); else - rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); + (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax); POPBLOCK(cx,PL_curpm); POPEVAL(cx); @@ -2841,17 +2907,17 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) (*startop)->op_ppaddr = PL_ppaddr[OP_NULL]; lex_end(); /* XXX DAPM do this properly one year */ - *padp = (AV*)SvREFCNT_inc(PL_comppad); + *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad)); LEAVE; if (IN_PERL_COMPILETIME) - PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); + CopHINTS_set(&PL_compiling, PL_hints); #ifdef OP_IN_REGISTER op = PL_opsave; #endif PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(optype); - return rop; + return PL_eval_start; } @@ -2870,6 +2936,7 @@ than in the scope of the debugger itself). CV* Perl_find_runcv(pTHX_ U32 *db_seqp) { + dVAR; PERL_SI *si; if (db_seqp) @@ -2899,10 +2966,12 @@ Perl_find_runcv(pTHX_ U32 *db_seqp) * 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. + * Returns a bool indicating whether the compile was successful; if so, + * PL_eval_start contains the first op of the compiled ocde; otherwise, + * pushes undef (also croaks if startop != NULL). */ -/* With USE_5005THREADS, eval_owner must be held on entry to doeval */ -STATIC OP * +STATIC bool S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) { dVAR; dSP; @@ -2915,21 +2984,22 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PUSHMARK(SP); SAVESPTR(PL_compcv); - PL_compcv = (CV*)NEWSV(1104,0); - sv_upgrade((SV *)PL_compcv, SVt_PVCV); + PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); CvEVAL_on(PL_compcv); 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); + CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside)); /* set up a scratch pad */ CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); + PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */ - SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ + if (!PL_madskills) + SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */ /* make sure we compile in the right package */ @@ -2937,22 +3007,29 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) SAVESPTR(PL_curstash); PL_curstash = CopSTASH(PL_curcop); } + /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */ SAVESPTR(PL_beginav); PL_beginav = newAV(); SAVEFREESV(PL_beginav); - SAVEI32(PL_error_count); + SAVESPTR(PL_unitcheckav); + PL_unitcheckav = newAV(); + SAVEFREESV(PL_unitcheckav); + +#ifdef PERL_MAD + SAVEBOOL(PL_madskills); + PL_madskills = 0; +#endif /* try to compile it */ - PL_eval_root = Nullop; - PL_error_count = 0; + PL_eval_root = NULL; PL_curcop = &PL_compiling; - PL_curcop->cop_arybase = 0; - if (saveop && saveop->op_flags & OPf_SPECIAL) + CopARYBASE_set(PL_curcop, 0); + if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL)) PL_in_eval |= EVAL_KEEPERR; else - sv_setpvn(ERRSV,"",0); - if (yyparse() || PL_error_count || !PL_eval_root) { + CLEAR_ERRSV(); + if (yyparse() || PL_parser->error_count || !PL_eval_root) { SV **newsp; /* Used by POPBLOCK. */ PERL_CONTEXT *cx = &cxstack[cxstack_ix]; I32 optype = 0; /* Might be reset by POPEVAL. */ @@ -2961,7 +3038,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) PL_op = saveop; if (PL_eval_root) { op_free(PL_eval_root); - PL_eval_root = Nullop; + PL_eval_root = NULL; } SP = PL_stack_base + POPMARK; /* pop original mark */ if (!startop) { @@ -2969,15 +3046,15 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) POPEVAL(cx); } lex_end(); - LEAVE; + LEAVE; /* pp_entereval knows about this LEAVE. */ msg = SvPVx_nolen_const(ERRSV); if (optype == OP_REQUIRE) { const SV * const 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"); + Perl_croak(aTHX_ "%sCompilation failed in require", + *msg ? msg : "Unknown error\n"); } else if (startop) { POPBLOCK(cx,PL_curpm); @@ -2987,11 +3064,13 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) } else { if (!*msg) { - sv_setpv(ERRSV, "Compilation error"); + sv_setpvs(ERRSV, "Compilation error"); } } PERL_UNUSED_VAR(newsp); - RETPUSHUNDEF; + PUSHs(&PL_sv_undef); + PUTBACK; + return FALSE; } CopLINE_set(&PL_compiling, 0); if (startop) { @@ -3007,9 +3086,9 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type == OP_REQUIRE) scalar(PL_eval_root); - else if (gimme & G_VOID) + else if ((gimme & G_WANT) == G_VOID) scalarvoid(PL_eval_root); - else if (gimme & G_ARRAY) + else if ((gimme & G_WANT) == G_ARRAY) list(PL_eval_root); else scalar(PL_eval_root); @@ -3017,62 +3096,79 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) DEBUG_x(dump_eval()); /* Register with debugger: */ - if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { - CV * const cv = get_cv("DB::postponed", FALSE); + if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) { + CV * const cv = get_cvs("DB::postponed", 0); if (cv) { dSP; PUSHMARK(SP); - XPUSHs((SV*)CopFILEGV(&PL_compiling)); + XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); PUTBACK; - call_sv((SV*)cv, G_DISCARD); + call_sv(MUTABLE_SV(cv), G_DISCARD); } } + if (PL_unitcheckav) + call_list(PL_scopestack_ix, PL_unitcheckav); + /* compiled okay, so do it */ CvDEPTH(PL_compcv) = 1; SP = PL_stack_base + POPMARK; /* pop original mark */ PL_op = saveop; /* The caller may need it. */ - PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */ + PL_parser->lex_state = LEX_NOTPARSING; /* $^S needs this. */ - RETURNOP(PL_eval_start); + PUTBACK; + return TRUE; } STATIC PerlIO * -S_doopen_pm(pTHX_ const char *name, const char *mode) +S_check_type_and_open(pTHX_ const char *name) { + Stat_t st; + const int st_rc = PerlLIO_stat(name, &st); + + PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN; + + if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { + return NULL; + } + + return PerlIO_open(name, PERL_SCRIPT_MODE); +} + #ifndef PERL_DISABLE_PMC - const STRLEN namelen = strlen(name); +STATIC PerlIO * +S_doopen_pm(pTHX_ const char *name, const STRLEN namelen) +{ PerlIO *fp; - if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) { - SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c'); - const char * const pmc = SvPV_nolen_const(pmcsv); + PERL_ARGS_ASSERT_DOOPEN_PM; + + if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) { + SV *const pmcsv = newSV(namelen + 2); + char *const pmc = SvPVX(pmcsv); Stat_t pmcstat; + + memcpy(pmc, name, namelen); + pmc[namelen] = 'c'; + pmc[namelen + 1] = '\0'; + if (PerlLIO_stat(pmc, &pmcstat) < 0) { - fp = PerlIO_open(name, mode); + fp = check_type_and_open(name); } else { - Stat_t pmstat; - if (PerlLIO_stat(name, &pmstat) < 0 || - pmstat.st_mtime < pmcstat.st_mtime) - { - fp = PerlIO_open(pmc, mode); - } - else { - fp = PerlIO_open(name, mode); - } + fp = check_type_and_open(pmc); } SvREFCNT_dec(pmcsv); } else { - fp = PerlIO_open(name, mode); + fp = check_type_and_open(name); } return fp; +} #else - return PerlIO_open(name, mode); +# define doopen_pm(name, namelen) check_type_and_open(name) #endif /* !PERL_DISABLE_PMC */ -} PP(pp_require) { @@ -3081,89 +3177,165 @@ PP(pp_require) SV *sv; const char *name; STRLEN len; - const char *tryname = Nullch; - SV *namesv = Nullsv; - SV** svp; + char * unixname; + STRLEN unixlen; +#ifdef VMS + int vms_unixname = 0; +#endif + const char *tryname = NULL; + SV *namesv = NULL; const I32 gimme = GIMME_V; - PerlIO *tryrsfp = 0; int filter_has_file = 0; - GV *filter_child_proc = 0; - SV *filter_state = 0; - SV *filter_sub = 0; - SV *hook_sv = 0; + PerlIO *tryrsfp = NULL; + SV *filter_cache = NULL; + SV *filter_state = NULL; + SV *filter_sub = NULL; + SV *hook_sv = NULL; SV *encoding; OP *op; sv = POPs; 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 %"SVf" required--this is only %"SVf", stopped", - vnormal(sv), vnormal(PL_patchlevel)); + upg_version(PL_patchlevel, TRUE); + if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { + if ( vcmp(sv,PL_patchlevel) <= 0 ) + DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped", + SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel))); + } + else { + if ( vcmp(sv,PL_patchlevel) > 0 ) { + I32 first = 0; + AV *lav; + SV * const req = SvRV(sv); + SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE); + + /* get the left hand term */ + lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE))); + + first = SvIV(*av_fetch(lav,0,0)); + if ( first > (int)PERL_REVISION /* probably 'use 6.0' */ + || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */ + || av_len(lav) > 1 /* FP with > 3 digits */ + || strstr(SvPVX(pv),".0") /* FP with leading 0 */ + ) { + DIE(aTHX_ "Perl %"SVf" required--this is only " + "%"SVf", stopped", SVfARG(vnormal(req)), + SVfARG(vnormal(PL_patchlevel))); + } + else { /* probably 'use 5.10' or 'use 5.8' */ + SV * hintsv = newSV(0); + I32 second = 0; + + if (av_len(lav)>=1) + second = SvIV(*av_fetch(lav,1,0)); + + second /= second >= 600 ? 100 : 10; + hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d", + (int)first, (int)second,0); + upg_version(hintsv, TRUE); + + DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)" + "--this is only %"SVf", stopped", + SVfARG(vnormal(req)), + SVfARG(vnormal(hintsv)), + SVfARG(vnormal(PL_patchlevel))); + } + } + } - RETPUSHYES; + /* We do this only with use, not require. */ + if (PL_compcv && + /* If we request a version >= 5.9.5, load feature.pm with the + * feature bundle that corresponds to the required version. */ + vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { + SV *const importsv = vnormal(sv); + *SvPVX_mutable(importsv) = ':'; + ENTER; + Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); + LEAVE; + } + /* If a version >= 5.11.0 is requested, strictures are on by default! */ + if (PL_compcv && + vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) { + PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS); + } + + RETPUSHYES; } name = SvPV_const(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))) { - if (*svp != &PL_sv_undef) - RETPUSHYES; - else - DIE(aTHX_ "Compilation failed in require"); + + +#ifdef VMS + /* The key in the %ENV hash is in the syntax of file passed as the argument + * usually this is in UNIX format, but sometimes in VMS format, which + * can result in a module being pulled in more than once. + * To prevent this, the key must be stored in UNIX format if the VMS + * name can be translated to UNIX. + */ + if ((unixname = tounixspec(name, NULL)) != NULL) { + unixlen = strlen(unixname); + vms_unixname = 1; + } + else +#endif + { + /* if not VMS or VMS name can not be translated to UNIX, pass it + * through. + */ + unixname = (char *) name; + unixlen = len; + } + if (PL_op->op_type == OP_REQUIRE) { + SV * const * const svp = hv_fetch(GvHVn(PL_incgv), + unixname, unixlen, 0); + if ( svp ) { + if (*svp != &PL_sv_undef) + RETPUSHYES; + else + DIE(aTHX_ "Attempt to reload %s aborted.\n" + "Compilation failed in require", unixname); + } } /* prepare to compile file */ if (path_is_absolute(name)) { tryname = name; - tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE); - } -#ifdef MACOS_TRADITIONAL - if (!tryrsfp) { - char newname[256]; - - MacPerl_CanonDir(name, newname, 1); - if (path_is_absolute(newname)) { - tryname = newname; - tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE); - } + tryrsfp = doopen_pm(name, len); } -#endif if (!tryrsfp) { - AV *ar = GvAVn(PL_incgv); + AV * const ar = GvAVn(PL_incgv); I32 i; #ifdef VMS - char *unixname; - if ((unixname = tounixspec(name, Nullch)) != Nullch) + if (vms_unixname) #endif { - namesv = NEWSV(806, 0); + namesv = newSV_type(SVt_PV); for (i = 0; i <= AvFILL(ar); i++) { - SV *dirsv = *av_fetch(ar, i, TRUE); + SV * const dirsv = *av_fetch(ar, i, TRUE); + if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied)) + mg_get(dirsv); if (SvROK(dirsv)) { int count; + SV **svp; SV *loader = dirsv; if (SvTYPE(SvRV(loader)) == SVt_PVAV && !sv_isobject(loader)) { - loader = *av_fetch((AV *)SvRV(loader), 0, TRUE); + loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE); } Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s", PTR2UV(SvRV(dirsv)), name); tryname = SvPVX_const(namesv); - tryrsfp = 0; + tryrsfp = NULL; ENTER; SAVETMPS; @@ -3179,6 +3351,11 @@ PP(pp_require) count = call_sv(loader, G_ARRAY); SPAGAIN; + /* Adjust file name if the hook has set an %INC entry */ + svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); + if (svp) + tryname = SvPVX_const(*svp); + if (count > 0) { int i = 0; SV *arg; @@ -3186,34 +3363,32 @@ PP(pp_require) SP -= count - 1; arg = SP[i++]; - if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) { + if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV) + && !isGV_with_GP(SvRV(arg))) { + filter_cache = SvRV(arg); + SvREFCNT_inc_simple_void_NN(filter_cache); + + if (i < count) { + arg = SP[i++]; + } + } + + if (SvROK(arg) && isGV_with_GP(SvRV(arg))) { arg = SvRV(arg); } - if (SvTYPE(arg) == SVt_PVGV) { - IO *io = GvIO((GV *)arg); + if (isGV_with_GP(arg)) { + IO * const io = GvIO((const GV *)arg); ++filter_has_file; if (io) { tryrsfp = IoIFP(io); - if (IoTYPE(io) == IoTYPE_PIPE) { - /* reading from a child process doesn't - nest -- when returning from reading - the inner module, the outer one is - unreadable (closed?) I've tried to - save the gv to manage the lifespan of - the pipe, but this didn't help. XXX */ - filter_child_proc = (GV *)arg; - (void)SvREFCNT_inc(filter_child_proc); - } - else { - if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { - PerlIO_close(IoOFP(io)); - } - IoIFP(io) = Nullfp; - IoOFP(io) = Nullfp; + if (IoOFP(io) && IoOFP(io) != IoIFP(io)) { + PerlIO_close(IoOFP(io)); } + IoIFP(io) = NULL; + IoOFP(io) = NULL; } if (i < count) { @@ -3223,17 +3398,17 @@ PP(pp_require) if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { filter_sub = arg; - (void)SvREFCNT_inc(filter_sub); + SvREFCNT_inc_simple_void_NN(filter_sub); if (i < count) { filter_state = SP[i]; - (void)SvREFCNT_inc(filter_state); + SvREFCNT_inc_simple_void(filter_state); } + } - if (tryrsfp == 0) { - tryrsfp = PerlIO_open("/dev/null", - PERL_SCRIPT_MODE); - } + if (!tryrsfp && (filter_cache || filter_sub)) { + tryrsfp = PerlIO_open(BIT_BUCKET, + PERL_SCRIPT_MODE); } SP--; } @@ -3248,44 +3423,40 @@ PP(pp_require) } filter_has_file = 0; - if (filter_child_proc) { - SvREFCNT_dec(filter_child_proc); - filter_child_proc = 0; + if (filter_cache) { + SvREFCNT_dec(filter_cache); + filter_cache = NULL; } if (filter_state) { SvREFCNT_dec(filter_state); - filter_state = 0; + filter_state = NULL; } if (filter_sub) { SvREFCNT_dec(filter_sub); - filter_sub = 0; + filter_sub = NULL; } } else { if (!path_is_absolute(name) -#ifdef MACOS_TRADITIONAL - /* We consider paths of the form :a:b ambiguous and interpret them first - as global then as local - */ - || (*name == ':' && name[1] != ':' && strchr(name+2, ':')) -#endif ) { - const char *dir = SvPVx_nolen_const(dirsv); -#ifdef MACOS_TRADITIONAL - char buf1[256]; - char buf2[256]; + const char *dir; + STRLEN dirlen; - MacPerl_CanonDir(name, buf2, 1); - Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':')); -#else -# ifdef VMS + if (SvOK(dirsv)) { + dir = SvPV_const(dirsv, dirlen); + } else { + dir = ""; + dirlen = 0; + } + +#ifdef VMS char *unixdir; - if ((unixdir = tounixpath(dir, Nullch)) == Nullch) + if ((unixdir = tounixpath(dir, NULL)) == NULL) continue; sv_setpv(namesv, unixdir); sv_catpv(namesv, unixname); -# else -# ifdef SYMBIAN +#else +# ifdef __SYMBIAN32__ if (PL_origfilename[0] && PL_origfilename[1] == ':' && !(dir[0] && dir[1] == ':')) @@ -3297,19 +3468,42 @@ PP(pp_require) Perl_sv_setpvf(aTHX_ namesv, "%s\\%s", dir, name); -# else - Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); -# endif +# else + /* The equivalent of + Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); + but without the need to parse the format string, or + call strlen on either pointer, and with the correct + allocation up front. */ + { + char *tmp = SvGROW(namesv, dirlen + len + 2); + + memcpy(tmp, dir, dirlen); + tmp +=dirlen; + *tmp++ = '/'; + /* name came from an SV, so it will have a '\0' at the + end that we can copy as part of this memcpy(). */ + memcpy(tmp, name, len + 1); + + SvCUR_set(namesv, dirlen + len + 1); + + /* Don't even actually have to turn SvPOK_on() as we + access it directly with SvPVX() below. */ + } # endif #endif TAINT_PROPER("require"); tryname = SvPVX_const(namesv); - tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE); + tryrsfp = doopen_pm(tryname, SvCUR(namesv)); if (tryrsfp) { - if (tryname[0] == '.' && tryname[1] == '/') - tryname += 2; + if (tryname[0] == '.' && tryname[1] == '/') { + ++tryname; + while (*++tryname == '/'); + } break; } + else if (errno == EMFILE) + /* no point in trying other paths if out of handles */ + break; } } } @@ -3321,25 +3515,31 @@ PP(pp_require) if (!tryrsfp) { if (PL_op->op_type == OP_REQUIRE) { const char *msgstr = name; - if (namesv) { /* did we lookup @INC? */ - SV *msg = sv_2mortal(newSVpv(msgstr,0)); - SV *dirmsgsv = NEWSV(0, 0); - AV *ar = GvAVn(PL_incgv); - I32 i; - sv_catpvn(msg, " in @INC", 8); - if (instr(SvPVX_const(msg), ".h ")) - sv_catpv(msg, " (change .h to .ph maybe?)"); - 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++) { - const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE)); - Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir); - sv_catsv(msg, dirmsgsv); - } - sv_catpvn(msg, ")", 1); - SvREFCNT_dec(dirmsgsv); + if(errno == EMFILE) { + SV * const msg + = sv_2mortal(Perl_newSVpvf(aTHX_ "%s: %s", msgstr, + Strerror(errno))); msgstr = SvPV_nolen_const(msg); + } else { + if (namesv) { /* did we lookup @INC? */ + AV * const ar = GvAVn(PL_incgv); + I32 i; + SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_ + "%s in @INC%s%s (@INC contains:", + msgstr, + (instr(msgstr, ".h ") + ? " (change .h to .ph maybe?)" : ""), + (instr(msgstr, ".ph ") + ? " (did you run h2ph?)" : "") + )); + + for (i = 0; i <= AvFILL(ar); i++) { + sv_catpvs(msg, " "); + sv_catsv(msg, *av_fetch(ar, i, TRUE)); + } + sv_catpvs(msg, ")"); + msgstr = SvPV_nolen_const(msg); + } } DIE(aTHX_ "Can't locate %s", msgstr); } @@ -3350,47 +3550,45 @@ PP(pp_require) SETERRNO(0, SS_NORMAL); /* Assume success here to prevent recursive requirement. */ - len = strlen(name); + /* name is never assigned to again, so len is still strlen(name) */ /* Check whether a hook in @INC has already filled %INC */ - if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) { - (void)hv_store(GvHVn(PL_incgv), name, len, - (hook_sv ? SvREFCNT_inc(hook_sv) - : newSVpv(CopFILE(&PL_compiling), 0)), - 0 ); + if (!hook_sv) { + (void)hv_store(GvHVn(PL_incgv), + unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0); + } else { + SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); + if (!svp) + (void)hv_store(GvHVn(PL_incgv), + unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 ); } ENTER; SAVETMPS; - lex_start(sv_2mortal(newSVpvn("",0))); - SAVEGENERICSV(PL_rsfp_filters); - PL_rsfp_filters = Nullav; + lex_start(NULL, tryrsfp, TRUE); - PL_rsfp = tryrsfp; SAVEHINTS(); PL_hints = 0; - SAVESPTR(PL_compiling.cop_warnings); + hv_clear(GvHV(PL_hintgv)); + + SAVECOMPILEWARNINGS(); if (PL_dowarn & G_WARN_ALL_ON) PL_compiling.cop_warnings = pWARN_ALL ; else if (PL_dowarn & G_WARN_ALL_OFF) PL_compiling.cop_warnings = pWARN_NONE ; - else if (PL_taint_warn) - PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize); else PL_compiling.cop_warnings = pWARN_STD ; - SAVESPTR(PL_compiling.cop_io); - PL_compiling.cop_io = Nullsv; - if (filter_sub || filter_child_proc) { - SV * const datasv = filter_add(run_user_filter, Nullsv); + if (filter_sub || filter_cache) { + SV * const datasv = filter_add(S_run_user_filter, NULL); IoLINES(datasv) = filter_has_file; - IoFMT_GV(datasv) = (GV *)filter_child_proc; - IoTOP_GV(datasv) = (GV *)filter_state; - IoBOTTOM_GV(datasv) = (GV *)filter_sub; + IoTOP_GV(datasv) = MUTABLE_GV(filter_state); + IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub); + IoFMT_GV(datasv) = MUTABLE_GV(filter_cache); } /* switch to eval mode */ PUSHBLOCK(cx, CXt_EVAL, SP); - PUSHEVAL(cx, name, Nullgv); + PUSHEVAL(cx, name); cx->blk_eval.retop = PL_op->op_next; SAVECOPLINE(&PL_compiling); @@ -3400,9 +3598,12 @@ PP(pp_require) /* Store and reset encoding. */ encoding = PL_encoding; - PL_encoding = Nullsv; + PL_encoding = NULL; - op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq)); + if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq)) + op = DOCATCH(PL_eval_start); + else + op = PL_op->op_next; /* Restore encoding. */ PL_encoding = encoding; @@ -3410,45 +3611,57 @@ PP(pp_require) return op; } -PP(pp_dofile) +/* This is a op added to hold the hints hash for + pp_entereval. The hash can be modified by the code + being eval'ed, so we return a copy instead. */ + +PP(pp_hintseval) { - return pp_require(); + dVAR; + dSP; + mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv)))); + RETURN; } + PP(pp_entereval) { dVAR; dSP; register PERL_CONTEXT *cx; - dPOPss; + SV *sv; const I32 gimme = GIMME_V; - const I32 was = PL_sub_generation; + const U32 was = PL_breakable_sub_gen; char tbuf[TYPE_DIGITS(long) + 12]; char *tmpbuf = tbuf; - char *safestr; STRLEN len; - OP *ret; CV* runcv; U32 seq; + HV *saved_hh = NULL; - if (!SvPV_const(sv,len)) - RETPUSHUNDEF; + if (PL_op->op_private & OPpEVAL_HAS_HH) { + saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs)); + } + sv = POPs; + + TAINT_IF(SvTAINTED(sv)); TAINT_PROPER("eval"); ENTER; - lex_start(sv); + lex_start(sv, NULL, FALSE); SAVETMPS; /* switch to eval mode */ if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) { - SV * const sv = sv_newmortal(); - Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]", + SV * const temp_sv = sv_newmortal(); + Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]", (unsigned long)++PL_evalseq, CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); - tmpbuf = SvPVX(sv); + tmpbuf = SvPVX(temp_sv); + len = SvCUR(temp_sv); } else - sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); + len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq); SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); SAVECOPLINE(&PL_compiling); @@ -3458,23 +3671,23 @@ PP(pp_entereval) (i.e. before run-time proper). To work around the coredump that ensues, we always turn GvMULTI_on for any globals that were introduced within evals. See force_ident(). GSAR 96-10-12 */ - safestr = savepv(tmpbuf); - SAVEDELETE(PL_defstash, safestr, strlen(safestr)); SAVEHINTS(); PL_hints = PL_op->op_targ; - SAVESPTR(PL_compiling.cop_warnings); - if (specialWARN(PL_curcop->cop_warnings)) - PL_compiling.cop_warnings = PL_curcop->cop_warnings; - else { - PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings); - SAVEFREESV(PL_compiling.cop_warnings); + if (saved_hh) { + /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ + SvREFCNT_dec(GvHV(PL_hintgv)); + GvHV(PL_hintgv) = saved_hh; } - SAVESPTR(PL_compiling.cop_io); - if (specialCopIO(PL_curcop->cop_io)) - PL_compiling.cop_io = PL_curcop->cop_io; - else { - PL_compiling.cop_io = newSVsv(PL_curcop->cop_io); - SAVEFREESV(PL_compiling.cop_io); + SAVECOMPILEWARNINGS(); + PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); + if (PL_compiling.cop_hints_hash) { + Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); + } + PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash; + if (PL_compiling.cop_hints_hash) { + HINTS_REFCNT_LOCK; + PL_compiling.cop_hints_hash->refcounted_he_refcnt++; + HINTS_REFCNT_UNLOCK; } /* special case: an eval '' executed within the DB package gets lexically * placed in the first non-DB CV rather than the current CV - this @@ -3484,20 +3697,37 @@ PP(pp_entereval) runcv = find_runcv(&seq); PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP); - PUSHEVAL(cx, 0, Nullgv); + PUSHEVAL(cx, 0); 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); + if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) + save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); PUTBACK; - 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. */ + + if (doeval(gimme, NULL, runcv, seq)) { + if (was != PL_breakable_sub_gen /* Some subs defined here. */ + ? (PERLDB_LINE || PERLDB_SAVESRC) + : PERLDB_SAVESRC_NOSUBS) { + /* Retain the filegv we created. */ + } else { + char *const safestr = savepvn(tmpbuf, len); + SAVEDELETE(PL_defstash, safestr, len); + } + return DOCATCH(PL_eval_start); + } else { + /* We have already left the scope set up earler thanks to the LEAVE + in doeval(). */ + if (was != PL_breakable_sub_gen /* Some subs defined here. */ + ? (PERLDB_LINE || PERLDB_SAVESRC) + : PERLDB_SAVESRC_INVALID) { + /* Retain the filegv we created. */ + } else { + (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD); + } + return PL_op->op_next; } - return DOCATCH(ret); } PP(pp_leaveeval) @@ -3556,41 +3786,75 @@ PP(pp_leaveeval) /* Unassume the success we assumed earlier. */ SV * const nsv = cx->blk_eval.old_namesv; (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); + retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv)); /* die_where() did LEAVE, or we won't be here */ } else { LEAVE; - if (!(save_flags & OPf_SPECIAL)) - sv_setpvn(ERRSV,"",0); + if (!(save_flags & OPf_SPECIAL)) { + CLEAR_ERRSV(); + } } RETURNOP(retop); } -PP(pp_entertry) +/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it + close to the related Perl_create_eval_scope. */ +void +Perl_delete_eval_scope(pTHX) { - dVAR; dSP; + SV **newsp; + PMOP *newpm; + I32 gimme; register PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + I32 optype; + + POPBLOCK(cx,newpm); + POPEVAL(cx); + PL_curpm = newpm; + LEAVE; + PERL_UNUSED_VAR(newsp); + PERL_UNUSED_VAR(gimme); + PERL_UNUSED_VAR(optype); +} +/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was + also needed by Perl_fold_constants. */ +PERL_CONTEXT * +Perl_create_eval_scope(pTHX_ U32 flags) +{ + PERL_CONTEXT *cx; + const I32 gimme = GIMME_V; + ENTER; SAVETMPS; - PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP); - PUSHEVAL(cx, 0, 0); - cx->blk_eval.retop = cLOGOP->op_other->op_next; + PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp); + PUSHEVAL(cx, 0); PL_in_eval = EVAL_INEVAL; - sv_setpvn(ERRSV,"",0); - PUTBACK; + if (flags & G_KEEPERR) + PL_in_eval |= EVAL_KEEPERR; + else + CLEAR_ERRSV(); + if (flags & G_FAKINGEVAL) { + PL_eval_root = PL_op; /* Only needed so that goto works right. */ + } + return cx; +} + +PP(pp_entertry) +{ + dVAR; + PERL_CONTEXT * const cx = create_eval_scope(0); + cx->blk_eval.retop = cLOGOP->op_other->op_next; return DOCATCH(PL_op->op_next); } PP(pp_leavetry) { dVAR; dSP; - register SV **mark; SV **newsp; PMOP *newpm; I32 gimme; @@ -3605,6 +3869,7 @@ PP(pp_leavetry) if (gimme == G_VOID) SP = newsp; else if (gimme == G_SCALAR) { + register SV **mark; MARK = newsp + 1; if (MARK <= SP) { if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) @@ -3620,6 +3885,7 @@ PP(pp_leavetry) } else { /* in case LEAVE wipes old return values */ + register SV **mark; for (mark = newsp + 1; mark <= SP; mark++) { if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { *mark = sv_mortalcopy(*mark); @@ -3630,29 +3896,694 @@ PP(pp_leavetry) PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE; - sv_setpvn(ERRSV,"",0); + CLEAR_ERRSV(); + RETURN; +} + +PP(pp_entergiven) +{ + dVAR; dSP; + register PERL_CONTEXT *cx; + const I32 gimme = GIMME_V; + + ENTER; + SAVETMPS; + + sv_setsv(PAD_SV(PL_op->op_targ), POPs); + + PUSHBLOCK(cx, CXt_GIVEN, SP); + PUSHGIVEN(cx); + + RETURN; +} + +PP(pp_leavegiven) +{ + dVAR; dSP; + register PERL_CONTEXT *cx; + I32 gimme; + SV **newsp; + PMOP *newpm; + PERL_UNUSED_CONTEXT; + + POPBLOCK(cx,newpm); + assert(CxTYPE(cx) == CXt_GIVEN); + + SP = newsp; + PUTBACK; + + PL_curpm = newpm; /* pop $1 et al */ + + LEAVE; + + return NORMAL; +} + +/* Helper routines used by pp_smartmatch */ +STATIC PMOP * +S_make_matcher(pTHX_ REGEXP *re) +{ + dVAR; + PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED); + + PERL_ARGS_ASSERT_MAKE_MATCHER; + + PM_SETRE(matcher, ReREFCNT_inc(re)); + + SAVEFREEOP((OP *) matcher); + ENTER; SAVETMPS; + SAVEOP(); + return matcher; +} + +STATIC bool +S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) +{ + dVAR; + dSP; + + PERL_ARGS_ASSERT_MATCHER_MATCHES_SV; + + PL_op = (OP *) matcher; + XPUSHs(sv); + PUTBACK; + (void) pp_match(); + SPAGAIN; + return (SvTRUEx(POPs)); +} + +STATIC void +S_destroy_matcher(pTHX_ PMOP *matcher) +{ + dVAR; + + PERL_ARGS_ASSERT_DESTROY_MATCHER; + PERL_UNUSED_ARG(matcher); + + FREETMPS; + LEAVE; +} + +/* Do a smart match */ +PP(pp_smartmatch) +{ + DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n")); + return do_smartmatch(NULL, NULL); +} + +/* This version of do_smartmatch() implements the + * table of smart matches that is found in perlsyn. + */ +STATIC OP * +S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) +{ + dVAR; + dSP; + + bool object_on_left = FALSE; + SV *e = TOPs; /* e is for 'expression' */ + SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */ + + /* First of all, handle overload magic of the rightmost argument */ + if (SvAMAGIC(e)) { + SV * tmpsv; + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); + DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); + + tmpsv = amagic_call(d, e, smart_amg, 0); + if (tmpsv) { + SPAGAIN; + (void)POPs; + SETs(tmpsv); + RETURN; + } + DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n")); + } + + SP -= 2; /* Pop the values */ + + /* Take care only to invoke mg_get() once for each argument. + * Currently we do this by copying the SV if it's magical. */ + if (d) { + if (SvGMAGICAL(d)) + d = sv_mortalcopy(d); + } + else + d = &PL_sv_undef; + + assert(e); + if (SvGMAGICAL(e)) + e = sv_mortalcopy(e); + + /* ~~ undef */ + if (!SvOK(e)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n")); + if (SvOK(d)) + RETPUSHNO; + else + RETPUSHYES; + } + + if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); + Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); + } + if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) + object_on_left = TRUE; + + /* ~~ sub */ + if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) { + I32 c; + if (object_on_left) { + goto sm_any_sub; /* Treat objects like scalars */ + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + /* Test sub truth for each key */ + HE *he; + bool andedresults = TRUE; + HV *hv = (HV*) SvRV(d); + I32 numkeys = hv_iterinit(hv); + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n")); + if (numkeys == 0) + RETPUSHYES; + while ( (he = hv_iternext(hv)) ) { + DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); + ENTER; + SAVETMPS; + PUSHMARK(SP); + PUSHs(hv_iterkeysv(he)); + PUTBACK; + c = call_sv(e, G_SCALAR); + SPAGAIN; + if (c == 0) + andedresults = FALSE; + else + andedresults = SvTRUEx(POPs) && andedresults; + FREETMPS; + LEAVE; + } + if (andedresults) + RETPUSHYES; + else + RETPUSHNO; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + /* Test sub truth for each element */ + I32 i; + bool andedresults = TRUE; + AV *av = (AV*) SvRV(d); + const I32 len = av_len(av); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n")); + if (len == -1) + RETPUSHYES; + for (i = 0; i <= len; ++i) { + SV * const * const svp = av_fetch(av, i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); + ENTER; + SAVETMPS; + PUSHMARK(SP); + if (svp) + PUSHs(*svp); + PUTBACK; + c = call_sv(e, G_SCALAR); + SPAGAIN; + if (c == 0) + andedresults = FALSE; + else + andedresults = SvTRUEx(POPs) && andedresults; + FREETMPS; + LEAVE; + } + if (andedresults) + RETPUSHYES; + else + RETPUSHNO; + } + else { + sm_any_sub: + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); + ENTER; + SAVETMPS; + PUSHMARK(SP); + PUSHs(d); + PUTBACK; + c = call_sv(e, G_SCALAR); + SPAGAIN; + if (c == 0) + PUSHs(&PL_sv_no); + else if (SvTEMP(TOPs)) + SvREFCNT_inc_void(TOPs); + FREETMPS; + LEAVE; + RETURN; + } + } + /* ~~ %hash */ + else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) { + if (object_on_left) { + goto sm_any_hash; /* Treat objects like scalars */ + } + else if (!SvOK(d)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n")); + RETPUSHNO; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + /* Check that the key-sets are identical */ + HE *he; + HV *other_hv = MUTABLE_HV(SvRV(d)); + bool tied = FALSE; + bool other_tied = FALSE; + U32 this_key_count = 0, + other_key_count = 0; + HV *hv = MUTABLE_HV(SvRV(e)); + + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n")); + /* Tied hashes don't know how many keys they have. */ + if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) { + tied = TRUE; + } + else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) { + HV * const temp = other_hv; + other_hv = hv; + hv = temp; + tied = TRUE; + } + if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) + other_tied = TRUE; + + if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv)) + RETPUSHNO; + + /* The hashes have the same number of keys, so it suffices + to check that one is a subset of the other. */ + (void) hv_iterinit(hv); + while ( (he = hv_iternext(hv)) ) { + SV *key = hv_iterkeysv(he); + + DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n")); + ++ this_key_count; + + if(!hv_exists_ent(other_hv, key, 0)) { + (void) hv_iterinit(hv); /* reset iterator */ + RETPUSHNO; + } + } + + if (other_tied) { + (void) hv_iterinit(other_hv); + while ( hv_iternext(other_hv) ) + ++other_key_count; + } + else + other_key_count = HvUSEDKEYS(other_hv); + + if (this_key_count != other_key_count) + RETPUSHNO; + else + RETPUSHYES; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + AV * const other_av = MUTABLE_AV(SvRV(d)); + const I32 other_len = av_len(other_av) + 1; + I32 i; + HV *hv = MUTABLE_HV(SvRV(e)); + + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n")); + for (i = 0; i < other_len; ++i) { + SV ** const svp = av_fetch(other_av, i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n")); + if (svp) { /* ??? When can this not happen? */ + if (hv_exists_ent(hv, *svp, 0)) + RETPUSHYES; + } + } + RETPUSHNO; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n")); + sm_regex_hash: + { + PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); + HE *he; + HV *hv = MUTABLE_HV(SvRV(e)); + + (void) hv_iterinit(hv); + while ( (he = hv_iternext(hv)) ) { + DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n")); + if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { + (void) hv_iterinit(hv); + destroy_matcher(matcher); + RETPUSHYES; + } + } + destroy_matcher(matcher); + RETPUSHNO; + } + } + else { + sm_any_hash: + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n")); + if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0)) + RETPUSHYES; + else + RETPUSHNO; + } + } + /* ~~ @array */ + else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) { + if (object_on_left) { + goto sm_any_array; /* Treat objects like scalars */ + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + AV * const other_av = MUTABLE_AV(SvRV(e)); + const I32 other_len = av_len(other_av) + 1; + I32 i; + + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n")); + for (i = 0; i < other_len; ++i) { + SV ** const svp = av_fetch(other_av, i, FALSE); + + DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n")); + if (svp) { /* ??? When can this not happen? */ + if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0)) + RETPUSHYES; + } + } + RETPUSHNO; + } + if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + AV *other_av = MUTABLE_AV(SvRV(d)); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n")); + if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av)) + RETPUSHNO; + else { + I32 i; + const I32 other_len = av_len(other_av); + + if (NULL == seen_this) { + seen_this = newHV(); + (void) sv_2mortal(MUTABLE_SV(seen_this)); + } + if (NULL == seen_other) { + seen_this = newHV(); + (void) sv_2mortal(MUTABLE_SV(seen_other)); + } + for(i = 0; i <= other_len; ++i) { + SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + SV * const * const other_elem = av_fetch(other_av, i, FALSE); + + if (!this_elem || !other_elem) { + if (this_elem || other_elem) + RETPUSHNO; + } + else if (hv_exists_ent(seen_this, + sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) || + hv_exists_ent(seen_other, + sv_2mortal(newSViv(PTR2IV(*other_elem))), 0)) + { + if (*this_elem != *other_elem) + RETPUSHNO; + } + else { + (void)hv_store_ent(seen_this, + sv_2mortal(newSViv(PTR2IV(*this_elem))), + &PL_sv_undef, 0); + (void)hv_store_ent(seen_other, + sv_2mortal(newSViv(PTR2IV(*other_elem))), + &PL_sv_undef, 0); + PUSHs(*other_elem); + PUSHs(*this_elem); + + PUTBACK; + DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n")); + (void) do_smartmatch(seen_this, seen_other); + SPAGAIN; + DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); + + if (!SvTRUEx(POPs)) + RETPUSHNO; + } + } + RETPUSHYES; + } + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n")); + sm_regex_array: + { + PMOP * const matcher = make_matcher((REGEXP*) SvRV(d)); + const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); + I32 i; + + for(i = 0; i <= this_len; ++i) { + SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n")); + if (svp && matcher_matches_sv(matcher, *svp)) { + destroy_matcher(matcher); + RETPUSHYES; + } + } + destroy_matcher(matcher); + RETPUSHNO; + } + } + else if (!SvOK(d)) { + /* undef ~~ array */ + const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); + I32 i; + + DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n")); + for (i = 0; i <= this_len; ++i) { + SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n")); + if (!svp || !SvOK(*svp)) + RETPUSHYES; + } + RETPUSHNO; + } + else { + sm_any_array: + { + I32 i; + const I32 this_len = av_len(MUTABLE_AV(SvRV(e))); + + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n")); + for (i = 0; i <= this_len; ++i) { + SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + if (!svp) + continue; + + PUSHs(d); + PUSHs(*svp); + PUTBACK; + /* infinite recursion isn't supposed to happen here */ + DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n")); + (void) do_smartmatch(NULL, NULL); + SPAGAIN; + DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); + if (SvTRUEx(POPs)) + RETPUSHYES; + } + RETPUSHNO; + } + } + } + /* ~~ qr// */ + else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) { + if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { + SV *t = d; d = e; e = t; + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n")); + goto sm_regex_hash; + } + else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + SV *t = d; d = e; e = t; + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n")); + goto sm_regex_array; + } + else { + PMOP * const matcher = make_matcher((REGEXP*) SvRV(e)); + + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); + PUTBACK; + PUSHs(matcher_matches_sv(matcher, d) + ? &PL_sv_yes + : &PL_sv_no); + destroy_matcher(matcher); + RETURN; + } + } + /* ~~ scalar */ + /* See if there is overload magic on left */ + else if (object_on_left && SvAMAGIC(d)) { + SV *tmpsv; + DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n")); + DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); + PUSHs(d); PUSHs(e); + PUTBACK; + tmpsv = amagic_call(d, e, smart_amg, AMGf_noright); + if (tmpsv) { + SPAGAIN; + (void)POPs; + SETs(tmpsv); + RETURN; + } + SP -= 2; + DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n")); + goto sm_any_scalar; + } + else if (!SvOK(d)) { + /* undef ~~ scalar ; we already know that the scalar is SvOK */ + DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n")); + RETPUSHNO; + } + else + sm_any_scalar: + if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) { + DEBUG_M(if (SvNIOK(e)) + Perl_deb(aTHX_ " applying rule Any-Num\n"); + else + Perl_deb(aTHX_ " applying rule Num-numish\n"); + ); + /* numeric comparison */ + PUSHs(d); PUSHs(e); + PUTBACK; + if (CopHINTS_get(PL_curcop) & HINT_INTEGER) + (void) pp_i_eq(); + else + (void) pp_eq(); + SPAGAIN; + if (SvTRUEx(POPs)) + RETPUSHYES; + else + RETPUSHNO; + } + + /* As a last resort, use string comparison */ + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n")); + PUSHs(d); PUSHs(e); + PUTBACK; + return pp_seq(); +} + +PP(pp_enterwhen) +{ + dVAR; dSP; + register PERL_CONTEXT *cx; + const I32 gimme = GIMME_V; + + /* This is essentially an optimization: if the match + fails, we don't want to push a context and then + pop it again right away, so we skip straight + to the op that follows the leavewhen. + */ + if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs)) + return cLOGOP->op_other->op_next; + + ENTER; + SAVETMPS; + + PUSHBLOCK(cx, CXt_WHEN, SP); + PUSHWHEN(cx); + RETURN; } +PP(pp_leavewhen) +{ + dVAR; dSP; + register PERL_CONTEXT *cx; + I32 gimme; + SV **newsp; + PMOP *newpm; + + POPBLOCK(cx,newpm); + assert(CxTYPE(cx) == CXt_WHEN); + + SP = newsp; + PUTBACK; + + PL_curpm = newpm; /* pop $1 et al */ + + LEAVE; + return NORMAL; +} + +PP(pp_continue) +{ + dVAR; + I32 cxix; + register PERL_CONTEXT *cx; + I32 inner; + + cxix = dopoptowhen(cxstack_ix); + if (cxix < 0) + DIE(aTHX_ "Can't \"continue\" outside a when block"); + if (cxix < cxstack_ix) + dounwind(cxix); + + /* clear off anything above the scope we're re-entering */ + inner = PL_scopestack_ix; + TOPBLOCK(cx); + if (PL_scopestack_ix < inner) + leave_scope(PL_scopestack[PL_scopestack_ix]); + PL_curcop = cx->blk_oldcop; + return cx->blk_givwhen.leave_op; +} + +PP(pp_break) +{ + dVAR; + I32 cxix; + register PERL_CONTEXT *cx; + I32 inner; + + cxix = dopoptogiven(cxstack_ix); + if (cxix < 0) { + if (PL_op->op_flags & OPf_SPECIAL) + DIE(aTHX_ "Can't use when() outside a topicalizer"); + else + DIE(aTHX_ "Can't \"break\" outside a given block"); + } + if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL))) + DIE(aTHX_ "Can't \"break\" in a loop topicalizer"); + + if (cxix < cxstack_ix) + dounwind(cxix); + + /* clear off anything above the scope we're re-entering */ + inner = PL_scopestack_ix; + TOPBLOCK(cx); + if (PL_scopestack_ix < inner) + leave_scope(PL_scopestack[PL_scopestack_ix]); + PL_curcop = cx->blk_oldcop; + + if (CxFOREACH(cx)) + return CX_LOOP_NEXTOP_GET(cx); + else + return cx->blk_givwhen.leave_op; +} + STATIC OP * S_doparseform(pTHX_ SV *sv) { STRLEN len; register char *s = SvPV_force(sv, len); - register char *send = s + len; - register char *base = Nullch; + register char * const send = s + len; + register char *base = NULL; register I32 skipspaces = 0; bool noblank = FALSE; bool repeat = FALSE; bool postspace = FALSE; U32 *fops; register U32 *fpc; - U32 *linepc = 0; + U32 *linepc = NULL; register I32 arg; bool ischop; bool unchopnum = FALSE; int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ + PERL_ARGS_ASSERT_DOPARSEFORM; + if (len == 0) Perl_croak(aTHX_ "Null picture in formline"); @@ -3662,7 +4593,7 @@ S_doparseform(pTHX_ SV *sv) maxops += 10; } s = base; - base = Nullch; + base = NULL; Newx(fops, maxops, U32); fpc = fops; @@ -3843,7 +4774,7 @@ S_doparseform(pTHX_ SV *sv) } Copy(fops, s, arg, U32); Safefree(fops); - sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0); + sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0); SvCOMPILED_on(sv); if (unchopnum && repeat) @@ -3880,26 +4811,83 @@ S_num_overflow(NV value, I32 fldsize, I32 frcsize) } static I32 -run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) +S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) { dVAR; - SV *datasv = FILTER_DATA(idx); + SV * const datasv = FILTER_DATA(idx); 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); - int len = 0; + SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv)); + SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv)); + int status = 0; + SV *upstream; + STRLEN got_len; + const char *got_p = NULL; + const char *prune_from = NULL; + bool read_from_cache = FALSE; + STRLEN umaxlen; + + PERL_ARGS_ASSERT_RUN_USER_FILTER; + + assert(maxlen >= 0); + umaxlen = maxlen; /* I was having segfault trouble under Linux 2.2.5 after a parse error occured. (Had to hack around it with a test - for PL_error_count == 0.) Solaris doesn't segfault -- + for PL_parser->error_count == 0.) Solaris doesn't segfault -- not sure where the trouble is yet. XXX */ + if (IoFMT_GV(datasv)) { + SV *const cache = MUTABLE_SV(IoFMT_GV(datasv)); + if (SvOK(cache)) { + STRLEN cache_len; + const char *cache_p = SvPV(cache, cache_len); + STRLEN take = 0; + + if (umaxlen) { + /* Running in block mode and we have some cached data already. + */ + if (cache_len >= umaxlen) { + /* In fact, so much data we don't even need to call + filter_read. */ + take = umaxlen; + } + } else { + const char *const first_nl = + (const char *)memchr(cache_p, '\n', cache_len); + if (first_nl) { + take = first_nl + 1 - cache_p; + } + } + if (take) { + sv_catpvn(buf_sv, cache_p, take); + sv_chop(cache, cache_p + take); + /* Definately not EOF */ + return 1; + } + + sv_catsv(buf_sv, cache); + if (umaxlen) { + umaxlen -= cache_len; + } + SvOK_off(cache); + read_from_cache = TRUE; + } + } + + /* Filter API says that the filter appends to the contents of the buffer. + Usually the buffer is "", so the details don't matter. But if it's not, + then clearly what it contains is already filtered by this filter, so we + don't want to pass it in a second time. + I'm going to use a mortal in case the upstream filter croaks. */ + upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv)) + ? sv_newmortal() : buf_sv; + SvUPGRADE(upstream, SVt_PV); + if (filter_has_file) { - len = FILTER_READ(idx+1, buf_sv, maxlen); + status = FILTER_READ(idx+1, upstream, 0); } - if (filter_sub && len >= 0) { + if (filter_sub && status >= 0) { dSP; int count; @@ -3908,9 +4896,9 @@ run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) SAVETMPS; EXTEND(SP, 2); - DEFSV = buf_sv; + DEFSV_set(upstream); PUSHMARK(SP); - PUSHs(sv_2mortal(newSViv(maxlen))); + mPUSHi(0); if (filter_state) { PUSHs(filter_state); } @@ -3921,7 +4909,7 @@ run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) if (count > 0) { SV *out = POPs; if (SvOK(out)) { - len = SvIV(out); + status = SvIV(out); } } @@ -3930,38 +4918,96 @@ run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) LEAVE; } - if (len <= 0) { - IoLINES(datasv) = 0; - if (filter_child_proc) { - SvREFCNT_dec(filter_child_proc); - IoFMT_GV(datasv) = Nullgv; + if(SvOK(upstream)) { + got_p = SvPV(upstream, got_len); + if (umaxlen) { + if (got_len > umaxlen) { + prune_from = got_p + umaxlen; + } + } else { + const char *const first_nl = + (const char *)memchr(got_p, '\n', got_len); + if (first_nl && first_nl + 1 < got_p + got_len) { + /* There's a second line here... */ + prune_from = first_nl + 1; + } } + } + if (prune_from) { + /* Oh. Too long. Stuff some in our cache. */ + STRLEN cached_len = got_p + got_len - prune_from; + SV *cache = MUTABLE_SV(IoFMT_GV(datasv)); + + if (!cache) { + IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen))); + } else if (SvOK(cache)) { + /* Cache should be empty. */ + assert(!SvCUR(cache)); + } + + sv_setpvn(cache, prune_from, cached_len); + /* If you ask for block mode, you may well split UTF-8 characters. + "If it breaks, you get to keep both parts" + (Your code is broken if you don't put them back together again + before something notices.) */ + if (SvUTF8(upstream)) { + SvUTF8_on(cache); + } + SvCUR_set(upstream, got_len - cached_len); + /* Can't yet be EOF */ + if (status == 0) + status = 1; + } + + /* If they are at EOF but buf_sv has something in it, then they may never + have touched the SV upstream, so it may be undefined. If we naively + concatenate it then we get a warning about use of uninitialised value. + */ + if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) { + sv_catsv(buf_sv, upstream); + } + + if (status <= 0) { + IoLINES(datasv) = 0; + SvREFCNT_dec(IoFMT_GV(datasv)); if (filter_state) { SvREFCNT_dec(filter_state); - IoTOP_GV(datasv) = Nullgv; + IoTOP_GV(datasv) = NULL; } if (filter_sub) { SvREFCNT_dec(filter_sub); - IoBOTTOM_GV(datasv) = Nullgv; + IoBOTTOM_GV(datasv) = NULL; } - filter_del(run_user_filter); + filter_del(S_run_user_filter); } - - return len; + if (status == 0 && read_from_cache) { + /* If we read some data from the cache (and by getting here it implies + that we emptied the cache) then we aren't yet at EOF, and mustn't + report that to our caller. */ + return 1; + } + return status; } /* 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_ const char *name) +S_path_is_absolute(const char *name) { + PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE; + if (PERL_FILE_IS_ABSOLUTE(name) -#ifdef MACOS_TRADITIONAL - || (*name == ':')) +#ifdef WIN32 + || (*name == '.' && ((name[1] == '/' || + (name[1] == '.' && name[2] == '/')) + || (name[1] == '\\' || + ( name[1] == '.' && name[2] == '\\'))) + ) #else || (*name == '.' && (name[1] == '/' || - (name[1] == '.' && name[2] == '/')))) + (name[1] == '.' && name[2] == '/'))) #endif + ) { return TRUE; }