perl 5.003_01: pp_ctl.c

Rename global variable to eliminate collision with system header files
Allow redurection of debug messages
Make sure the right stack is in use in die()
Correct juggling of stack and @_ in pp_goto()
Get more information about XSUBs to debugger
Preserve SP around eval
Propagate G_KEEPERR down into eval
Don't worry about %INC if we're not in a "require"

diff --git a/pp_ctl.c b/pp_ctl.c
index e57e88a..0e86fd1 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -621,13 +621,13 @@ PP(pp_sort)
            SAVETMPS;
            SAVESPTR(op);
 
-           oldstack = stack;
+           oldstack = curstack;
            if (!sortstack) {
                sortstack = newAV();
                AvREAL_off(sortstack);
                av_extend(sortstack, 32);
            }
-           SWITCHSTACK(stack, sortstack);
+           SWITCHSTACK(curstack, sortstack);
            if (sortstash != stash) {
                firstgv = gv_fetchpv("a", TRUE, SVt_PV);
                secondgv = gv_fetchpv("b", TRUE, SVt_PV);
@@ -881,7 +881,7 @@ I32 cxix;
 
     while (cxstack_ix > cxix) {
        cx = &cxstack[cxstack_ix--];
-       DEBUG_l(fprintf(stderr, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
+       DEBUG_l(fprintf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
                    block_type[cx->cx_type]));
        /* Note: we don't need to restore the base context info till the end. */
        switch (cx->cx_type) {
@@ -919,6 +919,13 @@ die(pat, va_alist)
     GV *gv;
     CV *cv;
 
+    /* We have to switch back to mainstack or die_where may try to pop
+     * the eval block from the wrong stack if die is being called from a
+     * signal handler.  - dkindred@cs.cmu.edu */
+    if (curstack != mainstack) {
+        dSP;
+        SWITCHSTACK(curstack, mainstack);
+    }
 #ifdef I_STDARG
     va_start(args, pat);
 #else
@@ -1308,8 +1315,8 @@ PP(pp_enteriter)
        cx->blk_loop.iterix = -1;
     }
     else {
-       cx->blk_loop.iterary = stack;
-       AvFILL(stack) = sp - stack_base;
+       cx->blk_loop.iterary = curstack;
+       AvFILL(curstack) = sp - stack_base;
        cx->blk_loop.iterix = MARK - stack_base;
     }
 
@@ -1376,11 +1383,11 @@ PP(pp_return)
     PMOP *newpm;
     I32 optype = 0;
 
-    if (stack == sortstack) {
+    if (curstack == sortstack) {
        if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) < sortcxix) {
            if (cxstack_ix > sortcxix)
                dounwind(sortcxix);
-           AvARRAY(stack)[1] = *SP;
+           AvARRAY(curstack)[1] = *SP;
            stack_sp = stack_base + 1;
            return 0;
        }
@@ -1634,7 +1641,9 @@ PP(pp_goto)
                AV* av = cx->blk_sub.argarray;
                
                items = AvFILL(av) + 1;
-               Copy(AvARRAY(av), ++stack_sp, items, SV*);
+               stack_sp++;
+               EXTEND(stack_sp, items); /* @_ could have been extended. */
+               Copy(AvARRAY(av), stack_sp, items, SV*);
                stack_sp += items;
                GvAV(defgv) = cx->blk_sub.savearray;
                AvREAL_off(av);
@@ -1661,6 +1670,7 @@ PP(pp_goto)
                    sp = stack_base + items;
                }
                else {
+                   stack_sp--;         /* There is no cv arg. */
                    (void)(*CvXSUB(cv))(cv);
                }
                LEAVE;
@@ -1750,6 +1760,13 @@ PP(pp_goto)
                        mark++;
                    }
                }
+               if (perldb && curstash != debstash) { /* &xsub is not copying @_ */
+                   SV *sv = GvSV(DBsub);
+                   save_item(sv);
+                   gv_efullname(sv, CvGV(cv)); /* We do not care about
+                                                * using sv to call CV,
+                                                * just for info. */
+               }
                RETURNOP(CvSTART(cv));
            }
        }
@@ -1843,7 +1860,7 @@ PP(pp_goto)
        do_undump = FALSE;
     }
 
-    if (stack == signalstack) {
+    if (curstack == signalstack) {
         restartop = retop;
         Siglongjmp(top_env, 3);
     }
@@ -1944,6 +1961,8 @@ int gimme;
 
     in_eval = 1;
 
+    PUSHMARK(SP);
+
     /* set up a scratch pad */
 
     SAVEINT(padix);
@@ -1992,7 +2011,10 @@ int gimme;
     curcop->cop_arybase = 0;
     SvREFCNT_dec(rs);
     rs = newSVpv("\n", 1);
-    sv_setpv(GvSV(errgv),"");
+    if (saveop->op_flags & OPf_SPECIAL)
+       in_eval |= 4;
+    else
+       sv_setpv(GvSV(errgv),"");
     if (yyparse() || error_count || !eval_root) {
        SV **newsp;
        I32 gimme;
@@ -2004,6 +2026,7 @@ int gimme;
            op_free(eval_root);
            eval_root = Nullop;
        }
+       SP = stack_base + POPMARK;              /* pop original mark */
        POPBLOCK(cx,curpm);
        POPEVAL(cx);
        pop_return();
@@ -2028,6 +2051,7 @@ int gimme;
 
     /* compiled okay, so do it */
 
+    SP = stack_base + POPMARK;         /* pop original mark */
     RETURNOP(eval_start);
 }
 
@@ -2201,6 +2225,7 @@ PP(pp_leaveeval)
     I32 gimme;
     register CONTEXT *cx;
     OP *retop;
+    OP *saveop = op;
     I32 optype;
 
     POPBLOCK(cx,newpm);
@@ -2233,21 +2258,19 @@ PP(pp_leaveeval)
     }
     curpm = newpm;     /* Don't pop $1 et al till now */
 
-    if (optype != OP_ENTEREVAL) {
+    if (optype == OP_REQUIRE &&
+       !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
        char *name = cx->blk_eval.old_name;
 
-       if (!(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
-           /* Unassume the success we assumed earlier. */
-           (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
-
-           if (optype == OP_REQUIRE)
-               retop = die("%s did not return a true value", name);
-       }
+       /* Unassume the success we assumed earlier. */
+       (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
+       retop = die("%s did not return a true value", name);
     }
 
     lex_end();
     LEAVE;
-    sv_setpv(GvSV(errgv),"");
+    if (!(saveop->op_flags & OPf_SPECIAL))
+       sv_setpv(GvSV(errgv),"");
 
     RETURNOP(retop);
 }