X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=8c04a70a12bd5aa9113183ef490d6e0d0ff5a096;hb=39696b0cdb512c61354df443d2f0b56bef0d4d8b;hp=5d43a7985ea795f08b837542163a4e0e3b008f1b;hpb=9c5ffd7c3fe1ab64d3e7d06810ac3ab42426718b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 5d43a79..8c04a70 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -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) { @@ -558,7 +558,10 @@ PP(pp_print) gv = (GV*)*++MARK; else gv = PL_defoutgv; - if ((mg = SvTIED_mg((SV*)gv, PERL_MAGIC_tiedscalar))) { + + if (gv && (io = GvIO(gv)) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + { had_magic: if (MARK == ORIGMARK) { /* If using default handle then we need to make space to @@ -570,7 +573,7 @@ PP(pp_print) ++SP; } PUSHMARK(MARK - 1); - *MARK = SvTIED_obj((SV*)gv, mg); + *MARK = SvTIED_obj((SV*)io, mg); PUTBACK; ENTER; call_method("PRINT", G_SCALAR); @@ -582,8 +585,8 @@ PP(pp_print) RETURN; } if (!(io = GvIO(gv))) { - if ((GvEGV(gv)) - && (mg = SvTIED_mg((SV*)GvEGV(gv), PERL_MAGIC_tiedscalar))) + if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv))) + && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) goto had_magic; if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) report_evil_fh(gv, io, PL_op->op_type); @@ -1190,7 +1193,7 @@ PP(pp_qr) register PMOP *pm = cPMOP; SV *rv = sv_newmortal(); SV *sv = newSVrv(rv, "Regexp"); - sv_magic(sv,(SV*)ReREFCNT_inc(pm->op_pmregexp), PERL_MAGIC_qr,0,0); + sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0); RETURNX(PUSHs(rv)); } @@ -1204,7 +1207,7 @@ PP(pp_match) I32 global; I32 r_flags = REXEC_CHECKED; char *truebase; /* Start of string */ - register REGEXP *rx = pm->op_pmregexp; + register REGEXP *rx = PM_GETRE(pm); bool rxtainted; I32 gimme = GIMME; STRLEN len; @@ -1219,7 +1222,7 @@ PP(pp_match) TARG = DEFSV; EXTEND(SP,1); } - PL_reg_sv = TARG; + PUTBACK; /* EVAL blocks need stack_sp. */ s = SvPV(TARG, len); strend = s + len; @@ -1229,6 +1232,8 @@ PP(pp_match) (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; + PL_reg_match_utf8 = DO_UTF8(TARG); + if (pm->op_pmdynflags & PMdf_USED) { failure: if (gimme == G_ARRAY) @@ -1238,7 +1243,7 @@ PP(pp_match) if (!rx->prelen && PL_curpm) { pm = PL_curpm; - rx = pm->op_pmregexp; + rx = PM_GETRE(pm); } if (rx->minlen > len) goto failure; @@ -1328,11 +1333,27 @@ play_it_again: len = rx->endp[i] - rx->startp[i]; s = rx->startp[i] + truebase; sv_setpvn(*SP, s, len); - if (DO_UTF8(TARG)) + if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len)) SvUTF8_on(*SP); } } if (global) { + if (pm->op_pmflags & PMf_CONTINUE) { + MAGIC* mg = 0; + if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) + mg = mg_find(TARG, PERL_MAGIC_regex_global); + if (!mg) { + sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0); + mg = mg_find(TARG, PERL_MAGIC_regex_global); + } + if (rx->startp[0] != -1) { + mg->mg_len = rx->endp[0]; + if (rx->startp[0] == rx->endp[0]) + mg->mg_flags |= MGf_MINMATCH; + else + mg->mg_flags &= ~MGf_MINMATCH; + } + } had_zerolen = (rx->startp[0] != -1 && rx->startp[0] == rx->endp[0]); PUTBACK; /* EVAL blocks may use stack */ @@ -1379,7 +1400,7 @@ yup: /* Confirmed by INTUIT */ if (global) { rx->subbeg = truebase; rx->startp[0] = s - truebase; - if (DO_UTF8(PL_reg_sv)) { + if (PL_reg_match_utf8) { char *t = (char*)utf8_hop((U8*)s, rx->minlen); rx->endp[0] = t - truebase; } @@ -1434,9 +1455,9 @@ Perl_do_readline(pTHX) I32 gimme = GIMME_V; MAGIC *mg; - if ((mg = SvTIED_mg((SV*)PL_last_in_gv, PERL_MAGIC_tiedscalar))) { + if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) { PUSHMARK(SP); - XPUSHs(SvTIED_obj((SV*)PL_last_in_gv, mg)); + XPUSHs(SvTIED_obj((SV*)io, mg)); PUTBACK; ENTER; call_method("READLINE", gimme); @@ -1719,12 +1740,12 @@ PP(pp_leave) SP = newsp; else if (gimme == G_SCALAR) { MARK = newsp + 1; - if (MARK <= SP) + if (MARK <= SP) { if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) *MARK = TOPs; else *MARK = sv_mortalcopy(TOPs); - else { + } else { MEXTEND(mark,0); *MARK = &PL_sv_undef; } @@ -1769,7 +1790,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); @@ -1795,7 +1816,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++); @@ -1875,11 +1896,10 @@ PP(pp_subst) bool rxtainted; char *orig; I32 r_flags; - register REGEXP *rx = pm->op_pmregexp; + register REGEXP *rx = PM_GETRE(pm); STRLEN len; int force_on_match = 0; I32 oldsave = PL_savestack_ix; - bool do_utf8; STRLEN slen; /* known replacement string? */ @@ -1890,8 +1910,7 @@ PP(pp_subst) TARG = DEFSV; EXTEND(SP,1); } - PL_reg_sv = TARG; - do_utf8 = DO_UTF8(PL_reg_sv); + if (SvFAKE(TARG) && SvREADONLY(TARG)) sv_force_normal(TARG); if (SvREADONLY(TARG) @@ -1909,19 +1928,21 @@ PP(pp_subst) rxtainted |= 2; TAINT_NOT; + PL_reg_match_utf8 = DO_UTF8(TARG); + force_it: if (!pm || !s) DIE(aTHX_ "panic: pp_subst"); strend = s + len; - slen = do_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. */ if (!rx->prelen && PL_curpm) { pm = PL_curpm; - rx = pm->op_pmregexp; + rx = PM_GETRE(pm); } r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand) ? REXEC_COPY_STR : 0; @@ -2315,18 +2336,16 @@ PP(pp_leavesublv) else if (gimme == G_ARRAY) { EXTEND_MORTAL(SP - newsp); for (mark = newsp + 1; mark <= SP; mark++) { - if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { + if (*mark != &PL_sv_undef + && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) { /* Might be flattened array after $#array = */ PUTBACK; POPSUB(cx,sv); PL_curpm = newpm; LEAVE; LEAVESUB(sv); - DIE(aTHX_ "Can't return %s from lvalue subroutine", - (*mark != &PL_sv_undef) - ? (SvREADONLY(TOPs) - ? "a readonly value" : "a temporary") - : "an uninitialized value"); + DIE(aTHX_ "Can't return a %s from lvalue subroutine", + SvREADONLY(TOPs) ? "readonly value" : "temporary"); } else { /* Can be a localized value subject to deletion. */ @@ -2446,6 +2465,8 @@ PP(pp_entersub) } if (SvGMAGICAL(sv)) { mg_get(sv); + if (SvROK(sv)) + goto got_rv; sym = SvPOKp(sv) ? SvPVX(sv) : Nullch; } else @@ -2457,6 +2478,7 @@ PP(pp_entersub) cv = get_cv(sym, TRUE); break; } + got_rv: { SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ tryAMAGICunDEREF(to_cv); @@ -2525,7 +2547,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 @@ -2569,7 +2591,7 @@ try_autoload: COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg)); MgOWNER(mg) = thr; DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n", - thr, sv);) + thr, sv)); MUTEX_UNLOCK(MgMUTEXP(mg)); SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv); } @@ -2653,11 +2675,11 @@ try_autoload: } DEBUG_S(if (CvDEPTH(cv) != 0) PerlIO_printf(Perl_debug_log, "depth %ld != 0\n", - CvDEPTH(cv));); + CvDEPTH(cv))); SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv); } } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ if (CvXSUB(cv)) { #ifdef PERL_XSUB_OLDSTYLE @@ -2690,11 +2712,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) { @@ -2712,7 +2734,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 ) { @@ -2786,7 +2808,7 @@ try_autoload: svp = AvARRAY(padlist); } } -#ifdef USE_THREADS +#ifdef USE_5005THREADS if (!hasargs) { AV* av = (AV*)PL_curpad[0]; @@ -2799,12 +2821,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; @@ -2821,10 +2843,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; @@ -3107,9 +3129,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; @@ -3118,10 +3140,10 @@ unset_cvowner(pTHXo_ void *cvarg) MUTEX_LOCK(CvMUTEXP(cv)); DEBUG_S(if (CvDEPTH(cv) != 0) PerlIO_printf(Perl_debug_log, "depth %ld != 0\n", - CvDEPTH(cv));); + CvDEPTH(cv))); assert(thr == CvOWNER(cv)); CvOWNER(cv) = 0; MUTEX_UNLOCK(CvMUTEXP(cv)); SvREFCNT_dec(cv); } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */