Add an optimization for map-maps-a-list-element-to-more-list-elements
[p5sagit/p5-mst-13.2.git] / op.c
diff --git a/op.c b/op.c
index 11ff181..ec43cce 100644 (file)
--- a/op.c
+++ b/op.c
 
 /* #define PL_OP_SLAB_ALLOC */
 
-/* XXXXXX testing */
-#ifdef USE_ITHREADS
-#  define OP_REFCNT_LOCK               NOOP
-#  define OP_REFCNT_UNLOCK             NOOP
-#  define OpREFCNT_set(o,n)            ((o)->op_targ = (n))
-#  define OpREFCNT_dec(o)              (--(o)->op_targ)
-#else
-#  define OP_REFCNT_LOCK               NOOP
-#  define OP_REFCNT_UNLOCK             NOOP
-#  define OpREFCNT_set(o,n)            NOOP
-#  define OpREFCNT_dec(o)              0
-#endif
-
 #ifdef PL_OP_SLAB_ALLOC 
 #define SLAB_SIZE 8192
 static char    *PL_OpPtr  = NULL;
@@ -172,20 +159,20 @@ Perl_pad_allocmy(pTHX_ char *name)
            }
        }
        if (PL_in_my == KEY_our) {
-           while (off <= top) {
+           do {
                if ((sv = svp[off])
                    && sv != &PL_sv_undef
+                   && (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
                    && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
                    && strEQ(name, SvPVX(sv)))
                {
                    Perl_warner(aTHX_ WARN_MISC,
                        "\"our\" variable %s redeclared", name);
                    Perl_warner(aTHX_ WARN_MISC,
-                       "(Did you mean \"local\" instead of \"our\"?)\n");
+                       "\t(Did you mean \"local\" instead of \"our\"?)\n");
                    break;
                }
-               --off;
-           }
+           } while ( off-- > 0 );
        }
     }
     off = pad_alloc(OP_PADSV, SVs_PADMY);
@@ -335,9 +322,12 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
                        }
                    }
                    else if (!CvUNIQUE(PL_compcv)) {
-                       if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv))
+                       if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
+                           && !(SvFLAGS(sv) & SVpad_OUR))
+                       {
                            Perl_warner(aTHX_ WARN_CLOSURE,
                                "Variable \"%s\" will not stay shared", name);
+                       }
                    }
                }
                av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
@@ -369,8 +359,9 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv,
                if (CxREALEVAL(cx))
                    saweval = i;
                break;
+           case OP_DOFILE:
            case OP_REQUIRE:
-               /* require must have its own scope */
+               /* require/do must have their own scope */
                return 0;
            }
            break;
@@ -793,6 +784,7 @@ S_op_clear(pTHX_ OP *o)
        cSVOPo->op_sv = Nullsv;
 #endif
        break;
+    case OP_METHOD_NAMED:
     case OP_CONST:
        SvREFCNT_dec(cSVOPo->op_sv);
        cSVOPo->op_sv = Nullsv;
