Clean up and document API for hashes

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

diff --git a/pp_ctl.c b/pp_ctl.c
index 2955b16..6eab4da 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -23,6 +23,9 @@
 #define WORD_ALIGN sizeof(U16)
 #endif
 
+#define DOCATCH(o) (mustcatch ? docatch(o) : (o))
+
+static OP *docatch _((OP *o));
 static OP *doeval _((int gimme));
 static OP *dofindlabel _((OP *op, char *label, OP **opstack));
 static void doparseform _((SV *sv));
@@ -123,6 +126,8 @@ PP(pp_substcont)
            SV *targ = cx->sb_targ;
            sv_catpvn(dstr, s, cx->sb_strend - s);
 
+           TAINT_IF(cx->sb_rxtainted || rx->exec_tainted);
+
            (void)SvOOK_off(targ);
            Safefree(SvPVX(targ));
            SvPVX(targ) = SvPVX(dstr);
@@ -133,8 +138,7 @@ PP(pp_substcont)
 
            (void)SvPOK_only(targ);
            SvSETMAGIC(targ);
-           if (cx->sb_rxtainted)
-               SvTAINTED_on(targ);
+           SvTAINT(targ);
            PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
            LEAVE_SCOPE(cx->sb_oldsave);
            POPSUBST(cx);
@@ -624,6 +628,7 @@ PP(pp_sort)
            AV *oldstack;
            CONTEXT *cx;
            SV** newsp;
+           bool oldmustcatch = mustcatch;
 
            SAVETMPS;
            SAVESPTR(op);
@@ -634,6 +639,7 @@ PP(pp_sort)
                AvREAL_off(sortstack);
                av_extend(sortstack, 32);
            }
+           mustcatch = TRUE;
            SWITCHSTACK(curstack, sortstack);
            if (sortstash != stash) {
                firstgv = gv_fetchpv("a", TRUE, SVt_PV);
@@ -650,6 +656,7 @@ PP(pp_sort)
 
            POPBLOCK(cx,curpm);
            SWITCHSTACK(sortstack, oldstack);
+           mustcatch = oldmustcatch;
        }
        LEAVE;
     }
@@ -1287,9 +1294,9 @@ PP(pp_leaveloop)
     SV **mark;
 
     POPBLOCK(cx,newpm);
+    mark = newsp;
     POPLOOP1(cx);      /* Delay POPLOOP2 until stack values are safe */
 
-    mark = newsp;
     if (gimme == G_SCALAR) {
        if (op->op_private & OPpLEAVE_VOID)
            ;
@@ -1422,8 +1429,7 @@ PP(pp_last)
     case CXt_LOOP:
        POPLOOP1(cx);   /* Delay POPLOOP2 until stack values are safe */
        pop2 = CXt_LOOP;
-       nextop = cx->blk_loop.last_op->op_next;
-       LEAVE;
+       nextop = cxloop.last_op->op_next;
        break;
     case CXt_SUB:
        POPSUB1(cx);    /* Delay POPSUB2 until stack values are safe */
@@ -1458,6 +1464,7 @@ PP(pp_last)
     switch (pop2) {
     case CXt_LOOP:
        POPLOOP2();     /* release loop vars ... */
+       LEAVE;
        break;
     case CXt_SUB:
        POPSUB2();      /* release CV and @_ ... */
@@ -1853,8 +1860,13 @@ PP(pp_exit)
 
     if (MAXARG < 1)
        anum = 0;
-    else
+    else {
        anum = SvIVx(POPs);
+#ifdef VMSISH_EXIT
+       if (anum == 1 && VMSISH_EXIT)
+           anum = 0;
+#endif
+    }
     my_exit(anum);
     PUSHs(&sv_undef);
     RETURN;
@@ -1929,6 +1941,46 @@ SV *sv;
 }
 
 static OP *
+docatch(o)
+OP *o;
+{
+    int ret;
+    int oldrunlevel = runlevel;
+    Sigjmp_buf oldtop;
+
+    op = o;
+    runlevel--;                                /* pretense */
+    Copy(top_env, oldtop, 1, Sigjmp_buf);
+#ifdef DEBUGGING
+    assert(mustcatch == TRUE);
+#endif
+    mustcatch = FALSE;
+    switch ((ret = Sigsetjmp(top_env,1))) {
+    default:                           /* topmost level handles it */
+       Copy(oldtop, top_env, 1, Sigjmp_buf);
+       runlevel = oldrunlevel;
+       mustcatch = TRUE;
+       Siglongjmp(top_env, ret);
+       /* NOTREACHED */
+    case 3:
+       if (!restartop) {
+           PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+           break;
+       }
+       op = restartop;
+       restartop = 0;
+       /* FALL THROUGH */
+    case 0:
+        runops();
+       break;
+    }
+    Copy(oldtop, top_env, 1, Sigjmp_buf);
+    runlevel = oldrunlevel;
+    mustcatch = TRUE;
+    return Nullop;
+}
+
+static OP *
 doeval(gimme)
 int gimme;
 {
@@ -2035,10 +2087,8 @@ int gimme;
     DEBUG_x(dump_eval());
 
     /* Register with debugger: */
-
     if (perldb && saveop->op_type == OP_REQUIRE) {
        CV *cv = perl_get_cv("DB::postponed", FALSE);
-       
        if (cv) {
            dSP;
            PUSHMARK(sp);
@@ -2050,6 +2100,8 @@ int gimme;
 
     /* compiled okay, so do it */
 
+    CvDEPTH(compcv) = 1;
+
     SP = stack_base + POPMARK;         /* pop original mark */
     RETURNOP(eval_start);
 }
@@ -2171,7 +2223,7 @@ PP(pp_require)
     compiling.cop_line = 0;
 
     PUTBACK;
-    return doeval(G_SCALAR);
+    return DOCATCH(doeval(G_SCALAR));
 }
 
 PP(pp_dofile)
@@ -2200,7 +2252,7 @@ PP(pp_entereval)
     /* switch to eval mode */
 
     SAVESPTR(compiling.cop_filegv);
-    sprintf(tmpbuf, "_<(eval %d)", ++evalseq);
+    sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
     compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
     compiling.cop_line = 1;
     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
@@ -2226,7 +2278,7 @@ PP(pp_entereval)
     if (perldb && was != sub_generation) { /* Some subs defined here. */
        strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
     }
-    return ret;
+    return DOCATCH(ret);
 }
 
 PP(pp_leaveeval)
@@ -2271,6 +2323,11 @@ PP(pp_leaveeval)
     }
     curpm = newpm;     /* Don't pop $1 et al till now */
 
+#ifdef DEBUGGING
+    assert(CvDEPTH(compcv) == 1);
+#endif
+    CvDEPTH(compcv) = 0;
+
     if (optype == OP_REQUIRE &&
        !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
        char *name = cx->blk_eval.old_name;
@@ -2282,6 +2339,7 @@ PP(pp_leaveeval)
 
     lex_end();
     LEAVE;
+
     if (!(save_flags & OPf_SPECIAL))
        sv_setpv(GvSV(errgv),"");
 
@@ -2304,7 +2362,8 @@ PP(pp_entertry)
 
     in_eval = 1;
     sv_setpv(GvSV(errgv),"");
-    RETURN;
+    PUTBACK;
+    return DOCATCH(op->op_next);
 }
 
 PP(pp_leavetry)