diff options
| -rw-r--r-- | dump.c | 9 | ||||
| -rw-r--r-- | ext/Devel/DProf/DProf.xs | 5 | ||||
| -rw-r--r-- | gv.c | 2 | ||||
| -rw-r--r-- | mg.c | 2 | ||||
| -rw-r--r-- | op.c | 55 | ||||
| -rw-r--r-- | perl.c | 9 | ||||
| -rw-r--r-- | pp.c | 7 | ||||
| -rw-r--r-- | sv.c | 158 | ||||
| -rw-r--r-- | warnings.h | 4 | ||||
| -rw-r--r-- | warnings.pl | 4 | ||||
| -rw-r--r-- | win32/Makefile | 4 | ||||
| -rw-r--r-- | win32/perllib.c | 6 |
12 files changed, 182 insertions, 83 deletions
@@ -510,18 +510,23 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) } switch (o->op_type) { + case OP_AELEMFAST: case OP_GVSV: case OP_GV: - if (cGVOPo) { +#ifdef USE_ITHREADS + Perl_dump_indent(aTHX_ level, file, "PADIX = %d\n", cPADOPo->op_padix); +#else + if (cSVOPo->op_sv) { SV *tmpsv = NEWSV(0,0); ENTER; SAVEFREESV(tmpsv); - gv_fullname3(tmpsv, (GV*)cGVOPo, Nullch); + gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, Nullch); Perl_dump_indent(aTHX_ level, file, "GV = %s\n", SvPV(tmpsv, n_a)); LEAVE; } else Perl_dump_indent(aTHX_ level, file, "GV = NULL\n"); +#endif break; case OP_CONST: case OP_METHOD_NAMED: diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs index c751127f08..381919fafe 100644 --- a/ext/Devel/DProf/DProf.xs +++ b/ext/Devel/DProf/DProf.xs @@ -106,7 +106,6 @@ dprof_times(struct tms *t) XS(XS_Devel__DProf_END); /* used by prof_mark() */ -static SV * Sub; /* pointer to $DB::sub */ static PerlIO *fp; /* pointer to tmon.out file */ /* Added -JH */ @@ -255,6 +254,7 @@ prof_mark( opcode ptype ) STRLEN len; SV *sv; U32 id; + SV *Sub = GvSV(DBsub); /* name of current sub */ if( SAVE_STACK ){ if( profstack_ix + 5 > profstack_max ){ @@ -552,6 +552,7 @@ XS(XS_DB_sub) dXSARGS; dORIGMARK; HV *oldstash = curstash; + SV *Sub = GvSV(DBsub); /* name of current sub */ SP -= items; @@ -605,6 +606,7 @@ XS(XS_DB_goto) dORIGMARK; HV *oldstash = curstash; + SV *Sub = GvSV(DBsub); /* name of current sub */ /* SP -= items; added by xsubpp */ DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) ); @@ -662,7 +664,6 @@ BOOT: dowarn = warn_tmp; } - Sub = GvSV(DBsub); /* name of current sub */ sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */ { @@ -929,6 +929,8 @@ Perl_newGVgen(pTHX_ char *pack) GP* Perl_gp_ref(pTHX_ GP *gp) { + if (!gp) + return (GP*)NULL; gp->gp_refcnt++; if (gp->gp_cv) { if (gp->gp_cvgen) { @@ -1640,7 +1640,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) PL_dowarn |= G_WARN_ONCE ; } } - } + } break; case '.': if (PL_localizing) { @@ -26,7 +26,7 @@ #define OP_REFCNT_LOCK NOOP #define OP_REFCNT_UNLOCK NOOP #define OpREFCNT_set(o,n) NOOP -#define OpREFCNT_dec(o) 0 +#define OpREFCNT_dec(o) ((o)->op_targ--) #ifdef PL_OP_SLAB_ALLOC #define SLAB_SIZE 8192 @@ -659,6 +659,7 @@ Perl_op_free(pTHX_ OP *o) OP_REFCNT_UNLOCK; return; } + o->op_targ = 0; /* XXXXXX */ OP_REFCNT_UNLOCK; break; default: @@ -718,16 +719,18 @@ S_op_clear(pTHX_ OP *o) case OP_GV: case OP_AELEMFAST: #ifdef USE_ITHREADS - if (PL_curpad) { - GV *gv = cGVOPo; - pad_swipe(cPADOPo->op_padix); - /* No GvIN_PAD_off(gv) here, because other references may still - * exist on the pad */ - SvREFCNT_dec(gv); - } - cPADOPo->op_padix = 0; + if (cPADOPo->op_padix > 0) { + if (PL_curpad) { + GV *gv = cGVOPo; + pad_swipe(cPADOPo->op_padix); + /* No GvIN_PAD_off(gv) here, because other references may still + * exist on the pad */ + SvREFCNT_dec(gv); + } + cPADOPo->op_padix = 0; + } #else - SvREFCNT_dec(cGVOPo); + SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = Nullsv; #endif break; @@ -754,11 +757,26 @@ S_op_clear(pTHX_ OP *o) break; case OP_SUBST: op_free(cPMOPo->op_pmreplroot); - cPMOPo->op_pmreplroot = Nullop; - /* FALL THROUGH */ + goto clear_pmop; case OP_PUSHRE: +#ifdef USE_ITHREADS + if ((PADOFFSET)cPMOPo->op_pmreplroot) { + if (PL_curpad) { + GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot]; + pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot); + /* No GvIN_PAD_off(gv) here, because other references may still + * exist on the pad */ + SvREFCNT_dec(gv); + } + } +#else + SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot); +#endif + /* FALL THROUGH */ case OP_MATCH: case OP_QR: +clear_pmop: + cPMOPo->op_pmreplroot = Nullop; ReREFCNT_dec(cPMOPo->op_pmregexp); cPMOPo->op_pmregexp = (REGEXP*)NULL; break; @@ -3240,7 +3258,13 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) { tmpop = ((UNOP*)left)->op_first; if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) { - pm->op_pmreplroot = (OP*)cGVOPx(tmpop); +#ifdef USE_ITHREADS + pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix; + cPADOPx(tmpop)->op_padix = 0; /* steal it */ +#else + pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv; + cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */ +#endif pm->op_pmflags |= PMf_ONCE; tmpop = cUNOPo->op_first; /* to list (nulled) */ tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ @@ -3339,7 +3363,12 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) { (void)SvIOK_on(*svp); SvIVX(*svp) = 1; +#ifndef USE_ITHREADS + /* XXX This nameless kludge interferes with cloning SVs. :-( + * What's more, it seems entirely redundant when considering + * PL_DBsingle exists to do the same thing */ SvSTASH(*svp) = (HV*)cop; +#endif } } @@ -512,7 +512,8 @@ perl_destruct(pTHXx) PL_utf8_totitle = Nullsv; PL_utf8_tolower = Nullsv; - SvREFCNT_dec(PL_compiling.cop_warnings); + if (!specialWARN(PL_compiling.cop_warnings)) + SvREFCNT_dec(PL_compiling.cop_warnings); PL_compiling.cop_warnings = Nullsv; /* Prepare to destruct main symbol table. */ @@ -3121,7 +3122,7 @@ void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { dTHR; - SV *atsv = ERRSV; + SV *atsv; line_t oldline = CopLINE(PL_curcop); CV *cv; STRLEN len; @@ -3134,8 +3135,10 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv); switch (ret) { case 0: + atsv = ERRSV; (void)SvPV(atsv, len); if (len) { + STRLEN n_a; PL_curcop = &PL_compiling; CopLINE_set(PL_curcop, oldline); if (paramList == PL_beginav) @@ -3148,7 +3151,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) : "END"); while (PL_scopestack_ix > oldscope) LEAVE; - Perl_croak(aTHX_ "%s", SvPVX(atsv)); + Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a)); } break; case 1: @@ -4938,8 +4938,13 @@ PP(pp_split) TAINT_IF((pm->op_pmflags & PMf_LOCALE) && (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE))); - if (pm->op_pmreplroot) + if (pm->op_pmreplroot) { +#ifdef USE_ITHREADS + ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]); +#else ary = GvAVn((GV*)pm->op_pmreplroot); +#endif + } else if (gimme != G_ARRAY) #ifdef USE_THREADS ary = (AV*)PL_curpad[0]; @@ -5604,9 +5604,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV #endif #ifndef OpREFCNT_inc -# define OpREFCNT_inc(o) o +# define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop) #endif +#ifndef GpREFCNT_inc +# define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL) +#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)) @@ -5653,13 +5658,22 @@ Perl_gp_dup(pTHX_ GP *gp) GP *ret; if (!gp) return (GP*)NULL; + /* look for it in the table first */ + ret = (GP*)sv_table_fetch(PL_sv_table, (SV*)gp); + if (ret) + return ret; + + /* create anew and remember what it is */ Newz(0, ret, 1, GP); + sv_table_store(PL_sv_table, (SV*)gp, (SV*)ret); + + /* clone */ 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_inc(gp->gp_egv); + ret->gp_egv = 0; ret->gp_cv = cv_dup_inc(gp->gp_cv); ret->gp_cvgen = gp->gp_cvgen; ret->gp_flags = gp->gp_flags; @@ -5676,6 +5690,8 @@ Perl_mg_dup(pTHX_ MAGIC *mg) MAGIC *mgprev; if (!mg) return (MAGIC*)NULL; + /* XXX need to handle aliases here? */ + for (; mg; mg = mg->mg_moremagic) { MAGIC *nmg; Newz(0, nmg, 1, MAGIC); @@ -5698,8 +5714,17 @@ Perl_mg_dup(pTHX_ MAGIC *mg) nmg->mg_len = mg->mg_len; nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */ if (mg->mg_ptr && mg->mg_type != 'g') { - if (mg->mg_len >= 0) + if (mg->mg_len >= 0) { nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len); + if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) { + AMT *amtp = (AMT*)mg->mg_ptr; + AMT *namtp = (AMT*)nmg->mg_ptr; + I32 i; + for (i = 1; i < NofAMmeth; i++) { + namtp->table[i] = cv_dup_inc(amtp->table[i]); + } + } + } else if (mg->mg_len == HEf_SVKEY) nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr); } @@ -5788,6 +5813,10 @@ Perl_sv_table_split(pTHX_ SVTBL *tbl) } } +#ifdef DEBUGGING +DllExport char *PL_watch_pvx; +#endif + SV * Perl_sv_dup(pTHX_ SV *sstr) { @@ -5796,7 +5825,7 @@ Perl_sv_dup(pTHX_ SV *sstr) int stype; SV *dstr; - if (!sstr) + if (!sstr || SvTYPE(sstr) == SVTYPEMASK) return Nullsv; /* look for it in the table first */ dstr = sv_table_fetch(PL_sv_table, sstr); @@ -5814,6 +5843,12 @@ Perl_sv_dup(pTHX_ SV *sstr) SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */ SvREFCNT(dstr) = 0; +#ifdef DEBUGGING + if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx) + PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", + PL_watch_pvx, SvPVX(sstr)); +#endif + switch (SvTYPE(sstr)) { case SVt_NULL: SvANY(dstr) = NULL; @@ -5834,8 +5869,10 @@ Perl_sv_dup(pTHX_ SV *sstr) SvANY(dstr) = new_XPV(); SvCUR(dstr) = SvCUR(sstr); SvLEN(dstr) = SvLEN(sstr); - if (SvPOKp(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ break; @@ -5844,8 +5881,10 @@ Perl_sv_dup(pTHX_ SV *sstr) SvCUR(dstr) = SvCUR(sstr); SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); - if (SvPOKp(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ break; @@ -5855,8 +5894,10 @@ Perl_sv_dup(pTHX_ SV *sstr) SvLEN(dstr) = SvLEN(sstr); SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); - if (SvPOKp(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ break; @@ -5867,12 +5908,11 @@ Perl_sv_dup(pTHX_ SV *sstr) SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); - if (SvSMAGICAL(sstr) && mg_find(sstr, 'l')) - SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */ - else - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); - if (SvPOKp(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) + SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ break; @@ -5883,11 +5923,10 @@ Perl_sv_dup(pTHX_ SV *sstr) SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); - if (SvSMAGICAL(sstr) && mg_find(sstr, 'l')) - SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */ - else - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); - if (SvPOKp(sstr) && SvLEN(sstr)) + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + else if (SvPVX(sstr) && SvLEN(sstr)) SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ @@ -5902,12 +5941,11 @@ Perl_sv_dup(pTHX_ SV *sstr) SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); - if (SvSMAGICAL(sstr) && mg_find(sstr, 'l')) - SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */ - else - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); - if (SvPOKp(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + 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 */ @@ -5922,12 +5960,11 @@ Perl_sv_dup(pTHX_ SV *sstr) SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); - if (SvSMAGICAL(sstr) && mg_find(sstr, 'l')) - SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */ - else - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); - if (SvPOKp(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + 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); @@ -5935,7 +5972,11 @@ Perl_sv_dup(pTHX_ SV *sstr) GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr)); GvFLAGS(dstr) = GvFLAGS(sstr); GvGP(dstr) = gp_dup(GvGP(sstr)); - GvGP(dstr)->gp_refcnt++; + (void)GpREFCNT_inc(GvGP(dstr)); + if (GvEGV(sstr) == (GV*)sstr) + GvEGV(dstr) = (GV*)dstr; + else + GvEGV(dstr) = gv_dup_inc(GvEGV(sstr)); break; case SVt_PVIO: SvANY(dstr) = new_XPVIO(); @@ -5944,12 +5985,11 @@ Perl_sv_dup(pTHX_ SV *sstr) SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); - if (SvSMAGICAL(sstr) && mg_find(sstr, 'l')) - SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */ - else - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); - if (SvPOKp(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + if (SvROK(sstr)) + SvRV(dstr) = sv_dup_inc(SvRV(sstr)); + 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)); @@ -6050,8 +6090,10 @@ Perl_sv_dup(pTHX_ SV *sstr) else dxhv->xhv_eiter = (HE*)NULL; } - else + else { SvPVX(dstr) = Nullch; + HvEITER((HV*)dstr) = (HE*)NULL; + } HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */ HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr)); break; @@ -6067,12 +6109,9 @@ dup_pvcv: SvIVX(dstr) = SvIVX(sstr); SvNVX(dstr) = SvNVX(sstr); SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr)); - if (SvSMAGICAL(sstr) && mg_find(sstr, 'l')) - SvSTASH(dstr) = SvSTASH(sstr); /* COP* in disguise */ - else - SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); - if (SvPOKp(sstr) && SvLEN(sstr)) - SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr)); + SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); + 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 */ @@ -6082,7 +6121,15 @@ dup_pvcv: CvXSUBANY(dstr) = CvXSUBANY(sstr); CvGV(dstr) = gv_dup_inc(CvGV(sstr)); CvDEPTH(dstr) = CvDEPTH(sstr); - CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); + 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)); + AvREAL_off(CvPADLIST(sstr)); + AvREAL_off(CvPADLIST(dstr)); + } + else + CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr)); CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr)); CvFLAGS(dstr) = CvFLAGS(sstr); break; @@ -6111,7 +6158,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PERL_SET_INTERP(my_perl); #ifdef DEBUGGING - memset(my_perl, 0xab, sizeof(PerlInterpreter)); + memset(my_perl, 0x0, sizeof(PerlInterpreter)); PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; @@ -6195,7 +6242,8 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_compiling = proto_perl->Icompiling; PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv); PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file); - PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings); + if (!specialWARN(PL_compiling.cop_warnings)) + PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings); if (proto_perl->Tcurcop == &proto_perl->Icompiling) PL_curcop = &PL_compiling; else @@ -6291,7 +6339,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_forkprocess = proto_perl->Iforkprocess; /* subprocess state */ - PL_fdpid = av_dup(proto_perl->Ifdpid); + PL_fdpid = av_dup_inc(proto_perl->Ifdpid); /* internal state */ PL_tainting = proto_perl->Itainting; @@ -6336,19 +6384,19 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, } else PL_exitlist = (PerlExitListEntry*)NULL; - PL_modglobal = hv_dup(proto_perl->Imodglobal); + PL_modglobal = hv_dup_inc(proto_perl->Imodglobal); PL_profiledata = NULL; /* XXX */ PL_rsfp = fp_dup(proto_perl->Irsfp, '<'); /* XXX PL_rsfp_filters entries have fake IoDIRP() */ - PL_rsfp_filters = av_dup(proto_perl->Irsfp_filters); + PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters); PL_compcv = cv_dup(proto_perl->Icompcv); PL_comppad = av_dup(proto_perl->Icomppad); PL_comppad_name = av_dup(proto_perl->Icomppad_name); PL_comppad_name_fill = proto_perl->Icomppad_name_fill; PL_comppad_name_floor = proto_perl->Icomppad_name_floor; - PL_curpad = AvARRAY(PL_comppad); /* XXX */ + PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : (SV**)NULL; #ifdef HAVE_INTERP_INTERN sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); @@ -6523,7 +6571,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_statbuf = proto_perl->Tstatbuf; PL_statcache = proto_perl->Tstatcache; PL_statgv = gv_dup(proto_perl->Tstatgv); - PL_statname = sv_dup(proto_perl->Tstatname); + PL_statname = sv_dup_inc(proto_perl->Tstatname); #ifdef HAS_TIMES PL_timesbuf = proto_perl->Ttimesbuf; #endif diff --git a/warnings.h b/warnings.h index a5d50bf859..8c1bbf752c 100644 --- a/warnings.h +++ b/warnings.h @@ -17,8 +17,8 @@ #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF) #define WARN_STD Nullsv -#define WARN_ALL (&PL_sv_yes) /* use warnings 'all' */ -#define WARN_NONE (&PL_sv_no) /* no warnings 'all' */ +#define WARN_ALL (Nullsv+1) /* use warnings 'all' */ +#define WARN_NONE (Nullsv+2) /* no warnings 'all' */ #define specialWARN(x) ((x) == WARN_STD || (x) == WARN_ALL || \ (x) == WARN_NONE) diff --git a/warnings.pl b/warnings.pl index 9ff4197612..72d19af67b 100644 --- a/warnings.pl +++ b/warnings.pl @@ -150,8 +150,8 @@ print WARN <<'EOM' ; #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF) #define WARN_STD Nullsv -#define WARN_ALL (&PL_sv_yes) /* use warnings 'all' */ -#define WARN_NONE (&PL_sv_no) /* no warnings 'all' */ +#define WARN_ALL (Nullsv+1) /* use warnings 'all' */ +#define WARN_NONE (Nullsv+2) /* no warnings 'all' */ #define specialWARN(x) ((x) == WARN_STD || (x) == WARN_ALL || \ (x) == WARN_NONE) diff --git a/win32/Makefile b/win32/Makefile index 654643a82a..c4bb568570 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -145,7 +145,11 @@ CCLIBDIR = $(CCHOME)\lib # #BUILDOPT = $(BUILDOPT) -DPERL_INTERNAL_GLOB +# Beginnings of interpreter cloning/threads: still rather rough, fails +# many tests. Do not enable unless you know what you're doing! # +#BUILDOPT = $(BUILDOPT) -DUSE_ITHREADS + # specify semicolon-separated list of extra directories that modules will # look for libraries (spaces in path names need not be quoted) # diff --git a/win32/perllib.c b/win32/perllib.c index 61798faf1c..0cf21cb627 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -1556,12 +1556,14 @@ RunPerl(int argc, char **argv, char **env) exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); if (!exitstatus) { -#if 0 /* def USE_ITHREADS */ /* XXXXXX testing */ +#ifdef USE_ITHREADS /* XXXXXX testing */ extern PerlInterpreter * perl_clone(pTHXx_ IV flags); PerlInterpreter *new_perl = perl_clone(my_perl, 0); + Perl_push_scope(new_perl); /* ENTER; (hack in lieu of perl_destruct()) */ exitstatus = perl_run( new_perl ); - /* perl_destruct(new_perl); perl_free(new_perl); */ + perl_destruct(new_perl); perl_free(new_perl); + SetPerlInterpreter(my_perl); #else exitstatus = perl_run( my_perl ); #endif |