X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=eba48b9207f1a5400103234d0dfbd4d783012915;hb=6e9d10810a2ec27ec94fd014e5dbab341c35afb1;hp=14c557314d9ec41701ba0ac72c016437aa59a32d;hpb=de4bf5b3f25740f501dafc07bf0bdefe01434583;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 14c5573..eba48b9 100644 --- a/op.c +++ b/op.c @@ -1,6 +1,6 @@ /* op.c * - * Copyright (c) 1991-2000, 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. @@ -20,9 +20,11 @@ #include "perl.h" #include "keywords.h" +#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) + /* #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 +34,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 +57,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) @@ -69,7 +72,7 @@ STATIC OP * S_no_fh_allowed(pTHX_ OP *o) { yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function", - PL_op_desc[o->op_type])); + OP_DESC(o))); return o; } @@ -91,7 +94,7 @@ STATIC void S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid) { yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)", - (int)n, name, t, PL_op_desc[kid->op_type])); + (int)n, name, t, OP_DESC(kid))); } STATIC void @@ -107,13 +110,12 @@ S_no_bareword_allowed(pTHX_ OP *o) 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) || + (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) || (name[1] == '_' && (int)strlen(name) > 2))) { if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { @@ -150,7 +152,7 @@ Perl_pad_allocmy(pTHX_ char *name) && strEQ(name, SvPVX(sv))) { Perl_warner(aTHX_ WARN_MISC, - "\"%s\" variable %s masks earlier declaration in same %s", + "\"%s\" variable %s masks earlier declaration in same %s", (PL_in_my == KEY_our ? "our" : "my"), name, (SvIVX(sv) == PAD_MAX ? "scope" : "statement")); @@ -183,10 +185,9 @@ Perl_pad_allocmy(pTHX_ char *name) if (*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); + SvFLAGS(sv) |= SVpad_TYPED; (void)SvUPGRADE(sv, SVt_PVMG); SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash); - PL_sv_objcount++; } if (PL_in_my == KEY_our) { (void)SvUPGRADE(sv, SVt_PVGV); @@ -223,11 +224,10 @@ S_pad_addlex(pTHX_ SV *proto_namesv) (void)SvUPGRADE(namesv, SVt_PVGV); GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv)); } - if (SvOBJECT(proto_namesv)) { /* A typed var */ - SvOBJECT_on(namesv); + if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */ + SvFLAGS(namesv) |= SVpad_TYPED; (void)SvUPGRADE(namesv, SVt_PVMG); SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv)); - PL_sv_objcount++; } return newoff; } @@ -238,7 +238,6 @@ 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; @@ -349,15 +348,24 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, switch (CxTYPE(cx)) { default: if (i == 0 && saweval) { - seq = cxstack[saweval].blk_oldcop->cop_seq; return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0); } break; case CXt_EVAL: switch (cx->blk_eval.old_op_type) { case OP_ENTEREVAL: - if (CxREALEVAL(cx)) + if (CxREALEVAL(cx)) { + PADOFFSET off; saweval = i; + seq = cxstack[i].blk_oldcop->cop_seq; + startcv = cxstack[i].blk_eval.cv; + if (startcv && CvOUTSIDE(startcv)) { + off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv), + i-1, saweval, 0); + if (off) /* continue looking if not found here */ + return off; + } + } break; case OP_DOFILE: case OP_REQUIRE: @@ -372,9 +380,9 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, cv = cx->blk_sub.cv; if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */ saweval = i; /* so we know where we were called from */ + seq = cxstack[i].blk_oldcop->cop_seq; continue; } - seq = cxstack[saweval].blk_oldcop->cop_seq; return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH); } } @@ -385,7 +393,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; @@ -394,7 +401,7 @@ Perl_pad_findmy(pTHX_ char *name) PERL_CONTEXT *cx; CV *outside; -#ifdef USE_THREADS +#ifdef USE_5005THREADS /* * Special case to get lexical (and hence per-thread) @_. * XXX I need to find out how to tell at parse-time whether use @@ -405,7 +412,7 @@ Perl_pad_findmy(pTHX_ char *name) */ if (strEQ(name, "@_")) return 0; /* success. (NOT_IN_PAD indicates failure) */ -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ /* The one we're looking for is probably just before comppad_name_fill. */ for (off = AvFILLp(PL_comppad_name); off > 0; off--) { @@ -448,7 +455,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; @@ -468,7 +474,6 @@ Perl_pad_leavemy(pTHX_ I32 fill) PADOFFSET Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) { - dTHR; SV *sv; I32 retval; @@ -495,14 +500,15 @@ 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)) && !IS_PADGV(sv)) + if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)) && + !IS_PADGV(sv) && !IS_PADCONST(sv)) break; } retval = PL_padix; } SvFLAGS(sv) |= tmptype; PL_curpad = AvARRAY(PL_comppad); -#ifdef USE_THREADS +#ifdef USE_5005THREADS DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n", PTR2UV(thr), PTR2UV(PL_curpad), @@ -512,15 +518,14 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) "Pad 0x%"UVxf" alloc %ld for %s\n", PTR2UV(PL_curpad), (long) retval, PL_op_name[optype])); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ return (PADOFFSET)retval; } SV * Perl_pad_sv(pTHX_ PADOFFSET po) { - dTHR; -#ifdef USE_THREADS +#ifdef USE_5005THREADS DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n", PTR2UV(thr), PTR2UV(PL_curpad), (IV)po)); @@ -529,28 +534,27 @@ Perl_pad_sv(pTHX_ PADOFFSET po) Perl_croak(aTHX_ "panic: pad_sv po"); DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n", PTR2UV(PL_curpad), (IV)po)); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ return PL_curpad[po]; /* eventually we'll turn this into a macro */ } void Perl_pad_free(pTHX_ PADOFFSET po) { - dTHR; if (!PL_curpad) return; if (AvARRAY(PL_comppad) != PL_curpad) Perl_croak(aTHX_ "panic: pad_free curpad"); if (!po) Perl_croak(aTHX_ "panic: pad_free po"); -#ifdef USE_THREADS +#ifdef USE_5005THREADS DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n", PTR2UV(thr), PTR2UV(PL_curpad), (IV)po)); #else DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n", PTR2UV(PL_curpad), (IV)po)); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) { SvPADTMP_off(PL_curpad[po]); #ifdef USE_ITHREADS @@ -564,19 +568,18 @@ 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 +#ifdef USE_5005THREADS DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n", PTR2UV(thr), PTR2UV(PL_curpad), (IV)po)); #else DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n", PTR2UV(PL_curpad), (IV)po)); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ SvPADTMP_off(PL_curpad[po]); PL_curpad[po] = NEWSV(1107,0); SvPADTMP_on(PL_curpad[po]); @@ -594,19 +597,18 @@ 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 +#ifdef USE_5005THREADS DEBUG_X(PerlIO_printf(Perl_debug_log, "0x%"UVxf" Pad 0x%"UVxf" reset\n", PTR2UV(thr), PTR2UV(PL_curpad))); #else DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n", PTR2UV(PL_curpad))); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */ for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) { if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po])) @@ -618,12 +620,11 @@ Perl_pad_reset(pTHX) PL_pad_reset_pending = FALSE; } -#ifdef USE_THREADS +#ifdef USE_5005THREADS /* find_threadsv is not reentrant */ PADOFFSET Perl_find_threadsv(pTHX_ const char *name) { - dTHR; char *p; PADOFFSET key; SV **svp; @@ -651,7 +652,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, PERL_MAGIC_sv, name, 1); break; case '&': case '`': @@ -675,7 +676,7 @@ Perl_find_threadsv(pTHX_ const char *name) /* case '!': */ default: - sv_magic(sv, 0, 0, name, 1); + sv_magic(sv, 0, PERL_MAGIC_sv, name, 1); } DEBUG_S(PerlIO_printf(Perl_error_log, "find_threadsv: new SV %p for $%s%c\n", @@ -684,7 +685,7 @@ Perl_find_threadsv(pTHX_ const char *name) } return key; } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ /* Destructor */ @@ -743,23 +744,24 @@ Perl_op_free(pTHX_ OP *o) #endif } -STATIC void -S_op_clear(pTHX_ OP *o) +void +Perl_op_clear(pTHX_ OP *o) { + switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ case OP_ENTEREVAL: /* Was holding hints. */ -#ifdef USE_THREADS +#ifdef USE_5005THREADS case OP_THREADSV: /* Was holding index into thr->threadsv AV. */ #endif o->op_targ = 0; break; -#ifdef USE_THREADS +#ifdef USE_5005THREADS case OP_ENTERITER: if (!(o->op_flags & OPf_SPECIAL)) break; /* FALL THROUGH */ -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ default: if (!(o->op_flags & OPf_REF) || (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst))) @@ -827,9 +829,46 @@ S_op_clear(pTHX_ OP *o) case OP_MATCH: case OP_QR: clear_pmop: + { + HV *pmstash = PmopSTASH(cPMOPo); + if (pmstash && SvREFCNT(pmstash)) { + PMOP *pmop = HvPMROOT(pmstash); + PMOP *lastpmop = NULL; + while (pmop) { + if (cPMOPo == pmop) { + if (lastpmop) + lastpmop->op_pmnext = pmop->op_pmnext; + else + HvPMROOT(pmstash) = pmop->op_pmnext; + break; + } + lastpmop = pmop; + pmop = pmop->op_pmnext; + } + } +#ifdef USE_ITHREADS + Safefree(PmopSTASHPV(cPMOPo)); +#else + /* NOTE: PMOP.op_pmstash is not refcounted */ +#endif + } cPMOPo->op_pmreplroot = Nullop; - ReREFCNT_dec(cPMOPo->op_pmregexp); - cPMOPo->op_pmregexp = (REGEXP*)NULL; + /* we use the "SAFE" version of the PM_ macros here + * since sv_clean_all might release some PMOPs + * after PL_regex_padav has been cleared + * and the clearing of PL_regex_padav needs to + * happen before sv_clean_all + */ + ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo)); + PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL); +#ifdef USE_ITHREADS + if(PL_regex_pad) { /* We could be in destruction */ + av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]); + SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]); + PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset); + } +#endif + break; } @@ -852,10 +891,12 @@ S_cop_free(pTHX_ COP* cop) #endif if (! specialWARN(cop->cop_warnings)) SvREFCNT_dec(cop->cop_warnings); + if (! specialCopIO(cop->cop_io)) + SvREFCNT_dec(cop->cop_io); } -STATIC void -S_null(pTHX_ OP *o) +void +Perl_op_null(pTHX_ OP *o) { if (o->op_type == OP_NULL) return; @@ -908,7 +949,6 @@ 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 = CopLINE(PL_curcop); @@ -937,8 +977,6 @@ Perl_scalar(pTHX_ OP *o) switch (o->op_type) { case OP_REPEAT: - if (o->op_private & OPpREPEAT_DOLIST) - null(((LISTOP*)cBINOPo->op_first)->op_first); scalar(cBINOPo->op_first); break; case OP_OR: @@ -1004,10 +1042,7 @@ 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; @@ -1022,7 +1057,7 @@ Perl_scalarvoid(pTHX_ OP *o) { return scalar(o); /* As if inside SASSIGN */ } - + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_VOID; switch (o->op_type) { @@ -1107,7 +1142,7 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_GETLOGIN: func_ops: if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO))) - useless = PL_op_desc[o->op_type]; + useless = OP_DESC(o); break; case OP_RV2GV: @@ -1124,12 +1159,20 @@ Perl_scalarvoid(pTHX_ OP *o) if (cSVOPo->op_private & OPpCONST_STRICT) no_bareword_allowed(o); else { - dTHR; if (ckWARN(WARN_VOID)) { useless = "a constant"; + /* the constants 0 and 1 are permitted as they are + conventionally used as dummies in constructs like + 1 while some_condition_with_side_effects; */ 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)) @@ -1137,7 +1180,7 @@ Perl_scalarvoid(pTHX_ OP *o) } } } - null(o); /* don't execute or even remember it */ + op_null(o); /* don't execute or even remember it */ break; case OP_POSTINC: @@ -1193,11 +1236,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; } @@ -1229,7 +1269,7 @@ Perl_list(pTHX_ OP *o) { return o; /* As if inside SASSIGN */ } - + o->op_flags = (o->op_flags & ~OPf_WANT) | OPf_WANT_LIST; switch (o->op_type) { @@ -1298,7 +1338,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); @@ -1329,7 +1368,6 @@ S_modkids(pTHX_ OP *o, I32 type) OP * Perl_mod(pTHX_ OP *o, I32 type) { - dTHR; OP *kid; STRLEN n_a; @@ -1341,7 +1379,7 @@ Perl_mod(pTHX_ OP *o, I32 type) { return o; } - + switch (o->op_type) { case OP_UNDEF: PL_modcount++; @@ -1372,11 +1410,12 @@ Perl_mod(pTHX_ OP *o, I32 type) o->op_type = OP_RV2CV; /* entersub => rv2cv */ o->op_ppaddr = PL_ppaddr[OP_RV2CV]; assert(cUNOPo->op_first->op_type == OP_NULL); - null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ + op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */ break; } else { /* lvalue subroutine call */ o->op_private |= OPpLVAL_INTRO; + PL_modcount = RETURN_UNLIMITED_NUMBER; if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) { /* Backward compatibility mode: */ o->op_private |= OPpENTERSUB_INARGS; @@ -1419,7 +1458,7 @@ Perl_mod(pTHX_ OP *o, I32 type) newop->op_private |= OPpLVAL_INTRO; break; } - + if (kid->op_type != OP_RV2CV) Perl_croak(aTHX_ "panic: unexpected lvalue entersub " @@ -1455,7 +1494,7 @@ Perl_mod(pTHX_ OP *o, I32 type) } cv = GvCV(kGVOP_gv); - if (!cv) + if (!cv) goto restore_2cv; if (CvLVALUE(cv)) break; @@ -1472,7 +1511,7 @@ Perl_mod(pTHX_ OP *o, I32 type) ? "do block" : (o->op_type == OP_ENTERSUB ? "non-lvalue subroutine call" - : PL_op_desc[o->op_type])), + : OP_DESC(o))), type ? PL_op_desc[type] : "local")); return o; @@ -1511,7 +1550,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 */ @@ -1520,14 +1559,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) @@ -1546,11 +1587,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++; @@ -1559,11 +1602,11 @@ Perl_mod(pTHX_ OP *o, I32 type) SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a)); break; -#ifdef USE_THREADS +#ifdef USE_5005THREADS case OP_THREADSV: PL_modcount++; /* XXX ??? */ break; -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ case OP_PUSHMARK: break; @@ -1578,6 +1621,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); @@ -1592,12 +1637,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; @@ -1616,8 +1664,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; @@ -1626,7 +1680,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; } @@ -1727,7 +1782,7 @@ Perl_ref(pTHX_ OP *o, I32 type) o->op_type = OP_RV2CV; /* entersub => rv2cv */ o->op_ppaddr = PL_ppaddr[OP_RV2CV]; assert(cUNOPo->op_first->op_type == OP_NULL); - null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ + op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */ o->op_flags |= OPf_SPECIAL; } break; @@ -1749,7 +1804,7 @@ Perl_ref(pTHX_ OP *o, I32 type) o->op_flags |= OPf_MOD; } break; - + case OP_THREADSV: o->op_flags |= OPf_MOD; /* XXX ??? */ break; @@ -1832,7 +1887,7 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) /* fake up C */ ENTER; /* need to protect against side-effects of 'use' */ SAVEINT(PL_expect); - if (stash && HvNAME(stash)) + if (stash) stashsv = newSVpv(HvNAME(stash), 0); else stashsv = &PL_sv_no; @@ -1900,6 +1955,16 @@ 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 && @@ -1908,7 +1973,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs) type != OP_PUSHMARK) { yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"", - PL_op_desc[o->op_type], + OP_DESC(o), PL_in_my == KEY_our ? "our" : "my")); return o; } @@ -1922,7 +1987,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs) /* check for C when deciding package */ namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE); - if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp))) + if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED)) stash = SvSTASH(*namesvp); else stash = PL_curstash; @@ -1964,7 +2029,6 @@ Perl_sawparens(pTHX_ OP *o) OP * Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) { - dTHR; OP *o; if (ckWARN(WARN_MISC) && @@ -1979,7 +2043,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) left->op_type == OP_PADAV) ? "@array" : "%hash"); Perl_warner(aTHX_ WARN_MISC, - "Applying %s to %s will act on scalar(%s)", + "Applying %s to %s will act on scalar(%s)", desc, sample, sample); } @@ -1988,7 +2052,15 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) right->op_type == OP_SUBST || 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)) || + /* if SV has magic, then match on original SV, not on its copy. + see note in pp_helem() */ + (right->op_type == OP_MATCH && + (left->op_type == OP_AELEM || + left->op_type == OP_HELEM || + left->op_type == OP_AELEMFAST))) left = mod(left, right->op_type); if (right->op_type == OP_TRANS) o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right); @@ -2028,7 +2100,7 @@ Perl_scope(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_SCOPE]; kid = ((LISTOP*)o)->op_first; if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) - null(kid); + op_null(kid); } else o = newLISTOP(OP_SCOPE, 0, o, Nullop); @@ -2049,7 +2121,6 @@ Perl_save_hints(pTHX) int Perl_block_start(pTHX_ int full) { - dTHR; int retval = PL_savestack_ix; SAVEI32(PL_comppad_name_floor); @@ -2067,20 +2138,27 @@ Perl_block_start(pTHX_ int full) PL_pad_reset_pending = FALSE; SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; - SAVESPTR(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); + line_t copline = PL_copline; + /* there should be a nextstate in every block */ + OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq); + PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */ LEAVE_SCOPE(floor); PL_pad_reset_pending = FALSE; PL_compiling.op_private = PL_hints; @@ -2094,19 +2172,18 @@ Perl_block_end(pTHX_ I32 floor, OP *seq) STATIC OP * S_newDEFSVOP(pTHX) { -#ifdef USE_THREADS +#ifdef USE_5005THREADS OP *o = newOP(OP_THREADSV, 0); o->op_targ = find_threadsv("_"); return o; #else return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ } void Perl_newPROG(pTHX_ OP *o) { - dTHR; if (PL_in_eval) { if (PL_eval_root) return; @@ -2117,7 +2194,7 @@ Perl_newPROG(pTHX_ OP *o) PL_eval_root->op_private |= OPpREFCOUNTED; OpREFCNT_set(PL_eval_root, 1); PL_eval_root->op_next = 0; - peep(PL_eval_start); + CALL_PEEP(PL_eval_start); } else { if (!o) @@ -2128,7 +2205,7 @@ Perl_newPROG(pTHX_ OP *o) PL_main_root->op_private |= OPpREFCOUNTED; OpREFCNT_set(PL_main_root, 1); PL_main_root->op_next = 0; - peep(PL_main_start); + CALL_PEEP(PL_main_start); PL_compcv = 0; /* Register with debugger */ @@ -2151,10 +2228,14 @@ 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++) ; + if (ckWARN(WARN_PARENTHESIS) + && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') + { + char *s = PL_bufptr; + + while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s))) + s++; + if (*s == ';' || *s == '=') Perl_warner(aTHX_ WARN_PARENTHESIS, "Parentheses missing around \"%s\" list", @@ -2175,12 +2256,12 @@ Perl_jmaybe(pTHX_ OP *o) { if (o->op_type == OP_LIST) { OP *o2; -#ifdef USE_THREADS +#ifdef USE_5005THREADS o2 = newOP(OP_THREADSV, 0); o2->op_targ = find_threadsv(";"); #else o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))), -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o)); } return o; @@ -2189,7 +2270,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; @@ -2226,8 +2306,8 @@ Perl_fold_constants(pTHX_ register OP *o) case OP_SLE: case OP_SGE: case OP_SCMP: - - if (o->op_private & OPpLOCALE) + /* XXX what about the numeric ops? */ + if (PL_hints & HINT_LOCALE) goto nope; } @@ -2265,13 +2345,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); } @@ -2307,7 +2385,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; @@ -2317,7 +2394,7 @@ Perl_gen_constant_list(pTHX_ register OP *o) PL_op = curop = LINKLIST(o); o->op_next = 0; - peep(curop); + CALL_PEEP(curop); pp_pushmark(); CALLRUNOPS(aTHX); PL_op = curop; @@ -2336,16 +2413,13 @@ 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 o->op_flags &= ~OPf_WANT; if (!(PL_opargs[type] & OA_MARK)) - null(cLISTOPo->op_first); + op_null(cLISTOPo->op_first); o->op_type = type; o->op_ppaddr = PL_ppaddr[type]; @@ -2355,13 +2429,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); } @@ -2389,7 +2456,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; } @@ -2410,13 +2476,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; } @@ -2434,6 +2498,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)) { @@ -2443,7 +2509,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; } @@ -2463,7 +2529,7 @@ Perl_force_list(pTHX_ OP *o) { if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, Nullop); - null(o); + op_null(o); return o; } @@ -2476,7 +2542,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) @@ -2496,8 +2563,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; } @@ -2575,15 +2640,16 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) } static int -utf8compare(const void *a, const void *b) -{ - int i; - for (i = 0; i < 10; i++) { - if ((*(U8**)a)[i] < (*(U8**)b)[i]) - return -1; - if ((*(U8**)a)[i] > (*(U8**)b)[i]) - return 1; - } +uvcompare(const void *a, const void *b) +{ + if (*((UV *)a) < (*(UV *)b)) + return -1; + if (*((UV *)a) > (*(UV *)b)) + return 1; + if (*((UV *)a+1) < (*(UV *)b+1)) + return -1; + if (*((UV *)a+1) > (*(UV *)b+1)) + return 1; return 0; } @@ -2594,23 +2660,25 @@ 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; + PL_hints |= HINT_BLOCK_SCOPE; 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)) + + if (SvUTF8(rstr)) o->op_private |= OPpTRANS_TO_UTF; if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { @@ -2618,7 +2686,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) SV* transv = 0; U8* tend = t + tlen; U8* rend = r + rlen; - I32 ulen; + STRLEN ulen; U32 tfirst = 1; U32 tlast = 0; I32 tdiff; @@ -2629,61 +2697,86 @@ 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; + U32 final = 0; I32 from_utf = o->op_private & OPpTRANS_FROM_UTF; I32 to_utf = o->op_private & OPpTRANS_TO_UTF; + U8* tsave = NULL; + U8* rsave = NULL; + + if (!from_utf) { + STRLEN len = tlen; + tsave = t = bytes_to_utf8(t, &len); + tend = t + len; + } + if (!to_utf && rlen) { + STRLEN len = rlen; + rsave = r = bytes_to_utf8(r, &len); + rend = r + len; + } + +/* There are several snags with this code on EBCDIC: + 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes). + 2. scan_const() in toke.c has encoded chars in native encoding which makes + ranges at least in EBCDIC 0..255 range the bottom odd. +*/ if (complement) { - U8 tmpbuf[UTF8_MAXLEN]; - U8** cp; + U8 tmpbuf[UTF8_MAXLEN+1]; + UV *cp; UV nextmin = 0; - New(1109, cp, tlen, U8*); + New(1109, cp, 2*tlen, UV); i = 0; transv = newSVpvn("",0); while (t < tend) { - cp[i++] = t; - t += UTF8SKIP(t); - if (*t == 0xff) { + cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0); + t += ulen; + if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { t++; - t += UTF8SKIP(t); + cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0); + t += ulen; } + else { + cp[2*i+1] = cp[2*i]; + } + i++; } - qsort(cp, i, sizeof(U8*), utf8compare); + qsort(cp, i, 2*sizeof(UV), uvcompare); for (j = 0; j < i; j++) { - U8 *s = cp[j]; - UV val = utf8_to_uv(s, &ulen); - s += ulen; + UV val = cp[2*j]; diff = val - nextmin; if (diff > 0) { - t = uv_to_utf8(tmpbuf,nextmin); + t = uvuni_to_utf8(tmpbuf,nextmin); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); if (diff > 1) { - t = uv_to_utf8(tmpbuf, val - 1); - sv_catpvn(transv, "\377", 1); + U8 range_mark = UTF_TO_NATIVE(0xff); + t = uvuni_to_utf8(tmpbuf, val - 1); + sv_catpvn(transv, (char *)&range_mark, 1); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); } } - if (*s == 0xff) - val = utf8_to_uv(s+1, &ulen); + val = cp[2*j+1]; if (val >= nextmin) nextmin = val + 1; } - t = uv_to_utf8(tmpbuf,nextmin); + t = uvuni_to_utf8(tmpbuf,nextmin); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); - t = uv_to_utf8(tmpbuf, 0x7fffffff); - sv_catpvn(transv, "\377", 1); + { + U8 range_mark = UTF_TO_NATIVE(0xff); + sv_catpvn(transv, (char *)&range_mark, 1); + } + t = uvuni_to_utf8(tmpbuf, 0x7fffffff); sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf); 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 (t == r || + if ((!rlen && !del) || t == r || (tlen == rlen && memEQ((char *)t, (char *)r, tlen))) { o->op_private |= OPpTRANS_IDENTICAL; @@ -2693,10 +2786,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) while (t < tend || tfirst <= tlast) { /* see if we need more "t" chars */ if (tfirst > tlast) { - tfirst = (I32)utf8_to_uv(t, &ulen); + tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); t += ulen; - if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */ - tlast = (I32)utf8_to_uv(++t, &ulen); + if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ + t++; + tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); t += ulen; } else @@ -2706,10 +2800,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)utf8n_to_uvuni(r, rend - r, &ulen, 0); r += ulen; - if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */ - rlast = (I32)utf8_to_uv(++r, &ulen); + if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ + r++; + rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); r += ulen; } else @@ -2750,21 +2845,10 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (rfirst + diff > max) max = rfirst + diff; + if (!grows) + grows = (tfirst < rfirst && + UNISKIP(tfirst) < UNISKIP(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); - } } tfirst += diff + 1; } @@ -2780,18 +2864,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) + if (!del && havefinal && rlen) (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; @@ -2812,10 +2902,27 @@ 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++]; + } } } + if (!del) { + if (!rlen) { + j = rlen; + if (!squash) + o->op_private |= OPpTRANS_IDENTICAL; + } + else if (j >= rlen) + j = rlen - 1; + else + cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short); + tbl[0x100] = rlen - j; + for (i=0; i < rlen - j; i++) + tbl[0x101+i] = r[j+i]; + } } else { if (!rlen && !del) { @@ -2834,10 +2941,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); @@ -2847,7 +2959,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); @@ -2862,10 +2973,28 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) pmop->op_pmpermflags |= PMf_LOCALE; pmop->op_pmflags = pmop->op_pmpermflags; - /* link into pm list */ +#ifdef USE_ITHREADS + { + SV* repointer; + if(av_len((AV*) PL_regex_pad[0]) > -1) { + repointer = av_pop((AV*)PL_regex_pad[0]); + pmop->op_pmoffset = SvIV(repointer); + SvREPADTMP_off(repointer); + sv_setiv(repointer,0); + } else { + repointer = newSViv(0); + av_push(PL_regex_padav,SvREFCNT_inc(repointer)); + pmop->op_pmoffset = av_len(PL_regex_padav); + PL_regex_pad = AvARRAY(PL_regex_padav); + } + } +#endif + + /* link into pm list */ if (type != OP_TRANS && PL_curstash) { pmop->op_pmnext = HvPMROOT(PL_curstash); HvPMROOT(PL_curstash) = pmop; + PmopSTASH_set(pmop,PL_curstash); } return (OP*)pmop; @@ -2874,7 +3003,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; @@ -2894,18 +3022,14 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) p = SvPV(pat, plen); pm->op_pmflags |= PMf_SKIPWHITE; } - if ((PL_hints & HINT_UTF8) || (SvUTF8(pat) && !(PL_hints & HINT_BYTE))) - pm->op_pmdynflags |= PMdf_UTF8; - pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm); - if (strEQ("\\s+", pm->op_pmregexp->precomp)) + PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm)); + if (strEQ("\\s+", PM_GETRE(pm)->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); @@ -2913,7 +3037,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; @@ -2940,21 +3064,21 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) if (CopLINE(PL_curcop) < PL_multi_end) CopLINE_set(PL_curcop, PL_multi_end); } -#ifdef USE_THREADS +#ifdef USE_5005THREADS else if (repl->op_type == OP_THREADSV && strchr("&`'123456789+", PL_threadsv_names[repl->op_targ])) { curop = 0; } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ else if (repl->op_type == OP_CONST) curop = repl; else { OP *lastop = 0; for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { if (PL_opargs[curop->op_type] & OA_DANGEROUS) { -#ifdef USE_THREADS +#ifdef USE_5005THREADS if (curop->op_type == OP_THREADSV) { repl_has_vars = 1; if (strchr("&`'123456789+", curop->op_private)) @@ -2967,7 +3091,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) if (strchr("&`'123456789+", *GvENAME(gv))) break; } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ else if (curop->op_type == OP_RV2CV) break; else if (curop->op_type == OP_RV2SV || @@ -2992,15 +3116,15 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl) } } if (curop == repl - && !(repl_has_vars - && (!pm->op_pmregexp - || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) { + && !(repl_has_vars + && (!PM_GETRE(pm) + || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) { pm->op_pmflags |= PMf_CONST; /* const for long enough */ pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ prepend_elem(o->op_type, scalar(repl), o); } else { - if (curop == repl && !pm->op_pmregexp) { /* Has variables. */ + if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */ pm->op_pmflags |= PMf_MAYBE_CONST; pm->op_pmpermflags |= PMf_MAYBE_CONST; } @@ -3065,7 +3189,6 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { - dTHR; #ifdef USE_ITHREADS GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc(gv)); @@ -3094,7 +3217,6 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) void Perl_package(pTHX_ OP *o) { - dTHR; SV *sv; save_hptr(&PL_curstash); @@ -3109,6 +3231,7 @@ Perl_package(pTHX_ OP *o) op_free(o); } else { + deprecate("\"package\" with no arguments"); sv_setpv(PL_curstname,""); PL_curstash = Nullhv; } @@ -3121,10 +3244,11 @@ void Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) { OP *pack; - OP *rqop; OP *imop; OP *veop; - GV *gv; + char *packname = Nullch; + STRLEN packlen = 0; + SV *packsv; if (id->op_type != OP_CONST) Perl_croak(aTHX_ "Module name must be constant"); @@ -3182,20 +3306,13 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) newSVOP(OP_METHOD_NAMED, 0, meth))); } - /* Fake up a require, handle override, if any */ - gv = gv_fetchpv("require", FALSE, SVt_PVCV); - if (!(gv && GvIMPORTED_CV(gv))) - gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV); - - if (gv && GvIMPORTED_CV(gv)) { - rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, - append_elem(OP_LIST, id, - scalar(newUNOP(OP_RV2CV, 0, - newGVOP(OP_GV, 0, - gv)))))); - } - else { - rqop = newUNOP(OP_REQUIRE, 0, id); + if (ckWARN(WARN_MISC) && + imop && (imop != arg) && /* no warning on use 5.0; or explicit () */ + SvPOK(packsv = ((SVOP*)id)->op_sv)) + { + /* BEGIN will free the ops, so we need to make a copy */ + packlen = SvCUR(packsv); + packname = savepvn(SvPVX(packsv), packlen); } /* Fake up the BEGIN {}, which does its thing immediately. */ @@ -3205,15 +3322,38 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) Nullop, append_elem(OP_LINESEQ, append_elem(OP_LINESEQ, - newSTATEOP(0, Nullch, rqop), + newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)), newSTATEOP(0, Nullch, veop)), newSTATEOP(0, Nullch, imop) )); + if (packname) { + if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) { + Perl_warner(aTHX_ WARN_MISC, + "Package `%s' not found " + "(did you use the incorrect case?)", packname); + } + safefree(packname); + } + PL_hints |= HINT_BLOCK_SCOPE; PL_copline = NOLINE; PL_expect = XSTATE; } +/* +=for apidoc load_module + +Loads the module whose name is pointed to by the string part of name. +Note that the actual module name, not its filename, should be given. +Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of +PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS +(or 0 for no flags). ver, if specified, provides version semantics +similar to C. The optional trailing SV* +arguments can be used to specify arguments to the module's import() +method, similar to C. + +=cut */ + void Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...) { @@ -3356,7 +3496,6 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) } if (list_assignment(left)) { - dTHR; OP *curop; PL_modcount = 0; @@ -3413,7 +3552,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; @@ -3458,7 +3601,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; @@ -3493,7 +3636,6 @@ 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; @@ -3507,7 +3649,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_BYTE); + cop->op_private = (PL_hints & HINT_PRIVATE_MASK); #ifdef NATIVE_HINTS cop->op_private |= NATIVE_HINTS; #endif @@ -3522,8 +3664,12 @@ 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) @@ -3582,7 +3728,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; @@ -3609,7 +3754,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) } if (first->op_type == OP_CONST) { if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) - Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional"); + Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional"); if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) { op_free(first); *firstp = Nullop; @@ -3636,7 +3781,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; } @@ -3694,7 +3839,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; @@ -3748,7 +3892,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; @@ -3795,7 +3938,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 && @@ -3812,12 +3954,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 @@ -3851,12 +3993,10 @@ 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 @@ -3867,12 +4007,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 @@ -3892,7 +4032,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * if (cont) { next = LINKLIST(cont); - loopflags |= OPpLOOP_CONTINUE; } if (expr) { OP *unstack = newOP(OP_UNSTACK, 0); @@ -3919,7 +4058,7 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * return Nullop; /* listop already freed by new_logop */ } if (listop) - ((LISTOP*)listop)->op_last->op_next = condop = + ((LISTOP*)listop)->op_last->op_next = (o == listop ? redo : LINKLIST(o)); } else @@ -3979,7 +4118,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); } else { -#ifdef USE_THREADS +#ifdef USE_5005THREADS padoff = find_threadsv("_"); iterflags |= OPf_SPECIAL; #else @@ -4015,7 +4154,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo op_free(expr); expr = (OP*)(listop); - null(expr); + op_null(expr); iterflags |= OPf_STACKED; } else { @@ -4035,7 +4174,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo } #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; @@ -4045,7 +4184,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; @@ -4072,39 +4210,59 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) void Perl_cv_undef(pTHX_ CV *cv) { - dTHR; -#ifdef USE_THREADS +#ifdef USE_5005THREADS if (CvMUTEXP(cv)) { MUTEX_DESTROY(CvMUTEXP(cv)); Safefree(CvMUTEXP(cv)); CvMUTEXP(cv) = 0; } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ + +#ifdef USE_ITHREADS + if (CvFILE(cv) && !CvXSUB(cv)) { + /* for XSUBs CvFILE point directly to static memory; __FILE__ */ + Safefree(CvFILE(cv)); + } + CvFILE(cv) = 0; +#endif if (!CvXSUB(cv) && CvROOT(cv)) { -#ifdef USE_THREADS +#ifdef USE_5005THREADS if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr)) Perl_croak(aTHX_ "Can't undef active subroutine"); #else if (CvDEPTH(cv)) Perl_croak(aTHX_ "Can't undef active subroutine"); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ ENTER; SAVEVPTR(PL_curpad); PL_curpad = 0; - if (!CvCLONED(cv)) - op_free(CvROOT(cv)); + op_free(CvROOT(cv)); CvROOT(cv) = Nullop; LEAVE; } SvPOK_off((SV*)cv); /* forget prototype */ - CvFLAGS(cv) = 0; - SvREFCNT_dec(CvGV(cv)); CvGV(cv) = Nullgv; - SvREFCNT_dec(CvOUTSIDE(cv)); + /* Since closure prototypes have the same lifetime as the containing + * CV, they don't hold a refcount on the outside CV. This avoids + * the refcount loop between the outer CV (which keeps a refcount to + * the closure prototype in the pad entry for pp_anoncode()) and the + * closure prototype, and the ensuing memory leak. This does not + * apply to closures generated within eval"", since eval"" CVs are + * ephemeral. --GSAR */ + if (!CvANON(cv) || CvCLONED(cv) + || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV + && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv)))) + { + SvREFCNT_dec(CvOUTSIDE(cv)); + } CvOUTSIDE(cv) = Nullcv; + if (CvCONST(cv)) { + SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); + CvCONST_off(cv); + } if (CvPADLIST(cv)) { /* may be during global destruction */ if (SvREFCNT(CvPADLIST(cv))) { @@ -4126,8 +4284,13 @@ Perl_cv_undef(pTHX_ CV *cv) } CvPADLIST(cv) = Nullav; } + if (CvXSUB(cv)) { + CvXSUB(cv) = 0; + } + CvFLAGS(cv) = 0; } +#ifdef DEBUG_CLOSURES STATIC void S_cv_dump(pTHX_ CV *cv) { @@ -4174,11 +4337,11 @@ S_cv_dump(pTHX_ CV *cv) } #endif /* DEBUGGING */ } +#endif /* DEBUG_CLOSURES */ STATIC CV * S_cv_clone2(pTHX_ CV *proto, CV *outside) { - dTHR; AV* av; I32 ix; AV* protopadlist = CvPADLIST(proto); @@ -4203,15 +4366,20 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside) CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE; CvCLONED_on(cv); -#ifdef USE_THREADS +#ifdef USE_5005THREADS New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); CvOWNER(cv) = 0; -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ +#ifdef USE_ITHREADS + CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto) + : savepv(CvFILE(proto)); +#else CvFILE(cv) = CvFILE(proto); - CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto)); +#endif + CvGV(cv) = CvGV(proto); CvSTASH(cv) = CvSTASH(proto); - CvROOT(cv) = CvROOT(proto); + CvROOT(cv) = OpREFCNT_inc(CvROOT(proto)); CvSTART(cv) = CvSTART(proto); if (outside) CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside); @@ -4305,6 +4473,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; } @@ -4321,8 +4498,6 @@ Perl_cv_clone(pTHX_ CV *proto) void Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) { - dTHR; - if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && ckWARN_d(WARN_PROTOTYPE)) { SV* msg = sv_newmortal(); SV* name = Nullsv; @@ -4343,12 +4518,25 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) } } +static void const_sv_xsub(pTHX_ 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 * @@ -4358,17 +4546,21 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv) 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) @@ -4378,7 +4570,17 @@ Perl_op_const_sv(pTHX_ OP *o, CV *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 @@ -4412,7 +4614,6 @@ 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; char *aname; @@ -4420,6 +4621,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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)) { @@ -4458,13 +4660,31 @@ 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 = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv); + +#ifdef GV_UNIQUE_CHECK + if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) { + Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", 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_UNIQUE_CHECK + if (exists && GvUNIQUE(gv)) { + Perl_croak(aTHX_ "Can't redefine unique 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 @@ -4473,8 +4693,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv_ckproto(cv, gv, ps); /* already defined (or promised)? */ if (exists || GvASSUMECV(gv)) { - SV* const_sv; - bool const_changed = TRUE; if (!block && !attrs) { /* just a "sub foo;" when &foo is already defined */ SAVEFREESV(PL_compcv); @@ -4483,24 +4701,43 @@ 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)) - { - line_t oldline = CopLINE(PL_curcop); - CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ WARN_REDEFINE, - const_sv ? "Constant subroutine %s redefined" - : "Subroutine %s redefined", name); - CopLINE_set(PL_curcop, 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); + if (PL_copline != NOLINE) + 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; @@ -4510,9 +4747,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) */ if (cv && !block) { rcv = (SV*)cv; - if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv)))) + if (CvGV(cv) && GvSTASH(CvGV(cv))) stash = GvSTASH(CvGV(cv)); - else if (CvSTASH(cv) && HvNAME(CvSTASH(cv))) + else if (CvSTASH(cv)) stash = CvSTASH(cv); else stash = PL_curstash; @@ -4520,7 +4757,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else { /* possibly about to re-define existing subr -- ignore old cv */ rcv = (SV*)PL_compcv; - if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv))) + if (name && GvSTASH(gv)) stash = GvSTASH(gv); else stash = PL_curstash; @@ -4539,9 +4776,33 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvOUTSIDE(PL_compcv) = 0; CvPADLIST(cv) = CvPADLIST(PL_compcv); CvPADLIST(PL_compcv) = 0; - if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */ - CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv); + /* inner references to PL_compcv must be fixed up ... */ + { + AV *padlist = CvPADLIST(cv); + AV *comppad_name = (AV*)AvARRAY(padlist)[0]; + AV *comppad = (AV*)AvARRAY(padlist)[1]; + SV **namepad = AvARRAY(comppad_name); + SV **curpad = AvARRAY(comppad); + for (ix = AvFILLp(comppad_name); ix > 0; ix--) { + SV *namesv = namepad[ix]; + if (namesv && namesv != &PL_sv_undef + && *SvPVX(namesv) == '&') + { + CV *innercv = (CV*)curpad[ix]; + if (CvOUTSIDE(innercv) == PL_compcv) { + CvOUTSIDE(innercv) = cv; + if (!CvANON(innercv) || CvCLONED(innercv)) { + (void)SvREFCNT_inc(cv); + SvREFCNT_dec(PL_compcv); + } + } + } + } + } + /* ... before we throw it away */ SvREFCNT_dec(PL_compcv); + if (PERLDB_INTER)/* Advice debugger on the new sub. */ + ++PL_sub_generation; } else { cv = PL_compcv; @@ -4551,16 +4812,16 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_sub_generation++; } } - CvGV(cv) = (GV*)SvREFCNT_inc(gv); - CvFILE(cv) = CopFILE(PL_curcop); + CvGV(cv) = gv; + CvFILE_set_from_cop(cv, PL_curcop); CvSTASH(cv) = PL_curstash; -#ifdef USE_THREADS +#ifdef USE_5005THREADS CvOWNER(cv) = 0; if (!CvMUTEXP(cv)) { New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ if (ps) sv_setpv((SV*)cv, ps); @@ -4584,18 +4845,15 @@ 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, scalarseq(block)); + CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, + mod(scalarseq(block), OP_LEAVESUBLV)); } else { CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); @@ -4604,7 +4862,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) OpREFCNT_set(CvROOT(cv), 1); CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; - peep(CvSTART(cv)); + CALL_PEEP(CvSTART(cv)); /* now that optimizer has done its work, adjust pad values */ if (CvCLONE(cv)) { @@ -4628,6 +4886,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 @_ */ @@ -4643,6 +4904,18 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } + /* If a potential closure prototype, don't keep a refcount on + * outer CV, unless the latter happens to be a passing eval"". + * This is okay as the lifetime of the prototype is tied to the + * lifetime of the outer CV. Avoids memory leak due to reference + * loop. --GSAR */ + if (!name && CvOUTSIDE(cv) + && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV + && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv)))) + { + SvREFCNT_dec(CvOUTSIDE(cv)); + } + if (name || aname) { char *s; char *tname = (name ? name : aname); @@ -4743,10 +5016,10 @@ eligible for inlining at compile-time. =cut */ -void +CV * Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) { - dTHR; + CV* cv; ENTER; @@ -4767,15 +5040,14 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv) #endif } - 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)) - ); + cv = newXS(name, const_sv_xsub, __FILE__); + CvXSUBANY(cv).any_ptr = sv; + CvCONST_on(cv); + sv_setpv((SV*)cv, ""); /* prototype is "" */ LEAVE; + + return cv; } /* @@ -4789,7 +5061,6 @@ Used by C to hook up XSUBs as Perl subs. 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; @@ -4802,12 +5073,14 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { /* already defined (or promised) */ if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv)) - && HvNAME(GvSTASH(CvGV(cv))) && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) { line_t oldline = CopLINE(PL_curcop); if (PL_copline != NOLINE) CopLINE_set(PL_curcop, PL_copline); - Perl_warner(aTHX_ WARN_REDEFINE, "Subroutine %s redefined",name); + Perl_warner(aTHX_ WARN_REDEFINE, + CvCONST(cv) ? "Constant subroutine %s redefined" + : "Subroutine %s redefined" + ,name); CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); @@ -4826,12 +5099,12 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) PL_sub_generation++; } } - CvGV(cv) = (GV*)SvREFCNT_inc(gv); -#ifdef USE_THREADS + CvGV(cv) = gv; +#ifdef USE_5005THREADS New(666, CvMUTEXP(cv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(cv)); CvOWNER(cv) = 0; -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ (void)gv_fetchfile(filename); CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be an external constant string */ @@ -4888,7 +5161,6 @@ done: void Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) { - dTHR; register CV *cv; char *name; GV *gv; @@ -4900,12 +5172,17 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) else name = "STDOUT"; gv = gv_fetchpv(name,TRUE, SVt_PVFM); +#ifdef GV_UNIQUE_CHECK + if (GvUNIQUE(gv)) { + Perl_croak(aTHX_ "Bad symbol for form (GV is unique)"); + } +#endif GvMULTI_on(gv); if ((cv = GvFORM(gv))) { if (ckWARN(WARN_REDEFINE)) { line_t oldline = CopLINE(PL_curcop); - - CopLINE_set(PL_curcop, PL_copline); + if (PL_copline != NOLINE) + CopLINE_set(PL_curcop, PL_copline); Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name); CopLINE_set(PL_curcop, oldline); } @@ -4913,8 +5190,8 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) } cv = PL_compcv; GvFORM(gv) = cv; - CvGV(cv) = (GV*)SvREFCNT_inc(gv); - CvFILE(cv) = CopFILE(PL_curcop); + CvGV(cv) = gv; + CvFILE_set_from_cop(cv, PL_curcop); for (ix = AvFILLp(PL_comppad); ix > 0; ix--) { if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix])) @@ -4926,7 +5203,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) OpREFCNT_set(CvROOT(cv), 1); CvSTART(cv) = LINKLIST(CvROOT(cv)); CvROOT(cv)->op_next = 0; - peep(CvSTART(cv)); + CALL_PEEP(CvSTART(cv)); op_free(o); PL_copline = NOLINE; LEAVE_SCOPE(floor); @@ -4986,8 +5263,6 @@ Perl_oopsAV(pTHX_ OP *o) OP * Perl_oopsHV(pTHX_ OP *o) { - dTHR; - switch (o->op_type) { case OP_PADSV: case OP_PADAV: @@ -5018,6 +5293,11 @@ Perl_newAVREF(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_PADAV]; return o; } + else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV) + && ckWARN(WARN_DEPRECATED)) { + Perl_warner(aTHX_ WARN_DEPRECATED, + "Using an array as a reference is deprecated"); + } return newUNOP(OP_RV2AV, 0, scalar(o)); } @@ -5037,6 +5317,11 @@ Perl_newHVREF(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_PADHV]; return o; } + else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV) + && ckWARN(WARN_DEPRECATED)) { + Perl_warner(aTHX_ WARN_DEPRECATED, + "Using a hash as a reference is deprecated"); + } return newUNOP(OP_RV2HV, 0, scalar(o)); } @@ -5152,9 +5437,9 @@ Perl_ck_delete(pTHX_ OP *o) break; default: Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", - PL_op_desc[o->op_type]); + OP_DESC(o)); } - null(kid); + op_null(kid); } return o; } @@ -5184,7 +5469,7 @@ Perl_ck_eval(pTHX_ OP *o) if (!kid) { o->op_flags &= ~OPf_KIDS; - null(o); + op_null(o); } else if (kid->op_type == OP_LINESEQ) { LOGOP *enter; @@ -5240,7 +5525,7 @@ Perl_ck_exec(pTHX_ OP *o) o = ck_fun(o); kid = cUNOPo->op_first->op_sibling; if (kid->op_type == OP_RV2GV) - null(kid); + op_null(kid); } else o = listkids(o); @@ -5257,15 +5542,15 @@ Perl_ck_exists(pTHX_ OP *o) (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]); + OP_DESC(o)); 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); + OP_DESC(o)); + op_null(kid); } return o; } @@ -5284,7 +5569,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); @@ -5347,7 +5631,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); } @@ -5385,6 +5669,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) #else kid->op_sv = SvREFCNT_inc(gv); #endif + kid->op_private = 0; kid->op_ppaddr = PL_ppaddr[OP_GV]; } } @@ -5394,7 +5679,6 @@ 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) { @@ -5419,20 +5703,12 @@ Perl_ck_ftst(pTHX_ OP *o) else 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; @@ -5482,6 +5758,12 @@ Perl_ck_fun(pTHX_ OP *o) list(kid); break; case OA_AVREF: + if ((type == OP_PUSH || type == OP_UNSHIFT) + && !kid->op_sibling && ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ WARN_SYNTAX, + "Useless use of %s with no values", + PL_op_desc[type]); + if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { @@ -5545,7 +5827,7 @@ Perl_ck_fun(pTHX_ OP *o) } else if (kid->op_type == OP_READLINE) { /* neophyte patrol: open(), close() etc. */ - bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid); + bad_type(numargs, "HANDLE", OP_DESC(o), kid); } else { I32 flags = OPf_SPECIAL; @@ -5613,7 +5895,7 @@ Perl_ck_fun(pTHX_ OP *o) } o->op_private |= numargs; if (kid) - return too_many_arguments(o,PL_op_desc[o->op_type]); + return too_many_arguments(o,OP_DESC(o)); listkids(o); } else if (PL_opargs[type] & OA_DEFGV) { @@ -5625,7 +5907,7 @@ Perl_ck_fun(pTHX_ OP *o) while (oa & OA_OPTIONAL) oa >>= 4; if (oa && oa != OA_LIST) - return too_few_arguments(o,PL_op_desc[o->op_type]); + return too_few_arguments(o,OP_DESC(o)); } return o; } @@ -5645,11 +5927,15 @@ Perl_ck_glob(pTHX_ OP *o) #if !defined(PERL_EXTERNAL_GLOB) /* XXX this can be tightened up and made more failsafe. */ if (!gv) { + GV *glob_gv; ENTER; - Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv, - /* null-terminated import list */ - newSVpvn(":globally", 9), Nullsv); + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv, + Nullsv, Nullsv); gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); + glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV); + GvCV(gv) = GvCV(glob_gv); + SvREFCNT_inc((SV*)GvCV(gv)); + GvIMPORTED_CV_on(gv); LEAVE; } #endif /* PERL_EXTERNAL_GLOB */ @@ -5720,7 +6006,7 @@ Perl_ck_grep(pTHX_ OP *o) kid = cLISTOPo->op_first->op_sibling; if (!kid || !kid->op_sibling) - return too_few_arguments(o,PL_op_desc[o->op_type]); + return too_few_arguments(o,OP_DESC(o)); for (kid = kid->op_sibling; kid; kid = kid->op_sibling) mod(kid, OP_GREPSTART); @@ -5757,11 +6043,14 @@ 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, @@ -5770,7 +6059,11 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ "\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"); @@ -5819,29 +6112,7 @@ Perl_ck_listiob(pTHX_ OP *o) if (!kid) append_elem(o->op_type, o, newDEFSVOP()); - o = listkids(o); - - o->op_private = 0; -#ifdef USE_LOCALE - if (PL_hints & HINT_LOCALE) - o->op_private |= OPpLOCALE; -#endif - - return o; -} - -OP * -Perl_ck_fun_locale(pTHX_ OP *o) -{ - o = ck_fun(o); - - o->op_private = 0; -#ifdef USE_LOCALE - if (PL_hints & HINT_LOCALE) - o->op_private |= OPpLOCALE; -#endif - - return o; + return listkids(o); } OP * @@ -5875,18 +6146,6 @@ Perl_ck_sassign(pTHX_ OP *o) } OP * -Perl_ck_scmp(pTHX_ OP *o) -{ - o->op_private = 0; -#ifdef USE_LOCALE - if (PL_hints & HINT_LOCALE) - o->op_private |= OPpLOCALE; -#endif - - return o; -} - -OP * Perl_ck_match(pTHX_ OP *o) { o->op_private |= OPpRUNTIME; @@ -5901,11 +6160,13 @@ Perl_ck_method(pTHX_ OP *o) SV* sv = kSVOP->op_sv; if (!(strchr(SvPVX(sv), ':') || strchr(SvPVX(sv), '\''))) { OP *cmop; - (void)SvUPGRADE(sv, SVt_PVIV); - (void)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; } @@ -5964,6 +6225,8 @@ Perl_ck_repeat(pTHX_ OP *o) OP * Perl_ck_require(pTHX_ OP *o) { + GV* gv; + if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */ SVOP *kid = (SVOP*)cUNOPo->op_first; @@ -5985,9 +6248,37 @@ Perl_ck_require(pTHX_ OP *o) sv_catpvn(kid->op_sv, ".pm", 3); } } + + /* handle override, if any */ + gv = gv_fetchpv("require", FALSE, SVt_PVCV); + if (!(gv && GvIMPORTED_CV(gv))) + gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV); + + if (gv && GvIMPORTED_CV(gv)) { + OP *kid = cUNOPo->op_first; + cUNOPo->op_first = 0; + op_free(o); + return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, kid, + scalar(newUNOP(OP_RV2CV, 0, + newGVOP(OP_GV, 0, + gv)))))); + } + 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) @@ -6027,7 +6318,7 @@ Perl_ck_shift(pTHX_ OP *o) OP *argop; op_free(o); -#ifdef USE_THREADS +#ifdef USE_5005THREADS if (!CvUNIQUE(PL_compcv)) { argop = newOP(OP_PADAV, OPf_REF); argop->op_targ = 0; /* PL_curpad[0] is @_ */ @@ -6041,7 +6332,7 @@ Perl_ck_shift(pTHX_ OP *o) argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ? PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV)))); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ return newUNOP(type, 0, scalar(argop)); } return scalar(modkids(ck_fun(o), type)); @@ -6051,17 +6342,12 @@ OP * Perl_ck_sort(pTHX_ OP *o) { OP *firstkid; - o->op_private = 0; -#ifdef USE_LOCALE - if (PL_hints & HINT_LOCALE) - o->op_private |= OPpLOCALE; -#endif if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED) simplify_sort(o); firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */ if (o->op_flags & OPf_STACKED) { /* may have been cleared */ - OP *k; + OP *k = NULL; OP *kid = cUNOPx(firstkid)->op_first; /* get past null */ if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) { @@ -6072,7 +6358,7 @@ Perl_ck_sort(pTHX_ OP *o) } else if (kid->op_type == OP_LEAVE) { if (o->op_type == OP_SORT) { - null(kid); /* wipe out leave */ + op_null(kid); /* wipe out leave */ kid->op_next = kid; for (k = kLISTOP->op_first->op_next; k; k = k->op_next) { @@ -6090,7 +6376,7 @@ Perl_ck_sort(pTHX_ OP *o) kid->op_next = 0; /* just disconnect the leave */ k = kLISTOP->op_first; } - peep(k); + CALL_PEEP(k); kid = firstkid; if (o->op_type == OP_SORT) { @@ -6103,7 +6389,7 @@ Perl_ck_sort(pTHX_ OP *o) o->op_flags |= OPf_SPECIAL; } else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV) - null(firstkid); + op_null(firstkid); firstkid = firstkid->op_sibling; } @@ -6118,15 +6404,14 @@ Perl_ck_sort(pTHX_ OP *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; @@ -6178,7 +6463,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 * @@ -6227,20 +6511,20 @@ Perl_ck_split(pTHX_ OP *o) scalar(kid); if (kid->op_sibling) - return too_many_arguments(o,PL_op_desc[o->op_type]); + return too_many_arguments(o,OP_DESC(o)); return 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; if (kid && kid->op_type == OP_MATCH) { char *pmstr = "STRING"; - if (kPMOP->op_pmregexp) - pmstr = kPMOP->op_pmregexp->precomp; + if (PM_GETRE(kPMOP)) + pmstr = PM_GETRE(kPMOP)->precomp; Perl_warner(aTHX_ WARN_SYNTAX, "/%s/ should probably be written as \"%s\"", pmstr, pmstr); @@ -6252,7 +6536,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; @@ -6262,6 +6545,8 @@ Perl_ck_subr(pTHX_ OP *o) GV *namegv = 0; int optional = 0; I32 arg = 0; + I32 contextclass = 0; + char *e = 0; STRLEN n_a; o->op_private |= OPpENTERSUB_HASTARG; @@ -6269,7 +6554,7 @@ Perl_ck_subr(pTHX_ OP *o) if (cvop->op_type == OP_RV2CV) { SVOP* tmpop; o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); - null(cvop); /* disable rv2cv */ + op_null(cvop); /* disable rv2cv */ tmpop = (SVOP*)((UNOP*)cvop)->op_first; if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) { GV *gv = cGVOPx_gv(tmpop); @@ -6358,36 +6643,67 @@ Perl_ck_subr(pTHX_ OP *o) } scalar(o2); break; + case '[': case ']': + goto oops; + break; case '\\': proto++; arg++; + again: switch (*proto++) { + case '[': + if (contextclass++ == 0) { + e = strchr(proto, ']'); + if (!e || e == proto) + goto oops; + } + else + goto oops; + goto again; + break; + case ']': + if (contextclass) + contextclass = 0; + else + goto oops; + break; case '*': - if (o2->op_type != OP_RV2GV) - bad_type(arg, "symbol", gv_ename(namegv), o2); - goto wrapref; + if (o2->op_type == OP_RV2GV) + goto wrapref; + if (!contextclass) + bad_type(arg, "symbol", gv_ename(namegv), o2); + break; case '&': - if (o2->op_type != OP_ENTERSUB) - bad_type(arg, "subroutine entry", gv_ename(namegv), o2); - goto wrapref; + if (o2->op_type == OP_ENTERSUB) + goto wrapref; + if (!contextclass) + bad_type(arg, "subroutine entry", gv_ename(namegv), o2); + break; case '$': - if (o2->op_type != OP_RV2SV - && o2->op_type != OP_PADSV - && o2->op_type != OP_HELEM - && o2->op_type != OP_AELEM - && o2->op_type != OP_THREADSV) - { + if (o2->op_type == OP_RV2SV || + o2->op_type == OP_PADSV || + o2->op_type == OP_HELEM || + o2->op_type == OP_AELEM || + o2->op_type == OP_THREADSV) + goto wrapref; + if (!contextclass) bad_type(arg, "scalar", gv_ename(namegv), o2); - } - goto wrapref; + break; case '@': - if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV) + if (o2->op_type == OP_RV2AV || + o2->op_type == OP_PADAV) + goto wrapref; + if (!contextclass) bad_type(arg, "array", gv_ename(namegv), o2); - goto wrapref; + break; case '%': - if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV) - bad_type(arg, "hash", gv_ename(namegv), o2); - wrapref: + if (o2->op_type == OP_RV2HV || + o2->op_type == OP_PADHV) + goto wrapref; + if (!contextclass) + bad_type(arg, "hash", gv_ename(namegv), o2); + break; + wrapref: { OP* kid = o2; OP* sib = kid->op_sibling; @@ -6396,9 +6712,15 @@ Perl_ck_subr(pTHX_ OP *o) o2->op_sibling = sib; prev->op_sibling = o2; } + if (contextclass && e) { + proto = e + 1; + contextclass = 0; + } break; default: goto oops; } + if (contextclass) + goto again; break; case ' ': proto++; @@ -6406,7 +6728,7 @@ Perl_ck_subr(pTHX_ OP *o) default: oops: Perl_croak(aTHX_ "Malformed prototype for %s: %s", - gv_ename(namegv), SvPV((SV*)cv, n_a)); + gv_ename(namegv), SvPV((SV*)cv, n_a)); } } else @@ -6446,15 +6768,29 @@ 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; @@ -6473,7 +6809,6 @@ 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: @@ -6487,7 +6822,7 @@ Perl_peep(pTHX_ register OP *o) 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 - * another pad, so make a copy. */ + * some pad, so make a copy. */ sv_setsv(PL_curpad[ix],cSVOPo->op_sv); SvREADONLY_on(PL_curpad[ix]); SvREFCNT_dec(cSVOPo->op_sv); @@ -6496,6 +6831,8 @@ Perl_peep(pTHX_ register OP *o) 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; @@ -6516,7 +6853,7 @@ Perl_peep(pTHX_ register OP *o) o->op_private |= OPpTARGET_MY; } } - null(o->op_next); + op_null(o->op_next); } ignore_optimization: o->op_seq = PL_op_seqmax++; @@ -6534,7 +6871,15 @@ Perl_peep(pTHX_ register OP *o) { PL_curcop = ((COP*)o); } - goto nothin; + /* XXX: We avoid setting op_seq here to prevent later calls + to peep() from mistakenly concluding that optimisation + has already occurred. This doesn't fix the real problem, + though (See 20010220.007). AMS 20010719 */ + if (oldop && o->op_next) { + oldop->op_next = o->op_next; + continue; + } + break; case OP_SCALAR: case OP_LINESEQ: case OP_SCOPE: @@ -6549,7 +6894,7 @@ Perl_peep(pTHX_ register OP *o) case OP_GV: if (o->op_next->op_type == OP_RV2SV) { if (!(o->op_next->op_private & OPpDEREF)) { - null(o->op_next); + op_null(o->op_next); o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO | OPpOUR_INTRO); o->op_next = o->op_next->op_next; @@ -6564,15 +6909,15 @@ 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)) && - (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase) + (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) && + (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase) <= 255 && i >= 0) { GV *gv; - null(o->op_next); - null(pop->op_next); - null(pop); + op_null(o->op_next); + op_null(pop->op_next); + op_null(pop); o->op_flags |= pop->op_next->op_flags & OPf_MOD; o->op_next = pop->op_next->op_next; o->op_type = OP_AELEMFAST; @@ -6593,6 +6938,15 @@ Perl_peep(pTHX_ register OP *o) SvPV_nolen(sv)); } } + else if (o->op_next->op_type == OP_READLINE + && o->op_next->op_next->op_type == OP_CONCAT + && (o->op_next->op_next->op_flags & OPf_STACKED)) + { + /* Turn "$a .= " into an OP_RCATLINE. AMS 20010811 */ + o->op_next->op_type = OP_RCATLINE; + o->op_next->op_flags |= OPf_STACKED; + op_null(o->op_next->op_next); + } o->op_seq = PL_op_seqmax++; break; @@ -6608,13 +6962,20 @@ Perl_peep(pTHX_ register OP *o) o->op_seq = PL_op_seqmax++; while (cLOGOP->op_other->op_type == OP_NULL) cLOGOP->op_other = cLOGOP->op_other->op_next; - peep(cLOGOP->op_other); + peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ break; case OP_ENTERLOOP: + case OP_ENTERITER: 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; @@ -6622,12 +6983,15 @@ 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 && @@ -6651,25 +7015,40 @@ Perl_peep(pTHX_ register OP *o) GV **fields; SV **svp, **indsvp, *sv; I32 ind; - char *key; + char *key = NULL; STRLEN keylen; o->op_seq = PL_op_seqmax++; - if ((o->op_private & (OPpLVAL_INTRO)) - || ((BINOP*)o)->op_last->op_type != OP_CONST) + + 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); + lexname = newSVpvn_share(key, + SvUTF8(sv) ? -(I32)keylen : 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; lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE); - if (!SvOBJECT(lexname)) + if (!(SvFLAGS(lexname) & SVpad_TYPED)) break; fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); if (!fields || !GvHV(*fields)) break; - svp = cSVOPx_svp(((BINOP*)o)->op_last); key = SvPV(*svp, keylen); - indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); + indsvp = hv_fetch(GvHV(*fields), key, + SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE); if (!indsvp) { Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s", key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname))); @@ -6711,7 +7090,7 @@ Perl_peep(pTHX_ register OP *o) 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)) + if (!(SvFLAGS(lexname) & SVpad_TYPED)) break; fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE); if (!fields || !GvHV(*fields)) @@ -6734,7 +7113,8 @@ Perl_peep(pTHX_ register OP *o) key_op = (SVOP*)key_op->op_sibling) { svp = cSVOPx_svp(key_op); key = SvPV(*svp, keylen); - indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE); + indsvp = hv_fetch(GvHV(*fields), key, + SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE); if (!indsvp) { Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" " "in variable %s of type %s", @@ -6754,42 +7134,6 @@ Perl_peep(pTHX_ register OP *o) break; } - 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 && o->op_next->op_type != OP_LEAVESUBLV) { - o->op_seq = PL_op_seqmax++; - break; - } - /* 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 */ - default: o->op_seq = PL_op_seqmax++; break; @@ -6798,3 +7142,60 @@ Perl_peep(pTHX_ register OP *o) } LEAVE; } + +#ifdef PERL_CUSTOM_OPS +char* custom_op_name(pTHX_ OP* o) +{ + IV index = PTR2IV(o->op_ppaddr); + SV* keysv; + HE* he; + + if (!PL_custom_op_names) /* This probably shouldn't happen */ + return PL_op_name[OP_CUSTOM]; + + keysv = sv_2mortal(newSViv(index)); + + he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0); + if (!he) + return PL_op_name[OP_CUSTOM]; /* Don't know who you are */ + + return SvPV_nolen(HeVAL(he)); +} + +char* custom_op_desc(pTHX_ OP* o) +{ + IV index = PTR2IV(o->op_ppaddr); + SV* keysv; + HE* he; + + if (!PL_custom_op_descs) + return PL_op_desc[OP_CUSTOM]; + + keysv = sv_2mortal(newSViv(index)); + + he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0); + if (!he) + return PL_op_desc[OP_CUSTOM]; + + return SvPV_nolen(HeVAL(he)); +} +#endif + +#include "XSUB.h" + +/* Efficient sub that returns a constant scalar value. */ +static void +const_sv_xsub(pTHX_ 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); +} +