deparse subroutine signatures

If 'use feature "signatures"' is in scope, deparse subs using the

    sub foo ($a,$b) { ... }

syntax rather than

    sub foo {
        my $a = $_[0];
        my $b = $_[0];
        ...
    }

Only do this where the sequence of OP_SIGCHECK and OP_SIGELEM etc ops
make up a consistent signature. Otherwise (e.g. someone's modified
it with a parser hook), fall back to 'my $a = $_[0]' syntax.

diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index c8cea77..731e9ce 100644 (file)
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -1203,6 +1203,104 @@ sub pad_subs {
        sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}}, @todo
 }
 
+
+# deparse_argops(): deparse, if possible, a sequence of argcheck + argelem
+# ops into a subroutine signature. If successful, return the first op
+# following the signature ops plus the signature string; else return the
+# empty list.
+#
+# Normally a bunch of argelem ops will have been generated by the
+# signature parsing, but it's possible that ops have been added manually
+# or altered. In this case we "return ()" and fall back to general
+# deparsing of the individual sigelems as 'my $x = $_[N]' etc.
+#
+# We're only called if the first two ops are nextstate and argcheck.
+
+sub deparse_argops {
+    my ($self, $firstop, $cv) = @_;
+
+    my @sig;
+    my $o = $firstop;
+    return if $o->label; #first nextstate;
+
+    # OP_ARGCHECK
+
+    $o = $o->sibling;
+    my ($params, $opt_params, $slurpy) = $o->aux_list($cv);
+    my $mandatory = $params - $opt_params;
+    my $seen_slurpy = 0;
+    my $last_ix = -1;
+
+    # keep looking for valid nextstate + argelem pairs
+
+    while (1) {
+        # OP_NEXTSTATE
+        $o = $o->sibling;
+        last unless $$o;
+        last unless $o->name =~ /^(next|db)state$/;
+        last if $o->label;
+
+        # OP_ARGELEM
+        my $o2 = $o->sibling;
+        last unless $$o2;
+
+        if ($o2->name eq 'argelem') {
+            my $ix  = $o2->string($cv);
+            while (++$last_ix < $ix) {
+                push @sig, $last_ix <  $mandatory ? '$' : '$=';
+            }
+            my $var = $self->padname($o2->targ);
+            if ($var =~ /^[@%]/) {
+                return if $seen_slurpy;
+                $seen_slurpy = 1;
+                return if $ix != $params or !$slurpy
+                            or substr($var,0,1) ne $slurpy;
+            }
+            else {
+                return if $ix >= $params;
+            }
+            if ($o2->flags & OPf_KIDS) {
+                my $kid = $o2->first;
+                return unless $$kid and $kid->name eq 'argdefelem';
+                my $def = $self->deparse($kid->first, 7);
+                $def = "($def)" if $kid->first->flags & OPf_PARENS;
+                $var .= " = $def";
+            }
+            push @sig, $var;
+        }
+        elsif ($o2->name eq 'null'
+               and ($o2->flags & OPf_KIDS)
+               and $o2->first->name eq 'argdefelem')
+        {
+            # special case - a void context default expression: $ = expr
+
+            my $defop = $o2->first;
+            my $ix = $defop->targ;
+            while (++$last_ix < $ix) {
+                push @sig, $last_ix <  $mandatory ? '$' : '$=';
+            }
+            return if $last_ix >= $params
+                    or $last_ix < $mandatory;
+            my $def = $self->deparse($defop->first, 7);
+            $def = "($def)" if $defop->first->flags & OPf_PARENS;
+            push @sig, '$ = ' . $def;
+        }
+        else {
+            last;
+        }
+
+        $o = $o2;
+    }
+
+    while (++$last_ix < $params) {
+        push @sig, $last_ix <  $mandatory ? '$' : '$=';
+    }
+    push @sig, $slurpy if $slurpy and !$seen_slurpy;
+
+    return ($o, join(', ', @sig));
+}
+
+
 sub deparse_sub {
     my $self = shift;
     my $cv = shift;
@@ -1242,12 +1340,32 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
        $self->pessimise($root, $cv->START);
        my $lineseq = $root->first;
        if ($lineseq->name eq "lineseq") {
-           my @ops;
-           for(my$o=$lineseq->first; $$o; $o=$o->sibling) {
+           my $firstop = $lineseq->first;
+
+            if ($has_sig) {
+                my $o2;
+                # try to deparse first few ops as a signature if possible
+                if (     $$firstop
+                     and $firstop->name =~  /^(next|db)state$/
+                     and (($o2 = $firstop->sibling))
+                     and $$o2)
+                {
+                    if ($o2->name eq 'argcheck') {
+                        my ($nexto, $sig) = $self->deparse_argops($firstop, $cv);
+                        if (defined $nexto) {
+                            $firstop = $nexto;
+                            $protosig = $sig;
+                        }
+                    }
+                }
+            }
+
+            my @ops;
+           for (my $o = $firstop; $$o; $o=$o->sibling) {
                push @ops, $o;
            }
            $body = $self->lineseq(undef, 0, @ops).";";
-            if ($ops[-1]->name =~ /^(next|db)state$/) {
+            if (!$has_sig and $ops[-1]->name =~ /^(next|db)state$/) {
                 # this handles void context in
                 #   use feature signatures; sub ($=1) {}
                 $body .= "\n()";
@@ -5846,6 +5964,8 @@ sub pp_argdefelem {
     my($op, $cx) = @_;
     my $ix  = $op->targ;
     my $expr = "\@_ >= " . ($ix+1) . " ? \$_[$ix] : ";
+    my $def = $self->deparse($op->first, 7);
+    $def = "($def)" if $op->first->flags & OPf_PARENS;
     $expr .= $self->deparse($op->first, $cx);
     return $expr;
 }

diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
index 2cc415e..7d65d74 100644 (file)
--- a/lib/B/Deparse.t
+++ b/lib/B/Deparse.t
@@ -2490,3 +2490,97 @@ $_ ^= $_;
 $_ |.= $_;
 $_ &.= $_;
 $_ ^.= $_;
+####
+####
+# Should really use 'no warnings "experimental::signatures"',
+# but it doesn't yet deparse correctly.
+# anon subs used because this test framework doesn't deparse named subs
+# in the DATA code snippets.
+#
+# general signature
+no warnings;
+use feature 'signatures';
+my $x;
+sub ($a, $, $b = $glo::bal, $c = $a, $d = 'foo', $e = -37, $f = 0, $g = 1, $h = undef, $i = $a + 1, $j = /foo/, @) {
+    $x++;
+}
+;
+$x++;
+####
+# Signature and prototype
+no warnings;
+use feature 'signatures';
+my $x;
+sub ($a, $b) : prototype($$) {
+    $x++;
+}
+;
+$x++;
+####
+# Signature and prototype and attrs
+no warnings;
+use feature 'signatures';
+my $x;
+sub ($a, $b) : prototype($$) lvalue {
+    $x++;
+}
+;
+$x++;
+####
+# Signature and attrs
+no warnings;
+use feature 'signatures';
+my $x;
+sub ($a, $b) : lvalue method {
+    $x++;
+}
+;
+$x++;
+####
+# named array slurp, null body
+no warnings;
+use feature 'signatures';
+sub (@a) {
+    ;
+}
+;
+####
+# named hash slurp
+no warnings;
+use feature 'signatures';
+sub ($key, %h) {
+    $h{$key};
+}
+;
+####
+# anon hash slurp
+no warnings;
+use feature 'signatures';
+sub ($a, %) {
+    $a;
+}
+;
+####
+# parenthesised default arg
+no warnings;
+use feature 'signatures';
+sub ($a, $b = (/foo/), $c = 1) {
+    $a + $b + $c;
+}
+;
+####
+# parenthesised default arg with TARGMY
+no warnings;
+use feature 'signatures';
+sub ($a, $b = ($a + 1), $c = 1) {
+    $a + $b + $c;
+}
+;
+####
+# empty default
+no warnings;
+use feature 'signatures';
+sub ($a, $=) {
+    $a;
+}
+;