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