diff --git a/.editorconfig b/.editorconfig index a7417d0bbe24..79f8d4369d6f 100644 --- a/.editorconfig +++ b/.editorconfig @@ -8,3 +8,12 @@ tab_width = 8 end_of_line = lf trim_trailing_whitespace = true insert_final_newline = true + +[**/*.xs] +charset = utf-8 +indent_style = space +indent_size = 4 +tab_width = 8 +end_of_line = lf +trim_trailing_whitespace = true +insert_final_newline = true diff --git a/MANIFEST b/MANIFEST index 55ba9e226975..3b20666b2113 100644 --- a/MANIFEST +++ b/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 diff --git a/embed.fnc b/embed.fnc index 08baaca9801a..2123d01ffad0 100644 --- a/embed.fnc +++ b/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 \ diff --git a/embed.h b/embed.h index 494941621405..8ac7210a5d76 100644 --- a/embed.h +++ b/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 diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index cf17ad71744d..ae76f0519e12 100644 --- a/ext/XS-APItest/APItest.pm +++ b/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; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index dc0d8b027cb2..dbd03f8314d8 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1,3 +1,7 @@ +/* + * ex: set ts=8 sts=4 sw=4 et: + */ + #define PERL_IN_XS_APITEST /* We want to be able to test things that aren't API yet. */ @@ -3880,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() diff --git a/ext/XS-APItest/t/cop_warnings.t b/ext/XS-APItest/t/cop_warnings.t new file mode 100644 index 000000000000..cdb1ffc6e3e4 --- /dev/null +++ b/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; diff --git a/op.c b/op.c index 8a85229e5116..43e07ac89be1 100644 --- a/op.c +++ b/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 +constants from F. + +=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 constants from F. + +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 constants from +F. + +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 diff --git a/proto.h b/proto.h index b01356f2e377..922ada10d42d 100644 --- a/proto.h +++ b/proto.h @@ -495,11 +495,26 @@ Perl_cmpchain_start(pTHX_ I32 type, OP *left, OP *right) #define PERL_ARGS_ASSERT_CNTRL_TO_MNEMONIC +PERL_CALLCONV void +Perl_cop_disable_warning(pTHX_ COP *cop, int warn_bit); +#define PERL_ARGS_ASSERT_COP_DISABLE_WARNING \ + assert(cop) + +PERL_CALLCONV void +Perl_cop_enable_warning(pTHX_ COP *cop, int warn_bit); +#define PERL_ARGS_ASSERT_COP_ENABLE_WARNING \ + assert(cop) + PERL_CALLCONV const char * Perl_cop_fetch_label(pTHX_ COP * const cop, STRLEN *len, U32 *flags); #define PERL_ARGS_ASSERT_COP_FETCH_LABEL \ assert(cop) +PERL_CALLCONV bool +Perl_cop_has_warning(pTHX_ const COP *cop, int warn_bit); +#define PERL_ARGS_ASSERT_COP_HAS_WARNING \ + assert(cop) + PERL_CALLCONV void Perl_cop_store_label(pTHX_ COP * const cop, const char *label, STRLEN len, U32 flags); #define PERL_ARGS_ASSERT_COP_STORE_LABEL \ diff --git a/regen/warnings.pl b/regen/warnings.pl index d518b4cc95cd..5ee1277fb4a4 100644 --- a/regen/warnings.pl +++ b/regen/warnings.pl @@ -461,6 +461,8 @@ sub main { print $warn_h tab(6, '#define WARNsize'), " $warn_size\n" ; print $warn_h tab(6, '#define WARN_ALLstring'), ' "', ('\125' x $warn_size) , "\"\n" ; print $warn_h tab(6, '#define WARN_NONEstring'), ' "', ('\0' x $warn_size) , "\"\n" ; + print $warn_h tab(6, '#define WARN_DEFAULTstring'), ' "', + mkHex($warn_size, map $_ * 2, @DEFAULTS), "\"\n"; print $warn_h warnings_h_boilerplate_2(); diff --git a/warnings.h b/warnings.h index bbe92dfe50f8..285a94b4b1b1 100644 --- a/warnings.h +++ b/warnings.h @@ -165,6 +165,7 @@ #define WARNsize 20 #define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125" #define WARN_NONEstring "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0" +#define WARN_DEFAULTstring "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x05\x00\x15\x14\x55\x55\x54\x55" #define isLEXWARN_on \ cBOOL(PL_curcop && PL_curcop->cop_warnings != pWARN_STD)