summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/B/Deparse.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/B/Deparse.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/B/Deparse.pm113
1 files changed, 76 insertions, 37 deletions
diff --git a/Master/tlpkg/tlperl/lib/B/Deparse.pm b/Master/tlpkg/tlperl/lib/B/Deparse.pm
index d62fe3bc5fe..e7eb8cf90d3 100644
--- a/Master/tlpkg/tlperl/lib/B/Deparse.pm
+++ b/Master/tlpkg/tlperl/lib/B/Deparse.pm
@@ -20,7 +20,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
CVf_METHOD CVf_LVALUE
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
-$VERSION = '1.20';
+$VERSION = '1.26';
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
@@ -249,6 +249,9 @@ BEGIN {
# subs_deparsed
# Keeps track of fully qualified names of all deparsed subs.
#
+# in_subst_repl
+# True when deparsing the replacement part of a substitution.
+#
# parens: -p
# linenums: -l
# unquote: -q
@@ -313,6 +316,9 @@ BEGIN {
+BEGIN { for (qw[ const stringify rv2sv list glob pushmark null]) {
+ eval "sub OP_\U$_ () { " . opnumber($_) . "}"
+}}
# _pessimise_walk(): recursively walk the optree of a sub,
# possibly undoing optimisations along the way.
@@ -342,6 +348,7 @@ sub _pessimise_walk {
# the original gv[_].
$B::overlay->{$$op} = {
+ type => OP_PUSHMARK,
name => 'pushmark',
private => ($op->private & OPpLVAL_INTRO),
next => ($op->flags & OPf_SPECIAL)
@@ -401,7 +408,7 @@ sub _pessimise_walk_exe {
}
}
-# Go through an optree and and "remove" some optimisations by using an
+# Go through an optree and "remove" some optimisations by using an
# overlay to selectively modify or un-null some ops. Deparsing in the
# absence of those optimisations is then easier.
#
@@ -972,6 +979,9 @@ sub indent {
}
$line = substr($line, 1);
}
+ if (index($line, "\f") > 0) {
+ $line =~ s/\f/\n/;
+ }
if (substr($line, 0, 1) eq "\f") {
$line = substr($line, 1); # no indent
} else {
@@ -1226,12 +1236,12 @@ sub padname_sv {
sub maybe_my {
my $self = shift;
- my($op, $cx, $text) = @_;
+ my($op, $cx, $text, $forbid_parens) = @_;
if ($op->private & OPpLVAL_INTRO and not $self->{'avoid_local'}{$$op}) {
my $my = $op->private & OPpPAD_STATE
? $self->keyword("state")
: "my";
- if (want_scalar($op)) {
+ if ($forbid_parens || want_scalar($op)) {
return "$my $text";
} else {
return $self->maybe_parens_func($my, $text, $cx, 16);
@@ -1805,7 +1815,6 @@ my %feature_keywords = (
# keywords that are strong and also have a prototype
#
my %strong_proto_keywords = map { $_ => 1 } qw(
- glob
pos
prototype
scalar
@@ -2659,7 +2668,6 @@ sub listop {
: $self->keyword($name) . '()' x (7 < $cx);
}
my $first;
- $name = "socketpair" if $name eq "sockpair";
my $fullname = $self->keyword($name);
my $proto = prototype("CORE::$name");
if (
@@ -2758,7 +2766,7 @@ sub pp_fcntl { listop(@_, "fcntl") }
sub pp_ioctl { listop(@_, "ioctl") }
sub pp_flock { maybe_targmy(@_, \&listop, "flock") }
sub pp_socket { listop(@_, "socket") }
-sub pp_sockpair { listop(@_, "sockpair") }
+sub pp_sockpair { listop(@_, "socketpair") }
sub pp_bind { listop(@_, "bind") }
sub pp_connect { listop(@_, "connect") }
sub pp_listen { listop(@_, "listen") }
@@ -2804,13 +2812,19 @@ sub pp_syscall { listop(@_, "syscall") }
sub pp_glob {
my $self = shift;
my($op, $cx) = @_;
- my $text = $self->dq($op->first->sibling); # skip pushmark
+ my $kid = $op->first->sibling; # skip pushmark
my $keyword =
$op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
- if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
- or $keyword =~ /^CORE::/
+ my $text;
+ if ($keyword =~ /^CORE::/
+ or $kid->name ne 'const'
+ or ($text = $self->dq($kid))
+ =~ /^\$?(\w|::|\`)+$/ # could look like a readline
or $text =~ /[<>]/) {
- return "$keyword(" . single_delim('qq', '"', $text) . ')';
+ $text = $self->deparse($kid);
+ return $cx >= 5 || $self->{'parens'}
+ ? "$keyword($text)"
+ : "$keyword $text";
} else {
return '<' . $text . '>';
}
@@ -2954,14 +2968,14 @@ sub pp_list {
# OPs that store things other than flags in their op_private,
# like OP_AELEMFAST, won't be immediate children of a list.
#
- # OP_ENTERSUB can break this logic, so check for it.
+ # OP_ENTERSUB and OP_SPLIT can break this logic, so check for them.
# I suspect that open and exit can too.
+ # XXX This really needs to be rewritten to accept only those ops
+ # known to take the OPpLVAL_INTRO flag.
if (!($lop->private & (OPpLVAL_INTRO|OPpOUR_INTRO)
or $lop->name eq "undef")
- or $lop->name eq "entersub"
- or $lop->name eq "exit"
- or $lop->name eq "open")
+ or $lop->name =~ /^(?:entersub|exit|open|split)\z/)
{
$local = ""; # or not
last;
@@ -3111,7 +3125,7 @@ sub loop_common {
# thread special var, under 5005threads
$var = $self->pp_threadsv($enter, 1);
} else { # regular my() variable
- $var = $self->pp_padsv($enter, 1);
+ $var = $self->pp_padsv($enter, 1, 1);
}
} elsif ($var->name eq "rv2gv") {
$var = $self->pp_rv2sv($var, 1);
@@ -3198,9 +3212,12 @@ sub pp_leavetry {
return "eval {\n\t" . $self->pp_leave(@_) . "\n\b}";
}
-BEGIN { for (qw[ const stringify rv2sv list glob ]) {
- eval "sub OP_\U$_ () { " . opnumber($_) . "}"
-}}
+sub _op_is_or_was {
+ my ($op, $expect_type) = @_;
+ my $type = $op->type;
+ return($type == $expect_type
+ || ($type == OP_NULL && $op->targ == $expect_type));
+}
sub pp_null {
my $self = shift;
@@ -3208,7 +3225,10 @@ sub pp_null {
if (class($op) eq "OP") {
# old value is lost
return $self->{'ex_const'} if $op->targ == OP_CONST;
- } elsif ($op->first->name eq "pushmark") {
+ } elsif ($op->first->name eq 'pushmark'
+ or $op->first->name eq 'null'
+ && $op->first->targ == OP_PUSHMARK
+ && _op_is_or_was($op, OP_LIST)) {
return $self->pp_list($op, $cx);
} elsif ($op->first->name eq "enter") {
return $self->pp_leave($op, $cx);
@@ -3267,8 +3287,9 @@ sub padany {
sub pp_padsv {
my $self = shift;
- my($op, $cx) = @_;
- return $self->maybe_my($op, $cx, $self->padname($op->targ));
+ my($op, $cx, $forbid_parens) = @_;
+ return $self->maybe_my($op, $cx, $self->padname($op->targ),
+ $forbid_parens);
}
sub pp_padav { pp_padsv(@_) }
@@ -3311,7 +3332,9 @@ sub pp_aelemfast_lex {
my($op, $cx) = @_;
my $name = $self->padname($op->targ);
$name =~ s/^@/\$/;
- return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
+ my $i = $op->private;
+ $i -= 256 if $i > 127;
+ return $name . "[" . ($i + $self->{'arybase'}) . "]";
}
sub pp_aelemfast {
@@ -3323,7 +3346,9 @@ sub pp_aelemfast {
my $gv = $self->gv_or_padgv($op);
my($name,$quoted) = $self->stash_variable_name('@',$gv);
$name = $quoted ? "$name->" : '$' . $name;
- return $name . "[" . ($op->private + $self->{'arybase'}) . "]";
+ my $i = $op->private;
+ $i -= 256 if $i > 127;
+ return $name . "[" . ($i + $self->{'arybase'}) . "]";
}
sub rv2x {
@@ -3377,7 +3402,7 @@ sub pp_av2arylen {
sub pp_rv2cv {
my ($self, $op, $cx) = @_;
if (!null($op->first) && $op->first->name eq 'null' &&
- $op->first->targ eq OP_LIST)
+ $op->first->targ == OP_LIST)
{
return $self->rv2x($op->first->first->sibling, $cx, "&")
}
@@ -3511,7 +3536,9 @@ sub elem {
}
if (my $array_name=$self->elem_or_slice_array_name
($array, $left, $padname, 1)) {
- return ($array_name =~ /->\z/ ? $array_name : "\$" . $array_name)
+ return ($array_name =~ /->\z/
+ ? $array_name
+ : $array_name eq '#' ? '${#}' : "\$" . $array_name)
. $left . $idx . $right;
} else {
# $x[20][3]{hi} or expr->[20]
@@ -3561,11 +3588,15 @@ sub slice {
} else {
$list = $self->elem_or_slice_single_index($kid);
}
- return "\@" . $array . $left . $list . $right;
+ my $lead = '@';
+ $lead = '%' if $op->name =~ /^kv/i;
+ return $lead . $array . $left . $list . $right;
}
-sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
-sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
+sub pp_aslice { maybe_local(@_, slice(@_, "[", "]", "rv2av", "padav")) }
+sub pp_kvaslice { slice(@_, "[", "]", "rv2av", "padav") }
+sub pp_hslice { maybe_local(@_, slice(@_, "{", "}", "rv2hv", "padhv")) }
+sub pp_kvhslice { slice(@_, "{", "}", "rv2hv", "padhv") }
sub pp_lslice {
my $self = shift;
@@ -3681,8 +3712,9 @@ sub check_proto {
my @reals;
# An unbackslashed @ or % gobbles up the rest of the args
1 while $proto =~ s/(?<!\\)([@%])[^\]]+$/$1/;
+ $proto =~ s/^\s*//;
while ($proto) {
- $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)//;
+ $proto =~ s/^(\\?[\$\@&%*_]|\\\[[\$\@&%*]+\]|;)\s*//;
my $chr = $1;
if ($chr eq "") {
return "&" if @args;
@@ -3839,7 +3871,7 @@ sub pp_entersub {
my $dproto = defined($proto) ? $proto : "undefined";
if (!$declared) {
return "$kid(" . $args . ")";
- } elsif ($dproto eq "") {
+ } elsif ($dproto =~ /^\s*\z/) {
return $kid;
} elsif ($dproto eq "\$" and is_scalar($exprs[0])) {
# is_scalar is an excessively conservative test here:
@@ -3934,7 +3966,7 @@ sub re_uninterp_extended {
}
}
-my %unctrl = # portable to to EBCDIC
+my %unctrl = # portable to EBCDIC
(
"\c@" => '\c@', # unused
"\cA" => '\cA',
@@ -4188,7 +4220,11 @@ sub const {
}
}
- return $self->maybe_parens("\\" . $self->const($ref, 20), $cx, 20);
+ my $const = $self->const($ref, 20);
+ if ($self->{in_subst_repl} && $const =~ /^[0-9]/) {
+ $const = "($const)";
+ }
+ return $self->maybe_parens("\\$const", $cx, 20);
} elsif ($sv->FLAGS & SVf_POK) {
my $str = $sv->PV;
if ($str =~ /[[:^print:]]/) {
@@ -4612,7 +4648,7 @@ sub pure_string {
}
elsif ($type eq 'join') {
my $join_op = $op->first->sibling; # Skip pushmark
- return 0 unless $join_op->name eq 'null' && $join_op->targ eq OP_RV2SV;
+ return 0 unless $join_op->name eq 'null' && $join_op->targ == OP_RV2SV;
my $gvop = $join_op->first;
return 0 unless $gvop->name eq 'gvsv';
@@ -4859,10 +4895,13 @@ sub pp_subst {
$repl = $repl->first;
$flags .= "e";
}
- if ($pmflags & PMf_EVAL) {
+ {
+ local $self->{in_subst_repl} = 1;
+ if ($pmflags & PMf_EVAL) {
$repl = $self->deparse($repl->first, 0);
- } else {
+ } else {
$repl = $self->dq($repl);
+ }
}
my $extended = ($pmflags & PMf_EXTENDED);
if (null $kid) {
@@ -5297,7 +5336,7 @@ parameter twice:
warnings => [FATAL => qw/void io/],
);
-See L<perllexwarn> for more information about lexical warnings.
+See L<warnings> for more information about lexical warnings.
=item hint_bits