Test XS registration of state subs

my subs do not currently work yet.  I am not sure what the API
should be.

diff --git a/MANIFEST b/MANIFEST
index a6884d0..350312d 100644 (file)
--- 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 (file)
--- 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 (file)
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';
+}