Skip to content

Commit 414c7ed

Browse files
leonerdleonerd
committed
Best-effort deparse of OP_MULTIPARAM when feature 'signatures' is disabled
1 parent da3253e commit 414c7ed

File tree

2 files changed

+239
-41
lines changed

2 files changed

+239
-41
lines changed

‎lib/B/Deparse.pm‎

Lines changed: 159 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,115 @@ 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+
1328+
# Optional anonymous params don't create or assign a variable but
1329+
# still evaluate the defaulting expression for side-effects
1330+
# they will have a name of '$'
1331+
if (length $param_padname[$parami] > 1) {
1332+
if ($defmode eq "=") {
1333+
$stmt .= "\@_ > $argix ? \$_[$argix] : $defexpr";
1334+
}
1335+
else {
1336+
$defmode =~ s/=\z//;
1337+
$stmt .= "\$_[$argix] $defmode $defexpr";
1338+
}
1339+
}
1340+
else {
1341+
my $cond = ( $defmode eq "//=" ) ? "defined \$_[$argix]" :
1342+
( $defmode eq "||=" ) ? "\$_[$argix]" :
1343+
"\@_ > $argix";
1344+
$stmt = "$defexpr unless $cond";
1345+
}
1346+
}
1347+
else {
1348+
# Mandatory anonymous params can be entirely ignored. Their pad
1349+
# index will be zero.
1350+
$param_padix[$parami] or next;
1351+
1352+
$stmt .= "\$_[$argix]";
1353+
}
1354+
1355+
$code .= "$stmt;\n";
12731356
}
12741357

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

1279-
return join(", ", @sig);
1362+
$code =~ s/;\n\z//;
1363+
return $code;
12801364
}
12811365

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

1437-
my $has_sig = $self->feature_enabled('signatures');
1521+
my $use_feature_sig = $self->feature_enabled('signatures');
14381522
if ($cv->FLAGS & SVf_POK) {
14391523
my $myproto = $cv->PV;
1440-
if ($has_sig) {
1524+
if ($use_feature_sig) {
14411525
push @attrs, "prototype($myproto)";
14421526
}
14431527
else {
@@ -1457,7 +1541,7 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
14571541
local($self->{'curcvlex'});
14581542
local(@$self{qw'curstash warnings hints hinthash'})
14591543
= @$self{qw'curstash warnings hints hinthash'};
1460-
my $body;
1544+
my $body = "";
14611545
my $root = $cv->ROOT;
14621546
local $B::overlay = {};
14631547
if (not null $root) {
@@ -1471,16 +1555,21 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
14711555

14721556
# Try to deparse first subtree as a signature if possible.
14731557
# 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;
1558+
if ($$firstop and $firstop->name eq 'null' and $firstop->targ == OP_ARGCHECK) {
1559+
if ($use_feature_sig) {
1560+
my ($mysig) = $self->deparse_multiparam($firstop, $cv, true) //
1561+
$self->deparse_argops($firstop, $cv);
1562+
if (defined $mysig) {
1563+
$sig = $mysig;
1564+
$firstop = $is_list ? $firstop->sibling : undef;
1565+
}
1566+
}
1567+
else {
1568+
my $prelude = $self->deparse_multiparam($firstop, $cv, false);
1569+
if (defined $prelude) {
1570+
$body .= $prelude;
1571+
$firstop = $is_list ? $firstop->sibling : undef;
1572+
}
14841573
}
14851574
}
14861575

@@ -1489,8 +1578,8 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
14891578
for (my $o = $firstop; $$o; $o=$o->sibling) {
14901579
push @ops, $o;
14911580
}
1492-
$body = $self->lineseq(undef, 0, @ops).";";
1493-
if (!$has_sig and $ops[-1]->name =~ /^(next|db)state$/) {
1581+
$body .= $self->lineseq(undef, 0, @ops).";";
1582+
if (!$use_feature_sig and $ops[-1]->name =~ /^(next|db)state$/) {
14941583
# this handles void context in
14951584
# use feature signatures; sub ($=1) {}
14961585
$body .= "\n()";
@@ -1502,10 +1591,10 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
15021591
}
15031592
}
15041593
elsif ($firstop) {
1505-
$body = $self->deparse($root->first, 0);
1594+
$body .= $self->deparse($root->first, 0);
15061595
}
15071596
else {
1508-
$body = ';'; # stub sub
1597+
$body .= ';'; # stub sub
15091598
}
15101599

15111600
my $l = '';
@@ -6977,6 +7066,11 @@ sub pp_argdefelem {
69777066
}
69787067

69797068

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

0 commit comments

Comments
 (0)