X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=729c25f0aa87bcd25f8606bd70d852c6c67e1967;hb=e853d2264b77e2bdc0758f8ab38e819629763e81;hp=d9bf34644eff893eaedb384c20510e0ce7c75f04;hpb=34795b444ea0d5e132ba709fc4810b1d0ca42796;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index d9bf346..729c25f 100644 --- a/op.c +++ b/op.c @@ -1,7 +1,7 @@ /* op.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -9,11 +9,13 @@ */ /* - * "You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was - * our Mr. Bilbo's first cousin on the mother's side (her mother being the - * youngest of the Old Took's daughters); and Mr. Drogo was his second - * cousin. So Mr. Frodo is his first *and* second cousin, once removed - * either way, as the saying is, if you follow me." --the Gaffer + * 'You see: Mr. Drogo, he married poor Miss Primula Brandybuck. She was + * our Mr. Bilbo's first cousin on the mother's side (her mother being the + * youngest of the Old Took's daughters); and Mr. Drogo was his second + * cousin. So Mr. Frodo is his first *and* second cousin, once removed + * either way, as the saying is, if you follow me.' --the Gaffer + * + * [p.23 of _The Lord of the Rings_, I/i: "A Long-Expected Party"] */ /* This file contains the functions that create, manipulate and optimize @@ -55,7 +57,7 @@ context is, either upward in the syntax tree, or either forward or backward in the execution order. (The bottom-up parser builds that part of the execution order it knows about, but if you follow the "next" links around, you'll find it's actually a closed loop through the -top level node. +top level node.) Whenever the bottom-up parser gets to a node that supplies context to its components, it invokes that portion of the top-down pass that applies @@ -101,6 +103,7 @@ recursive, but it's recursive on basic blocks, not on tree nodes. #include "keywords.h" #define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o) +#define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o) #if defined(PL_OP_SLAB_ALLOC) @@ -397,14 +400,6 @@ Perl_allocmy(pTHX_ const char *const name) /* check for duplicate declaration */ pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash)); - if (PL_parser->in_my_stash && *name != '$') { - yyerror(Perl_form(aTHX_ - "Can't declare class for non-scalar %s in \"%s\"", - name, - is_our ? "our" - : PL_parser->in_my == KEY_state ? "state" : "my")); - } - /* allocate a spare slot and store the name in that slot */ off = pad_add_name(name, @@ -488,6 +483,11 @@ Perl_op_free(pTHX_ OP *o) } } + /* Call the op_free hook if it has been set. Do it now so that it's called + * at the right time for refcounted ops, but still before all of the kids + * are freed. */ + CALL_OPFREEHOOK(o); + if (o->op_flags & OPf_KIDS) { register OP *kid, *nextkid; for (kid = cUNOPo->op_first; kid; kid = nextkid) { @@ -495,8 +495,6 @@ Perl_op_free(pTHX_ OP *o) op_free(kid); } } - if (type == OP_NULL) - type = (OPCODE)o->op_targ; #ifdef PERL_DEBUG_READONLY_OPS Slab_to_rw(o); @@ -504,10 +502,16 @@ Perl_op_free(pTHX_ OP *o) /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ - if (type == OP_NEXTSTATE || type == OP_DBSTATE) { + if (type == OP_NEXTSTATE || type == OP_DBSTATE + || (type == OP_NULL /* the COP might have been null'ed */ + && ((OPCODE)o->op_targ == OP_NEXTSTATE + || (OPCODE)o->op_targ == OP_DBSTATE))) { cop_free((COP*)o); } + if (type == OP_NULL) + type = (OPCODE)o->op_targ; + op_clear(o); if (o->op_latefree) { o->op_latefreed = 1; @@ -548,7 +552,7 @@ Perl_op_clear(pTHX_ OP *o) switch (o->op_type) { case OP_NULL: /* Was holding old type, if any. */ if (PL_madskills && o->op_targ != OP_NULL) { - o->op_type = (optype)o->op_targ; + o->op_type = (Optype)o->op_targ; o->op_targ = 0; goto retry; } @@ -580,6 +584,7 @@ Perl_op_clear(pTHX_ OP *o) break; case OP_METHOD_NAMED: case OP_CONST: + case OP_HINTSEVAL: SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = NULL; #ifdef USE_ITHREADS @@ -630,7 +635,7 @@ Perl_op_clear(pTHX_ OP *o) pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); } #else - SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv); + SvREFCNT_dec(MUTABLE_SV(cPMOPo->op_pmreplrootu.op_pmtargetgv)); #endif /* FALL THROUGH */ case OP_MATCH: @@ -671,7 +676,6 @@ S_cop_free(pTHX_ COP* cop) { PERL_ARGS_ASSERT_COP_FREE; - CopLABEL_free(cop); CopFILE_free(cop); CopSTASH_free(cop); if (! specialWARN(cop->cop_warnings)) @@ -691,7 +695,7 @@ S_forget_pmop(pTHX_ PMOP *const o PERL_ARGS_ASSERT_FORGET_PMOP; if (pmstash && !SvIS_FREED(pmstash)) { - MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab); + MAGIC * const mg = mg_find((const SV *)pmstash, PERL_MAGIC_symtab); if (mg) { PMOP **const array = (PMOP**) mg->mg_ptr; U32 count = mg->mg_len / sizeof(PMOP**); @@ -779,8 +783,8 @@ Perl_op_refcnt_unlock(pTHX) #define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o)) -OP * -Perl_linklist(pTHX_ OP *o) +static OP * +S_linklist(pTHX_ OP *o) { OP *first; @@ -811,8 +815,8 @@ Perl_linklist(pTHX_ OP *o) return o->op_next; } -OP * -Perl_scalarkids(pTHX_ OP *o) +static OP * +S_scalarkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; @@ -868,12 +872,8 @@ Perl_scalar(pTHX_ OP *o) for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) scalar(kid); break; - case OP_SPLIT: - if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { - if (!kPMOP->op_pmreplrootu.op_pmreplroot) - deprecate_old("implicit split to @_"); - } /* FALL THROUGH */ + case OP_SPLIT: case OP_MATCH: case OP_QR: case OP_SUBST: @@ -910,6 +910,7 @@ Perl_scalar(pTHX_ OP *o) case OP_SORT: if (ckWARN(WARN_VOID)) Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); + break; } return o; } @@ -1133,6 +1134,20 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_OR: case OP_AND: + kid = cLOGOPo->op_first; + if (kid->op_type == OP_NOT + && (kid->op_flags & OPf_KIDS) + && !PL_madskills) { + if (o->op_type == OP_AND) { + o->op_type = OP_OR; + o->op_ppaddr = PL_ppaddr[OP_OR]; + } else { + o->op_type = OP_AND; + o->op_ppaddr = PL_ppaddr[OP_AND]; + } + op_null(kid); + } + case OP_DOR: case OP_COND_EXPR: case OP_ENTERGIVEN: @@ -1172,20 +1187,14 @@ Perl_scalarvoid(pTHX_ OP *o) /* FALL THROUGH */ case OP_SCALAR: return scalar(o); - case OP_SPLIT: - if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) { - if (!kPMOP->op_pmreplrootu.op_pmreplroot) - deprecate_old("implicit split to @_"); - } - break; } if (useless && ckWARN(WARN_VOID)) Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless); return o; } -OP * -Perl_listkids(pTHX_ OP *o) +static OP * +S_listkids(pTHX_ OP *o) { if (o && o->op_flags & OPf_KIDS) { OP *kid; @@ -1272,8 +1281,8 @@ Perl_list(pTHX_ OP *o) return o; } -OP * -Perl_scalarseq(pTHX_ OP *o) +static OP * +S_scalarseq(pTHX_ OP *o) { dVAR; if (o) { @@ -1745,8 +1754,8 @@ S_is_handle_constructor(const OP *o, I32 numargs) } } -OP * -Perl_refkids(pTHX_ OP *o, I32 type) +static OP * +S_refkids(pTHX_ OP *o, I32 type) { if (o && o->op_flags & OPf_KIDS) { OP *kid; @@ -2010,7 +2019,7 @@ Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv, newSVOP(OP_CONST, 0, newSVpv(stashpv,0)), prepend_elem(OP_LIST, newSVOP(OP_CONST, 0, - newRV((SV*)cv)), + newRV(MUTABLE_SV(cv))), attrs))); } @@ -2056,8 +2065,8 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp) PL_parser->in_my_stash = NULL; apply_attrs(GvSTASH(gv), (type == OP_RV2SV ? GvSV(gv) : - type == OP_RV2AV ? (SV*)GvAV(gv) : - type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv), + type == OP_RV2AV ? MUTABLE_SV(GvAV(gv)) : + type == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(gv)), attrs, FALSE); } o->op_private |= OPpOUR_INTRO; @@ -2131,14 +2140,6 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs) } OP * -Perl_my(pTHX_ OP *o) -{ - PERL_ARGS_ASSERT_MY; - - return my_attrs(o, NULL); -} - -OP * Perl_sawparens(pTHX_ OP *o) { PERL_UNUSED_CONTEXT; @@ -2325,14 +2326,13 @@ Perl_newPROG(pTHX_ OP *o) /* Register with debugger */ if (PERLDB_INTER) { - CV * const cv - = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0); + CV * const cv = get_cvs("DB::postponed", 0); if (cv) { dSP; PUSHMARK(SP); - XPUSHs((SV*)CopFILEGV(&PL_compiling)); + XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling))); PUTBACK; - call_sv((SV*)cv, G_DISCARD); + call_sv(MUTABLE_SV(cv), G_DISCARD); } } } @@ -2413,8 +2413,8 @@ Perl_jmaybe(pTHX_ OP *o) return o; } -OP * -Perl_fold_constants(pTHX_ register OP *o) +static OP * +S_fold_constants(pTHX_ register OP *o) { dVAR; register OP * VOL curop; @@ -2426,6 +2426,7 @@ Perl_fold_constants(pTHX_ register OP *o) OP *old_next; SV * const oldwarnhook = PL_warnhook; SV * const olddiehook = PL_diehook; + COP not_compiling; dJMPENV; PERL_ARGS_ASSERT_FOLD_CONSTANTS; @@ -2464,6 +2465,7 @@ Perl_fold_constants(pTHX_ register OP *o) /* XXX what about the numeric ops? */ if (PL_hints & HINT_LOCALE) goto nope; + break; } if (PL_parser && PL_parser->error_count) @@ -2489,6 +2491,13 @@ Perl_fold_constants(pTHX_ register OP *o) oldscope = PL_scopestack_ix; create_eval_scope(G_FAKINGEVAL); + /* Verify that we don't need to save it: */ + assert(PL_curcop == &PL_compiling); + StructCopy(&PL_compiling, ¬_compiling, COP); + PL_curcop = ¬_compiling; + /* The above ensures that we run with all the correct hints of the + currently compiling COP, but that IN_PERL_RUNTIME is not true. */ + assert(IN_PERL_RUNTIME); PL_warnhook = PERL_WARNHOOK_FATAL; PL_diehook = NULL; JMPENV_PUSH(ret); @@ -2507,7 +2516,7 @@ Perl_fold_constants(pTHX_ register OP *o) case 3: /* Something tried to die. Abandon constant folding. */ /* Pretend the error never happened. */ - sv_setpvn(ERRSV,"",0); + CLEAR_ERRSV(); o->op_next = old_next; break; default: @@ -2522,6 +2531,7 @@ Perl_fold_constants(pTHX_ register OP *o) JMPENV_POP; PL_warnhook = oldwarnhook; PL_diehook = olddiehook; + PL_curcop = &PL_compiling; if (PL_scopestack_ix > oldscope) delete_eval_scope(); @@ -2534,9 +2544,9 @@ Perl_fold_constants(pTHX_ register OP *o) #endif assert(sv); if (type == OP_RV2GV) - newop = newGVOP(OP_GV, 0, (GV*)sv); + newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv)); else - newop = newSVOP(OP_CONST, 0, (SV*)sv); + newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv)); op_getmad(o,newop,'f'); return newop; @@ -2544,8 +2554,8 @@ Perl_fold_constants(pTHX_ register OP *o) return o; } -OP * -Perl_gen_constant_list(pTHX_ register OP *o) +static OP * +S_gen_constant_list(pTHX_ register OP *o) { dVAR; register OP *curop; @@ -2750,7 +2760,7 @@ Perl_token_getmad(pTHX_ TOKEN* tk, OP* o, char slot) /* faked up qw list? */ if (slot == '(' && tm->mad_type == MAD_SV && - SvPVX((SV*)tm->mad_val)[0] == 'q') + SvPVX((SV *)tm->mad_val)[0] == 'q') slot = 'x'; if (o) { @@ -2907,7 +2917,7 @@ Perl_newMADsv(pTHX_ char key, SV* sv) } MADPROP * -Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen) +Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen) { MADPROP *mp; Newxz(mp, 1, MADPROP); @@ -2941,7 +2951,7 @@ Perl_mad_free(pTHX_ MADPROP* mp) op_free((OP*)mp->mad_val); break; case MAD_SV: - sv_free((SV*)mp->mad_val); + sv_free(MUTABLE_SV(mp->mad_val)); break; default: PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n"); @@ -2958,8 +2968,8 @@ Perl_newNULLLIST(pTHX) return newOP(OP_STUB, 0); } -OP * -Perl_force_list(pTHX_ OP *o) +static OP * +S_force_list(pTHX_ OP *o) { if (!o || o->op_type != OP_LIST) o = newLISTOP(OP_LIST, 0, o, NULL); @@ -3096,8 +3106,8 @@ static int uvcompare(const void *a, const void *b) return 0; } -OP * -Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) +static OP * +S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) { dVAR; SV * const tstr = ((SVOP*)expr)->op_sv; @@ -3319,12 +3329,13 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) PerlMemShared_free(cPVOPo->op_pv); cPVOPo->op_pv = NULL; - swash = (SV*)swash_init("utf8", "", listsv, bits, none); + swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none)); #ifdef USE_ITHREADS cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP); SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix)); PAD_SETSV(cPADOPo->op_padix, swash); SvPADTMP_on(swash); + SvREADONLY_on(swash); #else cSVOPo->op_sv = swash; #endif @@ -3332,7 +3343,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) SvREFCNT_dec(transv); if (!del && havefinal && rlen) - (void)hv_store((HV*)SvRV(swash), "FINAL", 5, + (void)hv_store(MUTABLE_HV(SvRV(swash)), "FINAL", 5, newSVuv((UV)final), 0); if (grows) @@ -3420,6 +3431,15 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } } } + + if(ckWARN(WARN_MISC)) { + if(del && rlen == tlen) { + Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); + } else if(rlen > tlen) { + Perl_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); + } + } + if (grows) o->op_private |= OPpTRANS_GROWS; #ifdef PERL_MAD @@ -3834,7 +3854,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) SV *meth; if (version->op_type != OP_CONST || !SvNIOKp(vesv)) - Perl_croak(aTHX_ "Version number must be constant number"); + Perl_croak(aTHX_ "Version number must be a constant number"); /* Make copy of idop so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); @@ -3932,7 +3952,11 @@ 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. +method, similar to C. They must be +terminated with a final NULL pointer. Note that this list can only +be omitted when the PERL_LOADMOD_NOIMPORT flag has been used. +Otherwise at least a single NULL pointer to designate the default +import list is required. =cut */ @@ -4235,7 +4259,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) else if (curop->op_type == OP_PUSHRE) { #ifdef USE_ITHREADS if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) { - GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff); + GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff)); if (gv == PL_defgv || (int)GvASSIGN_GENERATION(gv) == PL_generation) break; @@ -4283,7 +4307,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) cPADOPx(tmpop)->op_padix = 0; /* steal it */ #else pm->op_pmreplrootu.op_pmtargetgv - = (GV*)cSVOPx(tmpop)->op_sv; + = MUTABLE_GV(cSVOPx(tmpop)->op_sv); cSVOPx(tmpop)->op_sv = NULL; /* steal it */ #endif pm->op_pmflags |= PMf_ONCE; @@ -4302,7 +4326,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) ((LISTOP*)right)->op_last->op_type == OP_CONST) { SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv; - if (SvIVX(sv) == 0) + if (SvIOK(sv) && SvIVX(sv) == 0) sv_setiv(sv, PL_modcount+1); } } @@ -4323,10 +4347,12 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (PL_eval_start) PL_eval_start = 0; else { - /* FIXME for MAD */ - op_free(o); - o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling))); - o->op_private |= OPpCONST_ARYBASE; + if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */ + deprecate("assignment to $["); + op_free(o); + o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling))); + o->op_private |= OPpCONST_ARYBASE; + } } } return o; @@ -4356,10 +4382,6 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) CopHINTS_set(&PL_compiling, CopHINTS_get(cop)); cop->op_next = (OP*)cop; - if (label) { - CopLABEL_set(cop, label); - PL_hints |= HINT_BLOCK_SCOPE; - } cop->cop_seq = seq; /* CopARYBASE is now "virtual", in that it's stored as a flag bit in CopHINTS and a possible value in cop_hints_hash, so no need to copy it. @@ -4371,6 +4393,16 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->cop_hints_hash->refcounted_he_refcnt++; HINTS_REFCNT_UNLOCK; } + if (label) { + cop->cop_hints_hash + = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label); + + PL_hints |= HINT_BLOCK_SCOPE; + /* It seems that we need to defer freeing this pointer, as other parts + of the grammar end up wanting to copy it after this op has been + created. */ + SAVEFREEPV(label); + } if (PL_parser && PL_parser->copline == NOLINE) CopLINE_set(cop, CopLINE(PL_curcop)); @@ -4386,7 +4418,8 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) #endif CopSTASH_set(cop, PL_curstash); - if (PERLDB_LINE && PL_curstash != PL_debstash) { + if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash) { + /* this line can have a breakpoint - store the cop in IV */ AV *av = CopFILEAVx(PL_curcop); if (av) { SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE); @@ -4397,6 +4430,8 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) } } + if (flags & OPf_SPECIAL) + op_null((OP*)cop); return prepend_elem(OP_LINESEQ, (OP*)cop, o); } @@ -4412,46 +4447,95 @@ Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other) } STATIC OP * +S_search_const(pTHX_ OP *o) +{ + PERL_ARGS_ASSERT_SEARCH_CONST; + + switch (o->op_type) { + case OP_CONST: + return o; + case OP_NULL: + if (o->op_flags & OPf_KIDS) + return search_const(cUNOPo->op_first); + break; + case OP_LEAVE: + case OP_SCOPE: + case OP_LINESEQ: + { + OP *kid; + if (!(o->op_flags & OPf_KIDS)) + return NULL; + kid = cLISTOPo->op_first; + do { + switch (kid->op_type) { + case OP_ENTER: + case OP_NULL: + case OP_NEXTSTATE: + kid = kid->op_sibling; + break; + default: + if (kid != cLISTOPo->op_last) + return NULL; + goto last; + } + } while (kid); + if (!kid) + kid = cLISTOPo->op_last; +last: + return search_const(kid); + } + } + + return NULL; +} + +STATIC OP * S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) { dVAR; LOGOP *logop; OP *o; - OP *first = *firstp; - OP * const other = *otherp; + OP *first; + OP *other; + OP *cstop = NULL; + int prepend_not = 0; PERL_ARGS_ASSERT_NEW_LOGOP; + first = *firstp; + other = *otherp; + if (type == OP_XOR) /* Not short circuit, but here by precedence. */ return newBINOP(type, flags, scalar(first), scalar(other)); scalarboolean(first); - /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */ + /* optimize AND and OR ops that have NOTs as children */ if (first->op_type == OP_NOT - && (first->op_flags & OPf_SPECIAL) && (first->op_flags & OPf_KIDS) + && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */ + || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */ && !PL_madskills) { if (type == OP_AND || type == OP_OR) { if (type == OP_AND) type = OP_OR; else type = OP_AND; - o = first; - first = *firstp = cUNOPo->op_first; - if (o->op_next) - first->op_next = o->op_next; - cUNOPo->op_first = NULL; - op_free(o); + op_null(first); + if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */ + op_null(other); + prepend_not = 1; /* prepend a NOT op later */ + } } } - if (first->op_type == OP_CONST) { - if (first->op_private & OPpCONST_STRICT) - no_bareword_allowed(first); - else if ((first->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD)) + /* search for a constant op that could let us fold the test */ + if ((cstop = search_const(first))) { + if (cstop->op_private & OPpCONST_STRICT) + no_bareword_allowed(cstop); + else if ((cstop->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD)) Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); - if ((type == OP_AND && SvTRUE(((SVOP*)first)->op_sv)) || - (type == OP_OR && !SvTRUE(((SVOP*)first)->op_sv)) || - (type == OP_DOR && !SvOK(((SVOP*)first)->op_sv))) { + if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) || + (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) || + (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) { *firstp = NULL; if (other->op_type == OP_CONST) other->op_private |= OPpCONST_SHORTCIRCUIT; @@ -4462,6 +4546,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) return newop; } op_free(first); + if (other->op_type == OP_LEAVE) + other = newUNOP(OP_NULL, OPf_SPECIAL, other); return other; } else { @@ -4558,7 +4644,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) CHECKOP(type,logop); - o = newUNOP(OP_NULL, 0, (OP*)logop); + o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop); other->op_next = o; return o; @@ -4571,6 +4657,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) LOGOP *logop; OP *start; OP *o; + OP *cstop; PERL_ARGS_ASSERT_NEWCONDOP; @@ -4580,14 +4667,14 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) return newLOGOP(OP_OR, 0, first, falseop); scalarboolean(first); - if (first->op_type == OP_CONST) { + if ((cstop = search_const(first))) { /* Left or right arm of the conditional? */ - const bool left = SvTRUE(((SVOP*)first)->op_sv); + const bool left = SvTRUE(((SVOP*)cstop)->op_sv); OP *live = left ? trueop : falseop; OP *const dead = left ? falseop : trueop; - if (first->op_private & OPpCONST_BARE && - first->op_private & OPpCONST_STRICT) { - no_bareword_allowed(first); + if (cstop->op_private & OPpCONST_BARE && + cstop->op_private & OPpCONST_STRICT) { + no_bareword_allowed(cstop); } if (PL_madskills) { /* This is all dead code when PERL_MAD is not defined. */ @@ -4598,6 +4685,8 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) op_free(first); op_free(dead); } + if (live->op_type == OP_LEAVE) + live = newUNOP(OP_NULL, OPf_SPECIAL, live); return live; } NewOp(1101, logop, 1, LOGOP); @@ -5039,7 +5128,7 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, PERL_ARGS_ASSERT_NEWGIVWHENOP; NewOp(1101, enterop, 1, LOGOP); - enterop->op_type = (optype)enter_opcode; + enterop->op_type = (Optype)enter_opcode; enterop->op_ppaddr = PL_ppaddr[enter_opcode]; enterop->op_flags = (U8) OPf_KIDS; enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg); @@ -5092,6 +5181,7 @@ S_looks_like_bool(pTHX_ const OP *o) switch(o->op_type) { case OP_OR: + case OP_DOR: return looks_like_bool(cLOGOPo->op_first); case OP_AND: @@ -5107,7 +5197,6 @@ S_looks_like_bool(pTHX_ const OP *o) case OP_ENTERSUB: case OP_NOT: case OP_XOR: - /* Note that OP_DOR is not here */ case OP_EQ: case OP_NE: case OP_LT: case OP_GT: case OP_LE: case OP_GE: @@ -5132,6 +5221,8 @@ S_looks_like_bool(pTHX_ const OP *o) case OP_DEFINED: case OP_EXISTS: case OP_MATCH: case OP_EOF: + case OP_FLOP: + return TRUE; case OP_CONST: @@ -5140,7 +5231,9 @@ S_looks_like_bool(pTHX_ const OP *o) || cSVOPo->op_sv == &PL_sv_no) return TRUE; - + else + return FALSE; + /* FALL THROUGH */ default: return FALSE; @@ -5225,7 +5318,7 @@ Perl_cv_undef(pTHX_ CV *cv) CvSTART(cv) = NULL; LEAVE; } - SvPOK_off((SV*)cv); /* forget prototype */ + SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */ CvGV(cv) = NULL; pad_undef(cv); @@ -5237,7 +5330,7 @@ Perl_cv_undef(pTHX_ CV *cv) CvOUTSIDE(cv) = NULL; } if (CvCONST(cv)) { - SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr); + SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr)); CvCONST_off(cv); } if (CvISXSUB(cv) && CvXSUB(cv)) { @@ -5297,14 +5390,14 @@ L. =cut */ SV * -Perl_cv_const_sv(pTHX_ CV *cv) +Perl_cv_const_sv(pTHX_ const CV *const cv) { PERL_UNUSED_CONTEXT; if (!cv) return NULL; if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM)) return NULL; - return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL; + return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL; } /* op_const_sv: examine an optree to determine whether it's in-lineable. @@ -5425,7 +5518,6 @@ CV * Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) { dVAR; - const char *aname; GV *gv; const char *ps; STRLEN ps_len; @@ -5441,6 +5533,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) || PL_madskills) ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT; const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL; + bool has_name; if (proto) { assert(proto->op_type == OP_CONST); @@ -5449,20 +5542,23 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else ps = NULL; - if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) { + if (name) { + gv = gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV); + has_name = TRUE; + } else if (PERLDB_NAMEANON && CopLINE(PL_curcop)) { SV * const sv = sv_newmortal(); Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]", PL_curstash ? "__ANON__" : "__ANON__::__ANON__", CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); - aname = SvPVX_const(sv); + gv = gv_fetchsv(sv, gv_fetch_flags, SVt_PVCV); + has_name = TRUE; + } else if (PL_curstash) { + gv = gv_fetchpvs("__ANON__", gv_fetch_flags, SVt_PVCV); + has_name = FALSE; + } else { + gv = gv_fetchpvs("__ANON__::__ANON__", gv_fetch_flags, SVt_PVCV); + has_name = FALSE; } - else - aname = NULL; - - gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV) - : gv_fetchpv(aname ? aname - : (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"), - gv_fetch_flags, SVt_PVCV); if (!PL_madskills) { if (o) @@ -5476,17 +5572,18 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (SvTYPE(gv) != SVt_PVGV) { /* Maybe prototype now, and had at maximum a prototype before. */ if (SvTYPE(gv) > SVt_NULL) { - if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1) + if (!SvPOK((const SV *)gv) + && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1) && ckWARN_d(WARN_PROTOTYPE)) { Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype"); } - cv_ckproto_len((CV*)gv, NULL, ps, ps_len); + cv_ckproto_len((const CV *)gv, NULL, ps, ps_len); } if (ps) - sv_setpvn((SV*)gv, ps, ps_len); + sv_setpvn(MUTABLE_SV(gv), ps, ps_len); else - sv_setiv((SV*)gv, -1); + sv_setiv(MUTABLE_SV(gv), -1); SvREFCNT_dec(PL_compcv); cv = PL_compcv = NULL; @@ -5495,12 +5592,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) cv = (!name || GvCVGEN(gv)) ? NULL : 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 || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS) #ifdef PERL_MAD @@ -5514,12 +5605,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (cv) { const 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 @@ -5573,7 +5658,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) SvREFCNT_inc_simple_void_NN(const_sv); if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); - sv_setpvn((SV*)cv, "", 0); /* prototype is "" */ + sv_setpvs(MUTABLE_SV(cv), ""); /* prototype is "" */ CvXSUBANY(cv).any_ptr = const_sv; CvXSUB(cv) = const_sv_xsub; CvCONST_on(cv); @@ -5597,69 +5682,34 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PL_compcv = NULL; goto done; } - if (attrs) { - HV *stash; - SV *rcv; - - /* Need to do a C - * before we clobber PL_compcv. - */ - if (cv && (!block + if (cv) { /* must reuse cv if autoloaded */ + /* transfer PL_compcv to cv */ + if (block #ifdef PERL_MAD - || block->op_type == OP_NULL + && block->op_type != OP_NULL #endif - )) { - rcv = (SV*)cv; - /* Might have had built-in attributes applied -- propagate them. */ - CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); - if (CvGV(cv) && GvSTASH(CvGV(cv))) - stash = GvSTASH(CvGV(cv)); - else if (CvSTASH(cv)) - stash = CvSTASH(cv); - else - stash = PL_curstash; + ) { + cv_undef(cv); + CvFLAGS(cv) = CvFLAGS(PL_compcv); + if (!CvWEAKOUTSIDE(cv)) + SvREFCNT_dec(CvOUTSIDE(cv)); + CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); + CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); + CvOUTSIDE(PL_compcv) = 0; + CvPADLIST(cv) = CvPADLIST(PL_compcv); + CvPADLIST(PL_compcv) = 0; + /* inner references to PL_compcv must be fixed up ... */ + pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); + if (PERLDB_INTER)/* Advice debugger on the new sub. */ + ++PL_sub_generation; } else { - /* possibly about to re-define existing subr -- ignore old cv */ - rcv = (SV*)PL_compcv; - if (name && GvSTASH(gv)) - stash = GvSTASH(gv); - else - stash = PL_curstash; - } - apply_attrs(stash, rcv, attrs, FALSE); - } - if (cv) { /* must reuse cv if autoloaded */ - if ( -#ifdef PERL_MAD - ( -#endif - !block -#ifdef PERL_MAD - || block->op_type == OP_NULL) && !PL_madskills -#endif - ) { - /* got here with just attrs -- work done, so bug out */ - SAVEFREESV(PL_compcv); - goto done; + /* Might have had built-in attributes applied -- propagate them. */ + CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS); } - /* transfer PL_compcv to cv */ - cv_undef(cv); - CvFLAGS(cv) = CvFLAGS(PL_compcv); - if (!CvWEAKOUTSIDE(cv)) - SvREFCNT_dec(CvOUTSIDE(cv)); - CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv); - CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv); - CvOUTSIDE(PL_compcv) = 0; - CvPADLIST(cv) = CvPADLIST(PL_compcv); - CvPADLIST(PL_compcv) = 0; - /* inner references to PL_compcv must be fixed up ... */ - pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv); /* ... before we throw it away */ SvREFCNT_dec(PL_compcv); PL_compcv = cv; - if (PERLDB_INTER)/* Advice debugger on the new sub. */ - ++PL_sub_generation; } else { cv = PL_compcv; @@ -5667,7 +5717,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) GvCV(gv) = cv; if (PL_madskills) { if (strEQ(name, "import")) { - PL_formfeed = (SV*)cv; + PL_formfeed = MUTABLE_SV(cv); Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv); } } @@ -5675,12 +5725,19 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */ } } - CvGV(cv) = gv; - CvFILE_set_from_cop(cv, PL_curcop); - CvSTASH(cv) = PL_curstash; + if (!CvGV(cv)) { + CvGV(cv) = gv; + CvFILE_set_from_cop(cv, PL_curcop); + CvSTASH(cv) = PL_curstash; + } + if (attrs) { + /* Need to do a C. */ + HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash; + apply_attrs(stash, MUTABLE_SV(cv), attrs, FALSE); + } if (ps) - sv_setpvn((SV*)cv, ps, ps_len); + sv_setpvn(MUTABLE_SV(cv), ps, ps_len); if (PL_parser && PL_parser->error_count) { op_free(block); @@ -5705,6 +5762,12 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!block) goto done; + /* If we assign an optree to a PVCV, then we've defined a subroutine that + the debugger could be able to set a breakpoint in, so signal to + pp_entereval that it should not throw away any saved lines at scope + exit. */ + + PL_breakable_sub_gen++; if (CvLVALUE(cv)) { CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, mod(scalarseq(block), OP_LEAVESUBLV)); @@ -5741,7 +5804,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CvCONST_on(cv); } - if (name || aname) { + if (has_name) { if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { SV * const sv = newSV(0); SV * const tmpstr = sv_newmortal(); @@ -5763,7 +5826,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) PUSHMARK(SP); XPUSHs(tmpstr); PUTBACK; - call_sv((SV*)pcv, G_DISCARD); + call_sv(MUTABLE_SV(pcv), G_DISCARD); } } } @@ -5796,7 +5859,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, SAVECOPLINE(&PL_compiling); DEBUG_x( dump_sub(gv) ); - Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv); + Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv)); GvCV(gv) = 0; /* cv has been hijacked */ call_list(oldscope, PL_beginav); @@ -5810,13 +5873,13 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, if (*name == 'E') { if strEQ(name, "END") { DEBUG_x( dump_sub(gv) ); - Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv); + Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv)); } else return; } else if (*name == 'U') { if (strEQ(name, "UNITCHECK")) { /* It's never too late to run a unitcheck block */ - Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv); + Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv)); } else return; @@ -5825,7 +5888,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block"); - Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv); + Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); } else return; @@ -5834,7 +5897,7 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, if (PL_main_start && ckWARN(WARN_VOID)) Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block"); - Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv); + Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); } else return; @@ -5851,6 +5914,11 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, Creates a constant sub equivalent to Perl C which is eligible for inlining at compile-time. +Passing NULL for SV creates a constant sub equivalent to C, +which won't be called if used as a destructor, but will suppress the overhead +of a call to C. (This form, however, isn't eligible for inlining at +compile time.) + =cut */ @@ -5860,14 +5928,11 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) dVAR; CV* cv; #ifdef USE_ITHREADS - const char *const temp_p = CopFILE(PL_curcop); - const STRLEN len = temp_p ? strlen(temp_p) : 0; + const char *const file = CopFILE(PL_curcop); #else SV *const temp_sv = CopFILESV(PL_curcop); - STRLEN len; - const char *const temp_p = temp_sv ? SvPV_const(temp_sv, len) : NULL; + const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL; #endif - char *const file = savepvn(temp_p, temp_p ? len : 0); ENTER; @@ -5895,10 +5960,10 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) and so doesn't get free()d. (It's expected to be from the C pre- processor __FILE__ directive). But we need a dynamically allocated one, and we need it to get freed. */ - cv = newXS_flags(name, const_sv_xsub, file, "", XS_DYNAMIC_FILENAME); + cv = newXS_flags(name, const_sv_xsub, file ? file : "", "", + XS_DYNAMIC_FILENAME); CvXSUBANY(cv).any_ptr = sv; CvCONST_on(cv); - Safefree(file); #ifdef USE_ITHREADS if (stash) @@ -5940,7 +6005,7 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, } /* This gets free()d. :-) */ - sv_usepvn_flags((SV*)cv, proto_and_file, proto_and_file_len, + sv_usepvn_flags(MUTABLE_SV(cv), proto_and_file, proto_and_file_len, SV_HAS_TRAILING_NUL); if (proto) { /* This gives us the correct prototype, rather than one with the @@ -5951,7 +6016,7 @@ Perl_newXS_flags(pTHX_ const char *name, XSUBADDR_t subaddr, } CvFILE(cv) = proto_and_file + proto_len; } else { - sv_setpv((SV *)cv, proto); + sv_setpv(MUTABLE_SV(cv), proto); } return cv; } @@ -6015,7 +6080,7 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) if (cv) /* must reuse cv if autoloaded */ cv_undef(cv); else { - cv = (CV*)newSV_type(SVt_PVCV); + cv = MUTABLE_CV(newSV_type(SVt_PVCV)); if (name) { GvCV(gv) = cv; GvCVGEN(gv) = 0; @@ -6054,20 +6119,19 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM) : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, 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)) { const line_t oldline = CopLINE(PL_curcop); if (PL_parser && PL_parser->copline != NOLINE) CopLINE_set(PL_curcop, PL_parser->copline); - Perl_warner(aTHX_ packWARN(WARN_REDEFINE), - o ? "Format %"SVf" redefined" - : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv)); + if (o) { + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv)); + } else { + Perl_warner(aTHX_ packWARN(WARN_REDEFINE), + "Format STDOUT redefined"); + } CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); @@ -6122,7 +6186,7 @@ Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block) { return newUNOP(OP_REFGEN, 0, newSVOP(OP_ANONCODE, 0, - (SV*)newATTRSUB(floor, 0, proto, attrs, block))); + MUTABLE_SV(newATTRSUB(floor, 0, proto, attrs, block)))); } OP * @@ -6372,6 +6436,8 @@ Perl_ck_delete(pTHX_ OP *o) Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice", OP_DESC(o)); } + if (kid->op_private & OPpLVAL_INTRO) + o->op_private |= OPpLVAL_INTRO; op_null(kid); } return o; @@ -6445,6 +6511,8 @@ Perl_ck_eval(pTHX_ OP *o) /* establish postfix order */ enter->op_next = (OP*)enter; + CHECKOP(OP_ENTERTRY, enter); + o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid); o->op_type = OP_LEAVETRY; o->op_ppaddr = PL_ppaddr[OP_LEAVETRY]; @@ -6468,12 +6536,9 @@ Perl_ck_eval(pTHX_ OP *o) } o->op_targ = (PADOFFSET)PL_hints; if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) { - /* Store a copy of %^H that pp_entereval can pick up. - OPf_SPECIAL flags the opcode as being for this purpose, - so that it in turn will return a copy at every - eval.*/ - OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL, - (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))); + /* Store a copy of %^H that pp_entereval can pick up. */ + OP *hhop = newSVOP(OP_HINTSEVAL, 0, + MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)))); cUNOPo->op_first->op_sibling = hhop; o->op_private |= OPpEVAL_HAS_HH; } @@ -6535,7 +6600,7 @@ Perl_ck_exists(pTHX_ OP *o) 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", + Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine", OP_DESC(o)); op_null(kid); } @@ -6649,7 +6714,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP); SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); GvIN_PAD_on(gv); - PAD_SETSV(kPADOP->op_padix, (SV*) SvREFCNT_inc_simple_NN(gv)); + PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); #else kid->op_sv = SvREFCNT_inc_simple_NN(gv); #endif @@ -6685,7 +6750,7 @@ Perl_ck_ftst(pTHX_ OP *o) #endif return newop; } - if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o)) + if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) o->op_private |= OPpFT_ACCESS; if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst) && kidtype != OP_STAT && kidtype != OP_LSTAT) @@ -6929,7 +6994,7 @@ Perl_ck_fun(pTHX_ OP *o) namesv = PAD_SVl(targ); SvUPGRADE(namesv, SVt_PV); if (*name != '$') - sv_setpvn(namesv, "$", 1); + sv_setpvs(namesv, "$"); sv_catpvn(namesv, name, len); } } @@ -7012,7 +7077,7 @@ Perl_ck_glob(pTHX_ OP *o) gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV); glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV); GvCV(gv) = GvCV(glob_gv); - SvREFCNT_inc_void((SV*)GvCV(gv)); + SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv))); GvIMPORTED_CV_on(gv); LEAVE; } @@ -7124,15 +7189,6 @@ Perl_ck_index(pTHX_ OP *o) } OP * -Perl_ck_lengthconst(pTHX_ OP *o) -{ - PERL_ARGS_ASSERT_CK_LENGTHCONST; - - /* XXX length optimization goes here */ - return ck_fun(o); -} - -OP * Perl_ck_lfun(pTHX_ OP *o) { const OPCODE type = o->op_type; @@ -7403,7 +7459,9 @@ Perl_ck_open(pTHX_ OP *o) if (table) { SV **svp = hv_fetchs(table, "open_IN", FALSE); if (svp && *svp) { - const I32 mode = mode_from_discipline(*svp); + STRLEN len = 0; + const char *d = SvPV_const(*svp, len); + const I32 mode = mode_from_discipline(d, len); if (mode & O_BINARY) o->op_private |= OPpOPEN_IN_RAW; else if (mode & O_TEXT) @@ -7412,7 +7470,9 @@ Perl_ck_open(pTHX_ OP *o) svp = hv_fetchs(table, "open_OUT", FALSE); if (svp && *svp) { - const I32 mode = mode_from_discipline(*svp); + STRLEN len = 0; + const char *d = SvPV_const(*svp, len); + const I32 mode = mode_from_discipline(d, len); if (mode & O_BINARY) o->op_private |= OPpOPEN_OUT_RAW; else if (mode & O_TEXT) @@ -7545,14 +7605,29 @@ OP * Perl_ck_return(pTHX_ OP *o) { dVAR; + OP *kid; PERL_ARGS_ASSERT_CK_RETURN; + kid = cLISTOPo->op_first->op_sibling; if (CvLVALUE(PL_compcv)) { - OP *kid; - for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling) + for (; kid; kid = kid->op_sibling) mod(kid, OP_LEAVESUBLV); + } else { + for (; kid; kid = kid->op_sibling) + if ((kid->op_type == OP_NULL) + && ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) { + /* This is a do block */ + OP *op = kUNOP->op_first; + if (op->op_type == OP_LEAVE && op->op_flags & OPf_KIDS) { + op = cUNOPx(op)->op_first; + assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL)); + /* Force the use of the caller's context */ + op->op_flags |= OPf_SPECIAL; + } + } } + return o; } @@ -7589,20 +7664,15 @@ Perl_ck_shift(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_SHIFT; if (!(o->op_flags & OPf_KIDS)) { - OP *argop; - /* FIXME - this can be refactored to reduce code in #ifdefs */ -#ifdef PERL_MAD - OP * const oldo = o; -#else - op_free(o); -#endif - argop = newUNOP(OP_RV2AV, 0, + OP *argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv))); #ifdef PERL_MAD + OP * const oldo = o; o = newUNOP(type, 0, scalar(argop)); op_getmad(oldo,o,'O'); return o; #else + op_free(o); return newUNOP(type, 0, scalar(argop)); #endif } @@ -7835,7 +7905,7 @@ Perl_ck_join(pTHX_ OP *o) if (kid && kid->op_type == OP_MATCH) { if (ckWARN(WARN_SYNTAX)) { const REGEXP *re = PM_GETRE(kPMOP); - const char *pmstr = re ? RX_PRECOMP(re) : "STRING"; + const char *pmstr = re ? RX_PRECOMP_const(re) : "STRING"; const STRLEN len = re ? RX_PRELEN(re) : 6; Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "/%.*s/ should probably be written as \"%.*s\"", @@ -7881,7 +7951,7 @@ Perl_ck_subr(pTHX_ OP *o) if (SvPOK(cv)) { STRLEN len; namegv = CvANON(cv) ? gv : CvGV(cv); - proto = SvPV((SV*)cv, len); + proto = SvPV(MUTABLE_SV(cv), len); proto_end = proto + len; } } @@ -8003,7 +8073,7 @@ Perl_ck_subr(pTHX_ OP *o) const char *p = proto; const char *const end = proto; contextclass = 0; - while (*--p != '['); + while (*--p != '[') {} bad_type(arg, Perl_form(aTHX_ "one of %.*s", (int)(end - p), p), gv_ename(namegv), o3); @@ -8234,20 +8304,21 @@ Perl_peep(pTHX_ register OP *o) if (cSVOPo->op_private & OPpCONST_STRICT) no_bareword_allowed(o); #ifdef USE_ITHREADS + case OP_HINTSEVAL: case OP_METHOD_NAMED: /* Relocate sv to the pad for thread safety. * Despite being a "constant", the SV is written to, * for reference counts, sv_upgrade() etc. */ if (cSVOP->op_sv) { const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP); - if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) { + if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) { /* If op_sv is already a PADTMP then it is being used by * some pad, so make a copy. */ sv_setsv(PAD_SVl(ix),cSVOPo->op_sv); SvREADONLY_on(PAD_SVl(ix)); SvREFCNT_dec(cSVOPo->op_sv); } - else if (o->op_type == OP_CONST + else if (o->op_type != OP_METHOD_NAMED && cSVOPo->op_sv == &PL_sv_undef) { /* PL_sv_undef is hack - it's unsafe to store it in the AV that is the pad, because av_fetch treats values of @@ -8458,7 +8529,7 @@ Perl_peep(pTHX_ register OP *o) /* Make the CONST have a shared SV */ svp = cSVOPx_svp(((BINOP*)o)->op_last); - if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) { + if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) { key = SvPV_const(sv, keylen); lexname = newSVpvn_share(key, SvUTF8(sv) ? -(I32)keylen : (I32)keylen, @@ -8863,15 +8934,20 @@ const_sv_xsub(pTHX_ CV* cv) { dVAR; dXSARGS; + SV *const sv = MUTABLE_SV(XSANY.any_ptr); if (items != 0) { NOOP; #if 0 + /* diag_listed_as: SKIPME */ Perl_croak(aTHX_ "usage: %s::%s()", HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); #endif } + if (!sv) { + XSRETURN(0); + } EXTEND(sp, 1); - ST(0) = (SV*)XSANY.any_ptr; + ST(0) = sv; XSRETURN(1); }