Add Perl_ck_warner_d(), which combines Perl_ckwarn_d() and Perl_warner().

Replace ckWARN_d{,2,3,4}() && Perl_warner() with it, which trades reduced code
size for 1 more function call if warnings are not enabled.

diff --git a/av.c b/av.c
index f45a3ea..4718af2 100644 (file)
--- a/av.c
+++ b/av.c
@@ -35,8 +35,8 @@ Perl_av_reify(pTHX_ AV *av)
     if (AvREAL(av))
        return;
 #ifdef DEBUGGING
-    if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING))
-       Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
+    if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied))
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array");
 #endif
     key = AvMAX(av) + 1;
     while (key > AvFILLp(av) + 1)
@@ -431,8 +431,8 @@ Perl_av_clear(pTHX_ register AV *av)
     assert(SvTYPE(av) == SVt_PVAV);
 
 #ifdef DEBUGGING
-    if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) {
-       Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
+    if (SvREFCNT(av) == 0) {
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array");
     }
 #endif
 

diff --git a/doio.c b/doio.c
index 2b2caa5..cd470c4 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -758,10 +758,9 @@ Perl_nextargv(pTHX_ register GV *gv)
                fileuid = PL_statbuf.st_uid;
                filegid = PL_statbuf.st_gid;
                if (!S_ISREG(PL_filemode)) {
-                   if (ckWARN_d(WARN_INPLACE)) 
-                       Perl_warner(aTHX_ packWARN(WARN_INPLACE),
-                           "Can't do inplace edit: %s is not a regular file",
-                           PL_oldname );
+                   Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
+                                    "Can't do inplace edit: %s is not a regular file",
+                                    PL_oldname );
                    do_close(gv,FALSE);
                    continue;
                }
@@ -790,10 +789,9 @@ Perl_nextargv(pTHX_ register GV *gv)
 #endif
                       )
                    {
-                       if (ckWARN_d(WARN_INPLACE))     
-                           Perl_warner(aTHX_ packWARN(WARN_INPLACE),
-                             "Can't do inplace edit: %"SVf" would not be unique",
-                             SVfARG(sv));
+                       Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
+                                        "Can't do inplace edit: %"SVf" would not be unique",
+                                        SVfARG(sv));
                        do_close(gv,FALSE);
                        continue;
                    }
@@ -801,10 +799,9 @@ Perl_nextargv(pTHX_ register GV *gv)
 #ifdef HAS_RENAME
 #if !defined(DOSISH) && !defined(__CYGWIN__) && !defined(EPOC)
                    if (PerlLIO_rename(PL_oldname,SvPVX_const(sv)) < 0) {
-                       if (ckWARN_d(WARN_INPLACE))     
-                           Perl_warner(aTHX_ packWARN(WARN_INPLACE),
-                             "Can't rename %s to %"SVf": %s, skipping file",
-                             PL_oldname, SVfARG(sv), Strerror(errno));
+                       Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
+                                        "Can't rename %s to %"SVf": %s, skipping file",
+                                        PL_oldname, SVfARG(sv), Strerror(errno));
                        do_close(gv,FALSE);
                        continue;
                    }
@@ -817,10 +814,9 @@ Perl_nextargv(pTHX_ register GV *gv)
 #else
                    (void)UNLINK(SvPVX_const(sv));
                    if (link(PL_oldname,SvPVX_const(sv)) < 0) {
-                       if (ckWARN_d(WARN_INPLACE))     
-                           Perl_warner(aTHX_ packWARN(WARN_INPLACE),
-                             "Can't rename %s to %"SVf": %s, skipping file",
-                             PL_oldname, SVfARG(sv), Strerror(errno) );
+                       Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
+                                        "Can't rename %s to %"SVf": %s, skipping file",
+                                        PL_oldname, SVfARG(sv), Strerror(errno) );
                        do_close(gv,FALSE);
                        continue;
                    }
