add verbose stack display option, -Dvs

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

diff --git a/util.c b/util.c
index e42efe3..99c79fb 100644 (file)
--- a/util.c
+++ b/util.c
@@ -2349,6 +2349,12 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
 {
     struct sigaction act, oact;
 
+#ifdef USE_ITHREADS
+    /* only "parent" interpreter can diddle signals */
+    if (PL_curinterp != aTHX)
+       return SIG_ERR;
+#endif
+
     act.sa_handler = handler;
     sigemptyset(&act.sa_mask);
     act.sa_flags = 0;
@@ -2383,6 +2389,12 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
 {
     struct sigaction act;
 
+#ifdef USE_ITHREADS
+    /* only "parent" interpreter can diddle signals */
+    if (PL_curinterp != aTHX)
+       return -1;
+#endif
+
     act.sa_handler = handler;
     sigemptyset(&act.sa_mask);
     act.sa_flags = 0;
@@ -2401,6 +2413,12 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
 int
 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
 {
+#ifdef USE_ITHREADS
+    /* only "parent" interpreter can diddle signals */
+    if (PL_curinterp != aTHX)
+       return -1;
+#endif
+
     return sigaction(signo, save, (struct sigaction *)NULL);
 }
 
@@ -2409,6 +2427,12 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
 Sighandler_t
 Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
 {
+#if defined(USE_ITHREADS) && !defined(WIN32)
+    /* only "parent" interpreter can diddle signals */
+    if (PL_curinterp != aTHX)
+       return SIG_ERR;
+#endif
+
     return PerlProc_signal(signo, handler);
 }
 
@@ -2427,6 +2451,12 @@ Perl_rsignal_state(pTHX_ int signo)
 {
     Sighandler_t oldsig;
 
+#if defined(USE_ITHREADS) && !defined(WIN32)
+    /* only "parent" interpreter can diddle signals */
+    if (PL_curinterp != aTHX)
+       return SIG_ERR;
+#endif
+
     sig_trapped = 0;
     oldsig = PerlProc_signal(signo, sig_trap);
     PerlProc_signal(signo, oldsig);
@@ -2438,6 +2468,11 @@ Perl_rsignal_state(pTHX_ int signo)
 int
 Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
 {
+#if defined(USE_ITHREADS) && !defined(WIN32)
+    /* only "parent" interpreter can diddle signals */
+    if (PL_curinterp != aTHX)
+       return -1;
+#endif
     *save = PerlProc_signal(signo, handler);
     return (*save == SIG_ERR) ? -1 : 0;
 }
@@ -2445,6 +2480,11 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
 int
 Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
 {
+#if defined(USE_ITHREADS) && !defined(WIN32)
+    /* only "parent" interpreter can diddle signals */
+    if (PL_curinterp != aTHX)
+       return -1;
+#endif
     return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
 }
 
@@ -3441,8 +3481,6 @@ Perl_my_fflush_all(pTHX)
 void
 Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
 {
-    char *vile;
-    I32   warn_type;
     char *func =
        op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
        op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
@@ -3453,42 +3491,53 @@ Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
                      "socket" : "filehandle";
     char *name = NULL;
 
-    if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
-       vile = "closed";
-       warn_type = WARN_CLOSED;
-    }
-    else {
-       vile = "unopened";
-       warn_type = WARN_UNOPENED;
-    }
-
     if (gv && isGV(gv)) {
        name = GvENAME(gv);
     }
 
     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
-       if (name && *name)
-           Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle %s opened only for %sput",
-                       name,
-                       (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
-       else
-           Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle opened only for %sput",
-                       (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
-    } else if (name && *name) {
-       Perl_warner(aTHX_ packWARN(warn_type),
-                   "%s%s on %s %s %s", func, pars, vile, type, name);
-       if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
-           Perl_warner(aTHX_ packWARN(warn_type),
-                       "\t(Are you trying to call %s%s on dirhandle %s?)\n",
-                       func, pars, name);
+        if (ckWARN(WARN_IO)) {
+            if (name && *name)
+                Perl_warner(aTHX_ packWARN(WARN_IO),
+                            "Filehandle %s opened only for %sput",
+                            name, (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
+            else
+                Perl_warner(aTHX_ packWARN(WARN_IO),
+                            "Filehandle opened only for %sput",
+                            (op == OP_phoney_INPUT_ONLY ? "in" : "out"));
+        }
     }
     else {
-       Perl_warner(aTHX_ packWARN(warn_type),
-                   "%s%s on %s %s", func, pars, vile, type);
-       if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
-           Perl_warner(aTHX_ packWARN(warn_type),
-                       "\t(Are you trying to call %s%s on dirhandle?)\n",
-                       func, pars);
+        char *vile;
+        I32   warn_type;
+
+        if (gv && io && IoTYPE(io) == IoTYPE_CLOSED) {
+            vile = "closed";
+            warn_type = WARN_CLOSED;
+        }
+        else {
+            vile = "unopened";
+            warn_type = WARN_UNOPENED;
+        }
+
+        if (ckWARN(warn_type)) {
+            if (name && *name) {
+                Perl_warner(aTHX_ packWARN(warn_type),
+                            "%s%s on %s %s %s", func, pars, vile, type, name);
+                if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+                    Perl_warner(aTHX_ packWARN(warn_type),
+                                "\t(Are you trying to call %s%s on dirhandle %s?)\n",
+                                func, pars, name);
+            }
+            else {
+                Perl_warner(aTHX_ packWARN(warn_type),
+                            "%s%s on %s %s", func, pars, vile, type);
+                if (gv && io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+                    Perl_warner(aTHX_ packWARN(warn_type),
+                                "\t(Are you trying to call %s%s on dirhandle?)\n",
+                                func, pars);
+            }
+        }
     }
 }