From dd2a7f9048da2c440a4dfed5122c0bfd98f079d3 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Fri, 6 Sep 2013 00:17:05 -0700
Subject: [PATCH] Use defelems for (goto) &xsub calls

Before ce0d59f:

$ perl -e '++$#_; &utf8::encode'
Modification of a read-only value attempted at -e line 1.

As of ce0d59f:

$ ./perl -Ilib -e '++$#_; &utf8::encode'
Assertion failed: (sv), function Perl_sv_utf8_encode, file sv.c, line 3581.
Abort trap: 6

Calling sub { utf8::encode($_[0]) } should be more or less equivalent
to calling utf8::encode, but it is not in this case:

$ ./perl -Ilib -we '++$#_; &{sub { utf8::encode($_[0]) }}'
Use of uninitialized value in subroutine entry at -e line 1.

In the first two examples above, an implementation detail is leaking
through.  What you are seeing is not the array element, but a place-
holder that indicates an element that has not been assigned to yet.

We should use defelem magic so that what the XSUB assigns to will cre-
ate an array element (as happens with utf8::encode($_[0])).

All of the above applies to goto &xsub as well.
---
 pp_ctl.c    | 13 ++++++++++++-
 pp_hot.c    | 13 ++++++++++++-
 t/op/goto.t | 11 ++++++++++-
 t/op/sub.t  | 12 +++++++++++-
 4 files changed, 45 insertions(+), 4 deletions(-)

diff --git a/pp_ctl.c b/pp_ctl.c
index 4ce8ddb..b7b3598 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2907,7 +2907,18 @@ PP(pp_goto)
 		if (AvREAL(arg)) {
 		    I32 index;
 		    for (index=0; index<items; index++)
-			SvREFCNT_inc_void(sv_2mortal(SP[-index]));
+			if (SP[-index])
+			    SvREFCNT_inc_void_NN(sv_2mortal(SP[-index]));
+			else {
+			    SV * const lv =
+				sv_2mortal(newSV_type(SVt_PVLV));
+			    SP[-index] = lv;
+			    LvTYPE(lv) = 'y';
+			    sv_magic(lv,NULL,PERL_MAGIC_defelem,NULL,0);
+			    LvTARG(lv) = SvREFCNT_inc_simple_NN(arg);
+			    LvSTARGOFF(lv) = AvFILLp(arg) - index;
+			    LvTARGLEN(lv) = 1;
+			}
 		}
 		SvREFCNT_dec(arg);
 		if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
diff --git a/pp_hot.c b/pp_hot.c
index be16eae..3b96643 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2728,9 +2728,20 @@ try_autoload:
 	    const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
 
 	    if (items) {
+		SSize_t i = 0;
 		/* Mark is at the end of the stack. */
 		EXTEND(SP, items);
-		Copy(AvARRAY(av), SP + 1, items, SV*);
+		for (; i < items; ++i)
+		    if (AvARRAY(av)[i]) SP[i+1] = AvARRAY(av)[i];
+		    else {
+			SV * const lv = sv_2mortal(newSV_type(SVt_PVLV));
+			SP[i+1] = lv;
+			LvTYPE(lv) = 'y';
+			sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
+			LvTARG(lv) = SvREFCNT_inc_simple_NN(av);
+			LvSTARGOFF(lv) = i;
+			LvTARGLEN(lv) = 1;
+		    }
 		SP += items;
 		PUTBACK ;		
 	    }
diff --git a/t/op/goto.t b/t/op/goto.t
index 37b69e3..1336685 100644
--- a/t/op/goto.t
+++ b/t/op/goto.t
@@ -10,7 +10,7 @@ BEGIN {
 
 use warnings;
 use strict;
-plan tests => 89;
+plan tests => 91;
 our $TODO;
 
 my $deprecated = 0;
@@ -481,6 +481,15 @@ is "@__", chr 256, 'goto &xsub with replaced *_{ARRAY}';
 sub { *__ = \@_;  goto &null } -> ("rough and tubbery");
 is ${*__}[0], 'rough and tubbery', 'goto &foo leaves reified @_ alone';
 
+# goto &xsub when @_ has nonexistent elements
+{
+    no warnings "uninitialized";
+    local @_ = ();
+    $#_++;
+    & {sub { goto &utf8::encode }};
+    is @_, 1, 'num of elems in @_ after goto &xsub with nonexistent $_[0]';
+    is $_[0], "", 'content of nonexistent $_[0] is modified by goto &xsub';
+}
 
 # [perl #36521] goto &foo in warn handler could defeat recursion avoider
 
diff --git a/t/op/sub.t b/t/op/sub.t
index fc04ac8..bbb9d76 100644
--- a/t/op/sub.t
+++ b/t/op/sub.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan( tests => 27 );
+plan( tests => 29 );
 
 sub empty_sub {}
 
@@ -165,3 +165,13 @@ is eval {
     is $w, undef,
       '*keyword = sub():method{$y} does not cause ambiguity warnings';
 }
+
+# &xsub when @_ has nonexistent elements
+{
+    no warnings "uninitialized";
+    local @_ = ();
+    $#_++;
+    &utf8::encode;
+    is @_, 1, 'num of elems in @_ after &xsub with nonexistent $_[0]';
+    is $_[0], "", 'content of nonexistent $_[0] is modified by &xsub';
+}
-- 
2.7.4