Change 30072 by [EMAIL PROTECTED] on 2007/01/29 22:40:01
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.
Affected files ...
... //depot/perl/ext/XS/APItest/APItest.pm#18 edit
... //depot/perl/ext/XS/APItest/APItest.xs#35 edit
... //depot/perl/ext/XS/APItest/t/xs_special_subs.t#2 edit
... //depot/perl/lib/ExtUtils/ParseXS.pm#19 edit
... //depot/perl/op.c#886 edit
Differences ...
==== //depot/perl/ext/XS/APItest/APItest.pm#18 (text) ====
Index: perl/ext/XS/APItest/APItest.pm
--- perl/ext/XS/APItest/APItest.pm#17~30067~ 2007-01-29 12:05:52.000000000
-0800
+++ perl/ext/XS/APItest/APItest.pm 2007-01-29 14:40:01.000000000 -0800
@@ -38,12 +38,36 @@
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;
}
==== //depot/perl/ext/XS/APItest/APItest.xs#35 (text) ====
Index: perl/ext/XS/APItest/APItest.xs
--- perl/ext/XS/APItest/APItest.xs#34~30067~ 2007-01-29 12:05:52.000000000
-0800
+++ perl/ext/XS/APItest/APItest.xs 2007-01-29 14:40:01.000000000 -0800
@@ -580,7 +580,7 @@
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()
==== //depot/perl/ext/XS/APItest/t/xs_special_subs.t#2 (text) ====
Index: perl/ext/XS/APItest/t/xs_special_subs.t
--- perl/ext/XS/APItest/t/xs_special_subs.t#1~30067~ 2007-01-29
12:05:52.000000000 -0800
+++ perl/ext/XS/APItest/t/xs_special_subs.t 2007-01-29 14:40:01.000000000
-0800
@@ -7,78 +7,149 @@
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");
}
==== //depot/perl/lib/ExtUtils/ParseXS.pm#19 (text) ====
Index: perl/lib/ExtUtils/ParseXS.pm
--- perl/lib/ExtUtils/ParseXS.pm#18~29418~ 2006-11-29 07:17:59.000000000
-0800
+++ perl/lib/ExtUtils/ParseXS.pm 2007-01-29 14:40:01.000000000 -0800
@@ -18,7 +18,7 @@
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 @@
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;
#]]
==== //depot/perl/op.c#886 (text) ====
Index: perl/op.c
--- perl/op.c#885~30067~ 2007-01-29 12:05:52.000000000 -0800
+++ perl/op.c 2007-01-29 14:40:01.000000000 -0800
@@ -5634,7 +5634,7 @@
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_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");
End of Patch.
