From 0932863fe57c5e3708f938df0664df51358e68ed Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Mon, 29 Jan 2007 22:40:01 +0000 Subject: [PATCH] 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 --- ext/XS/APItest/APItest.pm | 28 +++++++++++++-- ext/XS/APItest/APItest.xs | 2 +- ext/XS/APItest/t/xs_special_subs.t | 73 +++++++++++++++++++++++++++++++++++++- lib/ExtUtils/ParseXS.pm | 8 ++++- op.c | 7 +++- 5 files changed, 112 insertions(+), 6 deletions(-) diff --git a/ext/XS/APItest/APItest.pm b/ext/XS/APItest/APItest.pm index 7d0b40f..e230eb2 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 923c532..9d56365 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 6c7eba0..bc99122 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 c3df5b0..420ce2a 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 0bfd478..431c7a4 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"); -- 2.7.4