X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=d4f6fb3ada7690f5e5855d1c1d996b3d15c052b2;hb=997e7b23827e884e717eba50697f2e5714034828;hp=64331ee526d7ffc1ffbbb39765107c45ef4a52f9;hpb=1665bca07dc555ad9940968da9d6f7b158ac2a47;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 64331ee..d4f6fb3 100644 --- a/op.c +++ b/op.c @@ -1,3 +1,4 @@ +#line 2 "op.c" /* op.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, @@ -371,7 +372,7 @@ S_no_bareword_allowed(pTHX_ const OP *o) /* "register" allocation */ PADOFFSET -Perl_allocmy(pTHX_ const char *const name) +Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) { dVAR; PADOFFSET off; @@ -379,38 +380,43 @@ Perl_allocmy(pTHX_ const char *const name) PERL_ARGS_ASSERT_ALLOCMY; + if (flags) + Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf, + (UV)flags); + + /* Until we're using the length for real, cross check that we're being + told the truth. */ + assert(strlen(name) == len); + /* complain about "my $" etc etc */ - if (*name && + if (len && !(is_our || isALPHA(name[1]) || (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) || - (name[1] == '_' && (*name == '$' || name[2])))) + (name[1] == '_' && (*name == '$' || len > 2)))) { /* name[2] is true if strlen(name) > 2 */ if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) { - yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"", - name[0], toCTRL(name[1]), name + 2, + yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"", + name[0], toCTRL(name[1]), (int)(len - 2), name + 2, PL_parser->in_my == KEY_state ? "state" : "my")); } else { - yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name, + yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name, PL_parser->in_my == KEY_state ? "state" : "my")); } } - /* check for duplicate declaration */ - pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash)); - /* allocate a spare slot and store the name in that slot */ - off = pad_add_name(name, + off = pad_add_name(name, len, + is_our ? padadd_OUR : + PL_parser->in_my == KEY_state ? padadd_STATE : 0, PL_parser->in_my_stash, (is_our /* $_ is always in main::, even with our */ ? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash) : NULL - ), - 0, /* not fake */ - PL_parser->in_my == KEY_state + ) ); /* anon sub prototypes contains state vars should always be cloned, * otherwise the state var would be shared between anon subs */ @@ -569,6 +575,29 @@ Perl_op_clear(pTHX_ OP *o) case OP_AELEMFAST: if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) { /* not an OP_PADAV replacement */ + GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV) +#ifdef USE_ITHREADS + && PL_curpad +#endif + ? cGVOPo_gv : NULL; + /* It's possible during global destruction that the GV is freed + before the optree. Whilst the SvREFCNT_inc is happy to bump from + 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0 + will trigger an assertion failure, because the entry to sv_clear + checks that the scalar is not already freed. A check of for + !SvIS_FREED(gv) turns out to be invalid, because during global + destruction the reference count can be forced down to zero + (with SVf_BREAK set). In which case raising to 1 and then + dropping to 0 triggers cleanup before it should happen. I + *think* that this might actually be a general, systematic, + weakness of the whole idea of SVf_BREAK, in that code *is* + allowed to raise and lower references during global destruction, + so any *valid* code that happens to do this during global + destruction might well trigger premature cleanup. */ + bool still_valid = gv && SvREFCNT(gv); + + if (still_valid) + SvREFCNT_inc_simple_void(gv); #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { /* No GvIN_PAD_off(cGVOPo_gv) here, because other references @@ -580,6 +609,12 @@ Perl_op_clear(pTHX_ OP *o) SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = NULL; #endif + if (still_valid) { + int try_downgrade = SvREFCNT(gv) == 2; + SvREFCNT_dec(gv); + if (try_downgrade) + gv_try_downgrade(gv); + } } break; case OP_METHOD_NAMED: @@ -908,8 +943,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; @@ -951,7 +985,7 @@ Perl_scalarvoid(pTHX_ OP *o) want = o->op_flags & OPf_WANT; if ((want && want != OPf_WANT_SCALAR) || (PL_parser && PL_parser->error_count) - || o->op_type == OP_RETURN) + || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE) { return o; } @@ -1181,15 +1215,11 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_ENTEREVAL: scalarkids(o); break; - case OP_REQUIRE: - /* all requires must return a boolean value */ - o->op_flags &= ~OPf_WANT; - /* FALL THROUGH */ case OP_SCALAR: return scalar(o); } - 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; } @@ -1273,10 +1303,6 @@ Perl_list(pTHX_ OP *o) } PL_curcop = &PL_compiling; break; - case OP_REQUIRE: - /* all requires must return a boolean value */ - o->op_flags &= ~OPf_WANT; - return scalar(o); } return o; } @@ -1541,12 +1567,17 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_DBSTATE: PL_modcount = RETURN_UNLIMITED_NUMBER; break; + case OP_AV2ARYLEN: + PL_hints |= HINT_BLOCK_SCOPE; + if (type == OP_LEAVESUBLV) + o->op_private |= OPpMAYBE_LVSUB; + PL_modcount++; + break; case OP_RV2SV: ref(cUNOPo->op_first, o->op_type); localize = 1; /* FALL THROUGH */ case OP_GV: - case OP_AV2ARYLEN: PL_hints |= HINT_BLOCK_SCOPE; case OP_SASSIGN: case OP_ANDASSIGN: @@ -1667,10 +1698,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 @@ -2278,7 +2307,7 @@ STATIC OP * S_newDEFSVOP(pTHX) { dVAR; - const PADOFFSET offset = pad_findmy("$_"); + const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); } @@ -2983,6 +3012,8 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) dVAR; LISTOP *listop; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP); + NewOp(1101, listop, 1, LISTOP); listop->op_type = (OPCODE)type; @@ -3016,6 +3047,12 @@ Perl_newOP(pTHX_ I32 type, I32 flags) { dVAR; OP *o; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); + NewOp(1101, o, 1, OP); o->op_type = (OPCODE)type; o->op_ppaddr = PL_ppaddr[type]; @@ -3039,6 +3076,13 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) dVAR; UNOP *unop; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP + || type == OP_SASSIGN + || type == OP_NULL ); + if (!first) first = newOP(OP_STUB, 0); if (PL_opargs[type] & OA_MARK) @@ -3062,6 +3106,10 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last) { dVAR; BINOP *binop; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP + || type == OP_SASSIGN || type == OP_NULL ); + NewOp(1101, binop, 1, BINOP); if (!first) @@ -3432,12 +3480,10 @@ S_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(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) @@ -3459,6 +3505,8 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags) dVAR; PMOP *pmop; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP); + NewOp(1101, pmop, 1, PMOP); pmop->op_type = (OPCODE)type; pmop->op_ppaddr = PL_ppaddr[type]; @@ -3703,6 +3751,10 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) PERL_ARGS_ASSERT_NEWSVOP; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP); + NewOp(1101, svop, 1, SVOP); svop->op_type = (OPCODE)type; svop->op_ppaddr = PL_ppaddr[type]; @@ -3725,6 +3777,10 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) PERL_ARGS_ASSERT_NEWPADOP; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP); + NewOp(1101, padop, 1, PADOP); padop->op_type = (OPCODE)type; padop->op_ppaddr = PL_ppaddr[type]; @@ -3763,6 +3819,10 @@ Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv) { dVAR; PVOP *pvop; + + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP + || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); + NewOp(1101, pvop, 1, PVOP); pvop->op_type = (OPCODE)type; pvop->op_ppaddr = PL_ppaddr[type]; @@ -3820,8 +3880,11 @@ 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); } @@ -4517,6 +4580,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if (type == OP_XOR) /* Not short circuit, but here by precedence. */ return newBINOP(type, flags, scalar(first), scalar(other)); + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP); + scalarboolean(first); /* optimize AND and OR ops that have NOTs as children */ if (first->op_type == OP_NOT @@ -4540,8 +4605,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) 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"); + 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))) { @@ -4571,11 +4636,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; @@ -4787,7 +4851,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) ); @@ -4796,7 +4862,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); @@ -4849,7 +4915,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) ); @@ -4858,7 +4926,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); @@ -4988,7 +5056,7 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP } } else { - const PADOFFSET offset = pad_findmy("$_"); + const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { sv = newGVOP(OP_GV, 0, PL_defgv); } @@ -5070,6 +5138,8 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) PERL_ARGS_ASSERT_NEWLOOPEX; + assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP); + if (type != OP_GOTO || label->op_type == OP_CONST) { /* "last()" means "last" */ if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) @@ -5586,10 +5656,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) maximum a prototype before. */ if (SvTYPE(gv) > SVt_NULL) { if (!SvPOK((const SV *)gv) - && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1) - && ckWARN_d(WARN_PROTOTYPE)) + && !(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((const CV *)gv, NULL, ps, ps_len); } @@ -5731,7 +5800,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (PL_madskills) { if (strEQ(name, "import")) { PL_formfeed = MUTABLE_SV(cv); - Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv); + /* diag_listed_as: SKIPME */ + Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv)); } } GvCVGEN(gv) = 0; @@ -5898,18 +5968,18 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, 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"); + 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"); + 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 @@ -6222,8 +6292,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; @@ -6251,8 +6320,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; @@ -6270,10 +6338,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)); } @@ -6298,10 +6365,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)); } @@ -6368,12 +6434,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; } @@ -6844,20 +6909,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 @@ -6877,10 +6941,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 @@ -7167,7 +7230,7 @@ Perl_ck_grep(pTHX_ OP *o) gwop->op_flags |= OPf_KIDS; gwop->op_other = LINKLIST(kid); kid->op_next = (OP*)gwop; - offset = pad_findmy("$_"); + offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { o->op_private = gwop->op_private = 0; gwop->op_targ = pad_alloc(type, SVs_PADTMP); @@ -7216,7 +7279,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 @@ -7226,22 +7289,17 @@ 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 - if (defined %stash::) - to work. Do not break Tk. - */ - 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 */ @@ -7412,7 +7470,7 @@ Perl_ck_match(pTHX_ OP *o) PERL_ARGS_ASSERT_CK_MATCH; if (o->op_type != OP_QR && PL_compcv) { - const PADOFFSET offset = pad_findmy("$_"); + const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0); if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) { o->op_targ = offset; o->op_private |= OPpTARGET_MY; @@ -7611,7 +7669,7 @@ Perl_ck_require(pTHX_ OP *o) return newop; } - return ck_fun(o); + return scalar(ck_fun(o)); } OP * @@ -7884,9 +7942,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) @@ -7951,22 +8009,29 @@ Perl_ck_subr(pTHX_ OP *o) o->op_private |= OPpENTERSUB_HASTARG; for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ; if (cvop->op_type == OP_RV2CV) { - SVOP* tmpop; o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER); op_null(cvop); /* disable rv2cv */ - tmpop = (SVOP*)((UNOP*)cvop)->op_first; - if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) { - GV *gv = cGVOPx_gv(tmpop); - cv = GvCVu(gv); - if (!cv) - tmpop->op_private |= OPpEARLY_CV; - else { - if (SvPOK(cv)) { - STRLEN len; - namegv = CvANON(cv) ? gv : CvGV(cv); - proto = SvPV(MUTABLE_SV(cv), len); - proto_end = proto + len; - } + if (!(o->op_private & OPpENTERSUB_AMPER)) { + SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first; + GV *gv = NULL; + switch (tmpop->op_type) { + case OP_GV: { + gv = cGVOPx_gv(tmpop); + cv = GvCVu(gv); + if (!cv) + tmpop->op_private |= OPpEARLY_CV; + } break; + case OP_CONST: { + SV *sv = cSVOPx_sv(tmpop); + if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) + cv = (CV*)SvRV(sv); + } break; + } + if (cv && SvPOK(cv)) { + STRLEN len; + namegv = gv && CvANON(cv) ? gv : CvGV(cv); + proto = SvPV(MUTABLE_SV(cv), len); + proto_end = proto + len; } } } @@ -8287,6 +8352,105 @@ Perl_ck_each(pTHX_ OP *o) return ck_fun(o); } +/* caller is supposed to assign the return to the + container of the rep_op var */ +STATIC 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; +} + +/* Checks if o acts as an in-place operator on an array. oright points to the + * beginning of the right-hand side. Returns the left-hand side of the + * assignment if o acts in-place, or NULL otherwise. */ + +STATIC OP * +S_is_inplace_av(pTHX_ OP *o, OP *oright) { + OP *o2; + OP *oleft = NULL; + + PERL_ARGS_ASSERT_IS_INPLACE_AV; + + if (!oright || + (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV) + || oright->op_next != o + || (oright->op_private & OPpLVAL_INTRO) + ) + return NULL; + + /* o2 follows the chain of op_nexts through the LHS of the + * assign (if any) to the aassign op itself */ + o2 = o->op_next; + if (!o2 || o2->op_type != OP_NULL) + return NULL; + o2 = o2->op_next; + if (!o2 || o2->op_type != OP_PUSHMARK) + return NULL; + o2 = o2->op_next; + if (o2 && o2->op_type == OP_GV) + o2 = o2->op_next; + if (!o2 + || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV) + || (o2->op_private & OPpLVAL_INTRO) + ) + return NULL; + oleft = o2; + o2 = o2->op_next; + if (!o2 || o2->op_type != OP_NULL) + return NULL; + o2 = o2->op_next; + if (!o2 || o2->op_type != OP_AASSIGN + || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID) + return NULL; + + /* check that the sort is the first arg on RHS of assign */ + + o2 = cUNOPx(o2)->op_first; + if (!o2 || o2->op_type != OP_NULL) + return NULL; + o2 = cUNOPx(o2)->op_first; + if (!o2 || o2->op_type != OP_PUSHMARK) + return NULL; + if (o2->op_sibling != o) + return NULL; + + /* check the array is the same on both sides */ + if (oleft->op_type == OP_RV2AV) { + if (oright->op_type != OP_RV2AV + || !cUNOPx(oright)->op_first + || cUNOPx(oright)->op_first->op_type != OP_GV + || cGVOPx_gv(cUNOPx(oleft)->op_first) != + cGVOPx_gv(cUNOPx(oright)->op_first) + ) + return NULL; + } + else if (oright->op_type != OP_PADAV + || oright->op_targ != oleft->op_targ + ) + return NULL; + + return oleft; +} + /* 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 */ @@ -8473,12 +8637,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: @@ -8672,62 +8891,8 @@ Perl_peep(pTHX_ register OP *o) oright = cUNOPx(oright)->op_sibling; } - if (!oright || - (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV) - || oright->op_next != o - || (oright->op_private & OPpLVAL_INTRO) - ) - break; - - /* o2 follows the chain of op_nexts through the LHS of the - * assign (if any) to the aassign op itself */ - o2 = o->op_next; - if (!o2 || o2->op_type != OP_NULL) - break; - o2 = o2->op_next; - if (!o2 || o2->op_type != OP_PUSHMARK) - break; - o2 = o2->op_next; - if (o2 && o2->op_type == OP_GV) - o2 = o2->op_next; - if (!o2 - || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV) - || (o2->op_private & OPpLVAL_INTRO) - ) - break; - oleft = o2; - o2 = o2->op_next; - if (!o2 || o2->op_type != OP_NULL) - break; - o2 = o2->op_next; - if (!o2 || o2->op_type != OP_AASSIGN - || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID) - break; - - /* check that the sort is the first arg on RHS of assign */ - - o2 = cUNOPx(o2)->op_first; - if (!o2 || o2->op_type != OP_NULL) - break; - o2 = cUNOPx(o2)->op_first; - if (!o2 || o2->op_type != OP_PUSHMARK) - break; - if (o2->op_sibling != o) - break; - - /* check the array is the same on both sides */ - if (oleft->op_type == OP_RV2AV) { - if (oright->op_type != OP_RV2AV - || !cUNOPx(oright)->op_first - || cUNOPx(oright)->op_first->op_type != OP_GV - || cGVOPx_gv(cUNOPx(oleft)->op_first) != - cGVOPx_gv(cUNOPx(oright)->op_first) - ) - break; - } - else if (oright->op_type != OP_PADAV - || oright->op_targ != oleft->op_targ - ) + oleft = is_inplace_av(o, oright); + if (!oleft) break; /* transfer MODishness etc from LHS arg to RHS arg */ @@ -8754,8 +8919,36 @@ Perl_peep(pTHX_ register OP *o) case OP_REVERSE: { OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av; OP *gvop = NULL; + OP *oleft, *oright; LISTOP *enter, *exlist; + /* @a = reverse @a */ + if ((oright = cLISTOPo->op_first) + && (oright->op_type == OP_PUSHMARK) + && (oright = oright->op_sibling) + && (oleft = is_inplace_av(o, oright))) { + OP *o2; + + /* transfer MODishness etc from LHS arg to RHS arg */ + oright->op_flags = oleft->op_flags; + o->op_private |= OPpREVERSE_INPLACE; + + /* excise push->gv->rv2av->null->aassign */ + o2 = o->op_next->op_next; + op_null(o2); /* PUSHMARK */ + o2 = o2->op_next; + if (o2->op_type == OP_GV) { + op_null(o2); /* GV */ + o2 = o2->op_next; + } + op_null(o2); /* RV2AV or PADAV */ + o2 = o2->op_next->op_next; + op_null(o2); /* AASSIGN */ + + o->op_next = o2->op_next; + break; + } + enter = (LISTOP *) o->op_next; if (!enter) break;