X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=d7a523473bda11af5696fda9a30d7a8e1f496e84;hb=d2d1d4de13bedc11af82b2ca4fd580671530195c;hp=4611dca587743d3208d41e1aebb17e3cf214eedc;hpb=9b38784150c0aca5746105b5f00bfc653322bcd1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 4611dca..d7a5234 100644 --- a/op.c +++ b/op.c @@ -1540,12 +1540,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: @@ -4571,8 +4576,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) && o2->op_private & OPpLVAL_INTRO && !(o2->op_private & OPpPAD_STATE)) { - Perl_ck_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; @@ -4784,7 +4789,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) ); @@ -4793,7 +4800,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); @@ -4846,7 +4853,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) ); @@ -4855,7 +4864,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); @@ -6265,7 +6274,7 @@ Perl_newAVREF(pTHX_ OP *o) return o; } else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) { - Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "Using an array as a reference is deprecated"); } return newUNOP(OP_RV2AV, 0, scalar(o)); @@ -6292,7 +6301,7 @@ Perl_newHVREF(pTHX_ OP *o) return o; } else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) { - Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "Using a hash as a reference is deprecated"); } return newUNOP(OP_RV2HV, 0, scalar(o)); @@ -6845,7 +6854,7 @@ Perl_ck_fun(pTHX_ OP *o) { OP * const newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) )); - Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + 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 @@ -6867,7 +6876,7 @@ Perl_ck_fun(pTHX_ OP *o) { OP * const newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) )); - Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + 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 @@ -7215,21 +7224,16 @@ 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_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "defined(@array) is deprecated"); - Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + 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_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "defined(%%hash) is deprecated"); - Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), "\t(Maybe you should just omit the defined()?)\n"); break; default: @@ -8276,6 +8280,33 @@ 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 */ +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 */ @@ -8462,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: