X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=a448938d46866e6165d3e84bd142cfdcc29a1284;hb=cb19cdb0fd3ce67876c25a91eb9a0f13a6646713;hp=fa3b29edfb80ad5c25a1b26736a1250c31ab9756;hpb=9041c2e396c8c7de7680a2007dc341a9f65be0d0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index fa3b29e..a448938 100644 --- a/sv.c +++ b/sv.c @@ -137,6 +137,7 @@ S_more_sv(pTHX) if (PL_nice_chunk) { sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0); PL_nice_chunk = Nullch; + PL_nice_chunk_size = 0; } else { char *chunk; /* must use New here to match call to */ @@ -147,20 +148,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 +186,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 @@ -1424,12 +1431,12 @@ S_not_a_number(pTHX_ SV *sv) { char tmpbuf[64]; char *d = tmpbuf; - char *s; char *limit = tmpbuf + sizeof(tmpbuf) - 8; /* each *s can expand to 4 chars + "...\0", i.e. need room for 8 chars */ - for (s = SvPVX(sv); *s && d < limit; s++) { + char *s, *end; + for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) { int ch = *s & 0xFF; if (ch & 128 && !isPRINT_LC(ch)) { *d++ = 'M'; @@ -1452,6 +1459,10 @@ S_not_a_number(pTHX_ SV *sv) *d++ = '\\'; *d++ = '\\'; } + else if (ch == '\0') { + *d++ = '\\'; + *d++ = '0'; + } else if (isPRINT_LC(ch)) *d++ = ch; else { @@ -1459,7 +1470,7 @@ S_not_a_number(pTHX_ SV *sv) *d++ = toCTRL(ch); } } - if (*s) { + if (s < end) { *d++ = '.'; *d++ = '.'; *d++ = '.'; @@ -1720,7 +1731,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (SvRV(tmpstr) != SvRV(sv))) + (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) return SvIV(tmpstr); return PTR2IV(SvRV(sv)); } @@ -1974,7 +1985,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (SvRV(tmpstr) != SvRV(sv))) + (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) return SvUV(tmpstr); return PTR2UV(SvRV(sv)); } @@ -2258,7 +2269,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (SvRV(tmpstr) != SvRV(sv))) + (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) return SvNV(tmpstr); return PTR2NV(SvRV(sv)); } @@ -2522,7 +2533,7 @@ Perl_looks_like_number(pTHX_ SV *sv) ) { #ifdef USE_LOCALE_NUMERIC if (specialradix) - s += SvCUR(PL_numeric_radix); + s += SvCUR(PL_numeric_radix_sv); else #endif s++; @@ -2538,7 +2549,7 @@ Perl_looks_like_number(pTHX_ SV *sv) ) { #ifdef USE_LOCALE_NUMERIC if (specialradix) - s += SvCUR(PL_numeric_radix); + s += SvCUR(PL_numeric_radix_sv); else #endif s++; @@ -2674,7 +2685,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) if (SvROK(sv)) { SV* tmpstr; if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) && - (SvRV(tmpstr) != SvRV(sv))) + (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv)))) return SvPV(tmpstr,*lp); sv = (SV*)SvRV(sv); if (!sv) @@ -2688,7 +2699,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) == (SVs_OBJECT|SVs_RMG)) && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp") - && (mg = mg_find(sv, 'r'))) { + && (mg = mg_find(sv, PERL_MAGIC_qr))) { regexp *re = (regexp *)mg->mg_obj; if (!mg->mg_ptr) { @@ -2914,7 +2925,7 @@ Perl_sv_2bool(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpsv; if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) && - (SvRV(tmpsv) != SvRV(sv))) + (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv)))) return SvTRUE(tmpsv); return SvRV(sv) != 0; } @@ -2954,37 +2965,41 @@ 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) return 0; - if (!SvPOK(sv)) - (void) SvPV_nolen(sv); + 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; @@ -3013,15 +3028,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", @@ -3032,9 +3069,8 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) } SvCUR(sv) = len; } - SvUTF8_off(sv); } - + SvUTF8_off(sv); return TRUE; } @@ -3071,8 +3107,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)) @@ -3081,12 +3117,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; } @@ -3233,7 +3270,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) char *name = GvNAME(sstr); STRLEN len = GvNAMELEN(sstr); sv_upgrade(dstr, SVt_PVGV); - sv_magic(dstr, dstr, '*', Nullch, 0); + sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0); GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr)); GvNAME(dstr) = savepvn(name, len); GvNAMELEN(dstr) = len; @@ -3789,8 +3826,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 */ @@ -3888,10 +3926,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) @@ -3957,12 +3995,23 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam MAGIC* mg; if (SvREADONLY(sv)) { - if (PL_curcop != &PL_compiling && !strchr("gBf", how)) + if (PL_curcop != &PL_compiling + /* XXX this used to be !strchr("gBf", how), which seems to + * implicity be equal to !strchr("gBf\0", how), ie \0 matches + * too. I find this suprising, but have hadded PERL_MAGIC_sv + * to the list of things to check - DAPM 19-May-01 */ + && how != PERL_MAGIC_regex_global + && how != PERL_MAGIC_bm + && how != PERL_MAGIC_fm + && how != PERL_MAGIC_sv + ) + { Perl_croak(aTHX_ PL_no_modify); + } } - if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { + if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) { if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { - if (how == 't') + if (how == PERL_MAGIC_taint) mg->mg_len |= 1; return; } @@ -3978,7 +4027,9 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam 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' || + if (!obj || obj == sv || + how == PERL_MAGIC_arylen || + how == PERL_MAGIC_qr || (SvTYPE(obj) == SVt_PVGV && (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv || @@ -4000,117 +4051,118 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam } switch (how) { - case 0: + case PERL_MAGIC_sv: mg->mg_virtual = &PL_vtbl_sv; break; - case 'A': + case PERL_MAGIC_overload: mg->mg_virtual = &PL_vtbl_amagic; break; - case 'a': + case PERL_MAGIC_overload_elem: mg->mg_virtual = &PL_vtbl_amagicelem; break; - case 'c': + case PERL_MAGIC_overload_table: mg->mg_virtual = &PL_vtbl_ovrld; break; - case 'B': + case PERL_MAGIC_bm: mg->mg_virtual = &PL_vtbl_bm; break; - case 'D': + case PERL_MAGIC_regdata: mg->mg_virtual = &PL_vtbl_regdata; break; - case 'd': + case PERL_MAGIC_regdatum: mg->mg_virtual = &PL_vtbl_regdatum; break; - case 'E': + case PERL_MAGIC_env: mg->mg_virtual = &PL_vtbl_env; break; - case 'f': + case PERL_MAGIC_fm: mg->mg_virtual = &PL_vtbl_fm; break; - case 'e': + case PERL_MAGIC_envelem: mg->mg_virtual = &PL_vtbl_envelem; break; - case 'g': + case PERL_MAGIC_regex_global: mg->mg_virtual = &PL_vtbl_mglob; break; - case 'I': + case PERL_MAGIC_isa: mg->mg_virtual = &PL_vtbl_isa; break; - case 'i': + case PERL_MAGIC_isaelem: mg->mg_virtual = &PL_vtbl_isaelem; break; - case 'k': + case PERL_MAGIC_nkeys: mg->mg_virtual = &PL_vtbl_nkeys; break; - case 'L': + case PERL_MAGIC_dbfile: SvRMAGICAL_on(sv); mg->mg_virtual = 0; break; - case 'l': + case PERL_MAGIC_dbline: mg->mg_virtual = &PL_vtbl_dbline; break; #ifdef USE_THREADS - case 'm': + case PERL_MAGIC_mutex: mg->mg_virtual = &PL_vtbl_mutex; break; #endif /* USE_THREADS */ #ifdef USE_LOCALE_COLLATE - case 'o': + case PERL_MAGIC_collxfrm: mg->mg_virtual = &PL_vtbl_collxfrm; break; #endif /* USE_LOCALE_COLLATE */ - case 'P': + case PERL_MAGIC_tied: mg->mg_virtual = &PL_vtbl_pack; break; - case 'p': - case 'q': + case PERL_MAGIC_tiedelem: + case PERL_MAGIC_tiedscalar: mg->mg_virtual = &PL_vtbl_packelem; break; - case 'r': + case PERL_MAGIC_qr: mg->mg_virtual = &PL_vtbl_regexp; break; - case 'S': + case PERL_MAGIC_sig: mg->mg_virtual = &PL_vtbl_sig; break; - case 's': + case PERL_MAGIC_sigelem: mg->mg_virtual = &PL_vtbl_sigelem; break; - case 't': + case PERL_MAGIC_taint: mg->mg_virtual = &PL_vtbl_taint; mg->mg_len = 1; break; - case 'U': + case PERL_MAGIC_uvar: mg->mg_virtual = &PL_vtbl_uvar; break; - case 'v': + case PERL_MAGIC_vec: mg->mg_virtual = &PL_vtbl_vec; break; - case 'x': + case PERL_MAGIC_substr: mg->mg_virtual = &PL_vtbl_substr; break; - case 'y': + case PERL_MAGIC_defelem: mg->mg_virtual = &PL_vtbl_defelem; break; - case '*': + case PERL_MAGIC_glob: mg->mg_virtual = &PL_vtbl_glob; break; - case '#': + case PERL_MAGIC_arylen: mg->mg_virtual = &PL_vtbl_arylen; break; - case '.': + case PERL_MAGIC_pos: mg->mg_virtual = &PL_vtbl_pos; break; - case '<': + case PERL_MAGIC_backref: mg->mg_virtual = &PL_vtbl_backref; break; - case '~': /* Reserved for use by extensions not perl internals. */ + case PERL_MAGIC_ext: + /* Reserved for use by extensions not perl internals. */ /* Useful for attaching extension internal data to perl vars. */ /* Note that multiple extensions may clash if magical scalars */ /* etc holding private data from one are passed to another. */ SvRMAGICAL_on(sv); break; default: - Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how); + Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how); } mg_magical(sv); if (SvGMAGICAL(sv)) @@ -4139,7 +4191,7 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) *mgp = mg->mg_moremagic; if (vtbl && vtbl->svt_free) CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); - if (mg->mg_ptr && mg->mg_type != 'g') { + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { if (mg->mg_len >= 0) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) @@ -4193,11 +4245,11 @@ S_sv_add_backref(pTHX_ SV *tsv, SV *sv) { AV *av; MAGIC *mg; - if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<'))) + if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref))) av = (AV*)mg->mg_obj; else { av = newAV(); - sv_magic(tsv, (SV*)av, '<', NULL, 0); + sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0); SvREFCNT_dec(av); /* for sv_magic */ } av_push(av,sv); @@ -4211,7 +4263,7 @@ S_sv_del_backref(pTHX_ SV *sv) I32 i; SV *tsv = SvRV(sv); MAGIC *mg; - if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<'))) + if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) Perl_croak(aTHX_ "panic: del_backref"); av = (AV *)mg->mg_obj; svp = AvARRAY(av); @@ -4705,8 +4757,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++; } @@ -4734,8 +4787,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 = ""; @@ -4754,31 +4806,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; } @@ -4914,7 +4968,7 @@ Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2) #ifdef USE_LOCALE_COLLATE /* - * Any scalar variable may carry an 'o' magic that contains the + * Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the * scalar data of the variable transformed to such a format that * a normal memory comparison can be used to compare the data * according to the locale settings. @@ -4924,7 +4978,7 @@ Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) { MAGIC *mg; - mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL; + mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL; if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { char *s, *xf; STRLEN len, xlen; @@ -4939,8 +4993,8 @@ Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) return xf + sizeof(PL_collation_ix); } if (! mg) { - sv_magic(sv, 0, 'o', 0, 0); - mg = mg_find(sv, 'o'); + sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0); + mg = mg_find(sv, PERL_MAGIC_collxfrm); assert(mg); } mg->mg_ptr = xf; @@ -6153,18 +6207,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); } @@ -6501,7 +6558,7 @@ S_sv_unglob(pTHX_ SV *sv) SvREFCNT_dec(GvSTASH(sv)); GvSTASH(sv) = Nullhv; } - sv_unmagic(sv, '*'); + sv_unmagic(sv, PERL_MAGIC_glob); Safefree(GvNAME(sv)); GvMULTI_off(sv); @@ -6568,14 +6625,14 @@ Perl_sv_unref(pTHX_ SV *sv) void Perl_sv_taint(pTHX_ SV *sv) { - sv_magic((sv), Nullsv, 't', Nullch, 0); + sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0); } void Perl_sv_untaint(pTHX_ SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - MAGIC *mg = mg_find(sv, 't'); + MAGIC *mg = mg_find(sv, PERL_MAGIC_taint); if (mg) mg->mg_len &= ~1; } @@ -6585,7 +6642,7 @@ bool Perl_sv_tainted(pTHX_ SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - MAGIC *mg = mg_find(sv, 't'); + MAGIC *mg = mg_find(sv, PERL_MAGIC_taint); if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv))) return TRUE; } @@ -6727,12 +6784,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, ...) @@ -7097,7 +7157,9 @@ 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; @@ -7637,8 +7699,8 @@ Perl_gp_dup(pTHX_ GP *gp) MAGIC * Perl_mg_dup(pTHX_ MAGIC *mg) { - MAGIC *mgret = (MAGIC*)NULL; - MAGIC *mgprev; + MAGIC *mgprev = (MAGIC*)NULL; + MAGIC *mgret; if (!mg) return (MAGIC*)NULL; /* look for it in the table first */ @@ -7649,15 +7711,15 @@ Perl_mg_dup(pTHX_ MAGIC *mg) for (; mg; mg = mg->mg_moremagic) { MAGIC *nmg; Newz(0, nmg, 1, MAGIC); - if (!mgret) - mgret = nmg; - else + if (mgprev) mgprev->mg_moremagic = nmg; + else + mgret = nmg; nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */ nmg->mg_private = mg->mg_private; nmg->mg_type = mg->mg_type; nmg->mg_flags = mg->mg_flags; - if (mg->mg_type == 'r') { + if (mg->mg_type == PERL_MAGIC_qr) { nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj); } else { @@ -7667,10 +7729,12 @@ Perl_mg_dup(pTHX_ MAGIC *mg) } nmg->mg_len = mg->mg_len; nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */ - if (mg->mg_ptr && mg->mg_type != 'g') { + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { if (mg->mg_len >= 0) { nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len); - if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) { + if (mg->mg_type == PERL_MAGIC_overload_table && + AMT_AMAGIC((AMT*)mg->mg_ptr)) + { AMT *amtp = (AMT*)mg->mg_ptr; AMT *namtp = (AMT*)nmg->mg_ptr; I32 i; @@ -8166,7 +8230,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 */ @@ -8177,7 +8241,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: @@ -8231,7 +8298,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; @@ -8485,6 +8552,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) TOPIV(nss,ix) = iv; break; case SAVEt_FREESV: + case SAVEt_MORTALIZESV: sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv); break; @@ -8818,7 +8886,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); @@ -9029,7 +9097,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_numeric_name = SAVEPV(proto_perl->Inumeric_name); PL_numeric_standard = proto_perl->Inumeric_standard; PL_numeric_local = proto_perl->Inumeric_local; - PL_numeric_radix = sv_dup_inc(proto_perl->Inumeric_radix); + PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv); #endif /* !USE_LOCALE_NUMERIC */ /* utf8 character classes */ @@ -9243,7 +9311,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_regendp = (I32*)NULL; PL_reglastparen = (U32*)NULL; PL_regtill = Nullch; - PL_regprev = '\n'; PL_reg_start_tmp = (char**)NULL; PL_reg_start_tmpl = 0; PL_regdata = (struct reg_data*)NULL;