@@ -852,8 +844,8 @@ S_cop_free(pTHX_ COP* cop)
 {
     Safefree(cop->cop_label);
 #ifdef USE_ITHREADS
-    Safefree(CopFILE(cop));            /* XXXXX share in a pvtable? */
-    Safefree(CopSTASHPV(cop));         /* XXXXX share in a pvtable? */
+    Safefree(CopFILE(cop));            /* XXX share in a pvtable? */
+    Safefree(CopSTASHPV(cop));         /* XXX share in a pvtable? */
 #else
     /* NOTE: COP.cop_stash is not refcounted */
     SvREFCNT_dec(CopFILEGV(cop));
@@ -1173,7 +1165,6 @@ Perl_scalarvoid(pTHX_ OP *o)
     case OP_DBSTATE:
     case OP_ENTERTRY:
     case OP_ENTER:
-    case OP_SCALAR:
        if (!(o->op_flags & OPf_KIDS))
            break;
        /* FALL THROUGH */
@@ -1192,6 +1183,8 @@ Perl_scalarvoid(pTHX_ OP *o)
     case OP_REQUIRE:
        /* all requires must return a boolean value */
        o->op_flags &= ~OPf_WANT;
+       /* FALL THROUGH */
+    case OP_SCALAR:
        return scalar(o);
     case OP_SPLIT:
        if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
@@ -1834,7 +1827,6 @@ S_dup_attrlist(pTHX_ OP *o)
 STATIC void
 S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
 {
-    OP *modname;       /* for 'use' */
     SV *stashsv;
 
     /* fake up C<use attributes $pkg,$rv,@attrs> */
@@ -1844,22 +1836,52 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
        stashsv = newSVpv(HvNAME(stash), 0);
     else
        stashsv = &PL_sv_no;
+
 #define ATTRSMODULE "attributes"
-    modname = newSVOP(OP_CONST, 0,
-                     newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
-    modname->op_private |= OPpCONST_BARE;
-    /* that flag is required to make 'use' work right */
-    utilize(1, start_subparse(FALSE, 0),
-           Nullop, /* version */
-           modname,
-           prepend_elem(OP_LIST,
-                        newSVOP(OP_CONST, 0, stashsv),
-                        prepend_elem(OP_LIST,
-                                     newSVOP(OP_CONST, 0, newRV(target)),
-                                     dup_attrlist(attrs))));
+
+    Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
+                    newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+                    Nullsv,
+                    prepend_elem(OP_LIST,
+                                 newSVOP(OP_CONST, 0, stashsv),
+                                 prepend_elem(OP_LIST,
+                                              newSVOP(OP_CONST, 0,
+                                                      newRV(target)),
+                                              dup_attrlist(attrs))));
     LEAVE;
 }
 
+void
+Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
+                        char *attrstr, STRLEN len)
+{
+    OP *attrs = Nullop;
+
+    if (!len) {
+        len = strlen(attrstr);
+    }
+
+    while (len) {
+        for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
+        if (len) {
+            char *sstr = attrstr;
+            for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
+            attrs = append_elem(OP_LIST, attrs,
+                                newSVOP(OP_CONST, 0,
+                                        newSVpvn(sstr, attrstr-sstr)));
+        }
+    }
+
+    Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
+                     newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+                     Nullsv, prepend_elem(OP_LIST,
+                                 newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
+                                 prepend_elem(OP_LIST,
+                                              newSVOP(OP_CONST, 0,
+                                                      newRV((SV*)cv)),
+                                               attrs)));
+}
+
 STATIC OP *
 S_my_kid(pTHX_ OP *o, OP *attrs)
 {
@@ -2583,6 +2605,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
     complement = o->op_private & OPpTRANS_COMPLEMENT;
     del                = o->op_private & OPpTRANS_DELETE;
     squash     = o->op_private & OPpTRANS_SQUASH;
+    
+    if (SvUTF8(tstr))
+        o->op_private |= OPpTRANS_FROM_UTF;
+    
+    if (SvUTF8(rstr)) 
+        o->op_private |= OPpTRANS_TO_UTF;
 
     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
        SV* listsv = newSVpvn("# comment\n",10);
@@ -2654,15 +2682,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            r = t; rlen = tlen; rend = tend;
        }
        if (!squash) {
-           if (to_utf && from_utf) {   /* only counting characters */
-               if (t == r || (tlen == rlen && memEQ(t, r, tlen)))
-                   o->op_private |= OPpTRANS_IDENTICAL;
-           }
-           else {      /* straight latin-1 translation */
-               if (tlen == 4 && memEQ(t, "\0\377\303\277", 4) &&
-                   rlen == 4 && memEQ(r, "\0\377\303\277", 4))
+               if (t == r ||
+                   (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
+               {
                    o->op_private |= OPpTRANS_IDENTICAL;
-           }
+               }
        }
 
        while (t < tend || tfirst <= tlast) {
@@ -2761,7 +2785,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            SvREFCNT_dec(transv);
 
        if (!del && havefinal)
-           (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, newSViv((IV)final), 0);
+           (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
+                          newSVuv((UV)final), 0);
 
        if (grows && to_utf)
            o->op_private |= OPpTRANS_GROWS;
@@ -3188,6 +3213,65 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
     PL_expect = XSTATE;
 }
 
+void
+Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
+{
+    va_list args;
+    va_start(args, ver);
+    vload_module(flags, name, ver, &args);
+    va_end(args);
+}
+
+#ifdef PERL_IMPLICIT_CONTEXT
+void
+Perl_load_module_nocontext(U32 flags, SV *name, SV *ver, ...)
+{
+    dTHX;
+    va_list args;
+    va_start(args, ver);
+    vload_module(flags, name, ver, &args);
+    va_end(args);
+}
+#endif
+
+void
+Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
+{
+    OP *modname, *veop, *imop;
+
+    modname = newSVOP(OP_CONST, 0, name);
+    modname->op_private |= OPpCONST_BARE;
+    if (ver) {
+       veop = newSVOP(OP_CONST, 0, ver);
+    }
+    else
+       veop = Nullop;
+    if (flags & PERL_LOADMOD_NOIMPORT) {
+       imop = sawparens(newNULLLIST());
+    }
+    else if (flags & PERL_LOADMOD_IMPORT_OPS) {
+       imop = va_arg(*args, OP*);
+    }
+    else {
+       SV *sv;
+       imop = Nullop;
+       sv = va_arg(*args, SV*);
+       while (sv) {
+           imop = append_elem(OP_LIST, imop, newSVOP(OP_CONST, 0, sv));
+           sv = va_arg(*args, SV*);
+       }
+    }
+    {
+       line_t ocopline = PL_copline;
+       int oexpect = PL_expect;
+
+       utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
+               veop, modname, imop);
+       PL_expect = oexpect;
+       PL_copline = ocopline;
+    }
+}
+
 OP *
 Perl_dofile(pTHX_ OP *term)
 {
@@ -3448,9 +3532,9 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
         PL_copline = NOLINE;
     }
 #ifdef USE_ITHREADS
-    CopFILE_set(cop, CopFILE(PL_curcop));      /* XXXXX share in a pvtable? */
+    CopFILE_set(cop, CopFILE(PL_curcop));      /* XXX share in a pvtable? */
 #else
-    CopFILEGV_set(cop, (GV*)SvREFCNT_inc(CopFILEGV(PL_curcop)));
+    CopFILEGV_set(cop, CopFILEGV(PL_curcop));
 #endif
     CopSTASH_set(cop, PL_curstash);
 
@@ -3810,7 +3894,10 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *
        loopflags |= OPpLOOP_CONTINUE;
     }
     if (expr) {
-       cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0));
+       OP *unstack = newOP(OP_UNSTACK, 0);
+       if (!next)
+           next = unstack;
+       cont = append_elem(OP_LINESEQ, cont, unstack);
        if ((line_t)whileline != NOLINE) {
            PL_copline = whileline;
            cont = append_elem(OP_LINESEQ, cont,
@@ -3833,8 +3920,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *
        if (listop)
            ((LISTOP*)listop)->op_last->op_next = condop =
                (o == listop ? redo : LINKLIST(o));
-       if (!next)
-           next = condop;
     }
     else
        o = listop;
@@ -4114,9 +4199,8 @@ S_cv_clone2(pTHX_ CV *proto, CV *outside)
 
     cv = PL_compcv = (CV*)NEWSV(1104,0);
     sv_upgrade((SV *)cv, SvTYPE(proto));
+    CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
     CvCLONED_on(cv);
-    if (CvANON(proto))
-       CvANON_on(cv);
 
 #ifdef USE_THREADS
     New(666, CvMUTEXP(cv), 1, perl_mutex);
@@ -4379,9 +4463,15 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     if (!name || GvCVGEN(gv))
        cv = Nullcv;
     else if ((cv = GvCV(gv))) {
-       cv_ckproto(cv, gv, ps);
+        bool exists = CvROOT(cv) || CvXSUB(cv);
+        /* 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(cv, gv, ps);
        /* already defined (or promised)? */
-       if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
+       if (exists || GvASSUMECV(gv)) {
            SV* const_sv;
            bool const_changed = TRUE;
            if (!block && !attrs) {
@@ -4396,7 +4486,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                goto withattrs;
            if ((const_sv = cv_const_sv(cv)))
                const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
-           if ((const_sv || const_changed) && ckWARN(WARN_REDEFINE))
+            if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE))
            {
                line_t oldline = CopLINE(PL_curcop);
                CopLINE_set(PL_curcop, PL_copline);
@@ -4599,8 +4689,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            if (!PL_beginav)
                PL_beginav = newAV();
            DEBUG_x( dump_sub(gv) );
-           av_push(PL_beginav, SvREFCNT_inc(cv));
-           GvCV(gv) = 0;
+           av_push(PL_beginav, (SV*)cv);
+           GvCV(gv) = 0;               /* cv has been hijacked */
            call_list(oldscope, PL_beginav);
 
            PL_curcop = &PL_compiling;
@@ -4612,23 +4702,27 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                PL_endav = newAV();
            DEBUG_x( dump_sub(gv) );
            av_unshift(PL_endav, 1);
-           av_store(PL_endav, 0, SvREFCNT_inc(cv));
-           GvCV(gv) = 0;
+           av_store(PL_endav, 0, (SV*)cv);
+           GvCV(gv) = 0;               /* cv has been hijacked */
        }
        else if (strEQ(s, "CHECK") && !PL_error_count) {
            if (!PL_checkav)
                PL_checkav = newAV();
            DEBUG_x( dump_sub(gv) );
+           if (PL_main_start && ckWARN(WARN_VOID))
+               Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
            av_unshift(PL_checkav, 1);
-           av_store(PL_checkav, 0, SvREFCNT_inc(cv));
-           GvCV(gv) = 0;
+           av_store(PL_checkav, 0, (SV*)cv);
+           GvCV(gv) = 0;               /* cv has been hijacked */
        }
        else if (strEQ(s, "INIT") && !PL_error_count) {
            if (!PL_initav)
                PL_initav = newAV();
            DEBUG_x( dump_sub(gv) );
-           av_push(PL_initav, SvREFCNT_inc(cv));
-           GvCV(gv) = 0;
+           if (PL_main_start && ckWARN(WARN_VOID))
+               Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
+           av_push(PL_initav, (SV*)cv);
+           GvCV(gv) = 0;               /* cv has been hijacked */
        }
     }
 
@@ -4654,10 +4748,11 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
     dTHR;
 
     ENTER;
-    SAVECOPLINE(PL_curcop);
-    SAVEHINTS();
 
+    SAVECOPLINE(PL_curcop);
     CopLINE_set(PL_curcop, PL_copline);
+
+    SAVEHINTS();
     PL_hints &= ~HINT_BLOCK_SCOPE;
 
     if (stash) {
@@ -4754,28 +4849,32 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
        if (strEQ(s, "BEGIN")) {
            if (!PL_beginav)
                PL_beginav = newAV();
-           av_push(PL_beginav, SvREFCNT_inc(cv));
-           GvCV(gv) = 0;
+           av_push(PL_beginav, (SV*)cv);
+           GvCV(gv) = 0;               /* cv has been hijacked */
        }
        else if (strEQ(s, "END")) {
            if (!PL_endav)
                PL_endav = newAV();
            av_unshift(PL_endav, 1);
-           av_store(PL_endav, 0, SvREFCNT_inc(cv));
-           GvCV(gv) = 0;
+           av_store(PL_endav, 0, (SV*)cv);
+           GvCV(gv) = 0;               /* cv has been hijacked */
        }
        else if (strEQ(s, "CHECK")) {
            if (!PL_checkav)
                PL_checkav = newAV();
+           if (PL_main_start && ckWARN(WARN_VOID))
+               Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
            av_unshift(PL_checkav, 1);
-           av_store(PL_checkav, 0, SvREFCNT_inc(cv));
-           GvCV(gv) = 0;
+           av_store(PL_checkav, 0, (SV*)cv);
+           GvCV(gv) = 0;               /* cv has been hijacked */
        }
        else if (strEQ(s, "INIT")) {
            if (!PL_initav)
                PL_initav = newAV();
-           av_push(PL_initav, SvREFCNT_inc(cv));
-           GvCV(gv) = 0;
+           if (PL_main_start && ckWARN(WARN_VOID))
+               Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
+           av_push(PL_initav, (SV*)cv);
+           GvCV(gv) = 0;               /* cv has been hijacked */
        }
     }
     else
@@ -5119,6 +5218,20 @@ Perl_ck_eval(pTHX_ OP *o)
 }
 
 OP *
