From 84ac5fd7451a86053a5e645e5d03f47d085d328f Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Mon, 29 Jan 2007 20:05:52 +0000 Subject: [PATCH] BEGIN blocks in XS should work. (Given that CHECK, INIT and END all do) p4raw-id: //depot/perl@30067 --- MANIFEST | 1 + ext/XS/APItest/APItest.pm | 14 +++++-- ext/XS/APItest/APItest.xs | 25 ++++++++++++ ext/XS/APItest/t/xs_special_subs.t | 84 ++++++++++++++++++++++++++++++++++++++ op.c | 10 +++++ 5 files changed, 131 insertions(+), 3 deletions(-) create mode 100644 ext/XS/APItest/t/xs_special_subs.t diff --git a/MANIFEST b/MANIFEST index 5ba407d..7069e83 100644 --- 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 --- 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 --- 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 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 --- 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); -- 1.8.3.1