Deparse my var attributes correctly

Formerly this:

    my $x :foo;

deparsed as

    'attributes'->import('main', \$x, 'foo'), my $x;

it now deparses as:

    my $x :foo;

It handles all the common forms, such as

    my Foo::Bar ($s, @a, %h) :foo(foo1) bar(bar1);

but doesn't yet handle an attribute declaration that's not a statement,
e.g.

    f(1, $x :foo);

Under TEST -deparse, this fixes the following unexpectedly failing
scripts:

    ../dist/IO/t/io_file_export.t
    ../dist/IO/t/io_multihomed.t
    ../dist/IO/t/io_udp.t
    ../dist/Thread-Queue/t/02_refs.t
    ../dist/Thread-Semaphore/t/01_basic.t
    ../dist/Thread-Semaphore/t/04_nonblocking.t
    ../dist/Thread-Semaphore/t/05_force.t
    ../dist/Thread-Semaphore/t/06_timed.t
    ../dist/threads-shared/t/av_refs.t
    ../dist/threads-shared/t/blessed.t
    ../dist/threads-shared/t/clone.t
    ../dist/threads-shared/t/cond.t
    ../dist/threads-shared/t/dualvar.t
    ../dist/threads-shared/t/hv_refs.t
    ../dist/threads-shared/t/object.t
    ../dist/threads-shared/t/object2.t
    ../dist/threads-shared/t/shared_attr.t
    ../dist/threads-shared/t/sv_refs.t
    ../dist/threads-shared/t/utf8.t
    ../dist/threads-shared/t/wait.t
    ../dist/threads-shared/t/waithires.t
    ../dist/threads/t/err.t
    ../dist/threads/t/free.t
    ../dist/threads/t/join.t
    ../dist/threads/t/kill.t
    ../dist/threads/t/kill2.t
    ../dist/threads/t/libc.t
    ../dist/threads/t/problems.t
    ../dist/threads/t/state.t
    op/threads-dirh.t

and fixes the following expected-to-fail scripts:

    ../dist/Thread-Queue/t/08_nothreads.t
    ../dist/threads/t/exit.t
    ../dist/threads/t/thread.t
    op/attrs.t
    op/getpid.t

2 files changed, 187 insertions, 0 deletions

diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index dd61739260..bf45482635 100644
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -3535,9 +3535,167 @@ BEGIN {
     delete @uses_intro{qw( lvref lvrefslice lvavref entersub )};
 }
 
