fixes for logical bugs in the lexwarn patch; other tweaks to avoid

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

diff --git a/sv.c b/sv.c
index e44c533..9973156 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -205,7 +205,9 @@ S_del_sv(pTHX_ SV *p)
                ok = 1;
        }
        if (!ok) {
-           Perl_warn(aTHX_ "Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
+           if (ckWARN_d(WARN_INTERNAL))        
+               Perl_warner(aTHX_ WARN_INTERNAL,
+                      "Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
            return;
        }
     }
@@ -1217,14 +1219,13 @@ Perl_sv_2iv(pTHX_ register SV *sv)
            SvNVX(sv) = d;
            (void)SvNOK_on(sv);
            (void)SvIOK_on(sv);
-           DEBUG_c(PerlIO_printf(Perl_debug_log,
 #if defined(USE_LONG_DOUBLE)
-                                 "0x%lx 2nv(%Lg)\n",
+           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
+                                 (unsigned long)sv, SvNVX(sv)));
 #else
-                                 "0x%lx 2nv(%g)\n",
+           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
+                                 (unsigned long)sv, SvNVX(sv)));
 #endif
-                                 (unsigned long)sv,
-                                 SvNVX(sv)));
            if (SvNVX(sv) < (NV)IV_MAX + 0.5)
                SvIVX(sv) = I_V(SvNVX(sv));
            else {
@@ -1362,14 +1363,13 @@ Perl_sv_2uv(pTHX_ register SV *sv)
            SvNVX(sv) = d;
            (void)SvNOK_on(sv);
            (void)SvIOK_on(sv);
-           DEBUG_c(PerlIO_printf(Perl_debug_log,
 #if defined(USE_LONG_DOUBLE)
-                                 "0x%lx 2nv(%Lg)\n",
+           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
+                                 (unsigned long)sv, SvNVX(sv)));
 #else
-                                 "0x%lx 2nv(%g)\n",
+           DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
+                                 (unsigned long)sv, SvNVX(sv)));
 #endif
-                                 (unsigned long)sv,
-                                 SvNVX(sv)));
            if (SvNVX(sv) < -0.5) {
                SvIVX(sv) = I_V(SvNVX(sv));
                goto ret_zero;
@@ -1490,17 +1490,21 @@ Perl_sv_2nv(pTHX_ register SV *sv)
            sv_upgrade(sv, SVt_PVNV);
        else
            sv_upgrade(sv, SVt_NV);
+#if defined(USE_LONG_DOUBLE)
        DEBUG_c({
            RESTORE_NUMERIC_STANDARD();
-           PerlIO_printf(Perl_debug_log,
-#if defined(USE_LONG_DOUBLE)
-                         "0x%lx num(%Lg)\n",
+           PerlIO_printf(Perl_debug_log, "0x%lx num(%Lg)\n",
+                         (unsigned long)sv, SvNVX(sv));
+           RESTORE_NUMERIC_LOCAL();
+       });
 #else
-                         "0x%lx num(%g)\n",
-#endif
-                         (unsigned long)sv,SvNVX(sv)));
+       DEBUG_c({
+           RESTORE_NUMERIC_STANDARD();
+           PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",
+                         (unsigned long)sv, SvNVX(sv));
            RESTORE_NUMERIC_LOCAL();
        });
+#endif
     }
     else if (SvTYPE(sv) < SVt_PVNV)
        sv_upgrade(sv, SVt_PVNV);
@@ -1525,17 +1529,21 @@ Perl_sv_2nv(pTHX_ register SV *sv)
        return 0.0;
     }
     SvNOK_on(sv);
+#if defined(USE_LONG_DOUBLE)
     DEBUG_c({
        RESTORE_NUMERIC_STANDARD();
-       PerlIO_printf(Perl_debug_log,
-#if defined(USE_LONG_DOUBLE)
-                     "0x%lx 2nv(%Lg)\n",
+       PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
+                     (unsigned long)sv, SvNVX(sv));
+       RESTORE_NUMERIC_LOCAL();
+    });
 #else
-                     "0x%lx 1nv(%g)\n",
-#endif
-                     (unsigned long)sv,SvNVX(sv)));
+    DEBUG_c({
+       RESTORE_NUMERIC_STANDARD();
+       PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n",
+                     (unsigned long)sv, SvNVX(sv));
        RESTORE_NUMERIC_LOCAL();
     });
+#endif
     return SvNVX(sv);
 }
 
@@ -2960,10 +2968,11 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN
 void
 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
 {
+    dTHR;
     U32 refcnt = SvREFCNT(sv);
     SV_CHECK_THINKFIRST(sv);
-    if (SvREFCNT(nsv) != 1)
-       Perl_warn(aTHX_ "Reference miscount in sv_replace()");
+    if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
+       Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
     if (SvMAGICAL(sv)) {
        if (SvMAGICAL(nsv))
            mg_free(nsv);
@@ -3180,6 +3189,7 @@ Perl_sv_newref(pTHX_ SV *sv)
 void
 Perl_sv_free(pTHX_ SV *sv)
 {
+    dTHR;
     int refcount_is_zero;
 
     if (!sv)
@@ -3194,7 +3204,8 @@ Perl_sv_free(pTHX_ SV *sv)
            SvREFCNT(sv) = (~(U32)0)/2;
            return;
        }
-       Perl_warn(aTHX_ "Attempt to free unreferenced scalar");
+       if (ckWARN_d(WARN_INTERNAL))
+           Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
        return;
     }
     ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
@@ -3202,7 +3213,9 @@ Perl_sv_free(pTHX_ SV *sv)
        return;
 #ifdef DEBUGGING
     if (SvTEMP(sv)) {
-       Perl_warn(aTHX_ "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
+       if (ckWARN_d(WARN_DEBUGGING))
+           Perl_warner(aTHX_ WARN_DEBUGGING,
+                       "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
        return;
     }
 #endif
@@ -3308,7 +3321,9 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
        ++len;
     }
     if (s != send) {
-       Perl_warn(aTHX_ "Malformed UTF-8 character");
+        dTHR;
+       if (ckWARN_d(WARN_UTF8))    
+           Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
        --len;
     }
     *offsetp = len;
@@ -4045,12 +4060,14 @@ Perl_newRV(pTHX_ SV *tmpRef)
 SV *
 Perl_newSVsv(pTHX_ register SV *old)
 {
+    dTHR;
     register SV *sv;
 
     if (!old)
        return Nullsv;
     if (SvTYPE(old) == SVTYPEMASK) {
-       Perl_warn(aTHX_ "semi-panic: attempt to dup freed string");
+        if (ckWARN_d(WARN_INTERNAL))
+           Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
        return Nullsv;
     }
     new_SV(sv);