UNITCHECK for XS code. Turned out to be harder that expected.

We need to get the XS BOOT section to run any UNITCHECK blocks for us.

p4raw-id: //depot/perl@30072

5 files changed, 112 insertions, 6 deletions

diff --git a/ext/XS/APItest/APItest.pm b/ext/XS/APItest/APItest.pm
index 7d0b40fa9d..e230eb2694 100644
--- a/ext/XS/APItest/APItest.pm
+++ b/ext/XS/APItest/APItest.pm
@@ -38,12 +38,36 @@ sub G_METHOD()	{  64 }
 our $VERSION = '0.12';
 
 use vars '$WARNINGS_ON_BOOTSTRAP';
+use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END);
+
+# Do these here to verify that XS code and Perl code get called at the same
+# times
+BEGIN {
+    $BEGIN_called_PP++;
+}
+UNITCHECK {
+    $UNITCHECK_called_PP++;
+}
+{
+    # 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)
+    no warnings 'void';
+    CHECK {
+	$CHECK_called_PP++;
+    }
+    INIT {
+	$INIT_called_PP++;
+    }
+}
+END {
+    $END_called_PP++;
+}
+
 if ($WARNINGS_ON_BOOTSTRAP) {
     bootstrap XS::APItest $VERSION;
 } else {
+    # More CHECK and INIT blocks that could warn:
     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;
 }
 
diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs
index 923c532802..9d56365f5c 100644
--- a/ext/XS/APItest/APItest.xs
+++ b/ext/XS/APItest/APItest.xs
@@ -580,7 +580,7 @@ CHECK()
 void
 UNITCHECK()
     CODE:
-	sv_inc(get_sv("XS::APItest::CHECK_called", GV_ADD|GV_ADDMULTI));
+	sv_inc(get_sv("XS::APItest::UNITCHECK_called", GV_ADD|GV_ADDMULTI));
 
 void
 INIT()
diff --git a/ext/XS/APItest/t/xs_special_subs.t b/ext/XS/APItest/t/xs_special_subs.t
index 6c7eba0884..bc9912294f 100644
--- a/ext/XS/APItest/t/xs_special_subs.t
+++ b/ext/XS/APItest/t/xs_special_subs.t
@@ -7,78 +7,149 @@ BEGIN {
         print "1..0 # Skip: XS::APItest was not built\n";
         exit 0;
     }
+    $XS::APItest::WARNINGS_ON_BOOTSTRAP++;
 }
 
 use strict;
 use warnings;
-use Test::More tests => 40;
+use Test::More tests => 100;
 
 # Doing this longhand cut&paste makes it clear
 # BEGIN and INIT are FIFO, CHECK and END are LIFO
 BEGIN {
+    print "# First BEGIN\n";
     is($XS::APItest::BEGIN_called, undef, "BEGIN not yet called");
+    is($XS::APItest::BEGIN_called_PP, undef, "BEGIN not yet called");
+    is($XS::APItest::UNITCHECK_called, undef, "UNITCHECK not yet called");
+    is($XS::APItest::UNITCHECK_called_PP, undef, "UNITCHECK not yet called");
     is($XS::APItest::CHECK_called, undef, "CHECK not yet called");
+    is($XS::APItest::CHECK_called_PP, undef, "CHECK not yet called");
     is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not yet called");
     is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
 }
 
 CHECK {
+    print "# First CHECK\n";
     is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
     is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::CHECK_called_PP, 1, "CHECK called");
     is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not yet called");
     is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
 }
 
 INIT {
+    print "# First INIT\n";
     is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
     is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::CHECK_called_PP, 1, "CHECK called");
     is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not yet called");
     is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
 }
 
 END {
+    print "# First END\n";
     is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
     is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::CHECK_called_PP, 1, "CHECK called");
     is($XS::APItest::INIT_called, 1, "INIT called");
+    is($XS::APItest::INIT_called_PP, 1, "INIT called");
     is($XS::APItest::END_called, 1, "END called");
+    is($XS::APItest::END_called_PP, 1, "END called");
 }
 
+print "# First body\n";
 is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
 is($XS::APItest::CHECK_called, 1, "CHECK called");
+is($XS::APItest::CHECK_called_PP, 1, "CHECK called");
 is($XS::APItest::INIT_called, 1, "INIT called");
