X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=193c9fb0f5d1a2e91757fbd4f903635c9b1ba207;hb=f9dc862fc43278b696e6cacef943fbe534e5baba;hp=0bae3ce72af44d2660435f02ec52686bf4e31eb4;hpb=771208afd937a008c2ced72cfe214c2dbc98985e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 0bae3ce..193c9fb 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. @@ -121,7 +123,7 @@ Private API to rest of sv.c Public API: - sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas() + sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas() =cut @@ -214,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, @@ -271,7 +275,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 +289,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; } } @@ -293,16 +297,19 @@ S_visit(pTHX_ SVFUNC_t f) return visited; } +#ifdef DEBUGGING + /* 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"); sv_dump(sv); } } +#endif /* =for apidoc sv_report_used @@ -315,13 +322,15 @@ Dump the contents of all SVs not yet freed. (Debugging aid). void Perl_sv_report_used(pTHX) { +#ifdef DEBUGGING visit(do_report_used); +#endif } /* called by sv_clean_objs() for each live SV */ static void -do_clean_objs(pTHXo_ SV *sv) +do_clean_objs(pTHX_ SV *sv) { SV* rv; @@ -345,7 +354,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 +393,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 +405,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 +547,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 +1216,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 */ @@ -1415,8 +1424,8 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) SvPVX(sv) = 0; HvFILL(sv) = 0; HvMAX(sv) = 0; - HvKEYS(sv) = 0; - SvNVX(sv) = 0.0; + HvTOTALKEYS(sv) = 0; + HvPLACEHOLDERS(sv) = 0; SvMAGIC(sv) = magic; SvSTASH(sv) = stash; HvRITER(sv) = 0; @@ -1567,8 +1576,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 +1623,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 +1734,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 */ @@ -1747,61 +1763,70 @@ Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) STATIC void S_not_a_number(pTHX_ SV *sv) { - char tmpbuf[64]; - char *d = tmpbuf; - char *limit = tmpbuf + sizeof(tmpbuf) - 8; - /* each *s can expand to 4 chars + "...\0", - i.e. need room for 8 chars */ - - char *s, *end; - for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) { - int ch = *s & 0xFF; - if (ch & 128 && !isPRINT_LC(ch)) { - *d++ = 'M'; - *d++ = '-'; - ch &= 127; - } - if (ch == '\n') { - *d++ = '\\'; - *d++ = 'n'; - } - else if (ch == '\r') { - *d++ = '\\'; - *d++ = 'r'; - } - else if (ch == '\f') { - *d++ = '\\'; - *d++ = 'f'; - } - else if (ch == '\\') { - *d++ = '\\'; - *d++ = '\\'; - } - else if (ch == '\0') { - *d++ = '\\'; - *d++ = '0'; - } - else if (isPRINT_LC(ch)) - *d++ = ch; - else { - *d++ = '^'; - *d++ = toCTRL(ch); - } - } - if (s < end) { - *d++ = '.'; - *d++ = '.'; - *d++ = '.'; + SV *dsv; + char tmpbuf[64]; + char *pv; + + if (DO_UTF8(sv)) { + dsv = sv_2mortal(newSVpv("", 0)); + pv = sv_uni_display(dsv, sv, 10, 0); + } else { + char *d = tmpbuf; + char *limit = tmpbuf + sizeof(tmpbuf) - 8; + /* each *s can expand to 4 chars + "...\0", + i.e. need room for 8 chars */ + + char *s, *end; + for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) { + int ch = *s & 0xFF; + if (ch & 128 && !isPRINT_LC(ch)) { + *d++ = 'M'; + *d++ = '-'; + ch &= 127; + } + if (ch == '\n') { + *d++ = '\\'; + *d++ = 'n'; + } + else if (ch == '\r') { + *d++ = '\\'; + *d++ = 'r'; + } + else if (ch == '\f') { + *d++ = '\\'; + *d++ = 'f'; + } + else if (ch == '\\') { + *d++ = '\\'; + *d++ = '\\'; + } + else if (ch == '\0') { + *d++ = '\\'; + *d++ = '0'; + } + else if (isPRINT_LC(ch)) + *d++ = ch; + else { + *d++ = '^'; + *d++ = toCTRL(ch); + } + } + if (s < end) { + *d++ = '.'; + *d++ = '.'; + *d++ = '.'; + } + *d = '\0'; + pv = tmpbuf; } - *d = '\0'; if (PL_op) Perl_warner(aTHX_ WARN_NUMERIC, - "Argument \"%s\" isn't numeric in %s", tmpbuf, - PL_op_desc[PL_op->op_type]); + "Argument \"%s\" isn't numeric in %s", pv, + OP_DESC(PL_op)); else Perl_warner(aTHX_ WARN_NUMERIC, - "Argument \"%s\" isn't numeric", tmpbuf); + "Argument \"%s\" isn't numeric", pv); } /* @@ -1918,7 +1943,7 @@ Perl_looks_like_number(pTHX_ SV *sv) STATIC int S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) { - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { (void)SvIOKp_on(sv); (void)SvNOK_on(sv); @@ -2045,7 +2070,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 +2081,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 +2137,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); @@ -2145,7 +2170,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) SvIVX(sv) = -(IV)value; } else { /* Too negative for an IV. This is a double upgrade, but - I'm assuming it will be be rare. */ + I'm assuming it will be rare. */ if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); SvNOK_on(sv); @@ -2172,7 +2197,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n", PTR2UV(sv), SvNVX(sv))); #else - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n", + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n", PTR2UV(sv), SvNVX(sv))); #endif @@ -2228,7 +2253,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) this NV is in the preserved range, therefore: */ if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) < (UV)IV_MAX)) { - Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); + Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); } } else { /* IN_UV NOT_INT @@ -2339,7 +2364,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 +2375,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 +2427,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); @@ -2436,7 +2461,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) SvIVX(sv) = -(IV)value; } else { /* Too negative for an IV. This is a double upgrade, but - I'm assuming it will be be rare. */ + I'm assuming it will be rare. */ if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); SvNOK_on(sv); @@ -2460,7 +2485,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n", PTR2UV(sv), SvNVX(sv))); #else - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n", + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n", PTR2UV(sv), SvNVX(sv))); #endif @@ -2515,7 +2540,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) this NV is in the preserved range, therefore: */ if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)) < (UV)IV_MAX)) { - Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); + Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX); } } else sv_2iuv_non_preserve (sv, numtype); @@ -2611,7 +2636,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) #else DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n", + PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); @@ -2619,10 +2644,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 +2669,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)); @@ -2740,7 +2765,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) #else DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n", + PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); @@ -2857,7 +2882,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 @@ -2986,8 +3011,15 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) default: s = "UNKNOWN"; break; } tsv = NEWSV(0,0); - if (SvOBJECT(sv)) - Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); + if (SvOBJECT(sv)) { + HV *svs = SvSTASH(sv); + Perl_sv_setpvf( + aTHX_ tsv, "%s=%s", + /* [20011101.072] This bandaid for C + should eventually be removed. AMS 20011103 */ + (svs ? HvNAME(svs) : ""), s + ); + } else sv_setpv(tsv, s); Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv)); @@ -3189,7 +3221,7 @@ Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) =for apidoc sv_2bool This function is only called on magical items, and is only used by -sv_true() or its macro equivalent. +sv_true() or its macro equivalent. =cut */ @@ -3205,7 +3237,7 @@ Perl_sv_2bool(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpsv; if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) && - (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv)))) + (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) return SvTRUE(tmpsv); return SvRV(sv) != 0; } @@ -3284,30 +3316,34 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) sv_force_normal(sv); } - /* This function could be much more efficient if we had a FLAG in SVs - * to signal if there are any hibit chars in the PV. - * Given that there isn't make loop fast as possible - */ - s = (U8 *) SvPVX(sv); - e = (U8 *) SvEND(sv); - t = s; - while (t < e) { - U8 ch = *t++; - if ((hibit = !NATIVE_IS_INVARIANT(ch))) - break; - } - if (hibit) { - STRLEN len; - - len = SvCUR(sv) + 1; /* Plus the \0 */ - SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len); - SvCUR(sv) = len - 1; - if (SvLEN(sv) != 0) - Safefree(s); /* No longer using what was there before. */ - SvLEN(sv) = len; /* No longer know the real size. */ + if (PL_encoding) + Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding); + else { /* Assume Latin-1/EBCDIC */ + /* This function could be much more efficient if we + * had a FLAG in SVs to signal if there are any hibit + * chars in the PV. Given that there isn't such a flag + * make the loop as fast as possible. */ + s = (U8 *) SvPVX(sv); + e = (U8 *) SvEND(sv); + t = s; + while (t < e) { + U8 ch = *t++; + if ((hibit = !NATIVE_IS_INVARIANT(ch))) + break; + } + if (hibit) { + STRLEN len; + + len = SvCUR(sv) + 1; /* Plus the \0 */ + SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len); + SvCUR(sv) = len - 1; + if (SvLEN(sv) != 0) + Safefree(s); /* No longer using what was there before. */ + SvLEN(sv) = len; /* No longer know the real size. */ + } + /* Mark as UTF-8 even if no hibit - saves scanning loop */ + SvUTF8_on(sv); } - /* Mark as UTF-8 even if no hibit - saves scanning loop */ - SvUTF8_on(sv); return SvCUR(sv); } @@ -3346,7 +3382,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 +3397,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 +3624,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 +3648,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 +3694,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 +4136,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); @@ -4269,8 +4305,15 @@ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) if (!ssv) return; if ((spv = SvPV(ssv, slen))) { - bool sutf8 = DO_UTF8(ssv); - bool dutf8; + /* sutf8 and dutf8 were type bool, but under USE_ITHREADS, + gcc version 2.95.2 20000220 (Debian GNU/Linux) for + Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously + get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though + dsv->sv_flags doesn't have that bit set. + Andy Dougherty 12 Oct 2001 + */ + I32 sutf8 = DO_UTF8(ssv); + I32 dutf8; if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC)) mg_get(dsv); @@ -4415,9 +4458,9 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam 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 - incrementing the object refcount. */ + each other. To prevent a reference loop that would prevent such + objects being freed, we look for such loops and if we find one we + avoid incrementing the object refcount. */ if (!obj || obj == sv || how == PERL_MAGIC_arylen || how == PERL_MAGIC_qr || @@ -4491,11 +4534,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 +4822,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 +4988,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 +5146,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 +5154,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 +5305,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 +5369,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; @@ -5502,13 +5541,19 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) register STDCHAR *bp; register I32 cnt; I32 i = 0; + I32 rspara = 0; SV_CHECK_THINKFIRST(sv); (void)SvUPGRADE(sv, SVt_PV); SvSCREAM_off(sv); - if (RsSNARF(PL_rs)) { + if (PL_curcop == &PL_compiling) { + /* we always read code in line mode */ + rsptr = "\n"; + rslen = 1; + } + else if (RsSNARF(PL_rs)) { rsptr = NULL; rslen = 0; } @@ -5540,6 +5585,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) else if (RsPARA(PL_rs)) { rsptr = "\n\n"; rslen = 2; + rspara = 1; } else { /* Get $/ i.e. PL_rs into same encoding as stream wants */ @@ -5558,7 +5604,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) rslast = rslen ? rsptr[rslen - 1] : '\0'; - if (RsPARA(PL_rs)) { /* have to do this both before and after */ + if (rspara) { /* have to do this both before and after */ do { /* to make sure file boundaries work right */ if (PerlIO_eof(fp)) return 0; @@ -5622,7 +5668,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", + "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); for (;;) { @@ -5656,19 +5702,23 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n", PTR2UV(ptr),(long)cnt)); - PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */ + PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */ +#if 0 DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); +#endif /* This used to call 'filbuf' in stdio form, but as that behaves like getc when cnt <= 0 we use PerlIO_getc here to avoid introducing another abstraction. */ i = PerlIO_getc(fp); /* get more characters */ +#if 0 DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); +#endif cnt = PerlIO_get_cnt(fp); ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ DEBUG_P(PerlIO_printf(Perl_debug_log, @@ -5697,7 +5747,7 @@ thats_really_all_folks: cnt += shortbuffered; DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); - PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */ + PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */ DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), @@ -5764,7 +5814,7 @@ screamer2: } } - if (RsPARA(PL_rs)) { /* have to do this both before and after */ + if (rspara) { /* have to do this both before and after */ while (i != EOF) { /* to make sure file boundaries work right */ i = PerlIO_getc(fp); if (i != '\n') { @@ -5802,6 +5852,8 @@ Perl_sv_inc(pTHX_ register SV *sv) if (SvGMAGICAL(sv)) mg_get(sv); if (SvTHINKFIRST(sv)) { + if (SvREADONLY(sv) && SvFAKE(sv)) + sv_force_normal(sv); if (SvREADONLY(sv)) { if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); @@ -5824,10 +5876,12 @@ 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); + sv_setnv(sv, UV_MAX_P1); else (void)SvIOK_only_UV(sv); ++SvUVX(sv); @@ -5859,7 +5913,7 @@ Perl_sv_inc(pTHX_ register SV *sv) while (isDIGIT(*d)) d++; if (*d) { #ifdef PERL_PRESERVE_IVUV - /* Got to punt this an an integer if needs be, but we don't issue + /* Got to punt this as an integer if needs be, but we don't issue warnings. Probably ought to make the sv_iv_please() that does the conversion if possible, and silently. */ int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL); @@ -5888,7 +5942,7 @@ Perl_sv_inc(pTHX_ register SV *sv) DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv))); #else - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n", + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv))); #endif } @@ -5954,6 +6008,8 @@ Perl_sv_dec(pTHX_ register SV *sv) if (SvGMAGICAL(sv)) mg_get(sv); if (SvTHINKFIRST(sv)) { + if (SvREADONLY(sv) && SvFAKE(sv)) + sv_force_normal(sv); if (SvREADONLY(sv)) { if (PL_curcop != &PL_compiling) Perl_croak(aTHX_ PL_no_modify); @@ -5972,7 +6028,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); @@ -6032,7 +6090,7 @@ Perl_sv_dec(pTHX_ register SV *sv) DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv))); #else - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n", + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv))); #endif } @@ -6045,8 +6103,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 +6132,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 +6154,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 +6237,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 +6390,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 */ @@ -6712,6 +6770,19 @@ Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) return sv_2pv(sv, lp); } +/* For -DCRIPPLED_CC only. See also C. + */ + +char * +Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp) +{ + if (SvPOK(sv)) { + *lp = SvCUR(sv); + return SvPVX(sv); + } + return sv_2pv_flags(sv, lp, 0); +} + /* =for apidoc sv_pvn_force @@ -6755,7 +6826,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); @@ -6893,8 +6964,12 @@ Returns a string describing what the SV is a reference to. char * Perl_sv_reftype(pTHX_ SV *sv, int ob) { - if (ob && SvOBJECT(sv)) - return HvNAME(SvSTASH(sv)); + if (ob && SvOBJECT(sv)) { + HV *svs = SvSTASH(sv); + /* [20011101.072] This bandaid for C should eventually + be removed. AMS 20011103 */ + return (svs ? HvNAME(svs) : ""); + } else { switch (SvTYPE(sv)) { case SVt_NULL: @@ -7169,6 +7244,12 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) else SvAMAGIC_off(sv); + if(SvSMAGICAL(tmpRef)) + if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar)) + mg_set(tmpRef); + + + return sv; } @@ -7642,8 +7723,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV char c; int i; unsigned base = 0; - IV iv; - UV uv; + IV iv = 0; + UV uv = 0; NV nv; STRLEN have; STRLEN need; @@ -7781,7 +7862,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); @@ -7933,13 +8014,15 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (!veclen) continue; if (vec_utf) - iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0); + uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV); else { - iv = *vecstr; + uv = *vecstr; ulen = 1; } vecstr += ulen; veclen -= ulen; + if (plus) + esignbuf[esignlen++] = plus; } else if (args) { switch (intsize) { @@ -7964,14 +8047,17 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV #endif } } - if (iv >= 0) { - uv = iv; - if (plus) - esignbuf[esignlen++] = plus; - } - else { - uv = -iv; - esignbuf[esignlen++] = '-'; + if ( !vectorize ) /* we already set uv above */ + { + if (iv >= 0) { + uv = iv; + if (plus) + esignbuf[esignlen++] = plus; + } + else { + uv = -iv; + esignbuf[esignlen++] = '-'; + } } base = 10; goto integer; @@ -8013,7 +8099,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (!veclen) continue; if (vec_utf) - uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0); + uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV); else { uv = *vecstr; ulen = 1; @@ -8313,8 +8399,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,33 +8408,124 @@ 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) +Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param) { PerlIO *ret; if (!fp) @@ -8360,7 +8537,7 @@ Perl_fp_dup(pTHX_ PerlIO *fp, char type) return ret; /* create anew and remember what it is */ - ret = PerlIO_fdupopen(aTHX_ fp); + ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE); ptr_table_store(PL_ptr_table, fp, ret); return ret; } @@ -8376,10 +8553,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 +8572,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 +8589,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 +8612,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 +8643,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 +8809,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 +8817,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 +8860,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 +8900,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 +8923,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 +8938,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 +8952,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 +8969,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 +8989,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 +9022,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,21 +9045,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? */ - IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr)); + IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param); if (IoOFP(sstr) == IoIFP(sstr)) IoOFP(dstr) = IoIFP(dstr); else - IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr)); + IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param); /* PL_rsfp_filters entries have fake IoDIRP() */ if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP)) IoDIRP(dstr) = dirp_dup(IoDIRP(sstr)); @@ -8881,11 +9070,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 +9085,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 +9100,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 +9122,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 +9133,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 +9144,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 +9155,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 +9207,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 +9246,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 +9259,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 +9271,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 +9300,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 +9316,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 +9365,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 +9375,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 +9391,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 +9404,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 +9423,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 +9469,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 +9487,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(gv, param); c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup(c); iv = POPIV(ss,ix); @@ -9316,7 +9515,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 +9550,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 +9566,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 +9580,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 +9604,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 +9612,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 +9622,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) return nss; } -#ifdef PERL_OBJECT -#include "XSUB.h" -#endif - /* =for apidoc perl_clone @@ -9436,16 +9631,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 +9670,22 @@ 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 */ + Zero(&PL_debug_pad, 1, struct perl_debug_pad); +# else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); -# endif /* DEBUGGING */ +# endif /* DEBUGGING */ /* host pointers */ PL_Mem = ipM; @@ -9499,12 +9697,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; @@ -9512,10 +9712,12 @@ 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 */ #endif /* PERL_IMPLICIT_SYS */ + param->flags = flags; /* arena roots */ PL_xiv_arenaroot = NULL; @@ -9553,6 +9755,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 +9769,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 +9778,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 +9798,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 +9811,24 @@ 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 */ + +#ifdef PERLIO_LAYERS + /* Clone PerlIO tables as soon as we can handle general xx_dup() */ + PerlIO_clone(aTHX_ proto_perl, param); +#endif + + PL_envgv = gv_dup(proto_perl->Ienvgv, param); + PL_incgv = gv_dup(proto_perl->Iincgv, param); + 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 +9843,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; @@ -9652,43 +9859,66 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #ifdef VMS PL_statusvalue_vms = proto_perl->Istatusvalue_vms; #endif + PL_encoding = sv_dup(proto_perl->Iencoding, param); + + /* 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); + av_push(PL_regex_padav, + sv_dup_inc(regexen[0],param)); + for(i = 1; i <= len; i++) { + if(SvREPADTMP(regexen[i])) { + av_push(PL_regex_padav, sv_dup_inc(regexen[i], param)); + } else { + av_push(PL_regex_padav, + SvREFCNT_inc( + newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *, + SvIVX(regexen[i])), param))) + )); + } + } + } + PL_regex_pad = AvARRAY(PL_regex_padav); /* 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_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, 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 +9926,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 +9937,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 +9954,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 +9970,18 @@ 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_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param); + PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param); PL_profiledata = NULL; - PL_rsfp = fp_dup(proto_perl->Irsfp, '<'); + PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param); /* PL_rsfp_filters entries have fake IoDIRP() */ - PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters); + 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 +9993,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 +10011,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 +10021,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 +10030,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 +10046,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 +10068,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 +10082,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 +10103,28 @@ 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); + PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param); /* swatch cache */ PL_last_swash_hv = Nullhv; /* reinits on demand */ @@ -9924,8 +10157,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 +10176,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 +10205,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 +10222,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 +10240,22 @@ 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_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 +10266,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 +10275,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 +10331,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_reg_re = (regexp*)NULL; PL_reg_ganch = Nullch; PL_reg_sv = Nullsv; + PL_reg_match_utf8 = FALSE; PL_reg_magic = (MAGIC*)NULL; PL_reg_oldpos = 0; PL_reg_oldcurpm = (PMOP*)NULL; @@ -10120,23 +10353,26 @@ 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; } - + /* 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 +10380,62 @@ 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 */ +#endif /* USE_ITHREADS */ -#ifdef PERL_OBJECT -#include "XSUB.h" -#endif +/* +=head1 Unicode Support -#endif /* USE_ITHREADS */ +=for apidoc sv_recode_to_utf8 + +The encoding is assumed to be an Encode object, on entry the PV +of the sv is assumed to be octets in that encoding, and the sv +will be converted into Unicode (and UTF-8). + +If the sv already is UTF-8 (or if it is not POK), or if the encoding +is not a reference, nothing is done to the sv. If the encoding is not +an C Encoding object, bad things will happen. +(See F and L). + +The PV of the sv is returned. + +=cut */ + +char * +Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) +{ + if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) { + SV *uni; + STRLEN len; + char *s; + dSP; + ENTER; + SAVETMPS; + PUSHMARK(sp); + EXTEND(SP, 3); + XPUSHs(encoding); + XPUSHs(sv); + XPUSHs(&PL_sv_yes); + PUTBACK; + call_method("decode", G_SCALAR); + SPAGAIN; + uni = POPs; + PUTBACK; + s = SvPV(uni, len); + if (s != SvPVX(sv)) { + SvGROW(sv, len); + Move(s, SvPVX(sv), len, char); + SvCUR_set(sv, len); + } + FREETMPS; + LEAVE; + SvUTF8_on(sv); + } + return SvPVX(sv); +}