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.

diff --git a/pp_ctl.c b/pp_ctl.c
index 4ce8ddb..b7b3598 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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';
+}