X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=7cc86558f218a8587b5d02c9d1a4fc85f6601199;hb=ba7b5225a182490f0fddd225ae43578870f30c47;hp=4b9ba00a0927b5f1f20ea6b32134ddb3cc9e39e2;hpb=36477c247f3c188fb8cc7e276c87b739d3e6ab7c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 4b9ba00..7cc8655 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1,6 +1,6 @@ /* pp_hot.c * - * Copyright (c) 1991-1994, Larry Wall + * Copyright (c) 1991-1997, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -97,7 +97,7 @@ PP(pp_gelem) break; case 'C': if (strEQ(elem, "CODE")) - ref = (SV*)GvCV(gv); + ref = (SV*)GvCVu(gv); break; case 'F': if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */ @@ -160,8 +160,7 @@ PP(pp_sassign) } if (tainting && tainted && !SvTAINTED(left)) TAINT_NOT; - SvSetSV(right, left); - SvSETMAGIC(right); + SvSetMagicSV(right, left); SETs(right); RETURN; } @@ -199,12 +198,15 @@ PP(pp_concat) } else if (SvGMAGICAL(TARG)) mg_get(TARG); - else if (!SvOK(TARG)) { - s = SvPV_force(TARG, len); + else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) { sv_setpv(TARG, ""); /* Suppress warning. */ + s = SvPV_force(TARG, len); } s = SvPV(right,len); - sv_catpvn(TARG,s,len); + if (SvOK(TARG)) + sv_catpvn(TARG,s,len); + else + sv_setpvn(TARG,s,len); /* suppress warning */ SETTARG; RETURN; } @@ -217,8 +219,8 @@ PP(pp_padsv) if (op->op_flags & OPf_MOD) { if (op->op_private & OPpLVAL_INTRO) SAVECLEARSV(curpad[op->op_targ]); - else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) - provide_ref(op, curpad[op->op_targ]); + else if (op->op_private & OPpDEREF) + vivify_ref(curpad[op->op_targ], op->op_private & OPpDEREF); } RETURN; } @@ -234,7 +236,7 @@ PP(pp_eq) dSP; tryAMAGICbinSET(eq,0); { dPOPnv; - SETs((TOPn == value) ? &sv_yes : &sv_no); + SETs(boolSV(TOPn == value)); RETURN; } } @@ -242,6 +244,8 @@ PP(pp_eq) PP(pp_preinc) { dSP; + if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + croak(no_modify); if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && SvIVX(TOPs) != IV_MAX) { @@ -269,7 +273,7 @@ PP(pp_add) { dSP; dATARGET; tryAMAGICbin(add,opASSIGN); { - dPOPTOPnnrl; + dPOPTOPnnrl_ul; SETn( left + right ); RETURN; } @@ -297,7 +301,19 @@ PP(pp_join) PP(pp_pushre) { dSP; +#ifdef DEBUGGING + /* + * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs + * will be enough to hold an OP*. + */ + SV* sv = sv_newmortal(); + sv_upgrade(sv, SVt_PVLV); + LvTYPE(sv) = '/'; + Copy(&op, &LvTARGOFF(sv), 1, OP*); + XPUSHs(sv); +#else XPUSHs((SV*)op); +#endif RETURN; } @@ -316,17 +332,22 @@ PP(pp_print) else gv = defoutgv; if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) { - SV *sv; - - PUSHMARK(MARK-1); + if (MARK == ORIGMARK) { + EXTEND(SP, 1); + ++MARK; + Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); + ++SP; + } + PUSHMARK(MARK - 1); *MARK = mg->mg_obj; + PUTBACK; ENTER; perl_call_method("PRINT", G_SCALAR); LEAVE; SPAGAIN; - sv = POPs; - SP = ORIGMARK; - PUSHs(sv); + MARK = ORIGMARK + 1; + *MARK = *SP; + SP = MARK; RETURN; } if (!(io = GvIO(gv))) { @@ -398,7 +419,6 @@ PP(pp_print) PP(pp_rv2av) { dSP; dPOPss; - AV *av; if (SvROK(sv)) { @@ -436,6 +456,8 @@ PP(pp_rv2av) if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "an ARRAY"); + if (dowarn) + warn(warn_uninit); if (GIMME == G_ARRAY) RETURN; RETPUSHUNDEF; @@ -473,9 +495,7 @@ PP(pp_rv2av) PP(pp_rv2hv) { - dSP; dTOPss; - HV *hv; if (SvROK(sv)) { @@ -513,6 +533,8 @@ PP(pp_rv2hv) if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a HASH"); + if (dowarn) + warn(warn_uninit); if (GIMME == G_ARRAY) { SP--; RETURN; @@ -543,7 +565,7 @@ PP(pp_rv2hv) else { dTARGET; if (HvFILL(hv)) { - sprintf(buf, "%d/%d", HvFILL(hv), HvMAX(hv)+1); + sprintf(buf, "%ld/%ld", (long)HvFILL(hv), (long)HvMAX(hv)+1); sv_setpv(TARG, buf); } else @@ -567,6 +589,7 @@ PP(pp_aassign) register SV *sv; register AV *ary; + I32 gimme; HV *hash; I32 i; int magic; @@ -598,6 +621,7 @@ PP(pp_aassign) magic = SvMAGICAL(ary) != 0; av_clear(ary); + av_extend(ary, lastrelem - relem); i = 0; while (relem <= lastrelem) { /* gobble up all the rest */ sv = NEWSV(28,0); @@ -720,20 +744,25 @@ PP(pp_aassign) tainting |= (uid && (euid != uid || egid != gid)); } delaymagic = 0; - if (GIMME == G_ARRAY) { + + gimme = GIMME_V; + if (gimme == G_VOID) + SP = firstrelem - 1; + else if (gimme == G_SCALAR) { + dTARGET; + SP = firstrelem; + SETi(lastrelem - firstrelem + 1); + } + else { if (ary || hash) SP = lastrelem; else SP = firstrelem + (lastlelem - firstlelem); - RETURN; - } - else { - dTARGET; - SP = firstrelem; - - SETi(lastrelem - firstrelem + 1); - RETURN; + lelem = firstlelem + (relem - firstrelem); + while (relem <= SP) + *relem++ = (lelem <= lastlelem) ? *lelem++ : &sv_undef; } + RETURN; } PP(pp_match) @@ -751,6 +780,7 @@ PP(pp_match) STRLEN len; I32 minmatch = 0; I32 oldsave = savestack_ix; + I32 update_minmatch = 1; if (op->op_flags & OPf_STACKED) TARG = POPs; @@ -762,6 +792,7 @@ PP(pp_match) strend = s + len; if (!s) DIE("panic: do_match"); + TAINT_NOT; if (pm->op_pmflags & PMf_USED) { if (gimme == G_ARRAY) @@ -781,12 +812,14 @@ PP(pp_match) if (mg && mg->mg_len >= 0) { rx->endp[0] = rx->startp[0] = s + mg->mg_len; minmatch = (mg->mg_flags & MGf_MINMATCH); + update_minmatch = 0; } } } if (!rx->nparens && !global) gimme = G_SCALAR; /* accidental array context? */ - safebase = (gimme == G_ARRAY) || global; + safebase = (((gimme == G_ARRAY) || global || !rx->nparens) + && !sawampersand); if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { SAVEINT(multiline); multiline = pm->op_pmflags & PMf_MULTILINE; @@ -795,9 +828,10 @@ PP(pp_match) play_it_again: if (global && rx->startp[0]) { t = s = rx->endp[0]; - if (s > strend) + if ((s + rx->minlen) > strend) goto nope; - minmatch = (s == rx->startp[0]); + if (update_minmatch++) + minmatch = (s == rx->startp[0]); } if (pm->op_pmshort) { if (pm->op_pmflags & PMf_SCANFIRST) { @@ -847,10 +881,10 @@ play_it_again: /*NOTREACHED*/ gotcha: + TAINT_IF(rx->exec_tainted); if (gimme == G_ARRAY) { I32 iters, i, len; - TAINT_IF(rx->exec_tainted); iters = rx->nparens; if (global && !iters) i = 1; @@ -868,6 +902,7 @@ play_it_again: } if (global) { truebase = rx->subbeg; + strend = rx->subend; if (rx->startp[0] && rx->startp[0] == rx->endp[0]) ++rx->endp[0]; goto play_it_again; @@ -885,24 +920,25 @@ play_it_again: mg = mg_find(TARG, 'g'); } if (rx->startp[0]) { - mg->mg_len = rx->endp[0] - truebase; + mg->mg_len = rx->endp[0] - rx->subbeg; if (rx->startp[0] == rx->endp[0]) mg->mg_flags |= MGf_MINMATCH; else mg->mg_flags &= ~MGf_MINMATCH; } - else - mg->mg_len = -1; } LEAVE_SCOPE(oldsave); RETPUSHYES; } yup: + TAINT_IF(rx->exec_tainted); ++BmUSEFUL(pm->op_pmshort); curpm = pm; if (pm->op_pmflags & PMf_ONCE) pm->op_pmflags |= PMf_USED; + Safefree(rx->subbase); + rx->subbase = Nullch; if (global) { rx->subbeg = truebase; rx->subend = strend; @@ -913,8 +949,6 @@ yup: if (sawampersand) { char *tmps; - if (rx->subbase) - Safefree(rx->subbase); tmps = rx->subbase = savepvn(t, strend-t); rx->subbeg = tmps; rx->subend = tmps + (strend-t); @@ -929,13 +963,6 @@ nope: ++BmUSEFUL(pm->op_pmshort); ret_no: - if (global) { - if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { - MAGIC* mg = mg_find(TARG, 'g'); - if (mg) - mg->mg_len = -1; - } - } LEAVE_SCOPE(oldsave); if (gimme == G_ARRAY) RETURN; @@ -952,6 +979,7 @@ do_readline() PerlIO *fp; register IO *io = GvIO(last_in_gv); register I32 type = op->op_type; + I32 gimme = GIMME_V; MAGIC *mg; if (SvMAGICAL(last_in_gv) && (mg = mg_find((SV*)last_in_gv, 'q'))) { @@ -959,10 +987,11 @@ do_readline() XPUSHs(mg->mg_obj); PUTBACK; ENTER; - perl_call_method("READLINE", GIMME); + perl_call_method("READLINE", gimme); LEAVE; SPAGAIN; - if (GIMME == G_SCALAR) sv_setsv(TARG, TOPs); + if (gimme == G_SCALAR) + SvSetMagicSV_nosteal(TARG, TOPs); RETURN; } fp = Nullfp; @@ -1041,7 +1070,7 @@ do_readline() *(end++) = '\n'; *end = '\0'; for (cp = rstr; *cp; cp++) *cp = _tolower(*cp); if (hasdir) { - if (isunix) trim_unixpath(rstr,SvPVX(tmpglob)); + if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1); begin = rstr; } else { @@ -1065,6 +1094,7 @@ do_readline() PerlIO_rewind(tmpfp); IoTYPE(io) = '<'; IoIFP(io) = fp = tmpfp; + IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */ } } } @@ -1108,18 +1138,16 @@ do_readline() if (!fp) { if (dowarn && io && !(IoFLAGS(io) & IOf_START)) warn("Read on closed filehandle <%s>", GvENAME(last_in_gv)); - if (GIMME == G_SCALAR) { + if (gimme == G_SCALAR) { (void)SvOK_off(TARG); PUSHTARG; } RETURN; } - if (GIMME == G_ARRAY) { - sv = sv_2mortal(NEWSV(57, 80)); - offset = 0; - } - else { + if (gimme == G_SCALAR) { sv = TARG; + if (SvROK(sv)) + sv_unref(sv); (void)SvUPGRADE(sv, SVt_PV); tmplen = SvLEN(sv); /* remember if already alloced */ if (!tmplen) @@ -1129,6 +1157,10 @@ do_readline() else offset = 0; } + else { + sv = sv_2mortal(NEWSV(57, 80)); + offset = 0; + } for (;;) { if (!sv_gets(sv, fp, offset)) { PerlIO_clearerr(fp); @@ -1140,9 +1172,10 @@ do_readline() IoFLAGS(io) |= IOf_START; } else if (type == OP_GLOB) { - (void)do_close(last_in_gv, FALSE); + if (do_close(last_in_gv, FALSE) & ~0xFF) + warn("internal error: glob failed"); } - if (GIMME == G_SCALAR) { + if (gimme == G_SCALAR) { (void)SvOK_off(TARG); PUSHTARG; } @@ -1154,6 +1187,7 @@ do_readline() SvTAINTED_on(sv); } IoLINES(io)++; + SvSETMAGIC(sv); XPUSHs(sv); if (type == OP_GLOB) { char *tmps; @@ -1174,7 +1208,7 @@ do_readline() continue; } } - if (GIMME == G_ARRAY) { + if (gimme == G_ARRAY) { if (SvLEN(sv) - SvCUR(sv) > 20) { SvLEN_set(sv, SvCUR(sv)+1); Renew(SvPVX(sv), SvLEN(sv), char); @@ -1182,7 +1216,7 @@ do_readline() sv = sv_2mortal(NEWSV(58, 80)); continue; } - else if (!tmplen && SvLEN(sv) - SvCUR(sv) > 80) { + else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) { /* try to reclaim a bit of scalar space (only on 1st alloc) */ if (SvCUR(sv) < 60) SvLEN_set(sv, 80); @@ -1198,19 +1232,14 @@ PP(pp_enter) { dSP; register CONTEXT *cx; - I32 gimme; - - /* - * We don't just use the GIMME macro here because it assumes there's - * already a context, which ain't necessarily so at initial startup. - */ + I32 gimme = OP_GIMME(op, -1); - if (op->op_flags & OPf_KNOW) - gimme = op->op_flags & OPf_LIST; - else if (cxstack_ix >= 0) - gimme = cxstack[cxstack_ix].blk_gimme; - else - gimme = G_SCALAR; + if (gimme == -1) { + if (cxstack_ix >= 0) + gimme = cxstack[cxstack_ix].blk_gimme; + else + gimme = G_SCALAR; + } ENTER; @@ -1226,18 +1255,36 @@ PP(pp_helem) HE* he; SV *keysv = POPs; HV *hv = (HV*)POPs; - I32 lval = op->op_flags & OPf_MOD; + U32 lval = op->op_flags & OPf_MOD; + U32 defer = op->op_private & OPpLVAL_DEFER; if (SvTYPE(hv) != SVt_PVHV) RETPUSHUNDEF; - he = hv_fetch_ent(hv, keysv, lval, 0); + he = hv_fetch_ent(hv, keysv, lval && !defer, 0); if (lval) { - if (!he || HeVAL(he) == &sv_undef) - DIE(no_helem, SvPV(keysv, na)); - if (op->op_private & OPpLVAL_INTRO) - save_svref(&HeVAL(he)); - else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) - provide_ref(op, HeVAL(he)); + if (!he || HeVAL(he) == &sv_undef) { + SV* lv; + SV* key2; + if (!defer) + DIE(no_helem, SvPV(keysv, na)); + lv = sv_newmortal(); + sv_upgrade(lv, SVt_PVLV); + LvTYPE(lv) = 'y'; + sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0); + SvREFCNT_dec(key2); /* sv_magic() increments refcount */ + LvTARG(lv) = SvREFCNT_inc(hv); + LvTARGLEN(lv) = 1; + PUSHs(lv); + RETURN; + } + if (op->op_private & OPpLVAL_INTRO) { + if (HvNAME(hv) && isGV(HeVAL(he))) + save_gp((GV*)HeVAL(he), !(op->op_flags & OPf_SPECIAL)); + else + save_svref(&HeVAL(he)); + } + else if (op->op_private & OPpDEREF) + vivify_ref(HeVAL(he), op->op_private & OPpDEREF); } PUSHs(he ? HeVAL(he) : &sv_undef); RETURN; @@ -1259,31 +1306,30 @@ PP(pp_leave) POPBLOCK(cx,newpm); - if (op->op_flags & OPf_KNOW) - gimme = op->op_flags & OPf_LIST; - else if (cxstack_ix >= 0) - gimme = cxstack[cxstack_ix].blk_gimme; - else - gimme = G_SCALAR; + gimme = OP_GIMME(op, -1); + if (gimme == -1) { + if (cxstack_ix >= 0) + gimme = cxstack[cxstack_ix].blk_gimme; + else + gimme = G_SCALAR; + } - if (gimme == G_SCALAR) { - if (op->op_private & OPpLEAVE_VOID) - SP = newsp; + if (gimme == G_VOID) + SP = newsp; + else if (gimme == G_SCALAR) { + MARK = newsp + 1; + if (MARK <= SP) + if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) + *MARK = TOPs; + else + *MARK = sv_mortalcopy(TOPs); else { - MARK = newsp + 1; - if (MARK <= SP) - if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); - else { - MEXTEND(mark,0); - *MARK = &sv_undef; - } - SP = MARK; + MEXTEND(mark,0); + *MARK = &sv_undef; } + SP = MARK; } - else { + else if (gimme == G_ARRAY) { for (mark = newsp + 1; mark <= SP; mark++) if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) *mark = sv_mortalcopy(*mark); @@ -1300,27 +1346,45 @@ PP(pp_iter) { dSP; register CONTEXT *cx; - SV *sv; + SV* sv; AV* av; EXTEND(sp, 1); cx = &cxstack[cxstack_ix]; if (cx->cx_type != CXt_LOOP) DIE("panic: pp_iter"); + av = cx->blk_loop.iterary; - if (av == curstack && cx->blk_loop.iterix >= cx->blk_oldsp) + if (cx->blk_loop.iterix >= (av == curstack ? cx->blk_oldsp : AvFILL(av))) RETPUSHNO; - if (cx->blk_loop.iterix >= AvFILL(av)) - RETPUSHNO; + SvREFCNT_dec(*cx->blk_loop.itervar); - if (sv = AvARRAY(av)[++cx->blk_loop.iterix]) { + if (sv = AvARRAY(av)[++cx->blk_loop.iterix]) SvTEMP_off(sv); - *cx->blk_loop.itervar = sv; - } else - *cx->blk_loop.itervar = &sv_undef; + sv = &sv_undef; + if (av != curstack && SvIMMORTAL(sv)) { + SV *lv = cx->blk_loop.iterlval; + if (lv && SvREFCNT(lv) > 1) { + SvREFCNT_dec(lv); + lv = Nullsv; + } + if (lv) + SvREFCNT_dec(LvTARG(lv)); + else { + lv = cx->blk_loop.iterlval = NEWSV(26, 0); + sv_upgrade(lv, SVt_PVLV); + LvTYPE(lv) = 'y'; + sv_magic(lv, Nullsv, 'y', Nullch, 0); + } + LvTARG(lv) = SvREFCNT_inc(av); + LvTARGOFF(lv) = cx->blk_loop.iterix; + LvTARGLEN(lv) = -1; + sv = (SV*)lv; + } + *cx->blk_loop.itervar = SvREFCNT_inc(sv); RETPUSHYES; } @@ -1340,6 +1404,7 @@ PP(pp_subst) I32 maxiters; register I32 i; bool once; + bool rxtainted; char *orig; I32 safebase; register REGEXP *rx = pm->op_pmregexp; @@ -1347,17 +1412,22 @@ PP(pp_subst) int force_on_match = 0; I32 oldsave = savestack_ix; - if (pm->op_pmflags & PMf_CONST) /* known replacement string? */ - dstr = POPs; + /* known replacement string? */ + dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; if (op->op_flags & OPf_STACKED) TARG = POPs; else { TARG = GvSV(defgv); EXTEND(SP,1); } + if (SvREADONLY(TARG) + || (SvTYPE(TARG) > SVt_PVLV + && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))) + croak(no_modify); s = SvPV(TARG, len); - if (!SvPOKp(TARG) || SvREADONLY(TARG) || (SvTYPE(TARG) == SVt_PVGV)) + if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV) force_on_match = 1; + TAINT_NOT; force_it: if (!pm || !s) @@ -1370,7 +1440,7 @@ PP(pp_subst) pm = curpm; rx = pm->op_pmregexp; } - safebase = ((!rx || !rx->nparens) && !sawampersand); + safebase = (!rx->nparens && !sawampersand); if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) { SAVEINT(multiline); multiline = pm->op_pmflags & PMf_MULTILINE; @@ -1407,124 +1477,112 @@ PP(pp_subst) pm->op_pmshort = Nullsv; /* opt is being useless */ } } + + /* only replace once? */ once = !(rpm->op_pmflags & PMf_GLOBAL); - if (rpm->op_pmflags & PMf_CONST) { /* known replacement string? */ - c = SvPV(dstr, clen); - if (clen <= rx->minlen) { - /* can do inplace substitution */ - if (pregexec(rx, s, strend, orig, 0, - SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { - if (force_on_match) { - force_on_match = 0; - s = SvPV_force(TARG, len); - goto force_it; + + /* known replacement string? */ + c = dstr ? SvPV(dstr, clen) : Nullch; + + /* can do inplace substitution? */ + if (c && clen <= rx->minlen && safebase) { + if (! pregexec(rx, s, strend, orig, 0, + SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { + PUSHs(&sv_no); + LEAVE_SCOPE(oldsave); + RETURN; + } + if (force_on_match) { + force_on_match = 0; + s = SvPV_force(TARG, len); + goto force_it; + } + d = s; + curpm = pm; + SvSCREAM_off(TARG); /* disable possible screamer */ + if (once) { + rxtainted = rx->exec_tainted; + m = rx->startp[0]; + d = rx->endp[0]; + s = orig; + if (m - s > strend - d) { /* faster to shorten from end */ + if (clen) { + Copy(c, m, clen, char); + m += clen; } - if (rx->subbase) /* oops, no we can't */ - goto long_way; - d = s; - curpm = pm; - SvSCREAM_off(TARG); /* disable possible screamer */ - if (once) { - m = rx->startp[0]; - d = rx->endp[0]; - s = orig; - if (m - s > strend - d) { /* faster to shorten from end */ - if (clen) { - Copy(c, m, clen, char); - m += clen; - } - i = strend - d; - if (i > 0) { - Move(d, m, i, char); - m += i; - } - *m = '\0'; - SvCUR_set(TARG, m - s); - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - LEAVE_SCOPE(oldsave); - RETURN; - } - /*SUPPRESS 560*/ - else if (i = m - s) { /* faster from front */ - d -= clen; - m = d; - sv_chop(TARG, d-i); - s += i; - while (i--) - *--d = *--s; - if (clen) - Copy(c, m, clen, char); - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - LEAVE_SCOPE(oldsave); - RETURN; - } - else if (clen) { - d -= clen; - sv_chop(TARG, d); - Copy(c, d, clen, char); - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - LEAVE_SCOPE(oldsave); - RETURN; - } - else { - sv_chop(TARG, d); - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(&sv_yes); - LEAVE_SCOPE(oldsave); - RETURN; - } - /* NOTREACHED */ + i = strend - d; + if (i > 0) { + Move(d, m, i, char); + m += i; } - do { - if (iters++ > maxiters) - DIE("Substitution loop"); - m = rx->startp[0]; - /*SUPPRESS 560*/ - if (i = m - s) { - if (s != d) - Move(s, d, i, char); - d += i; - } - if (clen) { - Copy(c, d, clen, char); - d += clen; - } - s = rx->endp[0]; - } while (pregexec(rx, s, strend, orig, s == m, - Nullsv, TRUE)); /* (don't match same null twice) */ - if (s != d) { - i = strend - s; - SvCUR_set(TARG, d - SvPVX(TARG) + i); - Move(s, d, i+1, char); /* include the Null */ + *m = '\0'; + SvCUR_set(TARG, m - s); + } + /*SUPPRESS 560*/ + else if (i = m - s) { /* faster from front */ + d -= clen; + m = d; + sv_chop(TARG, d-i); + s += i; + while (i--) + *--d = *--s; + if (clen) + Copy(c, m, clen, char); + } + else if (clen) { + d -= clen; + sv_chop(TARG, d); + Copy(c, d, clen, char); + } + else { + sv_chop(TARG, d); + } + TAINT_IF(rxtainted); + PUSHs(&sv_yes); + } + else { + rxtainted = 0; + do { + if (iters++ > maxiters) + DIE("Substitution loop"); + rxtainted |= rx->exec_tainted; + m = rx->startp[0]; + /*SUPPRESS 560*/ + if (i = m - s) { + if (s != d) + Move(s, d, i, char); + d += i; } - (void)SvPOK_only(TARG); - SvSETMAGIC(TARG); - PUSHs(sv_2mortal(newSViv((I32)iters))); - LEAVE_SCOPE(oldsave); - RETURN; + if (clen) { + Copy(c, d, clen, char); + d += clen; + } + s = rx->endp[0]; + } while (pregexec(rx, s, strend, orig, s == m, + Nullsv, TRUE)); /* don't match same null twice */ + if (s != d) { + i = strend - s; + SvCUR_set(TARG, d - SvPVX(TARG) + i); + Move(s, d, i+1, char); /* include the NUL */ } - PUSHs(&sv_no); - LEAVE_SCOPE(oldsave); - RETURN; + TAINT_IF(rxtainted); + PUSHs(sv_2mortal(newSViv((I32)iters))); } + (void)SvPOK_only(TARG); + SvSETMAGIC(TARG); + SvTAINT(TARG); + LEAVE_SCOPE(oldsave); + RETURN; } - else - c = Nullch; + if (pregexec(rx, s, strend, orig, 0, - SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { - long_way: + SvSCREAM(TARG) ? TARG : Nullsv, safebase)) { if (force_on_match) { force_on_match = 0; s = SvPV_force(TARG, len); goto force_it; } + rxtainted = rx->exec_tainted; dstr = NEWSV(25, sv_len(TARG)); sv_setpvn(dstr, m, s-m); curpm = pm; @@ -1536,6 +1594,7 @@ PP(pp_subst) do { if (iters++ > maxiters) DIE("Substitution loop"); + rxtainted |= rx->exec_tainted; if (rx->subbase && rx->subbase != orig) { m = s; s = orig; @@ -1550,10 +1609,11 @@ PP(pp_subst) sv_catpvn(dstr, c, clen); if (once) break; - } while (pregexec(rx, s, strend, orig, s == m, Nullsv, - safebase)); + } while (pregexec(rx, s, strend, orig, s == m, Nullsv, safebase)); sv_catpvn(dstr, s, strend - s); + TAINT_IF(rxtainted); + (void)SvOOK_off(TARG); Safefree(SvPVX(TARG)); SvPVX(TARG) = SvPVX(dstr); @@ -1564,16 +1624,17 @@ PP(pp_subst) (void)SvPOK_only(TARG); SvSETMAGIC(TARG); + SvTAINT(TARG); PUSHs(sv_2mortal(newSViv((I32)iters))); LEAVE_SCOPE(oldsave); RETURN; } - PUSHs(&sv_no); - LEAVE_SCOPE(oldsave); - RETURN; + goto ret_no; nope: ++BmUSEFUL(pm->op_pmshort); + +ret_no: PUSHs(&sv_no); LEAVE_SCOPE(oldsave); RETURN; @@ -1591,18 +1652,19 @@ PP(pp_grepwhile) /* All done yet? */ if (stack_base + *markstack_ptr > sp) { I32 items; + I32 gimme = GIMME_V; LEAVE; /* exit outer scope */ (void)POPMARK; /* pop src */ items = --*markstack_ptr - markstack_ptr[-1]; (void)POPMARK; /* pop dst */ SP = stack_base + POPMARK; /* pop original mark */ - if (GIMME != G_ARRAY) { + if (gimme == G_SCALAR) { dTARGET; XPUSHi(items); - RETURN; } - SP += items; + else if (gimme == G_ARRAY) + SP += items; RETURN; } else { @@ -1627,40 +1689,33 @@ PP(pp_leavesub) PMOP *newpm; I32 gimme; register CONTEXT *cx; + struct block_sub cxsub; POPBLOCK(cx,newpm); - POPSUB(cx); - + POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */ + if (gimme == G_SCALAR) { MARK = newsp + 1; if (MARK <= SP) - if (SvFLAGS(TOPs) & SVs_TEMP) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); + *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); else { - MEXTEND(mark,0); + MEXTEND(MARK, 0); *MARK = &sv_undef; } SP = MARK; } - else { - for (mark = newsp + 1; mark <= SP; mark++) - if (!(SvFLAGS(*mark) & SVs_TEMP)) - *mark = sv_mortalcopy(*mark); - /* in case LEAVE wipes old return values */ - } - - if (cx->blk_sub.hasargs) { /* You don't exist; go away. */ - AV* av = cx->blk_sub.argarray; - - av_clear(av); - AvREAL_off(av); + else if (gimme == G_ARRAY) { + for (MARK = newsp + 1; MARK <= SP; MARK++) { + if (!SvTEMP(*MARK)) + *MARK = sv_mortalcopy(*MARK); + } } - curpm = newpm; /* Don't pop $1 et al till now */ + PUTBACK; + + POPSUB2(); /* Stack values are safe: release CV and @_ ... */ + curpm = newpm; /* ... and pop $1 et al */ LEAVE; - PUTBACK; return pop_return(); } @@ -1672,7 +1727,7 @@ PP(pp_entersub) register CV *cv; register CONTEXT *cx; I32 gimme; - I32 hasargs = (op->op_flags & OPf_STACKED) != 0; + bool hasargs = (op->op_flags & OPf_STACKED) != 0; if (!sv) DIE("Not a CODE reference"); @@ -1683,9 +1738,14 @@ PP(pp_entersub) if (sv == &sv_yes) /* unfound import, ignore */ RETURN; - if (!SvOK(sv)) + if (SvGMAGICAL(sv)) { + mg_get(sv); + sym = SvPOKp(sv) ? SvPVX(sv) : Nullch; + } + else + sym = SvPV(sv, na); + if (!sym) DIE(no_usym, "a subroutine"); - sym = SvPV(sv,na); if (op->op_private & HINT_STRICT_REFS) DIE(no_symref, sym, "a subroutine"); cv = perl_get_cv(sym, TRUE); @@ -1702,7 +1762,7 @@ PP(pp_entersub) cv = (CV*)sv; break; case SVt_PVGV: - if (!(cv = GvCV((GV*)sv))) + if (!(cv = GvCVu((GV*)sv))) cv = sv_2cv(sv, &stash, &gv, TRUE); break; } @@ -1715,40 +1775,42 @@ PP(pp_entersub) DIE("Not a CODE reference"); if (!CvROOT(cv) && !CvXSUB(cv)) { - if (gv = CvGV(cv)) { - SV *tmpstr; - GV *ngv; - if (SvFAKE(cv) && GvCV(gv) != cv) { /* autoloaded stub? */ - cv = GvCV(gv); - if (SvTYPE(sv) == SVt_PVGV) { - SvREFCNT_dec(GvCV((GV*)sv)); - GvCV((GV*)sv) = (CV*)SvREFCNT_inc((SV*)cv); - } - goto retry; - } - tmpstr = sv_newmortal(); - gv_efullname3(tmpstr, gv, Nullch); - ngv = gv_fetchmethod(GvESTASH(gv), "AUTOLOAD"); - if (ngv && ngv != gv && (cv = GvCV(ngv))) { /* One more chance... */ - gv = ngv; - sv_setsv(GvSV(CvGV(cv)), tmpstr); /* Set CV's $AUTOLOAD */ - SvTAINTED_off(GvSV(CvGV(cv))); - goto retry; - } - else - DIE("Undefined subroutine &%s called",SvPVX(tmpstr)); + GV* autogv; + SV* subname; + + /* anonymous or undef'd function leaves us no recourse */ + if (CvANON(cv) || !(gv = CvGV(cv))) + DIE("Undefined subroutine called"); + /* autoloaded stub? */ + if (cv != GvCV(gv)) { + cv = GvCV(gv); + goto retry; + } + /* should call AUTOLOAD now? */ + if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), + FALSE))) + { + cv = GvCV(autogv); + goto retry; } - DIE("Undefined subroutine called"); + /* sorry */ + subname = sv_newmortal(); + gv_efullname3(subname, gv, Nullch); + DIE("Undefined subroutine &%s called", SvPVX(subname)); } - gimme = GIMME; - if ((op->op_private & OPpENTERSUB_DB)) { + gimme = GIMME_V; + if ((op->op_private & OPpENTERSUB_DB) && GvCV(DBsub) && !CvNODEBUG(cv)) { + SV *oldsv = sv; sv = GvSV(DBsub); save_item(sv); gv = CvGV(cv); - if ( CvFLAGS(cv) & (CVf_ANON | CVf_CLONED) - || strEQ(GvNAME(gv), "END") ) { - /* GV is potentially non-unique */ + if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) + || strEQ(GvNAME(gv), "END") + || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ + !( (SvTYPE(oldsv) == SVt_PVGV) && (GvCV((GV*)oldsv) == cv) + && (gv = (GV*)oldsv) ))) { /* Use GV from the stack as a fallback. */ + /* GV is potentially non-unique, or contain different CV. */ sv_setsv(sv, newRV((SV*)cv)); } else { @@ -1831,8 +1893,9 @@ PP(pp_entersub) if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ - if (CvDEPTH(cv) == 100 && dowarn) - warn("Deep recursion on subroutine \"%s\"",GvENAME(CvGV(cv))); + if (CvDEPTH(cv) == 100 && dowarn + && !(perldb && cv == GvCV(DBsub))) + sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { AV *av; AV *newpad = newAV(); @@ -1842,9 +1905,10 @@ PP(pp_entersub) for ( ;ix > 0; ix--) { if (svp[ix] != &sv_undef) { char *name = SvPVX(svp[ix]); - if (SvFLAGS(svp[ix]) & SVf_FAKE) { /* outer lexical? */ - av_store(newpad, ix, - SvREFCNT_inc(oldpad[ix]) ); + if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */ + || *name == '&') /* anonymous code? */ + { + av_store(newpad, ix, SvREFCNT_inc(oldpad[ix])); } else { /* our own lexical */ if (*name == '@') @@ -1882,7 +1946,7 @@ PP(pp_entersub) } cx->blk_sub.savearray = GvAV(defgv); cx->blk_sub.argarray = av; - GvAV(defgv) = cx->blk_sub.argarray; + GvAV(defgv) = (AV*)SvREFCNT_inc(av); ++MARK; if (items > AvMAX(av) + 1) { @@ -1911,44 +1975,85 @@ PP(pp_entersub) } } +void +sub_crush_depth(cv) +CV* cv; +{ + if (CvANON(cv)) + warn("Deep recursion on anonymous subroutine"); + else { + SV* tmpstr = sv_newmortal(); + gv_efullname3(tmpstr, CvGV(cv), Nullch); + warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr)); + } +} + PP(pp_aelem) { dSP; SV** svp; I32 elem = POPi; - AV *av = (AV*)POPs; - I32 lval = op->op_flags & OPf_MOD; + AV* av = (AV*)POPs; + U32 lval = op->op_flags & OPf_MOD; + U32 defer = (op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av)); if (elem > 0) elem -= curcop->cop_arybase; if (SvTYPE(av) != SVt_PVAV) RETPUSHUNDEF; - svp = av_fetch(av, elem, lval); + svp = av_fetch(av, elem, lval && !defer); if (lval) { - if (!svp || *svp == &sv_undef) - DIE(no_aelem, elem); + if (!svp || *svp == &sv_undef) { + SV* lv; + if (!defer) + DIE(no_aelem, elem); + lv = sv_newmortal(); + sv_upgrade(lv, SVt_PVLV); + LvTYPE(lv) = 'y'; + sv_magic(lv, Nullsv, 'y', Nullch, 0); + LvTARG(lv) = SvREFCNT_inc(av); + LvTARGOFF(lv) = elem; + LvTARGLEN(lv) = 1; + PUSHs(lv); + RETURN; + } if (op->op_private & OPpLVAL_INTRO) save_svref(svp); - else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) - provide_ref(op, *svp); + else if (op->op_private & OPpDEREF) + vivify_ref(*svp, op->op_private & OPpDEREF); } PUSHs(svp ? *svp : &sv_undef); RETURN; } void -provide_ref(op, sv) -OP* op; +vivify_ref(sv, to_what) SV* sv; +U32 to_what; { if (SvGMAGICAL(sv)) mg_get(sv); if (!SvOK(sv)) { if (SvREADONLY(sv)) croak(no_modify); - (void)SvUPGRADE(sv, SVt_RV); - SvRV(sv) = (op->op_private & OPpDEREF_HV ? - (SV*)newHV() : (SV*)newAV()); + if (SvTYPE(sv) < SVt_RV) + sv_upgrade(sv, SVt_RV); + else if (SvTYPE(sv) >= SVt_PV) { + (void)SvOOK_off(sv); + Safefree(SvPVX(sv)); + SvLEN(sv) = SvCUR(sv) = 0; + } + switch (to_what) { + case OPpDEREF_SV: + SvRV(sv) = newSV(0); + break; + case OPpDEREF_AV: + SvRV(sv) = (SV*)newAV(); + break; + case OPpDEREF_HV: + SvRV(sv) = (SV*)newHV(); + break; + } SvROK_on(sv); SvSETMAGIC(sv); } @@ -1960,61 +2065,64 @@ PP(pp_method) SV* sv; SV* ob; GV* gv; - SV* nm; + HV* stash; + char* name; + char* packname; + STRLEN packlen; - nm = TOPs; + name = SvPV(TOPs, na); sv = *(stack_base + TOPMARK + 1); - gv = 0; if (SvGMAGICAL(sv)) mg_get(sv); if (SvROK(sv)) ob = (SV*)SvRV(sv); else { GV* iogv; - char* packname = 0; - STRLEN packlen; + packname = Nullch; if (!SvOK(sv) || !(packname = SvPV(sv, packlen)) || !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || !(ob=(SV*)GvIO(iogv))) { - char *name = SvPV(nm, na); - HV *stash; - if (!packname || !isALPHA(*packname)) -DIE("Can't call method \"%s\" without a package or object reference", name); - if (!(stash = gv_stashpvn(packname, packlen, FALSE))) { - if (gv_stashpvn("UNIVERSAL", 9, FALSE)) - stash = gv_stashpvn(packname, packlen, TRUE); - else - DIE("Can't call method \"%s\" in empty package \"%s\"", - name, packname); - } - gv = gv_fetchmethod(stash,name); - if (!gv) - DIE("Can't locate object method \"%s\" via package \"%s\"", - name, packname); - SETs((SV*)gv); - RETURN; + if (!packname || !isIDFIRST(*packname)) + DIE("Can't call method \"%s\" without a package or object reference", name); + stash = gv_stashpvn(packname, packlen, TRUE); + goto fetch; } *(stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); } - if (!ob || !SvOBJECT(ob)) { - char *name = SvPV(nm, na); + if (!ob || !SvOBJECT(ob)) DIE("Can't call method \"%s\" on unblessed reference", name); - } - if (!gv) { /* nothing cached */ - char *name = SvPV(nm, na); - gv = gv_fetchmethod(SvSTASH(ob),name); - if (!gv) - DIE("Can't locate object method \"%s\" via package \"%s\"", - name, HvNAME(SvSTASH(ob))); - } + stash = SvSTASH(ob); + + fetch: + gv = gv_fetchmethod(stash, name); + if (!gv) { + char* leaf = name; + char* sep = Nullch; + char* p; - SETs((SV*)gv); + for (p = name; *p; p++) { + if (*p == '\'') + sep = p, leaf = p + 1; + else if (*p == ':' && *(p + 1) == ':') + sep = p, leaf = p + 2; + } + if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) { + packname = HvNAME(sep ? curcop->cop_stash : stash); + packlen = strlen(packname); + } + else { + packname = name; + packlen = sep - name; + } + DIE("Can't locate object method \"%s\" via package \"%.*s\"", + leaf, (int)packlen, packname); + } + SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv); RETURN; } -