Localise PL_curcop for BEGIN blocks

Usually when a BEGIN block exits it has to set PL_curcop to
&PL_compiling, so that subsequent compiled code in the surrounding
scope will have the right warning hints during compilation.

If an XS function creates a BEGIN block via newXS or newATTRSUB, how-
ever, the assumption that compilation will resume as soon as the block
exits is false.

This can be demonstrated with this code, which warns about CHECK and
INIT blocks created too late when it shouldn’t due to ‘no warnings’:

use warnings;
eval q|
  BEGIN{
    no warnings;
    package XS::APItest; require XSLoader; XSLoader::load()
  }
|;

In every case where it is correct for BEGIN to set PL_curcop to
&PL_compiling when it exits it is actually just restoring it to its
previous value, so localisation is the right fix.

diff --git a/MANIFEST b/MANIFEST
index b1da016..fd89605 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3880,6 +3880,7 @@ ext/XS-APItest/t/Block.pm Helper for ./blockhooks.t
 ext/XS-APItest/t/call_checker.t        test call checker plugin API
 ext/XS-APItest/t/caller.t      XS::APItest: tests for caller_cx
 ext/XS-APItest/t/call.t                XS::APItest extension
+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/cophh.t       test COPHH API

diff --git a/ext/XS-APItest/t/check_warnings.t b/ext/XS-APItest/t/check_warnings.t
new file mode 100644 (file)
index 0000000..2de083d
--- /dev/null
+++ b/ext/XS-APItest/t/check_warnings.t
@@ -0,0 +1,20 @@
+#!perl
+
+# This test checks to make sure that a BEGIN block created from an XS call
+# does not implicitly change the current warning scope, causing a CHECK
+# or INIT block created after the corresponding phase to warn when it
+# shouldn’t.
+
+use Test::More tests => 1;
+
+$SIG{__WARN__} = sub { $w .= shift };
+
+use warnings;
+eval q|
+  BEGIN{
+    no warnings;
+    package XS::APItest; require XSLoader; XSLoader::load()
+  }
+|;
+
+is $w, undef, 'No warnings about CHECK and INIT in warningless scope';

diff --git a/ext/XS-APItest/t/xs_special_subs_require.t b/ext/XS-APItest/t/xs_special_subs_require.t
index 49604a5..3131aad 100644 (file)
--- a/ext/XS-APItest/t/xs_special_subs_require.t
+++ b/ext/XS-APItest/t/xs_special_subs_require.t
@@ -86,8 +86,8 @@ is($XS::APItest::END_called_PP, undef, "END not yet called");
 
     @trap = sort @trap;
     is(scalar @trap, 2, "There were 2 warnings");
-    is($trap[0], "Too late to run CHECK block.\n");
-    is($trap[1], "Too late to run INIT block.\n");
+    like($trap[0], qr "^Too late to run CHECK block");
+    like($trap[1], qr "^Too late to run INIT block");
 }
 
 print "# Second body\n";

diff --git a/op.c b/op.c
index 2399bb3..63e5a4a 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6811,13 +6811,13 @@ S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
            ENTER;
            SAVECOPFILE(&PL_compiling);
            SAVECOPLINE(&PL_compiling);
+           SAVEVPTR(PL_curcop);
 
            DEBUG_x( dump_sub(gv) );
            Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
            GvCV_set(gv,0);             /* cv has been hijacked */
            call_list(oldscope, PL_beginav);
 
-           PL_curcop = &PL_compiling;
            CopHINTS_set(&PL_compiling, PL_hints);
            LEAVE;
        }