X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=21d0a8e9c2607afb4fe1a7ea37eed5b7cc70764b;hb=f9bcfeacc119e37fd70816a2cb4678fded53e8d1;hp=0a27e1aaca7e9a1dc96c04bbde53854ac2271eb1;hpb=9b38784150c0aca5746105b5f00bfc653322bcd1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 0a27e1a..21d0a8e 100644 --- a/sv.c +++ b/sv.c @@ -607,7 +607,7 @@ Perl_sv_clean_all(pTHX) struct arena_desc { char *arena; /* the raw storage, allocated aligned */ size_t size; /* its size ~4k typ */ - U32 misc; /* type, and in future other things. */ + svtype utype; /* bodytype stored in arena */ }; struct arena_set; @@ -720,7 +720,7 @@ Perl_sv_free_arenas(pTHX) TBD: export properly for hv.c: S_more_he(). */ void* -Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc) +Perl_get_arena(pTHX_ const size_t arena_size, const svtype bodytype) { dVAR; struct arena_desc* adesc; @@ -749,7 +749,7 @@ Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc) Newx(adesc->arena, arena_size, char); adesc->size = arena_size; - adesc->misc = misc; + adesc->utype = bodytype; DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n", curr, (void*)adesc->arena, (UV)arena_size)); @@ -1372,6 +1372,10 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) break; + case SVt_REGEXP: + /* This ensures that SvTHINKFIRST(sv) is true, and hence that + sv_force_normal_flags(sv) is called. */ + SvFAKE_on(sv); case SVt_PVIV: /* XXX Is this still needed? Was it ever needed? Surely as there is no route from NV to PVIV, NOK can never be true */ @@ -1382,7 +1386,6 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) case SVt_PVGV: case SVt_PVCV: case SVt_PVLV: - case SVt_REGEXP: case SVt_PVMG: case SVt_PVNV: case SVt_PV: @@ -1431,17 +1434,13 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) if (new_type == SVt_PVIO) { IO * const io = MUTABLE_IO(sv); - GV *iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV); + GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); SvOBJECT_on(io); /* Clear the stashcache because a new IO could overrule a package name */ hv_clear(PL_stashcache); - /* unless exists($main::{FileHandle}) and - defined(%main::FileHandle::) */ - if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv)))) - iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV); SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); IoPAGE_LEN(sv) = 60; } @@ -1456,14 +1455,14 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) (unsigned long)new_type); } - if (old_type_details->arena) { - /* If there was an old body, then we need to free it. - Note that there is an assumption that all bodies of types that - can be upgraded came from arenas. Only the more complex non- - upgradable types are allowed to be directly malloc()ed. */ + if (old_type > SVt_IV) { /* SVt_IVs are overloaded for PTEs */ #ifdef PURIFY my_safefree(old_body); #else + /* Note that there is an assumption that all bodies of types that + can be upgraded came from arenas. Only the more complex non- + upgradable types are allowed to be directly malloc()ed. */ + assert(old_type_details->arena); del_body((void*)((char*)old_body + old_type_details->offset), &PL_body_roots[old_type]); #endif @@ -2990,11 +2989,17 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags gv_efullname3(buffer, gv, "*"); SvFLAGS(gv) |= wasfake; - assert(SvPOK(buffer)); - if (lp) { - *lp = SvCUR(buffer); + if (SvPOK(buffer)) { + if (lp) { + *lp = SvCUR(buffer); + } + return SvPVX(buffer); + } + else { + if (lp) + *lp = 0; + return (char *)""; } - return SvPVX(buffer); } if (lp) @@ -3119,7 +3124,7 @@ Perl_sv_2bool(pTHX_ register SV *const sv) if (SvAMAGIC(sv)) { SV * const tmpsv = AMG_CALLun(sv,bool_); if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) - return (bool)SvTRUE(tmpsv); + return cBOOL(SvTRUE(tmpsv)); } return SvRV(sv) != 0; } @@ -3250,7 +3255,9 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, ST return SvCUR(sv); } - if (SvCUR(sv) > 0) { /* Assume Latin-1/EBCDIC */ + if (SvCUR(sv) == 0) { + if (extra) SvGROW(sv, extra); + } 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 variant * chars in the PV. Given that there isn't such a flag @@ -3678,7 +3685,6 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) SV **location; U8 import_flag = 0; const U32 stype = SvTYPE(sref); - bool mro_changes = FALSE; PERL_ARGS_ASSERT_GLOB_ASSIGN_REF; @@ -3699,8 +3705,6 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) goto common; case SVt_PVAV: location = (SV **) &GvAV(dstr); - if (strEQ(GvNAME((GV*)dstr), "ISA")) - mro_changes = TRUE; import_flag = GVf_IMPORTED_AV; goto common; case SVt_PVIO: @@ -3774,12 +3778,15 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvFLAGS(dstr) |= import_flag; } + if (stype == SVt_PVAV && strEQ(GvNAME((GV*)dstr), "ISA")) { + sv_magic(sref, dstr, PERL_MAGIC_isa, NULL, 0); + mro_isa_changed_in(GvSTASH(dstr)); + } break; } SvREFCNT_dec(dref); if (SvTAINTED(sstr)) SvTAINT(dstr); - if (mro_changes) mro_isa_changed_in(GvSTASH(dstr)); return; } @@ -3891,7 +3898,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } /* Fall through */ #endif - case SVt_REGEXP: case SVt_PV: if (dtype < SVt_PV) sv_upgrade(dstr, SVt_PV); @@ -3914,6 +3920,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } break; + case SVt_REGEXP: + if (dtype < SVt_REGEXP) + sv_upgrade(dstr, SVt_REGEXP); + break; + /* case SVt_BIND: */ case SVt_PVLV: case SVt_PVGV: @@ -4016,6 +4027,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } } } + else if (dtype == SVt_REGEXP && stype == SVt_REGEXP) { + reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr); + } else if (sflags & SVp_POK) { bool isSwipe = 0; @@ -4604,6 +4618,45 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) sv_unref_flags(sv, flags); else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) sv_unglob(sv); + else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) { + /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous + to sv_unglob. We only need it here, so inline it. */ + const svtype new_type = SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV; + SV *const temp = newSV_type(new_type); + void *const temp_p = SvANY(sv); + + if (new_type == SVt_PVMG) { + SvMAGIC_set(temp, SvMAGIC(sv)); + SvMAGIC_set(sv, NULL); + SvSTASH_set(temp, SvSTASH(sv)); + SvSTASH_set(sv, NULL); + } + SvCUR_set(temp, SvCUR(sv)); + /* Remember that SvPVX is in the head, not the body. */ + if (SvLEN(temp)) { + SvLEN_set(temp, SvLEN(sv)); + /* This signals "buffer is owned by someone else" in sv_clear, + which is the least effort way to stop it freeing the buffer. + */ + SvLEN_set(sv, SvLEN(sv)+1); + } else { + /* Their buffer is already owned by someone else. */ + SvPVX(sv) = savepvn(SvPVX(sv), SvCUR(sv)); + SvLEN_set(temp, SvCUR(sv)+1); + } + + /* Now swap the rest of the bodies. */ + + SvFLAGS(sv) &= ~(SVf_FAKE|SVTYPEMASK); + SvFLAGS(sv) |= new_type; + SvANY(sv) = SvANY(temp); + + SvFLAGS(temp) &= ~(SVTYPEMASK); + SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE; + SvANY(temp) = temp_p; + + SvREFCNT_dec(temp); + } } /* @@ -5204,12 +5257,14 @@ Perl_sv_unmagic(pTHX_ SV *const sv, const int type) else mgp = &mg->mg_moremagic; } - if (!SvMAGIC(sv)) { + if (SvMAGIC(sv)) { + if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ + mg_magical(sv); /* else fix the flags now */ + } + else { SvMAGICAL_off(sv); SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; - SvMAGIC_set(sv, NULL); } - return 0; } @@ -5651,7 +5706,8 @@ Perl_sv_clear(pTHX_ register SV *const sv) && !CvCONST(destructor) /* Don't bother calling an empty destructor */ && (CvISXSUB(destructor) - || CvSTART(destructor)->op_next->op_type != OP_LEAVESUB)) + || (CvSTART(destructor) + && (CvSTART(destructor)->op_next->op_type != OP_LEAVESUB)))) { SV* const tmpref = newRV(sv); SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ @@ -6009,12 +6065,17 @@ Perl_sv_len_utf8(pTHX_ register SV *const sv) else { ulen = Perl_utf8_length(aTHX_ s, s + len); if (!SvREADONLY(sv)) { - if (!mg) { + if (!mg && (SvTYPE(sv) < SVt_PVMG || + !(mg = mg_find(sv, PERL_MAGIC_utf8)))) { mg = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0); } assert(mg); mg->mg_len = ulen; + /* For now, treat "overflowed" as "still unknown". + See RT #72924. */ + if (ulen != (STRLEN) mg->mg_len) + mg->mg_len = -1; } } return ulen; @@ -6089,8 +6150,10 @@ S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start assert (uoffset >= uoffset0); - if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache - && (*mgp || (*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { + if (!SvREADONLY(sv) + && PL_utf8cache + && (*mgp || (SvTYPE(sv) >= SVt_PVMG && + (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) { if ((*mgp)->mg_ptr) { STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr; if (cache[0] == uoffset) { @@ -6181,62 +6244,97 @@ S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start /* -=for apidoc sv_pos_u2b +=for apidoc sv_pos_u2b_flags Converts the value pointed to by offsetp from a count of UTF-8 chars from the start of the string, to a count of the equivalent number of bytes; if lenp is non-zero, it does the same to lenp, but this time starting from -the offset, rather than from the start of the string. Handles magic and -type coercion. +the offset, rather than from the start of the string. Handles type coercion. +I is passed to C, and usually should be +C to handle magic. =cut */ /* - * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential + * sv_pos_u2b_flags() uses, like sv_pos_b2u(), the mg_ptr of the potential * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and * byte offsets. See also the comments of S_utf8_mg_pos_cache_update(). * */ -void -Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp) +STRLEN +Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp, + U32 flags) { const U8 *start; STRLEN len; + STRLEN boffset; - PERL_ARGS_ASSERT_SV_POS_U2B; - - if (!sv) - return; + PERL_ARGS_ASSERT_SV_POS_U2B_FLAGS; - start = (U8*)SvPV_const(sv, len); + start = (U8*)SvPV_flags(sv, len, flags); if (len) { - STRLEN uoffset = (STRLEN) *offsetp; const U8 * const send = start + len; MAGIC *mg = NULL; - const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send, - uoffset, 0, 0); - - *offsetp = (I32) boffset; + boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0); if (lenp) { /* Convert the relative offset to absolute. */ - const STRLEN uoffset2 = uoffset + (STRLEN) *lenp; + const STRLEN uoffset2 = uoffset + *lenp; const STRLEN boffset2 = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2, uoffset, boffset) - boffset; *lenp = boffset2; } - } - else { - *offsetp = 0; - if (lenp) - *lenp = 0; + } else { + if (lenp) + *lenp = 0; + boffset = 0; } - return; + return boffset; +} + +/* +=for apidoc sv_pos_u2b + +Converts the value pointed to by offsetp from a count of UTF-8 chars from +the start of the string, to a count of the equivalent number of bytes; if +lenp is non-zero, it does the same to lenp, but this time starting from +the offset, rather than from the start of the string. Handles magic and +type coercion. + +Use C in preference, which correctly handles strings longer +than 2Gb. + +=cut +*/ + +/* + * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential + * PERL_MAGIC_utf8 of the sv to store the mapping between UTF-8 and + * byte offsets. See also the comments of S_utf8_mg_pos_cache_update(). + * + */ + +/* This function is subject to size and sign problems */ + +void +Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp) +{ + PERL_ARGS_ASSERT_SV_POS_U2B; + + if (lenp) { + STRLEN ulen = (STRLEN)*lenp; + *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen, + SV_GMAGIC|SV_CONST_RETURN); + *lenp = (I32)ulen; + } else { + *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL, + SV_GMAGIC|SV_CONST_RETURN); + } } /* Create and update the UTF8 magic offset cache, with the proffered utf8/ @@ -6273,7 +6371,8 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN b if (SvREADONLY(sv)) return; - if (!*mgp) { + if (!*mgp && (SvTYPE(sv) < SVt_PVMG || + !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0); (*mgp)->mg_len = -1; @@ -6470,8 +6569,11 @@ Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp) send = s + byte; - if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache - && (mg = mg_find(sv, PERL_MAGIC_utf8))) { + if (!SvREADONLY(sv) + && PL_utf8cache + && SvTYPE(sv) >= SVt_PVMG + && (mg = mg_find(sv, PERL_MAGIC_utf8))) + { if (mg->mg_ptr) { STRLEN * const cache = (STRLEN *) mg->mg_ptr; if (cache[1] == byte) { @@ -7572,7 +7674,8 @@ string. You are responsible for ensuring that the source string is at least C bytes long. If the C argument is NULL the new SV will be undefined. Currently the only flag bits accepted are C and C. If C is set, then C is called on the result before -returning. If C is set, then it will be set on the new SV. +returning. If C is set, C is considered to be in UTF-8 and the +C flag will be set on the new SV. C is a convenience wrapper for this function, defined as #define newSVpvn_utf8(s, len, u) \ @@ -9156,6 +9259,22 @@ Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted); } + +/* + * Warn of missing argument to sprintf, and then return a defined value + * to avoid inappropriate "use of uninit" warnings [perl #71000]. + */ +#define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */ +STATIC SV* +S_vcatpvfn_missing_argument(pTHX) { + if (ckWARN(WARN_MISSING)) { + Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s", + PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); + } + return &PL_sv_no; +} + + STATIC I32 S_expect_number(pTHX_ char **const pattern) { @@ -9521,9 +9640,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, vecsv = va_arg(*args, SV*); else if (evix) { vecsv = (evix > 0 && evix <= svmax) - ? svargs[evix-1] : &PL_sv_undef; + ? svargs[evix-1] : S_vcatpvfn_missing_argument(aTHX); } else { - vecsv = svix < svmax ? svargs[svix++] : &PL_sv_undef; + vecsv = svix < svmax + ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX); } dotstr = SvPV_const(vecsv, dotstrlen); /* Keep the DO_UTF8 test *after* the SvPV call, else things go @@ -9670,10 +9790,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, if (!vectorize && !args) { if (efix) { const I32 i = efix-1; - argsv = (i >= 0 && i < svmax) ? svargs[i] : &PL_sv_undef; + argsv = (i >= 0 && i < svmax) + ? svargs[i] : S_vcatpvfn_missing_argument(aTHX); } else { argsv = (svix >= 0 && svix < svmax) - ? svargs[svix++] : &PL_sv_undef; + ? svargs[svix++] : S_vcatpvfn_missing_argument(aTHX); } } @@ -10310,6 +10431,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, goto vector; } } + SvTAINT(sv); } /* ========================================================================= @@ -11003,10 +11125,23 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) GvNAME_HEK(dstr) = hek_dup(GvNAME_HEK(dstr), param); /* Don't call sv_add_backref here as it's going to be created as part of the magic cloning of the symbol - table. */ + table--unless this is during a join and the stash + is not actually being cloned. */ /* Danger Will Robinson - GvGP(dstr) isn't initialised at the point of this comment. */ GvSTASH(dstr) = hv_dup(GvSTASH(dstr), param); + if(param->flags & CLONEf_JOIN_IN) { + const HEK * const hvname + = HvNAME_HEK(GvSTASH(dstr)); + if( hvname + && GvSTASH(dstr) == gv_stashpvn( + HEK_KEY(hvname), HEK_LEN(hvname), 0 + ) + ) + Perl_sv_add_backref( + aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr + ); + } GvGP(dstr) = gp_dup(GvGP(sstr), param); (void)GpREFCNT_inc(GvGP(dstr)); } else @@ -11059,6 +11194,11 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) else { while (items-- > 0) *dst_ary++ = sv_dup(*src_ary++, param); + if (!(param->flags & CLONEf_COPY_STACKS) + && AvREIFY(sstr)) + { + av_reify(MUTABLE_AV(dstr)); /* #41138 */ + } } items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr); while (items-- > 0) { @@ -11103,7 +11243,7 @@ Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) daux->xhv_riter = saux->xhv_riter; daux->xhv_eiter = saux->xhv_eiter ? he_dup(saux->xhv_eiter, - (bool)!!HvSHAREKEYS(sstr), param) : 0; + cBOOL(HvSHAREKEYS(sstr)), param) : 0; /* backref array needs refcnt=2; see sv_add_backref */ daux->xhv_backreferences = saux->xhv_backreferences @@ -11556,7 +11696,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); longval = (long)POPBOOL(ss,ix); - TOPBOOL(nss,ix) = (bool)longval; + TOPBOOL(nss,ix) = cBOOL(longval); break; case SAVEt_SET_SVFLAGS: i = POPINT(ss,ix); @@ -11765,27 +11905,40 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); PERL_ARGS_ASSERT_PERL_CLONE_USING; +#else /* !PERL_IMPLICIT_SYS */ + IV i; + CLONE_PARAMS clone_params; + CLONE_PARAMS* param = &clone_params; + PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); + + PERL_ARGS_ASSERT_PERL_CLONE; +#endif /* PERL_IMPLICIT_SYS */ /* for each stash, determine whether its objects should be cloned */ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); PERL_SET_THX(my_perl); -# ifdef DEBUGGING +#ifdef DEBUGGING PoisonNew(my_perl, 1, PerlInterpreter); PL_op = NULL; PL_curcop = NULL; PL_markstack = 0; PL_scopestack = 0; + PL_scopestack_name = 0; PL_savestack = 0; PL_savestack_ix = 0; PL_savestack_max = -1; PL_sig_pending = 0; PL_parser = NULL; Zero(&PL_debug_pad, 1, struct perl_debug_pad); -# else /* !DEBUGGING */ +# ifdef DEBUG_LEAKING_SCALARS + PL_sv_serial = (((U32)my_perl >> 2) & 0xfff) * 1000000; +# endif +#else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); -# endif /* DEBUGGING */ +#endif /* DEBUGGING */ +#ifdef PERL_IMPLICIT_SYS /* host pointers */ PL_Mem = ipM; PL_MemShared = ipMS; @@ -11796,34 +11949,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_Dir = ipD; PL_Sock = ipS; PL_Proc = ipP; -#else /* !PERL_IMPLICIT_SYS */ - IV i; - CLONE_PARAMS clone_params; - CLONE_PARAMS* param = &clone_params; - PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); - - PERL_ARGS_ASSERT_PERL_CLONE; - - /* for each stash, determine whether its objects should be cloned */ - S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); - PERL_SET_THX(my_perl); - -# ifdef DEBUGGING - PoisonNew(my_perl, 1, PerlInterpreter); - PL_op = NULL; - PL_curcop = NULL; - PL_markstack = 0; - PL_scopestack = 0; - PL_savestack = 0; - PL_savestack_ix = 0; - PL_savestack_max = -1; - PL_sig_pending = 0; - PL_parser = NULL; - 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; param->proto_perl = proto_perl; @@ -11883,6 +12010,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvNV_set(&PL_sv_yes, 1); ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); + /* dbargs array probably holds garbage */ + PL_dbargs = NULL; + /* create (a non-shared!) shared string table */ PL_strtab = newHV(); HvSHAREKEYS_off(PL_strtab); @@ -12009,7 +12139,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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_dbargs = av_dup(proto_perl->Idbargs, param); /* symbol tables */ PL_defstash = hv_dup_inc(proto_perl->Idefstash, param); @@ -12180,6 +12309,16 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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_X_begin = sv_dup_inc(proto_perl->Iutf8_X_begin, param); + PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param); + PL_utf8_X_prepend = sv_dup_inc(proto_perl->Iutf8_X_prepend, param); + PL_utf8_X_non_hangul = sv_dup_inc(proto_perl->Iutf8_X_non_hangul, param); + PL_utf8_X_L = sv_dup_inc(proto_perl->Iutf8_X_L, param); + PL_utf8_X_LV = sv_dup_inc(proto_perl->Iutf8_X_LV, param); + PL_utf8_X_LVT = sv_dup_inc(proto_perl->Iutf8_X_LVT, param); + PL_utf8_X_T = sv_dup_inc(proto_perl->Iutf8_X_T, param); + PL_utf8_X_V = sv_dup_inc(proto_perl->Iutf8_X_V, param); + PL_utf8_X_LV_LVT_V = sv_dup_inc(proto_perl->Iutf8_X_LV_LVT_V, 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); @@ -12255,8 +12394,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_tmps_max = proto_perl->Itmps_max; PL_tmps_floor = proto_perl->Itmps_floor; Newx(PL_tmps_stack, PL_tmps_max, SV*); - sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, PL_tmps_ix, - param); + sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, + PL_tmps_ix+1, param); /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ i = proto_perl->Imarkstack_max - proto_perl->Imarkstack; @@ -12275,6 +12414,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Newxz(PL_scopestack, PL_scopestack_max, I32); Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); +#ifdef DEBUGGING + Newxz(PL_scopestack_name, PL_scopestack_max, const char *); + Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *); +#endif /* NOTE: si_dup() looks at PL_markstack */ PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param);