This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add Compress-Raw-Bzip2, by Paul Marquess
[perl5.git] / pp_hot.c
index c86762e..c52a0d6 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
  * shaking the air.
  *
- *            Awake!  Awake!  Fear, Fire, Foes!  Awake!
- *                     Fire, Foes!  Awake!
+ *                  Awake!  Awake!  Fear, Fire, Foes!  Awake!
+ *                               Fire, Foes!  Awake!
+ *
+ *     [p.1007 of _The Lord of the Rings_, VI/viii: "The Scouring of the Shire"]
  */
 
 /* This file contains 'hot' pp ("push/pop") functions that
@@ -180,7 +182,7 @@ PP(pp_sassign)
                   So change the reference so that it points to the subroutine
                   of that typeglob, as that's what they were after all along.
                */
-               GV *const upgraded = (GV *) cv;
+               GV *const upgraded = MUTABLE_GV(cv);
                CV *const source = GvCV(upgraded);
 
                assert(source);
@@ -306,16 +308,16 @@ PP(pp_readline)
 {
     dVAR;
     tryAMAGICunTARGET(iter, 0);
-    PL_last_in_gv = (GV*)(*PL_stack_sp--);
+    PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
     if (!isGV_with_GP(PL_last_in_gv)) {
        if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv)))
-           PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
+           PL_last_in_gv = MUTABLE_GV(SvRV(PL_last_in_gv));
        else {
            dSP;
            XPUSHs(MUTABLE_SV(PL_last_in_gv));
            PUTBACK;
            pp_rv2gv();
-           PL_last_in_gv = (GV*)(*PL_stack_sp--);
+           PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
        }
     }
     return do_readline();
