Add Compress-Raw-Bzip2, by Paul Marquess

[perl5.git] / pp_hot.c

diff --git a/pp_hot.c b/pp_hot.c
index e22502f..c52a0d6 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -753,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;
                    }
@@ -1752,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;
     }
 
@@ -1777,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) {
@@ -1818,7 +1820,7 @@ PP(pp_helem)
            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));
            else {
@@ -1863,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)
@@ -2772,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");
@@ -2911,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))
@@ -2921,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
@@ -2950,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);
     }