Skip to content

Commit d371cc7

Browse files
leonerdleonerd
committed
Best-effort deparse of OP_MULTIPARAM when feature 'signatures' is disabled
1 parent faa8351 commit d371cc7

File tree

2 files changed

+237
-41
lines changed

2 files changed

+237
-41
lines changed

‎lib/B/Deparse.pm‎

Lines changed: 157 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,113 @@ 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+
# anonymous params with defaults don't create or assign a variable but
1329+
# still evaluate the defaulting expression for side-effects
1330+
if( length $param_padname[$parami] > 1 ) {
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+
my $cond = ( $defmode eq "//=" ) ? "defined \$_[$argix]" :
1341+
( $defmode eq "||=" ) ? "\$_[$argix]" :
1342+
"\@_ > $argix";
1343+
$stmt = "$defexpr unless $cond";
1344+
}
1345+
}
1346+
else {
1347+
# anonymous params without defaulting expressions can be entirely ignored
1348+
$param_padix[$parami] or next;
1349+
1350+
$stmt .= "\$_[$argix]";
1351+
}
1352+
1353+
$code .= "$stmt;\n";
12731354
}
12741355

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

1279-
return join(", ", @sig);
1360+
$code =~ s/;\n\z//;
1361+
return $code;
12801362
}
12811363

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

1437-
my $has_sig = $self->feature_enabled('signatures');
1519+
my $use_feature_sig = $self->feature_enabled('signatures');
14381520
if ($cv->FLAGS & SVf_POK) {
14391521
my $myproto = $cv->PV;
1440-
if ($has_sig) {
1522+
if ($use_feature_sig) {
14411523
push @attrs, "prototype($myproto)";
14421524
}
14431525
else {
@@ -1457,7 +1539,7 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
14571539
local($self->{'curcvlex'});
14581540
local(@$self{qw'curstash warnings hints hinthash'})
14591541
= @$self{qw'curstash warnings hints hinthash'};
1460-
my $body;
1542+
my $body = "";
14611543
my $root = $cv->ROOT;
14621544
local $B::overlay = {};
14631545
if (not null $root) {
@@ -1471,16 +1553,21 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
14711553

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

@@ -1489,8 +1576,8 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
14891576
for (my $o = $firstop; $$o; $o=$o->sibling) {
14901577
push @ops, $o;
14911578
}
1492-
$body = $self->lineseq(undef, 0, @ops).";";
1493-
if (!$has_sig and $ops[-1]->name =~ /^(next|db)state$/) {
1579+
$body .= $self->lineseq(undef, 0, @ops).";";
1580+
if (!$use_feature_sig and $ops[-1]->name =~ /^(next|db)state$/) {
14941581
# this handles void context in
14951582
# use feature signatures; sub ($=1) {}
14961583
$body .= "\n()";
@@ -1502,10 +1589,10 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
15021589
}
15031590
}
15041591
elsif ($firstop) {
1505-
$body = $self->deparse($root->first, 0);
1592+
$body .= $self->deparse($root->first, 0);
15061593
}
15071594
else {
1508-
$body = ';'; # stub sub
1595+
$body .= ';'; # stub sub
15091596
}
15101597

15111598
my $l = '';
@@ -6977,6 +7064,11 @@ sub pp_argdefelem {
69777064
}
69787065

69797066

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

0 commit comments

Comments
 (0)