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 Perl#13814
tonycoz · Dec 5, 2023 · 9873cde · 9873cde
1 parent 20b9297
commit 9873cde
Show file tree

Hide file tree

Showing 7 changed files with 85 additions and 18 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
diff --git 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
@@ -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