X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d0e98d276e2cc7fdcdfbde4dabbc0843fb890ac7..3351db0262a00327940d490d1d2727273740be19:/sv.c diff --git a/sv.c b/sv.c index c5511b0..ef61d1b 100644 --- a/sv.c +++ b/sv.c @@ -1,6 +1,6 @@ /* sv.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (c) 1991-2002, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -199,7 +199,7 @@ S_del_sv(pTHX_ SV *p) } if (!ok) { if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free non-arena SV: 0x%"UVxf, PTR2UV(p)); return; @@ -216,6 +216,8 @@ S_del_sv(pTHX_ SV *p) /* +=head1 SV Manipulation Functions + =for apidoc sv_add_arena Given a chunk of memory, link it to the head of the list of arenas, @@ -295,6 +297,8 @@ S_visit(pTHX_ SVFUNC_t f) return visited; } +#ifdef DEBUGGING + /* called by sv_report_used() for each live SV */ static void @@ -305,6 +309,7 @@ do_report_used(pTHX_ SV *sv) sv_dump(sv); } } +#endif /* =for apidoc sv_report_used @@ -317,7 +322,9 @@ Dump the contents of all SVs not yet freed. (Debugging aid). void Perl_sv_report_used(pTHX) { +#ifdef DEBUGGING visit(do_report_used); +#endif } /* called by sv_clean_objs() for each live SV */ @@ -539,10 +546,10 @@ void Perl_report_uninit(pTHX) { if (PL_op) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, + Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, " in ", OP_DESC(PL_op)); else - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", ""); + Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", ""); } /* grab a new IV body from the free list, allocating more if necessary */ @@ -1219,13 +1226,13 @@ You generally want to use the C macro wrapper. See also C. bool Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) { - char* pv; - U32 cur; - U32 len; - IV iv; - NV nv; - MAGIC* magic; - HV* stash; + char* pv = NULL; + U32 cur = 0; + U32 len = 0; + IV iv = 0; + NV nv = 0.0; + MAGIC* magic = NULL; + HV* stash = Nullhv; if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) { sv_force_normal(sv); @@ -1417,8 +1424,8 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) SvPVX(sv) = 0; HvFILL(sv) = 0; HvMAX(sv) = 0; - HvKEYS(sv) = 0; - SvNVX(sv) = 0.0; + HvTOTALKEYS(sv) = 0; + HvPLACEHOLDERS(sv) = 0; SvMAGIC(sv) = magic; SvSTASH(sv) = stash; HvRITER(sv) = 0; @@ -1533,6 +1540,8 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) { register char *s; + + #ifdef HAS_64K_LIMIT if (newlen >= 0x10000) { PerlIO_printf(Perl_debug_log, @@ -1558,6 +1567,7 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) } else s = SvPVX(sv); + if (newlen > SvLEN(sv)) { /* need more room? */ if (SvLEN(sv) && s) { #if defined(MYMALLOC) && !defined(LEAKTEST) @@ -1577,6 +1587,9 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) SvREADONLY_off(sv); } New(703, s, newlen, char); + if (SvPVX(sv) && SvCUR(sv)) { + Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char); + } } SvPV_set(sv, s); SvLEN_set(sv, newlen); @@ -1768,7 +1781,7 @@ S_not_a_number(pTHX_ SV *sv) char *limit = tmpbuf + sizeof(tmpbuf) - 8; /* each *s can expand to 4 chars + "...\0", i.e. need room for 8 chars */ - + char *s, *end; for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) { int ch = *s & 0xFF; @@ -1814,11 +1827,11 @@ S_not_a_number(pTHX_ SV *sv) } if (PL_op) - Perl_warner(aTHX_ WARN_NUMERIC, + Perl_warner(aTHX_ packWARN(WARN_NUMERIC), "Argument \"%s\" isn't numeric in %s", pv, OP_DESC(PL_op)); else - Perl_warner(aTHX_ WARN_NUMERIC, + Perl_warner(aTHX_ packWARN(WARN_NUMERIC), "Argument \"%s\" isn't numeric", pv); } @@ -1936,7 +1949,7 @@ Perl_looks_like_number(pTHX_ SV *sv) STATIC int S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) { - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { (void)SvIOKp_on(sv); (void)SvNOK_on(sv); @@ -2163,7 +2176,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) SvIVX(sv) = -(IV)value; } else { /* Too negative for an IV. This is a double upgrade, but - I'm assuming it will be be rare. */ + I'm assuming it will be rare. */ if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); SvNOK_on(sv); @@ -2190,7 +2203,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n", PTR2UV(sv), SvNVX(sv))); #else - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n", + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n", PTR2UV(sv), SvNVX(sv))); #endif @@ -2246,7 +2259,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) this NV is in the preserved range, therefore: */ if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) < (UV)IV_MAX)) { - Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); + Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); } } else { /* IN_UV NOT_INT @@ -2454,7 +2467,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) SvIVX(sv) = -(IV)value; } else { /* Too negative for an IV. This is a double upgrade, but - I'm assuming it will be be rare. */ + I'm assuming it will be rare. */ if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); SvNOK_on(sv); @@ -2478,7 +2491,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n", PTR2UV(sv), SvNVX(sv))); #else - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n", + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n", PTR2UV(sv), SvNVX(sv))); #endif @@ -2533,7 +2546,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) this NV is in the preserved range, therefore: */ if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) < (UV)IV_MAX)) { - Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); + Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); } } else sv_2iuv_non_preserve (sv, numtype); @@ -2629,7 +2642,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) #else DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n", + PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); @@ -2758,7 +2771,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) #else DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n", + PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); @@ -2862,8 +2875,8 @@ uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) return ptr; } -/* For backwards-compatibility only. sv_2pv() is normally #def'ed to - * C. See also C. +/* sv_2pv() is now a macro using Perl_sv_2pv_flags(); + * this function provided for binary compatibility only */ char * @@ -3004,8 +3017,15 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) default: s = "UNKNOWN"; break; } tsv = NEWSV(0,0); - if (SvOBJECT(sv)) - Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); + if (SvOBJECT(sv)) { + HV *svs = SvSTASH(sv); + Perl_sv_setpvf( + aTHX_ tsv, "%s=%s", + /* [20011101.072] This bandaid for C + should eventually be removed. AMS 20011103 */ + (svs ? HvNAME(svs) : ""), s + ); + } else sv_setpv(tsv, s); Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv)); @@ -3131,6 +3151,45 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } /* +=for apidoc sv_copypv + +Copies a stringified representation of the source SV into the +destination SV. Automatically performs any necessary mg_get and +coercion of numeric values into strings. Guaranteed to preserve +UTF-8 flag even from overloaded objects. Similar in nature to +sv_2pv[_flags] but operates directly on an SV instead of just the +string. Mostly uses sv_2pv_flags to do its work, except when that +would lose the UTF-8'ness of the PV. + +=cut +*/ + +void +Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) +{ + SV *tmpsv = sv_newmortal(); + + if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) ) { + tmpsv = AMG_CALLun(ssv,string); + if (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(ssv))) { + SvSetSV(dsv,tmpsv); + return; + } + } + { + STRLEN len; + char *s; + s = SvPV(ssv,len); + sv_setpvn(tmpsv,s,len); + if (SvUTF8(ssv)) + SvUTF8_on(tmpsv); + else + SvUTF8_off(tmpsv); + SvSetSV(dsv,tmpsv); + } +} + +/* =for apidoc sv_2pvbyte_nolen Return a pointer to the byte-encoded representation of the SV. @@ -3223,7 +3282,7 @@ Perl_sv_2bool(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpsv; if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) && - (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv)))) + (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) return SvTRUE(tmpsv); return SvRV(sv) != 0; } @@ -3257,9 +3316,17 @@ Forces the SV to string form if it is not already. Always sets the SvUTF8 flag to avoid future validity checks even if all the bytes have hibit clear. +This is not as a general purpose byte encoding to Unicode interface: +use the Encode extension for that. + =cut */ +/* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags(); + * this function provided for binary compatibility only + */ + + STRLEN Perl_sv_utf8_upgrade(pTHX_ register SV *sv) { @@ -3276,6 +3343,9 @@ 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. +This is not as a general purpose byte encoding to Unicode interface: +use the Encode extension for that. + =cut */ @@ -3303,7 +3373,7 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) } if (PL_encoding) - Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding); + sv_recode_to_utf8(sv, PL_encoding); else { /* Assume Latin-1/EBCDIC */ /* This function could be much more efficient if we * had a FLAG in SVs to signal if there are any hibit @@ -3319,7 +3389,7 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) } if (hibit) { STRLEN len; - + len = SvCUR(sv) + 1; /* Plus the \0 */ SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len); SvCUR(sv) = len - 1; @@ -3341,6 +3411,9 @@ This may not be possible if the PV contains non-byte encoding characters; if this is the case, either returns false or, if C is not true, croaks. +This is not as a general purpose Unicode to byte encoding interface: +use the Encode extension for that. + =cut */ @@ -3358,28 +3431,6 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) if (!utf8_to_bytes(s, &len)) { if (fail_ok) return FALSE; -#ifdef USE_BYTES_DOWNGRADES - else if (IN_BYTES) { - 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", - OP_DESC(PL_op); - 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", @@ -3470,9 +3521,10 @@ C. =cut */ -/* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided - for binary compatibility only -*/ +/* sv_setsv() is now a macro using Perl_sv_setsv_flags(); + * this function provided for binary compatibility only + */ + void Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) { @@ -3750,15 +3802,16 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) || sv_cmp(cv_const_sv(cv), cv_const_sv((CV*)sref))))) { - Perl_warner(aTHX_ WARN_REDEFINE, + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), CvCONST(cv) ? "Constant subroutine %s redefined" : "Subroutine %s redefined", GvENAME((GV*)dstr)); } } - cv_ckproto(cv, (GV*)dstr, - SvPOK(sref) ? SvPVX(sref) : Nullch); + if (!intro) + cv_ckproto(cv, (GV*)dstr, + SvPOK(sref) ? SvPVX(sref) : Nullch); } GvCV(dstr) = (CV*)sref; GvCVGEN(dstr) = 0; /* Switch off cacheness. */ @@ -3873,7 +3926,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } else { /* have to copy actual string */ STRLEN len = SvCUR(sstr); - SvGROW(dstr, len + 1); /* inlined from sv_setpvn */ Move(SvPVX(sstr),SvPVX(dstr),len,char); SvCUR_set(dstr, len); @@ -3929,7 +3981,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) else { if (dtype == SVt_PVGV) { if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob"); + Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob"); } else (void)SvOK_off(dstr); @@ -4201,9 +4253,10 @@ 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 -*/ +/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags(); + * this function provided for binary compatibility only + */ + void Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen) { @@ -4264,9 +4317,10 @@ not 'set' magic. See C. =cut */ -/* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided - for binary compatibility only -*/ +/* sv_catsv() is now a macro using Perl_sv_catsv_flags(); + * this function provided for binary compatibility only + */ + void Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) { @@ -4401,52 +4455,42 @@ Perl_newSV(pTHX_ STRLEN len) } return sv; } - /* -=for apidoc sv_magic +=for apidoc sv_magicext -Adds magic to an SV. First upgrades C to type C if necessary, -then adds a new magic item of type C to the head of the magic list. +Adds magic to an SV, upgrading it if necessary. Applies the +supplied vtable and returns pointer to the magic added. + +Note that sv_magicext will allow things that sv_magic will not. +In particular you can add magic to SvREADONLY SVs and and more than +one instance of the same 'how' -C is assumed to contain an C if C<(name && namelen == HEf_SVKEY)> +I C is greater then zero then a savepvn() I of C is stored, +if C is zero then C is stored as-is and - as another special +case - if C<(name && namelen == HEf_SVKEY)> then C is assumed to contain +an C and has its REFCNT incremented + +(This is now used as a subroutine by sv_magic.) =cut */ - -void -Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) +MAGIC * +Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, + const char* name, I32 namlen) { MAGIC* mg; - if (SvREADONLY(sv)) { - if (PL_curcop != &PL_compiling - && 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 == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) { - if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { - if (how == PERL_MAGIC_taint) - mg->mg_len |= 1; - return; - } - } - else { - (void)SvUPGRADE(sv, SVt_PVMG); + if (SvTYPE(sv) < SVt_PVMG) { + (void)SvUPGRADE(sv, SVt_PVMG); } Newz(702,mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); SvMAGIC(sv) = mg; - /* Some magic contains a reference loop, where the sv and object refer to - each other. To 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. */ + /* Some magic sontains a reference loop, where the sv and object refer to + each other. To prevent 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 == PERL_MAGIC_arylen || how == PERL_MAGIC_qr || @@ -4464,129 +4508,182 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam mg->mg_type = how; mg->mg_len = namlen; if (name) { - if (namlen >= 0) + if (namlen > 0) mg->mg_ptr = savepvn(name, namlen); else if (namlen == HEf_SVKEY) mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name); + else + mg->mg_ptr = (char *) name; + } + mg->mg_virtual = vtable; + + mg_magical(sv); + if (SvGMAGICAL(sv)) + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); + return mg; +} + +/* +=for apidoc sv_magic + +Adds magic to an SV. First upgrades C to type C if necessary, +then adds a new magic item of type C to the head of the magic list. + +=cut +*/ + +void +Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) +{ + MAGIC* mg; + MGVTBL *vtable = 0; + + if (SvREADONLY(sv)) { + if (PL_curcop != &PL_compiling + && 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 == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) { + if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { + /* sv_magic() refuses to add a magic of the same 'how' as an + existing one + */ + if (how == PERL_MAGIC_taint) + mg->mg_len |= 1; + return; + } } switch (how) { case PERL_MAGIC_sv: - mg->mg_virtual = &PL_vtbl_sv; + vtable = &PL_vtbl_sv; break; case PERL_MAGIC_overload: - mg->mg_virtual = &PL_vtbl_amagic; + vtable = &PL_vtbl_amagic; break; case PERL_MAGIC_overload_elem: - mg->mg_virtual = &PL_vtbl_amagicelem; + vtable = &PL_vtbl_amagicelem; break; case PERL_MAGIC_overload_table: - mg->mg_virtual = &PL_vtbl_ovrld; + vtable = &PL_vtbl_ovrld; break; case PERL_MAGIC_bm: - mg->mg_virtual = &PL_vtbl_bm; + vtable = &PL_vtbl_bm; break; case PERL_MAGIC_regdata: - mg->mg_virtual = &PL_vtbl_regdata; + vtable = &PL_vtbl_regdata; break; case PERL_MAGIC_regdatum: - mg->mg_virtual = &PL_vtbl_regdatum; + vtable = &PL_vtbl_regdatum; break; case PERL_MAGIC_env: - mg->mg_virtual = &PL_vtbl_env; + vtable = &PL_vtbl_env; break; case PERL_MAGIC_fm: - mg->mg_virtual = &PL_vtbl_fm; + vtable = &PL_vtbl_fm; break; case PERL_MAGIC_envelem: - mg->mg_virtual = &PL_vtbl_envelem; + vtable = &PL_vtbl_envelem; break; case PERL_MAGIC_regex_global: - mg->mg_virtual = &PL_vtbl_mglob; + vtable = &PL_vtbl_mglob; break; case PERL_MAGIC_isa: - mg->mg_virtual = &PL_vtbl_isa; + vtable = &PL_vtbl_isa; break; case PERL_MAGIC_isaelem: - mg->mg_virtual = &PL_vtbl_isaelem; + vtable = &PL_vtbl_isaelem; break; case PERL_MAGIC_nkeys: - mg->mg_virtual = &PL_vtbl_nkeys; + vtable = &PL_vtbl_nkeys; break; case PERL_MAGIC_dbfile: - SvRMAGICAL_on(sv); - mg->mg_virtual = 0; + vtable = 0; break; case PERL_MAGIC_dbline: - mg->mg_virtual = &PL_vtbl_dbline; + vtable = &PL_vtbl_dbline; break; #ifdef USE_5005THREADS case PERL_MAGIC_mutex: - mg->mg_virtual = &PL_vtbl_mutex; + vtable = &PL_vtbl_mutex; break; #endif /* USE_5005THREADS */ #ifdef USE_LOCALE_COLLATE case PERL_MAGIC_collxfrm: - mg->mg_virtual = &PL_vtbl_collxfrm; + vtable = &PL_vtbl_collxfrm; break; #endif /* USE_LOCALE_COLLATE */ case PERL_MAGIC_tied: - mg->mg_virtual = &PL_vtbl_pack; + vtable = &PL_vtbl_pack; break; case PERL_MAGIC_tiedelem: case PERL_MAGIC_tiedscalar: - mg->mg_virtual = &PL_vtbl_packelem; + vtable = &PL_vtbl_packelem; break; case PERL_MAGIC_qr: - mg->mg_virtual = &PL_vtbl_regexp; + vtable = &PL_vtbl_regexp; break; case PERL_MAGIC_sig: - mg->mg_virtual = &PL_vtbl_sig; + vtable = &PL_vtbl_sig; break; case PERL_MAGIC_sigelem: - mg->mg_virtual = &PL_vtbl_sigelem; + vtable = &PL_vtbl_sigelem; break; case PERL_MAGIC_taint: - mg->mg_virtual = &PL_vtbl_taint; - mg->mg_len = 1; + vtable = &PL_vtbl_taint; break; case PERL_MAGIC_uvar: - mg->mg_virtual = &PL_vtbl_uvar; + vtable = &PL_vtbl_uvar; break; case PERL_MAGIC_vec: - mg->mg_virtual = &PL_vtbl_vec; + vtable = &PL_vtbl_vec; break; case PERL_MAGIC_substr: - mg->mg_virtual = &PL_vtbl_substr; + vtable = &PL_vtbl_substr; break; case PERL_MAGIC_defelem: - mg->mg_virtual = &PL_vtbl_defelem; + vtable = &PL_vtbl_defelem; break; case PERL_MAGIC_glob: - mg->mg_virtual = &PL_vtbl_glob; + vtable = &PL_vtbl_glob; break; case PERL_MAGIC_arylen: - mg->mg_virtual = &PL_vtbl_arylen; + vtable = &PL_vtbl_arylen; break; case PERL_MAGIC_pos: - mg->mg_virtual = &PL_vtbl_pos; + vtable = &PL_vtbl_pos; break; case PERL_MAGIC_backref: - mg->mg_virtual = &PL_vtbl_backref; + vtable = &PL_vtbl_backref; break; 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 \\%o", how); } - mg_magical(sv); - if (SvGMAGICAL(sv)) - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); + + /* Rest of work is done else where */ + mg = sv_magicext(sv,obj,how,vtable,name,namlen); + + switch (how) { + case PERL_MAGIC_taint: + mg->mg_len = 1; + break; + case PERL_MAGIC_ext: + case PERL_MAGIC_dbfile: + SvRMAGICAL_on(sv); + break; + } } /* @@ -4612,7 +4709,7 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) if (vtbl && vtbl->svt_free) CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { - if (mg->mg_len >= 0) + if (mg->mg_len > 0) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) SvREFCNT_dec((SV*)mg->mg_ptr); @@ -4653,7 +4750,7 @@ Perl_sv_rvweaken(pTHX_ SV *sv) Perl_croak(aTHX_ "Can't weaken a nonreference"); else if (SvWEAKREF(sv)) { if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ WARN_MISC, "Reference is already weak"); + Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak"); return sv; } tsv = SvRV(sv); @@ -4693,7 +4790,7 @@ S_sv_del_backref(pTHX_ SV *sv) SV **svp; I32 i; SV *tsv = SvRV(sv); - MAGIC *mg; + MAGIC *mg = NULL; if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref))) Perl_croak(aTHX_ "panic: del_backref"); av = (AV *)mg->mg_obj; @@ -4820,7 +4917,7 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) U32 refcnt = SvREFCNT(sv); SV_CHECK_THINKFIRST(sv); if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()"); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()"); if (SvMAGICAL(sv)) { if (SvMAGICAL(nsv)) mg_free(nsv); @@ -5095,7 +5192,7 @@ Perl_sv_free(pTHX_ SV *sv) return; } if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar"); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar"); return; } ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv)); @@ -5104,7 +5201,7 @@ Perl_sv_free(pTHX_ SV *sv) #ifdef DEBUGGING if (SvTEMP(sv)) { if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ WARN_DEBUGGING, + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to free temp prematurely: SV 0x%"UVxf, PTR2UV(sv)); return; @@ -5272,6 +5369,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) STRLEN cur2; I32 eq = 0; char *tpv = Nullch; + SV* svrecode = Nullsv; if (!sv1) { pv1 = ""; @@ -5287,33 +5385,57 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) else pv2 = SvPV(sv2, cur2); - /* do not utf8ize the comparands as a side-effect */ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { - bool is_utf8 = TRUE; - /* UTF-8ness differs */ - - 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 (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 (pv != pv2) - pv2 = tpv = pv; - } - if (is_utf8) { - /* Downgrade not possible - cannot be eq */ - return FALSE; - } + /* Differing utf8ness. + * Do not UTF8size the comparands as a side-effect. */ + if (PL_encoding) { + if (SvUTF8(sv1)) { + svrecode = newSVpvn(pv2, cur2); + sv_recode_to_utf8(svrecode, PL_encoding); + pv2 = SvPV(svrecode, cur2); + } + else { + svrecode = newSVpvn(pv1, cur1); + sv_recode_to_utf8(svrecode, PL_encoding); + pv1 = SvPV(svrecode, cur1); + } + /* Now both are in UTF-8. */ + if (cur1 != cur2) + return FALSE; + } + else { + bool is_utf8 = TRUE; + + 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 (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 (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 (tpv != Nullch) + if (svrecode) + SvREFCNT_dec(svrecode); + + if (tpv) Safefree(tpv); return eq; @@ -5334,10 +5456,9 @@ I32 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) { STRLEN cur1, cur2; - char *pv1, *pv2; + char *pv1, *pv2, *tpv = Nullch; I32 cmp; - bool pv1tmp = FALSE; - bool pv2tmp = FALSE; + SV *svrecode = Nullsv; if (!sv1) { pv1 = ""; @@ -5346,22 +5467,35 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) else pv1 = SvPV(sv1, cur1); - if (!sv2){ + if (!sv2) { pv2 = ""; cur2 = 0; } else pv2 = SvPV(sv2, cur2); - /* do not utf8ize the comparands as a side-effect */ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { + /* Differing utf8ness. + * Do not UTF8size the comparands as a side-effect. */ if (SvUTF8(sv1)) { - pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2); - pv2tmp = TRUE; + if (PL_encoding) { + svrecode = newSVpvn(pv2, cur2); + sv_recode_to_utf8(svrecode, PL_encoding); + pv2 = SvPV(svrecode, cur2); + } + else { + pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2); + } } else { - pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1); - pv1tmp = TRUE; + if (PL_encoding) { + svrecode = newSVpvn(pv1, cur1); + sv_recode_to_utf8(svrecode, PL_encoding); + pv1 = SvPV(svrecode, cur1); + } + else { + pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1); + } } } @@ -5381,10 +5515,11 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) } } - if (pv1tmp) - Safefree(pv1); - if (pv2tmp) - Safefree(pv2); + if (svrecode) + SvREFCNT_dec(svrecode); + + if (tpv) + Safefree(tpv); return cmp; } @@ -5654,7 +5789,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", + "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); for (;;) { @@ -5688,19 +5823,23 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n", PTR2UV(ptr),(long)cnt)); - PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */ + PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */ +#if 0 DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); +#endif /* This used to call 'filbuf' in stdio form, but as that behaves like getc when cnt <= 0 we use PerlIO_getc here to avoid introducing another abstraction. */ i = PerlIO_getc(fp); /* get more characters */ +#if 0 DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); +#endif cnt = PerlIO_get_cnt(fp); ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ DEBUG_P(PerlIO_printf(Perl_debug_log, @@ -5729,7 +5868,7 @@ thats_really_all_folks: cnt += shortbuffered; DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); - PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */ + PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */ DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), @@ -5834,6 +5973,8 @@ Perl_sv_inc(pTHX_ register SV *sv) if (SvGMAGICAL(sv)) mg_get(sv); if (SvTHINKFIRST(sv)) { + if (SvREADONLY(sv) && SvFAKE(sv)) + sv_force_normal(sv); if (SvREADONLY(sv)) { if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); @@ -5861,7 +6002,7 @@ Perl_sv_inc(pTHX_ register SV *sv) #endif if (SvIsUV(sv)) { if (SvUVX(sv) == UV_MAX) - sv_setnv(sv, (NV)UV_MAX + 1.0); + sv_setnv(sv, UV_MAX_P1); else (void)SvIOK_only_UV(sv); ++SvUVX(sv); @@ -5893,7 +6034,7 @@ Perl_sv_inc(pTHX_ register SV *sv) while (isDIGIT(*d)) d++; if (*d) { #ifdef PERL_PRESERVE_IVUV - /* Got to punt this an an integer if needs be, but we don't issue + /* Got to punt this as an integer if needs be, but we don't issue warnings. Probably ought to make the sv_iv_please() that does the conversion if possible, and silently. */ int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL); @@ -5922,7 +6063,7 @@ Perl_sv_inc(pTHX_ register SV *sv) DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv))); #else - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n", + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv))); #endif } @@ -5988,6 +6129,8 @@ Perl_sv_dec(pTHX_ register SV *sv) if (SvGMAGICAL(sv)) mg_get(sv); if (SvTHINKFIRST(sv)) { + if (SvREADONLY(sv) && SvFAKE(sv)) + sv_force_normal(sv); if (SvREADONLY(sv)) { if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); @@ -6068,7 +6211,7 @@ Perl_sv_dec(pTHX_ register SV *sv) DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv))); #else - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n", + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv))); #endif } @@ -6396,7 +6539,7 @@ Perl_newSVsv(pTHX_ register SV *old) return Nullsv; if (SvTYPE(old) == SVTYPEMASK) { if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string"); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); return Nullsv; } new_SV(sv); @@ -6547,8 +6690,8 @@ possible to set C<*st> and C<*gvp> to the stash and GV associated with it. CV * Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) { - GV *gv; - CV *cv; + GV *gv = Nullgv; + CV *cv = Nullcv; STRLEN n_a; if (!sv) @@ -6712,12 +6855,16 @@ Perl_sv_nv(pTHX_ register SV *sv) /* =for apidoc sv_pv -A private implementation of the C macro for compilers which can't -cope with complex macro expressions. Always use the macro instead. +Use the C macro instead =cut */ +/* sv_pv() is now a macro using SvPV_nolen(); + * this function provided for binary compatibility only + */ + + char * Perl_sv_pv(pTHX_ SV *sv) { @@ -6748,8 +6895,6 @@ Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) return sv_2pv(sv, lp); } -/* For -DCRIPPLED_CC only. See also C. - */ char * Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp) @@ -6771,6 +6916,10 @@ can't cope with complex macro expressions. Always use the macro instead. =cut */ +/* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags(); + * this function provided for binary compatibility only + */ + char * Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) { @@ -6793,7 +6942,7 @@ C and C char * Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) { - char *s; + char *s = NULL; if (SvTHINKFIRST(sv) && !SvROK(sv)) sv_force_normal(sv); @@ -6832,13 +6981,16 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) /* =for apidoc sv_pvbyte -A private implementation of the C macro for compilers -which can't cope with complex macro expressions. Always use the macro -instead. +Use C instead. =cut */ +/* sv_pvbyte () is now a macro using Perl_sv_2pv_flags(); + * this function provided for binary compatibility only + */ + + char * Perl_sv_pvbyte(pTHX_ SV *sv) { @@ -6883,12 +7035,14 @@ Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) /* =for apidoc sv_pvutf8 -A private implementation of the C macro for compilers -which can't cope with complex macro expressions. Always use the macro -instead. +Use the C macro instead =cut */ +/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags(); + * this function provided for binary compatibility only + */ + char * Perl_sv_pvutf8(pTHX_ SV *sv) @@ -6942,8 +7096,12 @@ Returns a string describing what the SV is a reference to. char * Perl_sv_reftype(pTHX_ SV *sv, int ob) { - if (ob && SvOBJECT(sv)) - return HvNAME(SvSTASH(sv)); + if (ob && SvOBJECT(sv)) { + HV *svs = SvSTASH(sv); + /* [20011101.072] This bandaid for C should eventually + be removed. AMS 20011103 */ + return (svs ? HvNAME(svs) : ""); + } else { switch (SvTYPE(sv)) { case SVt_NULL: @@ -7223,7 +7381,7 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) mg_set(tmpRef); - + return sv; } @@ -7629,6 +7787,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV I32 svix = 0; static char nullstr[] = "(null)"; SV *argsv = Nullsv; + bool has_utf8 = FALSE; /* has the result utf8? */ /* no matter what, this is a string now */ (void)SvPV_force(sv, origlen); @@ -7662,13 +7821,16 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } + if (!args && svix < svmax && DO_UTF8(*svargs)) + has_utf8 = TRUE; + patend = (char*)pat + patlen; for (p = (char*)pat; p < patend; p = q) { bool alt = FALSE; bool left = FALSE; bool vectorize = FALSE; bool vectorarg = FALSE; - bool vec_utf = FALSE; + bool vec_utf8 = FALSE; char fill = ' '; char plus = 0; char intsize = 0; @@ -7676,7 +7838,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STRLEN zeros = 0; bool has_precis = FALSE; STRLEN precis = 0; - bool is_utf = FALSE; + bool is_utf8 = FALSE; /* is this item utf8? */ char esignbuf[4]; U8 utf8buf[UTF8_MAXLEN+1]; @@ -7694,7 +7856,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV SV *vecsv; U8 *vecstr = Null(U8*); STRLEN veclen = 0; - char c; + char c = 0; int i; unsigned base = 0; IV iv = 0; @@ -7801,17 +7963,17 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef; dotstr = SvPVx(vecsv, dotstrlen); if (DO_UTF8(vecsv)) - is_utf = TRUE; + is_utf8 = TRUE; } if (args) { vecsv = va_arg(*args, SV*); vecstr = (U8*)SvPVx(vecsv,veclen); - vec_utf = DO_UTF8(vecsv); + vec_utf8 = DO_UTF8(vecsv); } else if (efix ? efix <= svmax : svix < svmax) { vecsv = svargs[efix ? efix-1 : svix++]; vecstr = (U8*)SvPVx(vecsv,veclen); - vec_utf = DO_UTF8(vecsv); + vec_utf8 = DO_UTF8(vecsv); } else { vecstr = (U8*)""; @@ -7905,7 +8067,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV && !IN_BYTES) { eptr = (char*)utf8buf; elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf; - is_utf = TRUE; + is_utf8 = TRUE; } else { c = (char)uv; @@ -7941,7 +8103,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (width) { /* fudge width (can't fudge elen) */ width += elen - sv_len_utf8(argsv); } - is_utf = TRUE; + is_utf8 = TRUE; } } goto string; @@ -7957,7 +8119,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV argsv = va_arg(*args, SV*); eptr = SvPVx(argsv, elen); if (DO_UTF8(argsv)) - is_utf = TRUE; + is_utf8 = TRUE; string: vectorize = FALSE; @@ -7987,8 +8149,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STRLEN ulen; if (!veclen) continue; - if (vec_utf) - uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV); + if (vec_utf8) + uv = utf8n_to_uvchr(vecstr, veclen, &ulen, + UTF8_ALLOW_ANYUV); else { uv = *vecstr; ulen = 1; @@ -8072,8 +8235,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV vector: if (!veclen) continue; - if (vec_utf) - uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV); + if (vec_utf8) + uv = utf8n_to_uvchr(vecstr, veclen, &ulen, + UTF8_ALLOW_ANYUV); else { uv = *vecstr; ulen = 1; @@ -8149,7 +8313,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (n >= 2 && s[n-2] == '1' && s[n-1] == '9' && (n == 2 || !isDIGIT(s[n-3]))) { - Perl_warner(aTHX_ WARN_Y2K, + Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %%%c %s", c, "format string following '19'"); } @@ -8286,7 +8450,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV (UV)c & 0xFF); } else sv_catpv(msg, "end of string"); - Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */ + Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ @@ -8305,6 +8469,22 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV continue; /* not "break" */ } + if (is_utf8 != has_utf8) { + if (is_utf8) { + if (SvCUR(sv)) + sv_utf8_upgrade(sv); + } + else { + SV *nsv = sv_2mortal(newSVpvn(eptr, elen)); + sv_utf8_upgrade(nsv); + eptr = SvPVX(nsv); + elen = SvCUR(nsv); + } + SvGROW(sv, SvCUR(sv) + elen + 1); + p = SvEND(sv); + *p = '\0'; + } + have = esignlen + zeros + elen; need = (have > width ? have : width); gap = need - have; @@ -8343,7 +8523,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV else vectorize = FALSE; /* done iterating over vecstr */ } - if (is_utf) + if (is_utf8) + has_utf8 = TRUE; + if (has_utf8) SvUTF8_on(sv); *p = '\0'; SvCUR(sv) = p - SvPVX(sv); @@ -8429,6 +8611,7 @@ Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) s->min_offset = r->substrs->data[i].min_offset; s->max_offset = r->substrs->data[i].max_offset; s->substr = sv_dup_inc(r->substrs->data[i].substr, param); + s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param); } ret->regstclass = NULL; @@ -8511,7 +8694,7 @@ Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param) return ret; /* create anew and remember what it is */ - ret = PerlIO_fdupopen(aTHX_ fp, param); + ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE); ptr_table_store(PL_ptr_table, fp, ret); return ret; } @@ -8608,7 +8791,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) nmg->mg_len = mg->mg_len; nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */ if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { - if (mg->mg_len >= 0) { + if (mg->mg_len > 0) { nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len); if (mg->mg_type == PERL_MAGIC_overload_table && AMT_AMAGIC((AMT*)mg->mg_ptr)) @@ -8624,6 +8807,9 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) else if (mg->mg_len == HEf_SVKEY) nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param); } + if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) { + CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param); + } mgprev = nmg; } return mgret; @@ -8833,6 +9019,40 @@ S_gv_share(pTHX_ SV *sstr) /* duplicate an SV of any type (including AV, HV etc) */ +void +Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) +{ + if (SvROK(sstr)) { + SvRV(dstr) = SvWEAKREF(sstr) + ? sv_dup(SvRV(sstr), param) + : sv_dup_inc(SvRV(sstr), param); + } + else if (SvPVX(sstr)) { + /* Has something there */ + if (SvLEN(sstr)) { + /* Normal PV - clone whole allocated space */ + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); + } + else { + /* Special case - not normally malloced for some reason */ + if (SvREADONLY(sstr) && SvFAKE(sstr)) { + /* A "shared" PV - clone it as unshared string */ + SvFAKE_off(dstr); + SvREADONLY_off(dstr); + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + } + else { + /* Some other special case - random pointer */ + SvPVX(dstr) = SvPVX(sstr); + } + } + } + else { + /* Copy the Null */ + SvPVX(dstr) = SvPVX(sstr); + } +} + SV * Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) { @@ -8874,36 +9094,20 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) break; case SVt_RV: SvANY(dstr) = new_XRV(); - SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr) - ? sv_dup(SvRV(sstr), param) - : sv_dup_inc(SvRV(sstr), param); + Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; case SVt_PV: SvANY(dstr) = new_XPV(); SvCUR(dstr) = SvCUR(sstr); SvLEN(dstr) = SvLEN(sstr); - if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(sstr) - ? sv_dup(SvRV(sstr), param) - : sv_dup_inc(SvRV(sstr), param); - else if (SvPVX(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); - else - SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; case SVt_PVIV: SvANY(dstr) = new_XPVIV(); SvCUR(dstr) = SvCUR(sstr); SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); - if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(sstr) - ? sv_dup(SvRV(sstr), param) - : sv_dup_inc(SvRV(sstr), param); - else if (SvPVX(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); - else - SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; case SVt_PVNV: SvANY(dstr) = new_XPVNV(); @@ -8911,14 +9115,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); - if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(sstr) - ? sv_dup(SvRV(sstr), param) - : sv_dup_inc(SvRV(sstr), param); - else if (SvPVX(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); - else - SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; case SVt_PVMG: SvANY(dstr) = new_XPVMG(); @@ -8928,14 +9125,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvNVX(dstr) = SvNVX(sstr); SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); - if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(sstr) - ? sv_dup(SvRV(sstr), param) - : sv_dup_inc(SvRV(sstr), param); - else if (SvPVX(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); - else - SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + Perl_rvpv_dup(aTHX_ dstr, sstr, param); break; case SVt_PVBM: SvANY(dstr) = new_XPVBM(); @@ -8945,14 +9135,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvNVX(dstr) = SvNVX(sstr); SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); - if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(sstr) - ? sv_dup(SvRV(sstr), param) - : sv_dup_inc(SvRV(sstr), param); - else if (SvPVX(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); - else - SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + Perl_rvpv_dup(aTHX_ dstr, sstr, param); BmRARE(dstr) = BmRARE(sstr); BmUSEFUL(dstr) = BmUSEFUL(sstr); BmPREVIOUS(dstr)= BmPREVIOUS(sstr); @@ -8965,14 +9148,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvNVX(dstr) = SvNVX(sstr); SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); - if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(sstr) - ? sv_dup(SvRV(sstr), param) - : sv_dup_inc(SvRV(sstr), param); - else if (SvPVX(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); - else - SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + Perl_rvpv_dup(aTHX_ dstr, sstr, param); LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */ LvTARGLEN(dstr) = LvTARGLEN(sstr); LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param); @@ -8998,14 +9174,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvNVX(dstr) = SvNVX(sstr); SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); - if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(sstr) - ? sv_dup(SvRV(sstr), param) - : sv_dup_inc(SvRV(sstr), param); - else if (SvPVX(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); - else - SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + Perl_rvpv_dup(aTHX_ dstr, sstr, param); GvNAMELEN(dstr) = GvNAMELEN(sstr); GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr)); GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param); @@ -9021,14 +9190,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvNVX(dstr) = SvNVX(sstr); SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); - if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(sstr) - ? sv_dup(SvRV(sstr), param) - : sv_dup_inc(SvRV(sstr), param); - else if (SvPVX(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); - else - SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + Perl_rvpv_dup(aTHX_ dstr, sstr, param); IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param); if (IoOFP(sstr) == IoIFP(sstr)) IoOFP(dstr) = IoIFP(dstr); @@ -9136,10 +9298,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SvNVX(dstr) = SvNVX(sstr); SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); - if (SvPVX(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); - else - SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ + Perl_rvpv_dup(aTHX_ dstr, sstr, param); CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */ CvSTART(dstr) = CvSTART(sstr); CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr)); @@ -9340,8 +9499,9 @@ Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl) /* see if it is part of the interpreter structure */ if (v >= (void*)proto_perl && v < (void*)(proto_perl+1)) ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl)); - else + else { ret = v; + } return ret; } @@ -9394,6 +9554,12 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); break; + case SAVEt_SHARED_PVREF: /* char* in shared space */ + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = savesharedpv(c); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; case SAVEt_GENERIC_SVREF: /* generic sv */ case SAVEt_SVREF: /* scalar reference */ sv = (SV*)POPPTR(ss,ix); @@ -9644,7 +9810,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, * their pointers copied. */ IV i; - CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS)); + CLONE_PARAMS clone_params; + CLONE_PARAMS* param = &clone_params; PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); PERL_SET_THX(my_perl); @@ -9656,6 +9823,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_savestack = 0; PL_retstack = 0; PL_sig_pending = 0; + Zero(&PL_debug_pad, 1, struct perl_debug_pad); # else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); # endif /* DEBUGGING */ @@ -9672,7 +9840,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_Proc = ipP; #else /* !PERL_IMPLICIT_SYS */ IV i; - CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS)); + CLONE_PARAMS clone_params; + CLONE_PARAMS* param = &clone_params; PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); PERL_SET_THX(my_perl); @@ -9685,6 +9854,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_savestack = 0; PL_retstack = 0; PL_sig_pending = 0; + Zero(&PL_debug_pad, 1, struct perl_debug_pad); # else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); # endif /* DEBUGGING */ @@ -9728,8 +9898,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_debug = proto_perl->Idebug; #ifdef USE_REENTRANT_API - New(31337, PL_reentrant_buffer,1, REBUF); - New(31337, PL_reentrant_buffer->tmbuff,1, struct tm); + Perl_reentrant_init(aTHX); #endif /* create SV map for pointer relocation */ @@ -9759,15 +9928,21 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvNVX(&PL_sv_yes) = 1; ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); - /* create shared string table */ + /* create (a non-shared!) shared string table */ PL_strtab = newHV(); HvSHAREKEYS_off(PL_strtab); hv_ksplit(PL_strtab, 512); ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab); - PL_compiling = proto_perl->Icompiling; - PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv); - PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file); + PL_compiling = proto_perl->Icompiling; + + /* These two PVs will be free'd special way so must set them same way op.c does */ + PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv); + ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv); + + PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file); + ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file); + ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); if (!specialWARN(PL_compiling.cop_warnings)) PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param); @@ -9833,6 +10008,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif PL_encoding = sv_dup(proto_perl->Iencoding, param); + sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */ + sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */ + sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */ + /* Clone the regex array */ PL_regex_padav = newAV(); { @@ -10096,6 +10275,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param); PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param); PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param); + PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param); /* swatch cache */ PL_last_swash_hv = Nullhv; /* reinits on demand */ @@ -10352,7 +10532,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } SvREFCNT_dec(param->stashes); - Safefree(param); return my_perl; } @@ -10360,6 +10539,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif /* USE_ITHREADS */ /* +=head1 Unicode Support + =for apidoc sv_recode_to_utf8 The encoding is assumed to be an Encode object, on entry the PV @@ -10368,7 +10549,8 @@ will be converted into Unicode (and UTF-8). If the sv already is UTF-8 (or if it is not POK), or if the encoding is not a reference, nothing is done to the sv. If the encoding is not -Encode object, bad things happen. +an C Encoding object, bad things will happen. +(See F and L). The PV of the sv is returned. @@ -10377,7 +10559,7 @@ The PV of the sv is returned. char * Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) { - if (SvPOK(sv) && !SvUTF8(sv) && SvROK(encoding)) { + if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) { SV *uni; STRLEN len; char *s; @@ -10394,7 +10576,7 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) SPAGAIN; uni = POPs; PUTBACK; - s = SvPVutf8(uni, len); + s = SvPV(uni, len); if (s != SvPVX(sv)) { SvGROW(sv, len); Move(s, SvPVX(sv), len, char); @@ -10407,3 +10589,4 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) return SvPVX(sv); } +