@@ -398,7 +400,7 @@ PP(pp_preinc)
 {
     dVAR; dSP;
     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
-       DIE(aTHX_ PL_no_modify);
+       DIE(aTHX_ "%s", PL_no_modify);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
         && SvIVX(TOPs) != IV_MAX)
     {
@@ -698,7 +700,8 @@ PP(pp_print)
     IO *io;
     register PerlIO *fp;
     MAGIC *mg;
-    GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
+    GV * const gv
+       = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
 
     if (gv && (io = GvIO(gv))
        && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
@@ -750,14 +753,16 @@ PP(pp_print)
        goto just_say_no;
     }
     else {
+       SV * const ofs = GvSV(PL_ofsgv); /* $, */
        MARK++;
-       if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
+       if (ofs && (SvGMAGICAL(ofs) || SvOK(ofs))) {
            while (MARK <= SP) {
                if (!do_print(*MARK, fp))
                    break;
                MARK++;
                if (MARK <= SP) {
-                   if (!do_print(PL_ofs_sv, fp)) { /* $, */
+                   /* don't use 'ofs' here - it may be invalidated by magic callbacks */
+                   if (!do_print(GvSV(PL_ofsgv), fp)) {
                        MARK--;
                        break;
                    }
@@ -825,7 +830,7 @@ PP(pp_rv2av)
        }
        else if (PL_op->op_flags & OPf_MOD
                && PL_op->op_private & OPpLVAL_INTRO)
-           Perl_croak(aTHX_ PL_no_localize_ref);
+           Perl_croak(aTHX_ "%s", PL_no_localize_ref);
     }
     else {
        if (SvTYPE(sv) == type) {
@@ -855,7 +860,7 @@ PP(pp_rv2av)
                    RETURN;
            }
            else {
-               gv = (GV*)sv;
+               gv = MUTABLE_GV(sv);
            }
            sv = is_pp_rv2av ? MUTABLE_SV(GvAVn(gv)) : MUTABLE_SV(GvHVn(gv));
            if (PL_op->op_private & OPpLVAL_INTRO)
@@ -945,7 +950,7 @@ S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
            }
            else
                err = "Odd number of elements in hash assignment";
-           Perl_warner(aTHX_ packWARN(WARN_MISC), err);
+           Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", err);
        }
 
         tmpstr = newSV(0);
@@ -1749,9 +1754,13 @@ PP(pp_enter)
     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;
     }
 
@@ -1774,28 +1783,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;
-    I32 preeminent = 0;
+    const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
+    bool preeminent = TRUE;
 
     if (SvTYPE(hv) != SVt_PVHV)
        RETPUSHUNDEF;
 
-    if (PL_op->op_private & OPpLVAL_INTRO) {
+    if (localizing) {
        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) {
@@ -1815,9 +1820,9 @@ PP(pp_helem)
            PUSHs(lv);
            RETURN;
        }
-       if (PL_op->op_private & OPpLVAL_INTRO) {
+       if (localizing) {
            if (HvNAME_get(hv) && isGV(*svp))
-               save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
+               save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
            else {
                if (!preeminent) {
                    STRLEN keylen;
@@ -1825,7 +1830,8 @@ PP(pp_helem)
                    SAVEDELETE(hv, savepvn(key,keylen),
                               SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
                } else
-                   save_helem(hv, keysv, svp);
+                   save_helem_flags(hv, keysv, svp,
+                                    (PL_op->op_flags & OPf_SPECIAL) ? 0 : SAVEf_SETMAGIC);
             }
        }
        else if (PL_op->op_private & OPpDEREF)
@@ -1859,13 +1865,7 @@ PP(pp_leave)
 
     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)
@@ -2096,7 +2096,7 @@ PP(pp_subst)
         || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
               || SvTYPE(TARG) > SVt_PVLV)
             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
-       DIE(aTHX_ PL_no_modify);
+       DIE(aTHX_ "%s", PL_no_modify);
     PUTBACK;
 
     s = SvPV_mutable(TARG, len);
@@ -2421,7 +2421,7 @@ PP(pp_grepwhile)
        if (PL_op->op_private & OPpGREP_LEX)
            PAD_SVl(PL_op->op_targ) = src;
        else
-           DEFSV = src;
+           DEFSV_set(src);
 
        RETURNOP(cLOGOP->op_other);
     }
@@ -2668,7 +2668,7 @@ PP(pp_entersub)
     case SVt_PVGV:
        if (!isGV_with_GP(sv))
            DIE(aTHX_ "Not a CODE reference");
-       if (!(cv = GvCVu((GV*)sv))) {
+       if (!(cv = GvCVu((const GV *)sv))) {
            HV *stash;
            cv = sv_2cv(sv, &stash, &gv, 0);
        }
@@ -2768,7 +2768,14 @@ try_autoload:
         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_fetchpv("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");
@@ -2907,6 +2914,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));
+    const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
+    bool preeminent = TRUE;
     SV *sv;
 
     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
@@ -2917,6 +2926,19 @@ PP(pp_aelem)
        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
@@ -2946,8 +2968,12 @@ PP(pp_aelem)
            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);
     }
@@ -2966,7 +2992,7 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
     SvGETMAGIC(sv);
     if (!SvOK(sv)) {
        if (SvREADONLY(sv))
-           Perl_croak(aTHX_ PL_no_modify);
+           Perl_croak(aTHX_ "%s", PL_no_modify);
        prepare_SV_for_RV(sv);
        switch (to_what) {
        case OPpDEREF_SV:
@@ -3079,7 +3105,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
     if (!ob || !(SvOBJECT(ob)
                 || (SvTYPE(ob) == SVt_PVGV 
                     && isGV_with_GP(ob)
-                    && (ob = MUTABLE_SV(GvIO((GV*)ob)))
+                    && (ob = MUTABLE_SV(GvIO((const GV *)ob)))
                     && SvOBJECT(ob))))
     {
        Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
@@ -3097,7 +3123,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
     if (hashp) {
        const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
        if (he) {
-           gv = (GV*)HeVAL(he);
+           gv = MUTABLE_GV(HeVAL(he));
            if (isGV(gv) && GvCV(gv) &&
                (!GvCVGEN(gv) || GvCVGEN(gv)
                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))