From 9873cdeb590607e077a3234f8bdf0321efec1cdd Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Mon, 4 Dec 2023 08:44:15 +1100 Subject: [PATCH] allow "used only once" warnings to be fatal "used only once" warnings are special, instead of being emitted at the code where the name in question is used, they are emitted during a scan of the symbol table done after parsing has finished. This meant that any FATAL flags set in the COP for the parse point of the name is no longer in scope, so the warnings we emit can't be treated as fatal. To make them behave as FATAL set a new flag on the name if fatal WARN_ONCE warnings are enabled and use that to dispatch the warnings as normal or fatally when we do the symbol table scan. I originally approached the dispatch as fatal or non-fatal by messing around with cop_warnings, but that was dumb, and I went for a much simpler change. Fixes #13814 --- embed.fnc | 6 ++++++ embed.h | 2 ++ gv.c | 31 ++++++++++++++++++++++--------- gv.h | 6 ++++++ proto.h | 11 +++++++++++ t/lib/warnings/gv | 8 ++++++++ util.c | 39 ++++++++++++++++++++++++++++++--------- 7 files changed, 85 insertions(+), 18 deletions(-) diff --git a/embed.fnc b/embed.fnc index 6b15455aba78a..ee57637bc0f68 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1119,6 +1119,9 @@ AOdp |SV * |eval_pv |NN const char *p \ |I32 croak_on_error AOdp |SSize_t|eval_sv |NN SV *sv \ |I32 flags +Adfpv |void |fatal_warner |U32 err \ + |NN const char *pat \ + |... Adp |void |fbm_compile |NN SV *sv \ |U32 flags ARdp |char * |fbm_instr |NN unsigned char *big \ @@ -3704,6 +3707,9 @@ Adpr |void |vcroak |NULLOK const char *pat \ |NULLOK va_list *args Adp |void |vdeb |NN const char *pat \ |NULLOK va_list *args +Adp |void |vfatal_warner |U32 err \ + |NN const char *pat \ + |NULLOK va_list *args Adp |char * |vform |NN const char *pat \ |NULLOK va_list *args : Used by Data::Alias diff --git a/embed.h b/embed.h index e42004da21b97..ce3050ae28d35 100644 --- a/embed.h +++ b/embed.h @@ -793,6 +793,7 @@ # define vcmp(a,b) Perl_vcmp(aTHX_ a,b) # define vcroak(a,b) Perl_vcroak(aTHX_ a,b) # define vdeb(a,b) Perl_vdeb(aTHX_ a,b) +# define vfatal_warner(a,b,c) Perl_vfatal_warner(aTHX_ a,b,c) # define vform(a,b) Perl_vform(aTHX_ a,b) # define vload_module(a,b,c,d) Perl_vload_module(aTHX_ a,b,c,d) # define vmess(a,b) Perl_vmess(aTHX_ a,b) @@ -859,6 +860,7 @@ # define deb(...) Perl_deb(aTHX_ __VA_ARGS__) # define die(...) Perl_die(aTHX_ __VA_ARGS__) # define dump_indent(a,b,...) Perl_dump_indent(aTHX_ a,b,__VA_ARGS__) +# define fatal_warner(a,...) Perl_fatal_warner(aTHX_ a,__VA_ARGS__) # define form(...) Perl_form(aTHX_ __VA_ARGS__) # define load_module(a,b,...) Perl_load_module(aTHX_ a,b,__VA_ARGS__) # define mess(...) Perl_mess(aTHX_ __VA_ARGS__) diff --git a/gv.c b/gv.c index 93fc37da63a56..00992a1783fcb 100644 --- a/gv.c +++ b/gv.c @@ -2685,10 +2685,14 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, gv_init_pvn(gv, stash, name, len, (add & GV_ADDMULTI)|is_utf8); if ( full_len != 0 - && isIDFIRST_lazy_if_safe(name, name + full_len, is_utf8) - && !ckWARN(WARN_ONCE) ) - { - GvMULTI_on(gv) ; + && isIDFIRST_lazy_if_safe(name, name + full_len, is_utf8)) { + if (ckWARN(WARN_ONCE)) { + if (ckDEAD(WARN_ONCE)) + GvONCE_FATAL_on(gv); + } + else { + GvMULTI_on(gv) ; + } } /* set up magic where warranted */ @@ -2819,11 +2823,20 @@ Perl_gv_check(pTHX_ HV *stash) CopFILEGV(PL_curcop) = gv_fetchfile_flags(file, HEK_LEN(GvFILE_HEK(gv)), 0); #endif - Perl_warner(aTHX_ packWARN(WARN_ONCE), - "Name \"%" HEKf "::%" HEKf - "\" used only once: possible typo", - HEKfARG(HvNAME_HEK(stash)), - HEKfARG(GvNAME_HEK(gv))); + if (GvONCE_FATAL(gv)) { + Perl_fatal_warner(aTHX_ packWARN(WARN_ONCE), + "Name \"%" HEKf "::%" HEKf + "\" used only once: possible typo", + HEKfARG(HvNAME_HEK(stash)), + HEKfARG(GvNAME_HEK(gv))); + } + else { + Perl_warner(aTHX_ packWARN(WARN_ONCE), + "Name \"%" HEKf "::%" HEKf + "\" used only once: possible typo", + HEKfARG(HvNAME_HEK(stash)), + HEKfARG(GvNAME_HEK(gv))); + } } } } diff --git a/gv.h b/gv.h index 68865b99916d6..f26356d4d6ebd 100644 --- a/gv.h +++ b/gv.h @@ -168,6 +168,7 @@ Return the CV from the GV. #define GVf_IMPORTED_AV 0x20 #define GVf_IMPORTED_HV 0x40 #define GVf_IMPORTED_CV 0x80 +#define GVf_ONCE_FATAL 0x100 #define GvINTRO(gv) (GvFLAGS(gv) & GVf_INTRO) #define GvINTRO_on(gv) (GvFLAGS(gv) |= GVf_INTRO) @@ -201,6 +202,11 @@ Return the CV from the GV. #define GvIMPORTED_CV_on(gv) (GvFLAGS(gv) |= GVf_IMPORTED_CV) #define GvIMPORTED_CV_off(gv) (GvFLAGS(gv) &= ~GVf_IMPORTED_CV) +/* set if WARN_ONCE warnings are fatal when we see this name */ +#define GvONCE_FATAL(gv) (GvFLAGS(gv) & GVf_ONCE_FATAL) +#define GvONCE_FATAL_on(gv) (GvFLAGS(gv) |= GVf_ONCE_FATAL) +#define GvONCE_FATAL_off(gv) (GvFLAGS(gv) &= ~GVf_ONCE_FATAL) + #ifndef PERL_CORE # define GvIN_PAD(gv) 0 # define GvIN_PAD_on(gv) NOOP diff --git a/proto.h b/proto.h index 3ebd419b487a1..13847e0023d80 100644 --- a/proto.h +++ b/proto.h @@ -1097,6 +1097,12 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags); #define PERL_ARGS_ASSERT_EVAL_SV \ assert(sv) +PERL_CALLCONV void +Perl_fatal_warner(pTHX_ U32 err, const char *pat, ...) + __attribute__format__(__printf__,pTHX_2,pTHX_3); +#define PERL_ARGS_ASSERT_FATAL_WARNER \ + assert(pat) + PERL_CALLCONV void Perl_fbm_compile(pTHX_ SV *sv, U32 flags); #define PERL_ARGS_ASSERT_FBM_COMPILE \ @@ -5180,6 +5186,11 @@ Perl_vdeb(pTHX_ const char *pat, va_list *args); #define PERL_ARGS_ASSERT_VDEB \ assert(pat) +PERL_CALLCONV void +Perl_vfatal_warner(pTHX_ U32 err, const char *pat, va_list *args); +#define PERL_ARGS_ASSERT_VFATAL_WARNER \ + assert(pat) + PERL_CALLCONV char * Perl_vform(pTHX_ const char *pat, va_list *args); #define PERL_ARGS_ASSERT_VFORM \ diff --git a/t/lib/warnings/gv b/t/lib/warnings/gv index 4a8c9aabd82e9..d0a8e0cb1963b 100644 --- a/t/lib/warnings/gv +++ b/t/lib/warnings/gv @@ -299,3 +299,11 @@ no strict; my $x = $i; EXPECT Name "main::i" used only once: possible typo at - line 4. +######## +# https://github.com/Perl/perl5/issues/13814 +use warnings FATAL => qw(once); +print @Foo::bar, "\n"; +print "still alive\n"; +EXPECT +OPTION fatal +Name "Foo::bar" used only once: possible typo at - line 3. diff --git a/util.c b/util.c index 3830f472665cf..eef18d3f06d2f 100644 --- a/util.c +++ b/util.c @@ -2195,21 +2195,42 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) && !(PL_in_eval & EVAL_KEEPERR) ) { - SV * const msv = vmess(pat, args); - - if (PL_parser && PL_parser->error_count) { - qerror(msv); - } - else { - invoke_exception_hook(msv, FALSE); - die_unwind(msv); - } + vfatal_warner(err, pat, args); } else { Perl_vwarn(aTHX_ pat, args); } } +void +Perl_fatal_warner(pTHX_ U32 err, const char *pat, ...) +{ + PERL_ARGS_ASSERT_FATAL_WARNER; + + va_list args; + va_start(args, pat); + vfatal_warner(err, pat, &args); + va_end(args); +} + +void +Perl_vfatal_warner(pTHX_ U32 err, const char *pat, va_list *args) +{ + PERL_ARGS_ASSERT_VFATAL_WARNER; + + PERL_UNUSED_ARG(err); + + SV * const msv = vmess(pat, args); + + if (PL_parser && PL_parser->error_count) { + qerror(msv); + } + else { + invoke_exception_hook(msv, FALSE); + die_unwind(msv); + } +} + /* implements the ckWARN? macros */ bool