This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix line numbers inside here-docs
[perl5.git] / op.c
diff --git a/op.c b/op.c
index 40c5be6..f807d33 100644 (file)
--- a/op.c
+++ b/op.c
@@ -631,10 +631,6 @@ Perl_alloccopstash(pTHX_ HV *hv)
 static void
 S_op_destroy(pTHX_ OP *o)
 {
-    if (o->op_latefree) {
-       o->op_latefreed = 1;
-       return;
-    }
     FreeOp(o);
 }
 
@@ -659,11 +655,6 @@ Perl_op_free(pTHX_ OP *o)
        may be freed before their parents. */
     if (!o || o->op_type == OP_FREED)
        return;
-    if (o->op_latefreed) {
-       if (o->op_latefree)
-           return;
-       goto do_free;
-    }
 
     type = o->op_type;
     if (o->op_private & OPpREFCOUNTED) {
@@ -698,33 +689,24 @@ Perl_op_free(pTHX_ OP *o)
     CALL_OPFREEHOOK(o);
 
     if (o->op_flags & OPf_KIDS) {
-        register OP *kid, *nextkid;
+        OP *kid, *nextkid;
        for (kid = cUNOPo->op_first; kid; kid = nextkid) {
            nextkid = kid->op_sibling; /* Get before next freeing kid */
            op_free(kid);
        }
     }
+    if (type == OP_NULL)
+       type = (OPCODE)o->op_targ;
 
     Slab_to_rw(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
-           || (type == OP_NULL /* the COP might have been null'ed */
-               && ((OPCODE)o->op_targ == OP_NEXTSTATE
-                   || (OPCODE)o->op_targ == OP_DBSTATE))) {
+    if (type == OP_NEXTSTATE || type == 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;
-       return;
-    }
-  do_free:
     FreeOp(o);
 #ifdef DEBUG_LEAKING_SCALARS
     if (PL_op == o)
@@ -826,6 +808,7 @@ Perl_op_clear(pTHX_ OP *o)
         }
 #endif
        break;
+    case OP_DUMP:
     case OP_GOTO:
     case OP_NEXT:
     case OP_LAST:
@@ -836,6 +819,7 @@ Perl_op_clear(pTHX_ OP *o)
     case OP_TRANS:
     case OP_TRANSR:
        if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
+           assert(o->op_type == OP_TRANS || o->op_type == OP_TRANSR);
 #ifdef USE_ITHREADS
            if (cPADOPo->op_padix > 0) {
                pad_swipe(cPADOPo->op_padix, TRUE);
@@ -1059,7 +1043,7 @@ Perl_op_linklist(pTHX_ OP *o)
     /* establish postfix order */
     first = cUNOPo->op_first;
     if (first) {
-        register OP *kid;
+        OP *kid;
        o->op_next = LINKLIST(first);
        kid = first;
        for (;;) {
@@ -1181,8 +1165,8 @@ Perl_scalarvoid(pTHX_ OP *o)
 {
     dVAR;
     OP *kid;
+    SV *useless_sv = NULL;
     const char* useless = NULL;
-    U32 useless_is_utf8 = 0;
     SV* sv;
     U8 want;
 
@@ -1383,19 +1367,19 @@ Perl_scalarvoid(pTHX_ OP *o)
                            useless = NULL;
                    else {
                        SV * const dsv = newSVpvs("");
-                       SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
-                                   "a constant (%s)",
-                                   pv_pretty(dsv, maybe_macro, SvCUR(sv), 32, NULL, NULL,
-                                           PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_NOCLEAR | PERL_PV_ESCAPE_UNI_DETECT )));
+                       useless_sv
+                            = Perl_newSVpvf(aTHX_
+                                            "a constant (%s)",
+                                            pv_pretty(dsv, maybe_macro,
+                                                      SvCUR(sv), 32, NULL, NULL,
+                                                      PERL_PV_PRETTY_DUMP
+                                                      | PERL_PV_ESCAPE_NOCLEAR
+                                                      | PERL_PV_ESCAPE_UNI_DETECT));
                        SvREFCNT_dec(dsv);
-                       useless = SvPV_nolen(msv);
-                       useless_is_utf8 = SvUTF8(msv);
                    }
                }
                else if (SvOK(sv)) {
-                   SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
-                               "a constant (%"SVf")", sv));
-                   useless = SvPV_nolen(msv);
+                   useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
                }
                else
                    useless = "a constant (undef)";
@@ -1522,10 +1506,18 @@ Perl_scalarvoid(pTHX_ OP *o)
     case OP_SCALAR:
        return scalar(o);
     }
-    if (useless)
-       Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %"SVf" in void context",
-                       newSVpvn_flags(useless, strlen(useless),
-                            SVs_TEMP | ( useless_is_utf8 ? SVf_UTF8 : 0 )));
+
+    if (useless_sv) {
+        /* mortalise it, in case warnings are fatal.  */
+        Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+                       "Useless use of %"SVf" in void context",
+                       sv_2mortal(useless_sv));
+    }
+    else if (useless) {
+       Perl_ck_warner(aTHX_ packWARN(WARN_VOID),
+                      "Useless use of %s in void context",
+                      useless);
+    }
     return o;
 }
 
@@ -2851,6 +2843,18 @@ Perl_op_scope(pTHX_ OP *o)
     return o;
 }
 
+OP *
+Perl_op_unscope(pTHX_ OP *o)
+{
+    if (o && o->op_type == OP_LINESEQ) {
+       OP *kid = cLISTOPo->op_first;
+       for(; kid; kid = kid->op_sibling)
+           if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+               op_null(kid);
+    }
+    return o;
+}
+
 int
 Perl_block_start(pTHX_ int full)
 {
@@ -3107,7 +3111,7 @@ static OP *
 S_fold_constants(pTHX_ register OP *o)
 {
     dVAR;
-    register OP * VOL curop;
+    OP * VOL curop;
     OP *newop;
     VOL I32 type = o->op_type;
     SV * VOL sv = NULL;
@@ -3257,7 +3261,7 @@ static OP *
 S_gen_constant_list(pTHX_ register OP *o)
 {
     dVAR;
-    register OP *curop;
+    OP *curop;
     const I32 oldtmps_floor = PL_tmps_floor;
 
     list(o);
@@ -3816,9 +3820,6 @@ Perl_newOP(pTHX_ I32 type, I32 flags)
     o->op_type = (OPCODE)type;
     o->op_ppaddr = PL_ppaddr[type];
     o->op_flags = (U8)flags;
-    o->op_latefree = 0;
-    o->op_latefreed = 0;
-    o->op_attached = 0;
 
     o->op_next = o;
     o->op_private = (U8)(0 | (flags >> 8));
@@ -3962,10 +3963,10 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
     STRLEN rlen;
     const U8 *t = (U8*)SvPV_const(tstr, tlen);
     const U8 *r = (U8*)SvPV_const(rstr, rlen);
-    register I32 i;
-    register I32 j;
+    I32 i;
+    I32 j;
     I32 grows = 0;
-    register short *tbl;
+    short *tbl;
 
     const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
@@ -5566,7 +5567,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
     dVAR;
     const U32 seq = intro_my();
     const U32 utf8 = flags & SVf_UTF8;
-    register COP *cop;
+    COP *cop;
 
     flags &= ~SVf_UTF8;
 
@@ -5604,8 +5605,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
         CopLINE_set(cop, CopLINE(PL_curcop));
     else {
        CopLINE_set(cop, PL_parser->copline);
-       if (PL_parser)
-           PL_parser->copline = NOLINE;
+       PL_parser->copline = NOLINE;
     }
 #ifdef USE_ITHREADS
     CopFILE_set(cop, CopFILE(PL_curcop));      /* XXX share in a pvtable? */
@@ -6387,7 +6387,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont)
 Constructs, checks, and returns a loop-exiting op (such as C<goto>
 or C<last>).  I<type> is the opcode.  I<label> supplies the parameter
 determining the target of the op; it is consumed by this function and
-become part of the constructed op tree.
+becomes part of the constructed op tree.
 
 =cut
 */
@@ -6396,7 +6396,7 @@ OP*
 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
 {
     dVAR;
-    OP *o;
+    OP *o = NULL;
 
     PERL_ARGS_ASSERT_NEWLOOPEX;
 
@@ -6404,37 +6404,39 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label)
 
     if (type != OP_GOTO) {
        /* "last()" means "last" */
-       if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
+       if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) {
            o = newOP(type, OPf_SPECIAL);
-       else {
-         const_label:
-           o = newPVOP(type,
-                        label->op_type == OP_CONST
-                            ? SvUTF8(((SVOP*)label)->op_sv)
-                            : 0,
-                        savesharedpv(label->op_type == OP_CONST
-                               ? SvPV_nolen_const(((SVOP*)label)->op_sv)
-                               : ""));
        }
-#ifdef PERL_MAD
-       op_getmad(label,o,'L');
-#else
-       op_free(label);
-#endif
     }
     else {
        /* Check whether it's going to be a goto &function */
        if (label->op_type == OP_ENTERSUB
                && !(label->op_flags & OPf_STACKED))
            label = newUNOP(OP_REFGEN, 0, op_lvalue(label, OP_REFGEN));
-       else if (label->op_type == OP_CONST) {
+    }
+
+    /* Check for a constant argument */
+    if (label->op_type == OP_CONST) {
            SV * const sv = ((SVOP *)label)->op_sv;
            STRLEN l;
            const char *s = SvPV_const(sv,l);
-           if (l == strlen(s)) goto const_label;
-       }
-       o = newUNOP(type, OPf_STACKED, label);
+           if (l == strlen(s)) {
+               o = newPVOP(type,
+                           SvUTF8(((SVOP*)label)->op_sv),
+                           savesharedpv(
+                               SvPV_nolen_const(((SVOP*)label)->op_sv)));
+           }
     }
+    
+    /* If we have already created an op, we do not need the label. */
+    if (o)
+#ifdef PERL_MAD
+               op_getmad(label,o,'L');
+#else
+               op_free(label);
+#endif
+    else o = newUNOP(type, OPf_STACKED, label);
+
     PL_hints |= HINT_BLOCK_SCOPE;
     return o;
 }
@@ -6666,7 +6668,7 @@ void
 Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
                    const STRLEN len, const U32 flags)
 {
-    const char * const cvp = CvPROTO(cv);
+    const char * const cvp = SvROK(cv) ? "" : CvPROTO(cv);
     const STRLEN clen = CvPROTOLEN(cv);
 
     PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
@@ -6688,11 +6690,15 @@ Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
        SV* name = NULL;
 
        if (gv)
+       {
+         if (isGV(gv))
            gv_efullname3(name = sv_newmortal(), gv, NULL);
+         else name = (SV *)gv;
+       }
        sv_setpvs(msg, "Prototype mismatch:");
        if (name)
            Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
-       if (SvPOK(cv))
+       if (cvp)
            Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
                SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
            );
