diff options
| -rw-r--r-- | lib/B/Deparse.pm | 126 | ||||
| -rw-r--r-- | lib/B/Deparse.t | 94 |
2 files changed, 217 insertions, 3 deletions
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm index c8cea77316..731e9cefc4 100644 --- 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 2cc415e746..7d65d74581 100644 --- 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; +} +; |