X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=de2dec44645c44f9b1ed08f80b9d92e94aa525f0;hb=8c1bea16abb5bfc7b9b56a932e319a1623cab1b9;hp=d21977691bc362bf39dc227d307cfaeabbb50869;hpb=d9f424b23bb434af43f899daf2cb6cfe42fe6e1a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index d219776..de2dec4 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1,6 +1,6 @@ /* pp_hot.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (c) 1991-2002, 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. @@ -21,9 +21,9 @@ /* Hot code. */ -#ifdef USE_THREADS -static void unset_cvowner(pTHXo_ void *cvarg); -#endif /* USE_THREADS */ +#ifdef USE_5005THREADS +static void unset_cvowner(pTHX_ void *cvarg); +#endif /* USE_5005THREADS */ PP(pp_const) { @@ -72,14 +72,7 @@ PP(pp_pushmark) PP(pp_stringify) { dSP; dTARGET; - STRLEN len; - char *s; - s = SvPV(TOPs,len); - sv_setpvn(TARG,s,len); - if (SvUTF8(TOPs)) - SvUTF8_on(TARG); - else - SvUTF8_off(TARG); + sv_copypv(TARG,TOPs); SETTARG; RETURN; } @@ -177,7 +170,7 @@ PP(pp_concat) if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9' && (llen == 2 || !isDIGIT(lpv[llen - 3]))) { - Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %s", + Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s", "about to append an integer to '19'"); } } @@ -237,7 +230,8 @@ PP(pp_eq) dSP; tryAMAGICbinSET(eq,0); #ifndef NV_PRESERVES_UV if (SvROK(TOPs) && SvROK(TOPm1s)) { - SETs(boolSV(SvRV(TOPs) == SvRV(TOPm1s))); + SP--; + SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s))); RETURN; } #endif @@ -252,53 +246,40 @@ PP(pp_eq) bool auvok = SvUOK(TOPm1s); bool buvok = SvUOK(TOPs); - if (!auvok && !buvok) { /* ## IV == IV ## */ - IV aiv = SvIVX(TOPm1s); - IV biv = SvIVX(TOPs); + if (auvok == buvok) { /* ## IV == IV or UV == UV ## */ + /* Casting IV to UV before comparison isn't going to matter + on 2s complement. On 1s complement or sign&magnitude + (if we have any of them) it could to make negative zero + differ from normal zero. As I understand it. (Need to + check - is negative zero implementation defined behaviour + anyway?). NWC */ + UV buv = SvUVX(POPs); + UV auv = SvUVX(TOPs); - SP--; - SETs(boolSV(aiv == biv)); - RETURN; - } - if (auvok && buvok) { /* ## UV == UV ## */ - UV auv = SvUVX(TOPm1s); - UV buv = SvUVX(TOPs); - - SP--; SETs(boolSV(auv == buv)); RETURN; } { /* ## Mixed IV,UV ## */ + SV *ivp, *uvp; IV iv; - UV uv; - /* == is commutative so swap if needed (save code) */ + /* == is commutative so doesn't matter which is left or right */ if (auvok) { - /* swap. top of stack (b) is the iv */ - iv = SvIVX(TOPs); - SP--; - if (iv < 0) { - /* As (a) is a UV, it's >0, so it cannot be == */ - SETs(&PL_sv_no); - RETURN; - } - uv = SvUVX(TOPs); - } else { - iv = SvIVX(TOPm1s); - SP--; - if (iv < 0) { - /* As (b) is a UV, it's >0, so it cannot be == */ - SETs(&PL_sv_no); - RETURN; - } - uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */ - } + /* top of stack (b) is the iv */ + ivp = *SP; + uvp = *--SP; + } else { + uvp = *SP; + ivp = *--SP; + } + iv = SvIVX(ivp); + if (iv < 0) { + /* As uv is a UV, it's >0, so it cannot be == */ + SETs(&PL_sv_no); + RETURN; + } /* we know iv is >= 0 */ - if (uv > (UV) IV_MAX) { - SETs(&PL_sv_no); - RETURN; - } - SETs(boolSV((UV)iv == uv)); + SETs(boolSV((UV)iv == SvUVX(uvp))); RETURN; } } @@ -314,10 +295,10 @@ PP(pp_eq) PP(pp_preinc) { dSP; - if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV) + if (SvTYPE(TOPs) > SVt_PVLV) DIE(aTHX_ PL_no_modify); - if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) && - SvIVX(TOPs) != IV_MAX) + if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) + && SvIVX(TOPs) != IV_MAX) { ++SvIVX(TOPs); SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK); @@ -440,7 +421,7 @@ PP(pp_add) buv = (UV)-biv; } /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve, - else "IV" now, independant of how it came in. + else "IV" now, independent of how it came in. if a, b represents positive, A, B negative, a maps to -A etc a + b => (a + b) A + b => -(a - b) @@ -753,7 +734,7 @@ PP(pp_rv2av) EXTEND(SP, maxarg); if (SvRMAGICAL(av)) { U32 i; - for (i=0; i < maxarg; i++) { + for (i=0; i < (U32)maxarg; i++) { SV **svp = av_fetch(av, i, FALSE); SP[i+1] = (svp) ? *svp : &PL_sv_undef; } @@ -946,11 +927,11 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) (SvTYPE(SvRV(*relem)) == SVt_PVAV || SvTYPE(SvRV(*relem)) == SVt_PVHV)) { - Perl_warner(aTHX_ WARN_MISC, + Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference found where even-sized list expected"); } else - Perl_warner(aTHX_ WARN_MISC, + Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in hash assignment"); } if (SvTYPE(hash) == SVt_PVAV) { @@ -1193,6 +1174,8 @@ PP(pp_qr) register PMOP *pm = cPMOP; SV *rv = sv_newmortal(); SV *sv = newSVrv(rv, "Regexp"); + if (pm->op_pmdynflags & PMdf_TAINTED) + SvTAINTED_on(rv); sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0); RETURNX(PUSHs(rv)); } @@ -1201,6 +1184,7 @@ PP(pp_match) { dSP; dTARG; register PMOP *pm = cPMOP; + PMOP *dynpm = pm; register char *t; register char *s; char *strend; @@ -1232,8 +1216,9 @@ PP(pp_match) (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; - PL_reg_sv_utf8 = DO_UTF8(TARG); + PL_reg_match_utf8 = DO_UTF8(TARG); + /* PMdf_USED is set after a ?? matches once */ if (pm->op_pmdynflags & PMdf_USED) { failure: if (gimme == G_ARRAY) @@ -1241,16 +1226,19 @@ PP(pp_match) RETPUSHNO; } + /* empty pattern special-cased to use last successful pattern if possible */ if (!rx->prelen && PL_curpm) { pm = PL_curpm; rx = PM_GETRE(pm); } - if (rx->minlen > len) goto failure; + + if (rx->minlen > (I32)len) + goto failure; truebase = t = s; /* XXXX What part of this is needed with true \G-support? */ - if ((global = pm->op_pmflags & PMf_GLOBAL)) { + if ((global = dynpm->op_pmflags & PMf_GLOBAL)) { rx->startp[0] = -1; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global); @@ -1303,8 +1291,8 @@ play_it_again: if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags)) { PL_curpm = pm; - if (pm->op_pmflags & PMf_ONCE) - pm->op_pmdynflags |= PMdf_USED; + if (dynpm->op_pmflags & PMf_ONCE) + dynpm->op_pmdynflags |= PMdf_USED; goto gotcha; } else @@ -1331,6 +1319,9 @@ play_it_again: /*SUPPRESS 560*/ if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) { len = rx->endp[i] - rx->startp[i]; + if (rx->endp[i] < 0 || rx->startp[i] < 0 || + len < 0 || len > strend - s) + DIE(aTHX_ "panic: pp_match start/end pointers"); s = rx->startp[i] + truebase; sv_setpvn(*SP, s, len); if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len)) @@ -1338,7 +1329,7 @@ play_it_again: } } if (global) { - if (pm->op_pmflags & PMf_CONTINUE) { + if (dynpm->op_pmflags & PMf_CONTINUE) { MAGIC* mg = 0; if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) mg = mg_find(TARG, PERL_MAGIC_regex_global); @@ -1391,8 +1382,8 @@ yup: /* Confirmed by INTUIT */ RX_MATCH_TAINTED_on(rx); TAINT_IF(RX_MATCH_TAINTED(rx)); PL_curpm = pm; - if (pm->op_pmflags & PMf_ONCE) - pm->op_pmdynflags |= PMdf_USED; + if (dynpm->op_pmflags & PMf_ONCE) + dynpm->op_pmdynflags |= PMdf_USED; if (RX_MATCH_COPIED(rx)) Safefree(rx->subbeg); RX_MATCH_COPIED_off(rx); @@ -1400,7 +1391,7 @@ yup: /* Confirmed by INTUIT */ if (global) { rx->subbeg = truebase; rx->startp[0] = s - truebase; - if (PL_reg_sv_utf8) { + if (PL_reg_match_utf8) { char *t = (char*)utf8_hop((U8*)s, rx->minlen); rx->endp[0] = t - truebase; } @@ -1429,7 +1420,7 @@ yup: /* Confirmed by INTUIT */ nope: ret_no: - if (global && !(pm->op_pmflags & PMf_CONTINUE)) { + if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) { if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) { MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global); if (mg) @@ -1501,7 +1492,7 @@ Perl_do_readline(pTHX) if (ckWARN2(WARN_GLOB, WARN_CLOSED) && (!io || !(IoFLAGS(io) & IOf_START))) { if (type == OP_GLOB) - Perl_warner(aTHX_ WARN_GLOB, + Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)", Strerror(errno)); else @@ -1558,7 +1549,7 @@ Perl_do_readline(pTHX) } else if (type == OP_GLOB) { if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) { - Perl_warner(aTHX_ WARN_GLOB, + Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (child exited with status %d%s)", (int)(STATUS_CURRENT >> 8), (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); @@ -1652,8 +1643,25 @@ PP(pp_helem) I32 preeminent = 0; if (SvTYPE(hv) == SVt_PVHV) { - if (PL_op->op_private & OPpLVAL_INTRO) - preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0); + if (PL_op->op_private & OPpLVAL_INTRO) { + MAGIC *mg; + HV *stash; + /* does the element we're localizing already exist? */ + preeminent = + /* can we determine whether it exists? */ + ( !SvRMAGICAL(hv) + || mg_find((SV*)hv, PERL_MAGIC_env) + || ( (mg = mg_find((SV*)hv, PERL_MAGIC_tied)) + /* Try to preserve the existenceness of a tied hash + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise */ + && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg)))) + && gv_fetchmethod_autoload(stash, "EXISTS", TRUE) + && gv_fetchmethod_autoload(stash, "DELETE", TRUE) + ) + ) ? hv_exists_ent(hv, keysv, 0) : 1; + + } he = hv_fetch_ent(hv, keysv, lval && !defer, hash); svp = he ? &HeVAL(he) : 0; } @@ -1790,7 +1798,7 @@ PP(pp_iter) STRLEN maxlen; char *max = SvPV((SV*)av, maxlen); if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) { -#ifndef USE_THREADS /* don't risk potential race */ +#ifndef USE_5005THREADS /* don't risk potential race */ if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ sv_setsv(*itersvp, cur); @@ -1816,7 +1824,7 @@ PP(pp_iter) if (cx->blk_loop.iterix > cx->blk_loop.itermax) RETPUSHNO; -#ifndef USE_THREADS /* don't risk potential race */ +#ifndef USE_5005THREADS /* don't risk potential race */ if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ sv_setiv(*itersvp, cx->blk_loop.iterix++); @@ -1901,6 +1909,7 @@ PP(pp_subst) int force_on_match = 0; I32 oldsave = PL_savestack_ix; STRLEN slen; + bool doutf8 = FALSE; /* known replacement string? */ dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv; @@ -1928,14 +1937,14 @@ PP(pp_subst) rxtainted |= 2; TAINT_NOT; - PL_reg_sv_utf8 = DO_UTF8(TARG); + PL_reg_match_utf8 = DO_UTF8(TARG); force_it: if (!pm || !s) DIE(aTHX_ "panic: pp_subst"); strend = s + len; - slen = PL_reg_sv_utf8 ? utf8_length((U8*)s, (U8*)strend) : len; + slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len; maxiters = 2 * slen + 10; /* We can match twice at each position, once with zero-length, second time with non-zero. */ @@ -1973,10 +1982,17 @@ PP(pp_subst) once = !(rpm->op_pmflags & PMf_GLOBAL); /* known replacement string? */ - c = dstr ? SvPV(dstr, clen) : Nullch; - + if (dstr) { + c = SvPV(dstr, clen); + doutf8 = DO_UTF8(dstr); + } + else { + c = Nullch; + doutf8 = FALSE; + } + /* can do inplace substitution? */ - if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) + if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR)) && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) { if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags | REXEC_CHECKED)) @@ -2080,8 +2096,6 @@ PP(pp_subst) if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL, r_flags | REXEC_CHECKED)) { - bool isutf8; - if (force_on_match) { force_on_match = 0; s = SvPV_force(TARG, len); @@ -2120,14 +2134,21 @@ PP(pp_subst) break; } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m, TARG, NULL, r_flags)); - sv_catpvn(dstr, s, strend - s); + if (doutf8 && !DO_UTF8(dstr)) { + SV* nsv = sv_2mortal(newSVpvn(s, strend - s)); + + sv_utf8_upgrade(nsv); + sv_catpvn(dstr, SvPVX(nsv), SvCUR(nsv)); + } + else + sv_catpvn(dstr, s, strend - s); (void)SvOOK_off(TARG); Safefree(SvPVX(TARG)); SvPVX(TARG) = SvPVX(dstr); SvCUR_set(TARG, SvCUR(dstr)); SvLEN_set(TARG, SvLEN(dstr)); - isutf8 = DO_UTF8(dstr); + doutf8 |= DO_UTF8(dstr); SvPVX(dstr) = 0; sv_free(dstr); @@ -2136,7 +2157,7 @@ PP(pp_subst) PUSHs(sv_2mortal(newSViv((I32)iters))); (void)SvPOK_only(TARG); - if (isutf8) + if (doutf8) SvUTF8_on(TARG); TAINT_IF(rxtainted); SvSETMAGIC(TARG); @@ -2547,7 +2568,7 @@ try_autoload: DIE(aTHX_ "No DBsub routine"); } -#ifdef USE_THREADS +#ifdef USE_5005THREADS /* * First we need to check if the sub or method requires locking. * If so, we gain a lock on the CV, the first argument or the @@ -2679,7 +2700,7 @@ try_autoload: SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv); } } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ if (CvXSUB(cv)) { #ifdef PERL_XSUB_OLDSTYLE @@ -2712,11 +2733,11 @@ try_autoload: * back. This would allow popping @_ in XSUB, e.g.. XXXX */ AV* av; I32 items; -#ifdef USE_THREADS +#ifdef USE_5005THREADS av = (AV*)PL_curpad[0]; #else av = GvAV(PL_defgv); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ items = AvFILLp(av) + 1; /* @_ is not tieable */ if (items) { @@ -2734,7 +2755,7 @@ try_autoload: PL_curcopdb = NULL; } /* Do we need to open block here? XXXX */ - (void)(*CvXSUB(cv))(aTHXo_ cv); + (void)(*CvXSUB(cv))(aTHX_ cv); /* Enforce some sanity in scalar context. */ if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) { @@ -2808,7 +2829,7 @@ try_autoload: svp = AvARRAY(padlist); } } -#ifdef USE_THREADS +#ifdef USE_5005THREADS if (!hasargs) { AV* av = (AV*)PL_curpad[0]; @@ -2821,12 +2842,12 @@ try_autoload: PUTBACK ; } } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ SAVEVPTR(PL_curpad); PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]); -#ifndef USE_THREADS +#ifndef USE_5005THREADS if (hasargs) -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ { AV* av; SV** ary; @@ -2843,10 +2864,10 @@ try_autoload: AvREAL_off(av); AvREIFY_on(av); } -#ifndef USE_THREADS +#ifndef USE_5005THREADS cx->blk_sub.savearray = GvAV(PL_defgv); GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ cx->blk_sub.oldcurpad = PL_curpad; cx->blk_sub.argarray = av; ++MARK; @@ -2892,11 +2913,11 @@ void Perl_sub_crush_depth(pTHX_ CV *cv) { if (CvANON(cv)) - Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine"); + Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine"); else { SV* tmpstr = sv_newmortal(); gv_efullname3(tmpstr, CvGV(cv), Nullch); - Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"", + Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"", SvPVX(tmpstr)); } } @@ -2913,7 +2934,7 @@ PP(pp_aelem) SV *sv; if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)) - Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv)); + Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv)); if (elem > 0) elem -= PL_curcop->cop_arybase; if (SvTYPE(av) != SVt_PVAV) @@ -3129,9 +3150,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp) return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; } -#ifdef USE_THREADS +#ifdef USE_5005THREADS static void -unset_cvowner(pTHXo_ void *cvarg) +unset_cvowner(pTHX_ void *cvarg) { register CV* cv = (CV *) cvarg; @@ -3146,4 +3167,4 @@ unset_cvowner(pTHXo_ void *cvarg) MUTEX_UNLOCK(CvMUTEXP(cv)); SvREFCNT_dec(cv); } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */