This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Honour lexical prototypes
[perl5.git] / op.c
diff --git a/op.c b/op.c
index 803c627..21f271e 100644 (file)
--- a/op.c
+++ b/op.c
@@ -261,18 +261,13 @@ Perl_Slab_to_ro(pTHX_ OPSLAB *slab)
     }
 }
 
-STATIC void
-S_Slab_to_rw(pTHX_ void *op)
+void
+Perl_Slab_to_rw(pTHX_ OPSLAB *const slab)
 {
-    OP * const o = (OP *)op;
-    OPSLAB *slab;
     OPSLAB *slab2;
 
     PERL_ARGS_ASSERT_SLAB_TO_RW;
 
-    if (!o->op_slabbed) return;
-
-    slab = OpSLAB(o);
     if (!slab->opslab_readonly) return;
     slab2 = slab;
     for (; slab2; slab2 = slab2->opslab_next) {
@@ -406,8 +401,14 @@ OP *
 Perl_op_refcnt_inc(pTHX_ OP *o)
 {
     if(o) {
-       Slab_to_rw(o);
-       ++o->op_targ;
+        OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
+        if (slab && slab->opslab_readonly) {
+            Slab_to_rw(slab);
+            ++o->op_targ;
+            Slab_to_ro(slab);
+        } else {
+            ++o->op_targ;
+        }
     }
     return o;
 
@@ -416,9 +417,19 @@ Perl_op_refcnt_inc(pTHX_ OP *o)
 PADOFFSET
 Perl_op_refcnt_dec(pTHX_ OP *o)
 {
+    PADOFFSET result;
+    OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL;
+
     PERL_ARGS_ASSERT_OP_REFCNT_DEC;
-    Slab_to_rw(o);
-    return --o->op_targ;
+
+    if (slab && slab->opslab_readonly) {
+        Slab_to_rw(slab);
+        result = --o->op_targ;
+        Slab_to_ro(slab);
+    } else {
+        result = --o->op_targ;
+    }
+    return result;
 }
 #endif
 /*
@@ -631,10 +642,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 +666,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 +700,26 @@ 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);
+    if (o->op_slabbed) {
+       Slab_to_rw(OpSLAB(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 +821,7 @@ Perl_op_clear(pTHX_ OP *o)
         }
 #endif
        break;
+    case OP_DUMP:
     case OP_GOTO:
     case OP_NEXT:
     case OP_LAST:
@@ -836,6 +832,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 +1056,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 (;;) {
@@ -1101,8 +1098,11 @@ S_scalarboolean(pTHX_ OP *o)
        if (ckWARN(WARN_SYNTAX)) {
            const line_t oldline = CopLINE(PL_curcop);
 
-           if (PL_parser && PL_parser->copline != NOLINE)
+           if (PL_parser && PL_parser->copline != NOLINE) {
+               /* This ensures that warnings are reported at the first line
+                   of the conditional, not the last.  */
                CopLINE_set(PL_curcop, PL_parser->copline);
+            }
            Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
            CopLINE_set(PL_curcop, oldline);
        }
@@ -1181,8 +1181,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 +1383,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 +1522,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 +2859,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)
 {
@@ -2874,6 +2894,7 @@ Perl_block_end(pTHX_ I32 floor, OP *seq)
     dVAR;
     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
     OP* retval = scalarseq(seq);
+    OP *o;
 
     CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
 
@@ -2881,7 +2902,66 @@ Perl_block_end(pTHX_ I32 floor, OP *seq)
     CopHINTS_set(&PL_compiling, PL_hints);
     if (needblockscope)
        PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
-    pad_leavemy();
+    o = pad_leavemy();
+
+    if (o) {
+       /* pad_leavemy has created a sequence of introcv ops for all my
+          subs declared in the block.  We have to replicate that list with
+          clonecv ops, to deal with this situation:
+
+              sub {
+                  my sub s1;
+                  my sub s2;
+                  sub s1 { state sub foo { \&s2 } }
+              }->()
+
+          Originally, I was going to have introcv clone the CV and turn
+          off the stale flag.  Since &s1 is declared before &s2, the
+          introcv op for &s1 is executed (on sub entry) before the one for
+          &s2.  But the &foo sub inside &s1 (which is cloned when &s1 is
+          cloned, since it is a state sub) closes over &s2 and expects
+          to see it in its outer CV’s pad.  If the introcv op clones &s1,
+          then &s2 is still marked stale.  Since &s1 is not active, and
+          &foo closes over &s1’s implicit entry for &s2, we get a ‘Varia-
+          ble will not stay shared’ warning.  Because it is the same stub
+          that will be used when the introcv op for &s2 is executed, clos-
+          ing over it is safe.  Hence, we have to turn off the stale flag
+          on all lexical subs in the block before we clone any of them.
+          Hence, having introcv clone the sub cannot work.  So we create a
+          list of ops like this:
+
+              lineseq
+                 |
+                 +-- introcv
+                 |
+                 +-- introcv
+                 |
+                 +-- introcv
+                 |
+                 .
+                 .
+                 .
+                 |
+                 +-- clonecv
+                 |
+                 +-- clonecv
+                 |
+                 +-- clonecv
+                 |
+                 .
+                 .
+                 .
+        */
+       OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : o;
+       OP * const last = o->op_flags & OPf_KIDS ? cLISTOPo->op_last : o;
+       for (;; kid = kid->op_sibling) {
+           OP *newkid = newOP(OP_CLONECV, 0);
+           newkid->op_targ = kid->op_targ;
+           o = op_append_elem(OP_LINESEQ, o, newkid);
+           if (kid == last) break;
+       }
+       retval = op_prepend_elem(OP_LINESEQ, o, retval);
+    }
 
     CALL_BLOCK_HOOKS(bhk_post_end, &retval);
 
@@ -2962,6 +3042,21 @@ Perl_newPROG(pTHX_ OP *o)
     }
     else {
        if (o->op_type == OP_STUB) {
+            /* This block is entered if nothing is compiled for the main
+               program. This will be the case for an genuinely empty main
+               program, or one which only has BEGIN blocks etc, so already
+               run and freed.
+
+               Historically (5.000) the guard above was !o. However, commit
+               f8a08f7b8bd67b28 (Jun 2001), integrated to blead as
+               c71fccf11fde0068, changed perly.y so that newPROG() is now
+               called with the output of block_end(), which returns a new
+               OP_STUB for the case of an empty optree. ByteLoader (and
+               maybe other things) also take this path, because they set up
+               PL_main_start and PL_main_root directly, without generating an
+               optree.
+            */
+
            PL_comppad_name = 0;
            PL_compcv = 0;
            S_op_destroy(aTHX_ o);
@@ -3107,7 +3202,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 +3352,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 +3911,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 +4054,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 +5658,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 +5696,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? */
@@ -5831,6 +5922,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
        }
        if (warnop) {
            const line_t oldline = CopLINE(PL_curcop);
+            /* This ensures that warnings are reported at the first line
+               of the construction, not the last.  */
            CopLINE_set(PL_curcop, PL_parser->copline);
            Perl_warner(aTHX_ packWARN(WARN_MISC),
                 "Value of %s%s can be \"0\"; test with defined()",
@@ -6387,7 +6480,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 +6489,7 @@ OP*
 Perl_newLOOPEX(pTHX_ I32 type, OP *label)
 {
     dVAR;
-    OP *o;
+    OP *o = NULL;
 
     PERL_ARGS_ASSERT_NEWLOOPEX;
 
@@ -6404,37 +6497,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;
 }
@@ -6613,7 +6708,7 @@ I<cond> supplies the expression that will be locally assigned to a lexical
 variable, and I<block> supplies the body of the C<given> construct; they
 are consumed by this function and become part of the constructed op tree.
 I<defsv_off> is the pad offset of the scalar lexical variable that will
-be affected.
+be affected.  If it is 0, the global $_ will be used.
 
 =cut
 */
@@ -6666,7 +6761,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 +6783,18 @@ 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 if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
+           name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1,
+                                 SvUTF8(gv)|SVs_TEMP);
+         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 +6853,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 *
@@ -6816,32 +6919,354 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
     return sv;
 }
 
-#ifdef PERL_MAD
-OP *
-#else
-void
-#endif
+CV *
 Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 {
-#if 0
-    /* This would be the return value, but the return cannot be reached.  */
-    OP* pegop = newOP(OP_NULL, 0);
+    dVAR;
+    CV **spot;
+    SV **svspot;
+    const char *ps;
+    STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
+    U32 ps_utf8 = 0;
+    register CV *cv = NULL;
+    register CV *compcv = PL_compcv;
+    SV *const_sv;
+    PADNAME *name;
+    PADOFFSET pax = o->op_targ;
+    CV *outcv = CvOUTSIDE(PL_compcv);
+    HEK *hek = NULL;
+
+    PERL_ARGS_ASSERT_NEWMYSUB;
+
+    /* Find the pad slot for storing the new sub.
+       We cannot use PL_comppad, as it is the pad owned by the new sub.  We
+       need to look in CvOUTSIDE and find the pad belonging to the enclos-
+       ing sub.  And then we need to dig deeper if this is a lexical from
+       outside, as in:
+          my sub foo; sub { sub foo { } }
+     */
+   redo:
+    name = PadlistNAMESARRAY(CvPADLIST(outcv))[pax];
+    if (PadnameOUTER(name) && PARENT_PAD_INDEX(name)) {
+       pax = PARENT_PAD_INDEX(name);
+       outcv = CvOUTSIDE(outcv);
+       assert(outcv);
+       goto redo;
+    }
+    svspot =
+       &PadARRAY(PadlistARRAY(CvPADLIST(outcv))[1])[pax];
+    spot = (CV **)svspot;
+
+    if (proto) {
+       assert(proto->op_type == OP_CONST);
+       ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
+        ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
+    }
+    else
+       ps = NULL;
+
+    if (!PL_madskills) {
+       if (proto)
+           SAVEFREEOP(proto);
+       if (attrs)
+           SAVEFREEOP(attrs);
+    }
+
+    if (PL_parser && PL_parser->error_count) {
+       op_free(block);
+       goto done;
+    }
+
+    if (PadnameIsSTATE(name))
+       cv = *spot;
+    else {
+       MAGIC *mg;
+       assert (SvTYPE(*spot) == SVt_PVCV);
+       if (CvROOT(*spot)) {
+           cv = *spot;
+           *svspot = newSV_type(SVt_PVCV);
+           SvPADMY_on(*spot);
+       }
+       if (CvNAMED(*spot))
+           hek = CvNAME_HEK(*spot);
+       else {
+           CvNAME_HEK_set(*spot, hek =
+               share_hek(
+                   PadnamePV(name)+1,
+                   PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
+               )
+           );
+       }
+       mg = mg_find(*svspot, PERL_MAGIC_proto);
+       if (mg) {
+           assert(mg->mg_obj);
+           cv = (CV *)mg->mg_obj;
+       }
+       else {
+           sv_magic(*svspot, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
+           mg = mg_find(*svspot, PERL_MAGIC_proto);
+       }
+       spot = (CV **)(svspot = &mg->mg_obj);
+    }
+
+    if (!block || !ps || *ps || attrs
+       || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
+#ifdef PERL_MAD
+       || block->op_type == OP_NULL
 #endif
+       )
+       const_sv = NULL;
+    else
+       const_sv = op_const_sv(block, NULL);
 
-    PERL_UNUSED_ARG(floor);
+    if (cv) {
+        const bool exists = CvROOT(cv) || CvXSUB(cv);
 
-    if (o)
-       SAVEFREEOP(o);
-    if (proto)
-       SAVEFREEOP(proto);
-    if (attrs)
-       SAVEFREEOP(attrs);
-    if (block)
-       SAVEFREEOP(block);
-    Perl_croak(aTHX_ "\"my sub\" not yet implemented");
+        /* if the subroutine doesn't exist and wasn't pre-declared
+         * with a prototype, assume it will be AUTOLOADed,
+         * skipping the prototype check
+         */
+        if (exists || SvPOK(cv))
+            cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
+       /* already defined? */
+       if (exists) {
+           if ((!block
+#ifdef PERL_MAD
+                || block->op_type == OP_NULL
+#endif
+                )) {
+               if (CvFLAGS(compcv)) {
+                   /* might have had built-in attrs applied */
+                   const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
+                   if (CvLVALUE(compcv) && ! CvLVALUE(cv) && pureperl
+                    && ckWARN(WARN_MISC))
+                       Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
+                   CvFLAGS(cv) |=
+                       (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS
+                         & ~(CVf_LVALUE * pureperl));
+               }
+               if (attrs) goto attrs;
+               /* just a "sub foo;" when &foo is already defined */
+               SAVEFREESV(compcv);
+               goto done;
+           }
+           else {
+               /* redundant check that avoids creating the extra SV
+                  most of the time: */
+               if (const_sv || ckWARN(WARN_REDEFINE)) {
+                   const line_t oldline = CopLINE(PL_curcop);
+                   SV *noamp = sv_2mortal(newSVpvn_utf8(
+                                   PadnamePV(name)+1,PadnameLEN(name)-1,
+                                    PadnameUTF8(name)
+                               ));
+                   if (PL_parser && PL_parser->copline != NOLINE)
+                       CopLINE_set(PL_curcop, PL_parser->copline);
+                   report_redefined_cv(noamp, cv, &const_sv);
+                   CopLINE_set(PL_curcop, oldline);
+               }
+#ifdef PERL_MAD
+               if (!PL_minus_c)        /* keep old one around for madskills */
+#endif
+                   {
+                       /* (PL_madskills unset in used file.) */
+                       SvREFCNT_dec(cv);
+                   }
+               cv = NULL;
+           }
+       }
+    }
+    if (const_sv) {
+       SvREFCNT_inc_simple_void_NN(const_sv);
+       if (cv) {
+           assert(!CvROOT(cv) && !CvCONST(cv));
+           cv_forget_slab(cv);
+       }
+       else {
+           cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+           CvFILE_set_from_cop(cv, PL_curcop);
+           CvSTASH_set(cv, PL_curstash);
+           *spot = cv;
+       }
+       sv_setpvs(MUTABLE_SV(cv), "");  /* prototype is "" */
+       CvXSUBANY(cv).any_ptr = const_sv;
+       CvXSUB(cv) = const_sv_xsub;
+       CvCONST_on(cv);
+       CvISXSUB_on(cv);
+       if (PL_madskills)
+           goto install_block;
+       op_free(block);
+       SvREFCNT_dec(compcv);
+       PL_compcv = NULL;
+       goto done;
+    }
+    /* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
+       determine whether this sub definition is in the same scope as its
+       declaration.  If this sub definition is inside an inner named pack-
+       age sub (my sub foo; sub bar { sub foo { ... } }), outcv points to
+       the package sub.  So check PadnameOUTER(name) too.
+     */
+    if (outcv == CvOUTSIDE(compcv) && !PadnameOUTER(name)) { 
+       assert(!CvWEAKOUTSIDE(compcv));
+       SvREFCNT_dec(CvOUTSIDE(compcv));
+       CvWEAKOUTSIDE_on(compcv);
+    }
+    /* XXX else do we have a circular reference? */
+    if (cv) {  /* must reuse cv in case stub is referenced elsewhere */
+       /* transfer PL_compcv to cv */
+       if (block
 #ifdef PERL_MAD
-    NORETURN_FUNCTION_END;
+                  && block->op_type != OP_NULL
 #endif
+       ) {
+           cv_flags_t preserved_flags =
+               CvFLAGS(cv) & (CVf_BUILTIN_ATTRS|CVf_NAMED);
+           PADLIST *const temp_padl = CvPADLIST(cv);
+           CV *const temp_cv = CvOUTSIDE(cv);
+           const cv_flags_t other_flags =
+               CvFLAGS(cv) & (CVf_SLABBED|CVf_WEAKOUTSIDE);
+           OP * const cvstart = CvSTART(cv);
+
+           SvPOK_off(cv);
+           CvFLAGS(cv) =
+               CvFLAGS(compcv) | preserved_flags;
+           CvOUTSIDE(cv) = CvOUTSIDE(compcv);
+           CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(compcv);
+           CvPADLIST(cv) = CvPADLIST(compcv);
+           CvOUTSIDE(compcv) = temp_cv;
+           CvPADLIST(compcv) = temp_padl;
+           CvSTART(cv) = CvSTART(compcv);
+           CvSTART(compcv) = cvstart;
+           CvFLAGS(compcv) &= ~(CVf_SLABBED|CVf_WEAKOUTSIDE);
+           CvFLAGS(compcv) |= other_flags;
+
+           if (CvFILE(cv) && CvDYNFILE(cv)) {
+               Safefree(CvFILE(cv));
+           }
+
+           /* inner references to compcv must be fixed up ... */
+           pad_fixup_inner_anons(CvPADLIST(cv), compcv, cv);
+           if (PERLDB_INTER)/* Advice debugger on the new sub. */
+             ++PL_sub_generation;
+       }
+       else {
+           /* Might have had built-in attributes applied -- propagate them. */
+           CvFLAGS(cv) |= (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS);
+       }
+       /* ... before we throw it away */
+       SvREFCNT_dec(compcv);
+       PL_compcv = compcv = cv;
+    }
+    else {
+       cv = compcv;
+       *spot = cv;
+    }
+    if (!CvNAME_HEK(cv)) {
+       CvNAME_HEK_set(cv,
+        hek
+         ? share_hek_hek(hek)
+         : share_hek(PadnamePV(name)+1,
+                     PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
+                     0)
+       );
+    }
+    CvFILE_set_from_cop(cv, PL_curcop);
+    CvSTASH_set(cv, PL_curstash);
+
+    if (ps) {
+       sv_setpvn(MUTABLE_SV(cv), ps, ps_len);
+        if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(cv));
+    }
+
+ install_block:
+    if (!block)
+       goto attrs;
+
+    /* 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++;
+    /* This makes sub {}; work as expected.  */
+    if (block->op_type == OP_STUB) {
+           OP* const newblock = newSTATEOP(0, NULL, 0);
+#ifdef PERL_MAD
+           op_getmad(block,newblock,'B');
+#else
+           op_free(block);
+#endif
+           block = newblock;
+    }
+    CvROOT(cv) = CvLVALUE(cv)
+                  ? newUNOP(OP_LEAVESUBLV, 0,
+                            op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+                  : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+    CvROOT(cv)->op_private |= OPpREFCOUNTED;
+    OpREFCNT_set(CvROOT(cv), 1);
+    /* The cv no longer needs to hold a refcount on the slab, as CvROOT
+       itself has a refcount. */
+    CvSLABBED_off(cv);
+    OpslabREFCNT_dec_padok((OPSLAB *)CvSTART(cv));
+    CvSTART(cv) = LINKLIST(CvROOT(cv));
+    CvROOT(cv)->op_next = 0;
+    CALL_PEEP(CvSTART(cv));
+    finalize_optree(CvROOT(cv));
+
+    /* now that optimizer has done its work, adjust pad values */
+
+    pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
+
+    if (CvCLONE(cv)) {
+       assert(!CvCONST(cv));
+       if (ps && !*ps && op_const_sv(block, cv))
+           CvCONST_on(cv);
+    }
+
+  attrs:
+    if (attrs) {
+       /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
+       apply_attrs(PL_curstash, MUTABLE_SV(cv), attrs, FALSE);
+    }
+
+    if (block) {
+       if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
+           SV * const tmpstr = sv_newmortal();
+           GV * const db_postponed = gv_fetchpvs("DB::postponed",
+                                                 GV_ADDMULTI, SVt_PVHV);
+           HV *hv;
+           SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
+                                         CopFILE(PL_curcop),
+                                         (long)PL_subline,
+                                         (long)CopLINE(PL_curcop));
+           if (HvNAME_HEK(PL_curstash)) {
+               sv_sethek(tmpstr, HvNAME_HEK(PL_curstash));
+               sv_catpvs(tmpstr, "::");
+           }
+           else sv_setpvs(tmpstr, "__ANON__::");
+           sv_catpvn_flags(tmpstr, PadnamePV(name)+1, PadnameLEN(name)-1,
+                           PadnameUTF8(name) ? SV_CATUTF8 : SV_CATBYTES);
+           (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
+                   SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr), sv, 0);
+           hv = GvHVn(db_postponed);
+           if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvUTF8(tmpstr) ? -(I32)SvCUR(tmpstr) : (I32)SvCUR(tmpstr))) {
+               CV * const pcv = GvCV(db_postponed);
+               if (pcv) {
+                   dSP;
+                   PUSHMARK(SP);
+                   XPUSHs(tmpstr);
+                   PUTBACK;
+                   call_sv(MUTABLE_SV(pcv), G_DISCARD);
+               }
+           }
+       }
+    }
+
+  done:
+    if (PL_parser)
+       PL_parser->copline = NOLINE;
+    LEAVE_SCOPE(floor);
+    if (o) op_free(o);
+    return cv;
 }
 
 CV *
@@ -6859,7 +7284,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 +7370,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);
@@ -7008,8 +7435,11 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
 #endif
                ) {
                const line_t oldline = CopLINE(PL_curcop);
-               if (PL_parser && PL_parser->copline != NOLINE)
+               if (PL_parser && PL_parser->copline != NOLINE) {
+                        /* This ensures that warnings are reported at the first
+                           line of a redefinition, not the last.  */
                        CopLINE_set(PL_curcop, PL_parser->copline);
+                }
                report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
                CopLINE_set(PL_curcop, oldline);
 #ifdef PERL_MAD
@@ -7056,12 +7486,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 +7505,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 +7575,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 +7741,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
@@ -7412,14 +7845,10 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len,
                 /* Redundant check that allows us to avoid creating an SV
                    most of the time: */
                 if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
-                    const line_t oldline = CopLINE(PL_curcop);
-                    if (PL_parser && PL_parser->copline != NOLINE)
-                        CopLINE_set(PL_curcop, PL_parser->copline);
                     report_redefined_cv(newSVpvn_flags(
                                          name,len,(flags&SVf_UTF8)|SVs_TEMP
                                         ),
                                         cv, const_svp);
-                    CopLINE_set(PL_curcop, oldline);
                 }
                 SvREFCNT_dec(cv);
                 cv = NULL;
@@ -7462,7 +7891,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 +7931,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 +7966,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 +7979,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);
@@ -7687,6 +8125,11 @@ Perl_newHVREF(pTHX_ OP *o)
 OP *
 Perl_newCVREF(pTHX_ I32 flags, OP *o)
 {
+    if (o->op_type == OP_PADANY) {
+       o->op_type = OP_PADCV;
+       o->op_ppaddr = PL_ppaddr[OP_PADCV];
+       return o;
+    }
     return newUNOP(OP_RV2CV, flags, scalar(o));
 }
 
@@ -8151,7 +8594,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 +8638,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 +8651,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;
@@ -8600,7 +9044,7 @@ Perl_ck_grep(pTHX_ OP *o)
     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;
@@ -8714,7 +9158,7 @@ Perl_ck_rfun(pTHX_ OP *o)
 OP *
 Perl_ck_listiob(pTHX_ OP *o)
 {
-    register OP *kid;
+    OP *kid;
 
     PERL_ARGS_ASSERT_CK_LISTIOB;
 
@@ -9184,7 +9628,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;
@@ -9291,7 +9735,7 @@ OP *
 Perl_ck_split(pTHX_ OP *o)
 {
     dVAR;
-    register OP *kid;
+    OP *kid;
 
     PERL_ARGS_ASSERT_CK_SPLIT;
 
@@ -9441,6 +9885,28 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
            cv = (CV*)SvRV(rv);
            gv = NULL;
        } break;
+       case OP_PADCV: {
+           PADNAME *name = PAD_COMPNAME(rvop->op_targ);
+           CV *compcv = PL_compcv;
+           SV *sv = PAD_SV(rvop->op_targ);
+           while (SvTYPE(sv) != SVt_PVCV) {
+               assert(PadnameOUTER(name));
+               assert(PARENT_PAD_INDEX(name));
+               compcv = CvOUTSIDE(PL_compcv);
+               sv = AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])
+                       [PARENT_PAD_INDEX(name)];
+               name = PadlistNAMESARRAY(CvPADLIST(compcv))
+                       [PARENT_PAD_INDEX(name)];
+           }
+           if (!PadnameIsOUR(name) && !PadnameIsSTATE(name)) {
+               MAGIC * mg = mg_find(sv, PERL_MAGIC_proto);
+               assert(mg);
+               assert(mg->mg_obj);
+               cv = (CV *)mg->mg_obj;
+           }
+           else cv = (CV *)sv;
+           gv = NULL;
+       } break;
        default: {
            return NULL;
        } break;
