X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=704718e23ba4dabeba889b3255ee686da72c8f75;hb=0026721a5b588a091ec5fe2016e8d00b8be712ab;hp=ea360c3f6ec9e6013b12aa24139418f21e533078;hpb=90f44359bb7541a575a1666f79be58a556605cf6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index ea360c3..704718e 100644 --- a/sv.c +++ b/sv.c @@ -63,7 +63,7 @@ static void do_clean_all(pTHXo_ SV *sv); #define del_SV(p) \ STMT_START { \ LOCK_SV_MUTEX; \ - if (PL_debug & 32768) \ + if (DEBUG_D_TEST) \ del_sv(p); \ else \ plant_SV(p); \ @@ -73,7 +73,7 @@ static void do_clean_all(pTHXo_ SV *sv); STATIC void S_del_sv(pTHX_ SV *p) { - if (PL_debug & 32768) { + if (DEBUG_D_TEST) { SV* sva; SV* sv; SV* svend; @@ -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 @@ -2884,7 +2890,8 @@ Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv) char * Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) { - return sv_2pv(sv,lp); + sv_utf8_downgrade(sv,0); + return SvPV(sv,*lp); } char * @@ -2943,46 +2950,61 @@ Perl_sv_2bool(pTHX_ register SV *sv) =for apidoc sv_utf8_upgrade Convert the PV of an SV to its UTF8-encoded form. +Forces the SV to string form it it is not already. +Always sets the SvUTF8 flag to avoid future validity checks even +if all the bytes have hibit clear. =cut */ -void +STRLEN Perl_sv_utf8_upgrade(pTHX_ register SV *sv) { - char *s, *t, *e; + U8 *s, *t, *e; int hibit = 0; - if (!sv || !SvPOK(sv) || SvUTF8(sv)) - return; + if (!sv) + return 0; + + if (!SvPOK(sv)) { + STRLEN len = 0; + (void) sv_2pv(sv,&len); + if (!SvPOK(sv)) + return len; + } + + 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; if (SvLEN(sv) != 0) Safefree(s); /* No longer using what was there before. */ SvLEN(sv) = len; /* No longer know the real size. */ - SvUTF8_on(sv); } + /* Mark as UTF-8 even if no hibit - saves scanning loop */ + SvUTF8_on(sv); + return SvCUR(sv); } /* @@ -3001,15 +3023,37 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) { if (SvPOK(sv) && SvUTF8(sv)) { if (SvCUR(sv)) { - char *s; + U8 *s; STRLEN len; if (SvREADONLY(sv) && SvFAKE(sv)) sv_force_normal(sv); - s = SvPV(sv, len); - if (!utf8_to_bytes((U8*)s, &len)) { + s = (U8 *) SvPV(sv, len); + if (!utf8_to_bytes(s, &len)) { if (fail_ok) return FALSE; +#ifdef USE_BYTES_DOWNGRADES + else if (IN_BYTE) { + U8 *d = s; + U8 *e = (U8 *) SvEND(sv); + int first = 1; + while (s < e) { + UV ch = utf8n_to_uvchr(s,(e-s),&len,0); + if (first && ch > 255) { + if (PL_op) + Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s", + PL_op_desc[PL_op->op_type]); + else + Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte"); + first = 0; + } + *d++ = ch; + s += len; + } + *d = '\0'; + len = (d - (U8 *) SvPVX(sv)); + } +#endif else { if (PL_op) Perl_croak(aTHX_ "Wide character in %s", @@ -3020,9 +3064,8 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) } SvCUR(sv) = len; } - SvUTF8_off(sv); } - + SvUTF8_off(sv); return TRUE; } @@ -3030,7 +3073,8 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) =for apidoc sv_utf8_encode Convert the PV of an SV to UTF8-encoded, but then turn off the C -flag so that it looks like bytes again. Nothing calls this. +flag so that it looks like octets again. Used as a building block +for encode_utf8 in Encode.xs =cut */ @@ -3038,29 +3082,43 @@ flag so that it looks like bytes again. Nothing calls this. void Perl_sv_utf8_encode(pTHX_ register SV *sv) { - sv_utf8_upgrade(sv); + (void) sv_utf8_upgrade(sv); SvUTF8_off(sv); } +/* +=for apidoc sv_utf8_decode + +Convert the octets in the PV from UTF-8 to chars. Scan for validity and then +turn of SvUTF8 if needed so that we see characters. Used as a building block +for decode_utf8 in Encode.xs + +=cut +*/ + + + 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)) return FALSE; /* 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; } @@ -3763,8 +3821,9 @@ Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming =for apidoc sv_catpvn Concatenates the string onto the end of the string which is in the SV. The -C indicates number of bytes to copy. Handles 'get' magic, but not -'set' magic. See C. +C indicates number of bytes to copy. If the SV has the UTF8 +status set, then the bytes appended should be valid UTF8. +Handles 'get' magic, but not 'set' magic. See C. =cut */ @@ -3862,10 +3921,10 @@ Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv) =for apidoc sv_catpv Concatenates the string onto the end of the string which is in the SV. -Handles 'get' magic, but not 'set' magic. See C. +If the SV has the UTF8 status set, then the bytes appended should be +valid UTF8. Handles 'get' magic, but not 'set' magic. See C. -=cut -*/ +=cut */ void Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) @@ -3946,10 +4005,20 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam } Newz(702,mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); - SvMAGIC(sv) = mg; - if (!obj || obj == sv || how == '#' || how == 'r') + + /* Some magic sontains a reference loop, where the sv and object refer to + each other. To prevent a avoid a reference loop that would prevent such + objects being freed, we look for such loops and if we find one we avoid + incrementing the object refcount. */ + if (!obj || obj == sv || how == '#' || how == 'r' || + (SvTYPE(obj) == SVt_PVGV && + (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || + GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv || + GvFORM(obj) == (CV*)sv))) + { mg->mg_obj = obj; + } else { mg->mg_obj = SvREFCNT_inc(obj); mg->mg_flags |= MGf_REFCOUNTED; @@ -4334,7 +4403,7 @@ Perl_sv_clear(pTHX_ register SV *sv) if (SvOBJECT(sv)) { if (PL_defstash) { /* Still have a symbol table? */ - djSP; + dSP; CV* destructor; SV tmpref; @@ -4669,8 +4738,9 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) len = 0; while (s < send) { STRLEN n; - - if (utf8_to_uv(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++; } @@ -4698,8 +4768,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 = ""; @@ -4718,31 +4787,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; } @@ -5620,8 +5691,12 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) len = -len; is_utf8 = TRUE; } - if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) - src = (char*)bytes_from_utf8((U8*)src, (STRLEN*)&len, &is_utf8); + if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) { + STRLEN tmplen = len; + /* See the note in hv.c:hv_fetch() --jhi */ + src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8); + len = tmplen; + } if (!hash) PERL_HASH(hash, src, len); new_SV(sv); @@ -6113,18 +6188,21 @@ Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) char * Perl_sv_pvbyte(pTHX_ SV *sv) { + sv_utf8_downgrade(sv,0); return sv_pv(sv); } char * Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp) { + sv_utf8_downgrade(sv,0); return sv_pvn(sv,lp); } char * Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) { + sv_utf8_downgrade(sv,0); return sv_pvn_force(sv,lp); } @@ -6349,6 +6427,25 @@ Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv) } /* +=for apidoc sv_setref_uv + +Copies an unsigned integer into a new SV, optionally blessing the SV. The C +argument will be upgraded to an RV. That RV will be modified to point to +the new SV. The C argument indicates the package for the +blessing. Set C to C to avoid the blessing. The new SV +will be returned and will have a reference count of 1. + +=cut +*/ + +SV* +Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv) +{ + sv_setuv(newSVrv(rv,classname), uv); + return rv; +} + +/* =for apidoc sv_setref_nv Copies a double into a new SV, optionally blessing the SV. The C @@ -6668,12 +6765,15 @@ Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...) /* =for apidoc sv_catpvf -Processes its arguments like C and appends the formatted output -to an SV. Handles 'get' magic, but not 'set' magic. C must -typically be called after calling this function to handle 'set' magic. +Processes its arguments like C and appends the formatted +output to an SV. If the appended data contains "wide" characters +(including, but not limited to, SVs with a UTF-8 PV formatted with %s, +and characters >255 formatted with %c), the original SV might get +upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. +C must typically be called after calling this function +to handle 'set' magic. -=cut -*/ +=cut */ void Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...) @@ -7038,9 +7138,11 @@ 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 = uv_to_utf8((U8*)eptr, uv) - utf8buf; + elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf; is_utf = TRUE; } else { @@ -7124,7 +7226,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (!veclen) continue; if (vec_utf) - iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0); + iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0); else { iv = *vecstr; ulen = 1; @@ -7204,7 +7306,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (!veclen) continue; if (vec_utf) - uv = utf8_to_uv(vecstr, veclen, &ulen, 0); + uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0); else { uv = *vecstr; ulen = 1; @@ -7788,7 +7890,7 @@ S_gv_share(pTHX_ SV *sstr) return Nullsv; } - /* + /* * write attempts will die with * "Modification of a read-only value attempted" */ @@ -8107,7 +8209,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 */ @@ -8118,7 +8220,10 @@ dup_pvcv: } else CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); - CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); + if (!CvANON(sstr) || CvCLONED(sstr)) + CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); + else + CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr)); CvFLAGS(dstr) = CvFLAGS(sstr); break; default: @@ -8172,7 +8277,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; @@ -8759,7 +8864,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);