+
+# Look for a my attribute declaration in a list or ex-list. Returns undef
+# if not found, 'my($x, @a) :Foo(bar)' etc otherwise.
+#
+# There are three basic tree structs that are expected:
+#
+# my $x :foo;
+#      <1> ex-list vK/LVINTRO ->c
+#         <0> ex-pushmark v ->3
+#         <1> entersub[t2] vKRS*/TARG ->b
+#                ....
+#         <0> padsv[$x:64,65] vM/LVINTRO ->c
+#
+# my @a :foo;
+# my %h :foo;
+#
+#      <1> ex-list vK ->c
+#         <0> ex-pushmark v ->3
+#         <0> padav[@a:64,65] vM/LVINTRO ->4
+#         <1> entersub[t2] vKRS*/TARG ->c
+#            ....
+#
+# my ($x,@a,%h) :foo;
+#
+#      <;> nextstate(main 64 -e:1) v:{ ->3
+#      <@> list vKP ->w
+#         <0> pushmark vM/LVINTRO ->4
+#         <0> padsv[$x:64,65] vM/LVINTRO ->5
+#         <0> padav[@a:64,65] vM/LVINTRO ->6
+#         <0> padhv[%h:64,65] vM/LVINTRO ->7
+#         <1> entersub[t4] vKRS*/TARG ->f
+#            ....
+#         <1> entersub[t5] vKRS*/TARG ->n
+#            ....
+#         <1> entersub[t6] vKRS*/TARG ->v
+#           ....
+# where the entersub in all cases looks like
+#        <1> entersub[t2] vKRS*/TARG ->c
+#           <0> pushmark s ->5
+#           <$> const[PV "attributes"] sM ->6
+#           <$> const[PV "main"] sM ->7
+#           <1> srefgen sKM/1 ->9
+#              <1> ex-list lKRM ->8
+#                 <0> padsv[@a:64,65] sRM ->8
+#           <$> const[PV "foo"] sM ->a
+#           <.> method_named[PV "import"] ->b
+
+sub maybe_my_attr {
+    my ($self, $op, $cx) = @_;
+
+    my $kid = $op->first->sibling; # skip pushmark
+    return if class($kid) eq 'NULL';
+
+    my $lop;
+    my $type;
+
+    # Extract out all the pad ops and entersub ops into
+    # @padops and @entersubops. Return if anything else seen.
+    # Also determine what class (if any) all the pad vars belong to
+    my $class;
+    my (@padops, @entersubops);
+    for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
+	my $lopname = $lop->name;
+	my $loppriv = $lop->private;
+        if ($lopname =~ /^pad[sah]v$/) {
+            return unless $loppriv & OPpLVAL_INTRO;
+            return if     $loppriv & OPpPAD_STATE;
+
+            my $padname = $self->padname_sv($lop->targ);
+            my $thisclass = ($padname->FLAGS & SVpad_TYPED)
+                                ? $padname->SvSTASH->NAME : 'main';
+
+            # all pad vars must be in the same class
+            $class //= $thisclass;
+            return unless $thisclass eq $class;
+
+            push @padops, $lop;
+        }
+        elsif ($lopname eq 'entersub') {
+            push @entersubops, $lop;
+        }
+        else {
+            return;
+        }
+    }
+
+    return unless @padops && @padops == @entersubops;
+
+    # there should be a balance: each padop has a corresponding
+    # 'attributes'->import() method call, in the same order.
+
+    my @varnames;
+    my $attr_text;
+
+    for my $i (0..$#padops) {
+        my $padop = $padops[$i];
+        my $esop  = $entersubops[$i];
+
+        push @varnames, $self->padname($padop->targ);
+
+        return unless ($esop->flags & OPf_KIDS);
+
+        my $kid = $esop->first;
+        return unless $kid->type == OP_PUSHMARK;
+
+        $kid = $kid->sibling;
+        return unless $$kid && $kid->type == OP_CONST;
+	return unless $self->const_sv($kid)->PV eq 'attributes';
+
+        $kid = $kid->sibling;
+        return unless $$kid && $kid->type == OP_CONST; # __PACKAGE__
+
+        $kid = $kid->sibling;
+        return unless  $$kid
+                    && $kid->name eq "srefgen"
+                    && ($kid->flags & OPf_KIDS)
+                    && ($kid->first->flags & OPf_KIDS)
+                    && $kid->first->first->name =~ /^pad[sah]v$/
+                    && $kid->first->first->targ == $padop->targ;
+
+        $kid = $kid->sibling;
+        my @attr;
+        while ($$kid) {
+            last if ($kid->type != OP_CONST);
+            push @attr, $self->const_sv($kid)->PV;
+            $kid = $kid->sibling;
+        }
+        return unless @attr;
+        my $thisattr = ":" . join(' ', @attr);
+        $attr_text //= $thisattr;
+        # all import calls must have the same list of attributes
+        return unless $attr_text eq $thisattr;
+
+        return unless $kid->name eq 'method_named';
+	return unless $self->meth_sv($kid)->PV eq 'import';
+
+        $kid = $kid->sibling;
+        return if $$kid;
+    }
+
+    my $res = 'my';
+    $res .= " $class " if $class ne 'main';
+    $res .=
+            (@varnames > 1)
+            ? "(" . join(', ', @varnames) . ')'
+            : " $varnames[0]";
+
+    return "$res $attr_text";
+}
+
+
 sub pp_list {
     my $self = shift;
     my($op, $cx) = @_;
+
+    {
+        # might be my ($s,@a,%h) :Foo(bar);
+        my $my_attr = maybe_my_attr($self, $op, $cx);
+        return $my_attr if defined $my_attr;
+    }
+
     my($expr, @exprs);
     my $kid = $op->first->sibling; # skip pushmark
     return '' if class($kid) eq 'NULL';
@@ -3831,6 +3989,13 @@ sub _op_is_or_was {
 
 sub pp_null {
     my($self, $op, $cx) = @_;
+
+    # might be 'my $s :Foo(bar);'
+    if ($op->targ == OP_LIST) {
+        my $my_attr = maybe_my_attr($self, $op, $cx);
+        return $my_attr if defined $my_attr;
+    }
+
     if (class($op) eq "OP") {
 	# old value is lost
 	return $self->{'ex_const'} if $op->targ == OP_CONST;
diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
index 4361967e6e..ab03ed7235 100644
--- a/lib/B/Deparse.t
+++ b/lib/B/Deparse.t
@@ -2627,3 +2627,25 @@ my $r2 = qr/$a(?{ my($x, $y) = (); })/;
 /a\ b/x;
 /a\	b/;
 /a\	b/x;
+####
+# my attributes
+my $s1 :foo(f1, f2) bar(b1, b2);
+my @a1 :foo(f1, f2) bar(b1, b2);
+my %h1 :foo(f1, f2) bar(b1, b2);
+my($s2, @a2, %h2) :foo(f1, f2) bar(b1, b2);
+####
+# my class attributes
+package Foo::Bar;
+my Foo::Bar $s1 :foo(f1, f2) bar(b1, b2);
+my Foo::Bar @a1 :foo(f1, f2) bar(b1, b2);
+my Foo::Bar %h1 :foo(f1, f2) bar(b1, b2);
+my Foo::Bar ($s2, @a2, %h2) :foo(f1, f2) bar(b1, b2);
+package main;
+my Foo::Bar $s3 :foo(f1, f2) bar(b1, b2);
+my Foo::Bar @a3 :foo(f1, f2) bar(b1, b2);
+my Foo::Bar %h3 :foo(f1, f2) bar(b1, b2);
+my Foo::Bar ($s4, @a4, %h4) :foo(f1, f2) bar(b1, b2);
+####
+# avoid false positives in my $x :attribute
+'attributes'->import('main', \my $x1, 'foo(bar)'), my $y1;
+'attributes'->import('Fooo', \my $x2, 'foo(bar)'), my $y2;