By swapping the order of pushes onto the save stack for

[p5sagit/p5-mst-13.2.git] / pp_ctl.c

diff --git a/pp_ctl.c b/pp_ctl.c
index 87a383d..cb35b59 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -380,7 +380,7 @@ Perl_rxres_free(pTHX_ void **rsp)
        void *tmp = INT2PTR(char*,*p);
        Safefree(tmp);
        if (*p)
-           Poison(*p, 1, sizeof(*p));
+           PoisonFree(*p, 1, sizeof(*p));
 #else
        Safefree(INT2PTR(char*,*p));
 #endif
@@ -1620,7 +1620,7 @@ PP(pp_caller)
        RETURN;
     }
 
-    EXTEND(SP, 10);
+    EXTEND(SP, 11);
 
     if (!stashname)
        PUSHs(&PL_sv_undef);
@@ -1695,8 +1695,7 @@ PP(pp_caller)
     /* XXX only hints propagated via op_private are currently
      * visible (others are not easily accessible, since they
      * use the global PL_hints) */
-    PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
-                            HINT_PRIVATE_MASK)));
+    PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
     {
        SV * mask ;
        SV * const old_warnings = cx->blk_oldcop->cop_warnings ;
@@ -1721,6 +1720,12 @@ PP(pp_caller)
             mask = newSVsv(old_warnings);
         PUSHs(sv_2mortal(mask));
     }
+
+    PUSHs(cx->blk_oldcop->cop_hints ?
+         sv_2mortal(newRV_noinc(
+               (SV*)Perl_refcounted_he_chain_2hv(aTHX_
+                                                 cx->blk_oldcop->cop_hints)))
+         : &PL_sv_undef);
     RETURN;
 }
 
@@ -2502,7 +2507,7 @@ PP(pp_goto)
 
        /* find label */
 
-       PL_lastgotoprobe = 0;
+       PL_lastgotoprobe = NULL;
        *enterops = 0;
        for (ix = cxstack_ix; ix >= 0; ix--) {
            cx = &cxstack[ix];
@@ -2809,7 +2814,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
     *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
     LEAVE;
     if (IN_PERL_COMPILETIME)
-       PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+       CopHINTS_set(&PL_compiling, PL_hints);
 #ifdef OP_IN_REGISTER
     op = PL_opsave;
 #endif
@@ -2919,7 +2924,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
     PL_eval_root = NULL;
     PL_error_count = 0;
     PL_curcop = &PL_compiling;
-    PL_curcop->cop_arybase = 0;
+    CopARYBASE_set(PL_curcop, 0);
     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
        PL_in_eval |= EVAL_KEEPERR;
     else
@@ -3470,6 +3475,29 @@ PP(pp_entereval)
         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
         SAVEFREESV(PL_compiling.cop_io);
     }
+    if (PL_compiling.cop_hints) {
+       PL_compiling.cop_hints->refcounted_he_refcnt--;
+    }
+    PL_compiling.cop_hints = PL_curcop->cop_hints;
+    if (PL_compiling.cop_hints) {
+#ifdef USE_ITHREADS
+       /* PL_curcop could be pointing to an optree owned by another /.*parent/
+          thread. We can't manipulate the reference count of the refcounted he
+          there (race condition) so we have to do something less than
+          pleasant to keep it read only. The simplest solution seems to be to
+          copy their chain. We might want to cache this.
+          Alternatively we could add a flag to the refcounted he *we* point to
+          here saying "I don't own a reference count on the thing I point to",
+          and arrange for Perl_refcounted_he_free() to spot that. If so, we'd
+          still need to copy the topmost refcounted he so that we could change
+          its flag. So still not trivial. (Flag bits could be hung from the
+          shared HEK) */
+       PL_compiling.cop_hints
+           = Perl_refcounted_he_copy(aTHX_ PL_compiling.cop_hints);
+#else
+       PL_compiling.cop_hints->refcounted_he_refcnt++;
+#endif
+    }
     /* special case: an eval '' executed within the DB package gets lexically
      * placed in the first non-DB CV rather than the current CV - this
      * allows the debugger to execute code, find lexicals etc, in the
@@ -3562,22 +3590,57 @@ PP(pp_leaveeval)
     RETURNOP(retop);
 }
 
-PP(pp_entertry)
+/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
+   close to the related Perl_create_eval_scope.  */
+void
+Perl_delete_eval_scope(pTHX)
 {
-    dVAR; dSP;
+    SV **newsp;
+    PMOP *newpm;
+    I32 gimme;
     register PERL_CONTEXT *cx;
-    const I32 gimme = GIMME_V;
+    I32 optype;
+       
+    POPBLOCK(cx,newpm);
+    POPEVAL(cx);
+    PL_curpm = newpm;
+    LEAVE;
+    PERL_UNUSED_VAR(newsp);
+    PERL_UNUSED_VAR(gimme);
+    PERL_UNUSED_VAR(optype);
+}
 
+/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
+   also needed by Perl_fold_constants.  */
+PERL_CONTEXT *
+Perl_create_eval_scope(pTHX_ U32 flags)
+{
+    PERL_CONTEXT *cx;
+    const I32 gimme = GIMME_V;
+       
     ENTER;
     SAVETMPS;
 
-    PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
+    PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
     PUSHEVAL(cx, 0, 0);
-    cx->blk_eval.retop = cLOGOP->op_other->op_next;
+    PL_eval_root = PL_op;      /* Only needed so that goto works right. */
 
     PL_in_eval = EVAL_INEVAL;
-    sv_setpvn(ERRSV,"",0);
-    PUTBACK;
+    if (flags & G_KEEPERR)
+       PL_in_eval |= EVAL_KEEPERR;
+    else
+       sv_setpvn(ERRSV,"",0);
+    if (flags & G_FAKINGEVAL) {
+       PL_eval_root = PL_op; /* Only needed so that goto works right. */
+    }
+    return cx;
+}
+    
+PP(pp_entertry)
+{
+    dVAR;
+    PERL_CONTEXT *cx = create_eval_scope(0);
+    cx->blk_eval.retop = cLOGOP->op_other->op_next;
     return DOCATCH(PL_op->op_next);
 }
 
@@ -4027,7 +4090,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
                PUSHs(other);
                PUSHs(*svp);
                PUTBACK;
-               if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
+               if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
                    (void) pp_i_eq();
                else
                    (void) pp_eq();
@@ -4121,7 +4184,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
        /* Otherwise, numeric comparison */
        PUSHs(d); PUSHs(e);
        PUTBACK;
-       if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
+       if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
            (void) pp_i_eq();
        else
            (void) pp_eq();