perl 5.003_01: lib/ExtUtils/xsubpp

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

diff --git a/pp_ctl.c b/pp_ctl.c
index 68628f1..e57e88a 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -102,7 +102,7 @@ PP(pp_substcont)
     register char *s = cx->sb_s;
     register char *m = cx->sb_m;
     char *orig = cx->sb_orig;
-    register REGEXP *rx = pm->op_pmregexp;
+    register REGEXP *rx = cx->sb_rx;
 
     if (cx->sb_iters++) {
        if (cx->sb_iters > cx->sb_maxiters)
@@ -937,7 +937,7 @@ die(pat, va_alist)
     }
     restartop = die_where(message);
     if ((!restartop && was_in_eval) || oldrunlevel > 1)
-       longjmp(top_env, 3);
+       Siglongjmp(top_env, 3);
     return restartop;
 }
 
@@ -969,7 +969,7 @@ char *message;
            }
        }
        else
-           sv_catpv(GvSV(errgv), message);
+           sv_setpv(GvSV(errgv), message);
        
        cxix = dopoptoeval(cxstack_ix);
        if (cxix >= 0) {
@@ -997,9 +997,16 @@ char *message;
        }
     }
     fputs(message, stderr);
-    (void)fflush(stderr);
-    if (e_fp)
+    (void)Fflush(stderr);
+    if (e_tmpname) {
+       if (e_fp) {
+           fclose(e_fp);
+           e_fp = Nullfp;
+       }
        (void)UNLINK(e_tmpname);
+       Safefree(e_tmpname);
+       e_tmpname = Nullch;
+    }
     statusvalue = SHIFTSTATUS(statusvalue);
 #ifdef VMS
     my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
@@ -1077,6 +1084,14 @@ PP(pp_caller)
        cxix = dopoptosub(cxix - 1);
     }
     cx = &cxstack[cxix];
+    if (cxstack[cxix].cx_type == CXt_SUB) {
+        dbcxix = dopoptosub(cxix - 1);
+       /* We expect that cxstack[dbcxix] is CXt_SUB, anyway, the
+          field below is defined for any cx. */
+       if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub))
+           cx = &cxstack[dbcxix];
+    }
+
     if (GIMME != G_ARRAY) {
        dTARGET;
 
@@ -1084,16 +1099,13 @@ PP(pp_caller)
        PUSHs(TARG);
        RETURN;
     }
-    dbcxix = dopoptosub(cxix - 1);
-    if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub))
-       cx = &cxstack[dbcxix];
 
     PUSHs(sv_2mortal(newSVpv(HvNAME(cx->blk_oldcop->cop_stash), 0)));
     PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0)));
     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
     if (!MAXARG)
        RETURN;
-    if (cx->cx_type == CXt_SUB) {
+    if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
        sv = NEWSV(49, 0);
        gv_efullname(sv, CvGV(cxstack[cxix].blk_sub.cv));
        PUSHs(sv_2mortal(sv));
@@ -1105,8 +1117,15 @@ PP(pp_caller)
     }
     PUSHs(sv_2mortal(newSViv((I32)cx->blk_gimme)));
     if (cx->cx_type == CXt_EVAL) {
-       if (cx->blk_eval.old_op_type == OP_ENTEREVAL)
+       if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
            PUSHs(cx->blk_eval.cur_text);
+           PUSHs(&sv_no);
+       } 
+       else if (cx->blk_eval.old_name) { /* Try blocks have old_name == 0. */
+           /* Require, put the name. */
+           PUSHs(sv_2mortal(newSVpv(cx->blk_eval.old_name, 0)));
+           PUSHs(&sv_yes);
+       }
     }
     else if (cx->cx_type == CXt_SUB &&
            cx->blk_sub.hasargs &&
@@ -1119,7 +1138,7 @@ PP(pp_caller)
            GV* tmpgv;
            dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
                                SVt_PVAV)));
-           SvMULTI_on(tmpgv);
+           GvMULTI_on(tmpgv);
            AvREAL_off(dbargs);         /* XXX Should be REIFY */
        }
 
@@ -1145,7 +1164,7 @@ const void *b;
     GvSV(secondgv) = *str2;
     stack_sp = stack_base;
     op = sortcop;
-    run();
+    runops();
     if (stack_sp != stack_base + 1)
        croak("Sort subroutine didn't return single value");
     if (!SvNIOKp(*stack_sp))
@@ -1232,7 +1251,7 @@ PP(pp_dbstate)
        if (!cv)
            DIE("No DB::DB routine defined");
 
-       if (CvDEPTH(cv) >= 1)           /* don't do recursive DB::DB call */
+       if (CvDEPTH(cv) >= 1 && !(debug & (1<<30))) /* don't do recursive DB::DB call */
            return NORMAL;
 
        ENTER;
@@ -1812,6 +1831,9 @@ PP(pp_goto)
     }
 
     if (do_dump) {
+#ifdef VMS
+       if (!retop) retop = main_start;
+#endif
        restartop = retop;
        do_undump = TRUE;
 
@@ -1823,7 +1845,7 @@ PP(pp_goto)
 
     if (stack == signalstack) {
         restartop = retop;
-        longjmp(top_env, 3);
+        Siglongjmp(top_env, 3);
     }
 
     RETURNOP(retop);
@@ -1968,10 +1990,8 @@ int gimme;
     error_count = 0;
     curcop = &compiling;
     curcop->cop_arybase = 0;
-    rs = "\n";
-    rslen = 1;
-    rschar = '\n';
-    rspara = 0;
+    SvREFCNT_dec(rs);
+    rs = newSVpv("\n", 1);
     sv_setpv(GvSV(errgv),"");
     if (yyparse() || error_count || !eval_root) {
        SV **newsp;
@@ -1991,16 +2011,12 @@ int gimme;
        LEAVE;
        if (optype == OP_REQUIRE)
            DIE("%s", SvPVx(GvSV(errgv), na));
-       rs = nrs;
-       rslen = nrslen;
-       rschar = nrschar;
-       rspara = (nrslen == 2);
+       SvREFCNT_dec(rs);
+       rs = SvREFCNT_inc(nrs);
        RETPUSHUNDEF;
     }
-    rs = nrs;
-    rslen = nrslen;
-    rschar = nrschar;
-    rspara = (nrslen == 2);
+    SvREFCNT_dec(rs);
+    rs = SvREFCNT_inc(nrs);
     compiling.cop_line = 0;
     SAVEFREEOP(eval_root);
     if (gimme & G_ARRAY)
@@ -2028,9 +2044,9 @@ PP(pp_require)
 
     sv = POPs;
     if (SvNIOKp(sv) && !SvPOKp(sv)) {
-       if (atof(patchlevel) + 0.000999 < SvNV(sv))
-           DIE("Perl %3.3f required--this is only version %s, stopped",
-               SvNV(sv),patchlevel);
+       if (atof(patchlevel) + 0.00000999 < SvNV(sv))
+           DIE("Perl %s required--this is only version %s, stopped",
+               SvPV(sv,na),patchlevel);
        RETPUSHYES;
     }
     name = SvPV(sv, na);