This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Fix for RT#1804: Anonymous glob breaks when assigned through
[perl5.git] / pp_hot.c
diff --git a/pp_hot.c b/pp_hot.c
index a60a176..bd0f909 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -52,6 +52,7 @@ PP(pp_nextstate)
     TAINT_NOT;         /* Each statement is presumed innocent */
     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
     FREETMPS;
     TAINT_NOT;         /* Each statement is presumed innocent */
     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
     FREETMPS;
+    PERL_ASYNC_CHECK();
     return NORMAL;
 }
 
     return NORMAL;
 }
 
@@ -98,6 +99,7 @@ PP(pp_gv)
 PP(pp_and)
 {
     dVAR; dSP;
 PP(pp_and)
 {
     dVAR; dSP;
+    PERL_ASYNC_CHECK();
     if (!SvTRUE(TOPs))
        RETURN;
     else {
     if (!SvTRUE(TOPs))
        RETURN;
     else {
@@ -110,6 +112,7 @@ PP(pp_and)
 PP(pp_sassign)
 {
     dVAR; dSP; dPOPTOPssrl;
 PP(pp_sassign)
 {
     dVAR; dSP; dPOPTOPssrl;
+    U32 wasfake = 0;
 
     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
        SV * const temp = left;
 
     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
        SV * const temp = left;
@@ -157,7 +160,7 @@ PP(pp_sassign)
            /* We've been returned a constant rather than a full subroutine,
               but they expect a subroutine reference to apply.  */
            if (SvROK(cv)) {
            /* We've been returned a constant rather than a full subroutine,
               but they expect a subroutine reference to apply.  */
            if (SvROK(cv)) {
-               ENTER;
+               ENTER_with_name("sassign_coderef");
                SvREFCNT_inc_void(SvRV(cv));
                /* newCONSTSUB takes a reference count on the passed in SV
                   from us.  We set the name to NULL, otherwise we get into
                SvREFCNT_inc_void(SvRV(cv));
                /* newCONSTSUB takes a reference count on the passed in SV
                   from us.  We set the name to NULL, otherwise we get into
@@ -167,7 +170,7 @@ PP(pp_sassign)
                SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
                                                      SvRV(cv))));
                SvREFCNT_dec(cv);
                SvRV_set(left, MUTABLE_SV(newCONSTSUB(GvSTASH(right), NULL,
                                                      SvRV(cv))));
                SvREFCNT_dec(cv);
-               LEAVE;
+               LEAVE_with_name("sassign_coderef");
            } else {
                /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
                   is that
            } else {
                /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
                   is that
@@ -195,7 +198,14 @@ PP(pp_sassign)
        }
 
     }
        }
 
     }
+    /* Allow glob assignments like *$x = ..., which, when the glob has a
+       SVf_FAKE flag, cannot be distinguished from $x = ... without looking
+       at the op tree. */
+    if( SvTYPE(right) == SVt_PVGV && cBINOP->op_last->op_type == OP_RV2GV
+     && (wasfake = SvFLAGS(right) & SVf_FAKE) )
+       SvFLAGS(right) &= ~SVf_FAKE;
     SvSetMagicSV(right, left);
     SvSetMagicSV(right, left);
+    if(wasfake) SvFLAGS(right) |= SVf_FAKE;
     SETs(right);
     RETURN;
 }
     SETs(right);
     RETURN;
 }
@@ -203,6 +213,7 @@ PP(pp_sassign)
 PP(pp_cond_expr)
 {
     dVAR; dSP;
 PP(pp_cond_expr)
 {
     dVAR; dSP;
+    PERL_ASYNC_CHECK();
     if (SvTRUEx(POPs))
        RETURNOP(cLOGOP->op_other);
     else
     if (SvTRUEx(POPs))
        RETURNOP(cLOGOP->op_other);
     else
@@ -213,6 +224,7 @@ PP(pp_unstack)
 {
     dVAR;
     I32 oldsave;
 {
     dVAR;
     I32 oldsave;
+    PERL_ASYNC_CHECK();
     TAINT_NOT;         /* Each statement is presumed innocent */
     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
     FREETMPS;
     TAINT_NOT;         /* Each statement is presumed innocent */
     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
     FREETMPS;
@@ -223,7 +235,7 @@ PP(pp_unstack)
 
 PP(pp_concat)
 {
 
 PP(pp_concat)
 {
-  dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
+  dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
   {
     dPOPTOPssrl;
     bool lbyte;
   {
     dPOPTOPssrl;
     bool lbyte;
@@ -232,18 +244,17 @@ PP(pp_concat)
     bool rbyte = FALSE;
     bool rcopied = FALSE;
 
     bool rbyte = FALSE;
     bool rcopied = FALSE;
 
-    if (TARG == right && right != left) {
-       /* mg_get(right) may happen here ... */
-       rpv = SvPV_const(right, rlen);
+    if (TARG == right && right != left) { /* $r = $l.$r */
+       rpv = SvPV_nomg_const(right, rlen);
        rbyte = !DO_UTF8(right);
        right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
        rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
        rcopied = TRUE;
     }
 
        rbyte = !DO_UTF8(right);
        right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
        rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
        rcopied = TRUE;
     }
 
-    if (TARG != left) {
+    if (TARG != left) { /* not $l .= $r */
         STRLEN llen;
         STRLEN llen;
-        const char* const lpv = SvPV_const(left, llen);        /* mg_get(left) may happen here */
+        const char* const lpv = SvPV_nomg_const(left, llen);
        lbyte = !DO_UTF8(left);
        sv_setpvn(TARG, lpv, llen);
        if (!lbyte)
        lbyte = !DO_UTF8(left);
        sv_setpvn(TARG, lpv, llen);
        if (!lbyte)
@@ -251,23 +262,23 @@ PP(pp_concat)
        else
            SvUTF8_off(TARG);
     }
        else
            SvUTF8_off(TARG);
     }
-    else { /* TARG == left */
-        STRLEN llen;
-       SvGETMAGIC(left);               /* or mg_get(left) may happen here */
+    else { /* $l .= $r */
        if (!SvOK(TARG)) {
        if (!SvOK(TARG)) {
-           if (left == right && ckWARN(WARN_UNINITIALIZED))
+           if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
                report_uninit(right);
            sv_setpvs(left, "");
        }
                report_uninit(right);
            sv_setpvs(left, "");
        }
-       (void)SvPV_nomg_const(left, llen);    /* Needed to set UTF8 flag */
-       lbyte = !DO_UTF8(left);
+       lbyte = (SvROK(left) && SvTYPE(SvRV(left)) == SVt_REGEXP)
+                   ?  !DO_UTF8(SvRV(left)) : !DO_UTF8(left);
        if (IN_BYTES)
            SvUTF8_off(TARG);
     }
 
        if (IN_BYTES)
            SvUTF8_off(TARG);
     }
 
-    /* or mg_get(right) may happen here */
     if (!rcopied) {
     if (!rcopied) {
-       rpv = SvPV_const(right, rlen);
+       if (left == right)
+           /* $r.$r: do magic twice: tied might return different 2nd time */
+           SvGETMAGIC(right);
+       rpv = SvPV_nomg_const(right, rlen);
        rbyte = !DO_UTF8(right);
     }
     if (lbyte != rbyte) {
        rbyte = !DO_UTF8(right);
     }
     if (lbyte != rbyte) {
@@ -277,7 +288,7 @@ PP(pp_concat)
            if (!rcopied)
                right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
            sv_utf8_upgrade_nomg(right);
            if (!rcopied)
                right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
            sv_utf8_upgrade_nomg(right);
-           rpv = SvPV_const(right, rlen);
+           rpv = SvPV_nomg_const(right, rlen);
        }
     }
     sv_catpvn_nomg(TARG, rpv, rlen);
        }
     }
     sv_catpvn_nomg(TARG, rpv, rlen);
@@ -325,7 +336,8 @@ PP(pp_readline)
 
 PP(pp_eq)
 {
 
 PP(pp_eq)
 {
-    dVAR; dSP; tryAMAGICbinSET(eq,0);
+    dVAR; dSP;
+    tryAMAGICbin_MG(eq_amg, AMGf_set);
 #ifndef NV_PRESERVES_UV
     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
         SP--;
 #ifndef NV_PRESERVES_UV
     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
         SP--;
@@ -334,12 +346,12 @@ PP(pp_eq)
     }
 #endif
 #ifdef PERL_PRESERVE_IVUV
     }
 #endif
 #ifdef PERL_PRESERVE_IVUV
-    SvIV_please(TOPs);
+    SvIV_please_nomg(TOPs);
     if (SvIOK(TOPs)) {
        /* Unless the left argument is integer in range we are going
           to have to use NV maths. Hence only attempt to coerce the
           right argument if we know the left is integer.  */
     if (SvIOK(TOPs)) {
        /* Unless the left argument is integer in range we are going
           to have to use NV maths. Hence only attempt to coerce the
           right argument if we know the left is integer.  */
-      SvIV_please(TOPm1s);
+      SvIV_please_nomg(TOPm1s);
        if (SvIOK(TOPm1s)) {
            const bool auvok = SvUOK(TOPm1s);
            const bool buvok = SvUOK(TOPs);
        if (SvIOK(TOPm1s)) {
            const bool auvok = SvUOK(TOPm1s);
            const bool buvok = SvUOK(TOPs);
@@ -384,13 +396,13 @@ PP(pp_eq)
 #endif
     {
 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
 #endif
     {
 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
-      dPOPTOPnnrl;
+      dPOPTOPnnrl_nomg;
       if (Perl_isnan(left) || Perl_isnan(right))
          RETSETNO;
       SETs(boolSV(left == right));
 #else
       if (Perl_isnan(left) || Perl_isnan(right))
          RETSETNO;
       SETs(boolSV(left == right));
 #else
-      dPOPnv;
-      SETs(boolSV(TOPn == value));
+      dPOPnv_nomg;
+      SETs(boolSV(SvNV_nomg(TOPs) == value));
 #endif
       RETURN;
     }
 #endif
       RETURN;
     }
@@ -400,7 +412,7 @@ PP(pp_preinc)
 {
     dVAR; dSP;
     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
 {
     dVAR; dSP;
     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
-       DIE(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
         && SvIVX(TOPs) != IV_MAX)
     {
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
         && SvIVX(TOPs) != IV_MAX)
     {
@@ -416,6 +428,7 @@ PP(pp_preinc)
 PP(pp_or)
 {
     dVAR; dSP;
 PP(pp_or)
 {
     dVAR; dSP;
+    PERL_ASYNC_CHECK();
     if (SvTRUE(TOPs))
        RETURN;
     else {
     if (SvTRUE(TOPs))
        RETURN;
     else {
@@ -434,6 +447,7 @@ PP(pp_defined)
     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
 
     if (is_dor) {
     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
 
     if (is_dor) {
+       PERL_ASYNC_CHECK();
         sv = TOPs;
         if (!sv || !SvANY(sv)) {
            if (op_type == OP_DOR)
         sv = TOPs;
         if (!sv || !SvANY(sv)) {
            if (op_type == OP_DOR)
@@ -485,9 +499,10 @@ PP(pp_defined)
 PP(pp_add)
 {
     dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
 PP(pp_add)
 {
     dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
-    tryAMAGICbin(add,opASSIGN);
-    svl = sv_2num(TOPm1s);
-    svr = sv_2num(TOPs);
+    tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
+    svr = TOPs;
+    svl = TOPm1s;
+
     useleft = USE_LEFT(svl);
 #ifdef PERL_PRESERVE_IVUV
     /* We must see if we can perform the addition with integers if possible,
     useleft = USE_LEFT(svl);
 #ifdef PERL_PRESERVE_IVUV
     /* We must see if we can perform the addition with integers if possible,
@@ -536,7 +551,8 @@ PP(pp_add)
        unsigned code below is actually shorter than the old code. :-)
     */
 
        unsigned code below is actually shorter than the old code. :-)
     */
 
-    SvIV_please(svr);
+    SvIV_please_nomg(svr);
+
     if (SvIOK(svr)) {
        /* Unless the left argument is integer in range we are going to have to
           use NV maths. Hence only attempt to coerce the right argument if
     if (SvIOK(svr)) {
        /* Unless the left argument is integer in range we are going to have to
           use NV maths. Hence only attempt to coerce the right argument if
@@ -553,7 +569,7 @@ PP(pp_add)
               lots of code to speed up what is probably a rarish case.  */
        } else {
            /* Left operand is defined, so is it IV? */
               lots of code to speed up what is probably a rarish case.  */
        } else {
            /* Left operand is defined, so is it IV? */
-           SvIV_please(svl);
+           SvIV_please_nomg(svl);
            if (SvIOK(svl)) {
                if ((auvok = SvUOK(svl)))
                    auv = SvUVX(svl);
            if (SvIOK(svl)) {
                if ((auvok = SvUOK(svl)))
                    auv = SvUVX(svl);
@@ -636,14 +652,14 @@ PP(pp_add)
     }
 #endif
     {
     }
 #endif
     {
-       NV value = SvNV(svr);
+       NV value = SvNV_nomg(svr);
        (void)POPs;
        if (!useleft) {
            /* left operand is undef, treat as zero. + 0.0 is identity. */
            SETn(value);
            RETURN;
        }
        (void)POPs;
        if (!useleft) {
            /* left operand is undef, treat as zero. + 0.0 is identity. */
            SETn(value);
            RETURN;
        }
-       SETn( value + SvNV(svl) );
+       SETn( value + SvNV_nomg(svl) );
        RETURN;
     }
 }
        RETURN;
     }
 }
@@ -657,8 +673,8 @@ PP(pp_aelemfast)
     SV** const svp = av_fetch(av, PL_op->op_private, lval);
     SV *sv = (svp ? *svp : &PL_sv_undef);
     EXTEND(SP, 1);
     SV** const svp = av_fetch(av, PL_op->op_private, lval);
     SV *sv = (svp ? *svp : &PL_sv_undef);
     EXTEND(SP, 1);
-    if (!lval && SvGMAGICAL(sv))       /* see note in pp_helem() */
-       sv = sv_mortalcopy(sv);
+    if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
+       mg_get(sv);
     PUSHs(sv);
     RETURN;
 }
     PUSHs(sv);
     RETURN;
 }
@@ -719,14 +735,14 @@ PP(pp_print)
        PUSHMARK(MARK - 1);
        *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
        PUTBACK;
        PUSHMARK(MARK - 1);
        *MARK = SvTIED_obj(MUTABLE_SV(io), mg);
        PUTBACK;
-       ENTER;
+       ENTER_with_name("call_PRINT");
        if( PL_op->op_type == OP_SAY ) {
                /* local $\ = "\n" */
                SAVEGENERICSV(PL_ors_sv);
                PL_ors_sv = newSVpvs("\n");
        }
        call_method("PRINT", G_SCALAR);
        if( PL_op->op_type == OP_SAY ) {
                /* local $\ = "\n" */
                SAVEGENERICSV(PL_ors_sv);
                PL_ors_sv = newSVpvs("\n");
        }
        call_method("PRINT", G_SCALAR);
-       LEAVE;
+       LEAVE_with_name("call_PRINT");
        SPAGAIN;
        MARK = ORIGMARK + 1;
        *MARK = *SP;
        SPAGAIN;
        MARK = ORIGMARK + 1;
        *MARK = *SP;
@@ -734,7 +750,7 @@ PP(pp_print)
        RETURN;
     }
     if (!(io = GvIO(gv))) {
        RETURN;
     }
     if (!(io = GvIO(gv))) {
-        if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
+        if ((GvEGVx(gv)) && (io = GvIO(GvEGV(gv)))
            && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
             goto had_magic;
        if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
            && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
             goto had_magic;
        if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
@@ -811,8 +827,9 @@ PP(pp_rv2av)
     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
 
     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
 
+    if (!(PL_op->op_private & OPpDEREFed))
+       SvGETMAGIC(sv);
     if (SvROK(sv)) {
     if (SvROK(sv)) {
-      wasref:
        tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
 
        sv = SvRV(sv);
        tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
 
        sv = SvRV(sv);
@@ -849,11 +866,6 @@ PP(pp_rv2av)
            GV *gv;
        
            if (!isGV_with_GP(sv)) {
            GV *gv;
        
            if (!isGV_with_GP(sv)) {
-               if (SvGMAGICAL(sv)) {
-                   mg_get(sv);
-                   if (SvROK(sv))
-                       goto wasref;
-               }
                gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
                                     type, &sp);
                if (!gv)
                gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
                                     type, &sp);
                if (!gv)
@@ -893,7 +905,7 @@ PP(pp_rv2av)
                SV ** const svp = av_fetch(av, i, FALSE);
                /* See note in pp_helem, and bug id #27839 */
                SP[i+1] = svp
                SV ** const svp = av_fetch(av, i, FALSE);
                /* See note in pp_helem, and bug id #27839 */
                SP[i+1] = svp
-                   ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
+                   ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
                    : &PL_sv_undef;
            }
        }
                    : &PL_sv_undef;
            }
        }
@@ -998,7 +1010,17 @@ PP(pp_aassign)
        for (relem = firstrelem; relem <= lastrelem; relem++) {
            if ((sv = *relem)) {
                TAINT_NOT;      /* Each item is independent */
        for (relem = firstrelem; relem <= lastrelem; relem++) {
            if ((sv = *relem)) {
                TAINT_NOT;      /* Each item is independent */
-               *relem = sv_mortalcopy(sv);
+
+               /* Dear TODO test in t/op/sort.t, I love you.
+                  (It's relying on a panic, not a "semi-panic" from newSVsv()
+                  and then an assertion failure below.)  */
+               if (SvIS_FREED(sv)) {
+                   Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
+                              (void*)sv);
+               }
+               /* Specifically *not* sv_mortalcopy(), as that will steal TEMPs,
+                  and we need a second copy of a temp here.  */
+               *relem = sv_2mortal(newSVsv(sv));
            }
        }
     }
            }
        }
     }
@@ -1021,24 +1043,19 @@ PP(pp_aassign)
            while (relem <= lastrelem) {        /* gobble up all the rest */
                SV **didstore;
                assert(*relem);
            while (relem <= lastrelem) {        /* gobble up all the rest */
                SV **didstore;
                assert(*relem);
-               sv = newSVsv(*relem);
+               sv = newSV(0);
+               sv_setsv(sv, *relem);
                *(relem++) = sv;
                didstore = av_store(ary,i++,sv);
                if (magic) {
                *(relem++) = sv;
                didstore = av_store(ary,i++,sv);
                if (magic) {
-                   if (SvSMAGICAL(sv)) {
-                       /* More magic can happen in the mg_set callback, so we
-                        * backup the delaymagic for now. */
-                       U16 dmbak = PL_delaymagic;
-                       PL_delaymagic = 0;
+                   if (SvSMAGICAL(sv))
                        mg_set(sv);
                        mg_set(sv);
-                       PL_delaymagic = dmbak;
-                   }
                    if (!didstore)
                        sv_2mortal(sv);
                }
                TAINT_NOT;
            }
                    if (!didstore)
                        sv_2mortal(sv);
                }
                TAINT_NOT;
            }
-           if (PL_delaymagic & DM_ARRAY)
+           if (PL_delaymagic & DM_ARRAY_ISA)
                SvSETMAGIC(MUTABLE_SV(ary));
            break;
        case SVt_PVHV: {                                /* normal hash */
                SvSETMAGIC(MUTABLE_SV(ary));
            break;
        case SVt_PVHV: {                                /* normal hash */
@@ -1062,12 +1079,8 @@ PP(pp_aassign)
                        duplicates += 2;
                    didstore = hv_store_ent(hash,sv,tmpstr,0);
                    if (magic) {
                        duplicates += 2;
                    didstore = hv_store_ent(hash,sv,tmpstr,0);
                    if (magic) {
-                       if (SvSMAGICAL(tmpstr)) {
-                           U16 dmbak = PL_delaymagic;
-                           PL_delaymagic = 0;
+                       if (SvSMAGICAL(tmpstr))
                            mg_set(tmpstr);
                            mg_set(tmpstr);
-                           PL_delaymagic = dmbak;
-                       }
                        if (!didstore)
                            sv_2mortal(tmpstr);
                    }
                        if (!didstore)
                            sv_2mortal(tmpstr);
                    }
@@ -1091,13 +1104,7 @@ PP(pp_aassign)
            }
            else
                sv_setsv(sv, &PL_sv_undef);
            }
            else
                sv_setsv(sv, &PL_sv_undef);
-
-           if (SvSMAGICAL(sv)) {
-               U16 dmbak = PL_delaymagic;
-               PL_delaymagic = 0;
-               mg_set(sv);
-               PL_delaymagic = dmbak;
-           }
+           SvSETMAGIC(sv);
            break;
        }
     }
            break;
        }
     }
@@ -1209,14 +1216,17 @@ PP(pp_qr)
     SV * const rv = sv_newmortal();
 
     SvUPGRADE(rv, SVt_IV);
     SV * const rv = sv_newmortal();
 
     SvUPGRADE(rv, SVt_IV);
-    /* This RV is about to own a reference to the regexp. (In addition to the
-       reference already owned by the PMOP.  */
-    ReREFCNT_inc(rx);
-    SvRV_set(rv, MUTABLE_SV(rx));
+    /* For a subroutine describing itself as "This is a hacky workaround" I'm
+       loathe to use it here, but it seems to be the right fix. Or close.
+       The key part appears to be that it's essential for pp_qr to return a new
+       object (SV), which implies that there needs to be an effective way to
+       generate a new SV from the existing SV that is pre-compiled in the
+       optree.  */
+    SvRV_set(rv, MUTABLE_SV(reg_temp_copy(NULL, rx)));
     SvROK_on(rv);
 
     if (pkg) {
     SvROK_on(rv);
 
     if (pkg) {
-       HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
+       HV *const stash = gv_stashsv(pkg, GV_ADD);
        SvREFCNT_dec(pkg);
        (void)sv_bless(rv, stash);
     }
        SvREFCNT_dec(pkg);
        (void)sv_bless(rv, stash);
     }
@@ -1258,7 +1268,11 @@ PP(pp_match)
     }
 
     PUTBACK;                           /* EVAL blocks need stack_sp. */
     }
 
     PUTBACK;                           /* EVAL blocks need stack_sp. */
-    s = SvPV_const(TARG, len);
+    /* Skip get-magic if this is a qr// clone, because regcomp has
+       already done it. */
+    s = ((struct regexp *)SvANY(rx))->mother_re
+        ? SvPV_nomg_const(TARG, len)
+        : SvPV_const(TARG, len);
     if (!s)
        DIE(aTHX_ "panic: pp_match");
     strend = s + len;
     if (!s)
        DIE(aTHX_ "panic: pp_match");
     strend = s + len;
@@ -1554,9 +1568,9 @@ Perl_do_readline(pTHX)
            PUSHMARK(SP);
            XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
            PUTBACK;
            PUSHMARK(SP);
            XPUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
            PUTBACK;
-           ENTER;
+           ENTER_with_name("call_READLINE");
            call_method("READLINE", gimme);
            call_method("READLINE", gimme);
-           LEAVE;
+           LEAVE_with_name("call_READLINE");
            SPAGAIN;
            if (gimme == G_SCALAR) {
                SV* const result = POPs;
            SPAGAIN;
            if (gimme == G_SCALAR) {
                SV* const result = POPs;
@@ -1633,8 +1647,12 @@ Perl_do_readline(pTHX)
        }
        SvUPGRADE(sv, SVt_PV);
        tmplen = SvLEN(sv);     /* remember if already alloced */
        }
        SvUPGRADE(sv, SVt_PV);
        tmplen = SvLEN(sv);     /* remember if already alloced */
-       if (!tmplen && !SvREADONLY(sv))
-           Sv_Grow(sv, 80);    /* try short-buffering it */
+       if (!tmplen && !SvREADONLY(sv)) {
+            /* try short-buffering it. Please update t/op/readline.t
+            * if you change the growth length.
+            */
+           Sv_Grow(sv, 80);
+        }
        offset = 0;
        if (type == OP_RCATLINE && SvOK(sv)) {
            if (!SvPOK(sv)) {
        offset = 0;
        if (type == OP_RCATLINE && SvOK(sv)) {
            if (!SvPOK(sv)) {
@@ -1675,11 +1693,11 @@ Perl_do_readline(pTHX)
                (void)do_close(PL_last_in_gv, FALSE);
            }
            else if (type == OP_GLOB) {
                (void)do_close(PL_last_in_gv, FALSE);
            }
            else if (type == OP_GLOB) {
-               if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
-                   Perl_warner(aTHX_ packWARN(WARN_GLOB),
-                          "glob failed (child exited with status %d%s)",
-                          (int)(STATUS_CURRENT >> 8),
-                          (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
+               if (!do_close(PL_last_in_gv, FALSE)) {
+                   Perl_ck_warner(aTHX_ packWARN(WARN_GLOB),
+                                  "glob failed (child exited with status %d%s)",
+                                  (int)(STATUS_CURRENT >> 8),
+                                  (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
                }
            }
            if (gimme == G_SCALAR) {
                }
            }
            if (gimme == G_SCALAR) {
@@ -1754,13 +1772,17 @@ PP(pp_enter)
     I32 gimme = OP_GIMME(PL_op, -1);
 
     if (gimme == -1) {
     I32 gimme = OP_GIMME(PL_op, -1);
 
     if (gimme == -1) {
-       if (cxstack_ix >= 0)
-           gimme = cxstack[cxstack_ix].blk_gimme;
-       else
+       if (cxstack_ix >= 0) {
+           /* If this flag is set, we're just inside a return, so we should
+            * store the caller's context */
+           gimme = (PL_op->op_flags & OPf_SPECIAL)
+               ? block_gimme()
+               : cxstack[cxstack_ix].blk_gimme;
+       } else
            gimme = G_SCALAR;
     }
 
            gimme = G_SCALAR;
     }
 
-    ENTER;
+    ENTER_with_name("block");
 
     SAVETMPS;
     PUSHBLOCK(cx, CXt_BLOCK, SP);
 
     SAVETMPS;
     PUSHBLOCK(cx, CXt_BLOCK, SP);
@@ -1779,28 +1801,24 @@ PP(pp_helem)
     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
     SV *sv;
     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
     SV *sv;
     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
-    I32 preeminent = 0;
+    const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
+    bool preeminent = TRUE;
 
     if (SvTYPE(hv) != SVt_PVHV)
        RETPUSHUNDEF;
 
 
     if (SvTYPE(hv) != SVt_PVHV)
        RETPUSHUNDEF;
 
-    if (PL_op->op_private & OPpLVAL_INTRO) {
+    if (localizing) {
        MAGIC *mg;
        HV *stash;
        MAGIC *mg;
        HV *stash;
-       /* does the element we're localizing already exist? */
-       preeminent = /* can we determine whether it exists? */
-           (    !SvRMAGICAL(hv)
-               || mg_find((const SV *)hv, PERL_MAGIC_env)
-               || (     (mg = mg_find((const SV *)hv, PERL_MAGIC_tied))
-                       /* Try to preserve the existenceness of a tied hash
-                       * element by using EXISTS and DELETE if possible.
-                       * Fallback to FETCH and STORE otherwise */
-                   && (stash = SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(hv), mg))))
-                   && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
-                   && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
-               )
-           ) ? hv_exists_ent(hv, keysv, 0) : 1;
+
+       /* If we can determine whether the element exist,
+        * Try to preserve the existenceness of a tied hash
+        * element by using EXISTS and DELETE if possible.
+        * Fallback to FETCH and STORE otherwise. */
+       if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
+           preeminent = hv_exists_ent(hv, keysv, 0);
     }
     }
+
     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
     svp = he ? &HeVAL(he) : NULL;
     if (lval) {
     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
     svp = he ? &HeVAL(he) : NULL;
     if (lval) {
@@ -1820,32 +1838,33 @@ PP(pp_helem)
            PUSHs(lv);
            RETURN;
        }
            PUSHs(lv);
            RETURN;
        }
-       if (PL_op->op_private & OPpLVAL_INTRO) {
+       if (localizing) {
            if (HvNAME_get(hv) && isGV(*svp))
                save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
            if (HvNAME_get(hv) && isGV(*svp))
                save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
-           else {
-               if (!preeminent) {
-                   STRLEN keylen;
-                   const char * const key = SvPV_const(keysv, keylen);
-                   SAVEDELETE(hv, savepvn(key,keylen),
-                              SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
-               } else
-                   save_helem_flags(hv, keysv, svp,
-                                    (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
-            }
+           else if (preeminent)
+               save_helem_flags(hv, keysv, svp,
+                    (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
+           else
+               SAVEHDELETE(hv, keysv);
        }
        else if (PL_op->op_private & OPpDEREF)
            vivify_ref(*svp, PL_op->op_private & OPpDEREF);
     }
     sv = (svp ? *svp : &PL_sv_undef);
        }
        else if (PL_op->op_private & OPpDEREF)
            vivify_ref(*svp, PL_op->op_private & OPpDEREF);
     }
     sv = (svp ? *svp : &PL_sv_undef);
-    /* This makes C<local $tied{foo} = $tied{foo}> possible.
-     * Pushing the magical RHS on to the stack is useless, since
-     * that magic is soon destined to be misled by the local(),
-     * and thus the later pp_sassign() will fail to mg_get() the
-     * old value.  This should also cure problems with delayed
-     * mg_get()s.  GSAR 98-07-03 */
-    if (!lval && SvGMAGICAL(sv))
-       sv = sv_mortalcopy(sv);
+    /* Originally this did a conditional C<sv = sv_mortalcopy(sv)>; this
+     * was to make C<local $tied{foo} = $tied{foo}> possible.
+     * However, it seems no longer to be needed for that purpose, and
+     * introduced a new bug: stuff like C<while ($hash{taintedval} =~ /.../g>
+     * would loop endlessly since the pos magic is getting set on the
+     * mortal copy and lost. However, the copy has the effect of
+     * triggering the get magic, and losing it altogether made things like
+     * c<$tied{foo};> in void context no longer do get magic, which some
+     * code relied on. Also, delayed triggering of magic on @+ and friends
+     * meant the original regex may be out of scope by now. So as a
+     * compromise, do the get magic here. (The MGf_GSKIP flag will stop it
+     * being called too many times). */
+    if (!lval && SvRMAGICAL(hv) && SvGMAGICAL(sv))
+       mg_get(sv);
     PUSHs(sv);
     RETURN;
 }
     PUSHs(sv);
     RETURN;
 }
@@ -1865,13 +1884,7 @@ PP(pp_leave)
 
     POPBLOCK(cx,newpm);
 
 
     POPBLOCK(cx,newpm);
 
-    gimme = OP_GIMME(PL_op, -1);
-    if (gimme == -1) {
-       if (cxstack_ix >= 0)
-           gimme = cxstack[cxstack_ix].blk_gimme;
-       else
-           gimme = G_SCALAR;
-    }
+    gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
 
     TAINT_NOT;
     if (gimme == G_VOID)
 
     TAINT_NOT;
     if (gimme == G_VOID)
@@ -1902,7 +1915,7 @@ PP(pp_leave)
     }
     PL_curpm = newpm;  /* Don't pop $1 et al till now */
 
     }
     PL_curpm = newpm;  /* Don't pop $1 et al till now */
 
-    LEAVE;
+    LEAVE_with_name("block");
 
     RETURN;
 }
 
     RETURN;
 }
@@ -2074,9 +2087,11 @@ PP(pp_subst)
     bool is_cow;
 #endif
     SV *nsv = NULL;
     bool is_cow;
 #endif
     SV *nsv = NULL;
-
     /* known replacement string? */
     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
     /* known replacement string? */
     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
+
+    PERL_ASYNC_CHECK();
+
     if (PL_op->op_flags & OPf_STACKED)
        TARG = POPs;
     else if (PL_op->op_private & OPpTARGET_MY)
     if (PL_op->op_flags & OPf_STACKED)
        TARG = POPs;
     else if (PL_op->op_private & OPpTARGET_MY)
@@ -2086,6 +2101,11 @@ PP(pp_subst)
        EXTEND(SP,1);
     }
 
        EXTEND(SP,1);
     }
 
+    /* In non-destructive replacement mode, duplicate target scalar so it
+     * remains unchanged. */
+    if (rpm->op_pmflags & PMf_NONDESTRUCT)
+       TARG = newSVsv(TARG);
+
 #ifdef PERL_OLD_COPY_ON_WRITE
     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
        because they make integers such as 256 "false".  */
 #ifdef PERL_OLD_COPY_ON_WRITE
     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
        because they make integers such as 256 "false".  */
@@ -2102,9 +2122,10 @@ PP(pp_subst)
         || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
               || SvTYPE(TARG) > SVt_PVLV)
             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
         || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
               || SvTYPE(TARG) > SVt_PVLV)
             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
-       DIE(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
     PUTBACK;
 
     PUTBACK;
 
+  setup_match:
     s = SvPV_mutable(TARG, len);
     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
        force_on_match = 1;
     s = SvPV_mutable(TARG, len);
     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
        force_on_match = 1;
@@ -2160,6 +2181,22 @@ PP(pp_subst)
                         r_flags | REXEC_CHECKED);
     /* known replacement string? */
     if (dstr) {
                         r_flags | REXEC_CHECKED);
     /* known replacement string? */
     if (dstr) {
+
+       /* Upgrade the source if the replacement is utf8 but the source is not,
+        * but only if it matched; see
+        * http://www.nntp.perl.org/group/perl.perl5.porters/2010/04/msg158809.html
+        */
+       if (matched && DO_UTF8(dstr) && ! DO_UTF8(TARG)) {
+           const STRLEN new_len = sv_utf8_upgrade(TARG);
+
+           /* If the lengths are the same, the pattern contains only
+            * invariants, can keep going; otherwise, various internal markers
+            * could be off, so redo */
+           if (new_len != len) {
+               goto setup_match;
+           }
+       }
+
        /* replacement needing upgrading? */
        if (DO_UTF8(TARG) && !doutf8) {
             nsv = sv_newmortal();
        /* replacement needing upgrading? */
        if (DO_UTF8(TARG) && !doutf8) {
             nsv = sv_newmortal();
@@ -2192,7 +2229,10 @@ PP(pp_subst)
        if (!matched)
        {
            SPAGAIN;
        if (!matched)
        {
            SPAGAIN;
-           PUSHs(&PL_sv_no);
+           if (rpm->op_pmflags & PMf_NONDESTRUCT)
+               PUSHs(TARG);
+           else
+               PUSHs(&PL_sv_no);
            LEAVE_SCOPE(oldsave);
            RETURN;
        }
            LEAVE_SCOPE(oldsave);
            RETURN;
        }
@@ -2246,7 +2286,10 @@ PP(pp_subst)
            }
            TAINT_IF(rxtainted & 1);
            SPAGAIN;
            }
            TAINT_IF(rxtainted & 1);
            SPAGAIN;
-           PUSHs(&PL_sv_yes);
+           if (rpm->op_pmflags & PMf_NONDESTRUCT)
+               PUSHs(TARG);
+           else
+               PUSHs(&PL_sv_yes);
        }
        else {
            do {
        }
        else {
            do {
@@ -2275,7 +2318,10 @@ PP(pp_subst)
            }
            TAINT_IF(rxtainted & 1);
            SPAGAIN;
            }
            TAINT_IF(rxtainted & 1);
            SPAGAIN;
-           mPUSHi((I32)iters);
+           if (rpm->op_pmflags & PMf_NONDESTRUCT)
+               PUSHs(TARG);
+           else
+               mPUSHi((I32)iters);
        }
        (void)SvPOK_only_UTF8(TARG);
        TAINT_IF(rxtainted);
        }
        (void)SvPOK_only_UTF8(TARG);
        TAINT_IF(rxtainted);
@@ -2361,7 +2407,10 @@ PP(pp_subst)
 
        TAINT_IF(rxtainted & 1);
        SPAGAIN;
 
        TAINT_IF(rxtainted & 1);
        SPAGAIN;
-       mPUSHi((I32)iters);
+       if (rpm->op_pmflags & PMf_NONDESTRUCT)
+           PUSHs(TARG);
+       else
+           mPUSHi((I32)iters);
 
        (void)SvPOK_only(TARG);
        if (doutf8)
 
        (void)SvPOK_only(TARG);
        if (doutf8)
@@ -2377,7 +2426,10 @@ PP(pp_subst)
 nope:
 ret_no:
     SPAGAIN;
 nope:
 ret_no:
     SPAGAIN;
-    PUSHs(&PL_sv_no);
+    if (rpm->op_pmflags & PMf_NONDESTRUCT)
+       PUSHs(TARG);
+    else
+       PUSHs(&PL_sv_no);
     LEAVE_SCOPE(oldsave);
     RETURN;
 }
     LEAVE_SCOPE(oldsave);
     RETURN;
 }
@@ -2389,14 +2441,14 @@ PP(pp_grepwhile)
     if (SvTRUEx(POPs))
        PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
     ++*PL_markstack_ptr;
     if (SvTRUEx(POPs))
        PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
     ++*PL_markstack_ptr;
-    LEAVE;                                     /* exit inner scope */
+    LEAVE_with_name("grep_item");                                      /* exit inner scope */
 
     /* All done yet? */
     if (PL_stack_base + *PL_markstack_ptr > SP) {
        I32 items;
        const I32 gimme = GIMME_V;
 
 
     /* All done yet? */
     if (PL_stack_base + *PL_markstack_ptr > SP) {
        I32 items;
        const I32 gimme = GIMME_V;
 
-       LEAVE;                                  /* exit outer scope */
+       LEAVE_with_name("grep");                                        /* exit outer scope */
        (void)POPMARK;                          /* pop src */
        items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
        (void)POPMARK;                          /* pop dst */
        (void)POPMARK;                          /* pop src */
        items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
        (void)POPMARK;                          /* pop dst */
@@ -2419,7 +2471,7 @@ PP(pp_grepwhile)
     else {
        SV *src;
 
     else {
        SV *src;
 
-       ENTER;                                  /* enter inner scope */
+       ENTER_with_name("grep_item");                                   /* enter inner scope */
        SAVEVPTR(PL_curpm);
 
        src = PL_stack_base[*PL_markstack_ptr];
        SAVEVPTR(PL_curpm);
 
        src = PL_stack_base[*PL_markstack_ptr];
@@ -2685,41 +2737,27 @@ PP(pp_entersub)
        }
        break;
     default:
        }
        break;
     default:
-       if (!SvROK(sv)) {
+       if (sv == &PL_sv_yes) {         /* unfound import, ignore */
+           if (hasargs)
+               SP = PL_stack_base + POPMARK;
+           RETURN;
+       }
+       SvGETMAGIC(sv);
+       if (SvROK(sv)) {
+           SV * const * sp = &sv;      /* Used in tryAMAGICunDEREF macro. */
+           tryAMAGICunDEREF(to_cv);
+       }
+       else {
            const char *sym;
            STRLEN len;
            const char *sym;
            STRLEN len;
-           if (sv == &PL_sv_yes) {             /* unfound import, ignore */
-               if (hasargs)
-                   SP = PL_stack_base + POPMARK;
-               RETURN;
-           }
-           if (SvGMAGICAL(sv)) {
-               mg_get(sv);
-               if (SvROK(sv))
-                   goto got_rv;
-               if (SvPOKp(sv)) {
-                   sym = SvPVX_const(sv);
-                   len = SvCUR(sv);
-               } else {
-                   sym = NULL;
-                   len = 0;
-               }
-           }
-           else {
-               sym = SvPV_const(sv, len);
-            }
+           sym = SvPV_nomg_const(sv, len);
            if (!sym)
                DIE(aTHX_ PL_no_usym, "a subroutine");
            if (PL_op->op_private & HINT_STRICT_REFS)
            if (!sym)
                DIE(aTHX_ PL_no_usym, "a subroutine");
            if (PL_op->op_private & HINT_STRICT_REFS)
-               DIE(aTHX_ PL_no_symref, sym, "a subroutine");
+               DIE(aTHX_ "Can't use string (\"%.32s\"%s) as a subroutine ref while \"strict refs\" in use", sym, len>32 ? "..." : "");
            cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
            break;
        }
            cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
            break;
        }
-  got_rv:
-       {
-           SV * const * sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
-           tryAMAGICunDEREF(to_cv);
-       }       
        cv = MUTABLE_CV(SvRV(sv));
        if (SvTYPE(cv) == SVt_PVCV)
            break;
        cv = MUTABLE_CV(SvRV(sv));
        if (SvTYPE(cv) == SVt_PVCV)
            break;
@@ -2774,7 +2812,14 @@ try_autoload:
         Perl_get_db_sub(aTHX_ &sv, cv);
         if (CvISXSUB(cv))
             PL_curcopdb = PL_curcop;
         Perl_get_db_sub(aTHX_ &sv, cv);
         if (CvISXSUB(cv))
             PL_curcopdb = PL_curcop;
-        cv = GvCV(PL_DBsub);
+         if (CvLVALUE(cv)) {
+             /* check for lsub that handles lvalue subroutines */
+            cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
+             /* if lsub not found then fall back to DB::sub */
+            if (!cv) cv = GvCV(PL_DBsub);
+         } else {
+             cv = GvCV(PL_DBsub);
+         }
 
        if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
            DIE(aTHX_ "No DB::sub routine defined");
 
        if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
            DIE(aTHX_ "No DB::sub routine defined");
@@ -2873,8 +2918,10 @@ try_autoload:
            PL_curcopdb = NULL;
        }
        /* Do we need to open block here? XXXX */
            PL_curcopdb = NULL;
        }
        /* Do we need to open block here? XXXX */
-       if (CvXSUB(cv)) /* XXX this is supposed to be true */
-           (void)(*CvXSUB(cv))(aTHX_ cv);
+
+       /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
+       assert(CvXSUB(cv));
+       CALL_FPTR(CvXSUB(cv))(aTHX_ cv);
 
        /* Enforce some sanity in scalar context. */
        if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
 
        /* Enforce some sanity in scalar context. */
        if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
@@ -2913,6 +2960,8 @@ PP(pp_aelem)
     AV *const av = MUTABLE_AV(POPs);
     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
     AV *const av = MUTABLE_AV(POPs);
     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
+    const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
+    bool preeminent = TRUE;
     SV *sv;
 
     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
     SV *sv;
 
     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
@@ -2923,6 +2972,19 @@ PP(pp_aelem)
        elem -= CopARYBASE_get(PL_curcop);
     if (SvTYPE(av) != SVt_PVAV)
        RETPUSHUNDEF;
        elem -= CopARYBASE_get(PL_curcop);
     if (SvTYPE(av) != SVt_PVAV)
        RETPUSHUNDEF;
+
+    if (localizing) {
+       MAGIC *mg;
+       HV *stash;
+
+       /* If we can determine whether the element exist,
+        * Try to preserve the existenceness of a tied array
+        * element by using EXISTS and DELETE if possible.
+        * Fallback to FETCH and STORE otherwise. */
+       if (SvCANEXISTDELETE(av))
+           preeminent = av_exists(av, elem);
+    }
+
     svp = av_fetch(av, elem, lval && !defer);
     if (lval) {
 #ifdef PERL_MALLOC_WRAP
     svp = av_fetch(av, elem, lval && !defer);
     if (lval) {
 #ifdef PERL_MALLOC_WRAP
@@ -2952,14 +3014,18 @@ PP(pp_aelem)
            PUSHs(lv);
            RETURN;
        }
            PUSHs(lv);
            RETURN;
        }
-       if (PL_op->op_private & OPpLVAL_INTRO)
-           save_aelem(av, elem, svp);
+       if (localizing) {
+           if (preeminent)
+               save_aelem(av, elem, svp);
+           else
+               SAVEADELETE(av, elem);
+       }
        else if (PL_op->op_private & OPpDEREF)
            vivify_ref(*svp, PL_op->op_private & OPpDEREF);
     }
     sv = (svp ? *svp : &PL_sv_undef);
        else if (PL_op->op_private & OPpDEREF)
            vivify_ref(*svp, PL_op->op_private & OPpDEREF);
     }
     sv = (svp ? *svp : &PL_sv_undef);
-    if (!lval && SvGMAGICAL(sv))       /* see note in pp_helem() */
-       sv = sv_mortalcopy(sv);
+    if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
+       mg_get(sv);
     PUSHs(sv);
     RETURN;
 }
     PUSHs(sv);
     RETURN;
 }
@@ -2972,7 +3038,7 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
     SvGETMAGIC(sv);
     if (!SvOK(sv)) {
        if (SvREADONLY(sv))
     SvGETMAGIC(sv);
     if (!SvOK(sv)) {
        if (SvREADONLY(sv))
-           Perl_croak(aTHX_ "%s", PL_no_modify);
+           Perl_croak_no_modify(aTHX);
        prepare_SV_for_RV(sv);
        switch (to_what) {
        case OPpDEREF_SV:
        prepare_SV_for_RV(sv);
        switch (to_what) {
        case OPpDEREF_SV:
@@ -3024,17 +3090,16 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
     SV* ob;
     GV* gv;
     HV* stash;
     SV* ob;
     GV* gv;
     HV* stash;
-    STRLEN namelen;
     const char* packname = NULL;
     SV *packsv = NULL;
     STRLEN packlen;
     const char* packname = NULL;
     SV *packsv = NULL;
     STRLEN packlen;
-    const char * const name = SvPV_const(meth, namelen);
     SV * const sv = *(PL_stack_base + TOPMARK + 1);
 
     PERL_ARGS_ASSERT_METHOD_COMMON;
 
     if (!sv)
     SV * const sv = *(PL_stack_base + TOPMARK + 1);
 
     PERL_ARGS_ASSERT_METHOD_COMMON;
 
     if (!sv)
-       Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
+       Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
+                  SVfARG(meth));
 
     SvGETMAGIC(sv);
     if (SvROK(sv))
 
     SvGETMAGIC(sv);
     if (SvROK(sv))
@@ -3063,7 +3128,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
                    : !isIDFIRST(*packname)
                ))
            {
                    : !isIDFIRST(*packname)
                ))
            {
-               Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
+               Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s",
+                          SVfARG(meth),
                           SvOK(sv) ? "without a package or object reference"
                                    : "on an undefined value");
            }
                           SvOK(sv) ? "without a package or object reference"
                                    : "on an undefined value");
            }
@@ -3088,6 +3154,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
                     && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
                     && SvOBJECT(ob))))
     {
                     && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
                     && SvOBJECT(ob))))
     {
+       const char * const name = SvPV_nolen_const(meth);
        Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
                   (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
                   name);
        Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
                   (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
                   name);
@@ -3111,7 +3178,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
        }
     }
 
        }
     }
 
-    gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv), name,
+    gv = gv_fetchmethod_flags(stash ? stash : MUTABLE_HV(packsv),
+                             SvPV_nolen_const(meth),
                              GV_AUTOLOAD | GV_CROAK);
 
     assert(gv);
                              GV_AUTOLOAD | GV_CROAK);
 
     assert(gv);
Unnamed repository; edit this file 'description' to name the repository.