From 0099fe06da2470ae6f7b3feb560b1a116886a531 Mon Sep 17 00:00:00 2001 From: Lukas Mai Date: Thu, 30 Mar 2023 02:42:40 +0200 Subject: Deparse: fix scalar-proto sub calls without arguments - fix (;$) - remove infinite loops from check_proto() - implement (+) - fix (\@) and (\%) Fixes GH #20989. --- lib/B/Deparse.pm | 116 ++++++++++++++++++++++++++++++++----------------------- lib/B/Deparse.t | 94 +++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 156 insertions(+), 54 deletions(-) (limited to 'lib') 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/(?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 -- cgit v1.2.1