X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ee1c5a4ed6beace0f9f941f22f8068cde74910fe..3351db0262a00327940d490d1d2727273740be19:/sv.c diff --git a/sv.c b/sv.c index 48d5422..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. @@ -123,7 +123,7 @@ Private API to rest of sv.c Public API: - sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas() + sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas() =cut @@ -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); @@ -1756,61 +1769,70 @@ Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) STATIC void S_not_a_number(pTHX_ SV *sv) { - char tmpbuf[64]; - char *d = tmpbuf; - 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; - if (ch & 128 && !isPRINT_LC(ch)) { - *d++ = 'M'; - *d++ = '-'; - ch &= 127; - } - if (ch == '\n') { - *d++ = '\\'; - *d++ = 'n'; - } - else if (ch == '\r') { - *d++ = '\\'; - *d++ = 'r'; - } - else if (ch == '\f') { - *d++ = '\\'; - *d++ = 'f'; - } - else if (ch == '\\') { - *d++ = '\\'; - *d++ = '\\'; - } - else if (ch == '\0') { - *d++ = '\\'; - *d++ = '0'; - } - else if (isPRINT_LC(ch)) - *d++ = ch; - else { - *d++ = '^'; - *d++ = toCTRL(ch); - } - } - if (s < end) { - *d++ = '.'; - *d++ = '.'; - *d++ = '.'; + SV *dsv; + char tmpbuf[64]; + char *pv; + + if (DO_UTF8(sv)) { + dsv = sv_2mortal(newSVpv("", 0)); + pv = sv_uni_display(dsv, sv, 10, 0); + } else { + char *d = tmpbuf; + 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; + if (ch & 128 && !isPRINT_LC(ch)) { + *d++ = 'M'; + *d++ = '-'; + ch &= 127; + } + if (ch == '\n') { + *d++ = '\\'; + *d++ = 'n'; + } + else if (ch == '\r') { + *d++ = '\\'; + *d++ = 'r'; + } + else if (ch == '\f') { + *d++ = '\\'; + *d++ = 'f'; + } + else if (ch == '\\') { + *d++ = '\\'; + *d++ = '\\'; + } + else if (ch == '\0') { + *d++ = '\\'; + *d++ = '0'; + } + else if (isPRINT_LC(ch)) + *d++ = ch; + else { + *d++ = '^'; + *d++ = toCTRL(ch); + } + } + if (s < end) { + *d++ = '.'; + *d++ = '.'; + *d++ = '.'; + } + *d = '\0'; + pv = tmpbuf; } - *d = '\0'; if (PL_op) - Perl_warner(aTHX_ WARN_NUMERIC, - "Argument \"%s\" isn't numeric in %s", tmpbuf, - OP_DESC(PL_op)); + Perl_warner(aTHX_ packWARN(WARN_NUMERIC), + "Argument \"%s\" isn't numeric in %s", pv, + OP_DESC(PL_op)); else - Perl_warner(aTHX_ WARN_NUMERIC, - "Argument \"%s\" isn't numeric", tmpbuf); + Perl_warner(aTHX_ packWARN(WARN_NUMERIC), + "Argument \"%s\" isn't numeric", pv); } /* @@ -1927,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); @@ -2154,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); @@ -2181,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 @@ -2237,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 @@ -2445,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); @@ -2469,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 @@ -2524,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); @@ -2620,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(); }); @@ -2749,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(); }); @@ -2853,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 * @@ -2995,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)); @@ -3122,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. @@ -3198,7 +3266,7 @@ Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) =for apidoc sv_2bool This function is only called on magical items, and is only used by -sv_true() or its macro equivalent. +sv_true() or its macro equivalent. =cut */ @@ -3214,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; } @@ -3248,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) { @@ -3267,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 */ @@ -3293,30 +3372,34 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) 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 = (U8 *) SvPVX(sv); - e = (U8 *) SvEND(sv); - t = s; - while (t < e) { - U8 ch = *t++; - if ((hibit = !NATIVE_IS_INVARIANT(ch))) - break; - } - if (hibit) { - STRLEN len; - - len = SvCUR(sv) + 1; /* Plus the \0 */ - SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len); - SvCUR(sv) = len - 1; - if (SvLEN(sv) != 0) - Safefree(s); /* No longer using what was there before. */ - SvLEN(sv) = len; /* No longer know the real size. */ + if (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 + * chars in the PV. Given that there isn't such a flag + * make the loop as fast as possible. */ + s = (U8 *) SvPVX(sv); + e = (U8 *) SvEND(sv); + t = s; + while (t < e) { + U8 ch = *t++; + if ((hibit = !NATIVE_IS_INVARIANT(ch))) + break; + } + if (hibit) { + STRLEN len; + + len = SvCUR(sv) + 1; /* Plus the \0 */ + SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len); + SvCUR(sv) = len - 1; + if (SvLEN(sv) != 0) + Safefree(s); /* No longer using what was there before. */ + SvLEN(sv) = len; /* No longer know the real size. */ + } + /* Mark as UTF-8 even if no hibit - saves scanning loop */ + SvUTF8_on(sv); } - /* Mark as UTF-8 even if no hibit - saves scanning loop */ - SvUTF8_on(sv); return SvCUR(sv); } @@ -3328,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 */ @@ -3345,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", @@ -3457,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) { @@ -3737,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. */ @@ -3860,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); @@ -3916,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); @@ -4188,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) { @@ -4251,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) { @@ -4278,8 +4345,15 @@ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) if (!ssv) return; if ((spv = SvPV(ssv, slen))) { - bool sutf8 = DO_UTF8(ssv); - bool dutf8; + /* sutf8 and dutf8 were type bool, but under USE_ITHREADS, + gcc version 2.95.2 20000220 (Debian GNU/Linux) for + Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously + get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though + dsv->sv_flags doesn't have that bit set. + Andy Dougherty 12 Oct 2001 + */ + I32 sutf8 = DO_UTF8(ssv); + I32 dutf8; if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC)) mg_get(dsv); @@ -4381,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 || @@ -4444,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; + } } /* @@ -4592,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); @@ -4633,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); @@ -4673,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; @@ -4800,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); @@ -5075,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)); @@ -5084,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; @@ -5252,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 = ""; @@ -5267,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; @@ -5314,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 = ""; @@ -5326,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); + } } } @@ -5361,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; } @@ -5634,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 (;;) { @@ -5668,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, @@ -5709,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), @@ -5814,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); @@ -5841,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); @@ -5873,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); @@ -5902,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 } @@ -5968,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); @@ -6048,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 } @@ -6376,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); @@ -6527,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) @@ -6692,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) { @@ -6728,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) @@ -6751,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) { @@ -6773,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); @@ -6812,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) { @@ -6863,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) @@ -6922,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: @@ -7198,6 +7376,12 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) else SvAMAGIC_off(sv); + if(SvSMAGICAL(tmpRef)) + if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar)) + mg_set(tmpRef); + + + return sv; } @@ -7603,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); @@ -7636,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; @@ -7650,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]; @@ -7668,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; @@ -7775,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*)""; @@ -7879,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; @@ -7915,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; @@ -7931,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; @@ -7961,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; @@ -8046,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; @@ -8123,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'"); } @@ -8260,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 ... */ @@ -8279,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; @@ -8317,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); @@ -8369,13 +8577,13 @@ ptr_table_* functions. #define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t)) #define SAVEPV(p) (p ? savepv(p) : Nullch) #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch) - + /* Duplicate a regexp. Required reading: pregcomp() and pregfree() in regcomp.c. AMS 20010712 */ REGEXP * -Perl_re_dup(pTHX_ REGEXP *r, clone_params *param) +Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) { REGEXP *ret; int i, len, npar; @@ -8403,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; @@ -8473,7 +8682,7 @@ Perl_re_dup(pTHX_ REGEXP *r, clone_params *param) /* duplicate a file handle */ PerlIO * -Perl_fp_dup(pTHX_ PerlIO *fp, char type) +Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param) { PerlIO *ret; if (!fp) @@ -8485,7 +8694,7 @@ Perl_fp_dup(pTHX_ PerlIO *fp, char type) return ret; /* create anew and remember what it is */ - ret = PerlIO_fdupopen(aTHX_ fp); + ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE); ptr_table_store(PL_ptr_table, fp, ret); return ret; } @@ -8504,7 +8713,7 @@ Perl_dirp_dup(pTHX_ DIR *dp) /* duplicate a typeglob */ GP * -Perl_gp_dup(pTHX_ GP *gp, clone_params* param) +Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param) { GP *ret; if (!gp) @@ -8537,7 +8746,7 @@ Perl_gp_dup(pTHX_ GP *gp, clone_params* param) /* duplicate a chain of magic */ MAGIC * -Perl_mg_dup(pTHX_ MAGIC *mg, clone_params* param) +Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) { MAGIC *mgprev = (MAGIC*)NULL; MAGIC *mgret; @@ -8582,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)) @@ -8598,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; @@ -8807,8 +9019,42 @@ 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) +Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) { SV *dstr; @@ -8848,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(); @@ -8885,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(); @@ -8902,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(); @@ -8919,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); @@ -8939,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); @@ -8972,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); @@ -8995,19 +9190,12 @@ 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? */ - IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr)); + 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); else - IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr)); + IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param); /* PL_rsfp_filters entries have fake IoDIRP() */ if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP)) IoDIRP(dstr) = dirp_dup(IoDIRP(sstr)); @@ -9110,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)); @@ -9160,7 +9345,7 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) /* duplicate a context */ PERL_CONTEXT * -Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, clone_params* param) +Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) { PERL_CONTEXT *ncxs; @@ -9248,7 +9433,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, clone_params* param) /* duplicate a stack info structure */ PERL_SI * -Perl_si_dup(pTHX_ PERL_SI *si, clone_params* param) +Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) { PERL_SI *nsi; @@ -9314,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; } @@ -9323,7 +9509,7 @@ Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl) /* duplicate the save stack */ ANY * -Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param) +Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) { ANY *ss = proto_perl->Tsavestack; I32 ix = proto_perl->Tsavestack_ix; @@ -9368,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); @@ -9618,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); @@ -9630,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 */ @@ -9646,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); @@ -9659,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 */ @@ -9702,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 */ @@ -9733,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); @@ -9758,9 +9959,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]); } - param->stashes = newAV(); /* Setup array of objects to call clone on */ +#ifdef PERLIO_LAYERS + /* Clone PerlIO tables as soon as we can handle general xx_dup() */ + PerlIO_clone(aTHX_ proto_perl, param); +#endif PL_envgv = gv_dup(proto_perl->Ienvgv, param); PL_incgv = gv_dup(proto_perl->Iincgv, param); @@ -9802,18 +10006,29 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #ifdef VMS PL_statusvalue_vms = proto_perl->Istatusvalue_vms; #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(); { I32 len = av_len((AV*)proto_perl->Iregex_padav); SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav); - for(i = 0; i <= len; i++) { - av_push(PL_regex_padav, - SvREFCNT_inc( - newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *, + av_push(PL_regex_padav, + sv_dup_inc(regexen[0],param)); + for(i = 1; i <= len; i++) { + if(SvREPADTMP(regexen[i])) { + av_push(PL_regex_padav, sv_dup_inc(regexen[i], param)); + } else { + av_push(PL_regex_padav, + SvREFCNT_inc( + newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *, SvIVX(regexen[i])), param))) - )); + )); + } } } PL_regex_pad = AvARRAY(PL_regex_padav); @@ -9911,7 +10126,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param); PL_profiledata = NULL; - PL_rsfp = fp_dup(proto_perl->Irsfp, '<'); + PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param); /* PL_rsfp_filters entries have fake IoDIRP() */ PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param); @@ -10060,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 */ @@ -10295,7 +10511,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; } - + /* Call the ->CLONE method, if it exists, for each of the stashes identified by sv_dup() above. */ @@ -10316,9 +10532,61 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } SvREFCNT_dec(param->stashes); - Safefree(param); return my_perl; } #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 +of the sv is assumed to be octets in that encoding, and the sv +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 +an C Encoding object, bad things will happen. +(See F and L). + +The PV of the sv is returned. + +=cut */ + +char * +Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) +{ + if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) { + SV *uni; + STRLEN len; + char *s; + dSP; + ENTER; + SAVETMPS; + PUSHMARK(sp); + EXTEND(SP, 3); + XPUSHs(encoding); + XPUSHs(sv); + XPUSHs(&PL_sv_yes); + PUTBACK; + call_method("decode", G_SCALAR); + SPAGAIN; + uni = POPs; + PUTBACK; + s = SvPV(uni, len); + if (s != SvPVX(sv)) { + SvGROW(sv, len); + Move(s, SvPVX(sv), len, char); + SvCUR_set(sv, len); + } + FREETMPS; + LEAVE; + SvUTF8_on(sv); + } + return SvPVX(sv); +} + +