+Perl_ck_exit(pTHX_ OP *o)
+{
+#ifdef VMS
+    HV *table = GvHV(PL_hintgv);
+    if (table) {
+       SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
+       if (svp && *svp && SvTRUE(*svp))
+           o->op_private |= OPpEXIT_VMSISH;
+    }
+#endif
+    return ck_fun(o);
+}
+
+OP *
 Perl_ck_exec(pTHX_ OP *o)
 {
     OP *kid;
@@ -5265,6 +5378,7 @@ Perl_ck_rvconst(pTHX_ register OP *o)
 #ifdef USE_ITHREADS
            /* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
            kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
+           SvREFCNT_dec(PL_curpad[kPADOP->op_padix]);
            GvIN_PAD_on(gv);
            PL_curpad[kPADOP->op_padix] = SvREFCNT_inc(gv);
 #else
@@ -5461,6 +5575,13 @@ Perl_ck_fun(pTHX_ OP *o)
                                name = GvNAME(gv);
                                len = GvNAMELEN(gv);
                            }
+                           else if (kid->op_type == OP_AELEM
+                                    || kid->op_type == OP_HELEM)
+                           {
+                               name = "__ANONIO__";
+                               len = 10;
+                               mod(kid,type);
+                           }
                            if (name) {
                                SV *namesv;
                                targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
@@ -5523,11 +5644,10 @@ Perl_ck_glob(pTHX_ OP *o)
 #if !defined(PERL_EXTERNAL_GLOB)
     /* XXX this can be tightened up and made more failsafe. */
     if (!gv) {
-       OP *modname = newSVOP(OP_CONST, 0, newSVpvn("File::Glob", 10));
-       modname->op_private |= OPpCONST_BARE;
        ENTER;
-       utilize(1, start_subparse(FALSE, 0), Nullop, modname,
-               newSVOP(OP_CONST, 0, newSVpvn(":globally", 9)));
+       Perl_load_module(aTHX_ 0, newSVpvn("File::Glob", 10), Nullsv,
+                        /* null-terminated import list */
+                        newSVpvn(":globally", 9), Nullsv);
        gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
        LEAVE;
     }
@@ -5646,7 +5766,7 @@ Perl_ck_defined(pTHX_ OP *o)              /* 19990527 MJD */
            Perl_warner(aTHX_ WARN_DEPRECATED,
                        "defined(@array) is deprecated");
            Perl_warner(aTHX_ WARN_DEPRECATED,
-                       "(Maybe you should just omit the defined()?)\n");
+                       "\t(Maybe you should just omit the defined()?)\n");
        break;
        case OP_RV2HV:
            break;                      /* Globals via GV can be undef */ 
