X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9d056fb0da516ee7e0b8deae1b90a1e2f382c7ec..4ff700b95e237f7cbe602fd953867428ee836122:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 31c716e..3304eac 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -34,10 +34,6 @@ #define PERL_IN_PP_CTL_C #include "perl.h" -#ifndef WORD_ALIGN -#define WORD_ALIGN sizeof(U32) -#endif - #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o)) #define dopoptosub(plop) dopoptosub_at(cxstack, (plop)) @@ -98,7 +94,7 @@ PP(pp_regcomp) STMT_START { \ SvGETMAGIC(rx); \ if (SvROK(rx) && SvAMAGIC(rx)) { \ - SV *sv = AMG_CALLun(rx, regexp); \ + SV *sv = AMG_CALLunary(rx, regexp_amg); \ if (sv) { \ if (SvROK(sv)) \ sv = SvRV(sv); \ @@ -111,7 +107,7 @@ PP(pp_regcomp) if (PL_op->op_flags & OPf_STACKED) { - /* multiple args; concatentate them */ + /* multiple args; concatenate them */ dMARK; dORIGMARK; tmpstr = PAD_SV(ARGTARG); sv_setpvs(tmpstr, ""); @@ -185,7 +181,7 @@ PP(pp_regcomp) memNE(RX_PRECOMP(re), t, len)) { const regexp_engine *eng = re ? RX_ENGINE(re) : NULL; - U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME; + U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME; if (re) { ReREFCNT_dec(re); #ifdef USE_ITHREADS @@ -240,10 +236,10 @@ PP(pp_regcomp) #ifndef INCOMPLETE_TAINTS if (PL_tainting) { - if (PL_tainted) + if (PL_tainted) { + SvTAINTED_on((SV*)re); RX_EXTFLAGS(re) |= RXf_TAINTED; - else - RX_EXTFLAGS(re) &= ~RXf_TAINTED; + } } #endif @@ -294,8 +290,9 @@ PP(pp_substcont) SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */ - if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs)) - cx->sb_rxtainted |= 2; + /* See "how taint works" above pp_subst() */ + if (SvTAINTED(TOPs)) + cx->sb_rxtainted |= SUBST_TAINT_REPL; sv_catsv_nomg(dstr, POPs); /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */ s -= RX_GOFS(rx); @@ -317,7 +314,8 @@ PP(pp_substcont) else sv_catpvn(dstr, s, cx->sb_strend - s); } - cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); + if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ + cx->sb_rxtainted |= SUBST_TAINT_PAT; #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(targ)) { @@ -334,20 +332,39 @@ PP(pp_substcont) SvUTF8_on(targ); SvPV_set(dstr, NULL); - TAINT_IF(cx->sb_rxtainted & 1); if (pm->op_pmflags & PMf_NONDESTRUCT) PUSHs(targ); else mPUSHi(saviters - 1); (void)SvPOK_only_UTF8(targ); - TAINT_IF(cx->sb_rxtainted); - SvSETMAGIC(targ); - SvTAINT(targ); + /* update the taint state of various various variables in + * preparation for final exit. + * See "how taint works" above pp_subst() */ + if (PL_tainting) { + if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || + ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + ) + (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ + + if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET) + && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT)) + ) + SvTAINTED_on(TOPs); /* taint return value */ + /* needed for mg_set below */ + PL_tainted = cBOOL(cx->sb_rxtainted & + (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)); + SvTAINT(TARG); + } + /* PL_tainted must be correctly set for this mg_set */ + SvSETMAGIC(TARG); + TAINT_NOT; LEAVE_SCOPE(cx->sb_oldsave); POPSUBST(cx); RETURNOP(pm->op_next); + /* NOTREACHED */ } cx->sb_iters = saviters; } @@ -382,7 +399,24 @@ PP(pp_substcont) } if (old != rx) (void)ReREFCNT_inc(rx); - cx->sb_rxtainted |= RX_MATCH_TAINTED(rx); + /* update the taint state of various various variables in preparation + * for calling the code block. + * See "how taint works" above pp_subst() */ + if (PL_tainting) { + if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ + cx->sb_rxtainted |= SUBST_TAINT_PAT; + + if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || + ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) + ) + (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */ + + if (cx->sb_iters > 1 && (cx->sb_rxtainted & + (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL))) + SvTAINTED_on(cx->sb_targ); + TAINT_NOT; + } rxres_save(&cx->sb_rxres, rx); PL_curpm = pm; RETURNOP(pm->op_pmstashstartu.op_pmreplstart); @@ -489,50 +523,48 @@ PP(pp_formline) { dVAR; dSP; dMARK; dORIGMARK; register SV * const tmpForm = *++MARK; - register U32 *fpc; - register char *t; - const char *f; + SV *formsv; /* contains text of original format */ + register U32 *fpc; /* format ops program counter */ + register char *t; /* current append position in target string */ + const char *f; /* current position in format string */ register I32 arg; - register SV *sv = NULL; - const char *item = NULL; - I32 itemsize = 0; - I32 fieldsize = 0; - I32 lines = 0; - bool chopspace = (strchr(PL_chopset, ' ') != NULL); - const char *chophere = NULL; - char *linemark = NULL; + register SV *sv = NULL; /* current item */ + const char *item = NULL;/* string value of current item */ + I32 itemsize = 0; /* length of current item, possibly truncated */ + I32 fieldsize = 0; /* width of current field */ + I32 lines = 0; /* number of lines that have been output */ + bool chopspace = (strchr(PL_chopset, ' ') != NULL); /* does $: have space */ + const char *chophere = NULL; /* where to chop current item */ + char *linemark = NULL; /* pos of start of line in output */ NV value; - bool gotsome = FALSE; + bool gotsome = FALSE; /* seen at least one non-blank item on this line */ STRLEN len; - const STRLEN fudge = SvPOKp(tmpForm) - ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0; + STRLEN fudge; /* estimate of output size in bytes */ bool item_is_utf8 = FALSE; bool targ_is_utf8 = FALSE; SV * nsv = NULL; - OP * parseres = NULL; const char *fmt; + MAGIC *mg = NULL; + U8 *source; /* source of bytes to append */ + STRLEN to_copy; /* how may bytes to append */ + + mg = doparseform(tmpForm); + + fpc = (U32*)mg->mg_ptr; + /* the actual string the format was compiled from. + * with overload etc, this may not match tmpForm */ + formsv = mg->mg_obj; + - if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) { - if (SvREADONLY(tmpForm)) { - SvREADONLY_off(tmpForm); - parseres = doparseform(tmpForm); - SvREADONLY_on(tmpForm); - } - else - parseres = doparseform(tmpForm); - if (parseres) - return parseres; - } SvPV_force(PL_formtarget, len); - if (SvTAINTED(tmpForm)) + if (SvTAINTED(tmpForm) || SvTAINTED(formsv)) SvTAINTED_on(PL_formtarget); if (DO_UTF8(PL_formtarget)) targ_is_utf8 = TRUE; + fudge = (SvCUR(formsv) * (IN_BYTES ? 1 : 3) + 1); t = SvGROW(PL_formtarget, len + fudge + 1); /* XXX SvCUR bad */ t += len; - f = SvPV_const(tmpForm, len); - /* need to jump to the next word */ - fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN); + f = SvPV_const(formsv, len); for (;;) { DEBUG_f( { @@ -573,23 +605,39 @@ PP(pp_formline) case FF_LITERAL: arg = *fpc++; - if (targ_is_utf8 && !SvUTF8(tmpForm)) { + if (targ_is_utf8 && !SvUTF8(formsv)) { + char *s; SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; - sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv); + + /* this is an unrolled sv_catpvn_utf8_upgrade(), + * but with the addition of s/~/ /g */ + if (!(nsv)) + nsv = newSVpvn_flags(f, arg, SVs_TEMP); + else + sv_setpvn(nsv, f, arg); + SvUTF8_off(nsv); + for (s = SvPVX(nsv); s <= SvEND(nsv); s++) + if (*s == '~') + *s = ' '; + sv_utf8_upgrade(nsv); + sv_catsv(PL_formtarget, nsv); + t = SvEND(PL_formtarget); f += arg; break; } - if (!targ_is_utf8 && DO_UTF8(tmpForm)) { + if (!targ_is_utf8 && DO_UTF8(formsv)) { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1); t = SvEND(PL_formtarget); targ_is_utf8 = TRUE; } - while (arg--) - *t++ = *f++; + while (arg--) { + *t++ = (*f == '~') ? ' ' : *f; + f++; + } break; case FF_SKIP: @@ -818,7 +866,7 @@ PP(pp_formline) const int ch = *t++ = *s++; if (iscntrl(ch)) #else - if ( !((*t++ = *s++) & ~31) ) + if ( !((*t++ = *s++) & ~31) ) #endif t[-1] = ' '; } @@ -843,72 +891,72 @@ PP(pp_formline) { const bool oneline = fpc[-1] == FF_LINESNGL; const char *s = item = SvPV_const(sv, len); + const char *const send = s + len; + U8 *tmp = NULL; + item_is_utf8 = DO_UTF8(sv); itemsize = len; - if (itemsize) { - 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) { - to_copy = s - SvPVX_const(sv) - 1; - chophere = s; - break; - } else { - if (s == send) { - itemsize--; - to_copy--; - } else - lines++; - } + if (!itemsize) + break; + gotsome = TRUE; + chophere = s + itemsize; + source = (U8 *) s; + to_copy = len; + while (s < send) { + if (*s++ == '\n') { + if (oneline) { + to_copy = s - SvPVX_const(sv) - 1; + chophere = s; + break; + } else { + if (s == send) { + itemsize--; + to_copy--; + } else + lines++; } } - if (targ_is_utf8 && !item_is_utf8) { - source = tmp = bytes_to_utf8(source, &to_copy); + } + 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 { - 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); + SvCUR_set(PL_formtarget, + t - SvPVX_const(PL_formtarget)); } - SvGROW(PL_formtarget, - SvCUR(PL_formtarget) + to_copy + fudge + 1); - t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget); - - 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); + + /* 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); + + 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; } @@ -972,14 +1020,8 @@ PP(pp_formline) arg = *fpc++; if (gotsome) { if (arg) { /* repeat until fields exhausted? */ - *t = '\0'; - SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); - lines += FmLINES(PL_formtarget); - if (targ_is_utf8) - SvUTF8_on(PL_formtarget); - FmLINES(PL_formtarget) = lines; - SP = ORIGMARK; - RETURNOP(cLISTOP->op_first); + fpc--; + goto end; } } else { @@ -1016,13 +1058,17 @@ PP(pp_formline) break; } case FF_END: + end: *t = '\0'; SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); if (targ_is_utf8) SvUTF8_on(PL_formtarget); FmLINES(PL_formtarget) += lines; SP = ORIGMARK; - RETPUSHYES; + if (fpc[-1] == FF_BLANK) + RETURNOP(cLISTOP->op_first); + else + RETPUSHYES; } } } @@ -1039,8 +1085,8 @@ PP(pp_grepstart) RETURNOP(PL_op->op_next->op_next); } PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1; - pp_pushmark(); /* push dst */ - pp_pushmark(); /* push src */ + Perl_pp_pushmark(aTHX); /* push dst */ + Perl_pp_pushmark(aTHX); /* push src */ ENTER_with_name("grep"); /* enter outer scope */ SAVETMPS; @@ -1060,7 +1106,7 @@ PP(pp_grepstart) PUTBACK; if (PL_op->op_type == OP_MAPSTART) - pp_pushmark(); /* push top */ + Perl_pp_pushmark(aTHX); /* push top */ return ((LOGOP*)PL_op->op_next)->op_other; } @@ -1645,6 +1691,40 @@ Perl_die_unwind(pTHX_ SV *msv) I32 cxix; I32 gimme; + /* + * Historically, perl used to set ERRSV ($@) early in the die + * process and rely on it not getting clobbered during unwinding. + * That sucked, because it was liable to get clobbered, so the + * setting of ERRSV used to emit the exception from eval{} has + * been moved to much later, after unwinding (see just before + * JMPENV_JUMP below). However, some modules were relying on the + * early setting, by examining $@ during unwinding to use it as + * a flag indicating whether the current unwinding was caused by + * an exception. It was never a reliable flag for that purpose, + * being totally open to false positives even without actual + * clobberage, but was useful enough for production code to + * semantically rely on it. + * + * We'd like to have a proper introspective interface that + * explicitly describes the reason for whatever unwinding + * operations are currently in progress, so that those modules + * work reliably and $@ isn't further overloaded. But we don't + * have one yet. In its absence, as a stopgap measure, ERRSV is + * now *additionally* set here, before unwinding, to serve as the + * (unreliable) flag that it used to. + * + * This behaviour is temporary, and should be removed when a + * proper way to detect exceptional unwinding has been developed. + * As of 2010-12, the authors of modules relying on the hack + * are aware of the issue, because the modules failed on + * perls 5.13.{1..7} which had late setting of $@ without this + * early-setting hack. + */ + if (!(in_eval & EVAL_KEEPERR)) { + SvTEMP_off(exceptsv); + sv_setsv(ERRSV, exceptsv); + } + while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { @@ -2184,6 +2264,7 @@ PP(pp_return) register PERL_CONTEXT *cx; bool popsub2 = FALSE; bool clear_errsv = FALSE; + bool lval = FALSE; I32 gimme; SV **newsp; PMOP *newpm; @@ -2224,6 +2305,7 @@ PP(pp_return) switch (CxTYPE(cx)) { case CXt_SUB: popsub2 = TRUE; + lval = !!CvLVALUE(cx->blk_sub.cv); retop = cx->blk_sub.retop; cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ break; @@ -2271,7 +2353,8 @@ PP(pp_return) } } else - *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); + *++newsp = + (lval || SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP); } else *++newsp = sv_mortalcopy(*SP); @@ -2281,7 +2364,7 @@ PP(pp_return) } else if (gimme == G_ARRAY) { while (++MARK <= SP) { - *++newsp = (popsub2 && SvTEMP(*MARK)) + *++newsp = popsub2 && (lval || SvTEMP(*MARK)) ? *MARK : sv_mortalcopy(*MARK); TAINT_NOT; /* Each item is independent */ } @@ -2624,8 +2707,8 @@ PP(pp_goto) SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */ if (CvISXSUB(cv)) { OP* const retop = cx->blk_sub.retop; - SV **newsp; - I32 gimme; + SV **newsp __attribute__unused__; + I32 gimme __attribute__unused__; if (reified) { I32 index; for (index=0; indexcop_hints; + if (PL_hints & HINT_LOCALIZE_HH) { + /* SAVEHINTS created a new HV in PL_hintgv, which we + need to GC */ + SvREFCNT_dec(GvHV(PL_hintgv)); + GvHV(PL_hintgv) = + refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0); + hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints); + } + SAVECOMPILEWARNINGS(); + PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); + cophh_free(CopHINTHASH_get(&PL_compiling)); + /* XXX Does this need to avoid copying a label? */ + PL_compiling.cop_hints_hash + = cophh_copy(PL_curcop->cop_hints_hash); + } + PL_op = &dummy; PL_op->op_type = OP_ENTEREVAL; PL_op->op_flags = 0; /* Avoid uninit warning. */ @@ -3376,9 +3478,10 @@ S_doopen_pm(pTHX_ SV *name) PERL_ARGS_ASSERT_DOOPEN_PM; if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) { - SV *const pmcsv = sv_mortalcopy(name); + SV *const pmcsv = sv_newmortal(); Stat_t pmcstat; + SvSetSV_nosteal(pmcsv,name); sv_catpvn(pmcsv, "c", 1); if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0) @@ -3462,9 +3565,10 @@ PP(pp_require) DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)" "--this is only %"SVf", stopped", - SVfARG(vnormal(req)), - SVfARG(vnormal(sv_2mortal(hintsv))), - SVfARG(vnormal(PL_patchlevel))); + SVfARG(sv_2mortal(vnormal(req))), + SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))), + SVfARG(sv_2mortal(vnormal(PL_patchlevel))) + ); } } } @@ -3716,11 +3820,7 @@ PP(pp_require) } } } - if (tryrsfp) { - SAVECOPFILE_FREE(&PL_compiling); - CopFILE_set(&PL_compiling, tryname); - } - SvREFCNT_dec(namesv); + sv_2mortal(namesv); if (!tryrsfp) { if (PL_op->op_type == OP_REQUIRE) { if(errno == EMFILE) { @@ -3761,7 +3861,7 @@ PP(pp_require) /* Check whether a hook in @INC has already filled %INC */ if (!hook_sv) { (void)hv_store(GvHVn(PL_incgv), - unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0); + unixname, unixlen, newSVpv(tryname,0),0); } else { SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0); if (!svp) @@ -3771,6 +3871,8 @@ PP(pp_require) ENTER_with_name("eval"); SAVETMPS; + SAVECOPFILE_FREE(&PL_compiling); + CopFILE_set(&PL_compiling, tryname); lex_start(NULL, tryrsfp, 0); SAVEHINTS(); @@ -3842,6 +3944,7 @@ PP(pp_entereval) const I32 gimme = GIMME_V; const U32 was = PL_breakable_sub_gen; char tbuf[TYPE_DIGITS(long) + 12]; + bool saved_delete = FALSE; char *tmpbuf = tbuf; STRLEN len; CV* runcv; @@ -3866,7 +3969,7 @@ PP(pp_entereval) TAINT_PROPER("eval"); ENTER_with_name("eval"); - lex_start(sv, NULL, 0); + lex_start(sv, NULL, LEX_START_SAME_FILTER); SAVETMPS; /* switch to eval mode */ @@ -3926,6 +4029,12 @@ PP(pp_entereval) if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr); + else { + char *const safestr = savepvn(tmpbuf, len); + SAVEDELETE(PL_defstash, safestr, len); + saved_delete = TRUE; + } + PUTBACK; if (doeval(gimme, NULL, runcv, seq)) { @@ -3933,19 +4042,19 @@ PP(pp_entereval) ? (PERLDB_LINE || PERLDB_SAVESRC) : PERLDB_SAVESRC_NOSUBS) { /* Retain the filegv we created. */ - } else { + } else if (!saved_delete) { 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 + /* We have already left the scope set up earlier thanks to the LEAVE in doeval(). */ if (was != PL_breakable_sub_gen /* Some subs defined here. */ ? (PERLDB_LINE || PERLDB_SAVESRC) : PERLDB_SAVESRC_INVALID) { /* Retain the filegv we created. */ - } else { + } else if (!saved_delete) { (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD); } return PL_op->op_next; @@ -3965,6 +4074,7 @@ PP(pp_leaveeval) I32 optype; SV *namesv; + PERL_ASYNC_CHECK(); POPBLOCK(cx,newpm); POPEVAL(cx); namesv = cx->blk_eval.old_namesv; @@ -4086,6 +4196,7 @@ PP(pp_leavetry) register PERL_CONTEXT *cx; I32 optype; + PERL_ASYNC_CHECK(); POPBLOCK(cx,newpm); POPEVAL(cx); PERL_UNUSED_VAR(optype); @@ -4134,7 +4245,7 @@ PP(pp_entergiven) ENTER_with_name("given"); SAVETMPS; - sv_setsv(PAD_SV(PL_op->op_targ), POPs); + sv_setsv_mg(PAD_SV(PL_op->op_targ), POPs); PUSHBLOCK(cx, CXt_GIVEN, SP); PUSHGIVEN(cx); @@ -4216,7 +4327,7 @@ S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv) PL_op = (OP *) matcher; XPUSHs(sv); PUTBACK; - (void) pp_match(); + (void) Perl_pp_match(aTHX); SPAGAIN; return (SvTRUEx(POPs)); } @@ -4699,9 +4810,9 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) PUSHs(d); PUSHs(e); PUTBACK; if (CopHINTS_get(PL_curcop) & HINT_INTEGER) - (void) pp_i_eq(); + (void) Perl_pp_i_eq(aTHX); else - (void) pp_eq(); + (void) Perl_pp_eq(aTHX); SPAGAIN; if (SvTRUEx(POPs)) RETPUSHYES; @@ -4713,7 +4824,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n")); PUSHs(d); PUSHs(e); PUTBACK; - return pp_seq(); + return Perl_pp_seq(aTHX); } PP(pp_enterwhen) @@ -4744,7 +4855,7 @@ PP(pp_leavewhen) { dVAR; dSP; register PERL_CONTEXT *cx; - I32 gimme; + I32 gimme __attribute__unused__; SV **newsp; PMOP *newpm; @@ -4817,30 +4928,66 @@ PP(pp_break) RETURNOP(cx->blk_givwhen.leave_op); } -STATIC OP * +static MAGIC * S_doparseform(pTHX_ SV *sv) { STRLEN len; - register char *s = SvPV_force(sv, len); - register char * const send = s + len; - register char *base = NULL; - register I32 skipspaces = 0; - bool noblank = FALSE; - bool repeat = FALSE; - bool postspace = FALSE; + register char *s = SvPV(sv, len); + register char *send; + register char *base = NULL; /* start of current field */ + register I32 skipspaces = 0; /* number of contiguous spaces seen */ + bool noblank = FALSE; /* ~ or ~~ seen on this line */ + bool repeat = FALSE; /* ~~ seen on this line */ + bool postspace = FALSE; /* a text field may need right padding */ U32 *fops; register U32 *fpc; - U32 *linepc = NULL; + U32 *linepc = NULL; /* position of last FF_LINEMARK */ register I32 arg; - bool ischop; - bool unchopnum = FALSE; + bool ischop; /* it's a ^ rather than a @ */ + bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */ int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */ + MAGIC *mg = NULL; + SV *sv_copy; PERL_ARGS_ASSERT_DOPARSEFORM; if (len == 0) Perl_croak(aTHX_ "Null picture in formline"); + if (SvTYPE(sv) >= SVt_PVMG) { + /* This might, of course, still return NULL. */ + mg = mg_find(sv, PERL_MAGIC_fm); + } else { + sv_upgrade(sv, SVt_PVMG); + } + + if (mg) { + /* still the same as previously-compiled string? */ + SV *old = mg->mg_obj; + if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv)) + && len == SvCUR(old) + && strnEQ(SvPVX(old), SvPVX(sv), len) + ) { + DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n")); + return mg; + } + + DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n")); + Safefree(mg->mg_ptr); + mg->mg_ptr = NULL; + SvREFCNT_dec(old); + mg->mg_obj = NULL; + } + else { + DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n")); + mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0); + } + + sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv)); + s = SvPV(sv_copy, len); /* work on the copy, not the original */ + send = s + len; + + /* estimate the buffer size needed */ for (base = s; s <= send; s++) { if (*s == '\n' || *s == '@' || *s == '^') @@ -4868,10 +5015,10 @@ S_doparseform(pTHX_ SV *sv) case '~': if (*s == '~') { repeat = TRUE; - *s = ' '; + skipspaces++; + s++; } noblank = TRUE; - s[-1] = ' '; /* FALL THROUGH */ case ' ': case '\t': skipspaces++; @@ -4935,7 +5082,7 @@ S_doparseform(pTHX_ SV *sv) base = s - 1; *fpc++ = FF_FETCH; - if (*s == '*') { + if (*s == '*') { /* @* or ^* */ s++; *fpc++ = 2; /* skip the @* or ^* */ if (ischop) { @@ -4944,7 +5091,7 @@ S_doparseform(pTHX_ SV *sv) } else *fpc++ = FF_LINEGLOB; } - else if (*s == '#' || (*s == '.' && s[1] == '#')) { + else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */ arg = ischop ? 512 : 0; base = s - 1; while (*s == '#') @@ -4977,7 +5124,7 @@ S_doparseform(pTHX_ SV *sv) *fpc++ = (U16)arg; unchopnum |= ! ischop; } - else { + else { /* text field */ I32 prespace = 0; bool ismore = FALSE; @@ -5004,7 +5151,7 @@ S_doparseform(pTHX_ SV *sv) *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL; if (prespace) - *fpc++ = (U16)prespace; + *fpc++ = (U16)prespace; /* add SPACE or HALFSPACE */ *fpc++ = FF_ITEM; if (ismore) *fpc++ = FF_MORE; @@ -5020,20 +5167,16 @@ S_doparseform(pTHX_ SV *sv) assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */ arg = fpc - fops; - { /* need to jump to the next word */ - int z; - z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN; - SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4); - s = SvPVX(sv) + SvCUR(sv) + z; - } - Copy(fops, s, arg, U32); - Safefree(fops); - sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0); - SvCOMPILED_on(sv); + + mg->mg_ptr = (char *) fops; + mg->mg_len = arg * sizeof(U32); + mg->mg_obj = sv_copy; + mg->mg_flags |= MGf_REFCOUNTED; if (unchopnum && repeat) - DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)"); - return 0; + Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)"); + + return mg; } @@ -5115,7 +5258,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) if (take) { sv_catpvn(buf_sv, cache_p, take); sv_chop(cache, cache_p + take); - /* Definately not EOF */ + /* Definitely not EOF */ return 1; }