@@ -831,10 +827,9 @@ Perl_nextargv(pTHX_ register GV *gv)
 #if !defined(DOSISH) && !defined(AMIGAOS)
 #  ifndef VMS  /* Don't delete; use automatic file versioning */
                    if (UNLINK(PL_oldname) < 0) {
-                       if (ckWARN_d(WARN_INPLACE))     
-                           Perl_warner(aTHX_ packWARN(WARN_INPLACE),
-                             "Can't remove %s: %s, skipping file",
-                             PL_oldname, Strerror(errno) );
+                       Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE),
+                                        "Can't remove %s: %s, skipping file",
+                                        PL_oldname, Strerror(errno) );
                        do_close(gv,FALSE);
                        continue;
                    }
@@ -854,9 +849,8 @@ Perl_nextargv(pTHX_ register GV *gv)
                                   O_WRONLY|O_CREAT|OPEN_EXCL,0600,
 #endif
                                   NULL, NULL, 0)) {
-                   if (ckWARN_d(WARN_INPLACE)) 
-                       Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s",
-                         PL_oldname, Strerror(errno) );
+                   Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit on %s: %s",
+                                    PL_oldname, Strerror(errno) );
                    do_close(gv,FALSE);
                    continue;
                }
@@ -1245,10 +1239,8 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
            }
            else {
                assert((char *)result == tmps);
-               if (ckWARN_d(WARN_UTF8)) {
-                   Perl_warner(aTHX_ packWARN(WARN_UTF8),
-                               "Wide character in print");
-               }
+               Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
+                                "Wide character in print");
            }
        }
        /* To detect whether the process is about to overstep its

diff --git a/dump.c b/dump.c
index fae2d11..70efde4 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -2016,8 +2016,7 @@ Perl_runops_debug(pTHX)
 {
     dVAR;
     if (!PL_op) {
-       if (ckWARN_d(WARN_DEBUGGING))
-           Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
        return 0;
     }
 

diff --git a/embed.fnc b/embed.fnc
index 23277ee..e51d89a 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1182,6 +1182,7 @@ Afpd      |void   |warn           |NN const char* pat|...
 Ap     |void   |vwarn          |NN const char* pat|NULLOK va_list* args
 Afp    |void   |warner         |U32 err|NN const char* pat|...
 Afp    |void   |ck_warner      |U32 err|NN const char* pat|...
+Afp    |void   |ck_warner_d    |U32 err|NN const char* pat|...
 Ap     |void   |vwarner        |U32 err|NN const char* pat|NULLOK va_list* args
 : FIXME
 p      |void   |watch          |NN char** addr

diff --git a/embed.h b/embed.h
index b4fd020..b987bd1 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1041,6 +1041,7 @@
 #define vwarn                  Perl_vwarn
 #define warner                 Perl_warner
 #define ck_warner              Perl_ck_warner
+#define ck_warner_d            Perl_ck_warner_d
 #define vwarner                        Perl_vwarner
 #ifdef PERL_CORE
 #define watch                  Perl_watch

diff --git a/global.sym b/global.sym
index 9bdcacb..7205e22 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -614,6 +614,7 @@ Perl_warn
 Perl_vwarn
 Perl_warner
 Perl_ck_warner
+Perl_ck_warner_d
 Perl_vwarner
 Perl_whichsig
 Perl_yylex

diff --git a/gv.c b/gv.c
index 6b38fe4..38f7208 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1137,8 +1137,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 
     faking_it = SvOK(gv);
 
-    if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL))
-       Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
+    if (add & GV_ADDWARN)
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "Had to create %s unexpectedly", nambeg);
     gv_init(gv, stash, name, len, add & GV_ADDMULTI);
     gv_init_sv(gv, faking_it ? SVt_PVCV : sv_type);
 
@@ -1350,9 +1350,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
        }
        case '*':
        case '#':
-           if (sv_type == SVt_PV && ckWARN2_d(WARN_DEPRECATED, WARN_SYNTAX))
-               Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
-                           "$%c is no longer supported", *name);
+           if (sv_type == SVt_PV)
+               Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+                                "$%c is no longer supported", *name);
            break;
        case '|':
            sv_setiv(GvSVn(gv), (IV)(IoFLAGS(GvIOp(PL_defoutgv)) & IOf_FLUSH) != 0);
@@ -1559,10 +1559,9 @@ Perl_gp_free(pTHX_ GV *gv)
     if (!gv || !isGV_with_GP(gv) || !(gp = GvGP(gv)))
        return;
     if (gp->gp_refcnt == 0) {
-       if (ckWARN_d(WARN_INTERNAL))
-           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                       "Attempt to free unreferenced glob pointers"
-                        pTHX__FORMAT pTHX__VALUE);
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+                        "Attempt to free unreferenced glob pointers"
+                        pTHX__FORMAT pTHX__VALUE);
         return;
     }
     if (--gp->gp_refcnt > 0) {

diff --git a/hv.c b/hv.c
index ee3a67e..fab9c99 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -2436,12 +2436,12 @@ S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
         }
     }
 
-    if (!entry && ckWARN_d(WARN_INTERNAL))
-       Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                    "Attempt to free non-existent shared string '%s'%s"
-                    pTHX__FORMAT,
-                    hek ? HEK_KEY(hek) : str,
-                    ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
+    if (!entry)
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+                        "Attempt to free non-existent shared string '%s'%s"
+                        pTHX__FORMAT,
+                        hek ? HEK_KEY(hek) : str,
+                        ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
     if (k_flags & HVhek_FREEKEY)
        Safefree(str);
 }

diff --git a/malloc.c b/malloc.c
index 75818cd..adfa23a 100644 (file)
--- a/malloc.c
+++ b/malloc.c
@@ -2056,10 +2056,10 @@ Perl_mfree(Malloc_t where)
 #ifdef PERL_CORE
                {
                    dTHX;
-                   if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
-                       Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)",
-                                   ovp->ov_rmagic == RMAGIC - 1 ?
-                                   "Duplicate" : "Bad");
+                   if (!PERL_IS_ALIVE || !PL_curcop)
+                       Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s free() ignored (RMAGIC, PERL_CORE)",
+                                        ovp->ov_rmagic == RMAGIC - 1 ?
+                                        "Duplicate" : "Bad");
                }
 #else
                warn("%s free() ignored (RMAGIC)",
@@ -2069,8 +2069,8 @@ Perl_mfree(Malloc_t where)
 #ifdef PERL_CORE
                {
                    dTHX;
-                   if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
-                       Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)");
+                   if (!PERL_IS_ALIVE || !PL_curcop)
+                       Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s", "Bad free() ignored (PERL_CORE)");
                }
 #else
                warn("%s", "Bad free() ignored");
@@ -2163,11 +2163,11 @@ Perl_realloc(void *mp, size_t nbytes)
 #ifdef PERL_CORE
                {
                    dTHX;
-                   if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
-                       Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%srealloc() %signored",
-                                   (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
-                                   ovp->ov_rmagic == RMAGIC - 1
-                                   ? "of freed memory " : "");
+                   if (!PERL_IS_ALIVE || !PL_curcop)
+                       Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%srealloc() %signored",
+                                        (ovp->ov_rmagic == RMAGIC - 1 ? "" : "Bad "),
+                                        ovp->ov_rmagic == RMAGIC - 1
+                                        ? "of freed memory " : "");
                }
 #else
                warn2("%srealloc() %signored",
@@ -2178,9 +2178,9 @@ Perl_realloc(void *mp, size_t nbytes)
 #ifdef PERL_CORE
                {
                    dTHX;
-                   if (!PERL_IS_ALIVE || !PL_curcop || ckWARN_d(WARN_MALLOC))
-                       Perl_warner(aTHX_ packWARN(WARN_MALLOC), "%s",
-                                   "Bad realloc() ignored");
+                   if (!PERL_IS_ALIVE || !PL_curcop)
+                       Perl_ck_warner_d(aTHX_ packWARN(WARN_MALLOC), "%s",
+                                        "Bad realloc() ignored");
                }
 #else
                warn("%s", "Bad realloc() ignored");

diff --git a/numeric.c b/numeric.c
index 2b4d68d..bfe6742 100644 (file)
--- a/numeric.c
+++ b/numeric.c
@@ -176,9 +176,8 @@ Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
                     continue;
                 }
                 /* Bah. We're just overflowed.  */