@@ -5654,7 +5774,7 @@ Perl_ck_defined(pTHX_ OP *o)              /* 19990527 MJD */
            Perl_warner(aTHX_ WARN_DEPRECATED,
                        "defined(%%hash) is deprecated");
            Perl_warner(aTHX_ WARN_DEPRECATED,
-                       "(Maybe you should just omit the defined()?)\n");
+                       "\t(Maybe you should just omit the defined()?)\n");
            break;
        default:
            /* no warning */
@@ -5799,6 +5919,36 @@ Perl_ck_null(pTHX_ OP *o)
 }
 
 OP *
+Perl_ck_open(pTHX_ OP *o)
+{
+    HV *table = GvHV(PL_hintgv);
+    if (table) {
+       SV **svp;
+       I32 mode;
+       svp = hv_fetch(table, "open_IN", 7, FALSE);
+       if (svp && *svp) {
+           mode = mode_from_discipline(*svp);
+           if (mode & O_BINARY)
+               o->op_private |= OPpOPEN_IN_RAW;
+           else if (mode & O_TEXT)
+               o->op_private |= OPpOPEN_IN_CRLF;
+       }
+
+       svp = hv_fetch(table, "open_OUT", 8, FALSE);
+       if (svp && *svp) {
+           mode = mode_from_discipline(*svp);
+           if (mode & O_BINARY)
+               o->op_private |= OPpOPEN_OUT_RAW;
+           else if (mode & O_TEXT)
+               o->op_private |= OPpOPEN_OUT_CRLF;
+       }
+    }
+    if (o->op_type == OP_BACKTICK)
+       return o;
+    return ck_fun(o);
+}
+
+OP *
 Perl_ck_repeat(pTHX_ OP *o)
 {
     if (cBINOPo->op_first->op_flags & OPf_PARENS) {
@@ -5825,7 +5975,13 @@ Perl_ck_require(pTHX_ OP *o)
                    --SvCUR(kid->op_sv);
                }
            }
