[perl #128260] Fix \substr %h

This is a follow-up to 79409ac8, which propagated substr’s own lvalue
context to the first argument only if it was one that would not croak
at compile time.

We can’t propagate OP_REFGEN lvalue context to the first argument,
as it causes the same bug for which #128260 was originally reported;
namely, that it prevents a hash or array from being flattened, causing
an unflattened aggregate to follow code paths that expect only sca-
lars, resulting in assertion failures:

$ ./perl -Ilib -e '%h=1..100; print ${\substr %h, 0}'
Assertion failed: (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVFM), function Perl_sv_2pv_flags, file sv.c, line 2924.
Abort trap: 6
$ ./perl -Ilib -e '@h=1..100; print ${\vec @a, 0, 1}'
Assertion failed: (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVFM), function Perl_sv_2pv_flags, file sv.c, line 2924.
Abort trap: 6

diff --git a/op.c b/op.c
index be6e7b7..8008a21 100644 (file)
--- a/op.c
+++ b/op.c
@@ -3062,11 +3062,14 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
        if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
            /* substr and vec */
            /* If this op is in merely potential (non-fatal) modifiable
-              context, then propagate that context to the kid op.  Other-
+              context, then apply OP_ENTERSUB context to
+              the kid op (to avoid croaking).  Other-
               wise pass this op’s own type so the correct op is mentioned
               in error messages.  */
            op_lvalue(OpSIBLING(cBINOPo->op_first),
-                     S_potential_mod_type(type) ? type : o->op_type);
+                     S_potential_mod_type(type)
+                       ? OP_ENTERSUB
+                       : o->op_type);
        }
        break;
 

diff --git a/t/op/substr.t b/t/op/substr.t
index eae2403..83e7bae 100644 (file)
--- a/t/op/substr.t
+++ b/t/op/substr.t
@@ -22,7 +22,7 @@ $SIG{__WARN__} = sub {
      }
 };
 
-plan(388);
+plan(390);
 
 run_tests() unless caller;
 
@@ -839,6 +839,14 @@ is $o::count, 1, 'assigning utf8 overload to substr lvalue calls ovld 1ce';
 # [perl #7678] core dump with substr reference and localisation
 {$b="abcde"; local $k; *k=\substr($b, 2, 1);}
 
+# [perl #128260] assertion failure with \substr %h, \substr @h
+{
+    my %h = 1..100;
+    my @a = 1..100;
+    is ${\substr %h, 0}, scalar %h, '\substr %h';
+    is ${\substr @a, 0}, scalar @a, '\substr @a';
+}
+
 } # sub run_tests - put tests above this line that can run in threads
 
 

diff --git a/t/op/vec.t b/t/op/vec.t
index 33aedab..ea63317 100644 (file)
--- a/t/op/vec.t
+++ b/t/op/vec.t
@@ -6,7 +6,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan( tests => 35 );
+plan( tests => 37 );
 
 
 is(vec($foo,0,1), 0);
@@ -127,3 +127,11 @@ like($@, qr/^Modification of a read-only value attempted at /,
     $v = vec($x, 0, 8);
     is($v, 255, "downgraded utf8 try 2");
 }
+
+# [perl #128260] assertion failure with \vec %h, \vec @h
+{
+    my %h = 1..100;
+    my @a = 1..100;
+    is ${\vec %h, 0, 1}, vec(scalar %h, 0, 1), '\vec %h';
+    is ${\vec @a, 0, 1}, vec(scalar @a, 0, 1), '\vec @a';
+}