In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/0be5d18d4f53600db81ddc43c2c98dba5b7869d2?hp=9c62c74d253b05d5e0ec6c62885030bfbe5ccda3>
- Log ----------------------------------------------------------------- commit 0be5d18d4f53600db81ddc43c2c98dba5b7869d2 Author: Father Chrysostomos <[email protected]> Date: Wed Sep 26 08:53:36 2012 -0700 Test XS registration of state subs my subs do not currently work yet. I am not sure what the API should be. M MANIFEST M ext/XS-APItest/APItest.xs A ext/XS-APItest/t/lexsub.t commit 85ffec368212c676791d13ff9743912238325bc2 Author: Father Chrysostomos <[email protected]> Date: Wed Sep 26 08:47:28 2012 -0700 Make PL_compcv visible to BEGIN blocks This allows BEGIN { XS_func(); } to access the currently-com- piling pad. BEGIN blocks were unlike any other subroutine or special block in that PL_compcv would be set to the BEGIN block itself at run time. M op.c ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + ext/XS-APItest/APItest.xs | 20 ++++++++++++++++++++ ext/XS-APItest/t/lexsub.t | 19 +++++++++++++++++++ op.c | 3 +++ 4 files changed, 43 insertions(+), 0 deletions(-) create mode 100644 ext/XS-APItest/t/lexsub.t diff --git a/MANIFEST b/MANIFEST index a6884d0..350312d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4016,6 +4016,7 @@ ext/XS-APItest/t/keyword_plugin.t test keyword plugin mechanism ext/XS-APItest/t/labelconst.aux auxiliary file for label test ext/XS-APItest/t/labelconst.t test recursive descent label parsing ext/XS-APItest/t/labelconst_utf8.aux auxiliary file for label test in UTF-8 +ext/XS-APItest/t/lexsub.t Test XS registration of lexical subs ext/XS-APItest/t/loopblock.t test recursive descent block parsing ext/XS-APItest/t/looprest.t test recursive descent statement-sequence parsing ext/XS-APItest/t/lvalue.t Test XS lvalue functions diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 357b033..8c045bc 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -3431,6 +3431,26 @@ CODE: OUTPUT: RETVAL +void +lexical_import(SV *name, CV *cv) + CODE: + { + PADLIST *pl; + PADOFFSET off; + if (!PL_compcv) + Perl_croak(aTHX_ + "lexical_import can only be called at compile time"); + pl = CvPADLIST(PL_compcv); + ENTER; + SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(pl); + SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(pl)[1]; + SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad); + off = pad_add_name_sv(newSVpvf("&%"SVf,name), padadd_STATE, 0, 0); + SvREFCNT_dec(PL_curpad[off]); + PL_curpad[off] = SvREFCNT_inc(cv); + LEAVE; + } + MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest diff --git a/ext/XS-APItest/t/lexsub.t b/ext/XS-APItest/t/lexsub.t new file mode 100644 index 0000000..2d66add --- /dev/null +++ b/ext/XS-APItest/t/lexsub.t @@ -0,0 +1,19 @@ +use Test::More tests => 4; +use XS::APItest; + + +sub fribbler { 2*shift } +{ + BEGIN { lexical_import fribbler => sub { 3*shift } } + is fribbler(15), 45, 'lexical subs via pad_add_name'; +} +is fribbler(15), 30, 'XS-allocated lexical subs falling out of scope'; + +{ + BEGIN { lexical_import fribbler => sub { 3*shift } } + is fribbler(15), 45, 'lexical subs via pad_add_name'; + no warnings; + use feature 'lexical_subs'; + our sub fribbler; + is fribbler(15), 30, 'our sub overrides XS-registered lexical sub'; +} diff --git a/op.c b/op.c index d074c0c..dfc1cd7 100644 --- a/op.c +++ b/op.c @@ -7663,7 +7663,10 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } if (name && ! (PL_parser && PL_parser->error_count)) + { + LEAVE_SCOPE(floor); process_special_blocks(name, gv, cv); + } } done: -- Perl5 Master Repository