+is($XS::APItest::INIT_called_PP, 1, "INIT called");
 is($XS::APItest::END_called, undef, "END not yet called");
+is($XS::APItest::END_called_PP, undef, "END not yet called");
 
 use XS::APItest;
 
+print "# Second body\n";
 is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
 is($XS::APItest::CHECK_called, 1, "CHECK called");
+is($XS::APItest::CHECK_called_PP, 1, "CHECK called");
 is($XS::APItest::INIT_called, 1, "INIT called");
+is($XS::APItest::INIT_called_PP, 1, "INIT called");
 is($XS::APItest::END_called, undef, "END not yet called");
+is($XS::APItest::END_called_PP, undef, "END not yet called");
 
 BEGIN {
+    print "# Second BEGIN\n";
     is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
     is($XS::APItest::CHECK_called, undef, "CHECK not yet called");
+    is($XS::APItest::CHECK_called_PP, undef, "CHECK not yet called");
     is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not yet called");
     is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
 }
 
 CHECK {
+    print "# Second CHECK\n";
     is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK yet called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK yet called");
     is($XS::APItest::CHECK_called, undef, "CHECK not yet called");
+    is($XS::APItest::CHECK_called_PP, undef, "CHECK not yet called");
     is($XS::APItest::INIT_called, undef, "INIT not yet called");
+    is($XS::APItest::INIT_called_PP, undef, "INIT not yet called");
     is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
 }
 
 INIT {
+    print "# Second INIT\n";
     is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
     is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::CHECK_called_PP, 1, "CHECK called");
     is($XS::APItest::INIT_called, 1, "INIT called");
+    is($XS::APItest::INIT_called_PP, 1, "INIT called");
     is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
 }
 
 END {
+    print "# Second END\n";
     is($XS::APItest::BEGIN_called, 1, "BEGIN called");
+    is($XS::APItest::BEGIN_called_PP, 1, "BEGIN called");
+    is($XS::APItest::UNITCHECK_called, 1, "UNITCHECK called");
+    is($XS::APItest::UNITCHECK_called_PP, 1, "UNITCHECK called");
     is($XS::APItest::CHECK_called, 1, "CHECK called");
+    is($XS::APItest::CHECK_called_PP, 1, "CHECK called");
     is($XS::APItest::INIT_called, 1, "INIT called");
+    is($XS::APItest::INIT_called_PP, 1, "INIT called");
     is($XS::APItest::END_called, undef, "END not yet called");
+    is($XS::APItest::END_called_PP, undef, "END not yet called");
 }
diff --git a/lib/ExtUtils/ParseXS.pm b/lib/ExtUtils/ParseXS.pm
index c3df5b0698..420ce2ac90 100644
--- a/lib/ExtUtils/ParseXS.pm
+++ b/lib/ExtUtils/ParseXS.pm
@@ -18,7 +18,7 @@ my(@XSStack);	# Stack of conditionals and INCLUDEs
 my($XSS_work_idx, $cpp_next_tmp);
 
 use vars qw($VERSION);
-$VERSION = '2.17_01';
+$VERSION = '2.17_02';
 
 use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback
 	    $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers
@@ -981,6 +981,12 @@ EOF
     print "\n    /* End of Initialisation Section */\n\n" ;
   }
 
+  if ($] >= 5.009) {
+    print <<'EOF';
+    if (PL_unitcheckav)
+         call_list(PL_scopestack_ix, PL_unitcheckav);
+EOF
+  }
   print Q(<<"EOF");
 #    XSRETURN_YES;
 #]]
diff --git a/op.c b/op.c
index 0bfd478283..431c7a4fbf 100644
--- a/op.c
+++ b/op.c
@@ -5634,7 +5634,7 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
 	else
 	    s = name;
 
-	if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
+	if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
 	    goto done;
 
 	if (strEQ(s, "BEGIN")) {
@@ -5661,6 +5661,11 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
 	    Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
 	    GvCV(gv) = 0;		/* cv has been hijacked */
 	}
+	else if (strEQ(s, "UNITCHECK")) {
+	    /* It's never too late to run a unitcheck block */
+	    Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
+	    GvCV(gv) = 0;		/* cv has been hijacked */
+	}
 	else if (strEQ(s, "INIT")) {
 	    if (PL_main_start && ckWARN(WARN_VOID))
 		Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");