Add cop_*_warning() API

This adds three new API functions: a pair to modify a COP by enabling or
disabling a single warning bit within it, and a query function to ask if
a given warning is already enabled.

This API is provided for CPAN modules to use to modify the set of
warnings present in a COP during compile-time. Currently modules need to
use the `new_warnings_bitfield()` function, which was recently hidden by
09a0707. That change broke the `Syntax::Keyword::Try` module, as
reported in #23609.

Author: leonerd

MANIFEST

@@ -5100,6 +5100,7 @@ ext/XS-APItest/t/callregexec.t			XS::APItest: tests for CALLREGEXEC()
 ext/XS-APItest/t/check_warnings.t		test scope of "Too late for CHECK"
 ext/XS-APItest/t/cleanup.t			test stack behaviour on unwinding
 ext/XS-APItest/t/clone-with-stack.t		test clone with CLONEf_COPY_STACKS works
+ext/XS-APItest/t/cop_warnings.t			test cop_*_warning
 ext/XS-APItest/t/cophh.t			test COPHH API
 ext/XS-APItest/t/coplabel.t			test cop_*_label
 ext/XS-APItest/t/copstash.t			test alloccopstash

embed.fnc

@@ -898,10 +898,18 @@ Rp	|OP *	|cmpchain_start |I32 type				\
 				|NULLOK OP *right
 ERTXp	|const char *|cntrl_to_mnemonic 				\
 				|const U8 c
+Adp	|void	|cop_disable_warning					\
+				|NN COP *cop				\
+				|int warn_bit
+Adp	|void	|cop_enable_warning					\
+				|NN COP *cop				\
+				|int warn_bit
 Adpx	|const char *|cop_fetch_label					\
 				|NN COP * const cop			\
 				|NULLOK STRLEN *len			\
 				|NULLOK U32 *flags
+Adp	|bool	|cop_has_warning|NN const COP *cop			\
+				|int warn_bit
 : Only used  in op.c and the perl compiler
 Adpx	|void	|cop_store_label|NN COP * const cop			\
 				|NN const char *label			\

embed.h

@@ -167,7 +167,10 @@
 # define ck_warner_d(a,...)                     Perl_ck_warner_d(aTHX_ a,__VA_ARGS__)
 # define clear_defarray(a,b)                    Perl_clear_defarray(aTHX_ a,b)
 # define clear_defarray_simple(a)               Perl_clear_defarray_simple(aTHX_ a)
+# define cop_disable_warning(a,b)               Perl_cop_disable_warning(aTHX_ a,b)
+# define cop_enable_warning(a,b)                Perl_cop_enable_warning(aTHX_ a,b)
 # define cop_fetch_label(a,b,c)                 Perl_cop_fetch_label(aTHX_ a,b,c)
+# define cop_has_warning(a,b)                   Perl_cop_has_warning(aTHX_ a,b)
 # define cop_store_label(a,b,c,d)               Perl_cop_store_label(aTHX_ a,b,c,d)
 # define croak_memory_wrap                      Perl_croak_memory_wrap
 # define croak_no_modify                        Perl_croak_no_modify

ext/XS-APItest/APItest.pm

@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '1.46';
+our $VERSION = '1.47';
 
 require XSLoader;
 

ext/XS-APItest/APItest.xs

@@ -3884,6 +3884,25 @@ test_coplabel()
         if (len != 4) croak("fail # cop_fetch_label len");
         if (!utf8) croak("fail # cop_fetch_label utf8");
 
+void
+test_cop_warnings(bool already_on)
+    PREINIT:
+        COP *cop = PL_curcop;
+    CODE:
+        if(cop_has_warning(cop, WARN_UNINITIALIZED) ^ already_on)
+            croak("fail # cop_has_warning initial state");
+
+        /* This code modfies PL_curcop which is normally quite rude, but we'll
+         * allow it during the test run.
+         */
+        cop_enable_warning(cop, WARN_UNINITIALIZED);
+        if (!cop_has_warning(cop, WARN_UNINITIALIZED))
+            croak("fail # cop_enable_warning did not enable");
+
+        cop_disable_warning(cop, WARN_UNINITIALIZED);
+        if (cop_has_warning(cop, WARN_UNINITIALIZED))
+            croak("fail # cop_disable_warning did not disable");
+
 
 HV *
 example_cophh_2hv()

ext/XS-APItest/t/cop_warnings.t

