X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=315c85b1a08424105207c66e208af6c53832b293;hb=fe9745bfc279b016730696fd0a6abca4d493be60;hp=b96cc454580d74b6a40a914f01edeb93bf7eec7f;hpb=5e1c5d9c059365c8c0b3de19e24481eaae21f7e5;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index b96cc45..315c85b 100644 --- a/sv.c +++ b/sv.c @@ -147,20 +147,24 @@ S_more_sv(pTHX) return sv; } -STATIC void +STATIC I32 S_visit(pTHX_ SVFUNC_t f) { SV* sva; SV* sv; register SV* svend; + I32 visited = 0; for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { - if (SvTYPE(sv) != SVTYPEMASK) + if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) { (FCALL)(aTHXo_ sv); + ++visited; + } } } + return visited; } void @@ -181,12 +185,14 @@ Perl_sv_clean_objs(pTHX) PL_in_clean_objs = FALSE; } -void +I32 Perl_sv_clean_all(pTHX) { + I32 cleaned; PL_in_clean_all = TRUE; - visit(do_clean_all); + cleaned = visit(do_clean_all); PL_in_clean_all = FALSE; + return cleaned; } void @@ -2954,7 +2960,7 @@ if all the bytes have hibit clear. STRLEN Perl_sv_utf8_upgrade(pTHX_ register SV *sv) { - char *s, *t, *e; + U8 *s, *t, *e; int hibit = 0; if (!sv) @@ -2966,25 +2972,25 @@ Perl_sv_utf8_upgrade(pTHX_ register SV *sv) if (SvUTF8(sv)) return SvCUR(sv); + if (SvREADONLY(sv) && SvFAKE(sv)) { + sv_force_normal(sv); + } + /* This function could be much more efficient if we had a FLAG in SVs * to signal if there are any hibit chars in the PV. * Given that there isn't make loop fast as possible */ - s = SvPVX(sv); - e = SvEND(sv); + s = (U8 *) SvPVX(sv); + e = (U8 *) SvEND(sv); t = s; while (t < e) { - if ((hibit = UTF8_IS_CONTINUED(*t++))) + U8 ch = *t++; + if ((hibit = !NATIVE_IS_INVARIANT(ch))) break; } - if (hibit) { STRLEN len; - if (SvREADONLY(sv) && SvFAKE(sv)) { - sv_force_normal(sv); - s = SvPVX(sv); - } len = SvCUR(sv) + 1; /* Plus the \0 */ SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len); SvCUR(sv) = len - 1; @@ -3092,8 +3098,8 @@ bool Perl_sv_utf8_decode(pTHX_ register SV *sv) { if (SvPOK(sv)) { - char *c; - char *e; + U8 *c; + U8 *e; /* The octets may have got themselves encoded - get them back as bytes */ if (!sv_utf8_downgrade(sv, TRUE)) @@ -3102,12 +3108,13 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) /* it is actually just a matter of turning the utf8 flag on, but * we want to make sure everything inside is valid utf8 first. */ - c = SvPVX(sv); - if (!is_utf8_string((U8*)c, SvCUR(sv)+1)) + c = (U8 *) SvPVX(sv); + if (!is_utf8_string(c, SvCUR(sv)+1)) return FALSE; - e = SvEND(sv); + e = (U8 *) SvEND(sv); while (c < e) { - if (UTF8_IS_CONTINUED(*c++)) { + U8 ch = *c++; + if (!UTF8_IS_INVARIANT(ch)) { SvUTF8_on(sv); break; } @@ -4726,8 +4733,9 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) len = 0; while (s < send) { STRLEN n; - /* We can use low level directly here as we are not looking at the values */ - if (utf8n_to_uvuni(s, UTF8SKIP(s), &n, 0)) { + /* Call utf8n_to_uvchr() to validate the sequence */ + utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0); + if (n > 0) { s += n; len++; } @@ -4755,8 +4763,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) char *pv2; STRLEN cur2; I32 eq = 0; - bool pv1tmp = FALSE; - bool pv2tmp = FALSE; + char *tpv = Nullch; if (!sv1) { pv1 = ""; @@ -4775,31 +4782,33 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) /* do not utf8ize the comparands as a side-effect */ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) { bool is_utf8 = TRUE; - + /* UTF-8ness differs */ if (PL_hints & HINT_UTF8_DISTINCT) return FALSE; if (SvUTF8(sv1)) { + /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */ char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8); - - if ((pv1tmp = (pv != pv1))) - pv1 = pv; + if (pv != pv1) + pv1 = tpv = pv; } else { + /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */ char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8); - - if ((pv2tmp = (pv != pv2))) - pv2 = pv; + if (pv != pv2) + pv2 = tpv = pv; + } + if (is_utf8) { + /* Downgrade not possible - cannot be eq */ + return FALSE; } } if (cur1 == cur2) eq = memEQ(pv1, pv2, cur1); - if (pv1tmp) - Safefree(pv1); - if (pv2tmp) - Safefree(pv2); + if (tpv != Nullch) + Safefree(tpv); return eq; } @@ -7121,7 +7130,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'c': uv = args ? va_arg(*args, int) : SvIVx(argsv); - if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) { + if ((uv > 255 || (!UNI_IS_INVARIANT(uv) || SvUTF8(sv))) && !IN_BYTE) { eptr = (char*)utf8buf; elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf; is_utf = TRUE; @@ -8190,7 +8199,7 @@ dup_pvcv: CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr)); CvXSUB(dstr) = CvXSUB(sstr); CvXSUBANY(dstr) = CvXSUBANY(sstr); - CvGV(dstr) = gv_dup_inc(CvGV(sstr)); + CvGV(dstr) = gv_dup(CvGV(sstr)); CvDEPTH(dstr) = CvDEPTH(sstr); if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) { /* XXX padlists are real, but pretend to be not */ @@ -8258,7 +8267,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) ncx->blk_sub.argarray = (cx->blk_sub.hasargs ? av_dup_inc(cx->blk_sub.argarray) : Nullav); - ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray); + ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray); ncx->blk_sub.olddepth = cx->blk_sub.olddepth; ncx->blk_sub.hasargs = cx->blk_sub.hasargs; ncx->blk_sub.lval = cx->blk_sub.lval; @@ -8845,7 +8854,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_defgv = gv_dup(proto_perl->Idefgv); PL_argvgv = gv_dup(proto_perl->Iargvgv); PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv); - PL_argvout_stack = av_dup(proto_perl->Iargvout_stack); + PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack); /* shortcuts to regexp stuff */ PL_replgv = gv_dup(proto_perl->Ireplgv);