Undo part of change 6489 which looks like a bulk edit which

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

diff --git a/util.c b/util.c
index d892e75..ea0778f 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1896,7 +1896,12 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
            PerlIO *serr = Perl_error_log;
            PerlIO_write(serr, message, msglen);
 #ifdef LEAKTEST
-           DEBUG_L(xstat());
+           DEBUG_L(*message == '!' 
+               ? (xstat(message[1]=='!'
+                        ? (message[2]=='!' ? 2 : 1)
+                        : 0)
+                  , 0)
+               : 0);
 #endif
            (void)PerlIO_flush(serr);
        }
@@ -2676,6 +2681,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 
     if (!pid)
        return -1;
+#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
     if (pid > 0) {
        sprintf(spid, "%"IVdf, (IV)pid);
        svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
@@ -2698,6 +2704,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
            return pid;
        }
     }
+#endif
 #ifdef HAS_WAITPID
 #  ifdef HAS_WAITPID_RUNTIME
     if (!HAS_WAITPID_RUNTIME)
@@ -3502,11 +3509,9 @@ Perl_sv_lock(pTHX_ SV *osv)
     MAGIC *mg;
     SV *sv = osv;
 
-    SvLOCK(osv);
+    LOCK_SV_LOCK_MUTEX;
     if (SvROK(sv)) {
        sv = SvRV(sv);
-       SvUNLOCK(osv);
-       SvLOCK(sv);
     }
 
     mg = condpair_magic(sv);
@@ -3523,7 +3528,7 @@ Perl_sv_lock(pTHX_ SV *osv)
        MUTEX_UNLOCK(MgMUTEXP(mg));
        SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
     }
-    SvUNLOCK(sv);
+    UNLOCK_SV_LOCK_MUTEX;
     return sv;
 }
 
@@ -3870,41 +3875,69 @@ Perl_my_fflush_all(pTHX)
 NV
 Perl_my_atof(pTHX_ const char* s)
 {
+    NV x = 0.0;
 #ifdef USE_LOCALE_NUMERIC
     if ((PL_hints & HINT_LOCALE) && PL_numeric_local) {
-       NV x, y;
+       NV y;
 
-       x = Perl_atof(s);
+       Perl_atof2(s, x);
        SET_NUMERIC_STANDARD();
-       y = Perl_atof(s);
+       Perl_atof2(s, y);
        SET_NUMERIC_LOCAL();
        if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
            return y;
-       return x;
     }
     else
-       return Perl_atof(s);
+       Perl_atof2(s, x);
 #else
-    return Perl_atof(s);
+    Perl_atof2(s, x);
 #endif
+    return x;
 }
 
 void
-Perl_report_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj)
-{
-    SV *sv;
-    char *name;
-
-    assert(gv);
-
-    sv = sv_newmortal();
-    gv_efullname3(sv, gv, Nullch);
-    name = SvPVX(sv);
+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 */
+       PL_op_desc[op];
+    char *pars = OP_IS_FILETEST(op) ? "" : "()";
+    char *type = OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ?
+                     "socket" : "filehandle";
+    char *name = NULL;
+
+    if (io && IoTYPE(io) == IoTYPE_CLOSED) {
+       vile = "closed";
+       warn_type = WARN_CLOSED;
+    }
+    else {
+       vile = "unopened";
+       warn_type = WARN_UNOPENED;
+    }
 
-    Perl_warner(aTHX_ WARN_CLOSED, "%s() on closed %s %s", func, obj, name);
+    if (gv && isGV(gv)) {
+       SV *sv = sv_newmortal();
+       gv_efullname4(sv, gv, Nullch, FALSE);
+       name = SvPVX(sv);
+    }
 
-    if (io && IoDIRP(io))
-       Perl_warner(aTHX_ WARN_CLOSED,
-                   "\t(Are you trying to call %s() on dirhandle %s?)\n",
-                   func, name);
+    if (name && *name) {
+       Perl_warner(aTHX_ 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_ warn_type,
+                       "\t(Are you trying to call %s%s on dirhandle %s?)\n",
+                       func, pars, name);
+    }
+    else {
+       Perl_warner(aTHX_ warn_type,
+                   "%s%s on %s %s", func, pars, vile, type);
+       if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+           Perl_warner(aTHX_ warn_type,
+                       "\t(Are you trying to call %s%s on dirhandle?)\n",
+                       func, pars);
+    }
 }