-                if (ckWARN_d(WARN_OVERFLOW))
-                    Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
-                                "Integer overflow in binary number");
+               Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
+                                "Integer overflow in binary number");
                 overflowed = TRUE;
                 value_nv = (NV) value;
             }
@@ -294,9 +293,8 @@ Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
                     continue;
                 }
                 /* Bah. We're just overflowed.  */
-                if (ckWARN_d(WARN_OVERFLOW))
-                    Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
-                                "Integer overflow in hexadecimal number");
+               Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
+                                "Integer overflow in hexadecimal number");
                 overflowed = TRUE;
                 value_nv = (NV) value;
             }
@@ -395,9 +393,8 @@ Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result)
                     continue;
                 }
                 /* Bah. We're just overflowed.  */
-                if (ckWARN_d(WARN_OVERFLOW))
-                    Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
-                                "Integer overflow in octal number");
+               Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
+                              "Integer overflow in octal number");
                 overflowed = TRUE;
                 value_nv = (NV) value;
             }

diff --git a/op.c b/op.c
index 35b7c95..4611dca 100644 (file)
--- a/op.c
+++ b/op.c
@@ -5583,10 +5583,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                                           maximum a prototype before. */
        if (SvTYPE(gv) > SVt_NULL) {
            if (!SvPOK((const SV *)gv)
-               && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1)
-               && ckWARN_d(WARN_PROTOTYPE))
+               && !(SvIOK((const SV *)gv) && SvIVX((const SV *)gv) == -1))
            {
-               Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
+               Perl_ck_warner_d(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
            }
            cv_ckproto_len((const CV *)gv, NULL, ps, ps_len);
        }
