X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=faf4ad8ffc5cfcb51c83801dee33dcafc62ff440;hb=fdb2241864c257e44490544064b09a293414e55f;hp=af125aa4afb7a6a1de39a6a8af1663c4b3d4b047;hpb=ad4c42df6bd5c3e95a77b950de1458bce8939ec3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index af125aa..faf4ad8 100644 --- a/op.c +++ b/op.c @@ -1,6 +1,6 @@ /* op.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (c) 1991-2002, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -15,6 +15,7 @@ * either way, as the saying is, if you follow me." --the Gaffer */ + #include "EXTERN.h" #define PERL_IN_OP_C #include "perl.h" @@ -22,28 +23,79 @@ #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) -/* #define PL_OP_SLAB_ALLOC */ +#if defined(PL_OP_SLAB_ALLOC) + +#ifndef PERL_SLAB_SIZE +#define PERL_SLAB_SIZE 2048 +#endif + +#define NewOp(m,var,c,type) \ + STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END -#if defined(PL_OP_SLAB_ALLOC) && !defined(PERL_IMPLICIT_CONTEXT) -#define SLAB_SIZE 8192 -static char *PL_OpPtr = NULL; /* XXX threadead */ -static int PL_OpSpace = 0; /* XXX threadead */ -#define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \ - var = (type *)(PL_OpPtr -= c*sizeof(type)); \ - else \ - var = (type *) Slab_Alloc(m,c*sizeof(type)); \ - } while (0) +#define FreeOp(p) Slab_Free(p) STATIC void * S_Slab_Alloc(pTHX_ int m, size_t sz) { - Newz(m,PL_OpPtr,SLAB_SIZE,char); - PL_OpSpace = SLAB_SIZE - sz; - return PL_OpPtr += PL_OpSpace; + /* + * To make incrementing use count easy PL_OpSlab is an I32 * + * To make inserting the link to slab PL_OpPtr is I32 ** + * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments + * Add an overhead for pointer to slab and round up as a number of pointers + */ + sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *); + if ((PL_OpSpace -= sz) < 0) { + PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*)); + if (!PL_OpPtr) { + return NULL; + } + Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **); + /* We reserve the 0'th I32 sized chunk as a use count */ + PL_OpSlab = (I32 *) PL_OpPtr; + /* Reduce size by the use count word, and by the size we need. + * Latter is to mimic the '-=' in the if() above + */ + PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz; + /* Allocation pointer starts at the top. + Theory: because we build leaves before trunk allocating at end + means that at run time access is cache friendly upward + */ + PL_OpPtr += PERL_SLAB_SIZE; + } + assert( PL_OpSpace >= 0 ); + /* Move the allocation pointer down */ + PL_OpPtr -= sz; + assert( PL_OpPtr > (I32 **) PL_OpSlab ); + *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */ + (*PL_OpSlab)++; /* Increment use count of slab */ + assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) ); + assert( *PL_OpSlab > 0 ); + return (void *)(PL_OpPtr + 1); +} + +STATIC void +S_Slab_Free(pTHX_ void *op) +{ + I32 **ptr = (I32 **) op; + I32 *slab = ptr[-1]; + assert( ptr-1 > (I32 **) slab ); + assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) ); + assert( *slab > 0 ); + if (--(*slab) == 0) { + #ifdef NETWARE + #define PerlMemShared PerlMem + #endif + + PerlMemShared_free(slab); + if (slab == PL_OpSlab) { + PL_OpSpace = 0; + } + } } #else #define NewOp(m, var, c, type) Newz(m, var, c, type) +#define FreeOp(p) Safefree(p) #endif /* * In the following definition, the ", Nullop" is just to make the compiler @@ -52,11 +104,10 @@ S_Slab_Alloc(pTHX_ int m, size_t sz) #define CHECKOP(type,o) \ ((PL_op_mask && PL_op_mask[type]) \ ? ( op_free((OP*)o), \ - Perl_croak(aTHX_ "%s trapped by operation mask", PL_op_desc[type]), \ + Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \ Nullop ) \ : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) -#define PAD_MAX 999999999 #define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) STATIC char* @@ -101,18 +152,18 @@ STATIC void S_no_bareword_allowed(pTHX_ OP *o) { qerror(Perl_mess(aTHX_ - "Bareword \"%s\" not allowed while \"strict subs\" in use", - SvPV_nolen(cSVOPo_sv))); + "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", + cSVOPo_sv)); } /* "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])) || @@ -139,553 +190,31 @@ 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; 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_ 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_ WARN_MISC, - "\"our\" variable %s redeclared", name); - Perl_warner(aTHX_ 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 <= SvIVX(sv) && - seq > 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_ 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_ 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. - */ - - 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); - } - } - - 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; - -#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 <= SvIVX(sv) && - seq > 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_ 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 - SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */ -#endif - } - if ((I32)po < PL_padix) - PL_padix = po - 1; -} -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 */ - 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; + /* check for duplicate declaration */ + pad_check_dup(name, + PL_in_my == KEY_our, + (PL_curstash ? PL_curstash : PL_defstash) + ); - 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; + 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")); } -#endif - PL_pad_reset_pending = FALSE; -} -#ifdef USE_5005THREADS -/* find_threadsv is not reentrant */ -PADOFFSET -Perl_find_threadsv(pTHX_ const char *name) -{ - char *p; - PADOFFSET key; - SV **svp; - /* We currently only handle names of a single character */ - p = strchr(PL_threadsv_names, *name); - if (!p) - return NOT_IN_PAD; - key = p - PL_threadsv_names; - MUTEX_LOCK(&thr->mutex); - svp = av_fetch(thr->threadsv, key, FALSE); - if (svp) - MUTEX_UNLOCK(&thr->mutex); - else { - SV *sv = NEWSV(0, 0); - av_store(thr->threadsv, key, sv); - thr->threadsvp = AvARRAY(thr->threadsv); - MUTEX_UNLOCK(&thr->mutex); - /* - * Some magic variables used to be automagically initialised - * in gv_fetchpv. Those which are now per-thread magicals get - * initialised here instead. - */ - switch (*name) { - case '_': - break; - case ';': - sv_setpv(sv, "\034"); - sv_magic(sv, 0, PERL_MAGIC_sv, name, 1); - break; - case '&': - case '`': - case '\'': - PL_sawampersand = TRUE; - /* FALL THROUGH */ - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - case '8': - case '9': - SvREADONLY_on(sv); - /* FALL THROUGH */ - - /* XXX %! tied to Errno.pm needs to be added here. - * See gv_fetchpv(). */ - /* case '!': */ + /* allocate a spare slot and store the name in that slot */ - default: - sv_magic(sv, 0, PERL_MAGIC_sv, name, 1); - } - DEBUG_S(PerlIO_printf(Perl_error_log, - "find_threadsv: new SV %p for $%s%c\n", - sv, (*name < 32) ? "^" : "", - (*name < 32) ? toCTRL(*name) : *name)); - } - return key; + 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; } -#endif /* USE_5005THREADS */ /* Destructor */ @@ -726,7 +255,7 @@ Perl_op_free(pTHX_ OP *o) } type = o->op_type; if (type == OP_NULL) - type = o->op_targ; + type = (OPCODE)o->op_targ; /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ @@ -734,14 +263,7 @@ Perl_op_free(pTHX_ OP *o) cop_free((COP*)o); op_clear(o); - -#ifdef PL_OP_SLAB_ALLOC - if ((char *) o == PL_OpPtr) - { - } -#else - Safefree(o); -#endif + FreeOp(o); } void @@ -751,17 +273,8 @@ Perl_op_clear(pTHX_ OP *o) switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ case OP_ENTEREVAL: /* Was holding hints. */ -#ifdef USE_5005THREADS - case OP_THREADSV: /* Was holding index into thr->threadsv AV. */ -#endif o->op_targ = 0; break; -#ifdef USE_5005THREADS - case OP_ENTERITER: - if (!(o->op_flags & OPf_SPECIAL)) - break; - /* FALL THROUGH */ -#endif /* USE_5005THREADS */ default: if (!(o->op_flags & OPf_REF) || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst))) @@ -772,13 +285,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 @@ -814,13 +323,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); @@ -846,11 +351,7 @@ clear_pmop: pmop = pmop->op_pmnext; } } -#ifdef USE_ITHREADS - Safefree(PmopSTASHPV(cPMOPo)); -#else - /* NOTE: PMOP.op_pmstash is not refcounted */ -#endif + PmopSTASH_free(cPMOPo); } cPMOPo->op_pmreplroot = Nullop; /* we use the "SAFE" version of the PM_ macros here @@ -867,7 +368,7 @@ clear_pmop: SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]); PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset); } -#endif +#endif break; } @@ -881,18 +382,22 @@ clear_pmop: STATIC void S_cop_free(pTHX_ COP* cop) { - Safefree(cop->cop_label); -#ifdef USE_ITHREADS - Safefree(CopFILE(cop)); /* XXX share in a pvtable? */ - Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */ -#else - /* NOTE: COP.cop_stash is not refcounted */ - SvREFCNT_dec(CopFILEGV(cop)); -#endif + Safefree(cop->cop_label); /* FIXME: treaddead ??? */ + CopFILE_free(cop); + CopSTASH_free(cop); if (! specialWARN(cop->cop_warnings)) SvREFCNT_dec(cop->cop_warnings); - if (! specialCopIO(cop->cop_io)) + if (! specialCopIO(cop->cop_io)) { +#ifdef USE_ITHREADS +#if 0 + STRLEN len; + char *s = SvPV(cop->cop_io,len); + Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */ +#endif +#else SvREFCNT_dec(cop->cop_io); +#endif + } } void @@ -954,7 +459,7 @@ S_scalarboolean(pTHX_ OP *o) if (PL_copline != NOLINE) CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be =="); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); CopLINE_set(PL_curcop, oldline); } } @@ -988,7 +493,7 @@ Perl_scalar(pTHX_ OP *o) case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { if (!kPMOP->op_pmreplroot) - deprecate("implicit split to @_"); + deprecate_old("implicit split to @_"); } /* FALL THROUGH */ case OP_MATCH: @@ -1024,6 +529,9 @@ Perl_scalar(pTHX_ OP *o) } WITH_THR(PL_curcop = &PL_compiling); break; + case OP_SORT: + if (ckWARN(WARN_VOID)) + Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); } return o; } @@ -1140,6 +648,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_GGRNAM: case OP_GGRGID: case OP_GETLOGIN: + case OP_PROTOTYPE: func_ops: if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) useless = OP_DESC(o); @@ -1195,6 +704,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_OR: case OP_AND: + case OP_DOR: case OP_COND_EXPR: for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) scalarvoid(kid); @@ -1232,12 +742,12 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { if (!kPMOP->op_pmreplroot) - deprecate("implicit split to @_"); + deprecate_old("implicit split to @_"); } break; } if (useless && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless); + Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless); return o; } @@ -1369,7 +879,6 @@ OP * Perl_mod(pTHX_ OP *o, I32 type) { OP *kid; - STRLEN n_a; if (!o || PL_error_count) return o; @@ -1413,6 +922,8 @@ Perl_mod(pTHX_ OP *o, I32 type) op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ break; } + else if (o->op_private & OPpENTERSUB_NOMOD) + return o; else { /* lvalue subroutine call */ o->op_private |= OPpLVAL_INTRO; PL_modcount = RETURN_UNLIMITED_NUMBER; @@ -1444,11 +955,6 @@ Perl_mod(pTHX_ OP *o, I32 type) { UNOP *newop; - if (kid->op_sibling || kid->op_next != kid) { - yyerror("panic: unexpected optree near method call"); - break; - } - NewOp(1101, newop, 1, UNOP); newop->op_type = OP_RV2CV; newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; @@ -1458,7 +964,7 @@ Perl_mod(pTHX_ OP *o, I32 type) newop->op_private |= OPpLVAL_INTRO; break; } - + if (kid->op_type != OP_RV2CV) Perl_croak(aTHX_ "panic: unexpected lvalue entersub " @@ -1467,12 +973,12 @@ Perl_mod(pTHX_ OP *o, I32 type) kid->op_private |= OPpLVAL_INTRO; break; /* Postpone until runtime */ } - - okid = kid; + + okid = kid; kid = kUNOP->op_first; if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV) kid = kUNOP->op_first; - if (kid->op_type == OP_NULL) + if (kid->op_type == OP_NULL) Perl_croak(aTHX_ "Unexpected constant lvalue entersub " "entry via type/targ %ld:%"UVuf, @@ -1492,7 +998,7 @@ Perl_mod(pTHX_ OP *o, I32 type) okid->op_private |= OPpLVAL_INTRO; break; } - + cv = GvCV(kGVOP_gv); if (!cv) goto restore_2cv; @@ -1539,7 +1045,7 @@ Perl_mod(pTHX_ OP *o, I32 type) goto nomod; PL_modcount++; break; - + case OP_COND_EXPR: for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) mod(kid, type); @@ -1567,7 +1073,6 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_AASSIGN: case OP_NEXTSTATE: case OP_DBSTATE: - case OP_CHOMP: PL_modcount = RETURN_UNLIMITED_NUMBER; break; case OP_RV2SV: @@ -1581,6 +1086,7 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_SASSIGN: case OP_ANDASSIGN: case OP_ORASSIGN: + case OP_DORASSIGN: case OP_AELEMFAST: PL_modcount++; break; @@ -1598,19 +1104,18 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_PADSV: PL_modcount++; if (!type) - Perl_croak(aTHX_ "Can't localize lexical variable %s", - SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a)); - break; + { /* 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)); -#ifdef USE_5005THREADS - case OP_THREADSV: - PL_modcount++; /* XXX ??? */ + Perl_croak(aTHX_ "Can't localize lexical variable %s", + PAD_COMPNAME_PV(o->op_targ)); + } break; -#endif /* USE_5005THREADS */ case OP_PUSHMARK: break; - + case OP_KEYS: if (type != OP_SASSIGN) goto nomod; @@ -1888,7 +1393,7 @@ S_dup_attrlist(pTHX_ OP *o) } STATIC void -S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) +S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) { SV *stashsv; @@ -1901,19 +1406,99 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) stashsv = &PL_sv_no; #define ATTRSMODULE "attributes" +#define ATTRSMODULE_PM "attributes.pm" - Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, - newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), - Nullsv, - prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, stashsv), - prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, - newRV(target)), - dup_attrlist(attrs)))); + if (for_my) { + SV **svp; + /* Don't force the C if we don't need it. */ + svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, + sizeof(ATTRSMODULE_PM)-1, 0); + if (svp && *svp != &PL_sv_undef) + ; /* already in %INC */ + else + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), + Nullsv); + } + else { + Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, + newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), + Nullsv, + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, stashsv), + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV(target)), + dup_attrlist(attrs)))); + } LEAVE; } +STATIC void +S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) +{ + OP *pack, *imop, *arg; + SV *meth, *stashsv; + + if (!attrs) + return; + + assert(target->op_type == OP_PADSV || + target->op_type == OP_PADHV || + target->op_type == OP_PADAV); + + /* Ensure that attributes.pm is loaded. */ + 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)); + + /* Build up the real arg-list. */ + if (stash) + stashsv = newSVpv(HvNAME(stash), 0); + else + stashsv = &PL_sv_no; + arg = newOP(OP_PADSV, 0); + arg->op_targ = target->op_targ; + arg = prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, stashsv), + prepend_elem(OP_LIST, + newUNOP(OP_REFGEN, 0, + mod(arg, OP_REFGEN)), + dup_attrlist(attrs))); + + /* Fake up a method call to import */ + meth = newSVpvn("import", 6); + (void)SvUPGRADE(meth, SVt_PVIV); + (void)SvIOK_on(meth); + PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); + imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, + append_elem(OP_LIST, + prepend_elem(OP_LIST, pack, list(arg)), + newSVOP(OP_METHOD_NAMED, 0, meth))); + imop->op_private |= OPpENTERSUB_NOMOD; + + /* Combine the ops. */ + *imopsp = append_elem(OP_LIST, *imopsp, imop); +} + +/* +=notfor apidoc apply_attrs_string + +Attempts to apply a list of attributes specified by the C and +C arguments to the subroutine identified by the C argument which +is expected to be associated with the package identified by the C +argument (see L). It gets this wrong, though, in that it +does not correctly identify the boundaries of the individual attribute +specifications within C. This is not really intended for the +public API, but has to be listed here for systems such as AIX which +need an explicit export list for symbols. (It's called from XS code +in support of the C keyword from F.) Patches to fix it +to respect attribute syntax properly would be welcome. + +=cut +*/ + void Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, char *attrstr, STRLEN len) @@ -1946,7 +1531,7 @@ Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, } STATIC OP * -S_my_kid(pTHX_ OP *o, OP *attrs) +S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) { OP *kid; I32 type; @@ -1957,25 +1542,29 @@ S_my_kid(pTHX_ OP *o, OP *attrs) type = o->op_type; if (type == OP_LIST) { for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) - my_kid(kid, attrs); + my_kid(kid, attrs, imopsp); } else if (type == OP_UNDEF) { return o; } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ - if (attrs) { - GV *gv = cGVOPx_gv(cUNOPo->op_first); - PL_in_my = FALSE; - PL_in_my_stash = Nullhv; - apply_attrs(GvSTASH(gv), - (type == OP_RV2SV ? GvSV(gv) : - type == OP_RV2AV ? (SV*)GvAV(gv) : - type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv), - attrs); - } + if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ + yyerror(Perl_form(aTHX_ "Can't declare %s in %s", + OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); + } else if (attrs) { + GV *gv = cGVOPx_gv(cUNOPo->op_first); + PL_in_my = FALSE; + PL_in_my_stash = Nullhv; + apply_attrs(GvSTASH(gv), + (type == OP_RV2SV ? GvSV(gv) : + type == OP_RV2AV ? (SV*)GvAV(gv) : + type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv), + attrs, FALSE); + } o->op_private |= OPpOUR_INTRO; return o; - } else if (type != OP_PADSV && + } + else if (type != OP_PADSV && type != OP_PADAV && type != OP_PADHV && type != OP_PUSHMARK) @@ -1987,20 +1576,15 @@ S_my_kid(pTHX_ OP *o, OP *attrs) } else if (attrs && type != OP_PUSHMARK) { HV *stash; - SV *padsv; - 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; - padsv = PAD_SV(o->op_targ); - apply_attrs(stash, padsv, attrs); + apply_attrs_my(stash, o, attrs, imopsp); } o->op_flags |= OPf_MOD; o->op_private |= OPpLVAL_INTRO; @@ -2010,11 +1594,30 @@ S_my_kid(pTHX_ OP *o, OP *attrs) OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs) { + OP *rops = Nullop; + int maybe_scalar = 0; + +/* [perl #17376]: this appears to be premature, and results in code such as + C< our(%x); > executing in list mode rather than void mode */ +#if 0 if (o->op_flags & OPf_PARENS) list(o); + else + maybe_scalar = 1; +#else + maybe_scalar = 1; +#endif if (attrs) SAVEFREEOP(attrs); - o = my_kid(o, attrs); + o = my_kid(o, attrs, &rops); + if (rops) { + if (maybe_scalar && o->op_type == OP_PADSV) { + o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o)); + o->op_private |= OPpLVAL_INTRO; + } + else + o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); + } PL_in_my = FALSE; PL_in_my_stash = Nullhv; return o; @@ -2023,7 +1626,7 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) OP * Perl_my(pTHX_ OP *o) { - return my_kid(o, Nullop); + return my_attrs(o, Nullop); } OP * @@ -2050,25 +1653,26 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) const char *sample = ((left->op_type == OP_RV2AV || left->op_type == OP_PADAV) ? "@array" : "%hash"); - Perl_warner(aTHX_ WARN_MISC, + Perl_warner(aTHX_ packWARN(WARN_MISC), "Applying %s to %s will act on scalar(%s)", desc, sample, sample); } + if (right->op_type == OP_CONST && + cSVOPx(right)->op_private & OPpCONST_BARE && + cSVOPx(right)->op_private & OPpCONST_STRICT) + { + no_bareword_allowed(right); + } + if (!(right->op_flags & OPf_STACKED) && (right->op_type == OP_MATCH || right->op_type == OP_SUBST || right->op_type == OP_TRANS)) { right->op_flags |= OPf_STACKED; - if ((right->op_type != OP_MATCH && - ! (right->op_type == OP_TRANS && - right->op_private & OPpTRANS_IDENTICAL)) || - /* if SV has magic, then match on original SV, not on its copy. - see note in pp_helem() */ - (right->op_type == OP_MATCH && - (left->op_type == OP_AELEM || - left->op_type == OP_HELEM || - left->op_type == OP_AELEMFAST))) + if (right->op_type != OP_MATCH && + ! (right->op_type == OP_TRANS && + right->op_private & OPpTRANS_IDENTICAL)) left = mod(left, right->op_type); if (right->op_type == OP_TRANS) o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); @@ -2101,18 +1705,16 @@ Perl_scope(pTHX_ OP *o) o->op_type = OP_LEAVE; o->op_ppaddr = PL_ppaddr[OP_LEAVE]; } - else { - if (o->op_type == OP_LINESEQ) { - OP *kid; - o->op_type = OP_SCOPE; - o->op_ppaddr = PL_ppaddr[OP_SCOPE]; - kid = ((LISTOP*)o)->op_first; - if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) - op_null(kid); - } - else - o = newLISTOP(OP_SCOPE, 0, o, Nullop); + else if (o->op_type == OP_LINESEQ) { + OP *kid; + o->op_type = OP_SCOPE; + o->op_ppaddr = PL_ppaddr[OP_SCOPE]; + kid = ((LISTOP*)o)->op_first; + if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) + op_null(kid); } + else + o = newLISTOP(OP_SCOPE, 0, o, Nullop); } return o; } @@ -2130,20 +1732,10 @@ int Perl_block_start(pTHX_ int full) { int retval = PL_savestack_ix; + /* If there were syntax errors, don't try to start a block */ + if (PL_yynerrs) return retval; - 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); @@ -2164,29 +1756,28 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) { int needblockscope = PL_hints & HINT_BLOCK_SCOPE; line_t copline = PL_copline; - /* there should be a nextstate in every block */ - OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq); - PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */ + OP* retval = scalarseq(seq); + /* If there were syntax errors, don't try to close a block */ + if (PL_yynerrs) return retval; + if (!seq) { + /* scalarseq() gave us an OP_STUB */ + retval->op_flags |= OPf_PARENS; + /* there should be a nextstate in every block */ + retval = newSTATEOP(0, Nullch, retval); + PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */ + } LEAVE_SCOPE(floor); - PL_pad_reset_pending = FALSE; - PL_compiling.op_private = PL_hints; + 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; } STATIC OP * S_newDEFSVOP(pTHX) { -#ifdef USE_5005THREADS - OP *o = newOP(OP_THREADSV, 0); - o->op_targ = find_threadsv("_"); - return o; -#else return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); -#endif /* USE_5005THREADS */ } void @@ -2234,7 +1825,13 @@ OP * Perl_localize(pTHX_ OP *o, I32 lex) { if (o->op_flags & OPf_PARENS) +/* [perl #17376]: this appears to be premature, and results in code such as + C< our(%x); > executing in list mode rather than void mode */ +#if 0 list(o); +#else + ; +#endif else { if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') @@ -2245,7 +1842,7 @@ Perl_localize(pTHX_ OP *o, I32 lex) s++; if (*s == ';' || *s == '=') - Perl_warner(aTHX_ WARN_PARENTHESIS, + Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS), "Parentheses missing around \"%s\" list", lex ? (PL_in_my == KEY_our ? "our" : "my") : "local"); } @@ -2264,12 +1861,7 @@ Perl_jmaybe(pTHX_ OP *o) { if (o->op_type == OP_LIST) { OP *o2; -#ifdef USE_5005THREADS - o2 = newOP(OP_THREADSV, 0); - o2->op_targ = find_threadsv(";"); -#else o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), -#endif /* USE_5005THREADS */ o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); } return o; @@ -2340,7 +1932,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); @@ -2348,45 +1940,9 @@ Perl_fold_constants(pTHX_ register OP *o) op_free(o); if (type == OP_RV2GV) return newGVOP(OP_GV, 0, (GV*)sv); - else { - /* try to smush double to int, but don't smush -2.0 to -2 */ - if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK && - type != OP_NEGATE) - { -#ifdef PERL_PRESERVE_IVUV - /* Only bother to attempt to fold to IV if - most operators will benefit */ - SvIV_please(sv); -#endif - } - return newSVOP(OP_CONST, 0, sv); - } + return newSVOP(OP_CONST, 0, sv); nope: - if (!(PL_opargs[type] & OA_OTHERINT)) - return o; - - if (!(PL_hints & HINT_INTEGER)) { - if (type == OP_MODULO - || type == OP_DIVIDE - || !(o->op_flags & OPf_KIDS)) - { - return o; - } - - for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) { - if (curop->op_type == OP_CONST) { - if (SvIOK(((SVOP*)curop)->op_sv)) - continue; - return o; - } - if (PL_opargs[curop->op_type] & OA_RETINTEGER) - continue; - return o; - } - o->op_ppaddr = PL_ppaddr[++(o->op_type)]; - } - return o; } @@ -2411,6 +1967,7 @@ Perl_gen_constant_list(pTHX_ register OP *o) o->op_type = OP_RV2AV; o->op_ppaddr = PL_ppaddr[OP_RV2AV]; + o->op_seq = 0; /* needs to be revisited in peep() */ curop = ((UNOP*)o)->op_first; ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--)); op_free(curop); @@ -2429,7 +1986,7 @@ Perl_convert(pTHX_ I32 type, I32 flags, OP *o) if (!(PL_opargs[type] & OA_MARK)) op_null(cLISTOPo->op_first); - o->op_type = type; + o->op_type = (OPCODE)type; o->op_ppaddr = PL_ppaddr[type]; o->op_flags |= flags; @@ -2486,10 +2043,8 @@ Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) first->op_last = last->op_last; first->op_flags |= (last->op_flags & OPf_KIDS); -#ifdef PL_OP_SLAB_ALLOC -#else - Safefree(last); -#endif + FreeOp(last); + return (OP*)first; } @@ -2548,11 +2103,11 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) NewOp(1101, listop, 1, LISTOP); - listop->op_type = type; + listop->op_type = (OPCODE)type; listop->op_ppaddr = PL_ppaddr[type]; if (first || last) flags |= OPf_KIDS; - listop->op_flags = flags; + listop->op_flags = (U8)flags; if (!last && first) last = first; @@ -2580,12 +2135,12 @@ Perl_newOP(pTHX_ I32 type, I32 flags) { OP *o; NewOp(1101, o, 1, OP); - o->op_type = type; + o->op_type = (OPCODE)type; o->op_ppaddr = PL_ppaddr[type]; - o->op_flags = flags; + o->op_flags = (U8)flags; o->op_next = o; - o->op_private = 0 + (flags >> 8); + o->op_private = (U8)(0 | (flags >> 8)); if (PL_opargs[type] & OA_RETSCALAR) scalar(o); if (PL_opargs[type] & OA_TARGET) @@ -2604,11 +2159,11 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) first = force_list(first); NewOp(1101, unop, 1, UNOP); - unop->op_type = type; + unop->op_type = (OPCODE)type; unop->op_ppaddr = PL_ppaddr[type]; unop->op_first = first; unop->op_flags = flags | OPf_KIDS; - unop->op_private = 1 | (flags >> 8); + unop->op_private = (U8)(1 | (flags >> 8)); unop = (UNOP*) CHECKOP(type, unop); if (unop->op_next) return (OP*)unop; @@ -2625,21 +2180,21 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) if (!first) first = newOP(OP_NULL, 0); - binop->op_type = type; + binop->op_type = (OPCODE)type; binop->op_ppaddr = PL_ppaddr[type]; binop->op_first = first; binop->op_flags = flags | OPf_KIDS; if (!last) { last = first; - binop->op_private = 1 | (flags >> 8); + binop->op_private = (U8)(1 | (flags >> 8)); } else { - binop->op_private = 2 | (flags >> 8); + binop->op_private = (U8)(2 | (flags >> 8)); first->op_sibling = last; } binop = (BINOP*)CHECKOP(type, binop); - if (binop->op_next || binop->op_type != type) + if (binop->op_next || binop->op_type != (OPCODE)type) return (OP*)binop; binop->op_last = binop->op_first->op_sibling; @@ -2773,7 +2328,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) U8 range_mark = UTF_TO_NATIVE(0xff); sv_catpvn(transv, (char *)&range_mark, 1); } - t = uvuni_to_utf8(tmpbuf, 0x7fffffff); + t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff, + UNICODE_ALLOW_SUPER); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); t = (U8*)SvPVX(transv); tlen = SvCUR(transv); @@ -2898,17 +2454,17 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) tbl = (short*)cPVOPo->op_pv; if (complement) { Zero(tbl, 256, short); - for (i = 0; i < tlen; i++) + for (i = 0; i < (I32)tlen; i++) tbl[t[i]] = -1; for (i = 0, j = 0; i < 256; i++) { if (!tbl[i]) { - if (j >= rlen) { + if (j >= (I32)rlen) { if (del) tbl[i] = -2; else if (rlen) tbl[i] = r[j-1]; else - tbl[i] = i; + tbl[i] = (short)i; } else { if (i < 128 && r[j] >= 128) @@ -2923,12 +2479,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (!squash) o->op_private |= OPpTRANS_IDENTICAL; } - else if (j >= rlen) + else if (j >= (I32)rlen) j = rlen - 1; else cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short); tbl[0x100] = rlen - j; - for (i=0; i < rlen - j; i++) + for (i=0; i < (I32)rlen - j; i++) tbl[0x101+i] = r[j+i]; } } @@ -2938,10 +2494,13 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (!squash) o->op_private |= OPpTRANS_IDENTICAL; } + else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) { + o->op_private |= OPpTRANS_IDENTICAL; + } for (i = 0; i < 256; i++) tbl[i] = -1; - for (i = 0, j = 0; i < tlen; i++,j++) { - if (j >= rlen) { + for (i = 0, j = 0; i < (I32)tlen; i++,j++) { + if (j >= (I32)rlen) { if (del) { if (tbl[t[i]] == -1) tbl[t[i]] = -2; @@ -2970,10 +2529,10 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) PMOP *pmop; NewOp(1101, pmop, 1, PMOP); - pmop->op_type = type; + pmop->op_type = (OPCODE)type; pmop->op_ppaddr = PL_ppaddr[type]; - pmop->op_flags = flags; - pmop->op_private = 0 | (flags >> 8); + pmop->op_flags = (U8)flags; + pmop->op_private = (U8)(0 | (flags >> 8)); if (PL_hints & HINT_RE_TAINT) pmop->op_pmpermflags |= PMf_RETAINT; @@ -2989,7 +2548,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) pmop->op_pmoffset = SvIV(repointer); SvREPADTMP_off(repointer); sv_setiv(repointer,0); - } else { + } else { repointer = newSViv(0); av_push(PL_regex_padav,SvREFCNT_inc(repointer)); pmop->op_pmoffset = av_len(PL_regex_padav); @@ -2997,7 +2556,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) } } #endif - + /* link into pm list */ if (type != OP_TRANS && PL_curstash) { pmop->op_pmnext = HvPMROOT(PL_curstash); @@ -3030,6 +2589,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; } + if (DO_UTF8(pat)) + pm->op_pmdynflags |= PMdf_UTF8; PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm)); if (strEQ("\\s+", PM_GETRE(pm)->precomp)) pm->op_pmflags |= PMf_WHITE; @@ -3070,36 +2631,20 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) if (pm->op_pmflags & PMf_EVAL) { curop = 0; if (CopLINE(PL_curcop) < PL_multi_end) - CopLINE_set(PL_curcop, PL_multi_end); + CopLINE_set(PL_curcop, (line_t)PL_multi_end); } -#ifdef USE_5005THREADS - else if (repl->op_type == OP_THREADSV - && strchr("&`'123456789+", - PL_threadsv_names[repl->op_targ])) - { - curop = 0; - } -#endif /* USE_5005THREADS */ else if (repl->op_type == OP_CONST) curop = repl; else { OP *lastop = 0; for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { if (PL_opargs[curop->op_type] & OA_DANGEROUS) { -#ifdef USE_5005THREADS - if (curop->op_type == OP_THREADSV) { - repl_has_vars = 1; - if (strchr("&`'123456789+", curop->op_private)) - break; - } -#else if (curop->op_type == OP_GV) { GV *gv = cGVOPx_gv(curop); repl_has_vars = 1; if (strchr("&`'123456789+", *GvENAME(gv))) break; } -#endif /* USE_5005THREADS */ else if (curop->op_type == OP_RV2CV) break; else if (curop->op_type == OP_RV2SV || @@ -3162,11 +2707,11 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) { SVOP *svop; NewOp(1101, svop, 1, SVOP); - svop->op_type = type; + svop->op_type = (OPCODE)type; svop->op_ppaddr = PL_ppaddr[type]; svop->op_sv = sv; svop->op_next = (OP*)svop; - svop->op_flags = flags; + svop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) scalar((OP*)svop); if (PL_opargs[type] & OA_TARGET) @@ -3179,14 +2724,15 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) { PADOP *padop; NewOp(1101, padop, 1, PADOP); - padop->op_type = type; + 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; - SvPADTMP_on(sv); + SvREFCNT_dec(PAD_SVl(padop->op_padix)); + PAD_SETSV(padop->op_padix, sv); + if (sv) + SvPADTMP_on(sv); padop->op_next = (OP*)padop; - padop->op_flags = flags; + padop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) scalar((OP*)padop); if (PL_opargs[type] & OA_TARGET) @@ -3198,7 +2744,8 @@ OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { #ifdef USE_ITHREADS - GvIN_PAD_on(gv); + if (gv) + GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc(gv)); #else return newSVOP(type, flags, SvREFCNT_inc(gv)); @@ -3210,11 +2757,11 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) { PVOP *pvop; NewOp(1101, pvop, 1, PVOP); - pvop->op_type = type; + pvop->op_type = (OPCODE)type; pvop->op_ppaddr = PL_ppaddr[type]; pvop->op_pv = pv; pvop->op_next = (OP*)pvop; - pvop->op_flags = flags; + pvop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) scalar((OP*)pvop); if (PL_opargs[type] & OA_TARGET) @@ -3225,24 +2772,17 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) void Perl_package(pTHX_ OP *o) { - SV *sv; + char *name; + STRLEN len; save_hptr(&PL_curstash); save_item(PL_curstname); - if (o) { - STRLEN len; - char *name; - sv = cSVOPo->op_sv; - name = SvPV(sv, len); - PL_curstash = gv_stashpvn(name,len,TRUE); - sv_setpvn(PL_curstname, name, len); - op_free(o); - } - else { - deprecate("\"package\" with no arguments"); - sv_setpv(PL_curstname,""); - PL_curstash = Nullhv; - } + + name = SvPV(cSVOPo->op_sv, len); + PL_curstash = gv_stashpvn(name, len, TRUE); + sv_setpvn(PL_curstname, name, len); + op_free(o); + PL_hints |= HINT_BLOCK_SCOPE; PL_copline = NOLINE; PL_expect = XSTATE; @@ -3254,9 +2794,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) OP *pack; OP *imop; OP *veop; - char *packname = Nullch; - STRLEN packlen = 0; - SV *packsv; if (id->op_type != OP_CONST) Perl_croak(aTHX_ "Module name must be constant"); @@ -3304,7 +2841,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); /* Fake up a method call to import/unimport */ - meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);; + meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8); (void)SvUPGRADE(meth, SVt_PVIV); (void)SvIOK_on(meth); PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); @@ -3314,15 +2851,6 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) newSVOP(OP_METHOD_NAMED, 0, meth))); } - if (ckWARN(WARN_MISC) && - imop && (imop != arg) && /* no warning on use 5.0; or explicit () */ - SvPOK(packsv = ((SVOP*)id)->op_sv)) - { - /* BEGIN will free the ops, so we need to make a copy */ - packlen = SvCUR(packsv); - packname = savepvn(SvPVX(packsv), packlen); - } - /* Fake up the BEGIN {}, which does its thing immediately. */ newATTRSUB(floor, newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)), @@ -3334,14 +2862,22 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) newSTATEOP(0, Nullch, veop)), newSTATEOP(0, Nullch, imop) )); - if (packname) { - if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) { - Perl_warner(aTHX_ WARN_MISC, - "Package `%s' not found " - "(did you use the incorrect case?)", packname); - } - safefree(packname); - } + /* The "did you use incorrect case?" warning used to be here. + * The problem is that on case-insensitive filesystems one + * might get false positives for "use" (and "require"): + * "use Strict" or "require CARP" will work. This causes + * portability problems for the script: in case-strict + * filesystems the script will stop working. + * + * The "incorrect case" warning checked whether "use Foo" + * imported "Foo" to your namespace, but that is wrong, too: + * there is no requirement nor promise in the language that + * a Foo.pm should or would contain anything in package "Foo". + * + * There is very little Configure-wise that can be done, either: + * the case-sensitivity of the build filesystem of Perl does not + * help in guessing the case-sensitivity of the runtime environment. + */ PL_hints |= HINT_BLOCK_SCOPE; PL_copline = NOLINE; @@ -3349,6 +2885,8 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) } /* +=head1 Embedding Functions + =for apidoc load_module Loads the module whose name is pointed to by the string part of name. @@ -3412,12 +2950,14 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) } { line_t ocopline = PL_copline; + COP *ocurcop = PL_curcop; int oexpect = PL_expect; utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), veop, modname, imop); PL_expect = oexpect; PL_copline = ocopline; + PL_curcop = ocurcop; } } @@ -3428,10 +2968,10 @@ Perl_dofile(pTHX_ OP *term) GV *gv; gv = gv_fetchpv("do", FALSE, SVt_PVCV); - if (!(gv && GvIMPORTED_CV(gv))) + if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV); - if (gv && GvIMPORTED_CV(gv)) { + if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, term, scalar(newUNOP(OP_RV2CV, 0, @@ -3472,6 +3012,11 @@ S_list_assignment(pTHX_ register OP *o) return FALSE; } + if (o->op_type == OP_LIST && + (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR && + o->op_private & OPpLVAL_INTRO) + return FALSE; + if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS || o->op_type == OP_RV2AV || o->op_type == OP_RV2HV || o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) @@ -3492,7 +3037,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) OP *o; if (optype) { - if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) { + if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) { return newLOGOP(optype, 0, mod(scalar(left), optype), newUNOP(OP_SASSIGN, 0, scalar(right))); @@ -3518,16 +3063,22 @@ 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 = 0 | (flags >> 8); - for (curop = ((LISTOP*)curop)->op_first; - curop; curop = curop->op_sibling) - { - if (curop->op_type == OP_RV2HV && - ((UNOP*)curop)->op_first->op_type != OP_GV) { - o->op_private |= OPpASSIGN_HASH; - break; - } - } + 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++; @@ -3535,19 +3086,21 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (PL_opargs[curop->op_type] & OA_DANGEROUS) { if (curop->op_type == OP_GV) { GV *gv = cGVOPx_gv(curop); - if (gv == PL_defgv || SvCUR(gv) == PL_generation) + if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) break; SvCUR(gv) = PL_generation; } 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 (SvCUR(sv) == PL_generation) + curop->op_type == OP_PADANY) + { + if (PAD_COMPNAME_GEN(curop->op_targ) + == (STRLEN)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; @@ -3561,14 +3114,15 @@ 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 - if (gv == PL_defgv || SvCUR(gv) == PL_generation) + if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation) break; SvCUR(gv) = PL_generation; - } + } } else break; @@ -3656,8 +3210,8 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->op_type = OP_NEXTSTATE; cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; } - cop->op_flags = flags; - cop->op_private = (PL_hints & HINT_PRIVATE_MASK); + cop->op_flags = (U8)flags; + cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif @@ -3695,37 +3249,15 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) if (PERLDB_LINE && PL_curstash != PL_debstash) { SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE); - if (svp && *svp != &PL_sv_undef ) { + if (svp && *svp != &PL_sv_undef ) { (void)SvIOK_on(*svp); SvIVX(*svp) = PTR2IV(cop); - } + } } 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) @@ -3761,8 +3293,12 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) } } if (first->op_type == OP_CONST) { - if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) - Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional"); + if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) { + if (first->op_private & OPpCONST_STRICT) + no_bareword_allowed(first); + else + Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); + } if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) { op_free(first); *firstp = Nullop; @@ -3774,12 +3310,6 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) return first; } } - else if (first->op_type == OP_WANTARRAY) { - if (type == OP_AND) - list(other); - else - scalar(other); - } else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) { OP *k1 = ((UNOP*)first)->op_first; OP *k2 = k1->op_sibling; @@ -3802,14 +3332,14 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) || k1->op_type == OP_EACH) { warnop = ((k1->op_type == OP_NULL) - ? k1->op_targ : k1->op_type); + ? (OPCODE)k1->op_targ : k1->op_type); } break; } if (warnop) { line_t oldline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ WARN_MISC, + Perl_warner(aTHX_ packWARN(WARN_MISC), "Value of %s%s can be \"0\"; test with defined()", PL_op_desc[warnop], ((warnop == OP_READLINE || warnop == OP_GLOB) @@ -3821,17 +3351,17 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if (!other) return first; - if (type == OP_ANDASSIGN || type == OP_ORASSIGN) + if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN) other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */ NewOp(1101, logop, 1, LOGOP); - logop->op_type = type; + logop->op_type = (OPCODE)type; logop->op_ppaddr = PL_ppaddr[type]; logop->op_first = first; logop->op_flags = flags | OPf_KIDS; logop->op_other = LINKLIST(other); - logop->op_private = 1 | (flags >> 8); + logop->op_private = (U8)(1 | (flags >> 8)); /* establish postfix order */ logop->op_next = LINKLIST(first); @@ -3858,6 +3388,10 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) scalarboolean(first); if (first->op_type == OP_CONST) { + if (first->op_private & OPpCONST_BARE && + first->op_private & OPpCONST_STRICT) { + no_bareword_allowed(first); + } if (SvTRUE(((SVOP*)first)->op_sv)) { op_free(first); op_free(falseop); @@ -3869,16 +3403,12 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) return falseop; } } - else if (first->op_type == OP_WANTARRAY) { - list(trueop); - scalar(falseop); - } NewOp(1101, logop, 1, LOGOP); logop->op_type = OP_COND_EXPR; logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR]; logop->op_first = first; logop->op_flags = flags | OPf_KIDS; - logop->op_private = 1 | (flags >> 8); + logop->op_private = (U8)(1 | (flags >> 8)); logop->op_other = LINKLIST(trueop); logop->op_next = LINKLIST(falseop); @@ -3914,7 +3444,7 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) range->op_flags = OPf_KIDS; leftstart = LINKLIST(left); range->op_other = LINKLIST(right); - range->op_private = 1 | (flags >> 8); + range->op_private = (U8)(1 | (flags >> 8)); left->op_sibling = right; @@ -3972,7 +3502,7 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) case OP_SASSIGN: if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB - || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL) + || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH) expr = newUNOP(OP_DEFINED, 0, expr); break; @@ -4047,7 +3577,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * next = unstack; cont = append_elem(OP_LINESEQ, cont, unstack); if ((line_t)whileline != NOLINE) { - PL_copline = whileline; + PL_copline = (line_t)whileline; cont = append_elem(OP_LINESEQ, cont, newSTATEOP(0, Nullch, Nullop)); } @@ -4057,7 +3587,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * redo = LINKLIST(listop); if (expr) { - PL_copline = whileline; + PL_copline = (line_t)whileline; scalar(listop); o = new_logop(OP_AND, 0, &expr, &listop); if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) { @@ -4101,7 +3631,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo { LOOP *loop; OP *wop; - int padoff = 0; + PADOFFSET padoff = 0; I32 iterflags = 0; if (sv) { @@ -4126,12 +3656,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); } else { -#ifdef USE_5005THREADS - padoff = find_threadsv("_"); - iterflags |= OPf_SPECIAL; -#else sv = newGVOP(OP_GV, 0, PL_defgv); -#endif } if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) { expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART); @@ -4178,6 +3703,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo LOOP *tmp; NewOp(1234,tmp,1,LOOP); Copy(loop,tmp,1,LOOP); + FreeOp(loop); loop = tmp; } #else @@ -4215,17 +3741,20 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) return o; } +/* +=for apidoc cv_undef + +Clear out all the active components of a CV. This can happen either +by an explicit C, or by the reference count going to zero. +In the former case, we keep the CvOUTSIDE pointer, so that any anonymous +children can still follow the full lexical scope chain. + +=cut +*/ + void Perl_cv_undef(pTHX_ CV *cv) { -#ifdef USE_5005THREADS - if (CvMUTEXP(cv)) { - MUTEX_DESTROY(CvMUTEXP(cv)); - Safefree(CvMUTEXP(cv)); - CvMUTEXP(cv) = 0; - } -#endif /* USE_5005THREADS */ - #ifdef USE_ITHREADS if (CvFILE(cv) && !CvXSUB(cv)) { /* for XSUBs CvFILE point directly to static memory; __FILE__ */ @@ -4235,17 +3764,11 @@ Perl_cv_undef(pTHX_ CV *cv) #endif if (!CvXSUB(cv) && CvROOT(cv)) { -#ifdef USE_5005THREADS - if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr)) - Perl_croak(aTHX_ "Can't undef active subroutine"); -#else if (CvDEPTH(cv)) Perl_croak(aTHX_ "Can't undef active subroutine"); -#endif /* USE_5005THREADS */ ENTER; - SAVEVPTR(PL_curpad); - PL_curpad = 0; + PAD_SAVE_SETNULLPAD(); op_free(CvROOT(cv)); CvROOT(cv) = Nullop; @@ -4253,248 +3776,24 @@ Perl_cv_undef(pTHX_ CV *cv) } SvPOK_off((SV*)cv); /* forget prototype */ CvGV(cv) = Nullgv; - /* Since closure prototypes have the same lifetime as the containing - * CV, they don't hold a refcount on the outside CV. This avoids - * the refcount loop between the outer CV (which keeps a refcount to - * the closure prototype in the pad entry for pp_anoncode()) and the - * closure prototype, and the ensuing memory leak. --GSAR */ - if (!CvANON(cv) || CvCLONED(cv)) - SvREFCNT_dec(CvOUTSIDE(cv)); - CvOUTSIDE(cv) = Nullcv; + + pad_undef(cv); + + /* remove CvOUTSIDE unless this is an undef rather than a free */ + if (!SvREFCNT(cv) && CvOUTSIDE(cv)) { + if (!CvWEAKOUTSIDE(cv)) + SvREFCNT_dec(CvOUTSIDE(cv)); + CvOUTSIDE(cv) = Nullcv; + } if (CvCONST(cv)) { SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); CvCONST_off(cv); } - if (CvPADLIST(cv)) { - /* may be during global destruction */ - if (SvREFCNT(CvPADLIST(cv))) { - I32 i = AvFILLp(CvPADLIST(cv)); - while (i >= 0) { - SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE); - SV* sv = svp ? *svp : Nullsv; - 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; - } if (CvXSUB(cv)) { CvXSUB(cv) = 0; } - 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; + /* delete all flags except WEAKOUTSIDE */ + CvFLAGS(cv) &= CVf_WEAKOUTSIDE; } void @@ -4510,19 +3809,22 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) if (name) Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name); if (SvPOK(cv)) - Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv)); + Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (SV *)cv); sv_catpv(msg, " vs "); if (p) Perl_sv_catpvf(aTHX_ msg, "(%s)", p); else sv_catpv(msg, "none"); - Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg); + Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg); } } static void const_sv_xsub(pTHX_ CV* cv); /* + +=head1 Optree Manipulation Functions + =for apidoc cv_const_sv If C is a constant sub eligible for inlining. returns the constant @@ -4570,8 +3872,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)) { @@ -4622,19 +3923,20 @@ 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; if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) { SV *sv = sv_newmortal(); - Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]", + Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]", + PL_curstash ? "__ANON__" : "__ANON__::__ANON__", CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); aname = SvPVX(sv); } else aname = Nullch; - gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"), + gv = gv_fetchpv(name ? name : (aname ? aname : + (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")), GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), SVt_PVCV); @@ -4651,7 +3953,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1) && ckWARN_d(WARN_PROTOTYPE)) { - Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype"); + Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype"); } cv_ckproto((CV*)gv, NULL, ps); } @@ -4696,6 +3998,10 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) /* already defined (or promised)? */ if (exists || GvASSUMECV(gv)) { if (!block && !attrs) { + if (CvFLAGS(PL_compcv)) { + /* might have had built-in attrs applied */ + CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); + } /* just a "sub foo;" when &foo is already defined */ SAVEFREESV(PL_compcv); goto done; @@ -4711,7 +4017,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ WARN_REDEFINE, + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), CvCONST(cv) ? "Constant subroutine %s redefined" : "Subroutine %s redefined", name); CopLINE_set(PL_curcop, oldline); @@ -4749,6 +4055,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) */ if (cv && !block) { rcv = (SV*)cv; + /* Might have had built-in attributes applied -- propagate them. */ + CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); if (CvGV(cv) && GvSTASH(CvGV(cv))) stash = GvSTASH(CvGV(cv)); else if (CvSTASH(cv)) @@ -4764,7 +4072,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else stash = PL_curstash; } - apply_attrs(stash, rcv, attrs); + apply_attrs(stash, rcv, attrs, FALSE); } if (cv) { /* must reuse cv if autoloaded */ if (!block) { @@ -4772,35 +4080,16 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) SAVEFREESV(PL_compcv); goto done; } + /* transfer PL_compcv to cv */ cv_undef(cv); CvFLAGS(cv) = CvFLAGS(PL_compcv); CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); + CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); CvOUTSIDE(PL_compcv) = 0; 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. */ @@ -4817,13 +4106,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvGV(cv) = gv; CvFILE_set_from_cop(cv, PL_curcop); CvSTASH(cv) = PL_curstash; -#ifdef USE_5005THREADS - CvOWNER(cv) = 0; - if (!CvMUTEXP(cv)) { - New(666, CvMUTEXP(cv), 1, perl_mutex); - MUTEX_INIT(CvMUTEXP(cv)); - } -#endif /* USE_5005THREADS */ if (ps) sv_setpv((SV*)cv, ps); @@ -4842,7 +4124,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else { /* force display of errors found but not reported */ sv_catpv(ERRSV, not_safe); - Perl_croak(aTHX_ "%s", SvPVx(ERRSV, n_a)); + Perl_croak(aTHX_ "%"SVf, ERRSV); } } } @@ -4850,9 +4132,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)); @@ -4867,51 +4146,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 - * lifetime of the outer CV. Avoids memory leak due to reference - * loop. --GSAR */ - if (!name) - SvREFCNT_dec(CvOUTSIDE(cv)); if (name || aname) { char *s; @@ -4963,7 +4205,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) call_list(oldscope, PL_beginav); PL_curcop = &PL_compiling; - PL_compiling.op_private = PL_hints; + PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); LEAVE; } else if (strEQ(s, "END") && !PL_error_count) { @@ -4979,7 +4221,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_checkav = newAV(); DEBUG_x( dump_sub(gv) ); if (PL_main_start && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); + Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); av_unshift(PL_checkav, 1); av_store(PL_checkav, 0, (SV*)cv); GvCV(gv) = 0; /* cv has been hijacked */ @@ -4989,7 +4231,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_initav = newAV(); DEBUG_x( dump_sub(gv) ); if (PL_main_start && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); + Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); av_push(PL_initav, (SV*)cv); GvCV(gv) = 0; /* cv has been hijacked */ } @@ -5028,11 +4270,7 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) SAVESPTR(PL_curstash); SAVECOPSTASH(PL_curcop); PL_curstash = stash; -#ifdef USE_ITHREADS - CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch; -#else - CopSTASH(PL_curcop) = stash; -#endif + CopSTASH_set(PL_curcop,stash); } cv = newXS(name, const_sv_xsub, __FILE__); @@ -5056,9 +4294,14 @@ Used by C to hook up XSUBs as Perl subs. CV * Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) { - GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); + GV *gv = gv_fetchpv(name ? name : + (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), + GV_ADDMULTI, SVt_PVCV); register CV *cv; + if (!subaddr) + Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename); + if ((cv = (name ? GvCV(gv) : Nullcv))) { if (GvCVGEN(gv)) { /* just a cached method */ @@ -5072,7 +4315,7 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ WARN_REDEFINE, + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), CvCONST(cv) ? "Constant subroutine %s redefined" : "Subroutine %s redefined" ,name); @@ -5095,11 +4338,6 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) } } CvGV(cv) = gv; -#ifdef USE_5005THREADS - New(666, CvMUTEXP(cv), 1, perl_mutex); - MUTEX_INIT(CvMUTEXP(cv)); - CvOWNER(cv) = 0; -#endif /* USE_5005THREADS */ (void)gv_fetchfile(filename); CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be an external constant string */ @@ -5132,7 +4370,7 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) if (!PL_checkav) PL_checkav = newAV(); if (PL_main_start && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block"); + Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); av_unshift(PL_checkav, 1); av_store(PL_checkav, 0, (SV*)cv); GvCV(gv) = 0; /* cv has been hijacked */ @@ -5141,7 +4379,7 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) if (!PL_initav) PL_initav = newAV(); if (PL_main_start && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); + Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); av_push(PL_initav, (SV*)cv); GvCV(gv) = 0; /* cv has been hijacked */ } @@ -5159,7 +4397,6 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) register CV *cv; char *name; GV *gv; - I32 ix; STRLEN n_a; if (o) @@ -5178,7 +4415,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name); + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name); CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); @@ -5188,11 +4425,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); @@ -5240,7 +4474,7 @@ Perl_oopsAV(pTHX_ OP *o) o->op_type = OP_PADAV; o->op_ppaddr = PL_ppaddr[OP_PADAV]; return ref(o, OP_RV2AV); - + case OP_RV2SV: o->op_type = OP_RV2AV; o->op_ppaddr = PL_ppaddr[OP_RV2AV]; @@ -5249,7 +4483,7 @@ Perl_oopsAV(pTHX_ OP *o) default: if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV"); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); break; } return o; @@ -5274,7 +4508,7 @@ Perl_oopsHV(pTHX_ OP *o) default: if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV"); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); break; } return o; @@ -5290,7 +4524,7 @@ Perl_newAVREF(pTHX_ OP *o) } else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV) && ckWARN(WARN_DEPRECATED)) { - Perl_warner(aTHX_ WARN_DEPRECATED, + Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Using an array as a reference is deprecated"); } return newUNOP(OP_RV2AV, 0, scalar(o)); @@ -5314,7 +4548,7 @@ Perl_newHVREF(pTHX_ OP *o) } else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV) && ckWARN(WARN_DEPRECATED)) { - Perl_warner(aTHX_ WARN_DEPRECATED, + Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Using a hash as a reference is deprecated"); } return newUNOP(OP_RV2HV, 0, scalar(o)); @@ -5354,27 +4588,37 @@ 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; } OP * Perl_ck_bitop(pTHX_ OP *o) { - o->op_private = PL_hints; +#define OP_IS_NUMCOMPARE(op) \ + ((op) == OP_LT || (op) == OP_I_LT || \ + (op) == OP_GT || (op) == OP_I_GT || \ + (op) == OP_LE || (op) == OP_I_LE || \ + (op) == OP_GE || (op) == OP_I_GE || \ + (op) == OP_EQ || (op) == OP_I_EQ || \ + (op) == OP_NE || (op) == OP_I_NE || \ + (op) == OP_NCMP || (op) == OP_I_NCMP) + o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK); + if (o->op_type == OP_BIT_OR + || o->op_type == OP_BIT_AND + || o->op_type == OP_BIT_XOR) + { + OPCODE typfirst = cBINOPo->op_first->op_type; + OPCODE typlast = cBINOPo->op_first->op_sibling->op_type; + if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast)) + if (ckWARN(WARN_PRECEDENCE)) + Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE), + "Possible precedence problem on bitwise %c operator", + o->op_type == OP_BIT_OR ? '|' + : o->op_type == OP_BIT_AND ? '&' : '^' + ); + } return o; } @@ -5401,7 +4645,7 @@ Perl_ck_spair(pTHX_ OP *o) !(PL_opargs[newop->op_type] & OA_RETSCALAR) || newop->op_type == OP_PADAV || newop->op_type == OP_PADHV || newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) { - + return o; } op_free(kUNOP->op_first); @@ -5600,17 +4844,8 @@ Perl_ck_rvconst(pTHX_ register OP *o) badtype = "an ARRAY"; break; case OP_RV2HV: - if (svtype != SVt_PVHV) { - if (svtype == SVt_PVAV) { /* pseudohash? */ - SV **ksv = av_fetch((AV*)rsv, 0, FALSE); - if (ksv && SvROK(*ksv) - && SvTYPE(SvRV(*ksv)) == SVt_PVHV) - { - break; - } - } + if (svtype != SVt_PVHV) badtype = "a HASH"; - } break; case OP_RV2CV: if (svtype != SVt_PVCV) @@ -5668,9 +4903,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 @@ -5765,18 +5000,18 @@ Perl_ck_fun(pTHX_ OP *o) case OA_AVREF: if ((type == OP_PUSH || type == OP_UNSHIFT) && !kid->op_sibling && ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Useless use of %s with no values", PL_op_desc[type]); - + if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVAV) )); - if (ckWARN(WARN_DEPRECATED)) - Perl_warner(aTHX_ WARN_DEPRECATED, + if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Array @%s missing the @ in argument %"IVdf" of %s()", name, (IV)numargs, PL_op_desc[type]); op_free(kid); @@ -5795,8 +5030,8 @@ Perl_ck_fun(pTHX_ OP *o) char *name = SvPVx(((SVOP*)kid)->op_sv, n_a); OP *newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVHV) )); - if (ckWARN(WARN_DEPRECATED)) - Perl_warner(aTHX_ WARN_DEPRECATED, + if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Hash %%%s missing the %% in argument %"IVdf" of %s()", name, (IV)numargs, PL_op_desc[type]); op_free(kid); @@ -5827,6 +5062,9 @@ Perl_ck_fun(pTHX_ OP *o) OP *newop = newGVOP(OP_GV, 0, gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE, SVt_PVIO) ); + if (!(o->op_private & 1) && /* if not unop */ + kid == cLISTOPo->op_last) + cLISTOPo->op_last = newop; op_free(kid); kid = newop; } @@ -5842,7 +5080,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 @@ -5851,10 +5089,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) @@ -5873,7 +5118,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); @@ -5926,16 +5171,19 @@ Perl_ck_glob(pTHX_ OP *o) if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) append_elem(OP_GLOB, o, newDEFSVOP()); - if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv))) + if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) + && GvCVu(gv) && GvIMPORTED_CV(gv))) + { gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); + } #if !defined(PERL_EXTERNAL_GLOB) /* XXX this can be tightened up and made more failsafe. */ if (!gv) { GV *glob_gv; ENTER; - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv, - Nullsv, Nullsv); + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv); gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV); GvCV(gv) = GvCV(glob_gv); @@ -5945,7 +5193,7 @@ Perl_ck_glob(pTHX_ OP *o) } #endif /* PERL_EXTERNAL_GLOB */ - if (gv && GvIMPORTED_CV(gv)) { + if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { append_elem(OP_GLOB, o, newSVOP(OP_CONST, 0, newSViv(PL_glob_index++))); o->op_type = OP_LIST; @@ -6048,7 +5296,7 @@ Perl_ck_lfun(pTHX_ OP *o) OP * Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ { - if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) { + if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) { switch (cUNOPo->op_first->op_type) { case OP_RV2AV: /* This is needed for @@ -6058,9 +5306,9 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ - Perl_warner(aTHX_ WARN_DEPRECATED, + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "defined(@array) is deprecated"); - Perl_warner(aTHX_ WARN_DEPRECATED, + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "\t(Maybe you should just omit the defined()?)\n"); break; case OP_RV2HV: @@ -6070,9 +5318,9 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ */ break; /* Globals via GV can be undef */ case OP_PADHV: - Perl_warner(aTHX_ WARN_DEPRECATED, + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "defined(%%hash) is deprecated"); - Perl_warner(aTHX_ WARN_DEPRECATED, + Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "\t(Maybe you should just omit the defined()?)\n"); break; default: @@ -6113,7 +5361,7 @@ Perl_ck_listiob(pTHX_ OP *o) kid = kid->op_sibling; } } - + if (!kid) append_elem(o->op_type, o, newDEFSVOP()); @@ -6256,10 +5504,10 @@ Perl_ck_require(pTHX_ OP *o) /* handle override, if any */ gv = gv_fetchpv("require", FALSE, SVt_PVCV); - if (!(gv && GvIMPORTED_CV(gv))) + if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV); - if (gv && GvIMPORTED_CV(gv)) { + if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { OP *kid = cUNOPo->op_first; cUNOPo->op_first = 0; op_free(o); @@ -6321,23 +5569,11 @@ Perl_ck_shift(pTHX_ OP *o) if (!(o->op_flags & OPf_KIDS)) { OP *argop; - + op_free(o); -#ifdef USE_5005THREADS - if (!CvUNIQUE(PL_compcv)) { - argop = newOP(OP_PADAV, OPf_REF); - argop->op_targ = 0; /* PL_curpad[0] is @_ */ - } - else { - argop = newUNOP(OP_RV2AV, 0, - scalar(newGVOP(OP_GV, 0, - gv_fetchpv("ARGV", TRUE, SVt_PVAV)))); - } -#else argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ? PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV)))); -#endif /* USE_5005THREADS */ return newUNOP(type, 0, scalar(argop)); } return scalar(modkids(ck_fun(o), type)); @@ -6502,6 +5738,10 @@ Perl_ck_split(pTHX_ OP *o) kid->op_type = OP_PUSHRE; kid->op_ppaddr = PL_ppaddr[OP_PUSHRE]; scalar(kid); + if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { + Perl_warner(aTHX_ packWARN(WARN_REGEXP), + "Use of /g modifier is meaningless in split"); + } if (!kid->op_sibling) append_elem(OP_SPLIT, o, newDEFSVOP()); @@ -6530,7 +5770,7 @@ Perl_ck_join(pTHX_ OP *o) char *pmstr = "STRING"; if (PM_GETRE(kPMOP)) pmstr = PM_GETRE(kPMOP)->precomp; - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "/%s/ should probably be written as \"%s\"", pmstr, pmstr); } @@ -6667,9 +5907,16 @@ Perl_ck_subr(pTHX_ OP *o) goto again; break; case ']': - if (contextclass) - contextclass = 0; - else + if (contextclass) { + char *p = proto; + char s = *p; + contextclass = 0; + *p = '\0'; + while (*--p != '['); + bad_type(arg, Perl_form(aTHX_ "one of %s", p), + gv_ename(namegv), o2); + *proto = s; + } else goto oops; break; case '*': @@ -6732,8 +5979,8 @@ Perl_ck_subr(pTHX_ OP *o) continue; default: oops: - Perl_croak(aTHX_ "Malformed prototype for %s: %s", - gv_ename(namegv), SvPV((SV*)cv, n_a)); + Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf, + gv_ename(namegv), cv); } } else @@ -6795,7 +6042,6 @@ void Perl_peep(pTHX_ register OP *o) { register OP* oldop = 0; - STRLEN n_a; if (!o || o->op_seq) return; @@ -6805,8 +6051,10 @@ Perl_peep(pTHX_ register OP *o) for (; o; o = o->op_next) { if (o->op_seq) break; - if (!PL_op_seqmax) - PL_op_seqmax++; + /* The special value -1 is used by the B::C compiler backend to indicate + * that an op is statically defined and should not be freed */ + if (!PL_op_seqmax || PL_op_seqmax == (U16)-1) + PL_op_seqmax = 1; PL_op = o; switch (o->op_type) { case OP_SETSTATE: @@ -6820,24 +6068,25 @@ Perl_peep(pTHX_ register OP *o) if (cSVOPo->op_private & OPpCONST_STRICT) no_bareword_allowed(o); #ifdef USE_ITHREADS + case OP_METHOD_NAMED: /* Relocate sv to the pad for thread safety. * Despite being a "constant", the SV is written to, * for reference counts, sv_upgrade() etc. */ if (cSVOP->op_sv) { PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); - if (SvPADTMP(cSVOPo->op_sv)) { + if (o->op_type == OP_CONST && 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; @@ -6910,7 +6159,7 @@ Perl_peep(pTHX_ register OP *o) else if (o->op_next->op_type == OP_RV2AV) { OP* pop = o->op_next->op_next; IV i; - if (pop->op_type == OP_CONST && + if (pop && pop->op_type == OP_CONST && (PL_op = pop->op_next) && pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & @@ -6938,9 +6187,9 @@ Perl_peep(pTHX_ register OP *o) /* XXX could check prototype here instead of just carping */ SV *sv = sv_newmortal(); gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_PROTOTYPE, - "%s() called too early to check prototype", - SvPV_nolen(sv)); + Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), + "%"SVf"() called too early to check prototype", + sv); } } else if (o->op_next->op_type == OP_READLINE @@ -6962,8 +6211,10 @@ Perl_peep(pTHX_ register OP *o) case OP_GREPWHILE: case OP_AND: case OP_OR: + case OP_DOR: case OP_ANDASSIGN: case OP_ORASSIGN: + case OP_DORASSIGN: case OP_COND_EXPR: case OP_RANGE: o->op_seq = PL_op_seqmax++; @@ -7007,24 +6258,21 @@ Perl_peep(pTHX_ register OP *o) line_t oldline = CopLINE(PL_curcop); CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next)); - Perl_warner(aTHX_ WARN_EXEC, + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Statement unlikely to be reached"); - Perl_warner(aTHX_ WARN_EXEC, + Perl_warner(aTHX_ packWARN(WARN_EXEC), "\t(Maybe you meant system() when you said exec()?)\n"); CopLINE_set(PL_curcop, oldline); } } break; - + case OP_HELEM: { - UNOP *rop; - SV *lexname; - GV **fields; - SV **svp, **indsvp, *sv; - I32 ind; + SV *lexname; + SV **svp, *sv; char *key = NULL; STRLEN keylen; - + o->op_seq = PL_op_seqmax++; if (((BINOP*)o)->op_last->op_type != OP_CONST) @@ -7040,106 +6288,8 @@ Perl_peep(pTHX_ register OP *o) SvREFCNT_dec(sv); *svp = lexname; } - - if ((o->op_private & (OPpLVAL_INTRO))) - break; - - rop = (UNOP*)((BINOP*)o)->op_first; - if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) - break; - lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); - if (!(SvFLAGS(lexname) & SVpad_TYPED)) - break; - fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); - if (!fields || !GvHV(*fields)) - break; - key = SvPV(*svp, keylen); - indsvp = hv_fetch(GvHV(*fields), key, - SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE); - if (!indsvp) { - Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s", - key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname))); - } - ind = SvIV(*indsvp); - if (ind < 1) - Perl_croak(aTHX_ "Bad index while coercing array into hash"); - rop->op_type = OP_RV2AV; - rop->op_ppaddr = PL_ppaddr[OP_RV2AV]; - o->op_type = OP_AELEM; - o->op_ppaddr = PL_ppaddr[OP_AELEM]; - sv = newSViv(ind); - if (SvREADONLY(*svp)) - SvREADONLY_on(sv); - SvFLAGS(sv) |= (SvFLAGS(*svp) - & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY)); - SvREFCNT_dec(*svp); - *svp = sv; - break; - } - - case OP_HSLICE: { - UNOP *rop; - SV *lexname; - GV **fields; - SV **svp, **indsvp, *sv; - I32 ind; - char *key; - STRLEN keylen; - SVOP *first_key_op, *key_op; - - o->op_seq = PL_op_seqmax++; - if ((o->op_private & (OPpLVAL_INTRO)) - /* I bet there's always a pushmark... */ - || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST) - /* hmmm, no optimization if list contains only one key. */ - break; - rop = (UNOP*)((LISTOP*)o)->op_last; - if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV) - break; - lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); - if (!(SvFLAGS(lexname) & SVpad_TYPED)) - break; - fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); - if (!fields || !GvHV(*fields)) - break; - /* Again guessing that the pushmark can be jumped over.... */ - first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling) - ->op_first->op_sibling; - /* Check that the key list contains only constants. */ - for (key_op = first_key_op; key_op; - key_op = (SVOP*)key_op->op_sibling) - if (key_op->op_type != OP_CONST) - break; - if (key_op) - break; - rop->op_type = OP_RV2AV; - rop->op_ppaddr = PL_ppaddr[OP_RV2AV]; - o->op_type = OP_ASLICE; - o->op_ppaddr = PL_ppaddr[OP_ASLICE]; - for (key_op = first_key_op; key_op; - key_op = (SVOP*)key_op->op_sibling) { - svp = cSVOPx_svp(key_op); - key = SvPV(*svp, keylen); - indsvp = hv_fetch(GvHV(*fields), key, - SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE); - if (!indsvp) { - Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" " - "in variable %s of type %s", - key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname))); - } - ind = SvIV(*indsvp); - if (ind < 1) - Perl_croak(aTHX_ "Bad index while coercing array into hash"); - sv = newSViv(ind); - if (SvREADONLY(*svp)) - SvREADONLY_on(sv); - SvFLAGS(sv) |= (SvFLAGS(*svp) - & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY)); - SvREFCNT_dec(*svp); - *svp = sv; - } - break; - } + break; + } default: o->op_seq = PL_op_seqmax++; @@ -7206,4 +6356,3 @@ const_sv_xsub(pTHX_ CV* cv) ST(0) = (SV*)XSANY.any_ptr; XSRETURN(1); } -