BEGIN blocks in XS should work. (Given that CHECK, INIT and END all do)

p4raw-id: //depot/perl@30067

diff --git a/MANIFEST b/MANIFEST
index 5ba407d..7069e83 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1230,6 +1230,7 @@ ext/XS/APItest/t/op.t             XS::APItest: tests for OP related APIs
 ext/XS/APItest/t/printf.t      XS::APItest extension
 ext/XS/APItest/t/push.t                XS::APItest extension
 ext/XS/APItest/t/svsetsv.t     Test behaviour of sv_setsv with/without PERL_CORE
+ext/XS/APItest/t/xs_special_subs.t     Test that XS BEGIN/CHECK/INIT/END work
 ext/XS/Typemap/Makefile.PL     XS::Typemap extension
 ext/XS/Typemap/README          XS::Typemap extension
 ext/XS/Typemap/stdio.c         XS::Typemap extension

diff --git a/ext/XS/APItest/APItest.pm b/ext/XS/APItest/APItest.pm
index 668c7a9..7d0b40f 100644 (file)
--- a/ext/XS/APItest/APItest.pm
+++ b/ext/XS/APItest/APItest.pm
@@ -35,9 +35,17 @@ sub G_KEEPERR()      {  16 }
 sub G_NODEBUG()        {  32 }
 sub G_METHOD() {  64 }
 
-our $VERSION = '0.11';
-
-bootstrap XS::APItest $VERSION;
+our $VERSION = '0.12';
+
+use vars '$WARNINGS_ON_BOOTSTRAP';
+if ($WARNINGS_ON_BOOTSTRAP) {
+    bootstrap XS::APItest $VERSION;
+} else {
+    local $^W;
+    # Need $W false by default, as some tests run under -w, and under -w we
+    # can get warnings about "Too late to run CHECK" block (and INIT block)
+    bootstrap XS::APItest $VERSION;
+}
 
 1;
 __END__

diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
index 827e362..923c532 100644 (file)
--- a/ext/XS/APItest/APItest.xs
+++ b/ext/XS/APItest/APItest.xs
@@ -566,3 +566,28 @@ sv_setsv_cow_hashkey_core()
 
 bool
 sv_setsv_cow_hashkey_notcore()
+
+void
+BEGIN()
+    CODE:
+       sv_inc(get_sv("XS::APItest::BEGIN_called", GV_ADD|GV_ADDMULTI));
+
+void
+CHECK()
+    CODE:
+       sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
+
+void
+UNITCHECK()
+    CODE:
+       sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
+
+void
+INIT()
+    CODE:
+       sv_inc(get_sv("XS::APItest::INIT_called", GV_ADD|GV_ADDMULTI));
+
+void
+END()
+    CODE:
+       sv_inc(get_sv("XS::APItest::END_called", GV_ADD|GV_ADDMULTI));

diff --git a/ext/XS/APItest/t/xs_special_subs.t b/ext/XS/APItest/t/xs_special_subs.t
new file mode 100644 (file)
index 0000000..6c7eba0
--- /dev/null
+++ b/ext/XS/APItest/t/xs_special_subs.t
@@ -0,0 +1,84 @@
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+    require Config; import Config;
+    if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+        print "1..0 # Skip: XS::APItest was not built\n";
+        exit 0;
+    }
+}
+
+use strict;
+use warnings;
+use Test::More tests => 40;
+
+# Doing this longhand cut&paste makes it clear
+# BEGIN and INIT are FIFO, CHECK and END are LIFO
+BEGIN {
+    is($XS::APItest::BEGIN_called, undef, "BEGIN not yet called");
+    is($XS::APItest::CHECK_called, undef, "CHECK not yet called");
+    is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+}
+
+CHECK {
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+}
+
+INIT {
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+}
+
+END {
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::INIT_called, 1, "INIT called");
+    is($XS::APItest::END_called, 1, "END called");
+}
+
+is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+is($XS::APItest::CHECK_called, 1, "CHECK called");
+is($XS::APItest::INIT_called, 1, "INIT called");
+is($XS::APItest::END_called, undef, "END not yet called");
+
+use XS::APItest;
+
+is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+is($XS::APItest::CHECK_called, 1, "CHECK called");
+is($XS::APItest::INIT_called, 1, "INIT called");
+is($XS::APItest::END_called, undef, "END not yet called");
+
+BEGIN {
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::CHECK_called, undef, "CHECK not yet called");
+    is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+}
+
+CHECK {
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::CHECK_called, undef, "CHECK not yet called");
+    is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+}
+
+INIT {
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::INIT_called, 1, "INIT called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+}
+
+END {
+    is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::INIT_called, 1, "INIT called");
+    is($XS::APItest::END_called, undef, "END not yet called");
+}

diff --git a/op.c b/op.c
index b952ef8..0bfd478 100644 (file)
--- a/op.c
+++ b/op.c
@@ -5638,8 +5638,18 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
            goto done;
 
        if (strEQ(s, "BEGIN")) {
+           const I32 oldscope = PL_scopestack_ix;
+           ENTER;
+           SAVECOPFILE(&PL_compiling);
+           SAVECOPLINE(&PL_compiling);
+
            Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
            GvCV(gv) = 0;               /* cv has been hijacked */
+           call_list(oldscope, PL_beginav);
+
+           PL_curcop = &PL_compiling;
+           CopHINTS_set(&PL_compiling, PL_hints);
+           LEAVE;
        }
        else if (strEQ(s, "END")) {
            Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);