@@ -6219,8 +6218,7 @@ Perl_oopsAV(pTHX_ OP *o)
        break;
 
     default:
-       if (ckWARN_d(WARN_INTERNAL))
-           Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
        break;
     }
     return o;
@@ -6248,8 +6246,7 @@ Perl_oopsHV(pTHX_ OP *o)
        break;
 
     default:
-       if (ckWARN_d(WARN_INTERNAL))
-           Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
        break;
     }
     return o;

diff --git a/pad.c b/pad.c
index 123342f..2e0b863 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1065,11 +1065,10 @@ Perl_pad_leavemy(pTHX)
     if (PL_min_intro_pending && PL_comppad_name_fill < PL_min_intro_pending) {
        for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
            const SV * const sv = svp[off];
-           if (sv && sv != &PL_sv_undef
-                   && !SvFAKE(sv) && ckWARN_d(WARN_INTERNAL))
-               Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                           "%"SVf" never introduced",
-                           SVfARG(sv));
+           if (sv && sv != &PL_sv_undef && !SvFAKE(sv))
+               Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+                                "%"SVf" never introduced",
+                                SVfARG(sv));
        }
     }
     /* "Deintroduce" my variables that are leaving with this scope. */

diff --git a/perl.c b/perl.c
index 7e5a406..1ca8bc8 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1049,21 +1049,21 @@ perl_destruct(pTHXx)
     SvREFCNT_dec(PL_isarev);
 
     FREETMPS;
-    if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
+    if (destruct_level >= 2) {
        if (PL_scopestack_ix != 0)
-           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
-                (long)PL_scopestack_ix);
+           Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+                            "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
+                            (long)PL_scopestack_ix);
        if (PL_savestack_ix != 0)
-           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                "Unbalanced saves: %ld more saves than restores\n",
-                (long)PL_savestack_ix);
+           Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+                            "Unbalanced saves: %ld more saves than restores\n",
+                            (long)PL_savestack_ix);
        if (PL_tmps_floor != -1)
