Fix my + attrs + list assignment

This script works in 5.6.x:

#!perl -l
sub MODIFY_SCALAR_ATTRIBUTES { return } # need these
sub MODIFY_ARRAY_ATTRIBUTES  {  return } # for it to
sub MODIFY_HASH_ATTRIBUTES   {   return } # compile
my ($x,@y,%z) : Bent = 72; # based on example from attributes.pm’s pod
print $x;
print "ok";

$ pbpaste|perl5.6.2
72
ok

(pbpaste is a Mac command that outputs the clipboard contents.)

In 5.8.0 to 5.8.8:

$ pbpaste|perl5.8.1

ok

So the assignment never happens. And with warnings:

$ pbpaste|perl5.8.1 -w
Bizarre copy of ARRAY in aassign at - line 5.

In 5.8.9 it gets slightly worse:

$ pbpaste|perl5.8.9
Bizarre copy of ARRAY in aassign at - line 5.

So warnings are not required to trigger the error. If my ($x,@y,%z)
is changed to my($x,$y), there is no error, but the assignment
doesn’t happen.

This was broken in 5.8.0 by this change:

commit 95f0a2f1ffc68ef908768ec5d39e4102afd28c1e
Author: Spider Boardman <spider@orb.nashua.nh.us>
Date:   Sat Dec 8 19:09:23 2001 -0500

    Re: attributes are broken
    Message-Id: <200112090509.AAA02053@Orb.Nashua.NH.US>

    p4raw-id: //depot/perl@13543

(Is there a ‘hereby’ missing from that subject? :-)

Oddly enough, that was the commit that put the attribute and list
assignment example in attribute.pm’s pod.

This change caused the bizarre assignment error to occur more often in
5.8.9 and 5.10.0, but I don’t think it’s actually relevant (just try-
ng to see how long I can get this commit message):

commit f17e6c41cacfbc6fe88a5ea5e01ba690dfdc7f2e
Author: Rafael Garcia-Suarez <rgarciasuarez@gmail.com>
Date:   Wed Jul 5 20:00:10 2006 +0000

    Fix a bug on setting OPpASSIGN_COMMON on a AASSIGN op when the left
    side is made out a list declared with our(). In this case OPpLVAL_INTRO
    isn't set on the left op, so we just remove that check. Add new tests.

    p4raw-id: //depot/perl@28488

What’s happening is that there is an extra pushmark in the list when
attributes are present:

$ perl5.14.0 -MO=Concise  -e 'my ($a,@b):foo'
o  <@> leave[1 ref] vKP/REFC ->(end)
1     <0> enter ->2
2     <;> nextstate(main 39 -e:1) v:{ ->3
n     <@> list vKPM/128 ->o
3        <0> pushmark vM/128 ->4
4        <0> padsv[$a:39,40] vM/LVINTRO ->5
5        <0> padav[@b:39,40] vM/LVINTRO ->6
6        <0> pushmark v ->7              <------- right here
e        <1> entersub[t3] vKS*/NOMOD,TARG ->f
7           <0> pushmark s ->8
8           <$> const[PV "attributes"] sM ->9
9           <$> const[PV "main"] sM ->a
b           <1> srefgen sKM/1 ->c
-              <1> ex-list lKRM ->b
a                 <0> padsv[$a:39,40] sRM ->b
c           <$> const[PV "foo"] sM ->d
d           <$> method_named[PV "import"] ->e
m        <1> entersub[t4] vKS*/NOMOD,TARG ->n
f           <0> pushmark s ->g
g           <$> const[PV "attributes"] sM ->h
h           <$> const[PV "main"] sM ->i
j           <1> srefgen sKM/1 ->k
-              <1> ex-list lKRM ->j
i                 <0> padsv[@b:39,40] sRM ->j
k           <$> const[PV "foo"] sM ->l
l           <$> method_named[PV "import"] ->m
-e syntax OK

That leaves an extra mark that confuses pp_aassign, which doesn’t know
what it’s supposed to be reading and what it’s supposed to be assign-
ing to (hence the bizarre copy).

The pushmark is the result of the concatenation of two lists, the sec-
ond one beginning with a pushmark (as listops do by default). The con-
catenation occurs in Perl_my_attrs, at this spot (in the ‘else’):

    if (rops) {
	if (maybe_scalar && o->op_type == OP_PADSV) {
	    o = scalar(op_append_list(OP_LIST, rops, o));
	    o->op_private |= OPpLVAL_INTRO;
	}
	else
	    o = op_append_list(OP_LIST, o, rops);
    }

So this commit make that ‘else’ clause check for a pushmark and oblit-
erate it if present, before concatenating the lists.

3 files changed, 28 insertions, 1 deletions

diff --git a/op.c b/op.c
index cddf5b81b9..ecbf4c53d6 100644
--- a/op.c
+++ b/op.c
@@ -2243,8 +2243,19 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs)
 	    o = scalar(op_append_list(OP_LIST, rops, o));
 	    o->op_private |= OPpLVAL_INTRO;
 	}
-	else
+	else {
+	    /* The listop in rops might have a pushmark at the beginning,
+	       which will mess up list assignment. */
+	    LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
+	    if (rops->op_type == OP_LIST && 
+	        lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
+	    {
+		OP * const pushmark = lrops->op_first;
+		lrops->op_first = pushmark->op_sibling;
+		op_free(pushmark);
+	    }
 	    o = op_append_list(OP_LIST, o, rops);
+	}
     }
     PL_parser->in_my = FALSE;
     PL_parser->in_my_stash = NULL;
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index a47980a070..2d3b19c07c 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -604,6 +604,12 @@ hashes being returned).  Now a more general fix has been applied
 
 =back
 
+=item *
+
+List assignment to lexical variables declared with attributes in the same
+statement (C<my ($x,@y) : blimp = (72,94)>) stopped working in Perl 5.8.0.
+It has now been fixed.
+
 =back
 
 =head1 Known Problems
diff --git a/t/op/attrs.t b/t/op/attrs.t
index 89becf6aa9..f237e5300e 100644
--- a/t/op/attrs.t
+++ b/t/op/attrs.t
@@ -322,4 +322,14 @@ foreach my $test (@tests) {
   is $x_values, '00', 'state with attributes';
 }
 
+{
+  package ningnangnong;
+  sub MODIFY_SCALAR_ATTRIBUTES{}
+  sub MODIFY_ARRAY_ATTRIBUTES{  }
+  sub MODIFY_HASH_ATTRIBUTES{    }
+  my ($cows, @go, %bong) : teapots = qw[ jibber jabber joo ];
+  ::is $cows, 'jibber', 'list assignment to scalar with attrs';
+  ::is "@go", 'jabber joo', 'list assignment to array with attrs';
+}
+
 done_testing();