diff options
| -rw-r--r-- | doop.c | 15 | ||||
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 1 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | gv.c | 12 | ||||
| -rw-r--r-- | mg.c | 20 | ||||
| -rw-r--r-- | numeric.c | 31 | ||||
| -rw-r--r-- | op.c | 117 | ||||
| -rw-r--r-- | pad.c | 16 | ||||
| -rw-r--r-- | perl.c | 5 | ||||
| -rw-r--r-- | perlio.c | 23 | ||||
| -rw-r--r-- | pp.c | 29 | ||||
| -rw-r--r-- | pp_ctl.c | 22 | ||||
| -rw-r--r-- | pp_hot.c | 10 | ||||
| -rw-r--r-- | pp_pack.c | 58 | ||||
| -rw-r--r-- | pp_sys.c | 73 | ||||
| -rw-r--r-- | proto.h | 6 | ||||
| -rw-r--r-- | sv.c | 24 | ||||
| -rw-r--r-- | toke.c | 135 | ||||
| -rw-r--r-- | util.c | 36 |
20 files changed, 291 insertions, 344 deletions
@@ -807,9 +807,8 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) } #ifdef UV_IS_QUAD else if (size == 64) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ packWARN(WARN_PORTABLE), - "Bit vector size > 32 non-portable"); + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Bit vector size > 32 non-portable"); if (uoffset >= srclen) retnum = 0; else if (uoffset + 1 >= srclen) @@ -875,9 +874,8 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size) s[uoffset + 3]; #ifdef UV_IS_QUAD else if (size == 64) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ packWARN(WARN_PORTABLE), - "Bit vector size > 32 non-portable"); + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Bit vector size > 32 non-portable"); retnum = ((UV) s[uoffset ] << 56) + ((UV) s[uoffset + 1] << 48) + @@ -968,9 +966,8 @@ Perl_do_vecset(pTHX_ SV *sv) } #ifdef UV_IS_QUAD else if (size == 64) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ packWARN(WARN_PORTABLE), - "Bit vector size > 32 non-portable"); + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Bit vector size > 32 non-portable"); s[offset ] = (U8)((lval >> 56) & 0xff); s[offset+1] = (U8)((lval >> 48) & 0xff); s[offset+2] = (U8)((lval >> 40) & 0xff); @@ -1181,6 +1181,7 @@ XEpd |void |report_uninit |NULLOK const SV *uninit_sv 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|... Ap |void |vwarner |U32 err|NN const char* pat|NULLOK va_list* args : FIXME p |void |watch |NN char** addr @@ -1040,6 +1040,7 @@ #define warn Perl_warn #define vwarn Perl_vwarn #define warner Perl_warner +#define ck_warner Perl_ck_warner #define vwarner Perl_vwarner #ifdef PERL_CORE #define watch Perl_watch diff --git a/global.sym b/global.sym index 222ea71390..9bdcacbe09 100644 --- a/global.sym +++ b/global.sym @@ -613,6 +613,7 @@ Perl_report_uninit Perl_warn Perl_vwarn Perl_warner +Perl_ck_warner Perl_vwarner Perl_whichsig Perl_yylex @@ -413,9 +413,8 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) cstash = gv_stashsv(linear_sv, 0); if (!cstash) { - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", - SVfARG(linear_sv), hvname); + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA", + SVfARG(linear_sv), hvname); continue; } @@ -729,11 +728,10 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) * Inheriting AUTOLOAD for non-methods works ... for now. */ if (!method && (GvCVGEN(gv) || GvSTASH(gv) != stash) - && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) ) - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", - packname, (int)len, name); + Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", + packname, (int)len, name); if (CvISXSUB(cv)) { /* rather than lookup/init $AUTOLOAD here @@ -1428,8 +1428,8 @@ Perl_magic_setsig(pTHX_ SV *sv, MAGIC *mg) mg->mg_private = (U16)i; } if (i <= 0) { - if (sv && ckWARN(WARN_SIGNAL)) - Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s); + if (sv) + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "No such signal: SIG%s", s); return 0; } #ifdef HAS_SIGPROCMASK @@ -1880,9 +1880,8 @@ Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg) if (obj) { av_fill(obj, SvIV(sv) - CopARYBASE_get(PL_curcop)); } else { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Attempt to set length of freed array"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Attempt to set length of freed array"); } return 0; } @@ -2863,12 +2862,11 @@ Perl_sighandler(int sig) } if (!cv || !CvROOT(cv)) { - if (ckWARN(WARN_SIGNAL)) - Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n", - PL_sig_name[sig], (gv ? GvENAME(gv) - : ((cv && CvGV(cv)) - ? GvENAME(CvGV(cv)) - : "__ANON__"))); + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), "SIG%s handler \"%s\" not defined.\n", + PL_sig_name[sig], (gv ? GvENAME(gv) + : ((cv && CvGV(cv)) + ? GvENAME(CvGV(cv)) + : "__ANON__"))); goto cleanup; } @@ -199,9 +199,9 @@ Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) ++s; goto redo; } - if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ packWARN(WARN_DIGIT), - "Illegal binary digit '%c' ignored", *s); + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), + "Illegal binary digit '%c' ignored", *s); break; } @@ -210,9 +210,8 @@ Perl_grok_bin(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) || (!overflowed && value > 0xffffffff ) #endif ) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ packWARN(WARN_PORTABLE), - "Binary number > 0b11111111111111111111111111111111 non-portable"); + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Binary number > 0b11111111111111111111111111111111 non-portable"); } *len_p = s - start; if (!overflowed) { @@ -318,8 +317,8 @@ Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) ++s; goto redo; } - if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ packWARN(WARN_DIGIT), + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), "Illegal hexadecimal digit '%c' ignored", *s); break; } @@ -329,9 +328,8 @@ Perl_grok_hex(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) || (!overflowed && value > 0xffffffff ) #endif ) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ packWARN(WARN_PORTABLE), - "Hexadecimal number > 0xffffffff non-portable"); + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Hexadecimal number > 0xffffffff non-portable"); } *len_p = s - start; if (!overflowed) { @@ -424,9 +422,9 @@ Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) * as soon as non-octal characters are seen, complain only if * someone seems to want to use the digits eight and nine). */ if (digit == 8 || digit == 9) { - if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT) && ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ packWARN(WARN_DIGIT), - "Illegal octal digit '%c' ignored", *s); + if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT)) + Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT), + "Illegal octal digit '%c' ignored", *s); } break; } @@ -436,9 +434,8 @@ Perl_grok_oct(pTHX_ const char *start, STRLEN *len_p, I32 *flags, NV *result) || (!overflowed && value > 0xffffffff ) #endif ) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ packWARN(WARN_PORTABLE), - "Octal number > 037777777777 non-portable"); + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "Octal number > 037777777777 non-portable"); } *len_p = s - start; if (!overflowed) { @@ -908,8 +908,7 @@ Perl_scalar(pTHX_ OP *o) PL_curcop = &PL_compiling; break; case OP_SORT: - if (ckWARN(WARN_VOID)) - Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); break; } return o; @@ -1188,8 +1187,8 @@ Perl_scalarvoid(pTHX_ OP *o) case OP_SCALAR: return scalar(o); } - if (useless && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless); + if (useless) + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless); return o; } @@ -1667,10 +1666,8 @@ Perl_mod(pTHX_ OP *o, I32 type) case 0: break; case -1: - if (ckWARN(WARN_SYNTAX)) { - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Useless localization of %s", OP_DESC(o)); - } + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Useless localization of %s", OP_DESC(o)); } } else if (type != OP_GREPSTART && type != OP_ENTERSUB @@ -3432,12 +3429,10 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } } - if(ckWARN(WARN_MISC)) { - if(del && rlen == tlen) { - Perl_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); - } else if(rlen > tlen) { - Perl_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); - } + if(del && rlen == tlen) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); + } else if(rlen > tlen) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list"); } if (grows) @@ -4543,8 +4538,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if ((cstop = search_const(first))) { if (cstop->op_private & OPpCONST_STRICT) no_bareword_allowed(cstop); - else if ((cstop->op_private & OPpCONST_BARE) && ckWARN(WARN_BAREWORD)) - Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); + else if ((cstop->op_private & OPpCONST_BARE)) + Perl_ck_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional"); if ((type == OP_AND && SvTRUE(((SVOP*)cstop)->op_sv)) || (type == OP_OR && !SvTRUE(((SVOP*)cstop)->op_sv)) || (type == OP_DOR && !SvOK(((SVOP*)cstop)->op_sv))) { @@ -4574,11 +4569,10 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV || o2->op_type == OP_PADHV) && o2->op_private & OPpLVAL_INTRO - && !(o2->op_private & OPpPAD_STATE) - && ckWARN(WARN_DEPRECATED)) + && !(o2->op_private & OPpPAD_STATE)) { - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), - "Deprecated use of my() in false conditional"); + Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), + "Deprecated use of my() in false conditional"); } *otherp = NULL; @@ -5901,18 +5895,18 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, return; } else if (*name == 'C') { if (strEQ(name, "CHECK")) { - if (PL_main_start && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ packWARN(WARN_VOID), - "Too late to run CHECK block"); + if (PL_main_start) + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run CHECK block"); Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv)); } else return; } else if (*name == 'I') { if (strEQ(name, "INIT")) { - if (PL_main_start && ckWARN(WARN_VOID)) - Perl_warner(aTHX_ packWARN(WARN_VOID), - "Too late to run INIT block"); + if (PL_main_start) + Perl_ck_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run INIT block"); Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv)); } else @@ -6273,10 +6267,9 @@ Perl_newAVREF(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_PADAV]; return o; } - else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV) - && ckWARN(WARN_DEPRECATED)) { - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), - "Using an array as a reference is deprecated"); + else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) { + Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), + "Using an array as a reference is deprecated"); } return newUNOP(OP_RV2AV, 0, scalar(o)); } @@ -6301,10 +6294,9 @@ Perl_newHVREF(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_PADHV]; return o; } - else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV) - && ckWARN(WARN_DEPRECATED)) { - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), - "Using a hash as a reference is deprecated"); + else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) { + Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), + "Using a hash as a reference is deprecated"); } return newUNOP(OP_RV2HV, 0, scalar(o)); } @@ -6371,12 +6363,11 @@ Perl_ck_bitop(pTHX_ OP *o) (left->op_flags & OPf_PARENS) == 0) || (OP_IS_NUMCOMPARE(right->op_type) && (right->op_flags & OPf_PARENS) == 0)) - if (ckWARN(WARN_PRECEDENCE)) - Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE), - "Possible precedence problem on bitwise %c operator", - o->op_type == OP_BIT_OR ? '|' - : o->op_type == OP_BIT_AND ? '&' : '^' - ); + Perl_ck_warner(aTHX_ packWARN(WARN_PRECEDENCE), + "Possible precedence problem on bitwise %c operator", + o->op_type == OP_BIT_OR ? '|' + : o->op_type == OP_BIT_AND ? '&' : '^' + ); } return o; } @@ -6847,20 +6838,19 @@ Perl_ck_fun(pTHX_ OP *o) break; case OA_AVREF: if ((type == OP_PUSH || type == OP_UNSHIFT) - && !kid->op_sibling && ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Useless use of %s with no values", - PL_op_desc[type]); + && !kid->op_sibling) + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Useless use of %s with no values", + PL_op_desc[type]); if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) { OP * const newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) )); - if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", - SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); + Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", + SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); #ifdef PERL_MAD op_getmad(kid,newop,'K'); #else @@ -6880,10 +6870,9 @@ Perl_ck_fun(pTHX_ OP *o) { OP * const newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) )); - if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", - SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); + Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", + SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); #ifdef PERL_MAD op_getmad(kid,newop,'K'); #else @@ -7219,7 +7208,7 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ { PERL_ARGS_ASSERT_CK_DEFINED; - if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) { + if ((o->op_flags & OPf_KIDS)) { switch (cUNOPo->op_first->op_type) { case OP_RV2AV: /* This is needed for @@ -7229,10 +7218,10 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ break; /* Globals via GV can be undef */ case OP_PADAV: case OP_AASSIGN: /* Is this a good idea? */ - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "defined(@array) is deprecated"); - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "\t(Maybe you should just omit the defined()?)\n"); + Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + "defined(@array) is deprecated"); + Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + "\t(Maybe you should just omit the defined()?)\n"); break; case OP_RV2HV: /* This is needed for @@ -7241,10 +7230,10 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ */ break; /* Globals via GV can be undef */ case OP_PADHV: - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "defined(%%hash) is deprecated"); - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "\t(Maybe you should just omit the defined()?)\n"); + Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + "defined(%%hash) is deprecated"); + Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + "\t(Maybe you should just omit the defined()?)\n"); break; default: /* no warning */ @@ -7887,9 +7876,9 @@ Perl_ck_split(pTHX_ OP *o) kid->op_type = OP_PUSHRE; kid->op_ppaddr = PL_ppaddr[OP_PUSHRE]; scalar(kid); - if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL && ckWARN(WARN_REGEXP)) { - Perl_warner(aTHX_ packWARN(WARN_REGEXP), - "Use of /g modifier is meaningless in split"); + if (((PMOP *)kid)->op_pmflags & PMf_GLOBAL) { + Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), + "Use of /g modifier is meaningless in split"); } if (!kid->op_sibling) @@ -781,9 +781,9 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, ? CvANON(cv) && CvCLONE(cv) && !CvCLONED(cv) : *out_flags & PAD_FAKELEX_ANON) { - if (warn && ckWARN(WARN_CLOSURE)) - Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" is not available", name); + if (warn) + Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), + "Variable \"%s\" is not available", name); *out_capture = NULL; } @@ -823,9 +823,8 @@ S_pad_findlex(pTHX_ const char *name, const CV* cv, U32 seq, int warn, if (SvPADSTALE(*out_capture) && !SvPAD_STATE(name_svp[offset])) { - if (ckWARN(WARN_CLOSURE)) - Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" is not available", name); + Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), + "Variable \"%s\" is not available", name); *out_capture = NULL; } } @@ -1527,9 +1526,8 @@ Perl_cv_clone(pTHX_ CV *proto) while my $x if $false can leave an active var marked as stale. And state vars are always available */ if (SvPADSTALE(sv) && !SvPAD_STATE(namesv)) { - if (ckWARN(WARN_CLOSURE)) - Perl_warner(aTHX_ packWARN(WARN_CLOSURE), - "Variable \"%s\" is not available", SvPVX_const(namesv)); + Perl_ck_warner(aTHX_ packWARN(WARN_CLOSURE), + "Variable \"%s\" is not available", SvPVX_const(namesv)); sv = NULL; } else @@ -1996,9 +1996,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # endif Sighandler_t sigstate = rsignal_state(SIGCHLD); if (sigstate == (Sighandler_t) SIG_IGN) { - if (ckWARN(WARN_SIGNAL)) - Perl_warner(aTHX_ packWARN(WARN_SIGNAL), - "Can't ignore signal CHLD, forcing to default"); + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), + "Can't ignore signal CHLD, forcing to default"); (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); } } @@ -981,10 +981,9 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) * seen as an invalid separator character. */ const char q = ((*s == '\'') ? '"' : '\''); - if (ckWARN(WARN_LAYER)) - Perl_warner(aTHX_ packWARN(WARN_LAYER), - "Invalid separator character %c%c%c in PerlIO layer specification %s", - q, *s, q, s); + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), + "Invalid separator character %c%c%c in PerlIO layer specification %s", + q, *s, q, s); SETERRNO(EINVAL, LIB_INVARG); return -1; } @@ -1018,10 +1017,9 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) */ case '\0': e--; - if (ckWARN(WARN_LAYER)) - Perl_warner(aTHX_ packWARN(WARN_LAYER), - "Argument list not closed for PerlIO layer \"%.*s\"", - (int) (e - s), s); + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), + "Argument list not closed for PerlIO layer \"%.*s\"", + (int) (e - s), s); return -1; default: /* @@ -1044,9 +1042,8 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) SvREFCNT_dec(arg); } else { - if (ckWARN(WARN_LAYER)) - Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"", - (int) llen, s); + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"", + (int) llen, s); return -1; } } @@ -1460,8 +1457,8 @@ PerlIO_layer_from_ref(pTHX_ SV *sv) PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1); /* This isn't supposed to happen, since PerlIO::scalar is core, * but could happen anyway in smaller installs or with PAR */ - if (!f && ckWARN(WARN_LAYER)) - Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\""); + if (!f) + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\""); return f; } @@ -576,9 +576,9 @@ PP(pp_bless) if (ssv && !SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv)) Perl_croak(aTHX_ "Attempt to bless into a reference"); ptr = SvPV_const(ssv,len); - if (len == 0 && ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Explicit blessing to '' (assuming package main)"); + if (len == 0) + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Explicit blessing to '' (assuming package main)"); stash = gv_stashpvn(ptr, len, GV_ADD); } @@ -813,10 +813,10 @@ PP(pp_undef) hv_undef(MUTABLE_HV(sv)); break; case SVt_PVCV: - if (cv_const_sv((const CV *)sv) && ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined", - CvANON((const CV *)sv) ? "(anonymous)" - : GvENAME(CvGV((const CV *)sv))); + if (cv_const_sv((const CV *)sv)) + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined", + CvANON((const CV *)sv) ? "(anonymous)" + : GvENAME(CvGV((const CV *)sv))); /* FALLTHROUGH */ case SVt_PVFM: { @@ -3148,8 +3148,7 @@ PP(pp_substr) if (fail < 0) { if (lvalue || repl) Perl_croak(aTHX_ "substr outside of string"); - if (ckWARN(WARN_SUBSTR)) - Perl_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); + Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); RETPUSHUNDEF; } else { @@ -3198,9 +3197,8 @@ PP(pp_substr) if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { SvPV_force_nolen(sv); - if (ckWARN(WARN_SUBSTR)) - Perl_warner(aTHX_ packWARN(WARN_SUBSTR), - "Attempt to use reference as lvalue in substr"); + Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), + "Attempt to use reference as lvalue in substr"); } if (isGV_with_GP(sv)) SvPV_force_nolen(sv); @@ -4491,8 +4489,8 @@ PP(pp_anonhash) SV * const val = newSV(0); if (MARK < SP) sv_setsv(val, *++MARK); - else if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash"); + else + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Odd number of elements in anonymous hash"); (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; @@ -4552,8 +4550,7 @@ PP(pp_splice) length = AvMAX(ary) + 1; } if (offset > AvFILLp(ary) + 1) { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" ); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "splice() offset past end of array" ); offset = AvFILLp(ary) + 1; } after = AvFILLp(ary) + 1 - (offset + length); @@ -535,8 +535,7 @@ PP(pp_formline) sv = *++MARK; else { sv = &PL_sv_no; - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments"); + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments"); } break; @@ -1283,9 +1282,8 @@ S_dopoptolabel(pTHX_ const char *label) case CXt_FORMAT: case CXt_EVAL: case CXt_NULL: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", - context_name[CxTYPE(cx)], OP_NAME(PL_op)); + Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", + context_name[CxTYPE(cx)], OP_NAME(PL_op)); if (CxTYPE(cx) == CXt_NULL) return -1; break; @@ -1404,9 +1402,8 @@ S_dopoptoloop(pTHX_ I32 startingblock) case CXt_FORMAT: case CXt_EVAL: case CXt_NULL: - if (ckWARN(WARN_EXITING)) - Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", - context_name[CxTYPE(cx)], OP_NAME(PL_op)); + Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", + context_name[CxTYPE(cx)], OP_NAME(PL_op)); if ((CxTYPE(cx)) == CXt_NULL) return -1; break; @@ -1548,14 +1545,13 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) e = NULL; } if (!e) { + STRLEN start; SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen); sv_catpvn(err, prefix, sizeof(prefix)-1); sv_catpvn(err, message, msglen); - if (ckWARN(WARN_MISC)) { - const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; - Perl_warner(aTHX_ packWARN(WARN_MISC), "%s", - SvPVX_const(err)+start); - } + start = SvCUR(err)-msglen-sizeof(prefix)+1; + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s", + SvPVX_const(err)+start); } } else { @@ -1675,11 +1675,11 @@ Perl_do_readline(pTHX) (void)do_close(PL_last_in_gv, FALSE); } else if (type == OP_GLOB) { - if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) { - Perl_warner(aTHX_ packWARN(WARN_GLOB), - "glob failed (child exited with status %d%s)", - (int)(STATUS_CURRENT >> 8), - (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); + if (!do_close(PL_last_in_gv, FALSE)) { + Perl_ck_warner(aTHX_ packWARN(WARN_GLOB), + "glob failed (child exited with status %d%s)", + (int)(STATUS_CURRENT >> 8), + (STATUS_CURRENT & 0x80) ? ", core dumped" : ""); } } if (gimme == G_SCALAR) { @@ -630,10 +630,9 @@ uni_to_byte(pTHX_ const char **s, const char *end, I32 datumtype) Perl_croak(aTHX_ "Malformed UTF-8 string in '%c' format in unpack", (int) TYPE_NO_MODIFIERS(datumtype)); if (val >= 0x100) { - if (ckWARN(WARN_UNPACK)) - Perl_warner(aTHX_ packWARN(WARN_UNPACK), - "Character in '%c' format wrapped in unpack", - (int) TYPE_NO_MODIFIERS(datumtype)); + Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK), + "Character in '%c' format wrapped in unpack", + (int) TYPE_NO_MODIFIERS(datumtype)); val &= 0xff; } *s += retlen; @@ -678,13 +677,12 @@ uni_to_bytes(pTHX_ const char **s, const char *end, const char *buf, int buf_len } if (from > end) from = end; } - if ((bad & 2) && ((datumtype & TYPE_IS_PACK) - ? ckWARN(WARN_PACK) : ckWARN(WARN_UNPACK))) - Perl_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ? + if ((bad & 2)) + Perl_ck_warner(aTHX_ packWARN(datumtype & TYPE_IS_PACK ? WARN_PACK : WARN_UNPACK), - "Character(s) in '%c' format wrapped in %s", - (int) TYPE_NO_MODIFIERS(datumtype), - datumtype & TYPE_IS_PACK ? "pack" : "unpack"); + "Character(s) in '%c' format wrapped in %s", + (int) TYPE_NO_MODIFIERS(datumtype), + datumtype & TYPE_IS_PACK ? "pack" : "unpack"); } *s = from; return TRUE; @@ -1040,11 +1038,11 @@ S_next_symbol(pTHX_ tempsym_t* symptr ) Perl_croak(aTHX_ "Can't use '%c' in a group with different byte-order in %s", *patptr, _action( symptr ) ); - if ((code & modifier) && ckWARN(WARN_UNPACK)) { - Perl_warner(aTHX_ packWARN(WARN_UNPACK), - "Duplicate modifier '%c' after '%c' in %s", - *patptr, (int) TYPE_NO_MODIFIERS(code), - _action( symptr ) ); + if ((code & modifier)) { + Perl_ck_warner(aTHX_ packWARN(WARN_UNPACK), + "Duplicate modifier '%c' after '%c' in %s", + *patptr, (int) TYPE_NO_MODIFIERS(code), + _action( symptr ) ); } code |= modifier; @@ -2951,10 +2949,9 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) IV aiv; fromstr = NEXTFROM; aiv = SvIV(fromstr); - if ((-128 > aiv || aiv > 127) && - ckWARN(WARN_PACK)) - Perl_warner(aTHX_ packWARN(WARN_PACK), - "Character in 'c' format wrapped in pack"); + if ((-128 > aiv || aiv > 127)) + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Character in 'c' format wrapped in pack"); PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff)); } break; @@ -2967,10 +2964,9 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) IV aiv; fromstr = NEXTFROM; aiv = SvIV(fromstr); - if ((0 > aiv || aiv > 0xff) && - ckWARN(WARN_PACK)) - Perl_warner(aTHX_ packWARN(WARN_PACK), - "Character in 'C' format wrapped in pack"); + if ((0 > aiv || aiv > 0xff)) + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Character in 'C' format wrapped in pack"); PUSH_BYTE(utf8, cur, (U8)(aiv & 0xff)); } break; @@ -3012,9 +3008,8 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) end = start+SvLEN(cat)-UTF8_MAXLEN; goto W_utf8; } - if (ckWARN(WARN_PACK)) - Perl_warner(aTHX_ packWARN(WARN_PACK), - "Character in 'W' format wrapped in pack"); + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Character in 'W' format wrapped in pack"); auv &= 0xff; } if (cur >= end) { @@ -3501,9 +3496,9 @@ extern const double _double_constants[]; * gone. */ if ((SvTEMP(fromstr) || (SvPADTMP(fromstr) && - !SvREADONLY(fromstr))) && ckWARN(WARN_PACK)) { - Perl_warner(aTHX_ packWARN(WARN_PACK), - "Attempt to pack pointer to temporary value"); + !SvREADONLY(fromstr)))) { + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Attempt to pack pointer to temporary value"); } if (SvPOK(fromstr) || SvNIOK(fromstr)) aptr = SvPV_nomg_const_nolen(fromstr); @@ -3522,9 +3517,8 @@ extern const double _double_constants[]; if (len <= 2) len = 45; else len = len / 3 * 3; if (len >= 64) { - if (ckWARN(WARN_PACK)) - Perl_warner(aTHX_ packWARN(WARN_PACK), - "Field too wide in 'u' format in pack"); + Perl_ck_warner(aTHX_ packWARN(WARN_PACK), + "Field too wide in 'u' format in pack"); len = 63; } aptr = SvPV_const(fromstr, fromlen); @@ -521,9 +521,9 @@ PP(pp_open) MAGIC *mg; IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; - if (IoDIRP(io) && ckWARN2(WARN_IO, WARN_DEPRECATED)) - Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), - "Opening dirhandle %s also as a file", GvENAME(gv)); + if (IoDIRP(io)) + Perl_ck_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), + "Opening dirhandle %s also as a file", GvENAME(gv)); mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { @@ -892,10 +892,10 @@ PP(pp_untie) LEAVE; SPAGAIN; } - else if (mg && SvREFCNT(obj) > 1 && ckWARN(WARN_UNTIE)) { - Perl_warner(aTHX_ packWARN(WARN_UNTIE), - "untie attempted while %"UVuf" inner references still exist", - (UV)SvREFCNT(obj) - 1 ) ; + else if (mg && SvREFCNT(obj) > 1) { + Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE), + "untie attempted while %"UVuf" inner references still exist", + (UV)SvREFCNT(obj) - 1 ) ; } } } @@ -1018,8 +1018,7 @@ PP(pp_sselect) DIE(aTHX_ "%s", PL_no_modify); } if (!SvPOK(sv)) { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask"); SvPV_force_nolen(sv); /* force string conversion */ } j = SvCUR(sv); @@ -1417,8 +1416,7 @@ PP(pp_leavewrite) } else { if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) { - if (ckWARN(WARN_IO)) - Perl_warner(aTHX_ packWARN(WARN_IO), "page overflow"); + Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow"); } if (!do_print(PL_formtarget, fp)) PUSHs(&PL_sv_no); @@ -2822,9 +2820,8 @@ PP(pp_stat) if (PL_op->op_type == OP_LSTAT) { if (gv != PL_defgv) { do_fstat_warning_check: - if (ckWARN(WARN_IO)) - Perl_warner(aTHX_ packWARN(WARN_IO), - "lstat() on filehandle %s", gv ? GvENAME(gv) : ""); + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "lstat() on filehandle %s", gv ? GvENAME(gv) : ""); } else if (PL_laststype != OP_LSTAT) Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); } @@ -3831,9 +3828,9 @@ PP(pp_open_dir) if (!io) goto nope; - if ((IoIFP(io) || IoOFP(io)) && ckWARN2(WARN_IO, WARN_DEPRECATED)) - Perl_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), - "Opening filehandle %s also as a directory", GvENAME(gv)); + if ((IoIFP(io) || IoOFP(io))) + Perl_ck_warner(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), + "Opening filehandle %s also as a directory", GvENAME(gv)); if (IoDIRP(io)) PerlDir_close(IoDIRP(io)); if (!(IoDIRP(io) = PerlDir_open(dirname))) @@ -3867,10 +3864,8 @@ PP(pp_readdir) register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { - if(ckWARN(WARN_IO)) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "readdir() attempted on invalid dirhandle %s", GvENAME(gv)); - } + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "readdir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } @@ -3920,10 +3915,8 @@ PP(pp_telldir) register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { - if(ckWARN(WARN_IO)) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "telldir() attempted on invalid dirhandle %s", GvENAME(gv)); - } + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "telldir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } @@ -3947,10 +3940,8 @@ PP(pp_seekdir) register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { - if(ckWARN(WARN_IO)) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "seekdir() attempted on invalid dirhandle %s", GvENAME(gv)); - } + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "seekdir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } (void)PerlDir_seek(IoDIRP(io), along); @@ -3973,10 +3964,8 @@ PP(pp_rewinddir) register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { - if(ckWARN(WARN_IO)) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv)); - } + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "rewinddir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } (void)PerlDir_rewind(IoDIRP(io)); @@ -3998,10 +3987,8 @@ PP(pp_closedir) register IO * const io = GvIOn(gv); if (!io || !IoDIRP(io)) { - if(ckWARN(WARN_IO)) { - Perl_warner(aTHX_ packWARN(WARN_IO), - "closedir() attempted on invalid dirhandle %s", GvENAME(gv)); - } + Perl_ck_warner(aTHX_ packWARN(WARN_IO), + "closedir() attempted on invalid dirhandle %s", GvENAME(gv)); goto nope; } #ifdef VOID_CLOSEDIR @@ -4489,9 +4476,9 @@ PP(pp_gmtime) else { double input = Perl_floor(POPn); when = (Time64_T)input; - if (when != input && ckWARN(WARN_OVERFLOW)) { - Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), - "%s(%.0f) too large", opname, input); + if (when != input) { + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "%s(%.0f) too large", opname, input); } } @@ -4500,10 +4487,10 @@ PP(pp_gmtime) else err = S_gmtime64_r(&when, &tmbuf); - if (err == NULL && ckWARN(WARN_OVERFLOW)) { + if (err == NULL) { /* XXX %lld broken for quads */ - Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), - "%s(%.0f) failed", opname, (double)when); + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "%s(%.0f) failed", opname, (double)when); } if (GIMME != G_ARRAY) { /* scalar context */ @@ -3702,6 +3702,12 @@ PERL_CALLCONV void Perl_warner(pTHX_ U32 err, const char* pat, ...) #define PERL_ARGS_ASSERT_WARNER \ assert(pat) +PERL_CALLCONV void Perl_ck_warner(pTHX_ U32 err, const char* pat, ...) + __attribute__format__(__printf__,pTHX_2,pTHX_3) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_CK_WARNER \ + 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 \ @@ -4005,9 +4005,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) } else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) { if (!(sflags & SVf_OK)) { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Undefined value assigned to typeglob"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Undefined value assigned to typeglob"); } else { GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV); @@ -5239,8 +5238,7 @@ Perl_sv_rvweaken(pTHX_ SV *const sv) if (!SvROK(sv)) Perl_croak(aTHX_ "Can't weaken a nonreference"); else if (SvWEAKREF(sv)) { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak"); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak"); return sv; } tsv = SvRV(sv); @@ -7284,10 +7282,10 @@ Perl_sv_inc(pTHX_ register SV *const sv) if (flags & SVp_NOK) { const NV was = SvNVX(sv); if (NV_OVERFLOWS_INTEGERS_AT && - was >= NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) { - Perl_warner(aTHX_ packWARN(WARN_IMPRECISION), - "Lost precision when incrementing %" NVff " by 1", - was); + was >= NV_OVERFLOWS_INTEGERS_AT) { + Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), + "Lost precision when incrementing %" NVff " by 1", + was); } (void)SvNOK_only(sv); SvNV_set(sv, was + 1.0); @@ -7450,10 +7448,10 @@ Perl_sv_dec(pTHX_ register SV *const sv) { const NV was = SvNVX(sv); if (NV_OVERFLOWS_INTEGERS_AT && - was <= -NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) { - Perl_warner(aTHX_ packWARN(WARN_IMPRECISION), - "Lost precision when decrementing %" NVff " by 1", - was); + was <= -NV_OVERFLOWS_INTEGERS_AT) { + Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), + "Lost precision when decrementing %" NVff " by 1", + was); } (void)SvNOK_only(sv); SvNV_set(sv, was - 1.0); @@ -593,8 +593,7 @@ Perl_deprecate(pTHX_ const char *const s) { PERL_ARGS_ASSERT_DEPRECATE; - if (ckWARN(WARN_DEPRECATED)) - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s); + Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s); } static void @@ -610,9 +609,8 @@ S_deprecate_old(pTHX_ const char *const s) PERL_ARGS_ASSERT_DEPRECATE_OLD; - if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), - "Use of %s is deprecated", s); + Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), + "Use of %s is deprecated", s); } /* @@ -2193,9 +2191,9 @@ S_scan_const(pTHX_ char *start) if (!PL_lex_inpat) /* not a regexp, so $ must be var */ break; if (s + 1 < send && !strchr("()| \r\n\t", s[1])) { - if (s[1] == '\\' && ckWARN(WARN_AMBIGUOUS)) { - Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), - "Possible unintended interpolation of $\\ in regex"); + if (s[1] == '\\') { + Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), + "Possible unintended interpolation of $\\ in regex"); } break; /* in regexp, $ might be tail anchor */ } @@ -2211,8 +2209,7 @@ S_scan_const(pTHX_ char *start) if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat && isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) { - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s); + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s); *--s = '$'; break; } @@ -2240,11 +2237,10 @@ S_scan_const(pTHX_ char *start) /* FALL THROUGH */ default: { - if ((isALPHA(*s) || isDIGIT(*s)) && - ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Unrecognized escape \\%c passed through", - *s); + if ((isALPHA(*s) || isDIGIT(*s))) + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Unrecognized escape \\%c passed through", + *s); /* default action is to copy the quoted character */ goto default_action; } @@ -5190,9 +5186,9 @@ Perl_yylex(pTHX) case '\\': s++; - if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression", - *s, *s); + if (PL_lex_inwhat && isDIGIT(*s)) + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression", + *s, *s); if (PL_expect == XOPERATOR) no_op("Backslash",s); OPERATOR(REFGEN); @@ -5335,17 +5331,16 @@ Perl_yylex(pTHX) } else { /* no override */ tmp = -tmp; - if (tmp == KEY_dump && ckWARN(WARN_MISC)) { - Perl_warner(aTHX_ packWARN(WARN_MISC), - "dump() better written as CORE::dump()"); + if (tmp == KEY_dump) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "dump() better written as CORE::dump()"); } gv = NULL; gvp = 0; - if (hgv && tmp != KEY_x && tmp != KEY_CORE - && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */ - Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), - "Ambiguous call resolved as CORE::%s(), %s", - GvENAME(hgv), "qualify as such or use &"); + if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */ + Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), + "Ambiguous call resolved as CORE::%s(), %s", + GvENAME(hgv), "qualify as such or use &"); } } @@ -7175,13 +7170,12 @@ S_pending_ident(pTHX) /* DO NOT warn for @- and @+ */ && !( PL_tokenbuf[2] == '\0' && ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' )) - && ckWARN(WARN_AMBIGUOUS) ) { /* Downgraded from fatal to warning 20000522 mjd */ - Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), - "Possible unintended interpolation of %s in string", - PL_tokenbuf); + Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), + "Possible unintended interpolation of %s in string", + PL_tokenbuf); } } @@ -11048,11 +11042,10 @@ S_scan_pat(pTHX_ char *start, I32 type) } #endif /* issue a warning if /c is specified,but /g is not */ - if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL) - && ckWARN(WARN_REGEXP)) + if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)) { - Perl_warner(aTHX_ packWARN(WARN_REGEXP), - "Use of /c modifier is meaningless without /g" ); + Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), + "Use of /c modifier is meaningless without /g" ); } PL_lex_op = (OP*)pm; @@ -11134,8 +11127,8 @@ S_scan_subst(pTHX_ char *start) PL_thismad = 0; } #endif - if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) { - Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" ); + if ((pm->op_pmflags & PMf_CONTINUE)) { + Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" ); } if (es) { @@ -12147,8 +12140,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) } if (*s == '_') { - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); lastub = s++; } @@ -12171,9 +12163,9 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) /* _ are ignored -- but warned about if consecutive */ case '_': - if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + if (lastub && s == lastub + 1) + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Misplaced _ in number"); lastub = s++; break; @@ -12245,24 +12237,23 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) /* final misplaced underbar check */ if (s[-1] == '_') { - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); } sv = newSV(0); if (overflowed) { - if (n > 4294967295.0 && ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ packWARN(WARN_PORTABLE), - "%s number > %s non-portable", - Base, max); + if (n > 4294967295.0) + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "%s number > %s non-portable", + Base, max); sv_setnv(sv, n); } else { #if UVSIZE > 4 - if (u > 0xffffffff && ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ packWARN(WARN_PORTABLE), - "%s number > %s non-portable", - Base, max); + if (u > 0xffffffff) + Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE), + "%s number > %s non-portable", + Base, max); #endif sv_setuv(sv, u); } @@ -12291,9 +12282,9 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) if -w is on */ if (*s == '_') { - if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + if (lastub && s == lastub + 1) + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Misplaced _ in number"); lastub = s++; } else { @@ -12307,8 +12298,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) /* final misplaced underbar check */ if (lastub && s == lastub + 1) { - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number"); } /* read a decimal portion if there is one. avoid @@ -12320,9 +12310,8 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) *d++ = *s++; if (*s == '_') { - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Misplaced _ in number"); lastub = s; } @@ -12333,9 +12322,9 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) if (d >= e) Perl_croak(aTHX_ number_too_long); if (*s == '_') { - if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + if (lastub && s == lastub + 1) + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Misplaced _ in number"); lastub = s; } else @@ -12343,9 +12332,8 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) } /* fractional part ending in underbar? */ if (s[-1] == '_') { - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Misplaced _ in number"); } if (*s == '.' && isDIGIT(s[1])) { /* oops, it's really a v-string, but without the "v" */ @@ -12364,9 +12352,8 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) /* stray preinitial _ */ if (*s == '_') { - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Misplaced _ in number"); lastub = s++; } @@ -12376,9 +12363,8 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) /* stray initial _ */ if (*s == '_') { - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Misplaced _ in number"); lastub = s++; } @@ -12391,10 +12377,9 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) } else { if (((lastub && s == lastub + 1) || - (!isDIGIT(s[1]) && s[1] != '_')) - && ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Misplaced _ in number"); + (!isDIGIT(s[1]) && s[1] != '_'))) + Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), + "Misplaced _ in number"); lastub = s++; } } @@ -1529,6 +1529,19 @@ Perl_warner_nocontext(U32 err, const char *pat, ...) #endif /* PERL_IMPLICIT_CONTEXT */ void +Perl_ck_warner(pTHX_ U32 err, const char* pat, ...) +{ + PERL_ARGS_ASSERT_CK_WARNER; + + if (Perl_ckwarn(aTHX_ err)) { + va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); + } +} + +void Perl_warner(pTHX_ U32 err, const char* pat,...) { va_list args; @@ -2275,8 +2288,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) } return NULL; } - if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); + Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); sleep(5); } if (pid == 0) { @@ -2423,8 +2435,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno)); return NULL; } - if (ckWARN(WARN_PIPE)) - Perl_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); + Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); sleep(5); } if (pid == 0) { @@ -4295,9 +4306,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) mult /= 10; if ( (PERL_ABS(orev) > PERL_ABS(rev)) || (PERL_ABS(rev) > VERSION_MAX )) { - if(ckWARN(WARN_OVERFLOW)) - Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in version %d",VERSION_MAX); + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in version %d",VERSION_MAX); s = end - 1; rev = VERSION_MAX; vinf = 1; @@ -4314,9 +4324,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) mult *= 10; if ( (PERL_ABS(orev) > PERL_ABS(rev)) || (PERL_ABS(rev) > VERSION_MAX )) { - if(ckWARN(WARN_OVERFLOW)) - Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in version"); + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in version"); end = s - 1; rev = VERSION_MAX; vinf = 1; @@ -4564,10 +4573,9 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) s = scan_version(version, ver, qv); if ( *s != '\0' ) - if(ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Version string '%s' contains invalid data; " - "ignoring: '%s'", version, s); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Version string '%s' contains invalid data; " + "ignoring: '%s'", version, s); Safefree(version); return ver; } |