From dd2155a49b710f23bc6d72169e5b1d71d8b3aa03 Mon Sep 17 00:00:00 2001 From: Dave Mitchell Date: Thu, 26 Sep 2002 00:40:23 +0100 Subject: move all pad-related code to its own src file Message-ID: <20020925234023.A20044@fdgroup.com> p4raw-id: //depot/perl@17953 --- op.c | 1000 +++++++----------------------------------------------------------- 1 file changed, 96 insertions(+), 904 deletions(-) (limited to 'op.c') diff --git a/op.c b/op.c index 9b2f205083..4804bf11c3 100644 --- a/op.c +++ b/op.c @@ -108,7 +108,6 @@ S_Slab_Free(pTHX_ void *op) Nullop ) \ : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) -#define PAD_MAX 999999999 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) STATIC char* @@ -160,11 +159,11 @@ S_no_bareword_allowed(pTHX_ OP *o) /* "register" allocation */ PADOFFSET -Perl_pad_allocmy(pTHX_ char *name) +Perl_allocmy(pTHX_ char *name) { PADOFFSET off; - SV *sv; + /* complain about "my $_" etc etc */ if (!(PL_in_my == KEY_our || isALPHA(name[1]) || (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) || @@ -191,492 +190,32 @@ Perl_pad_allocmy(pTHX_ char *name) } yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name)); } - if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) { - SV **svp = AvARRAY(PL_comppad_name); - HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash); - PADOFFSET top = AvFILLp(PL_comppad_name); - for (off = top; (I32)off > PL_comppad_name_floor; off--) { - if ((sv = svp[off]) - && sv != &PL_sv_undef - && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0) - && (PL_in_my != KEY_our - || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)) - && strEQ(name, SvPVX(sv))) - { - Perl_warner(aTHX_ packWARN(WARN_MISC), - "\"%s\" variable %s masks earlier declaration in same %s", - (PL_in_my == KEY_our ? "our" : "my"), - name, - (SvIVX(sv) == PAD_MAX ? "scope" : "statement")); - --off; - break; - } - } - if (PL_in_my == KEY_our) { - do { - if ((sv = svp[off]) - && sv != &PL_sv_undef - && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0) - && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash) - && strEQ(name, SvPVX(sv))) - { - Perl_warner(aTHX_ packWARN(WARN_MISC), - "\"our\" variable %s redeclared", name); - Perl_warner(aTHX_ packWARN(WARN_MISC), - "\t(Did you mean \"local\" instead of \"our\"?)\n"); - break; - } - } while ( off-- > 0 ); - } - } - off = pad_alloc(OP_PADSV, SVs_PADMY); - sv = NEWSV(1102,0); - sv_upgrade(sv, SVt_PVNV); - sv_setpv(sv, name); - if (PL_in_my_stash) { - if (*name != '$') - yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"", - name, PL_in_my == KEY_our ? "our" : "my")); - SvFLAGS(sv) |= SVpad_TYPED; - (void)SvUPGRADE(sv, SVt_PVMG); - SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash); - } - if (PL_in_my == KEY_our) { - (void)SvUPGRADE(sv, SVt_PVGV); - GvSTASH(sv) = (HV*)SvREFCNT_inc(PL_curstash ? (SV*)PL_curstash : (SV*)PL_defstash); - SvFLAGS(sv) |= SVpad_OUR; - } - av_store(PL_comppad_name, off, sv); - SvNVX(sv) = (NV)PAD_MAX; - SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */ - if (!PL_min_intro_pending) - PL_min_intro_pending = off; - PL_max_intro_pending = off; - if (*name == '@') - av_store(PL_comppad, off, (SV*)newAV()); - else if (*name == '%') - av_store(PL_comppad, off, (SV*)newHV()); - SvPADMY_on(PL_curpad[off]); - return off; -} - -STATIC PADOFFSET -S_pad_addlex(pTHX_ SV *proto_namesv) -{ - SV *namesv = NEWSV(1103,0); - PADOFFSET newoff = pad_alloc(OP_PADSV, SVs_PADMY); - sv_upgrade(namesv, SVt_PVNV); - sv_setpv(namesv, SvPVX(proto_namesv)); - av_store(PL_comppad_name, newoff, namesv); - SvNVX(namesv) = (NV)PL_curcop->cop_seq; - SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */ - SvFAKE_on(namesv); /* A ref, not a real var */ - if (SvFLAGS(proto_namesv) & SVpad_OUR) { /* An "our" variable */ - SvFLAGS(namesv) |= SVpad_OUR; - (void)SvUPGRADE(namesv, SVt_PVGV); - GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv)); - } - if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */ - SvFLAGS(namesv) |= SVpad_TYPED; - (void)SvUPGRADE(namesv, SVt_PVMG); - SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv)); - } - return newoff; -} - -#define FINDLEX_NOSEARCH 1 /* don't search outer contexts */ - -STATIC PADOFFSET -S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, - I32 cx_ix, I32 saweval, U32 flags) -{ - CV *cv; - I32 off; - SV *sv; - register I32 i; - register PERL_CONTEXT *cx; - - for (cv = startcv; cv; cv = CvOUTSIDE(cv)) { - AV *curlist = CvPADLIST(cv); - SV **svp = av_fetch(curlist, 0, FALSE); - AV *curname; - - if (!svp || *svp == &PL_sv_undef) - continue; - curname = (AV*)*svp; - svp = AvARRAY(curname); - for (off = AvFILLp(curname); off > 0; off--) { - if ((sv = svp[off]) && - sv != &PL_sv_undef && - seq <= (U32)SvIVX(sv) && - seq > (U32)I_32(SvNVX(sv)) && - strEQ(SvPVX(sv), name)) - { - I32 depth; - AV *oldpad; - SV *oldsv; - - depth = CvDEPTH(cv); - if (!depth) { - if (newoff) { - if (SvFAKE(sv)) - continue; - return 0; /* don't clone from inactive stack frame */ - } - depth = 1; - } - oldpad = (AV*)AvARRAY(curlist)[depth]; - oldsv = *av_fetch(oldpad, off, TRUE); - if (!newoff) { /* Not a mere clone operation. */ - newoff = pad_addlex(sv); - if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) { - /* "It's closures all the way down." */ - CvCLONE_on(PL_compcv); - if (cv == startcv) { - if (CvANON(PL_compcv)) - oldsv = Nullsv; /* no need to keep ref */ - } - else { - CV *bcv; - for (bcv = startcv; - bcv && bcv != cv && !CvCLONE(bcv); - bcv = CvOUTSIDE(bcv)) - { - if (CvANON(bcv)) { - /* install the missing pad entry in intervening - * nested subs and mark them cloneable. - * XXX fix pad_foo() to not use globals */ - AV *ocomppad_name = PL_comppad_name; - AV *ocomppad = PL_comppad; - SV **ocurpad = PL_curpad; - AV *padlist = CvPADLIST(bcv); - PL_comppad_name = (AV*)AvARRAY(padlist)[0]; - PL_comppad = (AV*)AvARRAY(padlist)[1]; - PL_curpad = AvARRAY(PL_comppad); - pad_addlex(sv); - PL_comppad_name = ocomppad_name; - PL_comppad = ocomppad; - PL_curpad = ocurpad; - CvCLONE_on(bcv); - } - else { - if (ckWARN(WARN_CLOSURE) - && !CvUNIQUE(bcv) && !CvUNIQUE(cv)) - { - Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" may be unavailable", - name); - } - break; - } - } - } - } - else if (!CvUNIQUE(PL_compcv)) { - if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv) - && !(SvFLAGS(sv) & SVpad_OUR)) - { - Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" will not stay shared", name); - } - } - } - av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv)); - return newoff; - } - } - } - if (flags & FINDLEX_NOSEARCH) - return 0; - - /* Nothing in current lexical context--try eval's context, if any. - * This is necessary to let the perldb get at lexically scoped variables. - * XXX This will also probably interact badly with eval tree caching. - */ + /* check for duplicate declaration */ + pad_check_dup(name, + PL_in_my == KEY_our, + (PL_curstash ? PL_curstash : PL_defstash) + ); - for (i = cx_ix; i >= 0; i--) { - cx = &cxstack[i]; - switch (CxTYPE(cx)) { - default: - if (i == 0 && saweval) { - return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0); - } - break; - case CXt_EVAL: - switch (cx->blk_eval.old_op_type) { - case OP_ENTEREVAL: - if (CxREALEVAL(cx)) { - PADOFFSET off; - saweval = i; - seq = cxstack[i].blk_oldcop->cop_seq; - startcv = cxstack[i].blk_eval.cv; - if (startcv && CvOUTSIDE(startcv)) { - off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv), - i-1, saweval, 0); - if (off) /* continue looking if not found here */ - return off; - } - } - break; - case OP_DOFILE: - case OP_REQUIRE: - /* require/do must have their own scope */ - return 0; - } - break; - case CXt_FORMAT: - case CXt_SUB: - if (!saweval) - return 0; - cv = cx->blk_sub.cv; - if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */ - saweval = i; /* so we know where we were called from */ - seq = cxstack[i].blk_oldcop->cop_seq; - continue; - } - return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH); - } + if (PL_in_my_stash && *name != '$') { + yyerror(Perl_form(aTHX_ + "Can't declare class for non-scalar %s in \"%s\"", + name, PL_in_my == KEY_our ? "our" : "my")); } - return 0; -} - -PADOFFSET -Perl_pad_findmy(pTHX_ char *name) -{ - I32 off; - I32 pendoff = 0; - SV *sv; - SV **svp = AvARRAY(PL_comppad_name); - U32 seq = PL_cop_seqmax; - PERL_CONTEXT *cx; - CV *outside; + /* allocate a spare slot and store the name in that slot */ -#ifdef USE_5005THREADS - /* - * Special case to get lexical (and hence per-thread) @_. - * XXX I need to find out how to tell at parse-time whether use - * of @_ should refer to a lexical (from a sub) or defgv (global - * scope and maybe weird sub-ish things like formats). See - * startsub in perly.y. It's possible that @_ could be lexical - * (at least from subs) even in non-threaded perl. - */ - if (strEQ(name, "@_")) - return 0; /* success. (NOT_IN_PAD indicates failure) */ -#endif /* USE_5005THREADS */ - - /* The one we're looking for is probably just before comppad_name_fill. */ - for (off = AvFILLp(PL_comppad_name); off > 0; off--) { - if ((sv = svp[off]) && - sv != &PL_sv_undef && - (!SvIVX(sv) || - (seq <= (U32)SvIVX(sv) && - seq > (U32)I_32(SvNVX(sv)))) && - strEQ(SvPVX(sv), name)) - { - if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR) - return (PADOFFSET)off; - pendoff = off; /* this pending def. will override import */ - } - } - - outside = CvOUTSIDE(PL_compcv); - - /* Check if if we're compiling an eval'', and adjust seq to be the - * eval's seq number. This depends on eval'' having a non-null - * CvOUTSIDE() while it is being compiled. The eval'' itself is - * identified by CvEVAL being true and CvGV being null. */ - if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) { - cx = &cxstack[cxstack_ix]; - if (CxREALEVAL(cx)) - seq = cx->blk_oldcop->cop_seq; - } - - /* See if it's in a nested scope */ - off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0); - if (off) { - /* If there is a pending local definition, this new alias must die */ - if (pendoff) - SvIVX(AvARRAY(PL_comppad_name)[off]) = seq; - return off; /* pad_findlex returns 0 for failure...*/ - } - return NOT_IN_PAD; /* ...but we return NOT_IN_PAD for failure */ -} - -void -Perl_pad_leavemy(pTHX_ I32 fill) -{ - I32 off; - SV **svp = AvARRAY(PL_comppad_name); - SV *sv; - if (PL_min_intro_pending && fill < PL_min_intro_pending) { - for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { - if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "%s never introduced", SvPVX(sv)); - } - } - /* "Deintroduce" my variables that are leaving with this scope. */ - for (off = AvFILLp(PL_comppad_name); off > fill; off--) { - if ((sv = svp[off]) && sv != &PL_sv_undef && SvIVX(sv) == PAD_MAX) - SvIVX(sv) = PL_cop_seqmax; - } -} - -PADOFFSET -Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) -{ - SV *sv; - I32 retval; - - if (AvARRAY(PL_comppad) != PL_curpad) - Perl_croak(aTHX_ "panic: pad_alloc"); - if (PL_pad_reset_pending) - pad_reset(); - if (tmptype & SVs_PADMY) { - do { - sv = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, TRUE); - } while (SvPADBUSY(sv)); /* need a fresh one */ - retval = AvFILLp(PL_comppad); - } - else { - SV **names = AvARRAY(PL_comppad_name); - SSize_t names_fill = AvFILLp(PL_comppad_name); - for (;;) { - /* - * "foreach" index vars temporarily become aliases to non-"my" - * values. Thus we must skip, not just pad values that are - * marked as current pad values, but also those with names. - */ - if (++PL_padix <= names_fill && - (sv = names[PL_padix]) && sv != &PL_sv_undef) - continue; - sv = *av_fetch(PL_comppad, PL_padix, TRUE); - if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) && - !IS_PADGV(sv) && !IS_PADCONST(sv)) - break; - } - retval = PL_padix; - } - SvFLAGS(sv) |= tmptype; - PL_curpad = AvARRAY(PL_comppad); -#ifdef USE_5005THREADS - DEBUG_X(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n", - PTR2UV(thr), PTR2UV(PL_curpad), - (long) retval, PL_op_name[optype])); -#else - DEBUG_X(PerlIO_printf(Perl_debug_log, - "Pad 0x%"UVxf" alloc %ld for %s\n", - PTR2UV(PL_curpad), - (long) retval, PL_op_name[optype])); -#endif /* USE_5005THREADS */ - return (PADOFFSET)retval; -} - -SV * -Perl_pad_sv(pTHX_ PADOFFSET po) -{ -#ifdef USE_5005THREADS - DEBUG_X(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n", - PTR2UV(thr), PTR2UV(PL_curpad), (IV)po)); -#else - if (!po) - Perl_croak(aTHX_ "panic: pad_sv po"); - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n", - PTR2UV(PL_curpad), (IV)po)); -#endif /* USE_5005THREADS */ - return PL_curpad[po]; /* eventually we'll turn this into a macro */ -} - -void -Perl_pad_free(pTHX_ PADOFFSET po) -{ - if (!PL_curpad) - return; - if (AvARRAY(PL_comppad) != PL_curpad) - Perl_croak(aTHX_ "panic: pad_free curpad"); - if (!po) - Perl_croak(aTHX_ "panic: pad_free po"); -#ifdef USE_5005THREADS - DEBUG_X(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n", - PTR2UV(thr), PTR2UV(PL_curpad), (IV)po)); -#else - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n", - PTR2UV(PL_curpad), (IV)po)); -#endif /* USE_5005THREADS */ - if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) { - SvPADTMP_off(PL_curpad[po]); -#ifdef USE_ITHREADS -#ifdef PERL_COPY_ON_WRITE - if (SvIsCOW(PL_curpad[po])) { - sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV); - } else -#endif - SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */ -#endif - } - if ((I32)po < PL_padix) - PL_padix = po - 1; + off = pad_add_name(name, + PL_in_my_stash, + (PL_in_my == KEY_our + ? (PL_curstash ? PL_curstash : PL_defstash) + : Nullhv + ), + 0 /* not fake */ + ); + return off; } -void -Perl_pad_swipe(pTHX_ PADOFFSET po) -{ - if (AvARRAY(PL_comppad) != PL_curpad) - Perl_croak(aTHX_ "panic: pad_swipe curpad"); - if (!po) - Perl_croak(aTHX_ "panic: pad_swipe po"); -#ifdef USE_5005THREADS - DEBUG_X(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n", - PTR2UV(thr), PTR2UV(PL_curpad), (IV)po)); -#else - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n", - PTR2UV(PL_curpad), (IV)po)); -#endif /* USE_5005THREADS */ - if (PL_curpad[po]) - SvPADTMP_off(PL_curpad[po]); - PL_curpad[po] = NEWSV(1107,0); - SvPADTMP_on(PL_curpad[po]); - if ((I32)po < PL_padix) - PL_padix = po - 1; -} - -/* XXX pad_reset() is currently disabled because it results in serious bugs. - * It causes pad temp TARGs to be shared between OPs. Since TARGs are pushed - * on the stack by OPs that use them, there are several ways to get an alias - * to a shared TARG. Such an alias will change randomly and unpredictably. - * We avoid doing this until we can think of a Better Way. - * GSAR 97-10-29 */ -void -Perl_pad_reset(pTHX) -{ -#ifdef USE_BROKEN_PAD_RESET - register I32 po; - - if (AvARRAY(PL_comppad) != PL_curpad) - Perl_croak(aTHX_ "panic: pad_reset curpad"); -#ifdef USE_5005THREADS - DEBUG_X(PerlIO_printf(Perl_debug_log, - "0x%"UVxf" Pad 0x%"UVxf" reset\n", - PTR2UV(thr), PTR2UV(PL_curpad))); -#else - DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n", - PTR2UV(PL_curpad))); -#endif /* USE_5005THREADS */ - if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */ - for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) { - if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po])) - SvPADTMP_off(PL_curpad[po]); - } - PL_padix = PL_padix_floor; - } -#endif - PL_pad_reset_pending = FALSE; -} #ifdef USE_5005THREADS /* find_threadsv is not reentrant */ @@ -823,13 +362,9 @@ Perl_op_clear(pTHX_ OP *o) case OP_AELEMFAST: #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { - if (PL_curpad) { - GV *gv = cGVOPo_gv; - pad_swipe(cPADOPo->op_padix); - /* No GvIN_PAD_off(gv) here, because other references may still - * exist on the pad */ - SvREFCNT_dec(gv); - } + /* No GvIN_PAD_off(cGVOPo_gv) here, because other references + * may still exist on the pad */ + pad_swipe(cPADOPo->op_padix, TRUE); cPADOPo->op_padix = 0; } #else @@ -865,13 +400,9 @@ Perl_op_clear(pTHX_ OP *o) case OP_PUSHRE: #ifdef USE_ITHREADS if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) { - if (PL_curpad) { - GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)]; - pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)); - /* No GvIN_PAD_off(gv) here, because other references may still - * exist on the pad */ - SvREFCNT_dec(gv); - } + /* No GvIN_PAD_off here, because other references may still + * exist on the pad */ + pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE); } #else SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot); @@ -1424,7 +955,6 @@ OP * Perl_mod(pTHX_ OP *o, I32 type) { OP *kid; - STRLEN n_a; if (!o || PL_error_count) return o; @@ -1650,8 +1180,13 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_PADSV: PL_modcount++; if (!type) + { /* XXX DAPM 2002.08.25 tmp assert test */ + /* XXX */ assert(av_fetch(PL_comppad_name, (o->op_targ), FALSE)); + /* XXX */ assert(*av_fetch(PL_comppad_name, (o->op_targ), FALSE)); + Perl_croak(aTHX_ "Can't localize lexical variable %s", - SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a)); + PAD_COMPNAME_PV(o->op_targ)); + } break; #ifdef USE_5005THREADS @@ -1995,7 +1530,7 @@ S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) target->op_type == OP_PADAV); /* Ensure that attributes.pm is loaded. */ - apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE); + apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE); /* Need package name for method call. */ pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); @@ -2123,16 +1658,13 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) } else if (attrs && type != OP_PUSHMARK) { HV *stash; - SV **namesvp; PL_in_my = FALSE; PL_in_my_stash = Nullhv; /* check for C when deciding package */ - namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE); - if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED)) - stash = SvSTASH(*namesvp); - else + stash = PAD_COMPNAME_TYPE(o->op_targ); + if (!stash) stash = PL_curstash; apply_attrs_my(stash, o, attrs, imopsp); } @@ -2285,19 +1817,7 @@ Perl_block_start(pTHX_ int full) { int retval = PL_savestack_ix; - SAVEI32(PL_comppad_name_floor); - PL_comppad_name_floor = AvFILLp(PL_comppad_name); - if (full) - PL_comppad_name_fill = PL_comppad_name_floor; - if (PL_comppad_name_floor < 0) - PL_comppad_name_floor = 0; - SAVEI32(PL_min_intro_pending); - SAVEI32(PL_max_intro_pending); - PL_min_intro_pending = 0; - SAVEI32(PL_comppad_name_fill); - SAVEI32(PL_padix_floor); - PL_padix_floor = PL_padix; - PL_pad_reset_pending = FALSE; + pad_block_start(full); SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; SAVESPTR(PL_compiling.cop_warnings); @@ -2322,12 +1842,10 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq); PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */ LEAVE_SCOPE(floor); - PL_pad_reset_pending = FALSE; PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); if (needblockscope) PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */ - pad_leavemy(PL_comppad_name_fill); - PL_cop_seqmax++; + pad_leavemy(); return retval; } @@ -2500,7 +2018,7 @@ Perl_fold_constants(pTHX_ register OP *o) CALLRUNOPS(aTHX); sv = *(PL_stack_sp--); if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */ - pad_swipe(o->op_targ); + pad_swipe(o->op_targ, FALSE); else if (SvTEMP(sv)) { /* grab mortal temp? */ (void)SvREFCNT_inc(sv); SvTEMP_off(sv); @@ -3323,8 +2841,8 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) padop->op_type = (OPCODE)type; padop->op_ppaddr = PL_ppaddr[type]; padop->op_padix = pad_alloc(type, SVs_PADTMP); - SvREFCNT_dec(PL_curpad[padop->op_padix]); - PL_curpad[padop->op_padix] = sv; + SvREFCNT_dec(PAD_SVl(padop->op_padix)); + PAD_SETSV(padop->op_padix, sv); if (sv) SvPADTMP_on(sv); padop->op_next = (OP*)padop; @@ -3658,6 +3176,21 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) curop = list(force_list(left)); o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); o->op_private = (U8)(0 | (flags >> 8)); + + /* PL_generation sorcery: + * an assignment like ($a,$b) = ($c,$d) is easier than + * ($a,$b) = ($c,$a), since there is no need for temporary vars. + * To detect whether there are common vars, the global var + * PL_generation is incremented for each assign op we compile. + * Then, while compiling the assign op, we run through all the + * variables on both sides of the assignment, setting a spare slot + * in each of them to PL_generation. If any of them already have + * that value, we know we've got commonality. We could use a + * single bit marker, but then we'd have to make 2 passes, first + * to clear the flag, then to test and set it. To find somewhere + * to store these values, evil chicanery is done with SvCUR(). + */ + if (!(left->op_private & OPpLVAL_INTRO)) { OP *lastop = o; PL_generation++; @@ -3672,12 +3205,14 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || - curop->op_type == OP_PADANY) { - SV **svp = AvARRAY(PL_comppad_name); - SV *sv = svp[curop->op_targ]; - if ((int)SvCUR(sv) == PL_generation) + curop->op_type == OP_PADANY) + { + if (PAD_COMPNAME_GEN(curop->op_targ) + == PL_generation) break; - SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */ + PAD_COMPNAME_GEN(curop->op_targ) + = PL_generation; + } else if (curop->op_type == OP_RV2CV) break; @@ -3691,7 +3226,8 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) else if (curop->op_type == OP_PUSHRE) { if (((PMOP*)curop)->op_pmreplroot) { #ifdef USE_ITHREADS - GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)]; + GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET, + ((PMOP*)curop)->op_pmreplroot)); #else GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; #endif @@ -3834,28 +3370,6 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) return prepend_elem(OP_LINESEQ, (OP*)cop, o); } -/* "Introduce" my variables to visible status. */ -U32 -Perl_intro_my(pTHX) -{ - SV **svp; - SV *sv; - I32 i; - - if (! PL_min_intro_pending) - return PL_cop_seqmax; - - svp = AvARRAY(PL_comppad_name); - for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) { - if ((sv = svp[i]) && sv != &PL_sv_undef && !SvIVX(sv)) { - SvIVX(sv) = PAD_MAX; /* Don't know scope end yet. */ - SvNVX(sv) = (NV)PL_cop_seqmax; - } - } - PL_min_intro_pending = 0; - PL_comppad_name_fill = PL_max_intro_pending; /* Needn't search higher */ - return PL_cop_seqmax++; -} OP * Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) @@ -4349,7 +3863,6 @@ Perl_cv_undef(pTHX_ CV *cv) { CV *outsidecv; CV *freecv = Nullcv; - bool is_eval = CvEVAL(cv) && !CvGV(cv); /* is this eval"" ? */ #ifdef USE_5005THREADS if (CvMUTEXP(cv)) { @@ -4377,8 +3890,7 @@ Perl_cv_undef(pTHX_ CV *cv) #endif /* USE_5005THREADS */ ENTER; - SAVEVPTR(PL_curpad); - PL_curpad = 0; + PAD_SAVE_SETNULLPAD; op_free(CvROOT(cv)); CvROOT(cv) = Nullop; @@ -4399,58 +3911,8 @@ Perl_cv_undef(pTHX_ CV *cv) SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); CvCONST_off(cv); } - if (CvPADLIST(cv)) { - /* may be during global destruction */ - if (SvREFCNT(CvPADLIST(cv))) { - AV *padlist = CvPADLIST(cv); - I32 ix; - /* pads may be cleared out already during global destruction */ - if ((is_eval && !PL_dirty) || CvSPECIAL(cv)) { - /* inner references to eval's cv must be fixed up */ - AV *comppad_name = (AV*)AvARRAY(padlist)[0]; - AV *comppad = (AV*)AvARRAY(padlist)[1]; - SV **namepad = AvARRAY(comppad_name); - SV **curpad = AvARRAY(comppad); - for (ix = AvFILLp(comppad_name); ix > 0; ix--) { - SV *namesv = namepad[ix]; - if (namesv && namesv != &PL_sv_undef - && *SvPVX(namesv) == '&' - && ix <= AvFILLp(comppad)) - { - CV *innercv = (CV*)curpad[ix]; - if (innercv && SvTYPE(innercv) == SVt_PVCV - && CvOUTSIDE(innercv) == cv) - { - CvOUTSIDE(innercv) = outsidecv; - if (!CvANON(innercv) || CvCLONED(innercv)) { - (void)SvREFCNT_inc(outsidecv); - if (SvREFCNT(cv)) - SvREFCNT_dec(cv); - } - } - } - } - } - if (freecv) - SvREFCNT_dec(freecv); - ix = AvFILLp(padlist); - while (ix >= 0) { - SV* sv = AvARRAY(padlist)[ix--]; - if (!sv) - continue; - if (sv == (SV*)PL_comppad_name) - PL_comppad_name = Nullav; - else if (sv == (SV*)PL_comppad) { - PL_comppad = Nullav; - PL_curpad = Null(SV**); - } - SvREFCNT_dec(sv); - } - SvREFCNT_dec((SV*)CvPADLIST(cv)); - } - CvPADLIST(cv) = Nullav; - } - else if (freecv) + pad_undef(cv, outsidecv); + if (freecv) SvREFCNT_dec(freecv); if (CvXSUB(cv)) { CvXSUB(cv) = 0; @@ -4458,211 +3920,6 @@ Perl_cv_undef(pTHX_ CV *cv) CvFLAGS(cv) = 0; } -#ifdef DEBUG_CLOSURES -STATIC void -S_cv_dump(pTHX_ CV *cv) -{ -#ifdef DEBUGGING - CV *outside = CvOUTSIDE(cv); - AV* padlist = CvPADLIST(cv); - AV* pad_name; - AV* pad; - SV** pname; - SV** ppad; - I32 ix; - - PerlIO_printf(Perl_debug_log, - "\tCV=0x%"UVxf" (%s), OUTSIDE=0x%"UVxf" (%s)\n", - PTR2UV(cv), - (CvANON(cv) ? "ANON" - : (cv == PL_main_cv) ? "MAIN" - : CvUNIQUE(cv) ? "UNIQUE" - : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"), - PTR2UV(outside), - (!outside ? "null" - : CvANON(outside) ? "ANON" - : (outside == PL_main_cv) ? "MAIN" - : CvUNIQUE(outside) ? "UNIQUE" - : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); - - if (!padlist) - return; - - pad_name = (AV*)*av_fetch(padlist, 0, FALSE); - pad = (AV*)*av_fetch(padlist, 1, FALSE); - pname = AvARRAY(pad_name); - ppad = AvARRAY(pad); - - for (ix = 1; ix <= AvFILLp(pad_name); ix++) { - if (SvPOK(pname[ix])) - PerlIO_printf(Perl_debug_log, - "\t%4d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n", - (int)ix, PTR2UV(ppad[ix]), - SvFAKE(pname[ix]) ? "FAKE " : "", - SvPVX(pname[ix]), - (IV)I_32(SvNVX(pname[ix])), - SvIVX(pname[ix])); - } -#endif /* DEBUGGING */ -} -#endif /* DEBUG_CLOSURES */ - -STATIC CV * -S_cv_clone2(pTHX_ CV *proto, CV *outside) -{ - AV* av; - I32 ix; - AV* protopadlist = CvPADLIST(proto); - AV* protopad_name = (AV*)*av_fetch(protopadlist, 0, FALSE); - AV* protopad = (AV*)*av_fetch(protopadlist, 1, FALSE); - SV** pname = AvARRAY(protopad_name); - SV** ppad = AvARRAY(protopad); - I32 fname = AvFILLp(protopad_name); - I32 fpad = AvFILLp(protopad); - AV* comppadlist; - CV* cv; - - assert(!CvUNIQUE(proto)); - - ENTER; - SAVECOMPPAD(); - SAVESPTR(PL_comppad_name); - SAVESPTR(PL_compcv); - - cv = PL_compcv = (CV*)NEWSV(1104,0); - sv_upgrade((SV *)cv, SvTYPE(proto)); - CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE; - CvCLONED_on(cv); - -#ifdef USE_5005THREADS - New(666, CvMUTEXP(cv), 1, perl_mutex); - MUTEX_INIT(CvMUTEXP(cv)); - CvOWNER(cv) = 0; -#endif /* USE_5005THREADS */ -#ifdef USE_ITHREADS - CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto) - : savepv(CvFILE(proto)); -#else - CvFILE(cv) = CvFILE(proto); -#endif - CvGV(cv) = CvGV(proto); - CvSTASH(cv) = CvSTASH(proto); - CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); - CvSTART(cv) = CvSTART(proto); - if (outside) - CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside); - - if (SvPOK(proto)) - sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto)); - - PL_comppad_name = newAV(); - for (ix = fname; ix >= 0; ix--) - av_store(PL_comppad_name, ix, SvREFCNT_inc(pname[ix])); - - PL_comppad = newAV(); - - comppadlist = newAV(); - AvREAL_off(comppadlist); - av_store(comppadlist, 0, (SV*)PL_comppad_name); - av_store(comppadlist, 1, (SV*)PL_comppad); - CvPADLIST(cv) = comppadlist; - av_fill(PL_comppad, AvFILLp(protopad)); - PL_curpad = AvARRAY(PL_comppad); - - av = newAV(); /* will be @_ */ - av_extend(av, 0); - av_store(PL_comppad, 0, (SV*)av); - AvFLAGS(av) = AVf_REIFY; - - for (ix = fpad; ix > 0; ix--) { - SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; - if (namesv && namesv != &PL_sv_undef) { - char *name = SvPVX(namesv); /* XXX */ - if (SvFLAGS(namesv) & SVf_FAKE) { /* lexical from outside? */ - I32 off = pad_findlex(name, ix, SvIVX(namesv), - CvOUTSIDE(cv), cxstack_ix, 0, 0); - if (!off) - PL_curpad[ix] = SvREFCNT_inc(ppad[ix]); - else if (off != ix) - Perl_croak(aTHX_ "panic: cv_clone: %s", name); - } - else { /* our own lexical */ - SV* sv; - if (*name == '&') { - /* anon code -- we'll come back for it */ - sv = SvREFCNT_inc(ppad[ix]); - } - else if (*name == '@') - sv = (SV*)newAV(); - else if (*name == '%') - sv = (SV*)newHV(); - else - sv = NEWSV(0,0); - if (!SvPADBUSY(sv)) - SvPADMY_on(sv); - PL_curpad[ix] = sv; - } - } - else if (IS_PADGV(ppad[ix]) || IS_PADCONST(ppad[ix])) { - PL_curpad[ix] = SvREFCNT_inc(ppad[ix]); - } - else { - SV* sv = NEWSV(0,0); - SvPADTMP_on(sv); - PL_curpad[ix] = sv; - } - } - - /* Now that vars are all in place, clone nested closures. */ - - for (ix = fpad; ix > 0; ix--) { - SV* namesv = (ix <= fname) ? pname[ix] : Nullsv; - if (namesv - && namesv != &PL_sv_undef - && !(SvFLAGS(namesv) & SVf_FAKE) - && *SvPVX(namesv) == '&' - && CvCLONE(ppad[ix])) - { - CV *kid = cv_clone2((CV*)ppad[ix], cv); - SvREFCNT_dec(ppad[ix]); - CvCLONE_on(kid); - SvPADMY_on(kid); - PL_curpad[ix] = (SV*)kid; - } - } - -#ifdef DEBUG_CLOSURES - PerlIO_printf(Perl_debug_log, "Cloned inside:\n"); - cv_dump(outside); - PerlIO_printf(Perl_debug_log, " from:\n"); - cv_dump(proto); - PerlIO_printf(Perl_debug_log, " to:\n"); - cv_dump(cv); -#endif - - LEAVE; - - if (CvCONST(cv)) { - SV* const_sv = op_const_sv(CvSTART(cv), cv); - assert(const_sv); - /* constant sub () { $x } closing over $x - see lib/constant.pm */ - SvREFCNT_dec(cv); - cv = newCONSTSUB(CvSTASH(proto), 0, const_sv); - } - - return cv; -} - -CV * -Perl_cv_clone(pTHX_ CV *proto) -{ - CV *cv; - LOCK_CRED_MUTEX; /* XXX create separate mutex */ - cv = cv_clone2(proto, CvOUTSIDE(proto)); - UNLOCK_CRED_MUTEX; /* XXX create separate mutex */ - return cv; -} - void Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) { @@ -4739,8 +3996,7 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) if (type == OP_CONST && cSVOPo->op_sv) sv = cSVOPo->op_sv; else if ((type == OP_PADSV || type == OP_CONST) && cv) { - AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]); - sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv; + sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ); if (!sv) return Nullsv; if (CvCONST(cv)) { @@ -4791,7 +4047,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) GV *gv; char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch; register CV *cv=0; - I32 ix; SV *const_sv; name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; @@ -4956,28 +4211,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvPADLIST(cv) = CvPADLIST(PL_compcv); CvPADLIST(PL_compcv) = 0; /* inner references to PL_compcv must be fixed up ... */ - { - AV *padlist = CvPADLIST(cv); - AV *comppad_name = (AV*)AvARRAY(padlist)[0]; - AV *comppad = (AV*)AvARRAY(padlist)[1]; - SV **namepad = AvARRAY(comppad_name); - SV **curpad = AvARRAY(comppad); - for (ix = AvFILLp(comppad_name); ix > 0; ix--) { - SV *namesv = namepad[ix]; - if (namesv && namesv != &PL_sv_undef - && *SvPVX(namesv) == '&') - { - CV *innercv = (CV*)curpad[ix]; - if (CvOUTSIDE(innercv) == PL_compcv) { - CvOUTSIDE(innercv) = cv; - if (!CvANON(innercv) || CvCLONED(innercv)) { - (void)SvREFCNT_inc(cv); - SvREFCNT_dec(PL_compcv); - } - } - } - } - } + pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); /* ... before we throw it away */ SvREFCNT_dec(PL_compcv); if (PERLDB_INTER)/* Advice debugger on the new sub. */ @@ -5027,9 +4261,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!block) goto done; - if (AvFILLp(PL_comppad_name) < AvFILLp(PL_comppad)) - av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv); - if (CvLVALUE(cv)) { CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, mod(scalarseq(block), OP_LEAVESUBLV)); @@ -5044,44 +4275,14 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CALL_PEEP(CvSTART(cv)); /* now that optimizer has done its work, adjust pad values */ - if (CvCLONE(cv)) { - SV **namep = AvARRAY(PL_comppad_name); - for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { - SV *namesv; - if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix])) - continue; - /* - * The only things that a clonable function needs in its - * pad are references to outer lexicals and anonymous subs. - * The rest are created anew during cloning. - */ - if (!((namesv = namep[ix]) != Nullsv && - namesv != &PL_sv_undef && - (SvFAKE(namesv) || - *SvPVX(namesv) == '&'))) - { - SvREFCNT_dec(PL_curpad[ix]); - PL_curpad[ix] = Nullsv; - } - } + pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB); + + if (CvCLONE(cv)) { assert(!CvCONST(cv)); if (ps && !*ps && op_const_sv(block, cv)) CvCONST_on(cv); } - else { - AV *av = newAV(); /* Will be @_ */ - av_extend(av, 0); - av_store(PL_comppad, 0, (SV*)av); - AvFLAGS(av) = AVf_REIFY; - - for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { - if (SvIMMORTAL(PL_curpad[ix]) || IS_PADGV(PL_curpad[ix]) || IS_PADCONST(PL_curpad[ix])) - continue; - if (!SvPADMY(PL_curpad[ix])) - SvPADTMP_on(PL_curpad[ix]); - } - } /* If a potential closure prototype, don't keep a refcount on outer CV. * This is okay as the lifetime of the prototype is tied to the @@ -5337,7 +4538,6 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) register CV *cv; char *name; GV *gv; - I32 ix; STRLEN n_a; if (o) @@ -5366,11 +4566,8 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) CvGV(cv) = gv; CvFILE_set_from_cop(cv, PL_curcop); - for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { - if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix])) - SvPADTMP_on(PL_curpad[ix]); - } + pad_tidy(padtidy_FORMAT); CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); CvROOT(cv)->op_private |= OPpREFCOUNTED; OpREFCNT_set(CvROOT(cv), 1); @@ -5532,20 +4729,8 @@ Perl_newSVREF(pTHX_ OP *o) OP * Perl_ck_anoncode(pTHX_ OP *o) { - PADOFFSET ix; - SV* name; - - name = NEWSV(1106,0); - sv_upgrade(name, SVt_PVNV); - sv_setpvn(name, "&", 1); - SvIVX(name) = -1; - SvNVX(name) = 1; - ix = pad_alloc(o->op_type, SVs_PADMY); - av_store(PL_comppad_name, ix, name); - av_store(PL_comppad, ix, cSVOPo->op_sv); - SvPADMY_on(cSVOPo->op_sv); + cSVOPo->op_targ = pad_add_anon(cSVOPo->op_sv, o->op_type); cSVOPo->op_sv = Nullsv; - cSVOPo->op_targ = ix; return o; } @@ -5837,9 +5022,9 @@ Perl_ck_rvconst(pTHX_ register OP *o) #ifdef USE_ITHREADS /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */ kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); - SvREFCNT_dec(PL_curpad[kPADOP->op_padix]); + SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); GvIN_PAD_on(gv); - PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv); + PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc(gv)); #else kid->op_sv = SvREFCNT_inc(gv); #endif @@ -6014,7 +5199,7 @@ Perl_ck_fun(pTHX_ OP *o) /* is this op a FH constructor? */ if (is_handle_constructor(o,numargs)) { char *name = Nullch; - STRLEN len; + STRLEN len = 0; flags = 0; /* Set a flag to tell rv2gv to vivify @@ -6023,10 +5208,17 @@ Perl_ck_fun(pTHX_ OP *o) */ priv = OPpDEREF; if (kid->op_type == OP_PADSV) { - SV **namep = av_fetch(PL_comppad_name, - kid->op_targ, 4); - if (namep && *namep) - name = SvPV(*namep, len); + /*XXX DAPM 2002.08.25 tmp assert test */ + /*XXX*/ assert(av_fetch(PL_comppad_name, (kid->op_targ), FALSE)); + /*XXX*/ assert(*av_fetch(PL_comppad_name, (kid->op_targ), FALSE)); + + name = PAD_COMPNAME_PV(kid->op_targ); + /* SvCUR of a pad namesv can't be trusted + * (see PL_generation), so calc its length + * manually */ + if (name) + len = strlen(name); + } else if (kid->op_type == OP_RV2SV && kUNOP->op_first->op_type == OP_GV) @@ -6045,7 +5237,7 @@ Perl_ck_fun(pTHX_ OP *o) if (name) { SV *namesv; targ = pad_alloc(OP_RV2GV, SVs_PADTMP); - namesv = PL_curpad[targ]; + namesv = PAD_SVl(targ); (void)SvUPGRADE(namesv, SVt_PV); if (*name != '$') sv_setpvn(namesv, "$", 1); @@ -6501,7 +5693,7 @@ Perl_ck_shift(pTHX_ OP *o) #ifdef USE_5005THREADS if (!CvUNIQUE(PL_compcv)) { argop = newOP(OP_PADAV, OPf_REF); - argop->op_targ = 0; /* PL_curpad[0] is @_ */ + argop->op_targ = 0; /* PAD_SV(0) is @_ */ } else { argop = newUNOP(OP_RV2AV, 0, @@ -7013,16 +6205,16 @@ Perl_peep(pTHX_ register OP *o) if (SvPADTMP(cSVOPo->op_sv)) { /* If op_sv is already a PADTMP then it is being used by * some pad, so make a copy. */ - sv_setsv(PL_curpad[ix],cSVOPo->op_sv); - SvREADONLY_on(PL_curpad[ix]); + sv_setsv(PAD_SVl(ix),cSVOPo->op_sv); + SvREADONLY_on(PAD_SVl(ix)); SvREFCNT_dec(cSVOPo->op_sv); } else { - SvREFCNT_dec(PL_curpad[ix]); + SvREFCNT_dec(PAD_SVl(ix)); SvPADTMP_on(cSVOPo->op_sv); - PL_curpad[ix] = cSVOPo->op_sv; + PAD_SETSV(ix, cSVOPo->op_sv); /* XXX I don't know how this isn't readonly already. */ - SvREADONLY_on(PL_curpad[ix]); + SvREADONLY_on(PAD_SVl(ix)); } cSVOPo->op_sv = Nullsv; o->op_targ = ix; -- cgit v1.2.1