-           sv_catpvn(kid->op_sv, ".pm", 3);
+           if (SvREADONLY(kid->op_sv)) {
+               SvREADONLY_off(kid->op_sv);
+               sv_catpvn(kid->op_sv, ".pm", 3);
+               SvREADONLY_on(kid->op_sv);
+           }
+           else
+               sv_catpvn(kid->op_sv, ".pm", 3);
        }
     }
     return ck_fun(o);
@@ -5893,6 +6049,7 @@ Perl_ck_shift(pTHX_ OP *o)
 OP *
 Perl_ck_sort(pTHX_ OP *o)
 {
+    OP *firstkid;
     o->op_private = 0;
 #ifdef USE_LOCALE
     if (PL_hints & HINT_LOCALE)
@@ -5901,10 +6058,10 @@ Perl_ck_sort(pTHX_ OP *o)
 
     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
        simplify_sort(o);
-    if (o->op_flags & OPf_STACKED) {                /* may have been cleared */
-       OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
+    firstkid = cLISTOPo->op_first->op_sibling;         /* get past pushmark */
+    if (o->op_flags & OPf_STACKED) {                   /* may have been cleared */
        OP *k;
-       kid = kUNOP->op_first;                          /* get past null */
+       OP *kid = cUNOPx(firstkid)->op_first;           /* get past null */
 
        if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
            linklist(kid);
@@ -5920,6 +6077,12 @@ Perl_ck_sort(pTHX_ OP *o)
                    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;
+                       }
                    }
                }
                else
