Skip to content

Commit 016841b

Browse files
leonerdleonerd
committed
Best-effort deparse of OP_MULTIPARAM when feature 'signatures' is disabled
1 parent dfa7e8a commit 016841b

File tree

2 files changed

+185
-41
lines changed

2 files changed

+185
-41
lines changed

‎lib/B/Deparse.pm‎

Lines changed: 119 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,100 @@ 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+
$code .= "my $param_padname[$parami] = ";
1324+
1325+
if (my $defmode = $param_defmode[$parami]) {
1326+
my $defexpr = $param_defexpr[$parami];
1327+
1328+
if ($defmode eq "=") {
1329+
$code .= "\@_ > $argix ? \$_[$argix] : $defexpr";
1330+
}
1331+
else {
1332+
$defmode =~ s/=\z//;
1333+
$code .= "\$_[$argix] $defmode $defexpr";
1334+
}
1335+
}
1336+
else {
1337+
$code .= "\$_[$argix]";
1338+
}
1339+
1340+
$code .= ";\n";
12731341
}
12741342

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

1279-
return join(", ", @sig);
1347+
$code =~ s/;\n\z//;
1348+
return $code;
12801349
}
12811350

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

1437-
my $has_sig = $self->feature_enabled('signatures');
1506+
my $use_feature_sig = $self->feature_enabled('signatures');
14381507
if ($cv->FLAGS & SVf_POK) {
14391508
my $myproto = $cv->PV;
1440-
if ($has_sig) {
1509+
if ($use_feature_sig) {
14411510
push @attrs, "prototype($myproto)";
14421511
}
14431512
else {
@@ -1457,7 +1526,7 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
14571526
local($self->{'curcvlex'});
14581527
local(@$self{qw'curstash warnings hints hinthash'})
14591528
= @$self{qw'curstash warnings hints hinthash'};
1460-
my $body;
1529+
my $body = "";
14611530
my $root = $cv->ROOT;
14621531
local $B::overlay = {};
14631532
if (not null $root) {
@@ -1471,16 +1540,21 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
14711540

14721541
# Try to deparse first subtree as a signature if possible.
14731542
# 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;
1543+
if ($$firstop and $firstop->name eq 'null' and $firstop->targ == OP_ARGCHECK) {
1544+
if ($use_feature_sig) {
1545+
my ($mysig) = $self->deparse_multiparam($firstop, $cv, true) //
1546+
$self->deparse_argops($firstop, $cv);
1547+
if (defined $mysig) {
1548+
$sig = $mysig;
1549+
$firstop = $is_list ? $firstop->sibling : undef;
1550+
}
1551+
}
1552+
else {
1553+
my $prelude = $self->deparse_multiparam($firstop, $cv, false);
1554+
if (defined $prelude) {
1555+
$body .= $prelude;
1556+
$firstop = $is_list ? $firstop->sibling : undef;
1557+
}
14841558
}
14851559
}
14861560

@@ -1489,8 +1563,8 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
14891563
for (my $o = $firstop; $$o; $o=$o->sibling) {
14901564
push @ops, $o;
14911565
}
1492-
$body = $self->lineseq(undef, 0, @ops).";";
1493-
if (!$has_sig and $ops[-1]->name =~ /^(next|db)state$/) {
1566+
$body .= $self->lineseq(undef, 0, @ops).";";
1567+
if (!$use_feature_sig and $ops[-1]->name =~ /^(next|db)state$/) {
14941568
# this handles void context in
14951569
# use feature signatures; sub ($=1) {}
14961570
$body .= "\n()";
@@ -1502,10 +1576,10 @@ Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
15021576
}
15031577
}
15041578
elsif ($firstop) {
1505-
$body = $self->deparse($root->first, 0);
1579+
$body .= $self->deparse($root->first, 0);
15061580
}
15071581
else {
1508-
$body = ';'; # stub sub
1582+
$body .= ';'; # stub sub
15091583
}
15101584

15111585
my $l = '';
@@ -6977,6 +7051,11 @@ sub pp_argdefelem {
69777051
}
69787052

69797053

7054+
sub pp_multiparam {
7055+
die "Unable to handle PP_MULTIPARAM outside of a regular subroutine signature position";
7056+
}
7057+
7058+
69807059
sub pp_pushdefer {
69817060
my $self = shift;
69827061
my($op, $cx) = @_;

‎lib/B/Deparse.t‎

Lines changed: 66 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,7 @@ BEGIN {
1313
use warnings;
1414
use strict;
1515

16-
my $tests = 55; # not counting those in the __DATA__ section
16+
my $tests = 68; # not counting those in the __DATA__ section
1717

1818
use B::Deparse;
1919
my $deparse = B::Deparse->new();
@@ -573,6 +573,14 @@ EOF
573573
sub ($x, $y) { return $x + $y; }
574574
};
575575

576+
{
577+
no feature qw( signatures );
578+
$deparse->ambient_pragmas_from_caller;
579+
my $deparsed = $deparse->coderef2text( $signatured_sub );
580+
unlike $deparsed, qr/^\(\$x, \$y\) \{/,
581+
'Deparsed signatured sub under no feature qw( signatures )';
582+
}
583+
576584
{
577585
use feature qw( signatures );
578586
$deparse->ambient_pragmas_from_caller;
@@ -590,6 +598,63 @@ EOF
590598
}
591599
}
592600

601+
{
602+
# Ability to deparse various kinds of signature into non-feature signatures
603+
# context
604+
no feature qw( signatures );
605+
$deparse->ambient_pragmas_from_caller;
606+
607+
use feature qw( signatures );
608+
my $deparsed;
609+
610+
# These tests are all somewhat fragile as they depend on the exact
611+
# pure-perl transliteration of OP_MULTIPARAM, as performed by B/Deparse.pm
612+
613+
$deparsed = $deparse->coderef2text( sub () { } );
614+
like $deparsed,
615+
qr/die .*Too many arguments for subroutine at.* unless \@_ <= 0/m,
616+
'Deparsed signature empty max bounds';
617+
618+
$deparsed = $deparse->coderef2text( sub ($x, $y) { } );
619+
like $deparsed,
620+
qr/die .*Too many arguments for subroutine at.* unless \@_ <= 2/m,
621+
'Deparsed signature two-args max bounds';
622+
like $deparsed,
623+
qr/die .*Too few arguments for subroutine at.* unless \@_ >= 2/m,
624+
'Deparsed signature two-args min bounds';
625+
like $deparsed,
626+
qr/my \$x = \$_\[0];/m,
627+
'Deparsed signature two-args arg 0';
628+
like $deparsed,
629+
qr/my \$y = \$_\[1];/m,
630+
'Deparsed signature two-args arg 1';
631+
632+
$deparsed = $deparse->coderef2text( sub ($one = 1, $two //= 2, $three ||= 3) { } );
633+
like $deparsed,
634+
qr/my \$one = \@_ > 0 \? \$_\[0] : 1;/m,
635+
'Deparsed signature with defaults arg 0';
636+
like $deparsed,
637+
qr/my \$two = \$_\[1] \/\/ 2;/m,
638+
'Deparsed signature with defaults arg 1';
639+
like $deparsed,
640+
qr/my \$three = \$_\[2] \|\| 3;/m,
641+
'Deparsed signature with defaults arg 2';
642+
643+
$deparsed = $deparse->coderef2text( sub ($z, @rest) { } );
644+
unlike $deparsed,
645+
qr/die .*Too many arguments for subroutine at.*/m,
646+
'Deparsed signature with slurpy has no max bounds';
647+
like $deparsed,
648+
qr/die .*Too few arguments for subroutine at.* unless \@_ >= 1/m,
649+
'Deparsed signature with slurpy min bounds';
650+
like $deparsed,
651+
qr/my \$z = \$_\[0];/m,
652+
'Deparsed signature with slurpy arg 0';
653+
like $deparsed,
654+
qr/my \@rest = \@_\[1..\$#_];/m,
655+
'Deparsed signature with slurpy slurpy';
656+
}
657+
593658
done_testing($tests);
594659

595660
__DATA__

0 commit comments

Comments
 (0)