X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=ac4090052c035762982abc7564d797b21c3b95fa;hb=4a4c6fe390894386eeb2fdd5dfec0acaeed13c9b;hp=ba51738c28602d4054db245c2caa6c13e4bcc53b;hpb=45ef2ede190b88887a0dfeb6502000b5ea6f0174;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index ba51738..ac40900 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, @@ -544,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 */ @@ -1224,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); @@ -1538,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, @@ -1563,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) @@ -1582,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); @@ -1819,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); } @@ -3143,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. @@ -3269,6 +3316,9 @@ 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 */ @@ -3288,6 +3338,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 */ @@ -3315,7 +3368,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 @@ -3353,6 +3406,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 */ @@ -3370,28 +3426,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", @@ -3762,15 +3796,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. */ @@ -3885,7 +3920,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); @@ -3941,7 +3975,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); @@ -4413,43 +4447,33 @@ 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. -C is assumed to contain an C if C<(name && namelen == HEf_SVKEY)> +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' + +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); @@ -4476,129 +4500,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; + } } /* @@ -4624,7 +4701,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); @@ -4665,7 +4742,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); @@ -4705,7 +4782,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; @@ -4832,7 +4909,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); @@ -5107,7 +5184,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)); @@ -5116,7 +5193,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; @@ -5284,6 +5361,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 = ""; @@ -5299,33 +5377,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; @@ -5346,10 +5448,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 = ""; @@ -5358,22 +5459,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); + } } } @@ -5393,10 +5507,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; } @@ -6416,7 +6531,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); @@ -6567,8 +6682,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) @@ -6813,7 +6928,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); @@ -7653,6 +7768,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); @@ -7686,13 +7802,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; @@ -7700,7 +7819,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]; @@ -7825,17 +7944,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*)""; @@ -7929,7 +8048,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; @@ -7965,7 +8084,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; @@ -7981,7 +8100,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; @@ -8011,8 +8130,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; @@ -8096,8 +8216,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; @@ -8173,7 +8294,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'"); } @@ -8310,7 +8431,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 ... */ @@ -8329,6 +8450,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; @@ -8367,7 +8504,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); @@ -8632,7 +8771,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)) @@ -8648,6 +8787,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; @@ -8857,6 +8999,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) { @@ -8898,36 +9074,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(); @@ -8935,14 +9095,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(); @@ -8952,14 +9105,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(); @@ -8969,14 +9115,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); @@ -8989,14 +9128,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); @@ -9022,14 +9154,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); @@ -9045,14 +9170,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); @@ -9160,10 +9278,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)); @@ -9364,8 +9479,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; } @@ -9418,6 +9534,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); @@ -9668,7 +9790,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); @@ -9680,7 +9803,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); + Zero(&PL_debug_pad, 1, struct perl_debug_pad); # else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); # endif /* DEBUGGING */ @@ -9697,7 +9820,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); @@ -9710,6 +9834,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 */ @@ -9753,8 +9878,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 */ @@ -9784,15 +9908,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); @@ -9858,6 +9988,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif PL_encoding = sv_dup(proto_perl->Iencoding, param); +#ifdef DEBUGGING + sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */ + sv_setpvn(PERL_DEBUG_PAD(1), "", 0); + sv_setpvn(PERL_DEBUG_PAD(2), "", 0); +#endif + /* Clone the regex array */ PL_regex_padav = newAV(); { @@ -10378,7 +10514,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } SvREFCNT_dec(param->stashes); - Safefree(param); return my_perl; } @@ -10386,6 +10521,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 @@ -10434,3 +10571,4 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) return SvPVX(sv); } +