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