@@ -10027,6 +10493,19 @@ Perl_ck_subr(pTHX_ OP *o)
        Perl_call_checker ckfun;
        SV *ckobj;
        cv_get_call_checker(cv, &ckfun, &ckobj);
+       if (!namegv) { /* expletive! */
+           /* XXX The call checker API is public.  And it guarantees that
+                  a GV will be provided with the right name.  So we have
+                  to create a GV.  But it is still not correct, as its
+                  stringification will include the package.  What we
+                  really need is a new call checker API that accepts a
+                  GV or string (or GV or CV). */
+           HEK * const hek = CvNAME_HEK(cv);
+           assert(hek);
+           namegv = (GV *)sv_newmortal();
+           gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
+                       SVf_UTF8 * !!HEK_UTF8(hek));
+       }
        return ckfun(aTHX_ o, namegv, ckobj);
     }
 }
@@ -10041,23 +10520,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;
@@ -10068,7 +10530,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;
@@ -10199,34 +10662,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 */
 
@@ -10330,7 +10765,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;
@@ -10518,10 +10953,18 @@ Perl_rpeep(pTHX_ register OP *o)
             OP *fop;
             OP *sop;
             
+#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)
+
         case OP_NOT:
-            fop = cUNOP->op_first;
-            sop = NULL;
-            goto stitch_keys;
+            if ((fop = HV_OR_SCALARHV(cUNOP->op_first)))
+                fop->op_private |= OPpTRUEBOOL;
             break;
 
         case OP_AND:
@@ -10536,12 +10979,10 @@ Perl_rpeep(pTHX_ register OP *o)
                o->op_next = o->op_next->op_next;
            DEFER(cLOGOP->op_other);
           
-          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)
-                    )
+            fop = HV_OR_SCALARHV(fop);
+            if (sop) sop = HV_OR_SCALARHV(sop);
+            if (fop || sop
             ){ 
                 OP * nop = o;
                 OP * lop = o;
@@ -10563,24 +11004,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 |= OPpTRUEBOOL;
+#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)