-           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
-                (long)PL_tmps_floor + 1);
+           Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
+                            (long)PL_tmps_floor + 1);
        if (cxstack_ix != -1)
-           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
-                (long)cxstack_ix + 1);
+           Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
+                            (long)cxstack_ix + 1);
     }
 
     /* Now absolutely destruct everything, somehow or other, loops or no. */

diff --git a/proto.h b/proto.h
index 4afff50..05b3812 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3708,6 +3708,12 @@ PERL_CALLCONV void       Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
 #define PERL_ARGS_ASSERT_CK_WARNER     \
        assert(pat)
 
+PERL_CALLCONV void     Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
+                       __attribute__format__(__printf__,pTHX_2,pTHX_3)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_CK_WARNER_D   \
+       assert(pat)
+
 PERL_CALLCONV void     Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args)
                        __attribute__nonnull__(pTHX_2);
 #define PERL_ARGS_ASSERT_VWARNER       \

diff --git a/sv.c b/sv.c
index cf1e698..0a27e1a 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -353,10 +353,9 @@ S_del_sv(pTHX_ SV *p)
            }
        }
        if (!ok) {
-           if (ckWARN_d(WARN_INTERNAL))        
-               Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                           "Attempt to free non-arena SV: 0x%"UVxf
-                            pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
+           Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+                            "Attempt to free non-arena SV: 0x%"UVxf
+                            pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
            return;
        }
     }
@@ -5916,10 +5915,9 @@ Perl_sv_free2(pTHX_ SV *const sv)
 
 #ifdef DEBUGGING
     if (SvTEMP(sv)) {
-       if (ckWARN_d(WARN_DEBUGGING))
-           Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
-                       "Attempt to free temp prematurely: SV 0x%"UVxf
-                        pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
+                        "Attempt to free temp prematurely: SV 0x%"UVxf
+                        pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
        return;
     }
 #endif
@@ -7996,8 +7994,7 @@ Perl_newSVsv(pTHX_ register SV *const old)
     if (!old)
        return NULL;
     if (SvTYPE(old) == SVTYPEMASK) {
-        if (ckWARN_d(WARN_INTERNAL))
-           Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
        return NULL;
     }
     new_SV(sv);
@@ -9442,9 +9439,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
                    goto string;
                }
                else if (n) {
-                   if (ckWARN_d(WARN_INTERNAL))
-                       Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                       "internal %%<num>p might conflict with future printf extensions");
+                   Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
+                                    "internal %%<num>p might conflict with future printf extensions");
                }
            }
            q = r; 

diff --git a/taint.c b/taint.c
index 719cce3..62c171f 100644 (file)
--- a/taint.c
+++ b/taint.c
@@ -66,8 +66,7 @@ Perl_taint_proper(pTHX_ const char *f, const char *const s)
         else
            ug = " while running with -T switch";
        if (PL_unsafe || PL_taint_warn) {
-            if(ckWARN_d(WARN_TAINT))
-                Perl_warner(aTHX_ packWARN(WARN_TAINT), f, s, ug);
+           Perl_ck_warner_d(aTHX_ packWARN(WARN_TAINT), f, s, ug);
         }
         else {
             Perl_croak(aTHX_ f, s, ug);

diff --git a/toke.c b/toke.c
index 02ddf97..4e711ab 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -1217,11 +1217,9 @@ S_check_uni(pTHX)
     if ((t = strchr(s, '(')) && t < PL_bufptr)
        return;
 
-    if (ckWARN_d(WARN_AMBIGUOUS)){
-        Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
-                  "Warning: Use of \"%.*s\" without parentheses is ambiguous",
-                  (int)(s - PL_last_uni), PL_last_uni);
-    }
+    Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
+                    "Warning: Use of \"%.*s\" without parentheses is ambiguous",
+                    (int)(s - PL_last_uni), PL_last_uni);
 }
 
 /*
@@ -5580,10 +5578,10 @@ Perl_yylex(pTHX)
                /* Not a method, so call it a subroutine (if defined) */
 
                if (cv) {
-                   if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
-                       Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
-                               "Ambiguous use of -%s resolved as -&%s()",
-                               PL_tokenbuf, PL_tokenbuf);
+                   if (lastchar == '-')
+                       Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
+                                        "Ambiguous use of -%s resolved as -&%s()",
+                                        PL_tokenbuf, PL_tokenbuf);
                    /* Check for a constant sub */
                    if ((sv = gv_const_sv(gv))) {
                  its_constant:
@@ -5725,14 +5723,13 @@ Perl_yylex(pTHX)
                }
 
            safe_bareword:
-               if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
-                   && ckWARN_d(WARN_AMBIGUOUS)) {
-                   Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
-                       "Operator or semicolon missing before %c%s",
-                       lastchar, PL_tokenbuf);
-                   Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
-                       "Ambiguous use of %c resolved as operator %c",
-                       lastchar, lastchar);
+               if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) {
+                   Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
+                                    "Operator or semicolon missing before %c%s",
+                                    lastchar, PL_tokenbuf);
+                   Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
+                                    "Ambiguous use of %c resolved as operator %c",
+                                    lastchar, lastchar);
                }
                TOKEN(WORD);
            }
@@ -8716,8 +8713,7 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
                   name[4] == 'i' &&
                   name[5] == 'f')
               {                                   /* elseif     */
-                if(ckWARN_d(WARN_SYNTAX))
-                  Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
+                  Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
               }
 
               goto unknown;
@@ -12207,10 +12203,9 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
                            && !(PL_hints & HINT_NEW_BINARY)) {
                            overflowed = TRUE;
                            n = (NV) u;
-                           if (ckWARN_d(WARN_OVERFLOW))
-                               Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
-                                           "Integer overflow in %s number",
-                                           base);
+                           Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
+                                            "Integer overflow in %s number",
+                                            base);
                        } else
                            u = x | b;          /* add the digit to the end */
                    }
@@ -12703,8 +12698,7 @@ Perl_yyerror(pTHX_ const char *const s)
         PL_multi_end = 0;
     }
     if (PL_in_eval & EVAL_WARNONLY) {
-       if (ckWARN_d(WARN_SYNTAX))
-           Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
+       Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
     }
     else
        qerror(msg);
@@ -12947,9 +12941,9 @@ Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
                    const UV orev = rev;
                    rev += (*end - '0') * mult;
                    mult *= 10;
-                   if (orev > rev && ckWARN_d(WARN_OVERFLOW))
-                       Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
-                                   "Integer overflow in decimal number");
+                   if (orev > rev)
+                       Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
+                                        "Integer overflow in decimal number");
                }
            }
 #ifdef EBCDIC

diff --git a/utf8.c b/utf8.c
index c154fdb..7b7fd57 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -731,13 +731,11 @@ Perl_utf8_length(pTHX_ const U8 *s, const U8 *e)
     if (e != s) {
        len--;
         warn_and_return:
-       if (ckWARN_d(WARN_UTF8)) {
-           if (PL_op)
-               Perl_warner(aTHX_ packWARN(WARN_UTF8),
-                           "%s in %s", unees, OP_DESC(PL_op));
-           else
-               Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
-       }
+       if (PL_op)
+           Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8),
+                            "%s in %s", unees, OP_DESC(PL_op));
+       else
+           Perl_ck_warner_d(aTHX_ packWARN(WARN_UTF8), unees);
     }
 
     return len;

diff --git a/util.c b/util.c
index 2018540..94820ef 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1529,6 +1529,19 @@ Perl_warner_nocontext(U32 err, const char *pat, ...)
 #endif /* PERL_IMPLICIT_CONTEXT */
 
 void
+Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...)
+{
+    PERL_ARGS_ASSERT_CK_WARNER_D;
+
+    if (Perl_ckwarn_d(aTHX_ err)) {
+       va_list args;
+       va_start(args, pat);
+       vwarner(err, pat, &args);
+       va_end(args);
+    }
+}
+
+void
 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
 {
     PERL_ARGS_ASSERT_CK_WARNER;