Deparse: fix scalar-proto sub calls without arguments

- fix (;$)
- remove infinite loops from check_proto()
- implement (+)
- fix (\@) and (\%)

Fixes GH #20989.

2 files changed, 156 insertions, 54 deletions

diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index 1abd40ccbb..fdb4d60463 100644
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -7,7 +7,7 @@
 # This is based on the module of the same name by Malcolm Beattie,
 # but essentially none of his code remains.
 
-package B::Deparse 1.72;
+package B::Deparse 1.73;
 use strict;
 use Carp;
 use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
@@ -1554,7 +1554,7 @@ sub maybe_parens_func {
     if ($prec <= $cx or substr($text, 0, 1) eq "(" or $self->{'parens'}) {
 	return "$func($text)";
     } else {
-	return "$func $text";
+        return $func . (length($text) ? " $text" : "");
     }
 }
 
@@ -5050,78 +5050,92 @@ sub e_method {
 sub check_proto {
     my $self = shift;
     return "&" if $self->{'noproto'};
-    my($proto, @args) = @_;
-    my($arg, $real);
+    my ($proto, @args) = @_;
     my $doneok = 0;
     my @reals;
-    # An unbackslashed @ or % gobbles up the rest of the args
-    1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
-    $proto =~ s/^\s*//;
-    while ($proto) {
-	$proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;|)\s*//;
+    $proto =~ s/^\s+//;
+    while (length $proto) {
+        $proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|[_+;])\s*//
+            or return "&";  # malformed prototype
 	my $chr = $1;
-	if ($chr eq "") {
-	    return "&" if @args;
-	} elsif ($chr eq ";") {
+        if ($chr eq ";") {
 	    $doneok = 1;
-	} elsif ($chr eq "@" or $chr eq "%") {
+        } elsif ($chr eq '@' or $chr eq '%') {
+            # An unbackslashed @ or % gobbles up the rest of the args
 	    push @reals, map($self->deparse($_, 6), @args);
 	    @args = ();
+            $proto = '';
+        } elsif (!@args) {
+            last if $doneok;
+            return "&"; # too few args and no ';'
 	} else {
-	    $arg = shift @args;
-	    last unless $arg;
-	    if ($chr eq "\$" || $chr eq "_") {
+            my $arg = shift @args;
+            if ($chr eq '$' || $chr eq '_') {
 		if (want_scalar $arg) {
 		    push @reals, $self->deparse($arg, 6);
 		} else {
 		    return "&";
 		}
 	    } elsif ($chr eq "&") {
-		if ($arg->name =~ /^(s?refgen|undef)$/) {
+                if ($arg->name =~ /^(?:s?refgen|undef)\z/) {
 		    push @reals, $self->deparse($arg, 6);
 		} else {
 		    return "&";
 		}
 	    } elsif ($chr eq "*") {
-		if ($arg->name =~ /^s?refgen$/
+                if ($arg->name =~ /^s?refgen\z/
 		    and $arg->first->first->name eq "rv2gv")
-		  {
-		      $real = $arg->first->first; # skip refgen, null
-		      if ($real->first->name eq "gv") {
-			  push @reals, $self->deparse($real, 6);
-		      } else {
-			  push @reals, $self->deparse($real->first, 6);
-		      }
-		  } else {
-		      return "&";
-		  }
+                {
+                    my $real = $arg->first->first; # skip refgen, null
+                    if ($real->first->name eq "gv") {
+                        push @reals, $self->deparse($real, 6);
+                    } else {
+                        push @reals, $self->deparse($real->first, 6);
+                    }
+                } else {
+                    return "&";
+                }
+            } elsif ($chr eq "+") {
+                my $real;
+                if ($arg->name =~ /^s?refgen\z/ and
+                    !null($real = $arg->first) and
+                    !null($real->first) and
+                    $real->first->name =~ /^(?:rv2|pad)[ah]v\z/)
+                {
+                    push @reals, $self->deparse($real, 6);
+                } elsif (want_scalar $arg) {
+                    push @reals, $self->deparse($arg, 6);
+                } else {
+                    return "&";
+                }
 	    } elsif (substr($chr, 0, 1) eq "\\") {
 		$chr =~ tr/\\[]//d;
-		if ($arg->name =~ /^s?refgen$/ and
+                my $real;
+                if ($arg->name =~ /^s?refgen\z/ and
 		    !null($real = $arg->first) and
 		    ($chr =~ /\$/ && is_scalar($real->first)
 		     or ($chr =~ /@/
-			 && class($real->first->sibling) ne 'NULL'
-			 && $real->first->sibling->name
-			 =~ /^(rv2|pad)av$/)
+                         && !null($real->first)
+                         && $real->first->name =~ /^(?:rv2|pad)av\z/)
 		     or ($chr =~ /%/
-			 && class($real->first->sibling) ne 'NULL'
-			 && $real->first->sibling->name
-			 =~ /^(rv2|pad)hv$/)
+                         && !null($real->first)
+                         && $real->first->name =~ /^(?:rv2|pad)hv\z/)
 		     #or ($chr =~ /&/ # This doesn't work
 		     #   && $real->first->name eq "rv2cv")
 		     or ($chr =~ /\*/
 			 && $real->first->name eq "rv2gv")))
-		  {
-		      push @reals, $self->deparse($real, 6);
-		  } else {
-		      return "&";
-		  }
-	    }
-       }
+                {
+                    push @reals, $self->deparse($real, 6);
+                } else {
+                    return "&";
+                }
+            } else {
+                # should not happen
+                return "&";
+            }
+        }
     }
-    return "&" if $proto and !$doneok; # too few args and no ';'
-    return "&" if @args;               # too many args
+    return "&" if @args; # too many args
     return ("", join ", ", @reals);
 }
 
@@ -5301,19 +5315,23 @@ sub pp_entersub {
 	# it back.
 	$kid =~ s/^CORE::GLOBAL:://;
 
-	my $dproto = defined($proto) ? $proto : "undefined";
-	my $scalar_proto = $dproto =~ /^;*(?:[\$*_+]|\\.|\\\[[^]]\])\z/;
         if (!$declared) {
 	    return "$kid(" . $args . ")";
-	} elsif ($dproto =~ /^\s*\z/) {
+        }
+
+        my $dproto = defined($proto) ? $proto : "undefined";
+        if ($dproto =~ /^\s*\z/) {
 	    return $kid;
-	} elsif ($scalar_proto and is_scalar($exprs[0])) {
+        }
+
+        my $scalar_proto = $dproto =~ /^ \s* (?: ;\s* )* (?: [\$*_+] |\\ \s* (?: [\$\@%&*] | \[ [^\]]+ \] ) ) \s* \z/x;
+        if ($scalar_proto and !@exprs || is_scalar($exprs[0])) {
 	    # is_scalar is an excessively conservative test here:
 	    # really, we should be comparing to the precedence of the
 	    # top operator of $exprs[0] (ala unop()), but that would
 	    # take some major code restructuring to do right.
 	    return $self->maybe_parens_func($kid, $args, $cx, 16);
-	} elsif (not $scalar_proto and defined($proto) || $simple) { #'
+        } elsif (not $scalar_proto and defined($proto) || $simple) {
 	    return $self->maybe_parens_func($kid, $args, $cx, 5);
 	} else {
 	    return "$kid(" . $args . ")";
diff --git a/lib/B/Deparse.t b/lib/B/Deparse.t
index ae1372f630..8cd3fb4d27 100644
--- a/lib/B/Deparse.t
+++ b/lib/B/Deparse.t
@@ -2134,7 +2134,7 @@ print f();
     {
       foo();
       my sub b;
-      b ;
+      b;
       main::b();
       &main::b;
       &main::b();
@@ -2150,7 +2150,7 @@ print f();
 ();
 state sub sb2;
 sub sb2 {
-    sb2 ;
+    sb2;
 }
 ####
 # lexical subroutine with outer declaration and inner definition
@@ -2236,6 +2236,14 @@ optoptwack($a = $b);
 wackbrack($a = $b);
 optwackbrack($a = $b);
 optoptwackbrack($a = $b);
+optbar;
+optoptbar;
+optplus;
+optoptplus;
+optwack;
+optoptwack;
+optwackbrack;
+optoptwackbrack;
 >>>>
 package prototest;
 dollar($a < $b);
@@ -2247,15 +2255,91 @@ optoptdollar($a < $b);
 bar($a < $b);
 optbar($a < $b);
 optoptbar($a < $b);
-&plus($a < $b);
-&optplus($a < $b);
-&optoptplus($a < $b);
+plus($a < $b);
+optplus($a < $b);
+optoptplus($a < $b);
 &wack(\($a = $b));
 &optwack(\($a = $b));
 &optoptwack(\($a = $b));
 &wackbrack(\($a = $b));
 &optwackbrack(\($a = $b));
 &optoptwackbrack(\($a = $b));
+optbar;
+optoptbar;
+optplus;
+optoptplus;
+optwack;
+optoptwack;
+optwackbrack;
+optoptwackbrack;
+####
+# enreferencing prototypes: @
+# CONTEXT sub wackat(\@) {} sub optwackat(;\@) {} sub wackbrackat(\[@]) {} sub optwackbrackat(;\[@]) {}
+wackat(my @a0);
+wackat(@a0);
+wackat(@ARGV);
+wackat(@{['t'];});
+optwackat;
+optwackat(my @a1);
+optwackat(@a1);
+optwackat(@ARGV);
+optwackat(@{['t'];});
+wackbrackat(my @a2);
+wackbrackat(@a2);
+wackbrackat(@ARGV);
+wackbrackat(@{['t'];});
+optwackbrackat;
+optwackbrackat(my @a3);
+optwackbrackat(@a3);
+optwackbrackat(@ARGV);
+optwackbrackat(@{['t'];});
+####
+# enreferencing prototypes: %
+# CONTEXT sub wackperc(\%) {} sub optwackperc(;\%) {} sub wackbrackperc(\[%]) {} sub optwackbrackperc(;\[%]) {}
+wackperc(my %a0);
+wackperc(%a0);
+wackperc(%ARGV);
+wackperc(%{+{'t', 1};});
+optwackperc;
+optwackperc(my %a1);
+optwackperc(%a1);
+optwackperc(%ARGV);
+optwackperc(%{+{'t', 1};});
+wackbrackperc(my %a2);
+wackbrackperc(%a2);
+wackbrackperc(%ARGV);
+wackbrackperc(%{+{'t', 1};});
+optwackbrackperc;
+optwackbrackperc(my %a3);
+optwackbrackperc(%a3);
+optwackbrackperc(%ARGV);
+optwackbrackperc(%{+{'t', 1};});
+####
+# enreferencing prototypes: +
+# CONTEXT sub plus(+) {} sub optplus(;+) {}
+plus('hi');
+plus(my @a0);
+plus(my %h0);
+plus(\@a0);
+plus(\%h0);
+optplus;
+optplus('hi');
+optplus(my @a1);
+optplus(my %h1);
+optplus(\@a1);
+optplus(\%h1);
+>>>>
+plus('hi');
+plus(my @a0);
+plus(my %h0);
+plus(@a0);
+plus(%h0);
+optplus;
+optplus('hi');
+optplus(my @a1);
+optplus(my %h1);
+optplus(@a1);
+optplus(%h1);
 ####
 # ensure aelemfast works in the range -128..127 and that there's no
 # funky edge cases