@@ -6751,7 +6757,8 @@ Perl_cv_const_sv(pTHX_ const CV *const cv)
  *
  *     We have just cloned an anon prototype that was marked as a const
  *     candidate. Try to grab the current value, and in the case of
- *     PADSV, ignore it if it has multiple references. Return the value.
+ *     PADSV, ignore it if it has multiple references. In this case we
+ *     return a newly created *copy* of the value.
  */
 
 SV *
@@ -6859,7 +6866,7 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     const char *ps;
     STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
     U32 ps_utf8 = 0;
-    register CV *cv = NULL;
+    CV *cv = NULL;
     SV *const_sv;
     const bool ec = PL_parser && PL_parser->error_count;
     /* If the subroutine has no body, no attributes, and no builtin attributes
@@ -6945,7 +6952,9 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     if (SvTYPE(gv) != SVt_PVGV) {      /* Maybe prototype now, and had at
                                           maximum a prototype before. */
        if (SvTYPE(gv) > SVt_NULL) {
-           cv_ckproto_len_flags((const CV *)gv, NULL, ps, ps_len, ps_utf8);
+           cv_ckproto_len_flags((const CV *)gv,
+                                o ? (const GV *)cSVOPo->op_sv : NULL, ps,
+                                ps_len, ps_utf8);
        }
        if (ps) {
            sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
@@ -7056,12 +7065,13 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
 #endif
        ) {
            cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
-           AV *const temp_av = CvPADLIST(cv);
+           PADLIST *const temp_av = CvPADLIST(cv);
            CV *const temp_cv = CvOUTSIDE(cv);
-           const cv_flags_t slabbed = CvSLABBED(cv);
+           const cv_flags_t other_flags =
+               CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
            OP * const cvstart = CvSTART(cv);
 
-           assert(!CvWEAKOUTSIDE(cv));
+           CvGV_set(cv,gv);
            assert(!CvCVGV_RC(cv));
            assert(CvGV(cv) == gv);
 
@@ -7074,8 +7084,8 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
            CvPADLIST(PL_compcv) = temp_av;
            CvSTART(cv) = CvSTART(PL_compcv);
            CvSTART(PL_compcv) = cvstart;
-           if (slabbed) CvSLABBED_on(PL_compcv);
-           else CvSLABBED_off(PL_compcv);
+           CvFLAGS(PL_compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
+           CvFLAGS(PL_compcv) |= other_flags;
 
            if (CvFILE(cv) && CvDYNFILE(cv)) {
                Safefree(CvFILE(cv));
@@ -7144,7 +7154,6 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
 #endif
            block = newblock;
     }
-    else block->op_attached = 1;
     CvROOT(cv) = CvLVALUE(cv)
                   ? newUNOP(OP_LEAVESUBLV, 0,
                             op_lvalue(scalarseq(block), OP_LEAVESUBLV))
@@ -7311,6 +7320,9 @@ eligible for inlining at compile-time.
 
 Currently, the only useful value for C<flags> is SVf_UTF8.
 
+The newly created subroutine takes ownership of a reference to the passed in
+SV.
+
 Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
 which won't be called if used as a destructor, but will suppress the overhead
 of a call to C<AUTOLOAD>.  (This form, however, isn't eligible for inlining at
@@ -7462,7 +7474,7 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
 CV *
 Perl_newSTUB(pTHX_ GV *gv, bool fake)
 {
-    register CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+    CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
     PERL_ARGS_ASSERT_NEWSTUB;
     assert(!GvCVu(gv));
     GvCV_set(gv, cv);
@@ -7502,12 +7514,19 @@ void
 Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
 {
     dVAR;
-    register CV *cv;
+    CV *cv;
 #ifdef PERL_MAD
     OP* pegop = newOP(OP_NULL, 0);
 #endif
 
-    GV * const gv = o
+    GV *gv;
+
+    if (PL_parser && PL_parser->error_count) {
+       op_free(block);
+       goto finish;
+    }
+
+    gv = o
        ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
        : gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
 
@@ -7530,7 +7549,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
        SvREFCNT_dec(cv);
     }
     cv = PL_compcv;
-    GvFORM(gv) = cv;
+    GvFORM(gv) = (CV *)SvREFCNT_inc_simple_NN(cv);
     CvGV_set(cv, gv);
     CvFILE_set_from_cop(cv, PL_curcop);
 
@@ -7543,13 +7562,15 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
     CvROOT(cv)->op_next = 0;
     CALL_PEEP(CvSTART(cv));
     finalize_optree(CvROOT(cv));
+    cv_forget_slab(cv);
+
+  finish:
 #ifdef PERL_MAD
     op_getmad(o,pegop,'n');
     op_getmad_weak(block, pegop, 'b');
 #else
     op_free(o);
 #endif
-    cv_forget_slab(cv);
     if (PL_parser)
        PL_parser->copline = NOLINE;
     LEAVE_SCOPE(floor);
@@ -8151,7 +8172,8 @@ Perl_ck_ftst(pTHX_ OP *o)
        SVOP * const kid = (SVOP*)cUNOPo->op_first;
        const OPCODE kidtype = kid->op_type;
 
-       if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
+       if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
+        && !(kid->op_private & OPpCONST_FOLDED)) {
            OP * const newop = newGVOP(type, OPf_REF,
                gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
 #ifdef PERL_MAD
@@ -8194,7 +8216,7 @@ Perl_ck_fun(pTHX_ OP *o)
 {
     dVAR;
     const int type = o->op_type;
-    register I32 oa = PL_opargs[type] >> OASHIFT;
+    I32 oa = PL_opargs[type] >> OASHIFT;
 
     PERL_ARGS_ASSERT_CK_FUN;
 
@@ -8207,7 +8229,7 @@ Perl_ck_fun(pTHX_ OP *o)
 
     if (o->op_flags & OPf_KIDS) {
         OP **tokid = &cLISTOPo->op_first;
-        register OP *kid = cLISTOPo->op_first;
+        OP *kid = cLISTOPo->op_first;
         OP *sibl;
         I32 numargs = 0;
        bool seen_optional = FALSE;
@@ -8323,7 +8345,6 @@ Perl_ck_fun(pTHX_ OP *o)
                {
                    OP * const newop = newUNOP(OP_NULL, 0, kid);
                    kid->op_sibling = 0;
-                   LINKLIST(kid);
                    newop->op_next = newop;
                    kid = newop;
                    kid->op_sibling = sibl;
@@ -8569,7 +8590,7 @@ OP *
 Perl_ck_grep(pTHX_ OP *o)
 {
     dVAR;
-    LOGOP *gwop = NULL;
+    LOGOP *gwop;
     OP *kid;
     const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
     PADOFFSET offset;
@@ -8580,22 +8601,9 @@ Perl_ck_grep(pTHX_ OP *o)
     /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
 
     if (o->op_flags & OPf_STACKED) {
-       OP* k;
-       OP *firstkid = cLISTOPo->op_first->op_sibling;
-        kid = cUNOPx(firstkid)->op_first;
+        kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
        if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
            return no_fh_allowed(o);
-       if (o->op_flags & OPf_STACKED) {
-           LINKLIST(kid);
-           firstkid->op_next = kLISTOP->op_first;
-           kid->op_next = 0; /* just disconnect the leave/scope */
-           o->op_flags |= OPf_SPECIAL;
-       }
-       for (k = kid; k; k = k->op_next) {
-           kid = k;
-       }
-       NewOp(1101, gwop, 1, LOGOP);
-       kid->op_next = (OP*)gwop;
        o->op_flags &= ~OPf_STACKED;
     }
     kid = cLISTOPo->op_first->op_sibling;
@@ -8611,11 +8619,10 @@ Perl_ck_grep(pTHX_ OP *o)
        Perl_croak(aTHX_ "panic: ck_grep, type=%u", (unsigned) kid->op_type);
     kid = kUNOP->op_first;
 
-    if (!gwop)
-       NewOp(1101, gwop, 1, LOGOP);
+    NewOp(1101, gwop, 1, LOGOP);
     gwop->op_type = type;
     gwop->op_ppaddr = PL_ppaddr[type];
-    gwop->op_first = listkids(o);
+    gwop->op_first = o;
     gwop->op_flags |= OPf_KIDS;
     gwop->op_other = LINKLIST(kid);
     kid->op_next = (OP*)gwop;
@@ -8630,8 +8637,6 @@ Perl_ck_grep(pTHX_ OP *o)
     }
 
     kid = cLISTOPo->op_first->op_sibling;
-    if (!kid || !kid->op_sibling)
-       return too_few_arguments_pv(o,OP_DESC(o), 0);
     for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
        op_lvalue(kid, OP_GREPSTART);
 
@@ -8731,7 +8736,7 @@ Perl_ck_rfun(pTHX_ OP *o)
 OP *
 Perl_ck_listiob(pTHX_ OP *o)
 {
-    register OP *kid;
+    OP *kid;
 
     PERL_ARGS_ASSERT_CK_LISTIOB;
 
@@ -9177,25 +9182,10 @@ Perl_ck_sort(pTHX_ OP *o)
 
        if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
            LINKLIST(kid);
-           if (kid->op_type == OP_SCOPE) {
-               kid->op_next = 0;
-           }
-           else if (kid->op_type == OP_LEAVE) {
-                   OP *k;
+           if (kid->op_type == OP_LEAVE)
                    op_null(kid);                       /* wipe out leave */
-                   kid->op_next = kid;
-
-                   for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
-                       if (k->op_next == kid)
-                           k->op_next = 0;
-                       /* don't descend into loops */
-                       else if (k->op_type == OP_ENTERLOOP
-                                || k->op_type == OP_ENTERITER)
-                       {
-                           k = cLOOPx(k)->op_lastop;
-                       }
-                   }
-           }
+           /* Prevent execution from escaping out of the sort block. */
+           kid->op_next = 0;
 
            /* provide scalar context for comparison function/block */
            kid = scalar(firstkid);
@@ -9216,7 +9206,7 @@ STATIC void
 S_simplify_sort(pTHX_ OP *o)
 {
     dVAR;
-    register OP *kid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
+    OP *kid = cLISTOPo->op_first->op_sibling;  /* get past pushmark */
     OP *k;
     int descending;
     GV *gv;
@@ -9323,7 +9313,7 @@ OP *
 Perl_ck_split(pTHX_ OP *o)
 {
     dVAR;
-    register OP *kid;
+    OP *kid;
 
     PERL_ARGS_ASSERT_CK_SPLIT;
 
@@ -10073,23 +10063,6 @@ Perl_ck_svconst(pTHX_ OP *o)
 }
 
 OP *
-Perl_ck_chdir(pTHX_ OP *o)
-{
-    PERL_ARGS_ASSERT_CK_CHDIR;
-    if (o->op_flags & OPf_KIDS) {
-       SVOP * const kid = (SVOP*)cUNOPo->op_first;
-
-       if (kid && kid->op_type == OP_CONST &&
-           (kid->op_private & OPpCONST_BARE))
-       {
-           o->op_flags |= OPf_SPECIAL;
-           kid->op_private &= ~OPpCONST_STRICT;
-       }
-    }
-    return ck_fun(o);
-}
-
-OP *
 Perl_ck_trunc(pTHX_ OP *o)
 {
     PERL_ARGS_ASSERT_CK_TRUNC;
@@ -10100,7 +10073,8 @@ Perl_ck_trunc(pTHX_ OP *o)
        if (kid->op_type == OP_NULL)
            kid = (SVOP*)kid->op_sibling;
        if (kid && kid->op_type == OP_CONST &&
-           (kid->op_private & OPpCONST_BARE))
+           (kid->op_private & (OPpCONST_BARE|OPpCONST_FOLDED))
+                            == OPpCONST_BARE)
        {
            o->op_flags |= OPf_SPECIAL;
            kid->op_private &= ~OPpCONST_STRICT;
@@ -10231,34 +10205,6 @@ Perl_ck_length(pTHX_ OP *o)
     return 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) {
-    dVAR;
-    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;
-}                        
-
 /* Check for in place reverse and sort assignments like "@a = reverse @a"
    and modify the optree to make them work inplace */
 
@@ -10362,7 +10308,7 @@ void
 Perl_rpeep(pTHX_ register OP *o)
 {
     dVAR;
-    register OP* oldop = NULL;
+    OP* oldop = NULL;
     OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
     int defer_base = 0;
     int defer_ix = -1;
@@ -10570,10 +10516,18 @@ Perl_rpeep(pTHX_ register OP *o)
           
           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)
-                    )
+#define HV_OR_SCALARHV(op)                                   \
+    (  (op)->op_type == OP_PADHV || (op)->op_type == OP_RV2HV \
+       ? (op)                                                  \
+       : (op)->op_type == OP_SCALAR && (op)->op_flags & OPf_KIDS \
+       && (  cUNOPx(op)->op_first->op_type == OP_PADHV          \
+          || cUNOPx(op)->op_first->op_type == OP_RV2HV)          \
+         ? cUNOPx(op)->op_first                                   \
+         : NULL)
+
+            fop = HV_OR_SCALARHV(fop);
+            if (sop) sop = HV_OR_SCALARHV(sop);
+            if (fop || sop
             ){ 
                 OP * nop = o;
                 OP * lop = o;
@@ -10595,24 +10549,33 @@ Perl_rpeep(pTHX_ register OP *o)
                         }
                     }            
                 }
-                if ((lop->op_flags & OPf_WANT) == 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);
-                }                                        
+                if (fop) {
+                    if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
+                      || o->op_type == OP_AND  )
+                        fop->op_private |= OPpTRUEBOOL;
+                    else if (!(lop->op_flags & OPf_WANT))
+                        fop->op_private |= OPpMAYBE_TRUEBOOL;
+                }
+                if (  (lop->op_flags & OPf_WANT) == OPf_WANT_VOID
+                   && sop)
+                    sop->op_private |= OPpTRUEBOOL;
             }                  
             
            
            break;
-       }    
        
+       case OP_COND_EXPR:
+           if ((fop = HV_OR_SCALARHV(cLOGOP->op_first)))
+               fop->op_private |= OPpMAYBE_TRUEBOOL;
+#undef HV_OR_SCALARHV
+           /* GERONIMO! */
+       }    
+
        case OP_MAPWHILE:
        case OP_GREPWHILE:
        case OP_ANDASSIGN:
        case OP_ORASSIGN:
        case OP_DORASSIGN:
-       case OP_COND_EXPR:
        case OP_RANGE:
        case OP_ONCE:
            while (cLOGOP->op_other->op_type == OP_NULL)
@@ -10650,7 +10613,8 @@ Perl_rpeep(pTHX_ register OP *o)
                OP * const kid =
                    cUNOPx(cLISTOP->op_first->op_sibling)->op_first;
                if (kid->op_type == OP_SCOPE
-                || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))                  DEFER(kLISTOP->op_first);
+                || (kid->op_type == OP_NULL && kid->op_targ == OP_LEAVE))
+                   DEFER(kLISTOP->op_first);
            }
 
            /* check that RHS of sort is a single plain array */