Make t/harness have non-zero exit if tests fail

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

diff --git a/doio.c b/doio.c
index 0e46582..2b2caa5 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -312,6 +312,7 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw,
                else {
                    PerlIO *that_fp = NULL;
                    if (num_svs > 1) {
+                       /* diag_listed_as: More than one argument to '%s' open */
                        Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io));
                    }
                    while (isSPACE(*type))
@@ -398,6 +399,7 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw,
                    fp = PerlIO_stdout();
                    IoTYPE(io) = IoTYPE_STD;
                    if (num_svs > 1) {
+                       /* diag_listed_as: More than one argument to '%s' open */
                        Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD);
                    }
                }
@@ -431,6 +433,7 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw,
                fp = PerlIO_stdin();
                IoTYPE(io) = IoTYPE_STD;
                if (num_svs > 1) {
+                   /* diag_listed_as: More than one argument to '%s' open */
                    Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD);
                }
            }
@@ -626,7 +629,6 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw,
                 Pid_t pid;
                 SV *sv;
 
-                LOCK_FDPID_MUTEX;
                 sv = *av_fetch(PL_fdpid,fd,TRUE);
                 SvUPGRADE(sv, SVt_IV);
                 pid = SvIVX(sv);
@@ -634,7 +636,6 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw,
                 sv = *av_fetch(PL_fdpid,savefd,TRUE);
                 SvUPGRADE(sv, SVt_IV);
                 SvIV_set(sv, pid);
-                UNLOCK_FDPID_MUTEX;
             }
 #endif
 
@@ -1725,8 +1726,11 @@ nothing in the core.
             * CRTL's emulation of Unix-style signals and kill()
             */
            while (++mark <= sp) {
-               I32 proc = SvIV(*mark);
+               I32 proc;
                register unsigned long int __vmssts;
+               if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark)))
+                   Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
+               proc = SvIV(*mark);
                APPLY_TAINT_PROPER();
                if (!((__vmssts = sys$delprc(&proc,0)) & 1)) {
                    tot--;
@@ -1749,7 +1753,10 @@ nothing in the core.
        if (val < 0) {
            val = -val;
            while (++mark <= sp) {
-               const I32 proc = SvIV(*mark);
+               I32 proc;
+               if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark)))
+                   Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
+               proc = SvIV(*mark);
                APPLY_TAINT_PROPER();
 #ifdef HAS_KILLPG
                if (PerlProc_killpg(proc,val))  /* BSD */
@@ -1761,7 +1768,10 @@ nothing in the core.
        }
        else {
            while (++mark <= sp) {
-               const I32 proc = SvIV(*mark);
+               I32 proc;
+               if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark)))
+                   Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
+               proc = SvIV(*mark);
                APPLY_TAINT_PROPER();
                if (PerlProc_kill(proc, val))
                    tot--;
@@ -1999,6 +2009,7 @@ Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp)
 #endif
 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
     default:
+        /* diag_listed_as: msg%s not implemented */
        Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
 #endif
     }
@@ -2059,12 +2070,14 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
                   than guessing about u_?short(_t)? */
        }
 #else
+        /* diag_listed_as: sem%s not implemented */
        Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
 #endif
        break;
 #endif
 #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM)
     default:
+        /* diag_listed_as: shm%s not implemented */
        Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
 #endif
     }
@@ -2112,6 +2125,7 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp)
 #endif
            ret = Semctl(id, n, cmd, unsemds);
 #else
+           /* diag_listed_as: sem%s not implemented */
            Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]);
 #endif
         }
@@ -2153,6 +2167,7 @@ Perl_do_msgsnd(pTHX_ SV **mark, SV **sp)
 #else
     PERL_UNUSED_ARG(sp);
     PERL_UNUSED_ARG(mark);
+    /* diag_listed_as: msg%s not implemented */
     Perl_croak(aTHX_ "msgsnd not implemented");
 #endif
 }
@@ -2194,6 +2209,7 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp)
 #else
     PERL_UNUSED_ARG(sp);
     PERL_UNUSED_ARG(mark);
+    /* diag_listed_as: msg%s not implemented */
     Perl_croak(aTHX_ "msgrcv not implemented");
 #endif
 }
@@ -2248,6 +2264,7 @@ Perl_do_semop(pTHX_ SV **mark, SV **sp)
         return result;
     }
 #else
+    /* diag_listed_as: sem%s not implemented */
     Perl_croak(aTHX_ "semop not implemented");
 #endif
 }
@@ -2306,6 +2323,7 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
     }
     return shmdt(shm);
 #else
+    /* diag_listed_as: shm%s not implemented */
     Perl_croak(aTHX_ "shm I/O not implemented");
 #endif
 }