X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=581c788318551c43504957e97908a9c291ff12ce;hb=3f939f220e50adb6f28f2dd14f06461c7cebfe14;hp=a891a88e4a3a9eba857355b2621ff380479b6ec2;hpb=96fa62ad548d6e808f1530052e817f845408c4bb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index a891a88..581c788 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 */ @@ -1469,7 +1470,7 @@ S_not_a_number(pTHX_ SV *sv) *d++ = toCTRL(ch); } } - if (*s < end) { + if (s < end) { *d++ = '.'; *d++ = '.'; *d++ = '.'; @@ -1730,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)); } @@ -1984,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)); } @@ -2268,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)); } @@ -2305,7 +2306,10 @@ Perl_sv_2nv(pTHX_ register SV *sv) } else if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); - if (SvIOKp(sv) && + if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) { + SvNOK_on(sv); + } + else if (SvIOKp(sv) && (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv))) { SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv); @@ -2525,14 +2529,14 @@ Perl_looks_like_number(pTHX_ SV *sv) UV_MAX= 18446744073709551615) so be cautious */ numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX; - if (*s == '.' + if ( #ifdef USE_LOCALE_NUMERIC - || (specialradix = IS_NUMERIC_RADIX(s)) + (specialradix = IS_NUMERIC_RADIX(s, send)) || #endif - ) { + *s == '.') { #ifdef USE_LOCALE_NUMERIC if (specialradix) - s += SvCUR(PL_numeric_radix); + s += SvCUR(PL_numeric_radix_sv); else #endif s++; @@ -2541,14 +2545,15 @@ Perl_looks_like_number(pTHX_ SV *sv) s++; } } - else if (*s == '.' + else if ( #ifdef USE_LOCALE_NUMERIC - || (specialradix = IS_NUMERIC_RADIX(s)) + (specialradix = IS_NUMERIC_RADIX(s, send)) || #endif + *s == '.' ) { #ifdef USE_LOCALE_NUMERIC if (specialradix) - s += SvCUR(PL_numeric_radix); + s += SvCUR(PL_numeric_radix_sv); else #endif s++; @@ -2642,6 +2647,12 @@ uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) char * Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) { + return sv_2pv_flags(sv, lp, SV_GMAGIC); +} + +char * +Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) +{ register char *s; int olderrno; SV *tsv; @@ -2653,7 +2664,8 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) return ""; } if (SvGMAGICAL(sv)) { - mg_get(sv); + if (flags & SV_GMAGIC) + mg_get(sv); if (SvPOKp(sv)) { *lp = SvCUR(sv); return SvPVX(sv); @@ -2684,7 +2696,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) @@ -2698,7 +2710,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) { @@ -2924,7 +2936,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; } @@ -2964,6 +2976,25 @@ if all the bytes have hibit clear. STRLEN Perl_sv_utf8_upgrade(pTHX_ register SV *sv) { + return sv_utf8_upgrade_flags(sv, SV_GMAGIC); +} + +/* +=for apidoc sv_utf8_upgrade_flags + +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. If C has C bit set, +will C on C if appropriate, else not. C and +C are implemented in terms of this function. + +=cut +*/ + +STRLEN +Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) +{ U8 *s, *t, *e; int hibit = 0; @@ -2972,7 +3003,7 @@ Perl_sv_utf8_upgrade(pTHX_ register SV *sv) if (!SvPOK(sv)) { STRLEN len = 0; - (void) sv_2pv(sv,&len); + (void) sv_2pv_flags(sv,&len, flags); if (!SvPOK(sv)) return len; } @@ -3037,7 +3068,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) if (fail_ok) return FALSE; #ifdef USE_BYTES_DOWNGRADES - else if (IN_BYTE) { + else if (IN_BYTES) { U8 *d = s; U8 *e = (U8 *) SvEND(sv); int first = 1; @@ -3148,9 +3179,30 @@ C. =cut */ +/* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided + for binary compatibility only +*/ void Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) { + sv_setsv_flags(dstr, sstr, SV_GMAGIC); +} + +/* +=for apidoc sv_setsv_flags + +Copies the contents of the source SV C into the destination SV C. +The source SV may be destroyed if it is mortal. Does not handle 'set' +magic. If C has C bit set, will C on C if +appropriate, else not. C and C are implemented +in terms of this function. + +=cut +*/ + +void +Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) +{ register U32 sflags; register int dtype; register int stype; @@ -3269,7 +3321,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; @@ -3304,7 +3356,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) /* FALL THROUGH */ default: - if (SvGMAGICAL(sstr)) { + if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { mg_get(sstr); if (SvTYPE(sstr) != stype) { stype = SvTYPE(sstr); @@ -3626,7 +3678,8 @@ Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN else { /* len is STRLEN which is unsigned, need to copy to signed */ IV iv = len; - assert(iv >= 0); + if (iv < 0) + Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen"); } (void)SvUPGRADE(sv, SVt_PV); @@ -3832,21 +3885,43 @@ Handles 'get' magic, but not 'set' magic. See C. =cut */ +/* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided + for binary compatibility only +*/ void -Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) +Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen) { - STRLEN tlen; - char *junk; + sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC); +} - junk = SvPV_force(sv, tlen); - SvGROW(sv, tlen + len + 1); - if (ptr == junk) - ptr = SvPVX(sv); - Move(ptr,SvPVX(sv)+tlen,len,char); - SvCUR(sv) += len; - *SvEND(sv) = '\0'; - (void)SvPOK_only_UTF8(sv); /* validate pointer */ - SvTAINT(sv); +/* +=for apidoc sv_catpvn_flags + +Concatenates the string onto the end of the string which is in the SV. The +C indicates number of bytes to copy. If the SV has the UTF8 +status set, then the bytes appended should be valid UTF8. +If C has C bit set, will C on C if +appropriate, else not. C and C are implemented +in terms of this function. + +=cut +*/ + +void +Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags) +{ + STRLEN dlen; + char *dstr; + + dstr = SvPV_force_flags(dsv, dlen, flags); + SvGROW(dsv, dlen + slen + 1); + if (sstr == dstr) + sstr = SvPVX(dsv); + Move(sstr, SvPVX(dsv) + dlen, slen, char); + SvCUR(dsv) += slen; + *SvEND(dsv) = '\0'; + (void)SvPOK_only_UTF8(dsv); /* validate pointer */ + SvTAINT(dsv); } /* @@ -3873,36 +3948,52 @@ not 'set' magic. See C. =cut */ +/* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided + for binary compatibility only +*/ void -Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv) +Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) +{ + sv_catsv_flags(dstr, sstr, SV_GMAGIC); +} + +/* +=for apidoc sv_catsv_flags + +Concatenates the string from SV C onto the end of the string in +SV C. Modifies C but not C. If C has C +bit set, will C on the SVs if appropriate, else not. C +and C are implemented in terms of this function. + +=cut */ + +void +Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) { char *spv; STRLEN slen; if (!ssv) return; if ((spv = SvPV(ssv, slen))) { - bool dutf8 = DO_UTF8(dsv); bool sutf8 = DO_UTF8(ssv); + bool dutf8; - if (dutf8 == sutf8) - sv_catpvn(dsv,spv,slen); - else { + if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC)) + mg_get(dsv); + dutf8 = DO_UTF8(dsv); + + if (dutf8 != sutf8) { if (dutf8) { /* Not modifying source SV, so taking a temporary copy. */ - SV* csv = sv_2mortal(newSVsv(ssv)); - char *cpv; - STRLEN clen; + SV* csv = sv_2mortal(newSVpvn(spv, slen)); sv_utf8_upgrade(csv); - cpv = SvPV(csv,clen); - sv_catpvn(dsv,cpv,clen); - } - else { - sv_utf8_upgrade(dsv); - sv_catpvn(dsv,spv,slen); - SvUTF8_on(dsv); /* If dsv has no wide characters. */ + spv = SvPV(csv, slen); } + else + sv_utf8_upgrade_nomg(dsv); } + sv_catpvn_nomg(dsv, spv, slen); } } @@ -3994,12 +4085,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; } @@ -4015,7 +4117,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 || @@ -4037,117 +4141,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)) @@ -4176,7 +4281,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) @@ -4191,7 +4296,7 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) } if (!SvMAGIC(sv)) { SvMAGICAL_off(sv); - SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; + SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT; } return 0; @@ -4230,11 +4335,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); @@ -4248,7 +4353,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); @@ -4789,7 +4894,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) pv2 = SvPV(sv2, cur2); /* do not utf8ize the comparands as a side-effect */ - if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) { + if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { bool is_utf8 = TRUE; /* UTF-8ness differs */ if (PL_hints & HINT_UTF8_DISTINCT) @@ -4856,7 +4961,7 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) pv2 = SvPV(sv2, cur2); /* do not utf8ize the comparands as a side-effect */ - if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) { + if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { if (PL_hints & HINT_UTF8_DISTINCT) return SvUTF8(sv1) ? 1 : -1; @@ -4953,7 +5058,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. @@ -4963,7 +5068,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; @@ -4978,8 +5083,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; @@ -5021,7 +5126,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) register STDCHAR rslast; register STDCHAR *bp; register I32 cnt; - I32 i; + I32 i = 0; SV_CHECK_THINKFIRST(sv); (void)SvUPGRADE(sv, SVt_PV); @@ -6153,6 +6258,23 @@ Get a sensible string out of the SV somehow. char * Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) { + return sv_pvn_force_flags(sv, lp, SV_GMAGIC); +} + +/* +=for apidoc sv_pvn_force_flags + +Get a sensible string out of the SV somehow. +If C has C bit set, will C on C if +appropriate, else not. C and C are +implemented in terms of this function. + +=cut +*/ + +char * +Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) +{ char *s; if (SvTHINKFIRST(sv) && !SvROK(sv)) @@ -6167,7 +6289,7 @@ Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) PL_op_name[PL_op->op_type]); } else - s = sv_2pv(sv, lp); + s = sv_2pv_flags(sv, lp, flags); if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */ STRLEN len = *lp; @@ -6543,7 +6665,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); @@ -6610,14 +6732,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; } @@ -6627,7 +6749,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; } @@ -6870,7 +6992,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STRLEN origlen; I32 svix = 0; static char nullstr[] = "(null)"; - SV *argsv; + SV *argsv = Nullsv; /* no matter what, this is a string now */ (void)SvPV_force(sv, origlen); @@ -6938,7 +7060,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STRLEN veclen = 0; char c; int i; - unsigned base; + unsigned base = 0; IV iv; UV uv; NV nv; @@ -7144,7 +7266,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV uv = args ? va_arg(*args, int) : SvIVx(argsv); if ((uv > 255 || (!UNI_IS_INVARIANT(uv) && SvUTF8(sv))) - && !IN_BYTE) { + && !IN_BYTES) { eptr = (char*)utf8buf; elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf; is_utf = TRUE; @@ -7704,7 +7826,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg) 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 { @@ -7714,10 +7836,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; @@ -7963,14 +8087,18 @@ Perl_sv_dup(pTHX_ SV *sstr) break; case SVt_RV: SvANY(dstr) = new_XRV(); - SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr)) + ? sv_dup(SvRV(sstr)) + : sv_dup_inc(SvRV(sstr)); break; case SVt_PV: SvANY(dstr) = new_XPV(); SvCUR(dstr) = SvCUR(sstr); SvLEN(dstr) = SvLEN(sstr); if (SvROK(sstr)) - SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + ? sv_dup(SvRV(sstr)) + : sv_dup_inc(SvRV(sstr)); else if (SvPVX(sstr) && SvLEN(sstr)) SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else @@ -7982,7 +8110,9 @@ Perl_sv_dup(pTHX_ SV *sstr) SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); if (SvROK(sstr)) - SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + ? sv_dup(SvRV(sstr)) + : sv_dup_inc(SvRV(sstr)); else if (SvPVX(sstr) && SvLEN(sstr)) SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else @@ -7995,7 +8125,9 @@ Perl_sv_dup(pTHX_ SV *sstr) SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); if (SvROK(sstr)) - SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + ? sv_dup(SvRV(sstr)) + : sv_dup_inc(SvRV(sstr)); else if (SvPVX(sstr) && SvLEN(sstr)) SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else @@ -8010,7 +8142,9 @@ Perl_sv_dup(pTHX_ SV *sstr) SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); if (SvROK(sstr)) - SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + ? sv_dup(SvRV(sstr)) + : sv_dup_inc(SvRV(sstr)); else if (SvPVX(sstr) && SvLEN(sstr)) SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else @@ -8025,7 +8159,9 @@ Perl_sv_dup(pTHX_ SV *sstr) SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); if (SvROK(sstr)) - SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + ? sv_dup(SvRV(sstr)) + : sv_dup_inc(SvRV(sstr)); else if (SvPVX(sstr) && SvLEN(sstr)) SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else @@ -8043,7 +8179,9 @@ Perl_sv_dup(pTHX_ SV *sstr) SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); if (SvROK(sstr)) - SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + ? sv_dup(SvRV(sstr)) + : sv_dup_inc(SvRV(sstr)); else if (SvPVX(sstr) && SvLEN(sstr)) SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else @@ -8074,7 +8212,9 @@ Perl_sv_dup(pTHX_ SV *sstr) SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); if (SvROK(sstr)) - SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + ? sv_dup(SvRV(sstr)) + : sv_dup_inc(SvRV(sstr)); else if (SvPVX(sstr) && SvLEN(sstr)) SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else @@ -8095,7 +8235,9 @@ Perl_sv_dup(pTHX_ SV *sstr) SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); if (SvROK(sstr)) - SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + SvRV(dstr) = SvWEAKREF(SvRV(sstr)) + ? sv_dup(SvRV(sstr)) + : sv_dup_inc(SvRV(sstr)); else if (SvPVX(sstr) && SvLEN(sstr)) SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else @@ -9080,7 +9222,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 */ @@ -9294,7 +9436,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; @@ -9365,7 +9506,7 @@ do_clean_objs(pTHXo_ SV *sv) SV* rv; if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));) + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv))); if (SvWEAKREF(sv)) { sv_del_backref(sv); SvWEAKREF_off(sv); @@ -9391,7 +9532,7 @@ do_clean_named_objs(pTHXo_ SV *sv) (GvIO(sv) && SvOBJECT(GvIO(sv))) || (GvCV(sv) && SvOBJECT(GvCV(sv))) ) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));) + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv))); SvREFCNT_dec(sv); } } @@ -9401,7 +9542,7 @@ do_clean_named_objs(pTHXo_ SV *sv) static void do_clean_all(pTHXo_ SV *sv) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );) + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); SvFLAGS(sv) |= SVf_BREAK; SvREFCNT_dec(sv); }