X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=6343a035782580116a0a69a38ef85d868a095dc0;hb=84d4ea48280f6b54fdc70fe4c8b9494e3331071e;hp=b9b7869240ebfc2539e5ccc5bda7af50c83a5e86;hpb=89de29047dd63c42d0e0d6b1cab1eea82aeda08d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index b9b7869..6343a03 100644 --- a/op.c +++ b/op.c @@ -24,10 +24,10 @@ /* #define PL_OP_SLAB_ALLOC */ -#ifdef PL_OP_SLAB_ALLOC +#if defined(PL_OP_SLAB_ALLOC) && !defined(PERL_IMPLICIT_CONTEXT) #define SLAB_SIZE 8192 -static char *PL_OpPtr = NULL; -static int PL_OpSpace = 0; +static char *PL_OpPtr = NULL; /* XXX threadead */ +static int PL_OpSpace = 0; /* XXX threadead */ #define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \ var = (type *)(PL_OpPtr -= c*sizeof(type)); \ else \ @@ -72,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; } @@ -94,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 @@ -115,7 +115,7 @@ Perl_pad_allocmy(pTHX_ char *name) if (!(PL_in_my == KEY_our || isALPHA(name[1]) || - (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) || + (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])) { @@ -401,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 @@ -412,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--) { @@ -508,7 +508,7 @@ Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype) } 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), @@ -518,14 +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) { -#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)); @@ -534,7 +534,7 @@ 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 */ } @@ -547,14 +547,14 @@ Perl_pad_free(pTHX_ PADOFFSET po) 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 @@ -572,14 +572,14 @@ Perl_pad_swipe(pTHX_ PADOFFSET po) 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]); @@ -601,14 +601,14 @@ Perl_pad_reset(pTHX) 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])) @@ -620,7 +620,7 @@ 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) @@ -685,7 +685,7 @@ Perl_find_threadsv(pTHX_ const char *name) } return key; } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ /* Destructor */ @@ -747,20 +747,21 @@ Perl_op_free(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))) @@ -812,10 +813,10 @@ Perl_op_clear(pTHX_ OP *o) goto clear_pmop; case OP_PUSHRE: #ifdef USE_ITHREADS - if ((PADOFFSET)cPMOPo->op_pmreplroot) { + if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) { if (PL_curpad) { - GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot]; - pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot); + GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)]; + pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)); /* No GvIN_PAD_off(gv) here, because other references may still * exist on the pad */ SvREFCNT_dec(gv); @@ -860,6 +861,14 @@ clear_pmop: */ 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; } @@ -1015,6 +1024,9 @@ Perl_scalar(pTHX_ OP *o) } WITH_THR(PL_curcop = &PL_compiling); break; + case OP_SORT: + if (ckWARN(WARN_VOID)) + Perl_warner(aTHX_ WARN_VOID, "Useless use of sort in scalar context"); } return o; } @@ -1133,7 +1145,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: @@ -1422,8 +1434,8 @@ Perl_mod(pTHX_ OP *o, I32 type) if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST) Perl_croak(aTHX_ "panic: unexpected lvalue entersub " - "args: type/targ %ld:%ld", - (long)kid->op_type,kid->op_targ); + "args: type/targ %ld:%"UVuf, + (long)kid->op_type, (UV)kid->op_targ); kid = kLISTOP->op_first; skip_kids: while (kid->op_sibling) @@ -1453,8 +1465,8 @@ Perl_mod(pTHX_ OP *o, I32 type) if (kid->op_type != OP_RV2CV) Perl_croak(aTHX_ "panic: unexpected lvalue entersub " - "entry via type/targ %ld:%ld", - (long)kid->op_type,kid->op_targ); + "entry via type/targ %ld:%"UVuf, + (long)kid->op_type, (UV)kid->op_targ); kid->op_private |= OPpLVAL_INTRO; break; /* Postpone until runtime */ } @@ -1466,8 +1478,8 @@ Perl_mod(pTHX_ OP *o, I32 type) if (kid->op_type == OP_NULL) Perl_croak(aTHX_ "Unexpected constant lvalue entersub " - "entry via type/targ %ld:%ld", - (long)kid->op_type,kid->op_targ); + "entry via type/targ %ld:%"UVuf, + (long)kid->op_type, (UV)kid->op_targ); if (kid->op_type != OP_GV) { /* Restore RV2CV to check lvalueness */ restore_2cv: @@ -1502,7 +1514,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; @@ -1593,11 +1605,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; @@ -1661,6 +1673,14 @@ Perl_mod(pTHX_ OP *o, I32 type) goto nomod; break; /* mod()ing was handled by ck_return() */ } + + /* [20011101.069] File test operators interpret OPf_REF to mean that + their argument is a filehandle; thus \stat(".") should not set + it. AMS 20011102 */ + if (type == OP_REFGEN && + PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst)) + return o; + if (type != OP_LEAVESUBLV) o->op_flags |= OPf_MOD; @@ -1964,7 +1984,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; } @@ -2146,7 +2166,10 @@ OP* Perl_block_end(pTHX_ I32 floor, OP *seq) { 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; @@ -2160,13 +2183,13 @@ 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 @@ -2244,12 +2267,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; @@ -2962,12 +2985,20 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) pmop->op_pmflags = pmop->op_pmpermflags; #ifdef USE_ITHREADS - { - SV* 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); + { + 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 */ @@ -3002,16 +3033,12 @@ 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_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) ? OP_REGCRESET @@ -3048,21 +3075,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)) @@ -3075,7 +3102,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 || @@ -3281,7 +3308,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) /* Fake up a method call to import/unimport */ meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);; - sv_upgrade(meth, SVt_PVIV); + (void)SvUPGRADE(meth, SVt_PVIV); (void)SvIOK_on(meth); PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL, @@ -3537,7 +3564,7 @@ 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]; + GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)]; #else GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot; #endif @@ -3567,7 +3594,7 @@ 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) { #ifdef USE_ITHREADS - pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix; + pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix); cPADOPx(tmpop)->op_padix = 0; /* steal it */ #else pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv; @@ -3671,10 +3698,10 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) if (PERLDB_LINE && PL_curstash != PL_debstash) { SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE); - if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) { - (void)SvIOK_on(*svp); + if (svp && *svp != &PL_sv_undef ) { + (void)SvIOK_on(*svp); SvIVX(*svp) = PTR2IV(cop); - } + } } return prepend_elem(OP_LINESEQ, (OP*)cop, o); @@ -4102,7 +4129,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 @@ -4194,13 +4221,13 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) void Perl_cv_undef(pTHX_ CV *cv) { -#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)) { @@ -4211,13 +4238,13 @@ Perl_cv_undef(pTHX_ CV *cv) #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); @@ -4233,15 +4260,9 @@ Perl_cv_undef(pTHX_ CV *cv) * 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)))) - { + * closure prototype, and the ensuing memory leak. --GSAR */ + if (!CvANON(cv) || CvCLONED(cv)) SvREFCNT_dec(CvOUTSIDE(cv)); - } CvOUTSIDE(cv) = Nullcv; if (CvCONST(cv)) { SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); @@ -4350,11 +4371,11 @@ 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)); @@ -4502,7 +4523,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) } } -static void const_sv_xsub(pTHXo_ CV* cv); +static void const_sv_xsub(pTHX_ CV* cv); /* =for apidoc cv_const_sv @@ -4691,7 +4712,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) && (!const_sv || sv_cmp(cv_const_sv(cv), const_sv)))) { 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, CvCONST(cv) ? "Constant subroutine %s redefined" : "Subroutine %s redefined", name); @@ -4798,13 +4820,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvGV(cv) = gv; CvFILE_set_from_cop(cv, PL_curcop); CvSTASH(cv) = PL_curstash; -#ifdef USE_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); @@ -4887,17 +4909,12 @@ 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"". + /* If a potential closure prototype, don't keep a refcount on outer CV. * This is okay as the lifetime of the prototype is tied to the * lifetime of the outer CV. Avoids memory leak due to reference * loop. --GSAR */ - if (!name && CvOUTSIDE(cv) - && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV - && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv)))) - { + if (!name) SvREFCNT_dec(CvOUTSIDE(cv)); - } if (name || aname) { char *s; @@ -4940,8 +4957,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) ENTER; SAVECOPFILE(&PL_compiling); SAVECOPLINE(&PL_compiling); - save_svref(&PL_rs); - sv_setsv(PL_rs, PL_nrs); if (!PL_beginav) PL_beginav = newAV(); @@ -5083,11 +5098,11 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) } } CvGV(cv) = gv; -#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 */ (void)gv_fetchfile(filename); CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be an external constant string */ @@ -5164,8 +5179,8 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) 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); } @@ -5420,7 +5435,7 @@ 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)); } op_null(kid); } @@ -5428,6 +5443,15 @@ Perl_ck_delete(pTHX_ OP *o) } OP * +Perl_ck_die(pTHX_ OP *o) +{ +#ifdef VMS + if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; +#endif + return ck_fun(o); +} + +OP * Perl_ck_eof(pTHX_ OP *o) { I32 type = o->op_type; @@ -5496,6 +5520,7 @@ Perl_ck_exit(pTHX_ OP *o) if (svp && *svp && SvTRUE(*svp)) o->op_private |= OPpEXIT_VMSISH; } + if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; #endif return ck_fun(o); } @@ -5525,14 +5550,14 @@ 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]); + OP_DESC(o)); op_null(kid); } return o; @@ -5810,7 +5835,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; @@ -5878,7 +5903,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) { @@ -5890,7 +5915,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; } @@ -5989,7 +6014,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); @@ -6301,7 +6326,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 @_ */ @@ -6315,7 +6340,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)); @@ -6494,7 +6519,7 @@ 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; } @@ -6528,6 +6553,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; @@ -6624,36 +6651,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; @@ -6662,9 +6720,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++; @@ -6672,7 +6736,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 @@ -6886,10 +6950,12 @@ Perl_peep(pTHX_ register OP *o) && 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; + /* Turn "$a .= " into an OP_RCATLINE. AMS 20010917 */ + o->op_type = OP_RCATLINE; + o->op_flags |= OPf_STACKED; + o->op_ppaddr = PL_ppaddr[OP_RCATLINE]; op_null(o->op_next->op_next); + op_null(o->op_next); } o->op_seq = PL_op_seqmax++; @@ -7087,11 +7153,50 @@ Perl_peep(pTHX_ register OP *o) LEAVE; } + + +char* Perl_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* Perl_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)); +} + + #include "XSUB.h" /* Efficient sub that returns a constant scalar value. */ static void -const_sv_xsub(pTHXo_ CV* cv) +const_sv_xsub(pTHX_ CV* cv) { dXSARGS; if (items != 0) {