X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=e629a42647a9fe8164624d2b6d6c977156ccae21;hb=114c60ecb1f775ef1deb4fdc8fb8e3a6f343d13d;hp=21aa23d9422e68e0d9f146f3595deacfcd6c2dec;hpb=61a59f30bcebf88ce17229ad2276090c32ad7c1f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 21aa23d..e629a42 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; @@ -631,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: @@ -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: @@ -908,8 +908,7 @@ Perl_scalar(pTHX_ OP *o) PL_curcop = &PL_compiling; break; case OP_SORT: - if (ckWARN(WARN_VOID)) - Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); break; } return o; @@ -1134,6 +1133,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: @@ -1173,20 +1186,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); + if (useless) + Perl_ck_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; @@ -1273,8 +1280,8 @@ Perl_list(pTHX_ OP *o) return o; } -OP * -Perl_scalarseq(pTHX_ OP *o) +static OP * +S_scalarseq(pTHX_ OP *o) { dVAR; if (o) { @@ -1659,10 +1666,8 @@ Perl_mod(pTHX_ OP *o, I32 type) case 0: break; case -1: - if (ckWARN(WARN_SYNTAX)) { - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Useless localization of %s", OP_DESC(o)); - } + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Useless localization of %s", OP_DESC(o)); } } else if (type != OP_GREPSTART && type != OP_ENTERSUB @@ -1746,8 +1751,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; @@ -2011,7 +2016,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))); } @@ -2057,8 +2062,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; @@ -2132,14 +2137,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; @@ -2326,14 +2323,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); } } } @@ -2414,8 +2410,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; @@ -2517,7 +2513,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: @@ -2545,9 +2541,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; @@ -2555,8 +2551,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; @@ -2761,7 +2757,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) { @@ -2918,7 +2914,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); @@ -2952,7 +2948,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"); @@ -2969,8 +2965,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); @@ -3107,8 +3103,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; @@ -3330,12 +3326,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 @@ -3343,7 +3340,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) @@ -3431,6 +3428,13 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } } } + + if(del && rlen == tlen) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); + } else if(rlen > tlen) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); + } + if (grows) o->op_private |= OPpTRANS_GROWS; #ifdef PERL_MAD @@ -3807,6 +3811,18 @@ Perl_package(pTHX_ OP *o) #endif } +void +Perl_package_version( pTHX_ OP *v ) +{ + dVAR; + U32 savehints = PL_hints; + PERL_ARGS_ASSERT_PACKAGE_VERSION; + PL_hints &= ~HINT_STRICT_VARS; + sv_setsv( GvSV(gv_fetchpvs("VERSION", GV_ADDMULTI, SVt_PV)), cSVOPx(v)->op_sv ); + PL_hints = savehints; + op_free(v); +} + #ifdef PERL_MAD OP* #else @@ -3845,7 +3861,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)); @@ -3943,7 +3959,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 */ @@ -4246,7 +4266,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; @@ -4294,7 +4314,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; @@ -4313,7 +4333,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); } } @@ -4335,6 +4355,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) PL_eval_start = 0; else { 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; @@ -4404,7 +4425,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); @@ -4415,6 +4437,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); } @@ -4430,46 +4454,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)) - 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))) { + /* 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)) + Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); + 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; @@ -4480,6 +4553,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 { @@ -4494,11 +4569,10 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV || o2->op_type == OP_PADHV) && o2->op_private & OPpLVAL_INTRO - && !(o2->op_private & OPpPAD_STATE) - && ckWARN(WARN_DEPRECATED)) + && !(o2->op_private & OPpPAD_STATE)) { - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), - "Deprecated use of my() in false conditional"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "Deprecated use of my() in false conditional"); } *otherp = NULL; @@ -4576,7 +4650,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; @@ -4589,6 +4663,7 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop) LOGOP *logop; OP *start; OP *o; + OP *cstop; PERL_ARGS_ASSERT_NEWCONDOP; @@ -4598,14 +4673,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. */ @@ -4616,6 +4691,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); @@ -4707,7 +4784,9 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) if (expr) { if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv)) return block; /* do {} while 0 does once */ - if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB + if (expr->op_type == OP_READLINE + || expr->op_type == OP_READDIR + || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); @@ -4716,7 +4795,7 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block) const OP * const k2 = k1 ? k1->op_sibling : NULL; switch (expr->op_type) { case OP_NULL: - if (k2 && k2->op_type == OP_READLINE + if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) expr = newUNOP(OP_DEFINED, 0, expr); @@ -4769,7 +4848,9 @@ whileline, OP *expr, OP *block, OP *cont, I32 has_my) PERL_UNUSED_ARG(debuggable); if (expr) { - if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB + if (expr->op_type == OP_READLINE + || expr->op_type == OP_READDIR + || expr->op_type == OP_GLOB || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) { expr = newUNOP(OP_DEFINED, 0, newASSIGNOP(0, newDEFSVOP(), 0, expr) ); @@ -4778,7 +4859,7 @@ whileline, OP *expr, OP *block, OP *cont, I32 has_my) const OP * const k2 = (k1) ? k1->op_sibling : NULL; switch (expr->op_type) { case OP_NULL: - if (k2 && k2->op_type == OP_READLINE + if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR) && (k2->op_flags & OPf_STACKED) && ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR)) expr = newUNOP(OP_DEFINED, 0, expr); @@ -5110,6 +5191,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: @@ -5122,10 +5204,13 @@ S_looks_like_bool(pTHX_ const OP *o) o->op_flags & OPf_KIDS && looks_like_bool(cUNOPo->op_first)); + case OP_SCALAR: + return looks_like_bool(cUNOPo->op_first); + + 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: @@ -5150,6 +5235,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: @@ -5158,7 +5245,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; @@ -5243,7 +5332,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); @@ -5255,7 +5344,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)) { @@ -5315,14 +5404,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. @@ -5443,7 +5532,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; @@ -5459,6 +5547,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); @@ -5467,20 +5556,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) @@ -5494,17 +5586,17 @@ 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) - && ckWARN_d(WARN_PROTOTYPE)) + if (!SvPOK((const SV *)gv) + && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)) { - Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype"); + Perl_ck_warner_d(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; @@ -5513,12 +5605,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 @@ -5532,12 +5618,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 @@ -5591,7 +5671,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); @@ -5615,69 +5695,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; @@ -5685,7 +5730,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); } } @@ -5693,12 +5738,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); @@ -5723,6 +5775,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)); @@ -5759,7 +5817,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(); @@ -5781,7 +5839,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); } } } @@ -5814,7 +5872,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); @@ -5828,31 +5886,31 @@ 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; } else if (*name == 'C') { if (strEQ(name, "CHECK")) { - 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); + if (PL_main_start) + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run CHECK block"); + Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); } else return; } else if (*name == 'I') { if (strEQ(name, "INIT")) { - 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); + if (PL_main_start) + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run INIT block"); + Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); } else return; @@ -5869,6 +5927,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 */ @@ -5878,14 +5941,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; @@ -5913,10 +5973,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) @@ -5958,7 +6018,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 @@ -5969,7 +6029,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; } @@ -6033,7 +6093,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; @@ -6072,20 +6132,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); @@ -6140,7 +6199,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 * @@ -6163,8 +6222,7 @@ Perl_oopsAV(pTHX_ OP *o) break; default: - if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); break; } return o; @@ -6192,8 +6250,7 @@ Perl_oopsHV(pTHX_ OP *o) break; default: - if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV"); break; } return o; @@ -6211,10 +6268,9 @@ 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_ packWARN(WARN_DEPRECATED), - "Using an array as a reference is deprecated"); + else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "Using an array as a reference is deprecated"); } return newUNOP(OP_RV2AV, 0, scalar(o)); } @@ -6239,10 +6295,9 @@ 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_ packWARN(WARN_DEPRECATED), - "Using a hash as a reference is deprecated"); + else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "Using a hash as a reference is deprecated"); } return newUNOP(OP_RV2HV, 0, scalar(o)); } @@ -6309,12 +6364,11 @@ Perl_ck_bitop(pTHX_ OP *o) (left->op_flags & OPf_PARENS) == 0) || (OP_IS_NUMCOMPARE(right->op_type) && (right->op_flags & OPf_PARENS) == 0)) - if (ckWARN(WARN_PRECEDENCE)) - Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE), - "Possible precedence problem on bitwise %c operator", - o->op_type == OP_BIT_OR ? '|' - : o->op_type == OP_BIT_AND ? '&' : '^' - ); + Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE), + "Possible precedence problem on bitwise %c operator", + o->op_type == OP_BIT_OR ? '|' + : o->op_type == OP_BIT_AND ? '&' : '^' + ); } return o; } @@ -6390,6 +6444,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; @@ -6463,6 +6519,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]; @@ -6488,7 +6546,7 @@ Perl_ck_eval(pTHX_ OP *o) if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) { /* Store a copy of %^H that pp_entereval can pick up. */ OP *hhop = newSVOP(OP_HINTSEVAL, 0, - (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv))); + MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)))); cUNOPo->op_first->op_sibling = hhop; o->op_private |= OPpEVAL_HAS_HH; } @@ -6550,7 +6608,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); } @@ -6664,7 +6722,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 @@ -6781,20 +6839,19 @@ Perl_ck_fun(pTHX_ OP *o) break; case OA_AVREF: if ((type == OP_PUSH || type == OP_UNSHIFT) - && !kid->op_sibling && ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Useless use of %s with no values", - PL_op_desc[type]); + && !kid->op_sibling) + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Useless use of %s with no values", + PL_op_desc[type]); if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { OP * const newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) )); - if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", - SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", + SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); #ifdef PERL_MAD op_getmad(kid,newop,'K'); #else @@ -6814,10 +6871,9 @@ Perl_ck_fun(pTHX_ OP *o) { OP * const newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) )); - if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", - SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", + SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); #ifdef PERL_MAD op_getmad(kid,newop,'K'); #else @@ -6944,7 +7000,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); } } @@ -7027,7 +7083,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; } @@ -7153,7 +7209,7 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ { PERL_ARGS_ASSERT_CK_DEFINED; - if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) { + if ((o->op_flags & OPf_KIDS)) { switch (cUNOPo->op_first->op_type) { case OP_RV2AV: /* This is needed for @@ -7163,10 +7219,10 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "defined(@array) is deprecated"); - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "\t(Maybe you should just omit the defined()?)\n"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "defined(@array) is deprecated"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "\t(Maybe you should just omit the defined()?)\n"); break; case OP_RV2HV: /* This is needed for @@ -7175,10 +7231,10 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ */ break; /* Globals via GV can be undef */ case OP_PADHV: - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "defined(%%hash) is deprecated"); - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "\t(Maybe you should just omit the defined()?)\n"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "defined(%%hash) is deprecated"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "\t(Maybe you should just omit the defined()?)\n"); break; default: /* no warning */ @@ -7409,7 +7465,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) @@ -7418,7 +7476,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) @@ -7551,14 +7611,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; } @@ -7595,20 +7670,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 } @@ -7807,9 +7877,9 @@ Perl_ck_split(pTHX_ OP *o) kid->op_type = OP_PUSHRE; kid->op_ppaddr = PL_ppaddr[OP_PUSHRE]; scalar(kid); - if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) { - Perl_warner(aTHX_ packWARN(WARN_REGEXP), - "Use of /g modifier is meaningless in split"); + if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { + Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), + "Use of /g modifier is meaningless in split"); } if (!kid->op_sibling) @@ -7841,7 +7911,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\"", @@ -7887,7 +7957,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; } } @@ -8009,7 +8079,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); @@ -8189,25 +8259,54 @@ OP * Perl_ck_each(pTHX_ OP *o) { dVAR; - OP *kid = cLISTOPo->op_first; + OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL; PERL_ARGS_ASSERT_CK_EACH; - if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) { - const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH - : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES; - o->op_type = new_type; - o->op_ppaddr = PL_ppaddr[new_type]; - } - else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV - || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) - )) { - bad_type(1, "hash or array", PL_op_desc[o->op_type], kid); - return o; + if (kid) { + if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) { + const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH + : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES; + o->op_type = new_type; + o->op_ppaddr = PL_ppaddr[new_type]; + } + else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV + || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE) + )) { + bad_type(1, "hash or array", PL_op_desc[o->op_type], kid); + return o; + } } return ck_fun(o); } +/* caller is supposed to assign the return to the + container of the rep_op var */ +OP * +S_opt_scalarhv(pTHX_ OP *rep_op) { + UNOP *unop; + + PERL_ARGS_ASSERT_OPT_SCALARHV; + + NewOp(1101, unop, 1, UNOP); + unop->op_type = (OPCODE)OP_BOOLKEYS; + unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS]; + unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS ); + unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8)); + unop->op_first = rep_op; + unop->op_next = rep_op->op_next; + rep_op->op_next = (OP*)unop; + rep_op->op_flags|=(OPf_REF | OPf_MOD); + unop->op_sibling = rep_op->op_sibling; + rep_op->op_sibling = NULL; + /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */ + if (rep_op->op_type == OP_PADHV) { + rep_op->op_flags &= ~OPf_WANT_SCALAR; + rep_op->op_flags |= OPf_WANT_LIST; + } + return (OP*)unop; +} + /* A peephole optimizer. We visit the ops in the order they're to execute. * See the comments at the top of this file for more details about when * peep() is called */ @@ -8394,12 +8493,67 @@ Perl_peep(pTHX_ register OP *o) } break; + + { + OP *fop; + OP *sop; + + case OP_NOT: + fop = cUNOP->op_first; + sop = NULL; + goto stitch_keys; + break; - case OP_MAPWHILE: - case OP_GREPWHILE: - case OP_AND: + case OP_AND: case OP_OR: case OP_DOR: + fop = cLOGOP->op_first; + sop = fop->op_sibling; + while (cLOGOP->op_other->op_type == OP_NULL) + cLOGOP->op_other = cLOGOP->op_other->op_next; + peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */ + + stitch_keys: + o->op_opt = 1; + if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV) + || ( sop && + (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV) + ) + ){ + OP * nop = o; + OP * lop = o; + if (!(nop->op_flags && OPf_WANT_VOID)) { + while (nop && nop->op_next) { + switch (nop->op_next->op_type) { + case OP_NOT: + case OP_AND: + case OP_OR: + case OP_DOR: + lop = nop = nop->op_next; + break; + case OP_NULL: + nop = nop->op_next; + break; + default: + nop = NULL; + break; + } + } + } + if (lop->op_flags && OPf_WANT_VOID) { + if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV) + cLOGOP->op_first = opt_scalarhv(fop); + if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)) + cLOGOP->op_first->op_sibling = opt_scalarhv(sop); + } + } + + + break; + } + + case OP_MAPWHILE: + case OP_GREPWHILE: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_DORASSIGN: @@ -8465,7 +8619,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, @@ -8870,15 +9024,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); }