X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=2230aaf2434e8b188100b4469d6254ffda83b49d;hb=238a4c30b3724d314933955c5c4a0162eae05ee0;hp=e40d3343ffceb1f09fce38f2ebcceb0c9f9f015d;hpb=7ea3cd407b6ec2a3e424bdfbc486b6e01d6d28bd;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index e40d334..2230aaf 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. @@ -15,33 +15,74 @@ * either way, as the saying is, if you follow me." --the Gaffer */ + #include "EXTERN.h" #define PERL_IN_OP_C #include "perl.h" #include "keywords.h" -/* #define PL_OP_SLAB_ALLOC */ +#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) -#ifdef PL_OP_SLAB_ALLOC -#define SLAB_SIZE 8192 -static char *PL_OpPtr = NULL; -static int PL_OpSpace = 0; -#define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \ - var = (type *)(PL_OpPtr -= c*sizeof(type)); \ - else \ - var = (type *) Slab_Alloc(m,c*sizeof(type)); \ - } while (0) +#if defined(PL_OP_SLAB_ALLOC) + +#ifndef PERL_SLAB_SIZE +#define PERL_SLAB_SIZE 2048 +#endif + +#define NewOp(m,var,c,type) \ + STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END + +#define FreeOp(p) Slab_Free(p) STATIC void * S_Slab_Alloc(pTHX_ int m, size_t sz) { - Newz(m,PL_OpPtr,SLAB_SIZE,char); - PL_OpSpace = SLAB_SIZE - sz; - return PL_OpPtr += PL_OpSpace; + /* Add an overhead for pointer to slab and round up as a number of IVs */ + sz = (sz + 2*sizeof(IV) -1)/sizeof(IV); + if ((PL_OpSpace -= sz) < 0) { + PL_OpSlab = (IV *) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(IV)); + if (!PL_OpSlab) { + return NULL; + } + Zero(PL_OpSlab,PERL_SLAB_SIZE,IV); + /* We reserve the 0'th word as a use count */ + PL_OpSpace = PERL_SLAB_SIZE - 1 - sz; + /* Allocation pointer starts at the top. + Theory: because we build leaves before trunk allocating at end + means that at run time access is cache friendly upward + */ + PL_OpPtr = (IV **) &PL_OpSlab[PERL_SLAB_SIZE]; + } + assert( PL_OpSpace >= 0 ); + /* Move the allocation pointer down */ + PL_OpPtr -= sz; + assert( PL_OpPtr > (IV **) PL_OpSlab ); + *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */ + (*PL_OpSlab)++; /* Increment use count of slab */ + assert( (IV *) (PL_OpPtr+sz) <= (PL_OpSlab + PERL_SLAB_SIZE) ); + assert( *PL_OpSlab > 0 ); + return (void *)(PL_OpPtr + 1); +} + +STATIC void +S_Slab_Free(pTHX_ void *op) +{ + IV **ptr = (IV **) op; + IV *slab = ptr[-1]; + assert( ptr-1 > (IV **) slab ); + assert( (IV *) ptr < (slab + PERL_SLAB_SIZE) ); + assert( *slab > 0 ); + if (--(*slab) == 0) { + PerlMemShared_free(slab); + if (slab == PL_OpSlab) { + PL_OpSpace = 0; + } + } } #else #define NewOp(m, var, c, type) Newz(m, var, c, type) +#define FreeOp(p) SafeFree(p) #endif /* * In the following definition, the ", Nullop" is just to make the compiler @@ -55,6 +96,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 +111,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 +133,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 @@ -112,7 +154,7 @@ Perl_pad_allocmy(pTHX_ char *name) 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])) { @@ -182,10 +224,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); @@ -222,11 +263,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; } @@ -347,15 +387,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: @@ -370,9 +419,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); } } @@ -391,7 +440,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 @@ -402,7 +451,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--) { @@ -498,7 +547,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), @@ -508,14 +557,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)); @@ -524,7 +573,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 */ } @@ -537,14 +586,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 @@ -562,14 +611,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]); @@ -591,14 +640,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])) @@ -610,7 +659,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) @@ -642,7 +691,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 '`': @@ -666,7 +715,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", @@ -675,7 +724,7 @@ Perl_find_threadsv(pTHX_ const char *name) } return key; } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ /* Destructor */ @@ -724,33 +773,27 @@ Perl_op_free(pTHX_ OP *o) cop_free((COP*)o); op_clear(o); - -#ifdef PL_OP_SLAB_ALLOC - if ((char *) o == PL_OpPtr) - { - } -#else - Safefree(o); -#endif + FreeOp(o); } -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))) @@ -802,10 +845,10 @@ S_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); @@ -818,9 +861,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; } @@ -847,8 +927,8 @@ S_cop_free(pTHX_ COP* cop) 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; @@ -929,8 +1009,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: @@ -978,6 +1056,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; } @@ -1096,7 +1177,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: @@ -1115,6 +1196,9 @@ Perl_scalarvoid(pTHX_ OP *o) else { 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)) { @@ -1131,7 +1215,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: @@ -1361,11 +1445,14 @@ 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 if (o->op_private & OPpENTERSUB_NOMOD) + return o; 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; @@ -1381,8 +1468,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) @@ -1393,11 +1480,6 @@ Perl_mod(pTHX_ OP *o, I32 type) || kid->op_type == OP_METHOD) { UNOP *newop; - - if (kid->op_sibling || kid->op_next != kid) { - yyerror("panic: unexpected optree near method call"); - break; - } NewOp(1101, newop, 1, UNOP); newop->op_type = OP_RV2CV; @@ -1412,8 +1494,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 */ } @@ -1425,8 +1507,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: @@ -1461,7 +1543,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; @@ -1500,7 +1582,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 */ @@ -1509,14 +1591,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) @@ -1535,11 +1619,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++; @@ -1548,11 +1634,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; @@ -1567,6 +1653,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); @@ -1581,12 +1669,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; @@ -1605,8 +1696,22 @@ 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; + + /* [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; if (type == OP_AASSIGN || type == OP_SASSIGN) o->op_flags |= OPf_SPECIAL|OPf_REF; @@ -1615,7 +1720,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; } @@ -1716,7 +1822,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; @@ -1814,32 +1920,112 @@ S_dup_attrlist(pTHX_ OP *o) } STATIC void -S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs) +S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my) { SV *stashsv; /* 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; #define ATTRSMODULE "attributes" +#define ATTRSMODULE_PM "attributes.pm" - Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, - newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), - Nullsv, - prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, stashsv), - prepend_elem(OP_LIST, - newSVOP(OP_CONST, 0, - newRV(target)), - dup_attrlist(attrs)))); + if (for_my) { + SV **svp; + /* Don't force the C if we don't need it. */ + svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM, + sizeof(ATTRSMODULE_PM)-1, 0); + if (svp && *svp != &PL_sv_undef) + ; /* already in %INC */ + else + Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, + newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), + Nullsv); + } + else { + Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS, + newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1), + Nullsv, + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, stashsv), + prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, + newRV(target)), + dup_attrlist(attrs)))); + } LEAVE; } +STATIC void +S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp) +{ + OP *pack, *imop, *arg; + SV *meth, *stashsv; + + if (!attrs) + return; + + assert(target->op_type == OP_PADSV || + target->op_type == OP_PADHV || + target->op_type == OP_PADAV); + + /* Ensure that attributes.pm is loaded. */ + apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE); + + /* Need package name for method call. */ + pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1)); + + /* Build up the real arg-list. */ + if (stash) + stashsv = newSVpv(HvNAME(stash), 0); + else + stashsv = &PL_sv_no; + arg = newOP(OP_PADSV, 0); + arg->op_targ = target->op_targ; + arg = prepend_elem(OP_LIST, + newSVOP(OP_CONST, 0, stashsv), + prepend_elem(OP_LIST, + newUNOP(OP_REFGEN, 0, + mod(arg, OP_REFGEN)), + dup_attrlist(attrs))); + + /* Fake up a method call to import */ + meth = newSVpvn("import", 6); + (void)SvUPGRADE(meth, SVt_PVIV); + (void)SvIOK_on(meth); + PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth)); + imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID, + append_elem(OP_LIST, + prepend_elem(OP_LIST, pack, list(arg)), + newSVOP(OP_METHOD_NAMED, 0, meth))); + imop->op_private |= OPpENTERSUB_NOMOD; + + /* Combine the ops. */ + *imopsp = append_elem(OP_LIST, *imopsp, imop); +} + +/* +=notfor apidoc apply_attrs_string + +Attempts to apply a list of attributes specified by the C and +C arguments to the subroutine identified by the C argument which +is expected to be associated with the package identified by the C +argument (see L). It gets this wrong, though, in that it +does not correctly identify the boundaries of the individual attribute +specifications within C. This is not really intended for the +public API, but has to be listed here for systems such as AIX which +need an explicit export list for symbols. (It's called from XS code +in support of the C keyword from F.) Patches to fix it +to respect attribute syntax properly would be welcome. + +=cut +*/ + void Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, char *attrstr, STRLEN len) @@ -1872,7 +2058,7 @@ Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv, } STATIC OP * -S_my_kid(pTHX_ OP *o, OP *attrs) +S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) { OP *kid; I32 type; @@ -1883,27 +2069,40 @@ S_my_kid(pTHX_ OP *o, OP *attrs) type = o->op_type; if (type == OP_LIST) { for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) - my_kid(kid, attrs); + my_kid(kid, attrs, imopsp); } else if (type == OP_UNDEF) { return o; } else if (type == OP_RV2SV || /* "our" declaration */ type == OP_RV2AV || type == OP_RV2HV) { /* XXX does this let anything illegal in? */ + if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */ + yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o))); + } + if (attrs) { + GV *gv = cGVOPx_gv(cUNOPo->op_first); + PL_in_my = FALSE; + PL_in_my_stash = Nullhv; + apply_attrs(GvSTASH(gv), + (type == OP_RV2SV ? GvSV(gv) : + type == OP_RV2AV ? (SV*)GvAV(gv) : + type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv), + attrs, FALSE); + } o->op_private |= OPpOUR_INTRO; return o; - } else if (type != OP_PADSV && + } + else if (type != OP_PADSV && type != OP_PADAV && type != OP_PADHV && type != OP_PUSHMARK) { 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; } else if (attrs && type != OP_PUSHMARK) { HV *stash; - SV *padsv; SV **namesvp; PL_in_my = FALSE; @@ -1911,12 +2110,11 @@ 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; - padsv = PAD_SV(o->op_targ); - apply_attrs(stash, padsv, attrs); + apply_attrs_my(stash, o, attrs, imopsp); } o->op_flags |= OPf_MOD; o->op_private |= OPpLVAL_INTRO; @@ -1926,11 +2124,24 @@ S_my_kid(pTHX_ OP *o, OP *attrs) OP * Perl_my_attrs(pTHX_ OP *o, OP *attrs) { + OP *rops = Nullop; + int maybe_scalar = 0; + if (o->op_flags & OPf_PARENS) list(o); + else + maybe_scalar = 1; if (attrs) SAVEFREEOP(attrs); - o = my_kid(o, attrs); + o = my_kid(o, attrs, &rops); + if (rops) { + if (maybe_scalar && o->op_type == OP_PADSV) { + o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o)); + o->op_private |= OPpLVAL_INTRO; + } + else + o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops); + } PL_in_my = FALSE; PL_in_my_stash = Nullhv; return o; @@ -1939,7 +2150,7 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) OP * Perl_my(pTHX_ OP *o) { - return my_kid(o, Nullop); + return my_attrs(o, Nullop); } OP * @@ -1971,6 +2182,13 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) desc, sample, sample); } + if (right->op_type == OP_CONST && + cSVOPx(right)->op_private & OPpCONST_BARE && + cSVOPx(right)->op_private & OPpCONST_STRICT) + { + no_bareword_allowed(right); + } + if (!(right->op_flags & OPf_STACKED) && (right->op_type == OP_MATCH || right->op_type == OP_SUBST || @@ -2018,7 +2236,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); @@ -2073,7 +2291,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; @@ -2087,13 +2308,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 @@ -2109,7 +2330,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) @@ -2120,7 +2341,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 */ @@ -2143,9 +2364,14 @@ Perl_localize(pTHX_ OP *o, I32 lex) if (o->op_flags & OPf_PARENS) list(o); else { - 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", @@ -2166,12 +2392,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; @@ -2216,8 +2442,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; } @@ -2304,7 +2530,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; @@ -2323,16 +2549,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]; @@ -2342,13 +2565,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); } @@ -2376,7 +2592,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; } @@ -2397,14 +2612,10 @@ 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); + + FreeOp(last); -#ifdef PL_OP_SLAB_ALLOC -#else - Safefree(last); -#endif return (OP*)first; } @@ -2421,6 +2632,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)) { @@ -2430,7 +2643,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; } @@ -2450,7 +2663,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; } @@ -2463,7 +2676,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) @@ -2483,8 +2697,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; } @@ -2562,15 +2774,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; } @@ -2581,15 +2794,17 @@ 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; @@ -2616,63 +2831,87 @@ 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+1]; - U8** cp; - I32* cl; + 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]; - I32 cur = j < i ? cp[j+1] - s : tend - s; - UV val = utf8_to_uv(s, cur, &ulen, 0); - 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, cur - 1, &ulen, 0); + 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_flags(tmpbuf, 0x7fffffff, + UNICODE_ALLOW_SUPER); 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; @@ -2682,11 +2921,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, tend - t, &ulen, 0); + tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); t += ulen; - if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */ + if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */ t++; - tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0); + tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0); t += ulen; } else @@ -2696,11 +2935,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, rend - r, &ulen, 0); + rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); r += ulen; - if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */ + if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */ r++; - rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0); + rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0); r += ulen; } else @@ -2741,21 +2980,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; } @@ -2771,18 +2999,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; @@ -2803,10 +3037,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) { @@ -2814,6 +3065,9 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) if (!squash) o->op_private |= OPpTRANS_IDENTICAL; } + else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) { + o->op_private |= OPpTRANS_IDENTICAL; + } for (i = 0; i < 256; i++) tbl[i] = -1; for (i = 0, j = 0; i < tlen; i++,j++) { @@ -2825,10 +3079,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); @@ -2852,10 +3111,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; @@ -2883,16 +3160,14 @@ 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)) + if (DO_UTF8(pat)) pm->op_pmdynflags |= PMdf_UTF8; - pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm); - if (strEQ("\\s+", pm->op_pmregexp->precomp)) + PM_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 @@ -2929,21 +3204,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)) @@ -2956,7 +3231,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 || @@ -2982,14 +3257,14 @@ 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))) { + && (!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; } @@ -3096,6 +3371,7 @@ Perl_package(pTHX_ OP *o) op_free(o); } else { + deprecate("\"package\" with no arguments"); sv_setpv(PL_curstname,""); PL_curstash = Nullhv; } @@ -3108,10 +3384,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"); @@ -3160,7 +3437,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, @@ -3169,20 +3446,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. */ @@ -3192,15 +3462,40 @@ 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; } +/* +=head1 Embedding Functions + +=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, ...) { @@ -3267,10 +3562,10 @@ Perl_dofile(pTHX_ OP *term) GV *gv; gv = gv_fetchpv("do", FALSE, SVt_PVCV); - if (!(gv && GvIMPORTED_CV(gv))) + if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV); - if (gv && GvIMPORTED_CV(gv)) { + if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED, append_elem(OP_LIST, term, scalar(newUNOP(OP_RV2CV, 0, @@ -3311,6 +3606,11 @@ S_list_assignment(pTHX_ register OP *o) return FALSE; } + if (o->op_type == OP_LIST && + (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR && + o->op_private & OPpLVAL_INTRO) + return FALSE; + if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS || o->op_type == OP_RV2AV || o->op_type == OP_RV2HV || o->op_type == OP_ASLICE || o->op_type == OP_HSLICE) @@ -3400,7 +3700,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 @@ -3430,7 +3730,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; @@ -3448,7 +3748,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; @@ -3496,7 +3796,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 @@ -3534,8 +3834,8 @@ 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); } } @@ -3811,7 +4111,7 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) case OP_SASSIGN: if (k1->op_type == OP_READDIR || k1->op_type == OP_GLOB - || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL) + || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB) || k1->op_type == OP_EACH) expr = newUNOP(OP_DEFINED, 0, expr); break; @@ -3844,7 +4144,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP * OP *next = 0; OP *listop; OP *o; - OP *condop; U8 loopflags = 0; if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB @@ -3880,7 +4179,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); @@ -3907,7 +4205,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 @@ -3967,7 +4265,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 @@ -4003,7 +4301,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 { @@ -4019,6 +4317,7 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo LOOP *tmp; NewOp(1234,tmp,1,LOOP); Copy(loop,tmp,1,LOOP); + FreeOp(loop); loop = tmp; } #else @@ -4059,37 +4358,48 @@ 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)) { + /* 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. --GSAR */ + if (!CvANON(cv) || CvCLONED(cv)) + SvREFCNT_dec(CvOUTSIDE(cv)); CvOUTSIDE(cv) = Nullcv; if (CvCONST(cv)) { SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); @@ -4116,8 +4426,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) { @@ -4164,6 +4479,7 @@ S_cv_dump(pTHX_ CV *cv) } #endif /* DEBUGGING */ } +#endif /* DEBUG_CLOSURES */ STATIC CV * S_cv_clone2(pTHX_ CV *proto, CV *outside) @@ -4192,15 +4508,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); @@ -4339,9 +4660,12 @@ 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); /* + +=head1 Optree Manipulation Functions + =for apidoc cv_const_sv If C is a constant sub eligible for inlining. returns the constant @@ -4486,6 +4810,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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 @@ -4493,6 +4823,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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 @@ -4515,7 +4852,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); @@ -4554,9 +4892,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; @@ -4564,12 +4902,12 @@ 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; } - apply_attrs(stash, rcv, attrs); + apply_attrs(stash, rcv, attrs, FALSE); } if (cv) { /* must reuse cv if autoloaded */ if (!block) { @@ -4583,9 +4921,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; @@ -4595,16 +4957,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); @@ -4635,7 +4997,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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)); @@ -4644,7 +5007,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)) { @@ -4686,6 +5049,13 @@ 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. + * This is okay as the lifetime of the prototype is tied to the + * lifetime of the outer CV. Avoids memory leak due to reference + * loop. --GSAR */ + if (!name) + SvREFCNT_dec(CvOUTSIDE(cv)); + if (name || aname) { char *s; char *tname = (name ? name : aname); @@ -4727,8 +5097,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(); @@ -4843,7 +5211,6 @@ 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) @@ -4870,12 +5237,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 */ @@ -4943,12 +5310,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); } @@ -4956,8 +5328,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])) @@ -4969,7 +5341,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); @@ -5059,6 +5431,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)); } @@ -5078,6 +5455,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)); } @@ -5193,14 +5575,23 @@ 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; } 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; @@ -5225,7 +5616,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; @@ -5269,6 +5660,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); } @@ -5281,7 +5673,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); @@ -5298,15 +5690,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; } @@ -5425,6 +5817,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]; } } @@ -5458,13 +5851,6 @@ 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; } @@ -5520,6 +5906,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)) { @@ -5578,12 +5970,14 @@ Perl_ck_fun(pTHX_ OP *o) OP *newop = newGVOP(OP_GV, 0, gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE, SVt_PVIO) ); + if (kid == cLISTOPo->op_last) + cLISTOPo->op_last = newop; op_free(kid); kid = newop; } 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; @@ -5651,7 +6045,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) { @@ -5663,7 +6057,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; } @@ -5677,22 +6071,29 @@ Perl_ck_glob(pTHX_ OP *o) if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling) append_elem(OP_GLOB, o, newDEFSVOP()); - if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv))) + if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) + && GvCVu(gv) && GvIMPORTED_CV(gv))) + { gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV); + } #if !defined(PERL_EXTERNAL_GLOB) /* XXX this can be tightened up and made more failsafe. */ if (!gv) { + GV *glob_gv; ENTER; - Perl_load_module(aTHX_ 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 */ - if (gv && GvIMPORTED_CV(gv)) { + if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) { append_elem(OP_GLOB, o, newSVOP(OP_CONST, 0, newSViv(PL_glob_index++))); o->op_type = OP_LIST; @@ -5758,7 +6159,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); @@ -5864,29 +6265,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 * @@ -5920,18 +6299,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; @@ -6011,6 +6378,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; @@ -6032,9 +6401,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 && GvCVu(gv) && GvIMPORTED_CV(gv))) + gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV); + + if (gv && GvCVu(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) @@ -6074,7 +6471,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 @_ */ @@ -6088,7 +6485,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)); @@ -6098,17 +6495,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) { @@ -6119,7 +6511,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) { @@ -6137,7 +6529,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) { @@ -6150,7 +6542,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; } @@ -6224,7 +6616,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 * @@ -6273,7 +6664,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; } @@ -6285,8 +6676,8 @@ Perl_ck_join(pTHX_ OP *o) 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); @@ -6307,6 +6698,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; @@ -6314,7 +6707,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); @@ -6403,36 +6796,74 @@ 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) { + char *p = proto; + char s = *p; + contextclass = 0; + *p = '\0'; + while (*--p != '['); + bad_type(arg, Perl_form(aTHX_ "one of %s", p), + gv_ename(namegv), o2); + *proto = s; + } else + goto oops; + break; case '*': - 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; @@ -6441,9 +6872,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++; @@ -6451,7 +6888,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 @@ -6514,7 +6951,6 @@ Perl_peep(pTHX_ register OP *o) { register OP* oldop = 0; STRLEN n_a; - OP *last_composite = Nullop; if (!o || o->op_seq) return; @@ -6533,7 +6969,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: @@ -6578,7 +7013,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++; @@ -6596,7 +7031,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: @@ -6611,7 +7054,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; @@ -6622,19 +7065,19 @@ Perl_peep(pTHX_ register OP *o) else if (o->op_next->op_type == OP_RV2AV) { OP* pop = o->op_next->op_next; IV i; - if (pop->op_type == OP_CONST && + if (pop && pop->op_type == OP_CONST && (PL_op = pop->op_next) && pop->op_next->op_type == OP_AELEM && !(pop->op_next->op_private & - (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; @@ -6655,6 +7098,17 @@ 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 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++; break; @@ -6670,13 +7124,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; @@ -6684,6 +7145,9 @@ 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; @@ -6725,9 +7189,9 @@ Perl_peep(pTHX_ register OP *o) svp = cSVOPx_svp(((BINOP*)o)->op_last); if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { key = SvPV(sv, keylen); - if (SvUTF8(sv)) - keylen = -keylen; - lexname = newSVpvn_share(key, keylen, 0); + lexname = newSVpvn_share(key, + SvUTF8(sv) ? -(I32)keylen : keylen, + 0); SvREFCNT_dec(sv); *svp = lexname; } @@ -6739,13 +7203,14 @@ 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)) break; 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))); @@ -6787,7 +7252,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)) @@ -6810,7 +7275,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", @@ -6830,42 +7296,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; @@ -6875,14 +7305,60 @@ 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) { +#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); } +