Skip to content

Commit a3c9c70

Browse files
leonerdleonerd
committed
Best-effort deparse of OP_MULTIPARAM when feature 'signatures' is disabled
1 parent 26f1b7f commit a3c9c70

File tree

2 files changed

+243
-41
lines changed

2 files changed

+243
-41
lines changed

‎lib/B/Deparse.pm‎

Lines changed: 163 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@
99

1010
package B::Deparse 1.88;
1111
use strict;
12+
use builtin qw( true false );
1213
use Carp;
1314
use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
1415
OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
@@ -1192,11 +1193,14 @@ sub pad_subs {
11921193

11931194

11941195
# deparse_multiparam(): deparse, if possible, a sequence of ops into a
1195-
# subroutine signature. If possible, returns a string representing the
1196-
# signature syntax, minus the surrounding parentheses.
1196+
# subroutine signature. If possible, returns either:
1197+
# (if $use_feature_sig is true): a string representing the signature syntax,
1198+
# minus the surrounding parentheses.
1199+
# (if $use_feature_sig is false): a string of perl code that approximates
1200+
# the behaviour of the signature.
11971201

11981202
sub deparse_multiparam {
1199-
my ($self, $topop, $cv) = @_;
1203+
my ($self, $topop, $cv, $use_feature_sig) = @_;
12001204

12011205
$topop = $topop->first;
12021206
return unless $$topop and $topop->name eq 'lineseq';
@@ -1223,16 +1227,20 @@ sub deparse_multiparam {
12231227
my @param_padix = splice @rest, 0, $nparams, ();
12241228
my ($slurpy_padix) = @rest;
12251229

1226-
my @sig;
1230+
my @param_padname = map { $_ ? $self->padname($_) : '$' } @param_padix;
1231+
my ($slurpy_padname) = map { $_ ? $self->padname($_) : $slurpy } $slurpy_padix;
1232+
12271233
my %parami_for_padix;
12281234

12291235
# Initial scalars
12301236
foreach my $parami ( 0 .. $max_args-1 ) {
12311237
my $padix = $param_padix[$parami];
1232-
$sig[$parami] = $self->padname($padix) || '$';
12331238
$parami_for_padix{$padix} = $parami;
12341239
}
12351240

1241+
my @param_defmode;
1242+
my @param_defexpr;
1243+
12361244
$o = $o->sibling;
12371245
for (; $o and !null $o; $o = $o->sibling) {
12381246
# Look for OP_NULL[OP_PARAMTEST[OP_PARAMSTORE]]
@@ -1244,39 +1252,119 @@ sub deparse_multiparam {
12441252

12451253
my $parami = $parami_for_padix{$ofirst->targ};
12461254

1247-
my $assign = "=";
1248-
$assign = "//=" if $ofirst->private == OPpPARAM_IF_UNDEF;
1249-
$assign = "||=" if $ofirst->private == OPpPARAM_IF_FALSE;
1250-
1251-
length $sig[$parami] > 1 ?
1252-
( $sig[$parami] .= ' ' ) :
1253-
( $sig[$parami] = '$' ); # intentionally no trailing space
1255+
my $defmode = "=";
1256+
$defmode = "//=" if $ofirst->private == OPpPARAM_IF_UNDEF;
1257+
$defmode = "||=" if $ofirst->private == OPpPARAM_IF_FALSE;
1258+
$param_defmode[$parami] = $defmode;
12541259

12551260
my $defop = $ofirst->first->first;
1256-
if ($defop->name eq "stub") {
1257-
$sig[$parami] .= "$assign";
1258-
}
1259-
else {
1260-
my $def = $self->deparse($defop, 7);
1261-
$def = "($def)" if $defop->flags & OPf_PARENS;
1261+
if ($defop->name ne "stub") {
1262+
my $expr = $self->deparse($defop, 7);
1263+
$expr = "($expr)" if $defop->flags & OPf_PARENS;
12621264

1263-
$sig[$parami] .= "$assign $def";
1265+
$param_defexpr[$parami] = $expr;
12641266
}
12651267
}
12661268
}
12671269

12681270
if ($cv->CvFLAGS & CVf_IsMETHOD) {
12691271
# Remove the implied `$self` argument
12701272
warn "Expected first signature argument to be named \$self"
1271-
unless @sig and $sig[0] eq '$self';
1272-
shift @sig;
1273+
unless @param_padname and $param_padname[0] eq '$self';
1274+
1275+
shift @param_padix;
1276+
shift @param_padname;
1277+
shift @param_defmode;
1278+
shift @param_defexpr;
1279+
}
1280+
1281+
if ($use_feature_sig) {
1282+
my @sig;
1283+
1284+
foreach my $parami ( 0 .. $#param_padix ) {
1285+
my $param_sig = $param_padname[$parami];
1286+
if ($param_defmode[$parami]) {
1287+
length $param_sig > 1 ?
1288+
( $param_sig .= ' ' ) :
1289+
( $param_sig = '$' ); # intentionally no trailing space
1290+
1291+
$param_sig .= $param_defmode[$parami];
1292+
1293+
my $defexpr = $param_defexpr[$parami];
1294+
$param_sig .= " $defexpr" if defined $defexpr;
1295+
}
1296+
1297+
push @sig, $param_sig;
1298+
}
1299+
1300+
push @sig, $slurpy_padname if $slurpy;
1301+
1302+
return join(", ", @sig);
1303+
}
1304+
1305+
# Approximate the behaviour using plain perl code
1306+
my $code = "";
1307+
1308+
$code .= <<"EOF" if !$slurpy_padix;
1309+
die sprintf("Too many arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ <= $nparams;
1310+
EOF
1311+
1312+
$code .= <<"EOF" if $min_args > 0;
1313+
die sprintf("Too few arguments for subroutine at %s line %d.\\n", (caller)[1, 2]) unless \@_ >= $min_args;
1314+
EOF
1315+
1316+
$code .= <<EOF if $slurpy and $slurpy eq '%';
1317+
die sprintf("Odd name/value argument for subroutine at %s line %d.\\n", (caller)[1, 2]) if \@_ > $nparams && ((\@_ - $nparams) & 1);
1318+
EOF
1319+
1320+
foreach my $parami ( 0 .. $#param_padix ) {
1321+
my $argix = $parami;
1322+
1323+
my $stmt = "my $param_padname[$parami] = ";
1324+
1325+
if (my $defmode = $param_defmode[$parami]) {
1326+
my $defexpr = $param_defexpr[$parami];
1327+
# Optional parameter
1328+
1329+
if (length $param_padname[$parami] > 1) {
1330+
# Named optional param
1331+
if ($defmode eq "=") {
1332+
$stmt .= "\@_ > $argix ? \$_[$argix] : $defexpr";
1333+
}
1334+
else {
1335+
$defmode =~ s/=\z//;
1336+
$stmt .= "\$_[$argix] $defmode $defexpr";
1337+
}
1338+
}
1339+
else {
1340+
# Anonymous optional param. This does not create or assign a
1341+
# variable but we still evaluate the defaulting expression for
1342+
# side-effects
1343+
my $cond = ( $defmode eq "//=" ) ? "defined \$_[$argix]" :
1344+
( $defmode eq "||=" ) ? "\$_[$argix]" :
1345+
"\@_ > $argix";
1346+
$stmt = "$defexpr unless $cond";
1347+
}
1348+
}
1349+
else {
1350+
# Mandatory parameter
1351+
1352+
# Anonymous mandatory params can be entirely ignored. Their pad
1353+
# index will be zero.
1354+
$param_padix[$parami] or next;
1355+
1356+
$stmt .= "\$_[$argix]";
1357+
}
1358+
1359+
$code .= "$stmt;\n";
12731360
}
12741361

12751362
if ($slurpy) {
1276-
push @sig, $slurpy_padix ? $self->padname($slurpy_padix) : $slurpy;
1363+
$code .= "my $slurpy_padname = \@_[$nparams..\$#_];\n";
12771364
}
12781365

1279-
return join(", ", @sig);
1366+
$code =~ s/;\n\z//;
1367+
return $code;
12801368
}
12811369

12821370
# deparse_argops(): deparse, if possible, a sequence of argcheck + argelem
@@ -1434,10 +1522,10 @@ Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
14341522
Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
14351523
local $self->{'curcop'} = $self->{'curcop'};
14361524

1437-
my $has_sig = $self->feature_enabled('signatures');
1525+
my $use_feature_sig = $self->feature_enabled('signatures');
14381526
if ($cv->FLAGS & SVf_POK) {
14391527
my $myproto = $cv->PV;
1440-
if ($has_sig) {
1528+
if ($use_feature_sig) {
14411529
push @attrs, "prototype($myproto)";
14421530
}
14431531
else {
@@ -1457,7 +1545,7 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
14571545
local($self->{'curcvlex'});
14581546
local(@$self{qw'curstash warnings hints hinthash'})
14591547
= @$self{qw'curstash warnings hints hinthash'};
1460-
my $body;
1548+
my $body = "";
14611549
my $root = $cv->ROOT;
14621550
local $B::overlay = {};
14631551
if (not null $root) {
@@ -1471,16 +1559,21 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
14711559

14721560
# Try to deparse first subtree as a signature if possible.
14731561
# Top of signature subtree has an ex-argcheck as a placeholder
1474-
if ( $has_sig
1475-
and $$firstop
1476-
and $firstop->name eq 'null'
1477-
and $firstop->targ == OP_ARGCHECK
1478-
) {
1479-
my ($mysig) = $self->deparse_multiparam($firstop, $cv) //
1480-
$self->deparse_argops($firstop, $cv);
1481-
if (defined $mysig) {
1482-
$sig = $mysig;
1483-
$firstop = $is_list ? $firstop->sibling : undef;
1562+
if ($$firstop and $firstop->name eq 'null' and $firstop->targ == OP_ARGCHECK) {
1563+
if ($use_feature_sig) {
1564+
my ($mysig) = $self->deparse_multiparam($firstop, $cv, true) //
1565+
$self->deparse_argops($firstop, $cv);
1566+
if (defined $mysig) {
1567+
$sig = $mysig;
1568+
$firstop = $is_list ? $firstop->sibling : undef;
1569+
}
1570+
}
1571+
else {
1572+
my $prelude = $self->deparse_multiparam($firstop, $cv, false);
1573+
if (defined $prelude) {
1574+
$body .= $prelude;
1575+
$firstop = $is_list ? $firstop->sibling : undef;
1576+
}
14841577
}
14851578
}
14861579

@@ -1489,8 +1582,8 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
14891582
for (my $o = $firstop; $$o; $o=$o->sibling) {
14901583
push @ops, $o;
14911584
}
1492-
$body = $self->lineseq(undef, 0, @ops).";";
1493-
if (!$has_sig and $ops[-1]->name =~ /^(next|db)state$/) {
1585+
$body .= $self->lineseq(undef, 0, @ops).";";
1586+
if (!$use_feature_sig and $ops[-1]->name =~ /^(next|db)state$/) {
14941587
# this handles void context in
14951588
# use feature signatures; sub ($=1) {}
14961589
$body .= "\n()";
@@ -1502,10 +1595,10 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
15021595
}
15031596
}
15041597
elsif ($firstop) {
1505-
$body = $self->deparse($root->first, 0);
1598+
$body .= $self->deparse($root->first, 0);
15061599
}
15071600
else {
1508-
$body = ';'; # stub sub
1601+
$body .= ';'; # stub sub
15091602
}
15101603

15111604
my $l = '';
@@ -6977,6 +7070,11 @@ sub pp_argdefelem {
69777070
}
69787071

69797072

7073+
sub pp_multiparam {
7074+
die "Unable to handle PP_MULTIPARAM outside of a regular subroutine signature position";
7075+
}
7076+
7077+
69807078
sub pp_pushdefer {
69817079
my $self = shift;
69827080
my($op, $cx) = @_;
@@ -7436,6 +7534,31 @@ want to eval the result, you should prepend "sub subname ", or "sub "
74367534
for an anonymous function constructor. Unless the sub was defined in
74377535
the main:: package, the code will include a package declaration.
74387536
7537+
Normally, C<B::Deparse> will emit code that includes the L<feature> pragma
7538+
if required to enable features that are used in the fragment that follows.
7539+
However, as L</coderef2text> emits only the body of a subroutine and expects
7540+
the caller to prepend the C<sub> and optional name onto the beginning of it,
7541+
it will not have the opportunity to emit a C<use feature 'signatures'> if the
7542+
subroutine uses a signature, and the signatures feature is not enabled in the
7543+
ambient pragmas.
7544+
7545+
In the particular situation of a subroutine that uses the C<signatures>
7546+
feature to parse its arguments being passed to L</coderef2text> when the
7547+
feature is B<not> enabled in L</ambient_pragmas>, C<B::Deparse> will attempt
7548+
to emit pure-perl code that emulates the behaviour of the signature as closely
7549+
as possible. This is performed on a B<best-effort> basis. It is not
7550+
guaranteed to perfectly capture the semantics of the signature's behaviour,
7551+
only to offer a human-readable suggestion as to what it might do.
7552+
Furthermore, it is not guaranteed to be able to reproduce every possible
7553+
behaviour of signatures in future versions of Perl. It may be that a future
7554+
version introduces a behaviour that does not have a tidy way to express it in
7555+
this pure-perl emulation code without using the C<signatures> feature.
7556+
7557+
If this is of importance to you, make sure to use the L</ambient_pragmas> or
7558+
L</ambient_pragmas_from_caller> method to enable the C<signatures> feature,
7559+
ensuring that C<B::Deparse> will use it to deparse subroutines that use
7560+
signatures.
7561+
74397562
=head1 BUGS
74407563
74417564
=over 4

0 commit comments

Comments
 (0)