gutsupport for C++ exceptions

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

diff --git a/pp_ctl.c b/pp_ctl.c
index e29ff19..9d6d063 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -29,6 +29,7 @@
 #define CALLOP this->*PL_op
 #else
 #define CALLOP *PL_op
+static void *docatch_body _((void *o));
 static OP *docatch _((OP *o));
 static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
 static void doparseform _((SV *sv));
@@ -41,6 +42,7 @@ static void save_lines _((AV *array, SV *sv));
 static I32 sortcv _((SV *a, SV *b));
 static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
 static OP *doeval _((int gimme, OP** startop));
+static PerlIO *doopen _((const char *name, const char *mode));
 static I32 sv_ncmp _((SV *a, SV *b));
 static I32 sv_i_ncmp _((SV *a, SV *b));
 static I32 amagic_ncmp _((SV *a, SV *b));
@@ -1319,7 +1321,7 @@ dounwind(I32 cxix)
 }
 
 OP *
-die_where(char *message)
+die_where(char *message, STRLEN msglen)
 {
     dSP;
     STRLEN n_a;
@@ -1332,9 +1334,8 @@ die_where(char *message)
        if (message) {
            if (PL_in_eval & 4) {
                SV **svp;
-               STRLEN klen = strlen(message);
                
-               svp = hv_fetch(ERRHV, message, klen, TRUE);
+               svp = hv_fetch(ERRHV, message, msglen, TRUE);
                if (svp) {
                    if (!SvIOK(*svp)) {
                        static char prefix[] = "\t(in cleanup) ";
@@ -1343,11 +1344,11 @@ die_where(char *message)
                        (void)SvIOK_only(*svp);
                        if (!SvPOK(err))
                            sv_setpv(err,"");
-                       SvGROW(err, SvCUR(err)+sizeof(prefix)+klen);
+                       SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
                        sv_catpvn(err, prefix, sizeof(prefix)-1);
-                       sv_catpvn(err, message, klen);
+                       sv_catpvn(err, message, msglen);
                        if (ckWARN(WARN_UNSAFE)) {
-                           STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1;
+                           STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
                            warner(WARN_UNSAFE, SvPVX(err)+start);
                        }
                    }
@@ -1355,10 +1356,10 @@ die_where(char *message)
                }
            }
            else
-               sv_setpv(ERRSV, message);
+               sv_setpvn(ERRSV, message, msglen);
        }
        else
-           message = SvPVx(ERRSV, n_a);
+           message = SvPVx(ERRSV, msglen);
 
        while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
            dounwind(-1);
@@ -1373,7 +1374,8 @@ die_where(char *message)
 
            POPBLOCK(cx,PL_curpm);
            if (CxTYPE(cx) != CXt_EVAL) {
-               PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
+               PerlIO_write(PerlIO_stderr(), "panic: die ", 11);
+               PerlIO_write(PerlIO_stderr(), message, msglen);
                my_exit(1);
            }
            POPEVAL(cx);
@@ -1392,9 +1394,18 @@ die_where(char *message)
        }
     }
     if (!message)
-       message = SvPVx(ERRSV, n_a);
-    PerlIO_printf(PerlIO_stderr(), "%s",message);
-    PerlIO_flush(PerlIO_stderr());
+       message = SvPVx(ERRSV, msglen);
+    {
+#ifdef USE_SFIO
+       /* SFIO can really mess with your errno */
+       int e = errno;
+#endif
+       PerlIO_write(PerlIO_stderr(), message, msglen);
+       (void)PerlIO_flush(PerlIO_stderr());
+#ifdef USE_SFIO
+       errno = e;
+#endif
+    }
     my_failure_exit();
     /* NOTREACHED */
     return 0;
@@ -2481,38 +2492,41 @@ save_lines(AV *array, SV *sv)
     }
 }
 
+STATIC void *
+docatch_body(va_list args)
+{
+    CALLRUNOPS();
+    return NULL;
+}
+
 STATIC OP *
 docatch(OP *o)
 {
     dTHR;
     int ret;
     OP *oldop = PL_op;
-    dJMPENV;
 
-    PL_op = o;
 #ifdef DEBUGGING
     assert(CATCH_GET == TRUE);
-    DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
 #endif
-    JMPENV_PUSH(ret);
+    PL_op = o;
+ redo_body:
+    CALLPROTECT(&ret, docatch_body);
     switch (ret) {
-    default:                           /* topmost level handles it */
-pass_the_buck:
-       JMPENV_POP;
+    case 0:
+       break;
+    case 3:
+       if (PL_restartop) {
+           PL_op = PL_restartop;
+           PL_restartop = 0;
+           goto redo_body;
+       }
+       /* FALL THROUGH */
+    default:
        PL_op = oldop;
        JMPENV_JUMP(ret);
        /* NOTREACHED */
-    case 3:
-       if (!PL_restartop)
-           goto pass_the_buck;
-       PL_op = PL_restartop;
-       PL_restartop = 0;
-       /* FALL THROUGH */
-    case 0:
-        CALLRUNOPS();
-       break;
     }
-    JMPENV_POP;
     PL_op = oldop;
     return Nullop;
 }
@@ -2762,6 +2776,35 @@ doeval(int gimme, OP** startop)
     RETURNOP(PL_eval_start);
 }
 
+static PerlIO *
+doopen(const char *name, const char *mode)
+{
+    STRLEN namelen = strlen(name);
+    PerlIO *fp;
+
+    if (namelen > 3 && strcmp(name + namelen - 3, ".pm") == 0) {
+        SV *pmcsv = newSVpvf("%s%c", name, 'c');
+       char *pmc = SvPV_nolen(pmcsv);
+       Stat_t pmstat;
+        Stat_t pmcstat;
+        if (PerlLIO_stat(pmc, &pmcstat) < 0) {
+           fp = PerlIO_open(name, mode);
+       } else {
+           if (PerlLIO_stat(name, &pmstat) < 0 ||
+               pmstat.st_mtime < pmcstat.st_mtime) {
+               fp = PerlIO_open(pmc, mode);
+         } else {
+               fp = PerlIO_open(name, mode);
+         }
+       }
+        SvREFCNT_dec(pmcsv);
+    } else {
+        fp = PerlIO_open(name, mode);
+    }
+
+    return fp;
+}
+
 PP(pp_require)
 {
     djSP;
@@ -2812,7 +2855,7 @@ PP(pp_require)
     )
     {
        tryname = name;
-       tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
+       tryrsfp = doopen(name,PERL_SCRIPT_MODE);
     }
     else {
        AV *ar = GvAVn(PL_incgv);
@@ -2836,7 +2879,7 @@ PP(pp_require)
 #endif
                TAINT_PROPER("require");
                tryname = SvPVX(namesv);
-               tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE);
+               tryrsfp = doopen(tryname, PERL_SCRIPT_MODE);
                if (tryrsfp) {
                    if (tryname[0] == '.' && tryname[1] == '/')
                        tryname += 2;