X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=eb60121edf7abbf80f4faa99b180d42d039257de;hb=453189b60dbb6e88d68de022c83a2a4ff03203fd;hp=64d801ff6231cb72fb9316944cdad329ac819f34;hpb=a7089531ba6cec0dc577ea527da80d08bb5964dd;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 64d801f..eb60121 100644 --- a/op.c +++ b/op.c @@ -1,6 +1,6 @@ /* op.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2001, 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. @@ -21,8 +21,8 @@ #include "keywords.h" /* #define PL_OP_SLAB_ALLOC */ - -#ifdef PL_OP_SLAB_ALLOC + +#ifdef PL_OP_SLAB_ALLOC #define SLAB_SIZE 8192 static char *PL_OpPtr = NULL; static int PL_OpSpace = 0; @@ -32,15 +32,15 @@ static int PL_OpSpace = 0; var = (type *) Slab_Alloc(m,c*sizeof(type)); \ } while (0) -STATIC void * +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; } -#else +#else #define NewOp(m, var, c, type) Newz(m, var, c, type) #endif /* @@ -55,6 +55,7 @@ S_Slab_Alloc(pTHX_ int m, size_t sz) : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o)) #define PAD_MAX 999999999 +#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2) STATIC char* S_gv_ename(pTHX_ GV *gv) @@ -99,23 +100,45 @@ S_no_bareword_allowed(pTHX_ OP *o) { qerror(Perl_mess(aTHX_ "Bareword \"%s\" not allowed while \"strict subs\" in use", - SvPV_nolen(cSVOPo->op_sv))); + SvPV_nolen(cSVOPo_sv))); } +STATIC U8* +S_trlist_upgrade(pTHX_ U8** sp, U8** ep) +{ + U8 *s = *sp; + U8 *e = *ep; + U8 *d; + + Newz(801, d, (e - s) * 2, U8); + *sp = d; + + while (s < e) { + if (*s < 0x80 || *s == 0xff) + *d++ = *s++; + else { + U8 c = *s++; + *d++ = ((c >> 6) | 0xc0); + *d++ = ((c & 0x3f) | 0x80); + } + } + *ep = d; + return *sp; +} + + /* "register" allocation */ PADOFFSET Perl_pad_allocmy(pTHX_ char *name) { - dTHR; PADOFFSET off; SV *sv; - if (!( - PL_in_my == KEY_our || - isALPHA(name[1]) || - (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) || - name[1] == '_' && (int)strlen(name) > 2 )) + if (!(PL_in_my == KEY_our || + isALPHA(name[1]) || + (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) || + (name[1] == '_' && (int)strlen(name) > 2))) { if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { /* 1999-02-27 mjd@plover.com */ @@ -138,22 +161,43 @@ Perl_pad_allocmy(pTHX_ char *name) } yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name)); } - if (ckWARN(WARN_UNSAFE) && AvFILLp(PL_comppad_name) >= 0) { + if (ckWARN(WARN_MISC) && AvFILLp(PL_comppad_name) >= 0) { SV **svp = AvARRAY(PL_comppad_name); - for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_floor; off--) { + 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_UNSAFE, - "\"%s\" variable %s masks earlier declaration in same %s", - (PL_in_my == KEY_our ? "our" : "my"), - name, - (SvIVX(sv) == PAD_MAX ? "scope" : "statement")); + 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); @@ -161,15 +205,18 @@ Perl_pad_allocmy(pTHX_ char *name) sv_setpv(sv, name); if (PL_in_my_stash) { if (*name != '$') - yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"my\"", - name)); + yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"", + name, PL_in_my == KEY_our ? "our" : "my")); SvOBJECT_on(sv); (void)SvUPGRADE(sv, SVt_PVMG); SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash); PL_sv_objcount++; } - if (PL_in_my == KEY_our) + 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 */ @@ -184,13 +231,37 @@ Perl_pad_allocmy(pTHX_ char *name) 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 (SvOBJECT(proto_namesv)) { /* A typed var */ + SvOBJECT_on(namesv); + (void)SvUPGRADE(namesv, SVt_PVMG); + SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv)); + PL_sv_objcount++; + } + 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) { - dTHR; CV *cv; I32 off; SV *sv; @@ -226,25 +297,10 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, } depth = 1; } - oldpad = (AV*)*av_fetch(curlist, depth, FALSE); + oldpad = (AV*)AvARRAY(curlist)[depth]; oldsv = *av_fetch(oldpad, off, TRUE); if (!newoff) { /* Not a mere clone operation. */ - SV *namesv = NEWSV(1103,0); - newoff = pad_alloc(OP_PADSV, SVs_PADMY); - sv_upgrade(namesv, SVt_PVNV); - sv_setpv(namesv, name); - 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(sv) & SVpad_OUR)/* An "our" variable */ - SvFLAGS(namesv) |= SVpad_OUR; - if (SvOBJECT(sv)) { /* A typed var */ - SvOBJECT_on(namesv); - (void)SvUPGRADE(namesv, SVt_PVMG); - SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(sv)); - PL_sv_objcount++; - } + newoff = pad_addlex(sv); if (CvANON(PL_compcv) || SvTYPE(PL_compcv) == SVt_PVFM) { /* "It's closures all the way down." */ CvCLONE_on(PL_compcv); @@ -258,8 +314,23 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, bcv && bcv != cv && !CvCLONE(bcv); bcv = CvOUTSIDE(bcv)) { - if (CvANON(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)) @@ -274,9 +345,12 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, } } else if (!CvUNIQUE(PL_compcv)) { - if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)) + 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)); @@ -308,11 +382,13 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, if (CxREALEVAL(cx)) saweval = i; break; + case OP_DOFILE: case OP_REQUIRE: - /* require must have its own scope */ + /* require/do must have their own scope */ return 0; } break; + case CXt_FORMAT: case CXt_SUB: if (!saweval) return 0; @@ -332,7 +408,6 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, PADOFFSET Perl_pad_findmy(pTHX_ char *name) { - dTHR; I32 off; I32 pendoff = 0; SV *sv; @@ -395,7 +470,6 @@ Perl_pad_findmy(pTHX_ char *name) void Perl_pad_leavemy(pTHX_ I32 fill) { - dTHR; I32 off; SV **svp = AvARRAY(PL_comppad_name); SV *sv; @@ -415,7 +489,6 @@ Perl_pad_leavemy(pTHX_ I32 fill) PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) { - dTHR; SV *sv; I32 retval; @@ -442,7 +515,8 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) (sv = names[PL_padix]) && sv != &PL_sv_undef) continue; sv = *av_fetch(PL_comppad, PL_padix, TRUE); - if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY))) + if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) && + !IS_PADGV(sv) && !IS_PADCONST(sv)) break; } retval = PL_padix; @@ -450,12 +524,14 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) SvFLAGS(sv) |= tmptype; PL_curpad = AvARRAY(PL_comppad); #ifdef USE_THREADS - DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx alloc %ld for %s\n", - (unsigned long) thr, (unsigned long) PL_curpad, + 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%lx alloc %ld for %s\n", - (unsigned long) PL_curpad, + 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_THREADS */ return (PADOFFSET)retval; @@ -464,15 +540,15 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) SV * Perl_pad_sv(pTHX_ PADOFFSET po) { - dTHR; #ifdef USE_THREADS - DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx sv %d\n", - (unsigned long) thr, (unsigned long) PL_curpad, po)); + 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%lx sv %d\n", - (unsigned long) PL_curpad, po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n", + PTR2UV(PL_curpad), (IV)po)); #endif /* USE_THREADS */ return PL_curpad[po]; /* eventually we'll turn this into a macro */ } @@ -480,7 +556,6 @@ Perl_pad_sv(pTHX_ PADOFFSET po) void Perl_pad_free(pTHX_ PADOFFSET po) { - dTHR; if (!PL_curpad) return; if (AvARRAY(PL_comppad) != PL_curpad) @@ -488,14 +563,19 @@ Perl_pad_free(pTHX_ PADOFFSET po) if (!po) Perl_croak(aTHX_ "panic: pad_free po"); #ifdef USE_THREADS - DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx free %d\n", - (unsigned long) thr, (unsigned long) PL_curpad, po)); + 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%lx free %d\n", - (unsigned long) PL_curpad, po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n", + PTR2UV(PL_curpad), (IV)po)); #endif /* USE_THREADS */ - if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) + 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; } @@ -503,17 +583,17 @@ Perl_pad_free(pTHX_ PADOFFSET po) void Perl_pad_swipe(pTHX_ PADOFFSET po) { - dTHR; if (AvARRAY(PL_comppad) != PL_curpad) Perl_croak(aTHX_ "panic: pad_swipe curpad"); if (!po) Perl_croak(aTHX_ "panic: pad_swipe po"); #ifdef USE_THREADS - DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx swipe %d\n", - (unsigned long) thr, (unsigned long) PL_curpad, po)); + 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%lx swipe %d\n", - (unsigned long) PL_curpad, po)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n", + PTR2UV(PL_curpad), (IV)po)); #endif /* USE_THREADS */ SvPADTMP_off(PL_curpad[po]); PL_curpad[po] = NEWSV(1107,0); @@ -532,17 +612,17 @@ void Perl_pad_reset(pTHX) { #ifdef USE_BROKEN_PAD_RESET - dTHR; register I32 po; if (AvARRAY(PL_comppad) != PL_curpad) Perl_croak(aTHX_ "panic: pad_reset curpad"); #ifdef USE_THREADS - DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%lx Pad 0x%lx reset\n", - (unsigned long) thr, (unsigned long) PL_curpad)); + 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%lx reset\n", - (unsigned long) PL_curpad)); + DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n", + PTR2UV(PL_curpad))); #endif /* USE_THREADS */ if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */ for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) { @@ -560,7 +640,6 @@ Perl_pad_reset(pTHX) PADOFFSET Perl_find_threadsv(pTHX_ const char *name) { - dTHR; char *p; PADOFFSET key; SV **svp; @@ -588,7 +667,7 @@ Perl_find_threadsv(pTHX_ const char *name) break; case ';': sv_setpv(sv, "\034"); - sv_magic(sv, 0, 0, name, 1); + sv_magic(sv, 0, 0, name, 1); break; case '&': case '`': @@ -612,7 +691,7 @@ Perl_find_threadsv(pTHX_ const char *name) /* case '!': */ default: - sv_magic(sv, 0, 0, name, 1); + sv_magic(sv, 0, 0, name, 1); } DEBUG_S(PerlIO_printf(Perl_error_log, "find_threadsv: new SV %p for $%s%c\n", @@ -634,6 +713,26 @@ Perl_op_free(pTHX_ OP *o) if (!o || o->op_seq == (U16)-1) return; + if (o->op_private & OPpREFCOUNTED) { + switch (o->op_type) { + case OP_LEAVESUB: + case OP_LEAVESUBLV: + case OP_LEAVEEVAL: + case OP_LEAVE: + case OP_SCOPE: + case OP_LEAVEWRITE: + OP_REFCNT_LOCK; + if (OpREFCNT_dec(o)) { + OP_REFCNT_UNLOCK; + return; + } + OP_REFCNT_UNLOCK; + break; + default: + break; + } + } + if (o->op_flags & OPf_KIDS) { for (kid = cUNOPo->op_first; kid; kid = nextkid) { nextkid = kid->op_sibling; /* Get before next freeing kid */ @@ -685,9 +784,23 @@ S_op_clear(pTHX_ OP *o) case OP_GVSV: case OP_GV: case OP_AELEMFAST: - SvREFCNT_dec(cGVOPo->op_gv); - cGVOPo->op_gv = Nullgv; +#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); + } + cPADOPo->op_padix = 0; + } +#else + SvREFCNT_dec(cSVOPo->op_sv); + cSVOPo->op_sv = Nullsv; +#endif break; + case OP_METHOD_NAMED: case OP_CONST: SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = Nullsv; @@ -711,27 +824,52 @@ S_op_clear(pTHX_ OP *o) break; case OP_SUBST: op_free(cPMOPo->op_pmreplroot); - cPMOPo->op_pmreplroot = Nullop; - /* FALL THROUGH */ + goto clear_pmop; case OP_PUSHRE: +#ifdef USE_ITHREADS + if ((PADOFFSET)cPMOPo->op_pmreplroot) { + if (PL_curpad) { + GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot]; + pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot); + /* No GvIN_PAD_off(gv) here, because other references may still + * exist on the pad */ + SvREFCNT_dec(gv); + } + } +#else + SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot); +#endif + /* FALL THROUGH */ case OP_MATCH: case OP_QR: +clear_pmop: + cPMOPo->op_pmreplroot = Nullop; ReREFCNT_dec(cPMOPo->op_pmregexp); cPMOPo->op_pmregexp = (REGEXP*)NULL; break; } - if (o->op_targ > 0) + if (o->op_targ > 0) { pad_free(o->op_targ); + o->op_targ = 0; + } } STATIC void S_cop_free(pTHX_ COP* cop) { Safefree(cop->cop_label); - SvREFCNT_dec(cop->cop_filegv); +#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 if (! specialWARN(cop->cop_warnings)) SvREFCNT_dec(cop->cop_warnings); + if (! specialCopIO(cop->cop_io)) + SvREFCNT_dec(cop->cop_io); } STATIC void @@ -788,14 +926,13 @@ STATIC OP * S_scalarboolean(pTHX_ OP *o) { if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { - dTHR; if (ckWARN(WARN_SYNTAX)) { - line_t oldline = PL_curcop->cop_line; + line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) - PL_curcop->cop_line = PL_copline; + CopLINE_set(PL_curcop, PL_copline); Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be =="); - PL_curcop->cop_line = oldline; + CopLINE_set(PL_curcop, oldline); } } return scalar(o); @@ -809,12 +946,10 @@ Perl_scalar(pTHX_ OP *o) /* assumes no premature commitment */ if (!o || (o->op_flags & OPf_WANT) || PL_error_count || o->op_type == OP_RETURN) + { return o; + } - if ((o->op_private & OPpTARGET_MY) - && (PL_opargs[o->op_type] & OA_TARGLEX)) /* OPp share the meaning */ - return scalar(o); /* As if inside SASSIGN */ - o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR; switch (o->op_type) { @@ -849,7 +984,7 @@ Perl_scalar(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; scalar(kid); - while (kid = kid->op_sibling) { + while ((kid = kid->op_sibling)) { if (kid->op_sibling) scalarvoid(kid); else @@ -886,21 +1021,22 @@ Perl_scalarvoid(pTHX_ OP *o) || (o->op_type == OP_NULL && (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_SETSTATE || o->op_targ == OP_DBSTATE))) - { - dTHR; PL_curcop = (COP*)o; /* for warning below */ - } /* assumes no premature commitment */ want = o->op_flags & OPf_WANT; if ((want && want != OPf_WANT_SCALAR) || PL_error_count || o->op_type == OP_RETURN) + { return o; + } if ((o->op_private & OPpTARGET_MY) - && (PL_opargs[o->op_type] & OA_TARGLEX)) /* OPp share the meaning */ + && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ + { return scalar(o); /* As if inside SASSIGN */ - + } + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; switch (o->op_type) { @@ -984,7 +1120,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_GGRGID: case OP_GETLOGIN: func_ops: - if (!(o->op_private & OPpLVAL_INTRO)) + if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) useless = PL_op_desc[o->op_type]; break; @@ -992,22 +1128,27 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_RV2SV: case OP_RV2AV: case OP_RV2HV: - if (!(o->op_private & OPpLVAL_INTRO) && + if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)) && (!o->op_sibling || o->op_sibling->op_type != OP_READLINE)) useless = "a variable"; break; case OP_CONST: - sv = cSVOPo->op_sv; + sv = cSVOPo_sv; if (cSVOPo->op_private & OPpCONST_STRICT) no_bareword_allowed(o); else { - dTHR; if (ckWARN(WARN_VOID)) { useless = "a constant"; if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = 0; else if (SvPOK(sv)) { + /* perl4's way of mixing documentation and code + (before the invention of POD) was based on a + trick to mix nroff and perl code. The trick was + built upon these three nroff macros being used in + void context. The pink camel has the details in + the script wrapman near page 319. */ if (strnEQ(SvPVX(sv), "di", 2) || strnEQ(SvPVX(sv), "ds", 2) || strnEQ(SvPVX(sv), "ig", 2)) @@ -1043,7 +1184,6 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_DBSTATE: case OP_ENTERTRY: case OP_ENTER: - case OP_SCALAR: if (!(o->op_flags & OPf_KIDS)) break; /* FALL THROUGH */ @@ -1062,6 +1202,8 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_REQUIRE: /* all requires must return a boolean value */ o->op_flags &= ~OPf_WANT; + /* FALL THROUGH */ + case OP_SCALAR: return scalar(o); case OP_SPLIT: if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { @@ -1070,11 +1212,8 @@ Perl_scalarvoid(pTHX_ OP *o) } break; } - if (useless) { - dTHR; - if (ckWARN(WARN_VOID)) - Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless); - } + if (useless && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless); return o; } @@ -1097,12 +1236,16 @@ Perl_list(pTHX_ OP *o) /* assumes no premature commitment */ if (!o || (o->op_flags & OPf_WANT) || PL_error_count || o->op_type == OP_RETURN) + { return o; + } if ((o->op_private & OPpTARGET_MY) - && (PL_opargs[o->op_type] & OA_TARGLEX)) /* OPp share the meaning */ + && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ + { return o; /* As if inside SASSIGN */ - + } + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; switch (o->op_type) { @@ -1134,7 +1277,7 @@ Perl_list(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; list(kid); - while (kid = kid->op_sibling) { + while ((kid = kid->op_sibling)) { if (kid->op_sibling) scalarvoid(kid); else @@ -1171,7 +1314,6 @@ Perl_scalarseq(pTHX_ OP *o) o->op_type == OP_LEAVE || o->op_type == OP_LEAVETRY) { - dTHR; for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { if (kid->op_sibling) { scalarvoid(kid); @@ -1202,27 +1344,52 @@ S_modkids(pTHX_ OP *o, I32 type) OP * Perl_mod(pTHX_ OP *o, I32 type) { - dTHR; OP *kid; - SV *sv; STRLEN n_a; if (!o || PL_error_count) return o; if ((o->op_private & OPpTARGET_MY) - && (PL_opargs[o->op_type] & OA_TARGLEX)) /* OPp share the meaning */ + && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */ + { return o; - + } + switch (o->op_type) { case OP_UNDEF: PL_modcount++; return o; case OP_CONST: + if (o->op_private & (OPpCONST_BARE) && + !(type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)) { + SV *sv = ((SVOP*)o)->op_sv; + GV *gv; + + /* Could be a filehandle */ + if ((gv = gv_fetchpv(SvPV_nolen(sv), FALSE, SVt_PVIO))) { + OP* gvio = newUNOP(OP_RV2GV, 0, newGVOP(OP_GV, 0, gv)); + op_free(o); + o = gvio; + } else { + /* OK, it's a sub */ + OP* enter; + gv = gv_fetchpv(SvPV_nolen(sv), TRUE, SVt_PVCV); + + enter = newUNOP(OP_ENTERSUB,0, + newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, gv) + )); + enter->op_private |= OPpLVAL_INTRO; + op_free(o); + o = enter; + } + break; + } if (!(o->op_private & (OPpCONST_ARYBASE))) goto nomod; if (PL_eval_start && PL_eval_start->op_type == OP_CONST) { - PL_compiling.cop_arybase = (I32)SvIV(((SVOP*)PL_eval_start)->op_sv); + PL_compiling.cop_arybase = (I32)SvIV(cSVOPx(PL_eval_start)->op_sv); PL_eval_start = 0; } else if (!type) { @@ -1249,7 +1416,8 @@ Perl_mod(pTHX_ OP *o, I32 type) } else { /* lvalue subroutine call */ o->op_private |= OPpLVAL_INTRO; - if (type == OP_GREPSTART || type == OP_ENTERSUB) { + PL_modcount = RETURN_UNLIMITED_NUMBER; + if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { /* Backward compatibility mode: */ o->op_private |= OPpENTERSUB_INARGS; break; @@ -1275,22 +1443,23 @@ Perl_mod(pTHX_ OP *o, I32 type) if (kid->op_type == OP_METHOD_NAMED || kid->op_type == OP_METHOD) { - OP *newop; + UNOP *newop; if (kid->op_sibling || kid->op_next != kid) { yyerror("panic: unexpected optree near method call"); break; } - NewOp(1101, newop, 1, OP); + NewOp(1101, newop, 1, UNOP); newop->op_type = OP_RV2CV; newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; - newop->op_next = newop; - kid->op_sibling = newop; + newop->op_first = Nullop; + newop->op_next = (OP*)newop; + kid->op_sibling = (OP*)newop; newop->op_private |= OPpLVAL_INTRO; break; } - + if (kid->op_type != OP_RV2CV) Perl_croak(aTHX_ "panic: unexpected lvalue entersub " @@ -1325,8 +1494,8 @@ Perl_mod(pTHX_ OP *o, I32 type) break; } - cv = GvCV(kGVOP->op_gv); - if (!cv) + cv = GvCV(kGVOP_gv); + if (!cv) goto restore_2cv; if (CvLVALUE(cv)) break; @@ -1382,7 +1551,7 @@ Perl_mod(pTHX_ OP *o, I32 type) if (!type && cUNOPo->op_first->op_type != OP_GV) Perl_croak(aTHX_ "Can't localize through a reference"); if (type == OP_REFGEN && o->op_flags & OPf_PARENS) { - PL_modcount = 10000; + PL_modcount = RETURN_UNLIMITED_NUMBER; return o; /* Treat \(@foo) like ordinary list. */ } /* FALL THROUGH */ @@ -1391,14 +1560,16 @@ Perl_mod(pTHX_ OP *o, I32 type) goto nomod; ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ - case OP_AASSIGN: case OP_ASLICE: case OP_HSLICE: + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + /* FALL THROUGH */ + case OP_AASSIGN: case OP_NEXTSTATE: case OP_DBSTATE: - case OP_REFGEN: case OP_CHOMP: - PL_modcount = 10000; + PL_modcount = RETURN_UNLIMITED_NUMBER; break; case OP_RV2SV: if (!type && cUNOPo->op_first->op_type != OP_GV) @@ -1417,11 +1588,13 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_PADAV: case OP_PADHV: - PL_modcount = 10000; + PL_modcount = RETURN_UNLIMITED_NUMBER; if (type == OP_REFGEN && o->op_flags & OPf_PARENS) return o; /* Treat \(@foo) like ordinary list. */ if (scalar_mod_type(o, type)) goto nomod; + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; /* FALL THROUGH */ case OP_PADSV: PL_modcount++; @@ -1449,6 +1622,8 @@ Perl_mod(pTHX_ OP *o, I32 type) /* FALL THROUGH */ case OP_POS: case OP_VEC: + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; lvalue_func: pad_free(o->op_targ); o->op_targ = pad_alloc(o->op_type, SVs_PADMY); @@ -1463,12 +1638,15 @@ Perl_mod(pTHX_ OP *o, I32 type) if (type == OP_ENTERSUB && !(o->op_private & (OPpLVAL_INTRO | OPpDEREF))) o->op_private |= OPpLVAL_DEFER; + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; PL_modcount++; break; case OP_SCOPE: case OP_LEAVE: case OP_ENTER: + case OP_LINESEQ: if (o->op_flags & OPf_KIDS) mod(cLISTOPo->op_last, type); break; @@ -1487,8 +1665,14 @@ Perl_mod(pTHX_ OP *o, I32 type) for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) mod(kid, type); break; + + case OP_RETURN: + if (type != OP_LEAVESUBLV) + goto nomod; + break; /* mod()ing was handled by ck_return() */ } - o->op_flags |= OPf_MOD; + if (type != OP_LEAVESUBLV) + o->op_flags |= OPf_MOD; if (type == OP_AASSIGN || type == OP_SASSIGN) o->op_flags |= OPf_SPECIAL|OPf_REF; @@ -1497,7 +1681,8 @@ Perl_mod(pTHX_ OP *o, I32 type) o->op_flags &= ~OPf_SPECIAL; PL_hints |= HINT_BLOCK_SCOPE; } - else if (type != OP_GREPSTART && type != OP_ENTERSUB) + else if (type != OP_GREPSTART && type != OP_ENTERSUB + && type != OP_LEAVESUBLV) o->op_flags |= OPf_REF; return o; } @@ -1593,7 +1778,7 @@ Perl_ref(pTHX_ OP *o, I32 type) switch (o->op_type) { case OP_ENTERSUB: - if ((type == OP_DEFINED || type == OP_LOCK) && + if ((type == OP_EXISTS || type == OP_DEFINED || type == OP_LOCK) && !(o->op_flags & OPf_STACKED)) { o->op_type = OP_RV2CV; /* entersub => rv2cv */ o->op_ppaddr = PL_ppaddr[OP_RV2CV]; @@ -1620,7 +1805,7 @@ Perl_ref(pTHX_ OP *o, I32 type) o->op_flags |= OPf_MOD; } break; - + case OP_THREADSV: o->op_flags |= OPf_MOD; /* XXX ??? */ break; @@ -1698,7 +1883,6 @@ S_dup_attrlist(pTHX_ OP *o) STATIC void S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) { - OP *modname; /* for 'use' */ SV *stashsv; /* fake up C */ @@ -1708,22 +1892,52 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) stashsv = newSVpv(HvNAME(stash), 0); else stashsv = &PL_sv_no; + #define ATTRSMODULE "attributes" - modname = newSVOP(OP_CONST, 0, - newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); - modname->op_private |= OPpCONST_BARE; - /* that flag is required to make 'use' work right */ - utilize(1, start_subparse(FALSE, 0), - Nullop, /* version */ - modname, - prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, stashsv), - prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, newRV(target)), - dup_attrlist(attrs)))); + + 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; } +void +Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, + char *attrstr, STRLEN len) +{ + OP *attrs = Nullop; + + if (!len) { + len = strlen(attrstr); + } + + while (len) { + for (; isSPACE(*attrstr) && len; --len, ++attrstr) ; + if (len) { + char *sstr = attrstr; + for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ; + attrs = append_elem(OP_LIST, attrs, + newSVOP(OP_CONST, 0, + newSVpvn(sstr, attrstr-sstr))); + } + } + + Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, + newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), + Nullsv, prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV((SV*)cv)), + attrs))); +} + STATIC OP * S_my_kid(pTHX_ OP *o, OP *attrs) { @@ -1742,13 +1956,26 @@ S_my_kid(pTHX_ OP *o, OP *attrs) } 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); + } + o->op_private |= OPpOUR_INTRO; return o; } else if (type != OP_PADSV && type != OP_PADAV && type != OP_PADHV && type != OP_PUSHMARK) { - yyerror(Perl_form(aTHX_ "Can't declare %s in my", PL_op_desc[o->op_type])); + yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", + PL_op_desc[o->op_type], + PL_in_my == KEY_our ? "our" : "my")); return o; } else if (attrs && type != OP_PUSHMARK) { @@ -1756,6 +1983,9 @@ S_my_kid(pTHX_ OP *o, OP *attrs) 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 && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp))) @@ -1775,11 +2005,12 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) { if (o->op_flags & OPf_PARENS) list(o); - PL_in_my = FALSE; - PL_in_my_stash = Nullhv; if (attrs) SAVEFREEOP(attrs); - return my_kid(o, attrs); + o = my_kid(o, attrs); + PL_in_my = FALSE; + PL_in_my_stash = Nullhv; + return o; } OP * @@ -1799,10 +2030,9 @@ Perl_sawparens(pTHX_ OP *o) OP * Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) { - dTHR; OP *o; - if (ckWARN(WARN_UNSAFE) && + if (ckWARN(WARN_MISC) && (left->op_type == OP_RV2AV || left->op_type == OP_RV2HV || left->op_type == OP_PADAV || @@ -1810,19 +2040,22 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) char *desc = PL_op_desc[(right->op_type == OP_SUBST || right->op_type == OP_TRANS) ? right->op_type : OP_MATCH]; - char *sample = ((left->op_type == OP_RV2AV || - left->op_type == OP_PADAV) - ? "@array" : "%hash"); - Perl_warner(aTHX_ WARN_UNSAFE, - "Applying %s to %s will act on scalar(%s)", + const char *sample = ((left->op_type == OP_RV2AV || + left->op_type == OP_PADAV) + ? "@array" : "%hash"); + Perl_warner(aTHX_ WARN_MISC, + "Applying %s to %s will act on scalar(%s)", desc, sample, sample); } - if (right->op_type == OP_MATCH || + if (!(right->op_flags & OPf_STACKED) && + (right->op_type == OP_MATCH || right->op_type == OP_SUBST || - right->op_type == OP_TRANS) { + right->op_type == OP_TRANS)) { right->op_flags |= OPf_STACKED; - if (right->op_type != OP_MATCH) + 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); @@ -1883,16 +2116,14 @@ Perl_save_hints(pTHX) int Perl_block_start(pTHX_ int full) { - dTHR; int retval = PL_savestack_ix; SAVEI32(PL_comppad_name_floor); - if (full) { - if ((PL_comppad_name_fill = AvFILLp(PL_comppad_name)) > 0) - PL_comppad_name_floor = PL_comppad_name_fill; - else - PL_comppad_name_floor = 0; - } + 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; @@ -1902,20 +2133,22 @@ Perl_block_start(pTHX_ int full) PL_pad_reset_pending = FALSE; SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; - SAVEPPTR(PL_compiling.cop_warnings); + SAVESPTR(PL_compiling.cop_warnings); if (! specialWARN(PL_compiling.cop_warnings)) { PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; SAVEFREESV(PL_compiling.cop_warnings) ; } - - + SAVESPTR(PL_compiling.cop_io); + if (! specialCopIO(PL_compiling.cop_io)) { + PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ; + SAVEFREESV(PL_compiling.cop_io) ; + } return retval; } OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { - dTHR; int needblockscope = PL_hints & HINT_BLOCK_SCOPE; OP* retval = scalarseq(seq); LEAVE_SCOPE(floor); @@ -1943,7 +2176,6 @@ S_newDEFSVOP(pTHX) void Perl_newPROG(pTHX_ OP *o) { - dTHR; if (PL_in_eval) { if (PL_eval_root) return; @@ -1951,6 +2183,8 @@ Perl_newPROG(pTHX_ OP *o) ((PL_in_eval & EVAL_KEEPERR) ? OPf_SPECIAL : 0), o); PL_eval_start = linklist(PL_eval_root); + PL_eval_root->op_private |= OPpREFCOUNTED; + OpREFCNT_set(PL_eval_root, 1); PL_eval_root->op_next = 0; peep(PL_eval_start); } @@ -1960,6 +2194,8 @@ Perl_newPROG(pTHX_ OP *o) PL_main_root = scope(sawparens(scalarvoid(o))); PL_curcop = &PL_compiling; PL_main_start = LINKLIST(PL_main_root); + PL_main_root->op_private |= OPpREFCOUNTED; + OpREFCNT_set(PL_main_root, 1); PL_main_root->op_next = 0; peep(PL_main_start); PL_compcv = 0; @@ -1970,7 +2206,7 @@ Perl_newPROG(pTHX_ OP *o) if (cv) { dSP; PUSHMARK(SP); - XPUSHs((SV*)PL_compiling.cop_filegv); + XPUSHs((SV*)CopFILEGV(&PL_compiling)); PUTBACK; call_sv((SV*)cv, G_DISCARD); } @@ -1984,21 +2220,22 @@ Perl_localize(pTHX_ OP *o, I32 lex) if (o->op_flags & OPf_PARENS) list(o); else { - dTHR; if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') { char *s; - for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ; + for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ; if (*s == ';' || *s == '=') - Perl_warner(aTHX_ WARN_PARENTHESIS, "Parentheses missing around \"%s\" list", - lex ? "my" : "local"); + Perl_warner(aTHX_ WARN_PARENTHESIS, + "Parentheses missing around \"%s\" list", + lex ? (PL_in_my == KEY_our ? "our" : "my") : "local"); } } - PL_in_my = FALSE; - PL_in_my_stash = Nullhv; if (lex) - return my(o); + o = my(o); else - return mod(o, OP_NULL); /* a bit kludgey */ + o = mod(o, OP_NULL); /* a bit kludgey */ + PL_in_my = FALSE; + PL_in_my_stash = Nullhv; + return o; } OP * @@ -2020,7 +2257,6 @@ Perl_jmaybe(pTHX_ OP *o) OP * Perl_fold_constants(pTHX_ register OP *o) { - dTHR; register OP *curop; I32 type = o->op_type; SV *sv; @@ -2096,13 +2332,11 @@ Perl_fold_constants(pTHX_ register OP *o) if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK && type != OP_NEGATE) { - IV iv = SvIV(sv); - if ((NV)iv == SvNV(sv)) { - SvREFCNT_dec(sv); - sv = newSViv(iv); - } - else - SvIOK_off(sv); /* undo SvIV() damage */ +#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); } @@ -2112,8 +2346,12 @@ Perl_fold_constants(pTHX_ register OP *o) return o; if (!(PL_hints & HINT_INTEGER)) { - if (type == OP_DIVIDE || !(o->op_flags & OPf_KIDS)) + 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) { @@ -2134,7 +2372,6 @@ Perl_fold_constants(pTHX_ register OP *o) OP * Perl_gen_constant_list(pTHX_ register OP *o) { - dTHR; register OP *curop; I32 oldtmps_floor = PL_tmps_floor; @@ -2144,6 +2381,7 @@ Perl_gen_constant_list(pTHX_ register OP *o) PL_op = curop = LINKLIST(o); o->op_next = 0; + peep(curop); pp_pushmark(); CALLRUNOPS(aTHX); PL_op = curop; @@ -2162,9 +2400,6 @@ Perl_gen_constant_list(pTHX_ register OP *o) OP * Perl_convert(pTHX_ I32 type, I32 flags, OP *o) { - OP *kid; - OP *last = 0; - if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, Nullop); else @@ -2181,13 +2416,6 @@ Perl_convert(pTHX_ I32 type, I32 flags, OP *o) if (o->op_type != type) return o; - if (cLISTOPo->op_children < 7) { - /* XXX do we really need to do this if we're done appending?? */ - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) - last = kid; - cLISTOPo->op_last = last; /* in case check substituted last arg */ - } - return fold_constants(o); } @@ -2202,8 +2430,11 @@ Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) if (!last) return first; - if (first->op_type != type || type==OP_LIST && first->op_flags & OPf_PARENS) - return newLISTOP(type, 0, first, last); + if (first->op_type != type + || (type == OP_LIST && (first->op_flags & OPf_PARENS))) + { + return newLISTOP(type, 0, first, last); + } if (first->op_flags & OPf_KIDS) ((LISTOP*)first)->op_last->op_sibling = last; @@ -2212,7 +2443,6 @@ Perl_append_elem(pTHX_ I32 type, OP *first, OP *last) ((LISTOP*)first)->op_first = last; } ((LISTOP*)first)->op_last = last; - ((LISTOP*)first)->op_children++; return first; } @@ -2233,13 +2463,11 @@ Perl_append_list(pTHX_ I32 type, LISTOP *first, LISTOP *last) first->op_last->op_sibling = last->op_first; first->op_last = last->op_last; - first->op_children += last->op_children; - if (first->op_children) - first->op_flags |= OPf_KIDS; - + first->op_flags |= (last->op_flags & OPf_KIDS); + #ifdef PL_OP_SLAB_ALLOC #else - Safefree(last); + Safefree(last); #endif return (OP*)first; } @@ -2257,6 +2485,8 @@ Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) if (type == OP_LIST) { /* already a PUSHMARK there */ first->op_sibling = ((LISTOP*)last)->op_first->op_sibling; ((LISTOP*)last)->op_first->op_sibling = first; + if (!(first->op_flags & OPf_PARENS)) + last->op_flags &= ~OPf_PARENS; } else { if (!(last->op_flags & OPf_KIDS)) { @@ -2266,7 +2496,7 @@ Perl_prepend_elem(pTHX_ I32 type, OP *first, OP *last) first->op_sibling = ((LISTOP*)last)->op_first; ((LISTOP*)last)->op_first = first; } - ((LISTOP*)last)->op_children++; + last->op_flags |= OPf_KIDS; return last; } @@ -2299,7 +2529,8 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) listop->op_type = type; listop->op_ppaddr = PL_ppaddr[type]; - listop->op_children = (first != 0) + (last != 0); + if (first || last) + flags |= OPf_KIDS; listop->op_flags = flags; if (!last && first) @@ -2319,8 +2550,6 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) if (!last) listop->op_last = pushop; } - else if (listop->op_children) - listop->op_flags |= OPf_KIDS; return (OP*)listop; } @@ -2417,25 +2646,32 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) SV *rstr = ((SVOP*)repl)->op_sv; STRLEN tlen; STRLEN rlen; - register U8 *t = (U8*)SvPV(tstr, tlen); - register U8 *r = (U8*)SvPV(rstr, rlen); + U8 *t = (U8*)SvPV(tstr, tlen); + U8 *r = (U8*)SvPV(rstr, rlen); register I32 i; register I32 j; I32 del; I32 complement; I32 squash; + I32 grows = 0; register short *tbl; complement = o->op_private & OPpTRANS_COMPLEMENT; del = o->op_private & OPpTRANS_DELETE; squash = o->op_private & OPpTRANS_SQUASH; + if (SvUTF8(tstr)) + o->op_private |= OPpTRANS_FROM_UTF; + + if (SvUTF8(rstr)) + o->op_private |= OPpTRANS_TO_UTF; + if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { SV* listsv = newSVpvn("# comment\n",10); SV* transv = 0; U8* tend = t + tlen; U8* rend = r + rlen; - I32 ulen; + STRLEN ulen; U32 tfirst = 1; U32 tlast = 0; I32 tdiff; @@ -2446,15 +2682,15 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) I32 none = 0; U32 max = 0; I32 bits; - I32 grows = 0; I32 havefinal = 0; U32 final; - HV *hv; I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; I32 to_utf = o->op_private & OPpTRANS_TO_UTF; + U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend); + U8* rsave = to_utf ? NULL : trlist_upgrade(&r, &rend); if (complement) { - U8 tmpbuf[10]; + U8 tmpbuf[UTF8_MAXLEN+1]; U8** cp; UV nextmin = 0; New(1109, cp, tlen, U8*); @@ -2463,7 +2699,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) while (t < tend) { cp[i++] = t; t += UTF8SKIP(t); - if (*t == 0xff) { + if (t < tend && *t == 0xff) { t++; t += UTF8SKIP(t); } @@ -2471,7 +2707,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) qsort(cp, i, sizeof(U8*), utf8compare); for (j = 0; j < i; j++) { U8 *s = cp[j]; - UV val = utf8_to_uv(s, &ulen); + I32 cur = j < i - 1 ? cp[j+1] - s : tend - s; + UV val = utf8_to_uv(s, cur, &ulen, 0); s += ulen; diff = val - nextmin; if (diff > 0) { @@ -2483,8 +2720,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); } } - if (*s == 0xff) - val = utf8_to_uv(s+1, &ulen); + if (s < tend && *s == 0xff) + val = utf8_to_uv(s+1, cur - 1, &ulen, 0); if (val >= nextmin) nextmin = val + 1; } @@ -2496,29 +2733,27 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) t = (U8*)SvPVX(transv); tlen = SvCUR(transv); tend = t + tlen; + Safefree(cp); } else if (!rlen && !del) { r = t; rlen = tlen; rend = tend; } if (!squash) { - if (to_utf && from_utf) { /* only counting characters */ - if (t == r || (tlen == rlen && memEQ(t, r, tlen))) - o->op_private |= OPpTRANS_IDENTICAL; - } - else { /* straight latin-1 translation */ - if (tlen == 4 && memEQ(t, "\0\377\303\277", 4) && - rlen == 4 && memEQ(r, "\0\377\303\277", 4)) + if (t == r || + (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) + { o->op_private |= OPpTRANS_IDENTICAL; - } + } } while (t < tend || tfirst <= tlast) { /* see if we need more "t" chars */ if (tfirst > tlast) { - tfirst = (I32)utf8_to_uv(t, &ulen); + tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0); t += ulen; if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */ - tlast = (I32)utf8_to_uv(++t, &ulen); + t++; + tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0); t += ulen; } else @@ -2528,10 +2763,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) /* now see if we need more "r" chars */ if (rfirst > rlast) { if (r < rend) { - rfirst = (I32)utf8_to_uv(r, &ulen); + rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0); r += ulen; if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */ - rlast = (I32)utf8_to_uv(++r, &ulen); + r++; + rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0); r += ulen; } else @@ -2556,33 +2792,25 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (rfirst == 0xffffffff) { diff = tdiff; /* oops, pretend rdiff is infinite */ if (diff > 0) - Perl_sv_catpvf(aTHX_ listsv, "%04x\t%04x\tXXXX\n", tfirst, tlast); + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\tXXXX\n", + (long)tfirst, (long)tlast); else - Perl_sv_catpvf(aTHX_ listsv, "%04x\t\tXXXX\n", tfirst); + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\tXXXX\n", (long)tfirst); } else { if (diff > 0) - Perl_sv_catpvf(aTHX_ listsv, "%04x\t%04x\t%04x\n", tfirst, tfirst + diff, rfirst); + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t%04lx\t%04lx\n", + (long)tfirst, (long)(tfirst + diff), + (long)rfirst); else - Perl_sv_catpvf(aTHX_ listsv, "%04x\t\t%04x\n", tfirst, rfirst); + Perl_sv_catpvf(aTHX_ listsv, "%04lx\t\t%04lx\n", + (long)tfirst, (long)rfirst); if (rfirst + diff > max) max = rfirst + diff; rfirst += diff + 1; - if (!grows) { - if (rfirst <= 0x80) - ; - else if (rfirst <= 0x800) - grows |= (tfirst < 0x80); - else if (rfirst <= 0x10000) - grows |= (tfirst < 0x800); - else if (rfirst <= 0x200000) - grows |= (tfirst < 0x10000); - else if (rfirst <= 0x4000000) - grows |= (tfirst < 0x200000); - else if (rfirst <= 0x80000000) - grows |= (tfirst < 0x4000000); - } + if (!grows) + grows = (UNISKIP(tfirst) < UNISKIP(rfirst)); } tfirst += diff + 1; } @@ -2598,17 +2826,24 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) else bits = 8; + Safefree(cPVOPo->op_pv); cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none); SvREFCNT_dec(listsv); if (transv) SvREFCNT_dec(transv); if (!del && havefinal) - (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, newSViv((IV)final), 0); + (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, + newSVuv((UV)final), 0); - if (grows && to_utf) + if (grows) o->op_private |= OPpTRANS_GROWS; + if (tsave) + Safefree(tsave); + if (rsave) + Safefree(rsave); + op_free(expr); op_free(repl); return o; @@ -2629,8 +2864,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) else tbl[i] = i; } - else + else { + if (i < 128 && r[j] >= 128) + grows = 1; tbl[i] = r[j++]; + } } } } @@ -2651,10 +2889,15 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } --j; } - if (tbl[t[i]] == -1) + if (tbl[t[i]] == -1) { + if (t[i] < 128 && r[j] >= 128) + grows = 1; tbl[t[i]] = r[j]; + } } } + if (grows) + o->op_private |= OPpTRANS_GROWS; op_free(expr); op_free(repl); @@ -2664,7 +2907,6 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) OP * Perl_newPMOP(pTHX_ I32 type, I32 flags) { - dTHR; PMOP *pmop; NewOp(1101, pmop, 1, PMOP); @@ -2691,7 +2933,6 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) OP * Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) { - dTHR; PMOP *pm; LOGOP *rcop; I32 repl_has_vars = 0; @@ -2711,14 +2952,18 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; } + if ((PL_hints & HINT_UTF8) || DO_UTF8(pat)) + pm->op_pmdynflags |= PMdf_UTF8; pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm); if (strEQ("\\s+", pm->op_pmregexp->precomp)) pm->op_pmflags |= PMf_WHITE; op_free(expr); } else { + if (PL_hints & HINT_UTF8) + pm->op_pmdynflags |= PMdf_UTF8; if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) - expr = newUNOP((!(PL_hints & HINT_RE_EVAL) + expr = newUNOP((!(PL_hints & HINT_RE_EVAL) ? OP_REGCRESET : OP_REGCMAYBE),0,expr); @@ -2726,7 +2971,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) rcop->op_type = OP_REGCOMP; rcop->op_ppaddr = PL_ppaddr[OP_REGCOMP]; rcop->op_first = scalar(expr); - rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) + rcop->op_flags |= ((PL_hints & HINT_RE_EVAL) ? (OPf_SPECIAL | OPf_KIDS) : OPf_KIDS); rcop->op_private = 1; @@ -2750,8 +2995,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) OP *curop; if (pm->op_pmflags & PMf_EVAL) { curop = 0; - if (PL_curcop->cop_line < PL_multi_end) - PL_curcop->cop_line = PL_multi_end; + if (CopLINE(PL_curcop) < PL_multi_end) + CopLINE_set(PL_curcop, PL_multi_end); } #ifdef USE_THREADS else if (repl->op_type == OP_THREADSV @@ -2775,7 +3020,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) } #else if (curop->op_type == OP_GV) { - GV *gv = ((GVOP*)curop)->op_gv; + GV *gv = cGVOPx_gv(curop); repl_has_vars = 1; if (strchr("&`'123456789+", *GvENAME(gv))) break; @@ -2805,8 +3050,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) } } if (curop == repl - && !(repl_has_vars - && (!pm->op_pmregexp + && !(repl_has_vars + && (!pm->op_pmregexp || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) { pm->op_pmflags |= PMf_CONST; /* const for long enough */ pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ @@ -2856,21 +3101,34 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) } OP * -Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) -{ - dTHR; - GVOP *gvop; - NewOp(1101, gvop, 1, GVOP); - gvop->op_type = type; - gvop->op_ppaddr = PL_ppaddr[type]; - gvop->op_gv = (GV*)SvREFCNT_inc(gv); - gvop->op_next = (OP*)gvop; - gvop->op_flags = flags; +Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) +{ + PADOP *padop; + NewOp(1101, padop, 1, PADOP); + padop->op_type = 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); + padop->op_next = (OP*)padop; + padop->op_flags = flags; if (PL_opargs[type] & OA_RETSCALAR) - scalar((OP*)gvop); + scalar((OP*)padop); if (PL_opargs[type] & OA_TARGET) - gvop->op_targ = pad_alloc(type, SVs_PADTMP); - return CHECKOP(type, gvop); + padop->op_targ = pad_alloc(type, SVs_PADTMP); + return CHECKOP(type, padop); +} + +OP * +Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) +{ +#ifdef USE_ITHREADS + GvIN_PAD_on(gv); + return newPADOP(type, flags, SvREFCNT_inc(gv)); +#else + return newSVOP(type, flags, SvREFCNT_inc(gv)); +#endif } OP * @@ -2893,7 +3151,6 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) void Perl_package(pTHX_ OP *o) { - dTHR; SV *sv; save_hptr(&PL_curstash); @@ -2920,7 +3177,6 @@ void Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) { OP *pack; - OP *meth; OP *rqop; OP *imop; OP *veop; @@ -2931,45 +3187,55 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) veop = Nullop; - if(version != Nullop) { + if (version != Nullop) { SV *vesv = ((SVOP*)version)->op_sv; - if (arg == Nullop && !SvNIOK(vesv)) { + if (arg == Nullop && !SvNIOKp(vesv)) { arg = version; } else { OP *pack; + SV *meth; - if (version->op_type != OP_CONST || !SvNIOK(vesv)) + if (version->op_type != OP_CONST || !SvNIOKp(vesv)) Perl_croak(aTHX_ "Version number must be constant number"); /* Make copy of id so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv)); /* Fake up a method call to VERSION */ + meth = newSVpvn("VERSION",7); + sv_upgrade(meth, SVt_PVIV); + (void)SvIOK_on(meth); + PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, append_elem(OP_LIST, - prepend_elem(OP_LIST, pack, list(version)), - newSVOP(OP_METHOD_NAMED, 0, - newSVpvn("VERSION", 7)))); + prepend_elem(OP_LIST, pack, list(version)), + newSVOP(OP_METHOD_NAMED, 0, meth))); } } /* Fake up an import/unimport */ if (arg && arg->op_type == OP_STUB) imop = arg; /* no import on explicit () */ - else if(SvNIOK(((SVOP*)id)->op_sv)) { + else if (SvNIOKp(((SVOP*)id)->op_sv)) { imop = Nullop; /* use 5.0; */ } else { + SV *meth; + /* Make copy of id so we don't free it twice */ 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);; + sv_upgrade(meth, SVt_PVIV); + (void)SvIOK_on(meth); + PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, - append_elem(OP_LIST, - prepend_elem(OP_LIST, pack, list(arg)), - newSVOP(OP_METHOD_NAMED, 0, - aver ? newSVpvn("import", 6) - : newSVpvn("unimport", 8)))); + append_elem(OP_LIST, + prepend_elem(OP_LIST, pack, list(arg)), + newSVOP(OP_METHOD_NAMED, 0, meth))); } /* Fake up a require, handle override, if any */ @@ -3004,6 +3270,65 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) PL_expect = XSTATE; } +void +Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) +{ + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} + +#ifdef PERL_IMPLICIT_CONTEXT +void +Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...) +{ + dTHX; + va_list args; + va_start(args, ver); + vload_module(flags, name, ver, &args); + va_end(args); +} +#endif + +void +Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args) +{ + OP *modname, *veop, *imop; + + modname = newSVOP(OP_CONST, 0, name); + modname->op_private |= OPpCONST_BARE; + if (ver) { + veop = newSVOP(OP_CONST, 0, ver); + } + else + veop = Nullop; + if (flags & PERL_LOADMOD_NOIMPORT) { + imop = sawparens(newNULLLIST()); + } + else if (flags & PERL_LOADMOD_IMPORT_OPS) { + imop = va_arg(*args, OP*); + } + else { + SV *sv; + imop = Nullop; + sv = va_arg(*args, SV*); + while (sv) { + imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv)); + sv = va_arg(*args, SV*); + } + } + { + line_t ocopline = PL_copline; + int oexpect = PL_expect; + + utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), + veop, modname, imop); + PL_expect = oexpect; + PL_copline = ocopline; + } +} + OP * Perl_dofile(pTHX_ OP *term) { @@ -3087,7 +3412,8 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } if (list_assignment(left)) { - dTHR; + OP *curop; + PL_modcount = 0; PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ left = mod(left, OP_AASSIGN); @@ -3098,18 +3424,25 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) op_free(right); return Nullop; } - o = newBINOP(OP_AASSIGN, flags, - list(force_list(right)), - list(force_list(left)) ); + 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; + } + } if (!(left->op_private & OPpLVAL_INTRO)) { - OP *curop; OP *lastop = o; PL_generation++; for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { if (PL_opargs[curop->op_type] & OA_DANGEROUS) { if (curop->op_type == OP_GV) { - GV *gv = ((GVOP*)curop)->op_gv; + GV *gv = cGVOPx_gv(curop); if (gv == PL_defgv || SvCUR(gv) == PL_generation) break; SvCUR(gv) = PL_generation; @@ -3135,7 +3468,11 @@ 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[(PADOFFSET)((PMOP*)curop)->op_pmreplroot]; +#else GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; +#endif if (gv == PL_defgv || SvCUR(gv) == PL_generation) break; SvCUR(gv) = PL_generation; @@ -3147,7 +3484,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) lastop = curop; } if (curop != o) - o->op_private = OPpASSIGN_COMMON; + o->op_private |= OPpASSIGN_COMMON; } if (right && right->op_type == OP_SPLIT) { OP* tmpop; @@ -3161,7 +3498,13 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) { tmpop = ((UNOP*)left)->op_first; if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) { - pm->op_pmreplroot = (OP*)((GVOP*)tmpop)->op_gv; +#ifdef USE_ITHREADS + pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix; + cPADOPx(tmpop)->op_padix = 0; /* steal it */ +#else + pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv; + cSVOPx(tmpop)->op_sv = Nullsv; /* steal it */ +#endif pm->op_pmflags |= PMf_ONCE; tmpop = cUNOPo->op_first; /* to list (nulled) */ tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */ @@ -3174,7 +3517,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } } else { - if (PL_modcount < 10000 && + if (PL_modcount < RETURN_UNLIMITED_NUMBER && ((LISTOP*)right)->op_last->op_type == OP_CONST) { SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; @@ -3209,12 +3552,11 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) OP * Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) { - dTHR; U32 seq = intro_my(); register COP *cop; NewOp(1101, cop, 1, COP); - if (PERLDB_LINE && PL_curcop->cop_line && PL_curstash != PL_debstash) { + if (PERLDB_LINE && CopLINE(PL_curcop) && PL_curstash != PL_debstash) { cop->op_type = OP_DBSTATE; cop->op_ppaddr = PL_ppaddr[ OP_DBSTATE ]; } @@ -3223,7 +3565,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ]; } cop->op_flags = flags; - cop->op_private = (PL_hints & HINT_UTF8); + cop->op_private = (PL_hints & HINT_BYTE); #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif @@ -3238,25 +3580,32 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->cop_arybase = PL_curcop->cop_arybase; if (specialWARN(PL_curcop->cop_warnings)) cop->cop_warnings = PL_curcop->cop_warnings ; - else + else cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ; + if (specialCopIO(PL_curcop->cop_io)) + cop->cop_io = PL_curcop->cop_io; + else + cop->cop_io = newSVsv(PL_curcop->cop_io) ; if (PL_copline == NOLINE) - cop->cop_line = PL_curcop->cop_line; + CopLINE_set(cop, CopLINE(PL_curcop)); else { - cop->cop_line = PL_copline; + CopLINE_set(cop, PL_copline); PL_copline = NOLINE; } - cop->cop_filegv = (GV*)SvREFCNT_inc(PL_curcop->cop_filegv); - cop->cop_stash = PL_curstash; +#ifdef USE_ITHREADS + CopFILE_set(cop, CopFILE(PL_curcop)); /* XXX share in a pvtable? */ +#else + CopFILEGV_set(cop, CopFILEGV(PL_curcop)); +#endif + CopSTASH_set(cop, PL_curstash); if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV **svp = av_fetch(GvAV(PL_curcop->cop_filegv),(I32)cop->cop_line, FALSE); + SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE); if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) { (void)SvIOK_on(*svp); - SvIVX(*svp) = 1; - SvSTASH(*svp) = (HV*)cop; + SvIVX(*svp) = PTR2IV(cop); } } @@ -3295,7 +3644,6 @@ Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) { - dTHR; LOGOP *logop; OP *o; OP *first = *firstp; @@ -3321,9 +3669,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) } } if (first->op_type == OP_CONST) { - if (ckWARN(WARN_PRECEDENCE) && (first->op_private & OPpCONST_BARE)) - Perl_warner(aTHX_ WARN_PRECEDENCE, "Probable precedence problem on %s", - PL_op_desc[type]); + if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) + Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional"); if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) { op_free(first); *firstp = Nullop; @@ -3341,7 +3688,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) else scalar(other); } - else if (ckWARN(WARN_UNSAFE) && (first->op_flags & OPf_KIDS)) { + else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) { OP *k1 = ((UNOP*)first)->op_first; OP *k2 = k1->op_sibling; OPCODE warnop = 0; @@ -3350,7 +3697,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) case OP_NULL: if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) - && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) { warnop = k2->op_type; } @@ -3368,14 +3715,14 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) break; } if (warnop) { - line_t oldline = PL_curcop->cop_line; - PL_curcop->cop_line = PL_copline; - Perl_warner(aTHX_ WARN_UNSAFE, + line_t oldline = CopLINE(PL_curcop); + CopLINE_set(PL_curcop, PL_copline); + Perl_warner(aTHX_ WARN_MISC, "Value of %s%s can be \"0\"; test with defined()", PL_op_desc[warnop], ((warnop == OP_READLINE || warnop == OP_GLOB) ? " construct" : "() operator")); - PL_curcop->cop_line = oldline; + CopLINE_set(PL_curcop, oldline); } } @@ -3408,7 +3755,6 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) OP * Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) { - dTHR; LOGOP *logop; OP *start; OP *o; @@ -3462,7 +3808,6 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) OP * Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) { - dTHR; LOGOP *range; OP *flip; OP *flop; @@ -3509,7 +3854,6 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) OP * Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) { - dTHR; OP* listop; OP* o; int once = block && block->op_flags & OPf_SPECIAL && @@ -3526,12 +3870,12 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) OP *k1 = ((UNOP*)expr)->op_first; OP *k2 = (k1) ? k1->op_sibling : NULL; switch (expr->op_type) { - case OP_NULL: + case OP_NULL: if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) - && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) expr = newUNOP(OP_DEFINED, 0, expr); - break; + break; case OP_SASSIGN: if (k1->op_type == OP_READDIR @@ -3565,12 +3909,12 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) OP * Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *block, OP *cont) { - dTHR; OP *redo; OP *next = 0; OP *listop; OP *o; OP *condop; + U8 loopflags = 0; if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) { @@ -3580,12 +3924,12 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * OP *k1 = ((UNOP*)expr)->op_first; OP *k2 = (k1) ? k1->op_sibling : NULL; switch (expr->op_type) { - case OP_NULL: + case OP_NULL: if (k2 && k2->op_type == OP_READLINE && (k2->op_flags & OPf_STACKED) - && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) + && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) expr = newUNOP(OP_DEFINED, 0, expr); - break; + break; case OP_SASSIGN: if (k1->op_type == OP_READDIR @@ -3599,11 +3943,18 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (!block) block = newOP(OP_NULL, 0); + else if (cont) { + block = scope(block); + } - if (cont) + if (cont) { next = LINKLIST(cont); + } if (expr) { - cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0)); + OP *unstack = newOP(OP_UNSTACK, 0); + if (!next) + next = unstack; + cont = append_elem(OP_LINESEQ, cont, unstack); if ((line_t)whileline != NOLINE) { PL_copline = whileline; cont = append_elem(OP_LINESEQ, cont, @@ -3626,8 +3977,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (listop) ((LISTOP*)listop)->op_last->op_next = condop = (o == listop ? redo : LINKLIST(o)); - if (!next) - next = condop; } else o = listop; @@ -3644,6 +3993,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * loop->op_redoop = redo; loop->op_lastop = o; + o->op_private |= loopflags; if (next) loop->op_nextop = next; @@ -3659,7 +4009,6 @@ OP * Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont) { LOOP *loop; - LOOP *tmp; OP *wop; int padoff = 0; I32 iterflags = 0; @@ -3671,11 +4020,13 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo } else if (sv->op_type == OP_PADSV) { /* private variable */ padoff = sv->op_targ; + sv->op_targ = 0; op_free(sv); sv = Nullop; } else if (sv->op_type == OP_THREADSV) { /* per-thread variable */ padoff = sv->op_targ; + sv->op_targ = 0; iterflags |= OPf_SPECIAL; op_free(sv); sv = Nullop; @@ -3732,12 +4083,15 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo append_elem(OP_LIST, expr, scalar(sv)))); assert(!loop->op_next); #ifdef PL_OP_SLAB_ALLOC - NewOp(1234,tmp,1,LOOP); - Copy(loop,tmp,1,LOOP); - loop = tmp; + { + LOOP *tmp; + NewOp(1234,tmp,1,LOOP); + Copy(loop,tmp,1,LOOP); + loop = tmp; + } #else Renew(loop, 1, LOOP); -#endif +#endif loop->op_targ = padoff; wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont); PL_copline = forline; @@ -3747,7 +4101,6 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo OP* Perl_newLOOPEX(pTHX_ I32 type, OP *label) { - dTHR; OP *o; STRLEN n_a; @@ -3774,7 +4127,6 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) void Perl_cv_undef(pTHX_ CV *cv) { - dTHR; #ifdef USE_THREADS if (CvMUTEXP(cv)) { MUTEX_DESTROY(CvMUTEXP(cv)); @@ -3793,7 +4145,7 @@ Perl_cv_undef(pTHX_ CV *cv) #endif /* USE_THREADS */ ENTER; - SAVESPTR(PL_curpad); + SAVEVPTR(PL_curpad); PL_curpad = 0; if (!CvCLONED(cv)) @@ -3802,11 +4154,13 @@ Perl_cv_undef(pTHX_ CV *cv) LEAVE; } SvPOK_off((SV*)cv); /* forget prototype */ - CvFLAGS(cv) = 0; - SvREFCNT_dec(CvGV(cv)); CvGV(cv) = Nullgv; 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))) { @@ -3828,12 +4182,14 @@ Perl_cv_undef(pTHX_ CV *cv) } CvPADLIST(cv) = Nullav; } + CvFLAGS(cv) = 0; } #ifdef DEBUG_CLOSURES STATIC void -cv_dump(CV *cv) +S_cv_dump(pTHX_ CV *cv) { +#ifdef DEBUGGING CV *outside = CvOUTSIDE(cv); AV* padlist = CvPADLIST(cv); AV* pad_name; @@ -3842,13 +4198,14 @@ cv_dump(CV *cv) SV** ppad; I32 ix; - PerlIO_printf(Perl_debug_log, "\tCV=0x%lx (%s), OUTSIDE=0x%lx (%s)\n", - cv, + 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"), - outside, + PTR2UV(outside), (!outside ? "null" : CvANON(outside) ? "ANON" : (outside == PL_main_cv) ? "MAIN" @@ -3865,20 +4222,21 @@ cv_dump(CV *cv) for (ix = 1; ix <= AvFILLp(pad_name); ix++) { if (SvPOK(pname[ix])) - PerlIO_printf(Perl_debug_log, "\t%4d. 0x%lx (%s\"%s\" %ld-%ld)\n", - ix, ppad[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]), - (long)I_32(SvNVX(pname[ix])), - (long)SvIVX(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) { - dTHR; AV* av; I32 ix; AV* protopadlist = CvPADLIST(proto); @@ -3894,24 +4252,22 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) assert(!CvUNIQUE(proto)); ENTER; - SAVESPTR(PL_curpad); - SAVESPTR(PL_comppad); + 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); - if (CvANON(proto)) - CvANON_on(cv); #ifdef USE_THREADS New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); CvOWNER(cv) = 0; #endif /* USE_THREADS */ - CvFILEGV(cv) = CvFILEGV(proto); - CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto)); + CvFILE(cv) = CvFILE(proto); + CvGV(cv) = CvGV(proto); CvSTASH(cv) = CvSTASH(proto); CvROOT(cv) = CvROOT(proto); CvSTART(cv) = CvSTART(proto); @@ -3969,6 +4325,9 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) 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); @@ -4004,6 +4363,15 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) #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; } @@ -4011,18 +4379,16 @@ CV * Perl_cv_clone(pTHX_ CV *proto) { CV *cv; - MUTEX_LOCK(&PL_cred_mutex); /* XXX create separate mutex */ + LOCK_CRED_MUTEX; /* XXX create separate mutex */ cv = cv_clone2(proto, CvOUTSIDE(proto)); - MUTEX_UNLOCK(&PL_cred_mutex); /* XXX create separate mutex */ + UNLOCK_CRED_MUTEX; /* XXX create separate mutex */ return cv; } void Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) { - dTHR; - - if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_UNSAFE)) { + if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { SV* msg = sv_newmortal(); SV* name = Nullsv; @@ -4030,7 +4396,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) gv_efullname3(name = sv_newmortal(), gv, Nullch); sv_setpv(msg, "Prototype mismatch:"); if (name) - Perl_sv_catpvf(aTHX_ msg, " sub %_", name); + Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, name); if (SvPOK(cv)) Perl_sv_catpvf(aTHX_ msg, " (%s)", SvPVX(cv)); sv_catpv(msg, " vs "); @@ -4038,16 +4404,29 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) Perl_sv_catpvf(aTHX_ msg, "(%s)", p); else sv_catpv(msg, "none"); - Perl_warner(aTHX_ WARN_UNSAFE, "%_", msg); + Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg); } } +static void const_sv_xsub(pTHXo_ CV* cv); + +/* +=for apidoc cv_const_sv + +If C is a constant sub eligible for inlining. returns the constant +value returned by the sub. Otherwise, returns NULL. + +Constant subs can be created with C or as described in +L. + +=cut +*/ SV * Perl_cv_const_sv(pTHX_ CV *cv) { - if (!cv || !SvPOK(cv) || SvCUR(cv)) + if (!cv || !CvCONST(cv)) return Nullsv; - return op_const_sv(CvSTART(cv), cv); + return (SV*)CvXSUBANY(cv).any_ptr; } SV * @@ -4055,29 +4434,43 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) { SV *sv = Nullsv; - if(!o) + if (!o) return Nullsv; - - if(o->op_type == OP_LINESEQ && cLISTOPo->op_first) + + if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) o = cLISTOPo->op_first->op_sibling; for (; o; o = o->op_next) { OPCODE type = o->op_type; - if (sv && o->op_next == o) + if (sv && o->op_next == o) return sv; - if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) - continue; + if (o->op_next != o) { + if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK) + continue; + if (type == OP_DBSTATE) + continue; + } if (type == OP_LEAVESUB || type == OP_RETURN) break; if (sv) return Nullsv; - if (type == OP_CONST) + if (type == OP_CONST && cSVOPo->op_sv) sv = cSVOPo->op_sv; - else if (type == OP_PADSV && cv) { + else if ((type == OP_PADSV || type == OP_CONST) && cv) { AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]); sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv; - if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1)) + if (!sv) + return Nullsv; + if (CvCONST(cv)) { + /* We get here only from cv_clone2() while creating a closure. + Copy the const value here instead of in cv_clone2 so that + SvREADONLY_on doesn't lead to problems when leaving + scope. + */ + sv = newSVsv(sv); + } + if (!SvREADONLY(sv) && SvREFCNT(sv) > 1) return Nullsv; } else @@ -4111,15 +4504,27 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { - dTHR; STRLEN n_a; - char *name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch; - GV *gv = gv_fetchpv(name ? name : "__ANON__", - GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), - SVt_PVCV); + char *name; + char *aname; + 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"]", + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + aname = SvPVX(sv); + } + else + aname = Nullch; + gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"), + GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT), + SVt_PVCV); if (o) SAVEFREEOP(o); @@ -4132,9 +4537,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) maximum a prototype before. */ if (SvTYPE(gv) > SVt_NULL) { if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1) - && ckWARN_d(WARN_UNSAFE)) + && ckWARN_d(WARN_PROTOTYPE)) { - Perl_warner(aTHX_ WARN_UNSAFE, "Runaway prototype"); + Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype"); } cv_ckproto((CV*)gv, NULL, ps); } @@ -4145,17 +4550,39 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; PL_sub_generation++; - goto noblock; + goto done; } - if (!name || GvCVGEN(gv)) - cv = Nullcv; - else if (cv = GvCV(gv)) { - cv_ckproto(cv, gv, ps); + cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv); + +#ifdef GV_SHARED_CHECK + if (cv && GvSHARED(gv) && SvREADONLY(cv)) { + Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name); + } +#endif + + if (!block || !ps || *ps || attrs) + const_sv = Nullsv; + else + const_sv = op_const_sv(block, Nullcv); + + if (cv) { + bool exists = CvROOT(cv) || CvXSUB(cv); + +#ifdef GV_SHARED_CHECK + if (exists && GvSHARED(gv)) { + Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name); + } +#endif + + /* if the subroutine doesn't exist and wasn't pre-declared + * with a prototype, assume it will be AUTOLOADed, + * skipping the prototype check + */ + if (exists || SvPOK(cv)) + cv_ckproto(cv, gv, ps); /* already defined (or promised)? */ - if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { - SV* const_sv; - bool const_changed = TRUE; + if (exists || GvASSUMECV(gv)) { if (!block && !attrs) { /* just a "sub foo;" when &foo is already defined */ SAVEFREESV(PL_compcv); @@ -4164,27 +4591,42 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) /* ahem, death to those who redefine active sort subs */ if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv)) Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name); - if (!block) - goto withattrs; - if(const_sv = cv_const_sv(cv)) - const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv)); - if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE) - && !(CvGV(cv) && GvSTASH(CvGV(cv)) - && HvNAME(GvSTASH(CvGV(cv))) - && strEQ(HvNAME(GvSTASH(CvGV(cv))), - "autouse"))) { - line_t oldline = PL_curcop->cop_line; - PL_curcop->cop_line = PL_copline; - Perl_warner(aTHX_ WARN_REDEFINE, - const_sv ? "Constant subroutine %s redefined" - : "Subroutine %s redefined", name); - PL_curcop->cop_line = oldline; + if (block) { + if (ckWARN(WARN_REDEFINE) + || (CvCONST(cv) + && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv)))) + { + line_t oldline = CopLINE(PL_curcop); + CopLINE_set(PL_curcop, PL_copline); + Perl_warner(aTHX_ WARN_REDEFINE, + CvCONST(cv) ? "Constant subroutine %s redefined" + : "Subroutine %s redefined", name); + CopLINE_set(PL_curcop, oldline); + } + SvREFCNT_dec(cv); + cv = Nullcv; } - SvREFCNT_dec(cv); - cv = Nullcv; } } - withattrs: + if (const_sv) { + SvREFCNT_inc(const_sv); + if (cv) { + assert(!CvROOT(cv) && !CvCONST(cv)); + sv_setpv((SV*)cv, ""); /* prototype is "" */ + CvXSUBANY(cv).any_ptr = const_sv; + CvXSUB(cv) = const_sv_xsub; + CvCONST_on(cv); + } + else { + GvCV(gv) = Nullcv; + cv = newCONSTSUB(NULL, name, const_sv); + } + op_free(block); + SvREFCNT_dec(PL_compcv); + PL_compcv = NULL; + PL_sub_generation++; + goto done; + } if (attrs) { HV *stash; SV *rcv; @@ -4235,8 +4677,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_sub_generation++; } } - CvGV(cv) = (GV*)SvREFCNT_inc(gv); - CvFILEGV(cv) = PL_curcop->cop_filegv; + CvGV(cv) = gv; + CvFILE(cv) = CopFILE(PL_curcop); CvSTASH(cv) = PL_curstash; #ifdef USE_THREADS CvOWNER(cv) = 0; @@ -4268,22 +4710,32 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } } - if (!block) { - noblock: - PL_copline = NOLINE; - LEAVE_SCOPE(floor); - return cv; - } + 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)); + } + else { + CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); + } + CvROOT(cv)->op_private |= OPpREFCOUNTED; + OpREFCNT_set(CvROOT(cv), 1); + CvSTART(cv) = LINKLIST(CvROOT(cv)); + CvROOT(cv)->op_next = 0; + 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])) + 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 @@ -4299,6 +4751,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_curpad[ix] = Nullsv; } } + assert(!CvCONST(cv)); + if (ps && !*ps && op_const_sv(block, cv)) + CvCONST_on(cv); } else { AV *av = newAV(); /* Will be @_ */ @@ -4307,66 +4762,62 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) AvFLAGS(av) = AVf_REIFY; for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { - if (SvIMMORTAL(PL_curpad[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(CvLVALUE(cv)) { - CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block)); - } - else { - CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); - } - CvSTART(cv) = LINKLIST(CvROOT(cv)); - CvROOT(cv)->op_next = 0; - peep(CvSTART(cv)); - - if (name) { + if (name || aname) { char *s; + char *tname = (name ? name : aname); if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { SV *sv = NEWSV(0,0); SV *tmpstr = sv_newmortal(); GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV); - CV *cv; + CV *pcv; HV *hv; - Perl_sv_setpvf(aTHX_ sv, "%_:%ld-%ld", - GvSV(PL_curcop->cop_filegv), - (long)PL_subline, (long)PL_curcop->cop_line); + Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld", + CopFILE(PL_curcop), + (long)PL_subline, (long)CopLINE(PL_curcop)); gv_efullname3(tmpstr, gv, Nullch); hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); hv = GvHVn(db_postponed); if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr)) - && (cv = GvCV(db_postponed))) { + && (pcv = GvCV(db_postponed))) + { dSP; PUSHMARK(SP); XPUSHs(tmpstr); PUTBACK; - call_sv((SV*)cv, G_DISCARD); + call_sv((SV*)pcv, G_DISCARD); } } - if ((s = strrchr(name,':'))) + if ((s = strrchr(tname,':'))) s++; else - s = name; + s = tname; + + if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') + goto done; + if (strEQ(s, "BEGIN")) { I32 oldscope = PL_scopestack_ix; ENTER; - SAVESPTR(PL_compiling.cop_filegv); - SAVEI16(PL_compiling.cop_line); + SAVECOPFILE(&PL_compiling); + SAVECOPLINE(&PL_compiling); save_svref(&PL_rs); sv_setsv(PL_rs, PL_nrs); if (!PL_beginav) PL_beginav = newAV(); DEBUG_x( dump_sub(gv) ); - av_push(PL_beginav, (SV *)cv); - GvCV(gv) = 0; + av_push(PL_beginav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ call_list(oldscope, PL_beginav); PL_curcop = &PL_compiling; @@ -4376,15 +4827,29 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else if (strEQ(s, "END") && !PL_error_count) { if (!PL_endav) PL_endav = newAV(); + DEBUG_x( dump_sub(gv) ); av_unshift(PL_endav, 1); - av_store(PL_endav, 0, (SV *)cv); - GvCV(gv) = 0; + av_store(PL_endav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ + } + else if (strEQ(s, "CHECK") && !PL_error_count) { + if (!PL_checkav) + 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"); + av_unshift(PL_checkav, 1); + av_store(PL_checkav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "INIT") && !PL_error_count) { if (!PL_initav) PL_initav = newAV(); - av_push(PL_initav, SvREFCNT_inc(cv)); - GvCV(gv) = 0; + DEBUG_x( dump_sub(gv) ); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); + av_push(PL_initav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } } @@ -4395,42 +4860,64 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } /* XXX unsafe for threads if eval_owner isn't held */ -void +/* +=for apidoc newCONSTSUB + +Creates a constant sub equivalent to Perl C which is +eligible for inlining at compile-time. + +=cut +*/ + +CV * Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) { - dTHR; - U32 oldhints = PL_hints; - HV *old_cop_stash = PL_curcop->cop_stash; - HV *old_curstash = PL_curstash; - line_t oldline = PL_curcop->cop_line; - PL_curcop->cop_line = PL_copline; + CV* cv; + + ENTER; + + SAVECOPLINE(PL_curcop); + CopLINE_set(PL_curcop, PL_copline); + SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; - if(stash) - PL_curstash = PL_curcop->cop_stash = stash; - newATTRSUB( - start_subparse(FALSE, 0), - newSVOP(OP_CONST, 0, newSVpv(name,0)), - newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */ - Nullop, - newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv)) - ); + if (stash) { + 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 + } + + cv = newXS(name, const_sv_xsub, __FILE__); + CvXSUBANY(cv).any_ptr = sv; + CvCONST_on(cv); + sv_setpv((SV*)cv, ""); /* prototype is "" */ - PL_hints = oldhints; - PL_curcop->cop_stash = old_cop_stash; - PL_curstash = old_curstash; - PL_curcop->cop_line = oldline; + LEAVE; + + return cv; } +/* +=for apidoc U||newXS + +Used by C to hook up XSUBs as Perl subs. + +=cut +*/ + CV * Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) { - dTHR; GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); register CV *cv; - if (cv = (name ? GvCV(gv) : Nullcv)) { + if ((cv = (name ? GvCV(gv) : Nullcv))) { if (GvCVGEN(gv)) { /* just a cached method */ SvREFCNT_dec(cv); @@ -4441,11 +4928,14 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))) && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) { - line_t oldline = PL_curcop->cop_line; + line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) - PL_curcop->cop_line = PL_copline; - Perl_warner(aTHX_ WARN_REDEFINE, "Subroutine %s redefined",name); - PL_curcop->cop_line = oldline; + CopLINE_set(PL_curcop, PL_copline); + Perl_warner(aTHX_ WARN_REDEFINE, + CvCONST(cv) ? "Constant subroutine %s redefined" + : "Subroutine %s redefined" + ,name); + CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); cv = 0; @@ -4463,13 +4953,15 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) PL_sub_generation++; } } - CvGV(cv) = (GV*)SvREFCNT_inc(gv); + CvGV(cv) = gv; #ifdef USE_THREADS New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); CvOWNER(cv) = 0; #endif /* USE_THREADS */ - CvFILEGV(cv) = gv_fetchfile(filename); + (void)gv_fetchfile(filename); + CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be + an external constant string */ CvXSUB(cv) = subaddr; if (name) { @@ -4478,36 +4970,51 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) s++; else s = name; + + if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') + goto done; + if (strEQ(s, "BEGIN")) { if (!PL_beginav) PL_beginav = newAV(); - av_push(PL_beginav, (SV *)cv); - GvCV(gv) = 0; + av_push(PL_beginav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } else if (strEQ(s, "END")) { if (!PL_endav) PL_endav = newAV(); av_unshift(PL_endav, 1); - av_store(PL_endav, 0, (SV *)cv); - GvCV(gv) = 0; + av_store(PL_endav, 0, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ + } + else if (strEQ(s, "CHECK")) { + if (!PL_checkav) + PL_checkav = newAV(); + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ 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 */ } else if (strEQ(s, "INIT")) { if (!PL_initav) PL_initav = newAV(); - av_push(PL_initav, (SV *)cv); - GvCV(gv) = 0; + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block"); + av_push(PL_initav, (SV*)cv); + GvCV(gv) = 0; /* cv has been hijacked */ } } else CvANON_on(cv); +done: return cv; } void Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { - dTHR; register CV *cv; char *name; GV *gv; @@ -4519,21 +5026,26 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) else name = "STDOUT"; gv = gv_fetchpv(name,TRUE, SVt_PVFM); +#ifdef GV_SHARED_CHECK + if (GvSHARED(gv)) { + Perl_croak(aTHX_ "Bad symbol for form (GV is shared)"); + } +#endif GvMULTI_on(gv); - if (cv = GvFORM(gv)) { + if ((cv = GvFORM(gv))) { if (ckWARN(WARN_REDEFINE)) { - line_t oldline = PL_curcop->cop_line; + line_t oldline = CopLINE(PL_curcop); - PL_curcop->cop_line = PL_copline; + CopLINE_set(PL_curcop, PL_copline); Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name); - PL_curcop->cop_line = oldline; + CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); } cv = PL_compcv; GvFORM(gv) = cv; - CvGV(cv) = (GV*)SvREFCNT_inc(gv); - CvFILEGV(cv) = PL_curcop->cop_filegv; + CvGV(cv) = gv; + CvFILE(cv) = CopFILE(PL_curcop); for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix])) @@ -4541,6 +5053,8 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) } CvROOT(cv) = newUNOP(OP_LEAVEWRITE, 0, scalarseq(block)); + CvROOT(cv)->op_private |= OPpREFCOUNTED; + OpREFCNT_set(CvROOT(cv), 1); CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; peep(CvSTART(cv)); @@ -4603,8 +5117,6 @@ Perl_oopsAV(pTHX_ OP *o) OP * Perl_oopsHV(pTHX_ OP *o) { - dTHR; - switch (o->op_type) { case OP_PADSV: case OP_PADAV: @@ -4755,11 +5267,22 @@ Perl_ck_delete(pTHX_ OP *o) o->op_private = 0; if (o->op_flags & OPf_KIDS) { OP *kid = cUNOPo->op_first; - if (kid->op_type == OP_HSLICE) + switch (kid->op_type) { + case OP_ASLICE: + o->op_flags |= OPf_SPECIAL; + /* FALL THROUGH */ + case OP_HSLICE: o->op_private |= OPpSLICE; - else if (kid->op_type != OP_HELEM) - Perl_croak(aTHX_ "%s argument is not a HASH element or slice", + break; + case OP_AELEM: + o->op_flags |= OPf_SPECIAL; + /* FALL THROUGH */ + case OP_HELEM: + break; + default: + Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", PL_op_desc[o->op_type]); + } null(kid); } return o; @@ -4825,6 +5348,20 @@ Perl_ck_eval(pTHX_ OP *o) } OP * +Perl_ck_exit(pTHX_ OP *o) +{ +#ifdef VMS + HV *table = GvHV(PL_hintgv); + if (table) { + SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE); + if (svp && *svp && SvTRUE(*svp)) + o->op_private |= OPpEXIT_VMSISH; + } +#endif + return ck_fun(o); +} + +OP * Perl_ck_exec(pTHX_ OP *o) { OP *kid; @@ -4845,8 +5382,18 @@ Perl_ck_exists(pTHX_ OP *o) o = ck_fun(o); if (o->op_flags & OPf_KIDS) { OP *kid = cUNOPo->op_first; - if (kid->op_type != OP_HELEM) - Perl_croak(aTHX_ "%s argument is not a HASH element", PL_op_desc[o->op_type]); + if (kid->op_type == OP_ENTERSUB) { + (void) ref(kid, o->op_type); + if (kid->op_type != OP_RV2CV && !PL_error_count) + Perl_croak(aTHX_ "%s argument is not a subroutine name", + PL_op_desc[o->op_type]); + o->op_private |= OPpEXISTS_SUB; + } + else if (kid->op_type == OP_AELEM) + o->op_flags |= OPf_SPECIAL; + else if (kid->op_type != OP_HELEM) + Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element", + PL_op_desc[o->op_type]); null(kid); } return o; @@ -4866,7 +5413,6 @@ Perl_ck_gvconst(pTHX_ register OP *o) OP * Perl_ck_rvconst(pTHX_ register OP *o) { - dTHR; SVOP *kid = (SVOP*)cUNOPo->op_first; o->op_private |= (PL_hints & HINT_STRICT_REFS); @@ -4929,7 +5475,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) break; } if (badthing) - Perl_croak(aTHX_ + Perl_croak(aTHX_ "Can't use bareword (\"%s\") as %s ref while \"strict refs\" in use", name, badthing); } @@ -4958,7 +5504,16 @@ Perl_ck_rvconst(pTHX_ register OP *o) if (gv) { kid->op_type = OP_GV; SvREFCNT_dec(kid->op_sv); +#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]); + GvIN_PAD_on(gv); + PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv); +#else kid->op_sv = SvREFCNT_inc(gv); +#endif + kid->op_private = 0; kid->op_ppaddr = PL_ppaddr[OP_GV]; } } @@ -4968,13 +5523,12 @@ Perl_ck_rvconst(pTHX_ register OP *o) OP * Perl_ck_ftst(pTHX_ OP *o) { - dTHR; I32 type = o->op_type; - if (o->op_flags & OPf_REF) - return o; - - if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { + if (o->op_flags & OPf_REF) { + /* nothing */ + } + else if (o->op_flags & OPf_KIDS && cUNOPo->op_first->op_type != OP_STUB) { SVOP *kid = (SVOP*)cUNOPo->op_first; if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { @@ -4982,24 +5536,30 @@ Perl_ck_ftst(pTHX_ OP *o) OP *newop = newGVOP(type, OPf_REF, gv_fetchpv(SvPVx(kid->op_sv, n_a), TRUE, SVt_PVIO)); op_free(o); - return newop; + o = newop; } } else { op_free(o); if (type == OP_FTTTY) - return newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE, + o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE, SVt_PVIO)); else - return newUNOP(type, 0, newDEFSVOP()); + o = newUNOP(type, 0, newDEFSVOP()); } +#ifdef USE_LOCALE + if (type == OP_FTTEXT || type == OP_FTBINARY) { + o->op_private = 0; + if (PL_hints & HINT_LOCALE) + o->op_private |= OPpLOCALE; + } +#endif return o; } OP * Perl_ck_fun(pTHX_ OP *o) { - dTHR; register OP *kid; OP **tokid; OP *sibl; @@ -5019,7 +5579,7 @@ Perl_ck_fun(pTHX_ OP *o) tokid = &cLISTOPo->op_first; kid = cLISTOPo->op_first; if (kid->op_type == OP_PUSHMARK || - kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK) + (kid->op_type == OP_NULL && kid->op_targ == OP_PUSHMARK)) { tokid = &kid->op_sibling; kid = kid->op_sibling; @@ -5055,8 +5615,8 @@ Perl_ck_fun(pTHX_ OP *o) 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_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, + if (ckWARN(WARN_DEPRECATED)) + Perl_warner(aTHX_ WARN_DEPRECATED, "Array @%s missing the @ in argument %"IVdf" of %s()", name, (IV)numargs, PL_op_desc[type]); op_free(kid); @@ -5075,8 +5635,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_SYNTAX)) - Perl_warner(aTHX_ WARN_SYNTAX, + if (ckWARN(WARN_DEPRECATED)) + Perl_warner(aTHX_ WARN_DEPRECATED, "Hash %%%s missing the %% in argument %"IVdf" of %s()", name, (IV)numargs, PL_op_desc[type]); op_free(kid); @@ -5117,26 +5677,53 @@ Perl_ck_fun(pTHX_ OP *o) else { I32 flags = OPf_SPECIAL; I32 priv = 0; + PADOFFSET targ = 0; + /* is this op a FH constructor? */ if (is_handle_constructor(o,numargs)) { - flags = 0; - /* Set a flag to tell rv2gv to vivify + char *name = Nullch; + STRLEN len; + + flags = 0; + /* Set a flag to tell rv2gv to vivify * need to "prove" flag does not mean something * else already - NI-S 1999/05/07 - */ - priv = OPpDEREF; -#if 0 - /* Helps with open($array[$n],...) - but is too simplistic - need to do selectively - */ - mod(kid,type); -#endif + */ + 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); + } + else if (kid->op_type == OP_RV2SV + && kUNOP->op_first->op_type == OP_GV) + { + GV *gv = cGVOPx_gv(kUNOP->op_first); + name = GvNAME(gv); + len = GvNAMELEN(gv); + } + else if (kid->op_type == OP_AELEM + || kid->op_type == OP_HELEM) + { + name = "__ANONIO__"; + len = 10; + mod(kid,type); + } + if (name) { + SV *namesv; + targ = pad_alloc(OP_RV2GV, SVs_PADTMP); + namesv = PL_curpad[targ]; + (void)SvUPGRADE(namesv, SVt_PV); + if (*name != '$') + sv_setpvn(namesv, "$", 1); + sv_catpvn(namesv, name, len); + } } kid->op_sibling = 0; kid = newUNOP(OP_RV2GV, flags, scalar(kid)); - if (priv) { - kid->op_private |= priv; - } + kid->op_targ = targ; + kid->op_private |= priv; } kid->op_sibling = sibl; *tokid = kid; @@ -5175,24 +5762,24 @@ Perl_ck_glob(pTHX_ OP *o) { GV *gv; + o = ck_fun(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))) gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); -#if defined(PERL_INTERNAL_GLOB) && !defined(MINIPERL_BUILD) +#if !defined(PERL_EXTERNAL_GLOB) /* XXX this can be tightened up and made more failsafe. */ if (!gv) { - OP *modname = newSVOP(OP_CONST, 0, newSVpvn("File::Glob", 10)); - modname->op_private |= OPpCONST_BARE; ENTER; - utilize(1, start_subparse(FALSE, 0), Nullop, modname, - newSVOP(OP_CONST, 0, newSVpvn("globally", 8))); + Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv, + /* null-terminated import list */ + newSVpvn(":globally", 9), Nullsv); gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); LEAVE; } -#endif /* PERL_INTERNAL_GLOB && !MINIPERL_BUILD */ +#endif /* PERL_EXTERNAL_GLOB */ if (gv && GvIMPORTED_CV(gv)) { append_elem(OP_GLOB, o, @@ -5213,7 +5800,7 @@ Perl_ck_glob(pTHX_ OP *o) gv_IOadd(gv); append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv)); scalarkids(o); - return ck_fun(o); + return o; } OP * @@ -5297,25 +5884,32 @@ Perl_ck_lfun(pTHX_ OP *o) OP * Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ { - dTHR; if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) { switch (cUNOPo->op_first->op_type) { case OP_RV2AV: - break; /* Globals via GV can be undef */ + /* This is needed for + if (defined %stash::) + to work. Do not break Tk. + */ + break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ Perl_warner(aTHX_ WARN_DEPRECATED, "defined(@array) is deprecated"); Perl_warner(aTHX_ WARN_DEPRECATED, - "(Maybe you should just omit the defined()?)\n"); + "\t(Maybe you should just omit the defined()?)\n"); break; case OP_RV2HV: - break; /* Globals via GV can be undef */ + /* This is needed for + if (defined %stash::) + to work. Do not break Tk. + */ + break; /* Globals via GV can be undef */ case OP_PADHV: Perl_warner(aTHX_ WARN_DEPRECATED, - "defined(%hash) is deprecated"); + "defined(%%hash) is deprecated"); Perl_warner(aTHX_ WARN_DEPRECATED, - "(Maybe you should just omit the defined()?)\n"); + "\t(Maybe you should just omit the defined()?)\n"); break; default: /* no warning */ @@ -5390,7 +5984,9 @@ Perl_ck_sassign(pTHX_ OP *o) OP *kid = cLISTOPo->op_first; /* has a disposable target? */ if ((PL_opargs[kid->op_type] & OA_TARGLEX) - && !(kid->op_flags & OPf_STACKED)) + && !(kid->op_flags & OPf_STACKED) + /* Cannot steal the second time! */ + && !(kid->op_private & OPpTARGET_MY)) { OP *kkid = kid->op_sibling; @@ -5398,32 +5994,8 @@ Perl_ck_sassign(pTHX_ OP *o) if (kkid && kkid->op_type == OP_PADSV && !(kkid->op_private & OPpLVAL_INTRO)) { - /* Concat has problems if target is equal to right arg. */ - if (kid->op_type == OP_CONCAT) { - if (kLISTOP->op_first->op_sibling->op_type == OP_PADSV - && kLISTOP->op_first->op_sibling->op_targ == kkid->op_targ) - return o; - } - else if (kid->op_type == OP_JOIN) { - /* do_join has problems if the arguments coincide with target. - In fact the second argument *can* safely coincide, - but ignore=pessimize this rare occasion. */ - OP *arg = kLISTOP->op_first->op_sibling; /* Skip PUSHMARK */ - - while (arg) { - if (arg->op_type == OP_PADSV - && arg->op_targ == kkid->op_targ) - return o; - arg = arg->op_sibling; - } - } - else if (kid->op_type == OP_QUOTEMETA) { - /* quotemeta has problems if the argument coincides with target. */ - if (kLISTOP->op_first->op_type == OP_PADSV - && kLISTOP->op_first->op_targ == kkid->op_targ) - return o; - } kid->op_targ = kkid->op_targ; + kkid->op_targ = 0; /* Now we do not need PADSV and SASSIGN. */ kid->op_sibling = o->op_sibling; /* NULL */ cLISTOPo->op_first = NULL; @@ -5463,11 +6035,13 @@ Perl_ck_method(pTHX_ OP *o) SV* sv = kSVOP->op_sv; if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) { OP *cmop; - sv_upgrade(sv, SVt_PVIV); - SvIOK_on(sv); - PERL_HASH(SvUVX(sv), SvPVX(sv), SvCUR(sv)); + if (!SvREADONLY(sv) || !SvFAKE(sv)) { + sv = newSVpvn_share(SvPVX(sv), SvCUR(sv), 0); + } + else { + kSVOP->op_sv = Nullsv; + } cmop = newSVOP(OP_METHOD_NAMED, 0, sv); - kSVOP->op_sv = Nullsv; op_free(o); return cmop; } @@ -5482,6 +6056,36 @@ Perl_ck_null(pTHX_ OP *o) } OP * +Perl_ck_open(pTHX_ OP *o) +{ + HV *table = GvHV(PL_hintgv); + if (table) { + SV **svp; + I32 mode; + svp = hv_fetch(table, "open_IN", 7, FALSE); + if (svp && *svp) { + mode = mode_from_discipline(*svp); + if (mode & O_BINARY) + o->op_private |= OPpOPEN_IN_RAW; + else if (mode & O_TEXT) + o->op_private |= OPpOPEN_IN_CRLF; + } + + svp = hv_fetch(table, "open_OUT", 8, FALSE); + if (svp && *svp) { + mode = mode_from_discipline(*svp); + if (mode & O_BINARY) + o->op_private |= OPpOPEN_OUT_RAW; + else if (mode & O_TEXT) + o->op_private |= OPpOPEN_OUT_CRLF; + } + } + if (o->op_type == OP_BACKTICK) + return o; + return ck_fun(o); +} + +OP * Perl_ck_repeat(pTHX_ OP *o) { if (cBINOPo->op_first->op_flags & OPf_PARENS) { @@ -5508,12 +6112,29 @@ Perl_ck_require(pTHX_ OP *o) --SvCUR(kid->op_sv); } } - sv_catpvn(kid->op_sv, ".pm", 3); + if (SvREADONLY(kid->op_sv)) { + SvREADONLY_off(kid->op_sv); + sv_catpvn(kid->op_sv, ".pm", 3); + SvREADONLY_on(kid->op_sv); + } + else + sv_catpvn(kid->op_sv, ".pm", 3); } } return ck_fun(o); } +OP * +Perl_ck_return(pTHX_ OP *o) +{ + OP *kid; + if (CvLVALUE(PL_compcv)) { + for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + mod(kid, OP_LEAVESUBLV); + } + return o; +} + #if 0 OP * Perl_ck_retarget(pTHX_ OP *o) @@ -5576,6 +6197,7 @@ Perl_ck_shift(pTHX_ OP *o) OP * Perl_ck_sort(pTHX_ OP *o) { + OP *firstkid; o->op_private = 0; #ifdef USE_LOCALE if (PL_hints & HINT_LOCALE) @@ -5584,10 +6206,10 @@ Perl_ck_sort(pTHX_ OP *o) if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) simplify_sort(o); - if (o->op_flags & OPf_STACKED) { /* may have been cleared */ - OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ + if (o->op_flags & OPf_STACKED) { /* may have been cleared */ OP *k; - kid = kUNOP->op_first; /* get past null */ + OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { linklist(kid); @@ -5603,6 +6225,12 @@ Perl_ck_sort(pTHX_ OP *o) for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { if (k->op_next == kid) k->op_next = 0; + /* don't descend into loops */ + else if (k->op_type == OP_ENTERLOOP + || k->op_type == OP_ENTERITER) + { + k = cLOOPx(k)->op_lastop; + } } } else @@ -5611,31 +6239,40 @@ Perl_ck_sort(pTHX_ OP *o) } peep(k); - kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ - if (o->op_type == OP_SORT) + kid = firstkid; + if (o->op_type == OP_SORT) { + /* provide scalar context for comparison function/block */ + kid = scalar(kid); kid->op_next = kid; + } else kid->op_next = k; o->op_flags |= OPf_SPECIAL; } else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) - null(cLISTOPo->op_first->op_sibling); + null(firstkid); + + firstkid = firstkid->op_sibling; } + /* provide list context for arguments */ + if (o->op_type == OP_SORT) + list(firstkid); + return o; } STATIC void S_simplify_sort(pTHX_ OP *o) { - dTHR; register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ OP *k; int reversed; + GV *gv; if (!(o->op_flags & OPf_STACKED)) return; - GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV)); - GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV)); + GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV)); + GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV)); kid = kUNOP->op_first; /* get past null */ if (kid->op_type != OP_SCOPE) return; @@ -5655,11 +6292,12 @@ S_simplify_sort(pTHX_ OP *o) if (kUNOP->op_first->op_type != OP_GV) return; kid = kUNOP->op_first; /* get past rv2sv */ - if (GvSTASH(kGVOP->op_gv) != PL_curstash) + gv = kGVOP_gv; + if (GvSTASH(gv) != PL_curstash) return; - if (strEQ(GvNAME(kGVOP->op_gv), "a")) + if (strEQ(GvNAME(gv), "a")) reversed = 0; - else if(strEQ(GvNAME(kGVOP->op_gv), "b")) + else if (strEQ(GvNAME(gv), "b")) reversed = 1; else return; @@ -5670,10 +6308,11 @@ S_simplify_sort(pTHX_ OP *o) if (kUNOP->op_first->op_type != OP_GV) return; kid = kUNOP->op_first; /* get past rv2sv */ - if (GvSTASH(kGVOP->op_gv) != PL_curstash + gv = kGVOP_gv; + if (GvSTASH(gv) != PL_curstash || ( reversed - ? strNE(GvNAME(kGVOP->op_gv), "a") - : strNE(GvNAME(kGVOP->op_gv), "b"))) + ? strNE(GvNAME(gv), "a") + : strNE(GvNAME(gv), "b"))) return; o->op_flags &= ~(OPf_STACKED | OPf_SPECIAL); if (reversed) @@ -5685,7 +6324,6 @@ S_simplify_sort(pTHX_ OP *o) kid = cLISTOPo->op_first->op_sibling; cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */ op_free(kid); /* then delete it */ - cLISTOPo->op_children--; } OP * @@ -5707,7 +6345,7 @@ Perl_ck_split(pTHX_ OP *o) cLISTOPo->op_last = kid; /* There was only one element previously */ } - if (kid->op_type != OP_MATCH) { + if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) { OP *sibl = kid->op_sibling; kid->op_sibling = 0; kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, Nullop); @@ -5740,7 +6378,7 @@ Perl_ck_split(pTHX_ OP *o) } OP * -Perl_ck_join(pTHX_ OP *o) +Perl_ck_join(pTHX_ OP *o) { if (ckWARN(WARN_SYNTAX)) { OP *kid = cLISTOPo->op_first->op_sibling; @@ -5759,7 +6397,6 @@ Perl_ck_join(pTHX_ OP *o) OP * Perl_ck_subr(pTHX_ OP *o) { - dTHR; OP *prev = ((cUNOPo->op_first->op_sibling) ? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first; OP *o2 = prev->op_sibling; @@ -5779,11 +6416,12 @@ Perl_ck_subr(pTHX_ OP *o) null(cvop); /* disable rv2cv */ tmpop = (SVOP*)((UNOP*)cvop)->op_first; if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) { - cv = GvCVu(tmpop->op_sv); + GV *gv = cGVOPx_gv(tmpop); + cv = GvCVu(gv); if (!cv) tmpop->op_private |= OPpEARLY_CV; else if (SvPOK(cv)) { - namegv = CvANON(cv) ? (GV*)tmpop->op_sv : CvGV(cv); + namegv = CvANON(cv) ? gv : CvGV(cv); proto = SvPV((SV*)cv, n_a); } } @@ -5823,7 +6461,9 @@ Perl_ck_subr(pTHX_ OP *o) proto++; arg++; if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF) - bad_type(arg, "block", gv_ename(namegv), o2); + bad_type(arg, + arg == 1 ? "block or sub {}" : "sub {}", + gv_ename(namegv), o2); break; case '*': /* '*' allows any scalar type, including bareword */ @@ -5846,7 +6486,7 @@ Perl_ck_subr(pTHX_ OP *o) (gvop = ((UNOP*)gvop)->op_first) && gvop->op_type == OP_GV) { - GV *gv = (GV*)((SVOP*)gvop)->op_sv; + GV *gv = cGVOPx_gv(gvop); OP *sibling = o2->op_sibling; SV *n = newSVpvn("",0); op_free(o2); @@ -5871,8 +6511,8 @@ Perl_ck_subr(pTHX_ OP *o) bad_type(arg, "symbol", gv_ename(namegv), o2); goto wrapref; case '&': - if (o2->op_type != OP_RV2CV) - bad_type(arg, "sub", gv_ename(namegv), o2); + if (o2->op_type != OP_ENTERSUB) + bad_type(arg, "subroutine entry", gv_ename(namegv), o2); goto wrapref; case '$': if (o2->op_type != OP_RV2SV @@ -5950,21 +6590,35 @@ Perl_ck_trunc(pTHX_ OP *o) return ck_fun(o); } +OP * +Perl_ck_substr(pTHX_ OP *o) +{ + o = ck_fun(o); + if ((o->op_flags & OPf_KIDS) && o->op_private == 4) { + OP *kid = cLISTOPo->op_first; + + if (kid->op_type == OP_NULL) + kid = kid->op_sibling; + if (kid) + kid->op_flags |= OPf_MOD; + + } + return o; +} + /* A peephole optimizer. We visit the ops in the order they're to execute. */ void Perl_peep(pTHX_ register OP *o) { - dTHR; register OP* oldop = 0; STRLEN n_a; - OP *last_composite = Nullop; if (!o || o->op_seq) return; ENTER; SAVEOP(); - SAVESPTR(PL_curcop); + SAVEVPTR(PL_curcop); for (; o; o = o->op_next) { if (o->op_seq) break; @@ -5977,38 +6631,47 @@ Perl_peep(pTHX_ register OP *o) case OP_DBSTATE: PL_curcop = ((COP*)o); /* for warnings */ o->op_seq = PL_op_seqmax++; - last_composite = Nullop; break; case OP_CONST: if (cSVOPo->op_private & OPpCONST_STRICT) no_bareword_allowed(o); - /* FALL THROUGH */ - case OP_UC: - case OP_UCFIRST: - case OP_LC: - case OP_LCFIRST: - if ( o->op_next && o->op_next->op_type == OP_STRINGIFY - && !(o->op_next->op_private & OPpTARGET_MY) ) - null(o->op_next); +#ifdef USE_ITHREADS + /* 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 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]); + SvREFCNT_dec(cSVOPo->op_sv); + } + else { + SvREFCNT_dec(PL_curpad[ix]); + SvPADTMP_on(cSVOPo->op_sv); + PL_curpad[ix] = cSVOPo->op_sv; + /* XXX I don't know how this isn't readonly already. */ + SvREADONLY_on(PL_curpad[ix]); + } + cSVOPo->op_sv = Nullsv; + o->op_targ = ix; + } +#endif o->op_seq = PL_op_seqmax++; break; + case OP_CONCAT: - case OP_JOIN: - case OP_QUOTEMETA: if (o->op_next && o->op_next->op_type == OP_STRINGIFY) { if (o->op_next->op_private & OPpTARGET_MY) { - if ((o->op_flags & OPf_STACKED) /* chained concats */ - || (o->op_type == OP_CONCAT - /* Concat has problems if target is equal to right arg. */ - && (((LISTOP*)o)->op_first->op_sibling->op_type - == OP_PADSV) - && (((LISTOP*)o)->op_first->op_sibling->op_targ - == o->op_next->op_targ))) { + if (o->op_flags & OPf_STACKED) /* chained concats */ goto ignore_optimization; - } else { + /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */ o->op_targ = o->op_next->op_targ; + o->op_next->op_targ = 0; o->op_private |= OPpTARGET_MY; } } @@ -6046,7 +6709,8 @@ Perl_peep(pTHX_ register OP *o) if (o->op_next->op_type == OP_RV2SV) { if (!(o->op_next->op_private & OPpDEREF)) { null(o->op_next); - o->op_private |= o->op_next->op_private & OPpLVAL_INTRO; + o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO + | OPpOUR_INTRO); o->op_next = o->op_next->op_next; o->op_type = OP_GVSV; o->op_ppaddr = PL_ppaddr[OP_GVSV]; @@ -6059,11 +6723,12 @@ Perl_peep(pTHX_ register OP *o) (PL_op = pop->op_next) && pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & - (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) && + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase) <= 255 && i >= 0) { + GV *gv; null(o->op_next); null(pop->op_next); null(pop); @@ -6072,16 +6737,17 @@ Perl_peep(pTHX_ register OP *o) o->op_type = OP_AELEMFAST; o->op_ppaddr = PL_ppaddr[OP_AELEMFAST]; o->op_private = (U8)i; - GvAVn(((GVOP*)o)->op_gv); + gv = cGVOPo_gv; + GvAVn(gv); } } - else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_UNSAFE)) { - GV *gv = cGVOPo->op_gv; + else if ((o->op_private & OPpEARLY_CV) && ckWARN(WARN_PROTOTYPE)) { + GV *gv = cGVOPo_gv; if (SvTYPE(gv) == SVt_PVGV && GvCV(gv) && SvPVX(GvCV(gv))) { /* XXX could check prototype here instead of just carping */ SV *sv = sv_newmortal(); gv_efullname3(sv, gv, Nullch); - Perl_warner(aTHX_ WARN_UNSAFE, + Perl_warner(aTHX_ WARN_PROTOTYPE, "%s() called too early to check prototype", SvPV_nolen(sv)); } @@ -6106,8 +6772,14 @@ Perl_peep(pTHX_ register OP *o) case OP_ENTERLOOP: o->op_seq = PL_op_seqmax++; + while (cLOOP->op_redoop->op_type == OP_NULL) + cLOOP->op_redoop = cLOOP->op_redoop->op_next; peep(cLOOP->op_redoop); + while (cLOOP->op_nextop->op_type == OP_NULL) + cLOOP->op_nextop = cLOOP->op_nextop->op_next; peep(cLOOP->op_nextop); + while (cLOOP->op_lastop->op_type == OP_NULL) + cLOOP->op_lastop = cLOOP->op_lastop->op_next; peep(cLOOP->op_lastop); break; @@ -6115,23 +6787,28 @@ Perl_peep(pTHX_ register OP *o) case OP_MATCH: case OP_SUBST: o->op_seq = PL_op_seqmax++; + while (cPMOP->op_pmreplstart && + cPMOP->op_pmreplstart->op_type == OP_NULL) + cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next; peep(cPMOP->op_pmreplstart); break; case OP_EXEC: o->op_seq = PL_op_seqmax++; - if (ckWARN(WARN_SYNTAX) && o->op_next + if (ckWARN(WARN_SYNTAX) && o->op_next && o->op_next->op_type == OP_NEXTSTATE) { if (o->op_next->op_sibling && o->op_next->op_sibling->op_type != OP_EXIT && o->op_next->op_sibling->op_type != OP_WARN && o->op_next->op_sibling->op_type != OP_DIE) { - line_t oldline = PL_curcop->cop_line; - - PL_curcop->cop_line = ((COP*)o->op_next)->cop_line; - Perl_warner(aTHX_ WARN_SYNTAX, "Statement unlikely to be reached"); - Perl_warner(aTHX_ WARN_SYNTAX, "(Maybe you meant system() when you said exec()?)\n"); - PL_curcop->cop_line = oldline; + line_t oldline = CopLINE(PL_curcop); + + CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next)); + Perl_warner(aTHX_ WARN_EXEC, + "Statement unlikely to be reached"); + Perl_warner(aTHX_ WARN_EXEC, + "\t(Maybe you meant system() when you said exec()?)\n"); + CopLINE_set(PL_curcop, oldline); } } break; @@ -6140,14 +6817,30 @@ Perl_peep(pTHX_ register OP *o) UNOP *rop; SV *lexname; GV **fields; - SV **svp, **indsvp; + SV **svp, **indsvp, *sv; I32 ind; - char *key; + char *key = NULL; STRLEN keylen; - if ((o->op_private & (OPpLVAL_INTRO)) - || ((BINOP*)o)->op_last->op_type != OP_CONST) + o->op_seq = PL_op_seqmax++; + + if (((BINOP*)o)->op_last->op_type != OP_CONST) break; + + /* Make the CONST have a shared SV */ + svp = cSVOPx_svp(((BINOP*)o)->op_last); + if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { + key = SvPV(sv, keylen); + if (SvUTF8(sv)) + keylen = -keylen; + lexname = newSVpvn_share(key, keylen, 0); + 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; @@ -6157,8 +6850,9 @@ Perl_peep(pTHX_ register OP *o) fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); if (!fields || !GvHV(*fields)) break; - svp = &((SVOP*)((BINOP*)o)->op_last)->op_sv; key = SvPV(*svp, keylen); + if (SvUTF8(*svp)) + keylen = -keylen; indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); if (!indsvp) { Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s", @@ -6171,46 +6865,80 @@ Perl_peep(pTHX_ register OP *o) 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 = newSViv(ind); + *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; - case OP_RV2AV: - case OP_RV2HV: - if (!(o->op_flags & OPf_WANT) - || (o->op_flags & OPf_WANT) == OPf_WANT_LIST) - { - last_composite = o; - } o->op_seq = PL_op_seqmax++; - break; - - case OP_RETURN: - if (o->op_next->op_type != OP_LEAVESUBLV) { - 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 (!SvOBJECT(lexname)) + 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); + if (SvUTF8(*svp)) + keylen = -keylen; + indsvp = hv_fetch(GvHV(*fields), key, 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; } - /* FALL THROUGH */ - - case OP_LEAVESUBLV: - if (last_composite) { - OP *r = last_composite; - - while (r->op_sibling) - r = r->op_sibling; - if (r->op_next == o - || (r->op_next->op_type == OP_LIST - && r->op_next->op_next == o)) - { - if (last_composite->op_type == OP_RV2AV) - yyerror("Lvalue subs returning arrays not implemented yet"); - else - yyerror("Lvalue subs returning hashes not implemented yet"); - ; - } - } - /* FALL THROUGH */ + break; + } default: o->op_seq = PL_op_seqmax++; @@ -6220,3 +6948,21 @@ Perl_peep(pTHX_ register OP *o) } LEAVE; } + +#include "XSUB.h" + +/* Efficient sub that returns a constant scalar value. */ +static void +const_sv_xsub(pTHXo_ CV* cv) +{ + dXSARGS; + if (items != 0) { +#if 0 + Perl_croak(aTHX_ "usage: %s::%s()", + HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); +#endif + } + EXTEND(sp, 1); + ST(0) = (SV*)XSANY.any_ptr; + XSRETURN(1); +}