Pure Perl lvalue subs can't return temps, even if they are magical. This holds back...

diff --git a/MANIFEST b/MANIFEST
index 59edeb9..12c66be 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3291,6 +3291,7 @@ ext/XS-APItest/t/push.t           XS::APItest extension
 ext/XS-APItest/t/rmagical.t    XS::APItest extension
 ext/XS-APItest/t/svpeek.t      XS::APItest extension
 ext/XS-APItest/t/svsetsv.t     Test behaviour of sv_setsv with/without PERL_CORE
+ext/XS-APItest/t/temp_lv_sub.t XS::APItest: tests for lvalue subs returning temps
 ext/XS-APItest/t/utf16_to_utf8.t       Test behaviour of utf16_to_utf8{,reversed}
 ext/XS-APItest/t/xs_special_subs_require.t     for require too
 ext/XS-APItest/t/xs_special_subs.t     Test that XS BEGIN/CHECK/INIT/END work

diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
index 73db4a5..05546ff 100644 (file)
--- a/ext/XS-APItest/APItest.pm
+++ b/ext/XS-APItest/APItest.pm
@@ -27,7 +27,7 @@ our @EXPORT = qw( print_double print_int print_long
                  sv_count
 );
 
-our $VERSION = '0.19';
+our $VERSION = '0.20';
 
 use vars '$WARNINGS_ON_BOOTSTRAP';
 use vars map "\$${_}_called_PP", qw(BEGIN UNITCHECK CHECK INIT END);

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 9e5ebe8..8dce9db 100644 (file)
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -653,6 +653,29 @@ sub CLEAR    { %{$_[0]} = () }
 
 =cut
 
+
+MODULE = XS::APItest:TempLv            PACKAGE = XS::APItest::TempLv
+
+void
+make_temp_mg_lv(sv)
+SV* sv
+    PREINIT:
+       SV * const lv = newSV_type(SVt_PVLV);
+       STRLEN len;
+    PPCODE:
+        SvPV(sv, len);
+
+       sv_magic(lv, NULL, PERL_MAGIC_substr, NULL, 0);
+       LvTYPE(lv) = 'x';
+       LvTARG(lv) = SvREFCNT_inc_simple(sv);
+       LvTARGOFF(lv) = len == 0 ? 0 : 1;
+       LvTARGLEN(lv) = len < 2 ? 0 : len-2;
+
+       EXTEND(SP, 1);
+       ST(0) = sv_2mortal(lv);
+       XSRETURN(1);
+
+
 MODULE = XS::APItest::PtrTable PACKAGE = XS::APItest::PtrTable PREFIX = ptr_table_
 
 void
@@ -1137,3 +1160,17 @@ peep_record_clear ()
         dMY_CXT;
     CODE:
         av_clear(MY_CXT.peep_record);
+
+BOOT:
+       {
+       HV* stash;
+       SV** meth = NULL;
+       CV* cv;
+       stash = gv_stashpv("XS::APItest::TempLv", 0);
+       if (stash)
+           meth = hv_fetchs(stash, "make_temp_mg_lv", 0);
+       if (!meth)
+           croak("lost method 'make_temp_mg_lv'");
+       cv = GvCV(*meth);
+       CvLVALUE_on(cv);
+       }

diff --git a/ext/XS-APItest/t/temp_lv_sub.t b/ext/XS-APItest/t/temp_lv_sub.t
new file mode 100644 (file)
index 0000000..bfcacd6
--- /dev/null
+++ b/ext/XS-APItest/t/temp_lv_sub.t
@@ -0,0 +1,37 @@
+#!perl -w
+
+BEGIN {
+  push @INC, "::lib:$MacPerl::Architecture:" if $^O eq 'MacOS';
+  require Config; import Config;
+  if ($Config{'extensions'} !~ /\bXS\/APItest\b/) {
+    # Look, I'm using this fully-qualified variable more than once!
+    my $arch = $MacPerl::Architecture;
+    print "1..0 # Skip: XS::APItest was not built\n";
+    exit 0;
+  }
+}
+
+use strict;
+use utf8;
+use Test::More tests => 5;
+
+BEGIN {use_ok('XS::APItest')};
+
+sub make_temp_mg_lv :lvalue {  XS::APItest::TempLv::make_temp_mg_lv($_[0]); }
+
+{
+    my $x = "[]";
+    eval { XS::APItest::TempLv::make_temp_mg_lv($x) = "a"; };
+    is($@, '',    'temp mg lv from xs exception check');
+    is($x, '[a]', 'temp mg lv from xs success');
+}
+
+{
+    local $TODO = "PP lvalue sub can't return magical temp";
+    my $x = "{}";
+    eval { make_temp_mg_lv($x) = "b"; };
+    is($@, '',    'temp mg lv from pp exception check');
+    is($x, '{b}', 'temp mg lv from pp success');
+}
+
+1;