Skip to content

Commit

Permalink
lib/B/Deparse.pm: Don't get upset by OP_METHSTART in method subs
Browse files Browse the repository at this point in the history
When encountering a `method` sub under `use feature 'class'`, we need to
skip over and ignore the `OP_METHSTART` at the beginning, so we can
still safely handle the signature ops. We also need to emit the
declaration under a `method` keyword, rather than a `sub`.
  • Loading branch information
leonerd committed Dec 2, 2024
1 parent 2ec5120 commit 6a9d009
Show file tree
Hide file tree
Showing 2 changed files with 40 additions and 12 deletions.
37 changes: 26 additions & 11 deletions lib/B/Deparse.pm
Original file line number Diff line number Diff line change
Expand Up @@ -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.80;
package B::Deparse 1.81;
use strict;
use Carp;
use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
Expand All @@ -28,7 +28,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
OPpARG_IF_UNDEF OPpARG_IF_FALSE
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVf_FAKE SVs_RMG SVs_SMG
SVs_PADTMP
CVf_NOWARN_AMBIGUOUS CVf_LVALUE
CVf_NOWARN_AMBIGUOUS CVf_LVALUE CVf_IsMETHOD
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED PMf_EXTENDED_MORE
PADNAMEf_OUTER PADNAMEf_OUR PADNAMEf_TYPED
Expand Down Expand Up @@ -480,7 +480,8 @@ sub next_todo {
# XXX We would do $self->keyword("sub"), but ‘my CORE::sub’
# doesn’t work and ‘my sub’ ignores a &sub in scope. I.e.,
# we have a core bug here.
push @text, "sub " . substr $name->PVX, 1;
my $kw = $cv ? $self->kw_sub_or_method($cv) : "sub";
push @text, "$kw " . substr $name->PVX, 1;
if ($cv) {
# my sub foo { }
push @text, " " . $self->deparse_sub($cv);
Expand Down Expand Up @@ -554,7 +555,7 @@ sub next_todo {
} elsif (defined $stash) {
$name =~ s/^\Q$stash\E::(?!\z|.*::)//;
}
my $ret = "$pragmata${p}${l}" . $self->keyword("sub") . " $name "
my $ret = "$pragmata${p}${l}" . $self->keyword($self->kw_sub_or_method($cv)) . " $name "
. $self->deparse_sub($cv);
$self->{'subs_declared'}{$name} = 1;
return $ret;
Expand Down Expand Up @@ -1304,6 +1305,12 @@ sub deparse_argops {
}


sub kw_sub_or_method {
my $self = shift;
my $cv = shift;
return ($cv->CvFLAGS & CVf_IsMETHOD) ? "method" : "sub";
}

# Deparse a sub. Returns everything except the 'sub foo',
# e.g. ($$) : method { ...; }
# or : prototype($$) lvalue ($a, $b) { ...; };
Expand All @@ -1329,10 +1336,13 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
$proto = $myproto;
}
}
if ($cv->CvFLAGS & (CVf_NOWARN_AMBIGUOUS|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) {
push @attrs, "lvalue" if $cv->CvFLAGS & CVf_LVALUE;
push @attrs, "method" if $cv->CvFLAGS & CVf_NOWARN_AMBIGUOUS;
push @attrs, "const" if $cv->CvFLAGS & CVf_ANONCONST;
my $cv_flags = $cv->CvFLAGS;
my $is_method = $cv_flags & CVf_IsMETHOD;

if ($cv_flags & (CVf_NOWARN_AMBIGUOUS|CVf_LOCKED|CVf_LVALUE|CVf_ANONCONST)) {
push @attrs, "lvalue" if $cv_flags & CVf_LVALUE;
push @attrs, "method" if $cv_flags & CVf_NOWARN_AMBIGUOUS and !$is_method;
push @attrs, "const" if $cv_flags & CVf_ANONCONST;
}

local($self->{'curcv'}) = $cv;
Expand All @@ -1351,6 +1361,10 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
my $is_list = ($lineseq->name eq "lineseq");
my $firstop = $is_list ? $lineseq->first : $lineseq;

if ($is_method and $firstop->name eq "methstart") {
$firstop = $firstop->sibling;
}

# Try to deparse first subtree as a signature if possible.
# Top of signature subtree has an ex-argcheck as a placeholder
if ( $has_sig
Expand Down Expand Up @@ -2812,8 +2826,9 @@ sub pp_refgen {

sub e_anoncode {
my ($self, $info) = @_;
my $text = $self->deparse_sub($info->{code});
return $self->keyword("sub") . " $text";
my $cv = $info->{code};
my $text = $self->deparse_sub($cv);
return $self->keyword($self->kw_sub_or_method($cv)) . " $text";
}

sub pp_anoncode {
Expand Down Expand Up @@ -5645,7 +5660,7 @@ sub const {
$self->{curcv}->object_2svref == $ref->object_2svref) {
return $self->keyword("__SUB__");
}
return "sub " . $self->deparse_sub($ref);
return $self->kw_sub_or_method($ref) . " " . $self->deparse_sub($ref);
}
if ($class ne 'SPECIAL' and $ref->FLAGS & SVs_SMG) {
for (my $mg = $ref->MAGIC; $mg; $mg = $mg->MOREMAGIC) {
Expand Down
15 changes: 14 additions & 1 deletion lib/B/Deparse.t
Original file line number Diff line number Diff line change
Expand Up @@ -13,7 +13,7 @@ BEGIN {
use warnings;
use strict;

my $tests = 52; # not counting those in the __DATA__ section
my $tests = 53; # not counting those in the __DATA__ section

use B::Deparse;
my $deparse = B::Deparse->new();
Expand Down Expand Up @@ -571,6 +571,19 @@ is runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
"package Foo;\nsub f {\n 1;\n}\nsub BEGIN {\n *Bar::f = \\&f;\n}\n",
"sub glob alias in separate package shouldn't impede emitting original sub";

# method declarations (GH#22777)
like runperl(stderr => 1, switches => [ '-MO=-qq,Deparse', $path ],
prog => <<'EOF',
use feature qw( class signatures );
class C {
field $x;
method m () { $x++ }
}
EOF
),
qr/ +method m \(\) \{\n +\$x\+\+;\n +\}/,
"feature class method deparses as method";


done_testing($tests);

Expand Down

0 comments on commit 6a9d009

Please sign in to comment.