@@ -0,0 +1,44 @@
+# no 'use warnings;' here so the first block sees defaults
+use strict;
+use Test::More tests => 6;
+
+use XS::APItest;
+
+{
+    local $^W = 0;
+    XS::APItest::test_cop_warnings(0);
+    ok 1, "standard warnings with \$^W = 0";
+}
+
+{
+    local $^W = 1;
+    XS::APItest::test_cop_warnings(1);
+    ok 2, "standard warnings with \$^W = 1";
+}
+
+{
+    use warnings;
+    XS::APItest::test_cop_warnings(1);
+    ok 3, "'use warnings'";
+}
+
+{
+    no warnings;
+    XS::APItest::test_cop_warnings(0);
+    ok 4, "'no warnings'";
+}
+{
+    no warnings;
+    use warnings qw( once );
+    XS::APItest::test_cop_warnings(0);
+    ok 5, "'no warnings' + other";
+}
+
+{
+    no warnings;
+    use warnings qw( uninitialized );
+    XS::APItest::test_cop_warnings(1);
+    ok 6, "'use warnings uninitialized'";
+}
+
+1;

op.c

@@ -9069,6 +9069,105 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
     return op_prepend_elem(OP_LINESEQ, (OP*)cop, o);
 }
 
+/*
+=for apidoc cop_has_warning
+
+Returns true if the set of warnings bits contained by (or implied by) the
+COP contains the given warning, as specified by one of the C<WARN_...>
+constants from F<warnings.h>.
+
+=cut
+*/
+
+bool
+Perl_cop_has_warning(pTHX_ const COP *cop, int warn_bit)
+{
+    PERL_ARGS_ASSERT_COP_HAS_WARNING;
+
+    const char *warning_bits = cop->cop_warnings;
+    if(warning_bits == pWARN_STD)
+        return (PL_dowarn & G_WARN_ON) ? true : PerlWarnIsSet_(WARN_DEFAULTstring, 2*warn_bit);
+    else if(warning_bits == pWARN_ALL)
+        return true;
+    else if(warning_bits == pWARN_NONE)
+        return false;
+    else
+        return isWARN_on(cop->cop_warnings, (STRLEN)warn_bit);
+}
+
+#define cop_inplace_expand_warning_bitmask(cop)  S_cop_inplace_expand_warning_bitmask(aTHX_ cop)
+STATIC void
+S_cop_inplace_expand_warning_bitmask(pTHX_ COP *cop)
+{
+    const char *warning_bits = cop->cop_warnings;
+
+    if(warning_bits == pWARN_STD)
+        warning_bits = (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_DEFAULTstring;
+    else if(warning_bits == pWARN_ALL)
+        warning_bits = WARN_ALLstring;
+    else if(warning_bits == pWARN_NONE)
+        warning_bits = WARN_NONEstring;
+
+    /* Must allocate the new one before we throw the old buffer away */
+    char *new_warnings = Perl_new_warnings_bitfield(aTHX_ NULL, warning_bits, WARNsize);
+    free_and_set_cop_warnings(cop, new_warnings);
+}
+
+/*
+=for apidoc cop_enable_warning
+
+Ensures that the set of warning bits contained by the COP includes the given
+warning, as specified by one of the C<WARN_...> constants from F<warnings.h>.
+
+If the COP already includes the warning, no modification is made.  Otherwise,
+the stored warning bitmask is cloned, and the given warning bit is enabled
+within it.  The COP is modified in-place, and therefore this function is
+intended only for use during compiletime when the optree is being constructed.
+
+=cut
+*/
+
+void
+Perl_cop_enable_warning(pTHX_ COP *cop, int warn_bit)
+{
+    PERL_ARGS_ASSERT_COP_ENABLE_WARNING;
+
+    if(cop_has_warning(cop, warn_bit))
+        return;
+
+    cop_inplace_expand_warning_bitmask(cop);
+
+    cop->cop_warnings[Perl_Warn_Off_(2 * warn_bit)] |= Perl_Warn_Bit_(2 * warn_bit);
+}
+
+/*
+=for apidoc cop_disable_warning
+
+Ensures that the set of warning bits contained by the COP does not include the
+given warning, as specified by one of the C<WARN_...> constants from
+F<warnings.h>.
+
+If the COP does not include the warning, no modification is made.  Otherwise,
+the stored warning bitmask is cloned, and the given warning bit is disabled
+within it.  The COP is modified in-place, and therefore this function is
+intended only for use during compiletime when the optree is being constructed.
+
+=cut
+*/
+
+void
+Perl_cop_disable_warning(pTHX_ COP *cop, int warn_bit)
+{
+    PERL_ARGS_ASSERT_COP_DISABLE_WARNING;
+
+    if(!cop_has_warning(cop, warn_bit))
+        return;
+
+    cop_inplace_expand_warning_bitmask(cop);
+
+    cop->cop_warnings[Perl_Warn_Off_(2 * warn_bit)] &= ~Perl_Warn_Bit_(2 * warn_bit);
+}
+
 /*
 =for apidoc newLOGOP