Test XS registration of state subs

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

2 files changed, 39 insertions, 0 deletions

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 357b033f7f..8c045bcf45 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 0000000000..2d66addf7a
--- /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';
+}