@@ -5928,17 +6091,26 @@ Perl_ck_sort(pTHX_ OP *o)
            }
            peep(k);
 
-           kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
-           if (o->op_type == OP_SORT)
+           kid = firstkid;
+           if (o->op_type == OP_SORT) {
+               /* provide scalar context for comparison function/block */
+               kid = scalar(kid);
                kid->op_next = kid;
+           }
            else
                kid->op_next = k;
            o->op_flags |= OPf_SPECIAL;
        }
        else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
-           null(cLISTOPo->op_first->op_sibling);
+           null(firstkid);
+
+       firstkid = firstkid->op_sibling;
     }
 
+    /* provide list context for arguments */
+    if (o->op_type == OP_SORT)
+       list(firstkid);
+
     return o;
 }
 
@@ -6144,7 +6316,9 @@ Perl_ck_subr(pTHX_ OP *o)
                proto++;
                arg++;
                if (o2->op_type != OP_REFGEN && o2->op_type != OP_UNDEF)
-                   bad_type(arg, "block", gv_ename(namegv), o2);
+                   bad_type(arg,
+                       arg == 1 ? "block or sub {}" : "sub {}",
+                       gv_ename(namegv), o2);
                break;
            case '*':
                /* '*' allows any scalar type, including bareword */
@@ -6192,8 +6366,8 @@ Perl_ck_subr(pTHX_ OP *o)
                        bad_type(arg, "symbol", gv_ename(namegv), o2);
                    goto wrapref;
                case '&':
-                   if (o2->op_type != OP_RV2CV)
-                       bad_type(arg, "sub", gv_ename(namegv), o2);
+                   if (o2->op_type != OP_ENTERSUB)
+                       bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
                    goto wrapref;
                case '$':
                    if (o2->op_type != OP_RV2SV
@@ -6310,26 +6484,32 @@ Perl_peep(pTHX_ register OP *o)
             * for reference counts, sv_upgrade() etc. */
            if (cSVOP->op_sv) {
                PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
-               SvREFCNT_dec(PL_curpad[ix]);
-               SvPADTMP_on(cSVOPo->op_sv);
-               PL_curpad[ix] = cSVOPo->op_sv;
+               if (SvPADTMP(cSVOPo->op_sv)) {
+                   /* If op_sv is already a PADTMP then it is being used by
+                    * another pad, so make a copy. */
+                   sv_setsv(PL_curpad[ix],cSVOPo->op_sv);
+                   SvREADONLY_on(PL_curpad[ix]);
+                   SvREFCNT_dec(cSVOPo->op_sv);
+               }
+               else {
+                   SvREFCNT_dec(PL_curpad[ix]);
+                   SvPADTMP_on(cSVOPo->op_sv);
+                   PL_curpad[ix] = cSVOPo->op_sv;
+               }
                cSVOPo->op_sv = Nullsv;
                o->op_targ = ix;
            }
 #endif
-           /* FALL THROUGH */
-       case OP_UC:
-       case OP_UCFIRST:
-       case OP_LC:
-       case OP_LCFIRST:
+           o->op_seq = PL_op_seqmax++;
+           break;
+
        case OP_CONCAT:
-       case OP_JOIN:
-       case OP_QUOTEMETA:
            if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
                if (o->op_next->op_private & OPpTARGET_MY) {
                    if (o->op_flags & OPf_STACKED) /* chained concats */
                        goto ignore_optimization;
                    else {
+                       /* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
                        o->op_targ = o->op_next->op_targ;
                        o->op_next->op_targ = 0;
                        o->op_private |= OPpTARGET_MY;
@@ -6458,7 +6638,7 @@ Perl_peep(pTHX_ register OP *o)
                    Perl_warner(aTHX_ WARN_EXEC,
                                "Statement unlikely to be reached");
                    Perl_warner(aTHX_ WARN_EXEC,
-                               "(Maybe you meant system() when you said exec()?)\n");
+                               "\t(Maybe you meant system() when you said exec()?)\n");
                    CopLINE_set(PL_curcop, oldline);
                }
            }