X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=48d0e2d2313c3eef89c84ff268e1f4bc8c634928;hb=79af22e4562a90bdaa3aa9d22a11a3fa41f9c6bc;hp=f74adea79bd3d43a7c405989cf8ab21ae5451c09;hpb=70612e96eacfe1d980494617b001dbed7e9eee65;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index f74adea..48d0e2d 100644 --- a/sv.c +++ b/sv.c @@ -287,7 +287,7 @@ S_visit(pTHX_ SVFUNC_t f) svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) { - (FCALL)(aTHXo_ sv); + (FCALL)(aTHX_ sv); ++visited; } } @@ -298,7 +298,7 @@ S_visit(pTHX_ SVFUNC_t f) /* called by sv_report_used() for each live SV */ static void -do_report_used(pTHXo_ SV *sv) +do_report_used(pTHX_ SV *sv) { if (SvTYPE(sv) != SVTYPEMASK) { PerlIO_printf(Perl_debug_log, "****\n"); @@ -323,7 +323,7 @@ Perl_sv_report_used(pTHX) /* called by sv_clean_objs() for each live SV */ static void -do_clean_objs(pTHXo_ SV *sv) +do_clean_objs(pTHX_ SV *sv) { SV* rv; @@ -347,7 +347,7 @@ do_clean_objs(pTHXo_ SV *sv) #ifndef DISABLE_DESTRUCTOR_KLUDGE static void -do_clean_named_objs(pTHXo_ SV *sv) +do_clean_named_objs(pTHX_ SV *sv) { if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) { if ( SvOBJECT(GvSV(sv)) || @@ -386,7 +386,7 @@ Perl_sv_clean_objs(pTHX) /* called by sv_clean_all() for each live SV */ static void -do_clean_all(pTHXo_ SV *sv) +do_clean_all(pTHX_ SV *sv) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); SvFLAGS(sv) |= SVf_BREAK; @@ -540,7 +540,7 @@ Perl_report_uninit(pTHX) { if (PL_op) Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, - " in ", PL_op_desc[PL_op->op_type]); + " in ", OP_DESC(PL_op)); else Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", ""); } @@ -1616,7 +1616,7 @@ Perl_sv_setiv(pTHX_ register SV *sv, IV i) case SVt_PVFM: case SVt_PVIO: Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), - PL_op_desc[PL_op->op_type]); + OP_DESC(PL_op)); } (void)SvIOK_only(sv); /* validate number */ SvIVX(sv) = i; @@ -1727,7 +1727,7 @@ Perl_sv_setnv(pTHX_ register SV *sv, NV num) case SVt_PVFM: case SVt_PVIO: Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); } SvNVX(sv) = num; (void)SvNOK_only(sv); /* validate number */ @@ -1807,7 +1807,7 @@ S_not_a_number(pTHX_ SV *sv) if (PL_op) Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf, - PL_op_desc[PL_op->op_type]); + OP_DESC(PL_op)); else Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf); @@ -2054,7 +2054,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) ) { SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" iv(%g => %"IVdf") (precise)\n", + "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", PTR2UV(sv), SvNVX(sv), SvIVX(sv))); @@ -2065,7 +2065,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) that PV->IV would be better than PV->NV->IV flags already correct - don't set public IOK. */ DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n", + "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n", PTR2UV(sv), SvNVX(sv), SvIVX(sv))); @@ -2348,7 +2348,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) ) { SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" uv(%g => %"IVdf") (precise)\n", + "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n", PTR2UV(sv), SvNVX(sv), SvIVX(sv))); @@ -2359,7 +2359,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) that PV->IV would be better than PV->NV->IV flags already correct - don't set public IOK. */ DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n", + "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n", PTR2UV(sv), SvNVX(sv), SvIVX(sv))); @@ -2628,10 +2628,10 @@ Perl_sv_2nv(pTHX_ register SV *sv) } else if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); - if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) { - SvNOK_on(sv); + if (SvNOKp(sv)) { + return SvNVX(sv); } - else if (SvIOKp(sv)) { + if (SvIOKp(sv)) { SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv); #ifdef NV_PRESERVES_UV SvNOK_on(sv); @@ -3355,7 +3355,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) if (first && ch > 255) { if (PL_op) Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s", - PL_op_desc[PL_op->op_type]); + OP_DESC(PL_op); else Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte"); first = 0; @@ -3370,7 +3370,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) else { if (PL_op) Perl_croak(aTHX_ "Wide character in %s", - PL_op_desc[PL_op->op_type]); + OP_DESC(PL_op)); else Perl_croak(aTHX_ "Wide character"); } @@ -3597,7 +3597,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) case SVt_PVIO: if (PL_op) Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0), - PL_op_name[PL_op->op_type]); + OP_NAME(PL_op)); else Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0)); break; @@ -4278,8 +4278,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); @@ -4500,11 +4507,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; @@ -5507,13 +5514,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; } @@ -5545,6 +5558,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 */ @@ -5563,7 +5577,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; @@ -5769,7 +5783,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') { @@ -5829,7 +5843,9 @@ Perl_sv_inc(pTHX_ register SV *sv) } if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { /* It's publicly an integer, or privately an integer-not-float */ +#ifdef PERL_PRESERVE_IVUV oops_its_int: +#endif if (SvIsUV(sv)) { if (SvUVX(sv) == UV_MAX) sv_setnv(sv, (NV)UV_MAX + 1.0); @@ -5977,7 +5993,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); @@ -6050,8 +6068,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 */ @@ -6078,8 +6097,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 */ @@ -6099,8 +6119,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 */ @@ -6714,6 +6735,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 @@ -6757,7 +6791,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); @@ -7644,8 +7678,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; @@ -7935,13 +7969,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) { @@ -7966,14 +8002,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; @@ -8015,7 +8054,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; @@ -8315,8 +8354,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 @@ -8400,6 +8439,10 @@ Perl_re_dup(pTHX_ REGEXP *r, clone_params *param) 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; @@ -9083,6 +9126,11 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param) CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr)); CvXSUB(dstr) = CvXSUB(sstr); CvXSUBANY(dstr) = CvXSUBANY(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); @@ -9272,7 +9320,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; @@ -9298,9 +9346,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param) 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); @@ -9411,7 +9459,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param) TOPPTR(nss,ix) = gp = gp_dup(gp, param); (void)GpREFCNT_inc(gp); gv = (GV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup_inc(c, param); + TOPPTR(nss,ix) = gv_dup_inc(gv, param); c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup(c); iv = POPIV(ss,ix); @@ -9473,7 +9521,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param) 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: @@ -9529,10 +9577,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, clone_params* param) return nss; } -#ifdef PERL_OBJECT -#include "XSUB.h" -#endif - /* =for apidoc perl_clone @@ -9542,14 +9586,12 @@ 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 /* perlhost.h so we need to call into it @@ -9585,26 +9627,19 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, IV i; clone_params* param = (clone_params*) malloc(sizeof(clone_params)); - - -# ifdef PERL_OBJECT - CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO, - ipD, ipS, ipP); - PERL_SET_THX(pPerl); -# else /* !PERL_OBJECT */ PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); PERL_SET_THX(my_perl); -# ifdef DEBUGGING +# ifdef DEBUGGING memset(my_perl, 0xab, sizeof(PerlInterpreter)); PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; PL_retstack = 0; PL_sig_pending = 0; -# else /* !DEBUGGING */ +# else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); -# endif /* DEBUGGING */ +# endif /* DEBUGGING */ /* host pointers */ PL_Mem = ipM; @@ -9616,7 +9651,6 @@ 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)); @@ -9688,11 +9722,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); @@ -9701,11 +9731,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); @@ -9770,6 +9796,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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? */ @@ -9788,12 +9815,18 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, { I32 len = av_len((AV*)proto_perl->Iregex_padav); SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav); - for(i = 0; i <= len; i++) { - av_push(PL_regex_padav, - SvREFCNT_inc( - newSViv((IV)re_dup((REGEXP *) - SvIVX(regexen[i]), param)) - )); + 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); @@ -9831,6 +9864,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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); @@ -9886,6 +9920,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, else PL_exitlist = (PerlExitListEntry*)NULL; 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, '<'); @@ -9924,7 +9960,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; @@ -9934,7 +9970,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; @@ -10160,7 +10196,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_tainted = proto_perl->Ttainted; PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */ - PL_nrs = sv_dup_inc(proto_perl->Tnrs, param); PL_rs = sv_dup_inc(proto_perl->Trs, param); PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param); PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param); @@ -10244,6 +10279,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; @@ -10265,6 +10301,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_reginterp_cnt = 0; PL_reg_starttry = 0; + /* Pluggable optimizer */ + PL_peepp = proto_perl->Tpeepp; + if (!(flags & CLONEf_KEEP_PTR_TABLE)) { ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; @@ -10292,17 +10331,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, SvREFCNT_dec(param->stashes); Safefree(param); -#ifdef PERL_OBJECT - return (PerlInterpreter*)pPerl; -#else return my_perl; -#endif } -#else /* !USE_ITHREADS */ - -#ifdef PERL_OBJECT -#include "XSUB.h" -#endif - #endif /* USE_ITHREADS */