X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=8713bf68a09d15c715669fe2fa6b3af6e9020cc5;hb=949d010fe77e69674beb14306cfc1b92afa3e47c;hp=0bae3ce72af44d2660435f02ec52686bf4e31eb4;hpb=771208afd937a008c2ced72cfe214c2dbc98985e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 0bae3ce..8713bf6 100644 --- a/sv.c +++ b/sv.c @@ -8,19 +8,18 @@ * "I wonder what the Entish is for 'yes' and 'no'," he thought. * * - * Manipulation of scalar values (SVs). This file contains the code that - * creates, manipulates and destroys SVs. (Opcode-level functions on SVs - * can be found in the various pp*.c files.) Note that the basic structure - * of an SV is also used to hold the other major Perl data types - AVs, - * HVs, GVs, IO etc. Low-level functions on these other types - such as - * memory allocation and destruction - are handled within this file, while - * higher-level stuff can be found in the individual files av.c, hv.c, - * etc. + * This file contains the code that creates, manipulates and destroys + * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the + * structure of an SV, so their creation and destruction is handled + * here; higher-level functions are in av.c, hv.c, and so on. Opcode + * level functions (eg. substr, split, join) for each of the types are + * in the pp*.c files. */ #include "EXTERN.h" #define PERL_IN_SV_C #include "perl.h" +#include "regcomp.h" #define FCALL *f #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv) @@ -30,16 +29,19 @@ =head1 Allocation and deallocation of SVs. -An SV (or AV, HV etc) is in 2 parts: the head and the body. There is only -one type of head, but around 13 body types. Head and body are each -separately allocated. Normally, this allocation is done using arenas, -which are approximately 1K chunks of memory parcelled up into N heads or -bodies. The first slot in each arena is reserved, and is used to hold a -link to the next arena. In the case of heads, the unused first slot -also contains some flags and a note of the number of slots. Snaked through -each arena chain is a linked list of free items; when this becomes empty, -an extra arena is allocated and divided up into N items which are threaded -into the free list. +An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv, +av, hv...) contains type and reference count information, as well as a +pointer to the body (struct xrv, xpv, xpviv...), which contains fields +specific to each type. + +Normally, this allocation is done using arenas, which are approximately +1K chunks of memory parcelled up into N heads or bodies. The first slot +in each arena is reserved, and is used to hold a link to the next arena. +In the case of heads, the unused first slot also contains some flags and +a note of the number of slots. Snaked through each arena chain is a +linked list of free items; when this becomes empty, an extra arena is +allocated and divided up into N items which are threaded into the free +list. The following global variables are associated with arenas: @@ -68,12 +70,12 @@ SVs in the free list have their SvTYPE field set to all ones. Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc that allocate and return individual body types. Normally these are mapped -to the arena-maniplulating functions new_xiv()/del_xiv() etc, but may be -instead mapped directly to malloc()/free() if PURIFY is in effect. The +to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be +instead mapped directly to malloc()/free() if PURIFY is defined. The new/del functions remove from, or add to, the appropriate PL_foo_root list, and call more_xiv() etc to add a new arena if the list is empty. -It the time of very final cleanup, sv_free_arenas() is called from +At the time of very final cleanup, sv_free_arenas() is called from perl_destruct() to physically free all the arenas allocated since the start of the interpreter. Note that this also clears PL_he_arenaroot, which is otherwise dealt with in hv.c. @@ -271,7 +273,7 @@ S_more_sv(pTHX) return sv; } -/* visit(): call the named function for each non-free in SV the arenas. */ +/* visit(): call the named function for each non-free SV in the arenas. */ STATIC I32 S_visit(pTHX_ SVFUNC_t f) @@ -285,7 +287,7 @@ S_visit(pTHX_ SVFUNC_t f) svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) { - (FCALL)(aTHXo_ sv); + (FCALL)(aTHX_ sv); ++visited; } } @@ -296,7 +298,7 @@ S_visit(pTHX_ SVFUNC_t f) /* called by sv_report_used() for each live SV */ static void -do_report_used(pTHXo_ SV *sv) +do_report_used(pTHX_ SV *sv) { if (SvTYPE(sv) != SVTYPEMASK) { PerlIO_printf(Perl_debug_log, "****\n"); @@ -321,7 +323,7 @@ Perl_sv_report_used(pTHX) /* called by sv_clean_objs() for each live SV */ static void -do_clean_objs(pTHXo_ SV *sv) +do_clean_objs(pTHX_ SV *sv) { SV* rv; @@ -345,7 +347,7 @@ do_clean_objs(pTHXo_ SV *sv) #ifndef DISABLE_DESTRUCTOR_KLUDGE static void -do_clean_named_objs(pTHXo_ SV *sv) +do_clean_named_objs(pTHX_ SV *sv) { if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) { if ( SvOBJECT(GvSV(sv)) || @@ -384,7 +386,7 @@ Perl_sv_clean_objs(pTHX) /* called by sv_clean_all() for each live SV */ static void -do_clean_all(pTHXo_ SV *sv) +do_clean_all(pTHX_ SV *sv) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); SvFLAGS(sv) |= SVf_BREAK; @@ -396,7 +398,7 @@ do_clean_all(pTHXo_ SV *sv) Decrement the refcnt of each remaining SV, possibly triggering a cleanup. This function may have to be called multiple times to free -SVs which are in complex self-referential heirarchies. +SVs which are in complex self-referential hierarchies. =cut */ @@ -538,7 +540,7 @@ Perl_report_uninit(pTHX) { if (PL_op) Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, - " in ", PL_op_desc[PL_op->op_type]); + " in ", OP_DESC(PL_op)); else Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", ""); } @@ -1207,9 +1209,9 @@ S_more_xpvbm(pTHX) /* =for apidoc sv_upgrade -Upgrade an SV to a more complex form. Gnenerally adds a new body type to the +Upgrade an SV to a more complex form. Generally adds a new body type to the SV, then copies across as much information as possible from the old body. -You genrally want to use the C macro wrapper. See also C. +You generally want to use the C macro wrapper. See also C. =cut */ @@ -1567,8 +1569,15 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) #endif Renew(s,newlen,char); } - else - New(703,s,newlen,char); + else { + /* sv_force_normal_flags() must not try to unshare the new + PVX we allocate below. AMS 20010713 */ + if (SvREADONLY(sv) && SvFAKE(sv)) { + SvFAKE_off(sv); + SvREADONLY_off(sv); + } + New(703, s, newlen, char); + } SvPV_set(sv, s); SvLEN_set(sv, newlen); } @@ -1607,7 +1616,7 @@ Perl_sv_setiv(pTHX_ register SV *sv, IV i) case SVt_PVFM: case SVt_PVIO: Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), - PL_op_desc[PL_op->op_type]); + OP_DESC(PL_op)); } (void)SvIOK_only(sv); /* validate number */ SvIVX(sv) = i; @@ -1718,7 +1727,7 @@ Perl_sv_setnv(pTHX_ register SV *sv, NV num) case SVt_PVFM: case SVt_PVIO: Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); } SvNVX(sv) = num; (void)SvNOK_only(sv); /* validate number */ @@ -1798,7 +1807,7 @@ S_not_a_number(pTHX_ SV *sv) if (PL_op) Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf, - PL_op_desc[PL_op->op_type]); + OP_DESC(PL_op)); else Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf); @@ -2045,7 +2054,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) ) { SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" iv(%g => %"IVdf") (precise)\n", + "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", PTR2UV(sv), SvNVX(sv), SvIVX(sv))); @@ -2056,7 +2065,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) that PV->IV would be better than PV->NV->IV flags already correct - don't set public IOK. */ DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n", + "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n", PTR2UV(sv), SvNVX(sv), SvIVX(sv))); @@ -2112,7 +2121,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { - /* It's defintately an integer, only upgrade to PVIV */ + /* It's definitely an integer, only upgrade to PVIV */ if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); (void)SvIOK_on(sv); @@ -2339,7 +2348,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) ) { SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" uv(%g => %"IVdf") (precise)\n", + "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n", PTR2UV(sv), SvNVX(sv), SvIVX(sv))); @@ -2350,7 +2359,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) that PV->IV would be better than PV->NV->IV flags already correct - don't set public IOK. */ DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n", + "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n", PTR2UV(sv), SvNVX(sv), SvIVX(sv))); @@ -2402,7 +2411,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { - /* It's defintately an integer, only upgrade to PVIV */ + /* It's definitely an integer, only upgrade to PVIV */ if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); (void)SvIOK_on(sv); @@ -2619,10 +2628,10 @@ Perl_sv_2nv(pTHX_ register SV *sv) } else if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); - if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) { - SvNOK_on(sv); + if (SvNOKp(sv)) { + return SvNVX(sv); } - else if (SvIOKp(sv)) { + if (SvIOKp(sv)) { SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv); #ifdef NV_PRESERVES_UV SvNOK_on(sv); @@ -2644,7 +2653,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) #ifdef NV_PRESERVES_UV if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) == IS_NUMBER_IN_UV) { - /* It's defintately an integer */ + /* It's definitely an integer */ SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value; } else SvNVX(sv) = Atof(SvPVX(sv)); @@ -2857,7 +2866,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) /* =for apidoc sv_2pv_flags -Returns pointer to the string value of an SV, and sets *lp to its length. +Returns a pointer to the string value of an SV, and sets *lp to its length. If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string if necessary. Normally invoked via the C macro. C and C @@ -3346,7 +3355,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) if (first && ch > 255) { if (PL_op) Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s", - PL_op_desc[PL_op->op_type]); + OP_DESC(PL_op); else Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte"); first = 0; @@ -3361,7 +3370,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) else { if (PL_op) Perl_croak(aTHX_ "Wide character in %s", - PL_op_desc[PL_op->op_type]); + OP_DESC(PL_op)); else Perl_croak(aTHX_ "Wide character"); } @@ -3588,7 +3597,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) case SVt_PVIO: if (PL_op) Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0), - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); else Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0)); break; @@ -3612,8 +3621,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", GvNAME(dstr)); -#ifdef GV_SHARED_CHECK - if (GvSHARED((GV*)dstr)) { +#ifdef GV_UNIQUE_CHECK + if (GvUNIQUE((GV*)dstr)) { Perl_croak(aTHX_ PL_no_modify); } #endif @@ -3658,8 +3667,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SV *dref = 0; int intro = GvINTRO(dstr); -#ifdef GV_SHARED_CHECK - if (GvSHARED((GV*)dstr)) { +#ifdef GV_UNIQUE_CHECK + if (GvUNIQUE((GV*)dstr)) { Perl_croak(aTHX_ PL_no_modify); } #endif @@ -4100,7 +4109,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) *SvEND(sv) = '\0'; SvFAKE_off(sv); SvREADONLY_off(sv); - unsharepvn(pvx,SvUTF8(sv)?-len:len,hash); + unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash); } else if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); @@ -4414,9 +4423,9 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam mg->mg_moremagic = SvMAGIC(sv); SvMAGIC(sv) = mg; - /* Some magic sontains a reference loop, where the sv and object refer to - each other. To prevent a avoid a reference loop that would prevent such - objects being freed, we look for such loops and if we find one we avoid + /* 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. */ if (!obj || obj == sv || how == PERL_MAGIC_arylen || @@ -4491,11 +4500,11 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam case PERL_MAGIC_dbline: mg->mg_virtual = &PL_vtbl_dbline; break; -#ifdef USE_THREADS +#ifdef USE_5005THREADS case PERL_MAGIC_mutex: mg->mg_virtual = &PL_vtbl_mutex; break; -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ #ifdef USE_LOCALE_COLLATE case PERL_MAGIC_collxfrm: mg->mg_virtual = &PL_vtbl_collxfrm; @@ -4779,7 +4788,7 @@ Make the first argument a copy of the second, then delete the original. The target SV physically takes over ownership of the body of the source SV and inherits its flags; however, the target keeps any magic it owns, and any magic in the source is discarded. -Note that this a rather specialist SV copying operation; most of the +Note that this is a rather specialist SV copying operation; most of the time you'll want to use C or one of its many macro front-ends. =cut @@ -4945,7 +4954,9 @@ Perl_sv_clear(pTHX_ register SV *sv) else if (SvPVX(sv) && SvLEN(sv)) Safefree(SvPVX(sv)); else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) { - unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv)); + unsharepvn(SvPVX(sv), + SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv), + SvUVX(sv)); SvFAKE_off(sv); } break; @@ -5101,7 +5112,6 @@ coercion. See also C, which gives raw access to the xpv_cur slot. STRLEN Perl_sv_len(pTHX_ register SV *sv) { - char *junk; STRLEN len; if (!sv) @@ -5110,7 +5120,7 @@ Perl_sv_len(pTHX_ register SV *sv) if (SvGMAGICAL(sv)) len = mg_length(sv); else - junk = SvPV(sv, len); + (void)SvPV(sv, len); return len; } @@ -5261,8 +5271,6 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { bool is_utf8 = TRUE; /* UTF-8ness differs */ - if (PL_hints & HINT_UTF8_DISTINCT) - return FALSE; if (SvUTF8(sv1)) { /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */ @@ -5327,9 +5335,6 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) /* do not utf8ize the comparands as a side-effect */ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { - if (PL_hints & HINT_UTF8_DISTINCT) - return SvUTF8(sv1) ? 1 : -1; - if (SvUTF8(sv1)) { pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2); pv2tmp = TRUE; @@ -5824,7 +5829,9 @@ Perl_sv_inc(pTHX_ register SV *sv) } if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { /* It's publicly an integer, or privately an integer-not-float */ +#ifdef PERL_PRESERVE_IVUV oops_its_int: +#endif if (SvIsUV(sv)) { if (SvUVX(sv) == UV_MAX) sv_setnv(sv, (NV)UV_MAX + 1.0); @@ -5972,7 +5979,9 @@ Perl_sv_dec(pTHX_ register SV *sv) flags = SvFLAGS(sv); if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { /* It's publicly an integer, or privately an integer-not-float */ +#ifdef PERL_PRESERVE_IVUV oops_its_int: +#endif if (SvIsUV(sv)) { if (SvUVX(sv) == 0) { (void)SvIOK_only(sv); @@ -6045,8 +6054,9 @@ Perl_sv_dec(pTHX_ register SV *sv) =for apidoc sv_mortalcopy Creates a new SV which is a copy of the original SV (using C). -The new SV is marked as mortal. It will be destroyed when the current -context ends. See also C and C. +The new SV is marked as mortal. It will be destroyed "soon", either by an +explicit call to FREETMPS, or by an implicit call at places such as +statement boundaries. See also C and C. =cut */ @@ -6073,8 +6083,9 @@ Perl_sv_mortalcopy(pTHX_ SV *oldstr) =for apidoc sv_newmortal Creates a new null SV which is mortal. The reference count of the SV is -set to 1. It will be destroyed when the current context ends. See -also C and C. +set to 1. It will be destroyed "soon", either by an explicit call to +FREETMPS, or by an implicit call at places such as statement boundaries. +See also C and C. =cut */ @@ -6094,8 +6105,9 @@ Perl_sv_newmortal(pTHX) /* =for apidoc sv_2mortal -Marks an existing SV as mortal. The SV will be destroyed when the current -context ends. See also C and C. +Marks an existing SV as mortal. The SV will be destroyed "soon", either +by an explicit call to FREETMPS, or by an implicit call at places such as +statement boundaries. See also C and C. =cut */ @@ -6176,11 +6188,8 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) register SV *sv; bool is_utf8 = FALSE; if (len < 0) { - len = -len; + STRLEN tmplen = -len; is_utf8 = TRUE; - } - if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) { - STRLEN tmplen = len; /* See the note in hv.c:hv_fetch() --jhi */ src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8); len = tmplen; @@ -6332,7 +6341,7 @@ Perl_newRV_noinc(pTHX_ SV *tmpRef) return sv; } -/* newRV_inc is the offical function name to use now. +/* newRV_inc is the official function name to use now. * newRV_inc is in fact #defined to newRV in sv.h */ @@ -6755,7 +6764,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) else { if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) { Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); } else s = sv_2pv_flags(sv, lp, flags); @@ -7781,7 +7790,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV q++; if (*q == '*') { q++; - if (EXPECT_NUMBER(q, epix) && *q++ != '$') + if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */ goto unknown; if (args) i = va_arg(*args, int); @@ -8313,8 +8322,8 @@ ptr_table_* functions. #if defined(USE_ITHREADS) -#if defined(USE_THREADS) -# include "error: USE_THREADS and USE_ITHREADS are incompatible" +#if defined(USE_5005THREADS) +# include "error: USE_5005THREADS and USE_ITHREADS are incompatible" #endif #ifndef GpREFCNT_inc @@ -8322,30 +8331,121 @@ ptr_table_* functions. #endif -#define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s)) -#define av_dup(s) (AV*)sv_dup((SV*)s) -#define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s)) -#define hv_dup(s) (HV*)sv_dup((SV*)s) -#define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s)) -#define cv_dup(s) (CV*)sv_dup((SV*)s) -#define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s)) -#define io_dup(s) (IO*)sv_dup((SV*)s) -#define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s)) -#define gv_dup(s) (GV*)sv_dup((SV*)s) -#define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s)) +#define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t)) +#define av_dup(s,t) (AV*)sv_dup((SV*)s,t) +#define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t)) +#define hv_dup(s,t) (HV*)sv_dup((SV*)s,t) +#define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t)) +#define cv_dup(s,t) (CV*)sv_dup((SV*)s,t) +#define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t)) +#define io_dup(s,t) (IO*)sv_dup((SV*)s,t) +#define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t)) +#define gv_dup(s,t) (GV*)sv_dup((SV*)s,t) +#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 */ +/* Duplicate a regexp. Required reading: pregcomp() and pregfree() in + regcomp.c. AMS 20010712 */ REGEXP * -Perl_re_dup(pTHX_ REGEXP *r) +Perl_re_dup(pTHX_ REGEXP *r, clone_params *param) { - /* XXX fix when pmop->op_pmregexp becomes shared */ - return ReREFCNT_inc(r); + REGEXP *ret; + int i, len, npar; + struct reg_substr_datum *s; + + if (!r) + return (REGEXP *)NULL; + + if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r))) + return ret; + + len = r->offsets[0]; + npar = r->nparens+1; + + Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp); + Copy(r->program, ret->program, len+1, regnode); + + New(0, ret->startp, npar, I32); + Copy(r->startp, ret->startp, npar, I32); + New(0, ret->endp, npar, I32); + Copy(r->startp, ret->startp, npar, I32); + + New(0, ret->substrs, 1, struct reg_substr_data); + for (s = ret->substrs->data, i = 0; i < 3; i++, s++) { + 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); + } + + ret->regstclass = NULL; + if (r->data) { + struct reg_data *d; + int count = r->data->count; + + Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *), + char, struct reg_data); + New(0, d->what, count, U8); + + d->count = count; + for (i = 0; i < count; i++) { + d->what[i] = r->data->what[i]; + switch (d->what[i]) { + case 's': + d->data[i] = sv_dup_inc((SV *)r->data->data[i], param); + break; + case 'p': + d->data[i] = av_dup_inc((AV *)r->data->data[i], param); + break; + case 'f': + /* This is cheating. */ + New(0, d->data[i], 1, struct regnode_charclass_class); + StructCopy(r->data->data[i], d->data[i], + struct regnode_charclass_class); + ret->regstclass = (regnode*)d->data[i]; + break; + case 'o': + /* Compiled op trees are readonly, and can thus be + shared without duplication. */ + d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]); + break; + case 'n': + d->data[i] = r->data->data[i]; + break; + } + } + + ret->data = d; + } + else + ret->data = NULL; + + New(0, ret->offsets, 2*len+1, U32); + Copy(r->offsets, ret->offsets, 2*len+1, U32); + + ret->precomp = SAVEPV(r->precomp); + ret->refcnt = r->refcnt; + ret->minlen = r->minlen; + ret->prelen = r->prelen; + ret->nparens = r->nparens; + ret->lastparen = r->lastparen; + ret->lastcloseparen = r->lastcloseparen; + ret->reganch = r->reganch; + + ret->sublen = r->sublen; + + if (RX_MATCH_COPIED(ret)) + ret->subbeg = SAVEPV(r->subbeg); + else + ret->subbeg = Nullch; + + ptr_table_store(PL_ptr_table, r, ret); + return ret; } -/* duplicate a filke handle */ +/* duplicate a file handle */ PerlIO * Perl_fp_dup(pTHX_ PerlIO *fp, char type) @@ -8376,10 +8476,10 @@ Perl_dirp_dup(pTHX_ DIR *dp) return dp; } -/* duplictate a typeglob */ +/* duplicate a typeglob */ GP * -Perl_gp_dup(pTHX_ GP *gp) +Perl_gp_dup(pTHX_ GP *gp, clone_params* param) { GP *ret; if (!gp) @@ -8395,13 +8495,13 @@ Perl_gp_dup(pTHX_ GP *gp) /* clone */ ret->gp_refcnt = 0; /* must be before any other dups! */ - ret->gp_sv = sv_dup_inc(gp->gp_sv); - ret->gp_io = io_dup_inc(gp->gp_io); - ret->gp_form = cv_dup_inc(gp->gp_form); - ret->gp_av = av_dup_inc(gp->gp_av); - ret->gp_hv = hv_dup_inc(gp->gp_hv); - ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */ - ret->gp_cv = cv_dup_inc(gp->gp_cv); + ret->gp_sv = sv_dup_inc(gp->gp_sv, param); + ret->gp_io = io_dup_inc(gp->gp_io, param); + ret->gp_form = cv_dup_inc(gp->gp_form, param); + ret->gp_av = av_dup_inc(gp->gp_av, param); + ret->gp_hv = hv_dup_inc(gp->gp_hv, param); + ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */ + ret->gp_cv = cv_dup_inc(gp->gp_cv, param); ret->gp_cvgen = gp->gp_cvgen; ret->gp_flags = gp->gp_flags; ret->gp_line = gp->gp_line; @@ -8412,7 +8512,7 @@ Perl_gp_dup(pTHX_ GP *gp) /* duplicate a chain of magic */ MAGIC * -Perl_mg_dup(pTHX_ MAGIC *mg) +Perl_mg_dup(pTHX_ MAGIC *mg, clone_params* param) { MAGIC *mgprev = (MAGIC*)NULL; MAGIC *mgret; @@ -8435,12 +8535,24 @@ Perl_mg_dup(pTHX_ MAGIC *mg) nmg->mg_type = mg->mg_type; nmg->mg_flags = mg->mg_flags; if (mg->mg_type == PERL_MAGIC_qr) { - nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj); + nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param); + } + else if(mg->mg_type == PERL_MAGIC_backref) { + AV *av = (AV*) mg->mg_obj; + SV **svp; + I32 i; + nmg->mg_obj = (SV*)newAV(); + svp = AvARRAY(av); + i = AvFILLp(av); + while (i >= 0) { + av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param)); + i--; + } } else { nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED) - ? sv_dup_inc(mg->mg_obj) - : sv_dup(mg->mg_obj); + ? sv_dup_inc(mg->mg_obj, param) + : sv_dup(mg->mg_obj, param); } nmg->mg_len = mg->mg_len; nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */ @@ -8454,12 +8566,12 @@ Perl_mg_dup(pTHX_ MAGIC *mg) AMT *namtp = (AMT*)nmg->mg_ptr; I32 i; for (i = 1; i < NofAMmeth; i++) { - namtp->table[i] = cv_dup_inc(amtp->table[i]); + namtp->table[i] = cv_dup_inc(amtp->table[i], param); } } } else if (mg->mg_len == HEf_SVKEY) - nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr); + nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param); } mgprev = nmg; } @@ -8620,7 +8732,7 @@ S_gv_share(pTHX_ SV *sstr) SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */ if (GvIO(gv) || GvFORM(gv)) { - GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */ + GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */ } else if (!GvCV(gv)) { GvCV(gv) = (CV*)sv; @@ -8628,11 +8740,11 @@ S_gv_share(pTHX_ SV *sstr) else { /* CvPADLISTs cannot be shared */ if (!CvXSUB(GvCV(gv))) { - GvSHARED_off(gv); + GvUNIQUE_off(gv); } } - if (!GvSHARED(gv)) { + if (!GvUNIQUE(gv)) { #if 0 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n", HvNAME(GvSTASH(gv)), GvNAME(gv)); @@ -8671,7 +8783,7 @@ S_gv_share(pTHX_ SV *sstr) /* duplicate an SV of any type (including AV, HV etc) */ SV * -Perl_sv_dup(pTHX_ SV *sstr) +Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) { SV *dstr; @@ -8711,18 +8823,18 @@ Perl_sv_dup(pTHX_ SV *sstr) break; case SVt_RV: SvANY(dstr) = new_XRV(); - SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr)) - ? sv_dup(SvRV(sstr)) - : sv_dup_inc(SvRV(sstr)); + SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr) + ? sv_dup(SvRV(sstr), param) + : sv_dup_inc(SvRV(sstr), param); break; case SVt_PV: SvANY(dstr) = new_XPV(); SvCUR(dstr) = SvCUR(sstr); SvLEN(dstr) = SvLEN(sstr); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) - ? sv_dup(SvRV(sstr)) - : sv_dup_inc(SvRV(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 @@ -8734,9 +8846,9 @@ Perl_sv_dup(pTHX_ SV *sstr) SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) - ? sv_dup(SvRV(sstr)) - : sv_dup_inc(SvRV(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 @@ -8749,9 +8861,9 @@ Perl_sv_dup(pTHX_ SV *sstr) SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) - ? sv_dup(SvRV(sstr)) - : sv_dup_inc(SvRV(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 @@ -8763,12 +8875,12 @@ Perl_sv_dup(pTHX_ SV *sstr) SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) - ? sv_dup(SvRV(sstr)) - : sv_dup_inc(SvRV(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 @@ -8780,12 +8892,12 @@ Perl_sv_dup(pTHX_ SV *sstr) SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) - ? sv_dup(SvRV(sstr)) - : sv_dup_inc(SvRV(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 @@ -8800,23 +8912,23 @@ Perl_sv_dup(pTHX_ SV *sstr) SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) - ? sv_dup(SvRV(sstr)) - : sv_dup_inc(SvRV(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? */ LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */ LvTARGLEN(dstr) = LvTARGLEN(sstr); - LvTARG(dstr) = sv_dup_inc(LvTARG(sstr)); + LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param); LvTYPE(dstr) = LvTYPE(sstr); break; case SVt_PVGV: - if (GvSHARED((GV*)sstr)) { + if (GvUNIQUE((GV*)sstr)) { SV *share; if ((share = gv_share(sstr))) { del_SV(dstr); @@ -8833,21 +8945,21 @@ Perl_sv_dup(pTHX_ SV *sstr) SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) - ? sv_dup(SvRV(sstr)) - : sv_dup_inc(SvRV(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? */ GvNAMELEN(dstr) = GvNAMELEN(sstr); GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr)); - GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr)); + GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param); GvFLAGS(dstr) = GvFLAGS(sstr); - GvGP(dstr) = gp_dup(GvGP(sstr)); + GvGP(dstr) = gp_dup(GvGP(sstr), param); (void)GpREFCNT_inc(GvGP(dstr)); break; case SVt_PVIO: @@ -8856,12 +8968,12 @@ Perl_sv_dup(pTHX_ SV *sstr) SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); if (SvROK(sstr)) - SvRV(dstr) = SvWEAKREF(SvRV(sstr)) - ? sv_dup(SvRV(sstr)) - : sv_dup_inc(SvRV(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 @@ -8881,11 +8993,11 @@ Perl_sv_dup(pTHX_ SV *sstr) IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr); IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr); IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr)); - IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr)); + IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param); IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr)); - IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr)); + IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param); IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr)); - IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr)); + IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param); IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr); IoTYPE(dstr) = IoTYPE(sstr); IoFLAGS(dstr) = IoFLAGS(sstr); @@ -8896,9 +9008,9 @@ Perl_sv_dup(pTHX_ SV *sstr) SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); - AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr)); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); + AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param); AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr); if (AvARRAY((AV*)sstr)) { SV **dst_ary, **src_ary; @@ -8911,11 +9023,11 @@ Perl_sv_dup(pTHX_ SV *sstr) AvALLOC((AV*)dstr) = dst_ary; if (AvREAL((AV*)sstr)) { while (items-- > 0) - *dst_ary++ = sv_dup_inc(*src_ary++); + *dst_ary++ = sv_dup_inc(*src_ary++, param); } else { while (items-- > 0) - *dst_ary++ = sv_dup(*src_ary++); + *dst_ary++ = sv_dup(*src_ary++, param); } items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr); while (items-- > 0) { @@ -8933,8 +9045,8 @@ Perl_sv_dup(pTHX_ SV *sstr) SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param); HvRITER((HV*)dstr) = HvRITER((HV*)sstr); if (HvARRAY((HV*)sstr)) { STRLEN i = 0; @@ -8944,10 +9056,10 @@ Perl_sv_dup(pTHX_ SV *sstr) PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char); while (i <= sxhv->xhv_max) { ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i], - !!HvSHAREKEYS(sstr)); + !!HvSHAREKEYS(sstr), param); ++i; } - dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr)); + dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param); } else { SvPVX(dstr) = Nullch; @@ -8955,9 +9067,9 @@ Perl_sv_dup(pTHX_ SV *sstr) } HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */ HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr)); - /* Record stashes for possible cloning in Perl_clone_using(). */ + /* Record stashes for possible cloning in Perl_clone(). */ if(HvNAME((HV*)dstr)) - av_push(PL_clone_callbacks, dstr); + av_push(param->stashes, dstr); break; case SVt_PVFM: SvANY(dstr) = new_XPVFM(); @@ -8966,38 +9078,48 @@ Perl_sv_dup(pTHX_ SV *sstr) /* NOTREACHED */ case SVt_PVCV: SvANY(dstr) = new_XPVCV(); -dup_pvcv: + dup_pvcv: SvCUR(dstr) = SvCUR(sstr); SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); - SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); - SvSTASH(dstr) = hv_dup_inc(SvSTASH(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? */ - CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */ + CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */ CvSTART(dstr) = CvSTART(sstr); CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr)); CvXSUB(dstr) = CvXSUB(sstr); CvXSUBANY(dstr) = CvXSUBANY(sstr); - CvGV(dstr) = gv_dup(CvGV(sstr)); - CvDEPTH(dstr) = CvDEPTH(sstr); + if (CvCONST(sstr)) { + CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ? + SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) : + sv_dup_inc(CvXSUBANY(sstr).any_ptr, param); + } + CvGV(dstr) = gv_dup(CvGV(sstr), param); + if (param->flags & CLONEf_COPY_STACKS) { + CvDEPTH(dstr) = CvDEPTH(sstr); + } else { + CvDEPTH(dstr) = 0; + } if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) { /* XXX padlists are real, but pretend to be not */ AvREAL_on(CvPADLIST(sstr)); - CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); + CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param); AvREAL_off(CvPADLIST(sstr)); AvREAL_off(CvPADLIST(dstr)); } else - CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); + CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param); if (!CvANON(sstr) || CvCLONED(sstr)) - CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); + CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param); else - CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr)); + CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param); CvFLAGS(dstr) = CvFLAGS(sstr); + CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr)); break; default: Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr)); @@ -9008,12 +9130,12 @@ dup_pvcv: ++PL_sv_objcount; return dstr; -} + } /* duplicate a context */ PERL_CONTEXT * -Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) +Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, clone_params* param) { PERL_CONTEXT *ncxs; @@ -9047,12 +9169,12 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) switch (CxTYPE(cx)) { case CXt_SUB: ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0 - ? cv_dup_inc(cx->blk_sub.cv) - : cv_dup(cx->blk_sub.cv)); + ? cv_dup_inc(cx->blk_sub.cv, param) + : cv_dup(cx->blk_sub.cv,param)); ncx->blk_sub.argarray = (cx->blk_sub.hasargs - ? av_dup_inc(cx->blk_sub.argarray) + ? av_dup_inc(cx->blk_sub.argarray, param) : Nullav); - ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray); + ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param); ncx->blk_sub.olddepth = cx->blk_sub.olddepth; ncx->blk_sub.hasargs = cx->blk_sub.hasargs; ncx->blk_sub.lval = cx->blk_sub.lval; @@ -9060,9 +9182,9 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) case CXt_EVAL: ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval; ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type; - ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv); + ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);; ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root; - ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text); + ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param); break; case CXt_LOOP: ncx->blk_loop.label = cx->blk_loop.label; @@ -9072,20 +9194,20 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) ncx->blk_loop.last_op = cx->blk_loop.last_op; ncx->blk_loop.iterdata = (CxPADLOOP(cx) ? cx->blk_loop.iterdata - : gv_dup((GV*)cx->blk_loop.iterdata)); + : gv_dup((GV*)cx->blk_loop.iterdata, param)); ncx->blk_loop.oldcurpad = (SV**)ptr_table_fetch(PL_ptr_table, cx->blk_loop.oldcurpad); - ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave); - ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval); - ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary); + ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param); + ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param); + ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param); ncx->blk_loop.iterix = cx->blk_loop.iterix; ncx->blk_loop.itermax = cx->blk_loop.itermax; break; case CXt_FORMAT: - ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv); - ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv); - ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv); + ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param); + ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param); + ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param); ncx->blk_sub.hasargs = cx->blk_sub.hasargs; break; case CXt_BLOCK: @@ -9101,7 +9223,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) /* duplicate a stack info structure */ PERL_SI * -Perl_si_dup(pTHX_ PERL_SI *si) +Perl_si_dup(pTHX_ PERL_SI *si, clone_params* param) { PERL_SI *nsi; @@ -9117,13 +9239,13 @@ Perl_si_dup(pTHX_ PERL_SI *si) Newz(56, nsi, 1, PERL_SI); ptr_table_store(PL_ptr_table, si, nsi); - nsi->si_stack = av_dup_inc(si->si_stack); + nsi->si_stack = av_dup_inc(si->si_stack, param); nsi->si_cxix = si->si_cxix; nsi->si_cxmax = si->si_cxmax; - nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax); + nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param); nsi->si_type = si->si_type; - nsi->si_prev = si_dup(si->si_prev); - nsi->si_next = si_dup(si->si_next); + nsi->si_prev = si_dup(si->si_prev, param); + nsi->si_next = si_dup(si->si_next, param); nsi->si_markoff = si->si_markoff; return nsi; @@ -9166,7 +9288,7 @@ 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*)aTHXo) + (((char*)v) - (char*)proto_perl)); + ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl)); else ret = v; @@ -9176,7 +9298,7 @@ Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl) /* duplicate the save stack */ ANY * -Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) +Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param) { ANY *ss = proto_perl->Tsavestack; I32 ix = proto_perl->Tsavestack_ix; @@ -9192,9 +9314,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) GP *gp; IV iv; I32 i; - char *c; + char *c = NULL; void (*dptr) (void*); - void (*dxptr) (pTHXo_ void*); + void (*dxptr) (pTHX_ void*); OP *o; Newz(54, nss, max, ANY); @@ -9205,15 +9327,15 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) switch (i) { case SAVEt_ITEM: /* normal string */ sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); break; case SAVEt_SV: /* scalar reference */ sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); gv = (GV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup_inc(gv); + TOPPTR(nss,ix) = gv_dup_inc(gv, param); break; case SAVEt_GENERIC_PVREF: /* generic char* */ c = (char*)POPPTR(ss,ix); @@ -9224,21 +9346,21 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) case SAVEt_GENERIC_SVREF: /* generic sv */ case SAVEt_SVREF: /* scalar reference */ sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ break; case SAVEt_AV: /* array reference */ av = (AV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = av_dup_inc(av); + TOPPTR(nss,ix) = av_dup_inc(av, param); gv = (GV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup(gv); + TOPPTR(nss,ix) = gv_dup(gv, param); break; case SAVEt_HV: /* hash reference */ hv = (HV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = hv_dup_inc(hv); + TOPPTR(nss,ix) = hv_dup_inc(hv, param); gv = (GV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup(gv); + TOPPTR(nss,ix) = gv_dup(gv, param); break; case SAVEt_INT: /* int reference */ ptr = POPPTR(ss,ix); @@ -9270,7 +9392,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup(sv); + TOPPTR(nss,ix) = sv_dup(sv, param); break; case SAVEt_VPTR: /* random* reference */ ptr = POPPTR(ss,ix); @@ -9288,24 +9410,24 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); hv = (HV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = hv_dup(hv); + TOPPTR(nss,ix) = hv_dup(hv, param); break; case SAVEt_APTR: /* AV* reference */ ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); av = (AV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = av_dup(av); + TOPPTR(nss,ix) = av_dup(av, param); break; case SAVEt_NSTAB: gv = (GV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup(gv); + TOPPTR(nss,ix) = gv_dup(gv, param); break; case SAVEt_GP: /* scalar reference */ gp = (GP*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gp = gp_dup(gp); + TOPPTR(nss,ix) = gp = gp_dup(gp, param); (void)GpREFCNT_inc(gp); gv = (GV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup_inc(c); + TOPPTR(nss,ix) = gv_dup_inc(c, param); c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup(c); iv = POPIV(ss,ix); @@ -9316,7 +9438,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) case SAVEt_FREESV: case SAVEt_MORTALIZESV: sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); break; case SAVEt_FREEOP: ptr = POPPTR(ss,ix); @@ -9351,7 +9473,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) break; case SAVEt_DELETE: hv = (HV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = hv_dup_inc(hv); + TOPPTR(nss,ix) = hv_dup_inc(hv, param); c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup_inc(c); i = POPINT(ss,ix); @@ -9367,7 +9489,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ dxptr = POPDXPTR(ss,ix); - TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl); + TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl); break; case SAVEt_REGCONTEXT: case SAVEt_ALLOC: @@ -9381,19 +9503,19 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) break; case SAVEt_AELEM: /* array element */ sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); i = POPINT(ss,ix); TOPINT(nss,ix) = i; av = (AV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = av_dup_inc(av); + TOPPTR(nss,ix) = av_dup_inc(av, param); break; case SAVEt_HELEM: /* hash element */ sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); hv = (HV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = hv_dup_inc(hv); + TOPPTR(nss,ix) = hv_dup_inc(hv, param); break; case SAVEt_OP: ptr = POPPTR(ss,ix); @@ -9405,7 +9527,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) break; case SAVEt_COMPPAD: av = (AV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = av_dup(av); + TOPPTR(nss,ix) = av_dup(av, param); break; case SAVEt_PADSV: longval = (long)POPLONG(ss,ix); @@ -9413,7 +9535,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup(sv); + TOPPTR(nss,ix) = sv_dup(sv, param); break; default: Perl_croak(aTHX_ "panic: ss_dup inconsistency"); @@ -9423,10 +9545,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) return nss; } -#ifdef PERL_OBJECT -#include "XSUB.h" -#endif - /* =for apidoc perl_clone @@ -9436,16 +9554,21 @@ Create and return a new interpreter by cloning the current one. */ /* XXX the above needs expanding by someone who actually understands it ! */ +EXTERN_C PerlInterpreter * +perl_clone_host(PerlInterpreter* proto_perl, UV flags); PerlInterpreter * perl_clone(PerlInterpreter *proto_perl, UV flags) { -#ifdef PERL_OBJECT - CPerlObj *pPerl = (CPerlObj*)proto_perl; -#endif - #ifdef PERL_IMPLICIT_SYS - return perl_clone_using(proto_perl, flags, + + /* perlhost.h so we need to call into it + to clone the host, CPerlHost should have a c interface, sky */ + + if (flags & CLONEf_CLONE_HOST) { + return perl_clone_host(proto_perl,flags); + } + return perl_clone_using(proto_perl, flags, proto_perl->IMem, proto_perl->IMemShared, proto_perl->IMemParse, @@ -9470,24 +9593,21 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, * their pointers copied. */ IV i; -# ifdef PERL_OBJECT - CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO, - ipD, ipS, ipP); - PERL_SET_THX(pPerl); -# else /* !PERL_OBJECT */ + clone_params* param = (clone_params*) malloc(sizeof(clone_params)); + PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); PERL_SET_THX(my_perl); -# ifdef DEBUGGING +# ifdef DEBUGGING memset(my_perl, 0xab, sizeof(PerlInterpreter)); PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; PL_retstack = 0; PL_sig_pending = 0; -# else /* !DEBUGGING */ +# else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); -# endif /* DEBUGGING */ +# endif /* DEBUGGING */ /* host pointers */ PL_Mem = ipM; @@ -9499,12 +9619,14 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_Dir = ipD; PL_Sock = ipS; PL_Proc = ipP; -# endif /* PERL_OBJECT */ #else /* !PERL_IMPLICIT_SYS */ IV i; + clone_params* param = (clone_params*) malloc(sizeof(clone_params)); PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); PERL_SET_THX(my_perl); + + # ifdef DEBUGGING memset(my_perl, 0xab, sizeof(PerlInterpreter)); PL_markstack = 0; @@ -9516,6 +9638,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Zero(my_perl, 1, PerlInterpreter); # endif /* DEBUGGING */ #endif /* PERL_IMPLICIT_SYS */ + param->flags = flags; /* arena roots */ PL_xiv_arenaroot = NULL; @@ -9553,6 +9676,11 @@ 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); +#endif + /* create SV map for pointer relocation */ PL_ptr_table = ptr_table_new(); @@ -9562,11 +9690,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); -#ifdef PERL_OBJECT - SvUPGRADE(&PL_sv_no, SVt_PVNV); -#else SvANY(&PL_sv_no) = new_XPVNV(); -#endif SvREFCNT(&PL_sv_no) = (~(U32)0)/2; SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0); @@ -9575,11 +9699,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvNVX(&PL_sv_no) = 0; ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); -#ifdef PERL_OBJECT - SvUPGRADE(&PL_sv_yes, SVt_PVNV); -#else SvANY(&PL_sv_yes) = new_XPVNV(); -#endif SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1); @@ -9599,9 +9719,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_compiling.cop_file = SAVEPV(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); + PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param); if (!specialCopIO(PL_compiling.cop_io)) - PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io); + PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param); PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl); /* pseudo environmental stuff */ @@ -9612,17 +9732,21 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, while (i-- > 0) { PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]); } - PL_clone_callbacks = newAV(); /* Setup array of objects to callbackon */ - PL_envgv = gv_dup(proto_perl->Ienvgv); - PL_incgv = gv_dup(proto_perl->Iincgv); - PL_hintgv = gv_dup(proto_perl->Ihintgv); + + + param->stashes = newAV(); /* Setup array of objects to call clone on */ + + + PL_envgv = gv_dup(proto_perl->Ienvgv, param); + PL_incgv = gv_dup(proto_perl->Iincgv, param); + PL_hintgv = gv_dup(proto_perl->Ihintgv, param); PL_origfilename = SAVEPV(proto_perl->Iorigfilename); - PL_diehook = sv_dup_inc(proto_perl->Idiehook); - PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook); + PL_diehook = sv_dup_inc(proto_perl->Idiehook, param); + PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param); /* switches */ PL_minus_c = proto_perl->Iminus_c; - PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel); + PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param); PL_localpatches = proto_perl->Ilocalpatches; PL_splitstr = proto_perl->Isplitstr; PL_preprocess = proto_perl->Ipreprocess; @@ -9637,14 +9761,15 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_sawampersand = proto_perl->Isawampersand; PL_unsafe = proto_perl->Iunsafe; PL_inplace = SAVEPV(proto_perl->Iinplace); - PL_e_script = sv_dup_inc(proto_perl->Ie_script); + PL_e_script = sv_dup_inc(proto_perl->Ie_script, param); PL_perldb = proto_perl->Iperldb; PL_perl_destruct_level = proto_perl->Iperl_destruct_level; + PL_exit_flags = proto_perl->Iexit_flags; /* magical thingies */ /* XXX time(&PL_basetime) when asked for? */ PL_basetime = proto_perl->Ibasetime; - PL_formfeed = sv_dup(proto_perl->Iformfeed); + PL_formfeed = sv_dup(proto_perl->Iformfeed, param); PL_maxsysfd = proto_perl->Imaxsysfd; PL_multiline = proto_perl->Imultiline; @@ -9653,42 +9778,57 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_statusvalue_vms = proto_perl->Istatusvalue_vms; #endif + /* 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((IV)re_dup((REGEXP *) + SvIVX(regexen[i]), param)) + )); + } + } + PL_regex_pad = AvARRAY(PL_regex_padav); + /* shortcuts to various I/O objects */ - PL_stdingv = gv_dup(proto_perl->Istdingv); - PL_stderrgv = gv_dup(proto_perl->Istderrgv); - PL_defgv = gv_dup(proto_perl->Idefgv); - PL_argvgv = gv_dup(proto_perl->Iargvgv); - PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv); - PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack); + PL_stdingv = gv_dup(proto_perl->Istdingv, param); + PL_stderrgv = gv_dup(proto_perl->Istderrgv, param); + PL_defgv = gv_dup(proto_perl->Idefgv, param); + PL_argvgv = gv_dup(proto_perl->Iargvgv, param); + PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param); + PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param); /* shortcuts to regexp stuff */ - PL_replgv = gv_dup(proto_perl->Ireplgv); + PL_replgv = gv_dup(proto_perl->Ireplgv, param); /* shortcuts to misc objects */ - PL_errgv = gv_dup(proto_perl->Ierrgv); + PL_errgv = gv_dup(proto_perl->Ierrgv, param); /* shortcuts to debugging objects */ - PL_DBgv = gv_dup(proto_perl->IDBgv); - PL_DBline = gv_dup(proto_perl->IDBline); - PL_DBsub = gv_dup(proto_perl->IDBsub); - PL_DBsingle = sv_dup(proto_perl->IDBsingle); - PL_DBtrace = sv_dup(proto_perl->IDBtrace); - PL_DBsignal = sv_dup(proto_perl->IDBsignal); - PL_lineary = av_dup(proto_perl->Ilineary); - PL_dbargs = av_dup(proto_perl->Idbargs); + PL_DBgv = gv_dup(proto_perl->IDBgv, param); + PL_DBline = gv_dup(proto_perl->IDBline, param); + PL_DBsub = gv_dup(proto_perl->IDBsub, param); + PL_DBsingle = sv_dup(proto_perl->IDBsingle, param); + PL_DBtrace = sv_dup(proto_perl->IDBtrace, param); + PL_DBsignal = sv_dup(proto_perl->IDBsignal, param); + PL_lineary = av_dup(proto_perl->Ilineary, param); + PL_dbargs = av_dup(proto_perl->Idbargs, param); /* symbol tables */ - PL_defstash = hv_dup_inc(proto_perl->Tdefstash); - PL_curstash = hv_dup(proto_perl->Tcurstash); - PL_nullstash = hv_dup(proto_perl->Inullstash); - PL_debstash = hv_dup(proto_perl->Idebstash); - PL_globalstash = hv_dup(proto_perl->Iglobalstash); - PL_curstname = sv_dup_inc(proto_perl->Icurstname); - - PL_beginav = av_dup_inc(proto_perl->Ibeginav); - PL_endav = av_dup_inc(proto_perl->Iendav); - PL_checkav = av_dup_inc(proto_perl->Icheckav); - PL_initav = av_dup_inc(proto_perl->Iinitav); + PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param); + PL_curstash = hv_dup(proto_perl->Tcurstash, param); + PL_nullstash = hv_dup(proto_perl->Inullstash, param); + PL_debstash = hv_dup(proto_perl->Idebstash, param); + PL_globalstash = hv_dup(proto_perl->Iglobalstash, param); + PL_curstname = sv_dup_inc(proto_perl->Icurstname, param); + + PL_beginav = av_dup_inc(proto_perl->Ibeginav, param); + PL_endav = av_dup_inc(proto_perl->Iendav, param); + PL_checkav = av_dup_inc(proto_perl->Icheckav, param); + PL_initav = av_dup_inc(proto_perl->Iinitav, param); PL_sub_generation = proto_perl->Isub_generation; @@ -9696,7 +9836,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_forkprocess = proto_perl->Iforkprocess; /* subprocess state */ - PL_fdpid = av_dup_inc(proto_perl->Ifdpid); + PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param); /* internal state */ PL_tainting = proto_perl->Itainting; @@ -9707,7 +9847,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_op_mask = Nullch; /* current interpreter roots */ - PL_main_cv = cv_dup_inc(proto_perl->Imain_cv); + PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param); PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); PL_main_start = proto_perl->Imain_start; PL_eval_root = proto_perl->Ieval_root; @@ -9724,12 +9864,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_Cmd = Nullch; PL_gensym = proto_perl->Igensym; PL_preambled = proto_perl->Ipreambled; - PL_preambleav = av_dup_inc(proto_perl->Ipreambleav); + PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param); PL_laststatval = proto_perl->Ilaststatval; PL_laststype = proto_perl->Ilaststype; PL_mess_sv = Nullsv; - PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv); + PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param); PL_ofmt = SAVEPV(proto_perl->Iofmt); /* interpreter atexit processing */ @@ -9740,16 +9880,16 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } else PL_exitlist = (PerlExitListEntry*)NULL; - PL_modglobal = hv_dup_inc(proto_perl->Imodglobal); + PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param); PL_profiledata = NULL; PL_rsfp = fp_dup(proto_perl->Irsfp, '<'); /* PL_rsfp_filters entries have fake IoDIRP() */ - PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters); + PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param); - PL_compcv = cv_dup(proto_perl->Icompcv); - PL_comppad = av_dup(proto_perl->Icomppad); - PL_comppad_name = av_dup(proto_perl->Icomppad_name); + PL_compcv = cv_dup(proto_perl->Icompcv, param); + PL_comppad = av_dup(proto_perl->Icomppad, param); + PL_comppad_name = av_dup(proto_perl->Icomppad_name, param); PL_comppad_name_fill = proto_perl->Icomppad_name_fill; PL_comppad_name_floor = proto_perl->Icomppad_name_floor; PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table, @@ -9761,7 +9901,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* more statics moved here */ PL_generation = proto_perl->Igeneration; - PL_DBcv = cv_dup(proto_perl->IDBcv); + PL_DBcv = cv_dup(proto_perl->IDBcv, param); PL_in_clean_objs = proto_perl->Iin_clean_objs; PL_in_clean_all = proto_perl->Iin_clean_all; @@ -9779,7 +9919,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_origalen = proto_perl->Iorigalen; PL_pidstatus = newHV(); /* XXX flag for cloning? */ PL_osname = SAVEPV(proto_perl->Iosname); - PL_sh_path = SAVEPV(proto_perl->Ish_path); + PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */ PL_sighandlerp = proto_perl->Isighandlerp; @@ -9789,7 +9929,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #ifdef CSH PL_cshlen = proto_perl->Icshlen; - PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen); + PL_cshname = proto_perl->Icshname; /* XXX never deallocated */ #endif PL_lex_state = proto_perl->Ilex_state; @@ -9798,8 +9938,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_lex_formbrack = proto_perl->Ilex_formbrack; PL_lex_dojoin = proto_perl->Ilex_dojoin; PL_lex_starts = proto_perl->Ilex_starts; - PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff); - PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl); + PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param); + PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param); PL_lex_op = proto_perl->Ilex_op; PL_lex_inpat = proto_perl->Ilex_inpat; PL_lex_inwhat = proto_perl->Ilex_inwhat; @@ -9814,7 +9954,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Copy(proto_perl->Inexttype, PL_nexttype, 5, I32); PL_nexttoke = proto_perl->Inexttoke; - PL_linestr = sv_dup_inc(proto_perl->Ilinestr); + PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param); i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr); PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i); i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr); @@ -9836,7 +9976,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_error_count = proto_perl->Ierror_count; PL_subline = proto_perl->Isubline; - PL_subname = sv_dup_inc(proto_perl->Isubname); + PL_subname = sv_dup_inc(proto_perl->Isubname, param); PL_min_intro_pending = proto_perl->Imin_intro_pending; PL_max_intro_pending = proto_perl->Imax_intro_pending; @@ -9850,7 +9990,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i); PL_last_lop_op = proto_perl->Ilast_lop_op; PL_in_my = proto_perl->Iin_my; - PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash); + PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param); #ifdef FCRYPT PL_cryptseen = proto_perl->Icryptseen; #endif @@ -9871,27 +10011,27 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_numeric_name = SAVEPV(proto_perl->Inumeric_name); PL_numeric_standard = proto_perl->Inumeric_standard; PL_numeric_local = proto_perl->Inumeric_local; - PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv); + PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param); #endif /* !USE_LOCALE_NUMERIC */ /* utf8 character classes */ - PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum); - PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc); - PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii); - PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha); - PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space); - PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl); - PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph); - PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit); - PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper); - PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower); - PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print); - PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct); - PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit); - PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark); - PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper); - PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle); - PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower); + PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param); + PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param); + PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param); + PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param); + PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param); + PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param); + PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param); + PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param); + PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param); + PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param); + PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param); + PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param); + PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param); + PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); + 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); /* swatch cache */ PL_last_swash_hv = Nullhv; /* reinits on demand */ @@ -9924,8 +10064,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Newz(0, PL_psig_ptr, SIG_SIZE, SV*); Newz(0, PL_psig_name, SIG_SIZE, SV*); for (i = 1; i < SIG_SIZE; i++) { - PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]); - PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]); + PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param); + PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param); } } else { @@ -9943,7 +10083,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Newz(50, PL_tmps_stack, PL_tmps_max, SV*); i = 0; while (i <= PL_tmps_ix) { - PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]); + PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param); ++i; } @@ -9972,11 +10112,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32); /* NOTE: si_dup() looks at PL_markstack */ - PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo); + PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param); /* PL_curstack = PL_curstackinfo->si_stack; */ - PL_curstack = av_dup(proto_perl->Tcurstack); - PL_mainstack = av_dup(proto_perl->Tmainstack); + PL_curstack = av_dup(proto_perl->Tcurstack, param); + PL_mainstack = av_dup(proto_perl->Tmainstack, param); /* next PUSHs() etc. set *(PL_stack_sp+1) */ PL_stack_base = AvARRAY(PL_curstack); @@ -9989,7 +10129,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_savestack_ix = proto_perl->Tsavestack_ix; PL_savestack_max = proto_perl->Tsavestack_max; /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/ - PL_savestack = ss_dup(proto_perl); + PL_savestack = ss_dup(proto_perl, param); } else { init_stacks(); @@ -10007,23 +10147,23 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_statbuf = proto_perl->Tstatbuf; PL_statcache = proto_perl->Tstatcache; - PL_statgv = gv_dup(proto_perl->Tstatgv); - PL_statname = sv_dup_inc(proto_perl->Tstatname); + PL_statgv = gv_dup(proto_perl->Tstatgv, param); + PL_statname = sv_dup_inc(proto_perl->Tstatname, param); #ifdef HAS_TIMES PL_timesbuf = proto_perl->Ttimesbuf; #endif PL_tainted = proto_perl->Ttainted; PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */ - PL_nrs = sv_dup_inc(proto_perl->Tnrs); - PL_rs = sv_dup_inc(proto_perl->Trs); - PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv); - PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv); - PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv); + PL_nrs = sv_dup_inc(proto_perl->Tnrs, param); + PL_rs = sv_dup_inc(proto_perl->Trs, param); + PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param); + PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param); + PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param); PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */ - PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget); - PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget); - PL_formtarget = sv_dup(proto_perl->Tformtarget); + PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param); + PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param); + PL_formtarget = sv_dup(proto_perl->Tformtarget, param); PL_restartop = proto_perl->Trestartop; PL_in_eval = proto_perl->Tin_eval; @@ -10034,7 +10174,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #ifdef PERL_FLEXIBLE_EXCEPTIONS PL_protect = proto_perl->Tprotect; #endif - PL_errors = sv_dup_inc(proto_perl->Terrors); + PL_errors = sv_dup_inc(proto_perl->Terrors, param); PL_av_fetch_sv = Nullsv; PL_hv_fetch_sv = Nullsv; Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */ @@ -10043,9 +10183,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_dumpindent = proto_perl->Tdumpindent; PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl); - PL_sortstash = hv_dup(proto_perl->Tsortstash); - PL_firstgv = gv_dup(proto_perl->Tfirstgv); - PL_secondgv = gv_dup(proto_perl->Tsecondgv); + PL_sortstash = hv_dup(proto_perl->Tsortstash, param); + PL_firstgv = gv_dup(proto_perl->Tfirstgv, param); + PL_secondgv = gv_dup(proto_perl->Tsecondgv, param); PL_sortcxix = proto_perl->Tsortcxix; PL_efloatbuf = Nullch; /* reinits on demand */ PL_efloatsize = 0; /* reinits on demand */ @@ -10099,6 +10239,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_reg_re = (regexp*)NULL; PL_reg_ganch = Nullch; PL_reg_sv = Nullsv; + PL_reg_sv_utf8 = FALSE; PL_reg_magic = (MAGIC*)NULL; PL_reg_oldpos = 0; PL_reg_oldcurpm = (PMOP*)NULL; @@ -10120,6 +10261,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_reginterp_cnt = 0; PL_reg_starttry = 0; + /* Pluggable optimizer */ + PL_peepp = proto_perl->Tpeepp; + if (!(flags & CLONEf_KEEP_PTR_TABLE)) { ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; @@ -10128,15 +10272,15 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* Call the ->CLONE method, if it exists, for each of the stashes identified by sv_dup() above. */ - while(av_len(PL_clone_callbacks) != -1) { - HV* stash = (HV*) av_shift(PL_clone_callbacks); + while(av_len(param->stashes) != -1) { + HV* stash = (HV*) av_shift(param->stashes); GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0); if (cloner && GvCV(cloner)) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(newSVpv(HvNAME(stash), 0)); + XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0))); PUTBACK; call_sv((SV*)GvCV(cloner), G_DISCARD); FREETMPS; @@ -10144,18 +10288,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } } -#ifdef PERL_OBJECT - return (PerlInterpreter*)pPerl; -#else + SvREFCNT_dec(param->stashes); + Safefree(param); + return my_perl; -#endif } -#else /* !USE_ITHREADS */ - -#ifdef PERL_OBJECT -#include "XSUB.h" -#endif - #endif /* USE_ITHREADS */ -