SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
CVf_METHOD CVf_LVALUE
PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
- PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED),
- ($] < 5.008004 ? () : 'OPpSORT_INPLACE'),
- ($] < 5.008006 ? () : qw(OPpSORT_DESCEND OPpITER_REVERSED)),
- ($] < 5.008009 ? () : qw(OPpCONST_NOVER OPpPAD_STATE)),
- ($] < 5.009 ? 'PMf_SKIPWHITE' : qw(RXf_SKIPWHITE)),
- ($] < 5.011 ? 'CVf_LOCKED' : 'OPpREVERSE_INPLACE'),
- ($] < 5.013 ? () : 'PMf_NONDESTRUCT'),
- ($] < 5.015003 &&
- # This empirical feature test is required during the
- # transitional phase where blead still identifies itself
- # as 5.15.2 but has had $[ removed. After blead has its
- # version number bumped to 5.15.3, this can be reduced to
- # just test $] < 5.015003.
- ($] < 5.015002 || do { require B; exists(&B::OPpCONST_ARYBASE) })
- ? qw(OPpCONST_ARYBASE) : ());
-$VERSION = "1.09";
+ PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
+$VERSION = "1.10";
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
BEGIN {
+ # List version-specific constants here.
# Easiest way to keep this code portable between version looks to
# be to fake up a dummy constant that will never actually be true.
foreach (qw(OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED OPpCONST_NOVER
- OPpPAD_STATE RXf_SKIPWHITE CVf_LOCKED OPpREVERSE_INPLACE
- PMf_NONDESTRUCT OPpCONST_ARYBASE)) {
+ OPpPAD_STATE PMf_SKIPWHITE RXf_SKIPWHITE
+ CVf_LOCKED OPpREVERSE_INPLACE OPpSUBSTR_REPL_FIRST
+ PMf_NONDESTRUCT OPpCONST_ARYBASE OPpEVAL_BYTES)) {
+ eval { import B $_ };
no strict 'refs';
*{$_} = sub () {0} unless *{$_}{CODE};
}
# - fixed reference constants (\"str")
# - handle empty programs gracefully
# - handle infinite loops (for (;;) {}, while (1) {})
-# - differentiate between `for my $x ...' and `my $x; for $x ...'
+# - differentiate between 'for my $x ...' and 'my $x; for $x ...'
# - various minor cleanups
# - moved globals into an object
-# - added `-u', like B::C
+# - added '-u', like B::C
# - package declarations using cop_stash
# - subs, formats and code sorted by cop_seq
# Changes between 0.51 and 0.52:
# - added documentation
# Changes between 0.52 and 0.53:
# - many changes adding precedence contexts and associativity
-# - added `-p' and `-s' output style options
+# - added '-p' and '-s' output style options
# - various other minor fixes
# Changes between 0.53 and 0.54:
-# - added support for new `for (1..100)' optimization,
+# - added support for new 'for (1..100)' optimization,
# thanks to Gisle Aas
# Changes between 0.54 and 0.55:
# - added support for new qr// construct
# - tested on base/*.t, cmd/*.t, comp/*.t, io/*.t
# - fixed $# on non-lexicals broken in last big rewrite
# - added temporary fix for change in opcode of OP_STRINGIFY
-# - fixed problem in 0.54's for() patch in `for (@ary)'
+# - fixed problem in 0.54's for() patch in 'for (@ary)'
# - fixed precedence in conditional of ?:
-# - tweaked list paren elimination in `my($x) = @_'
+# - tweaked list paren elimination in 'my($x) = @_'
# - made continue-block detection trickier wrt. null ops
# - fixed various prototype problems in pp_entersub
# - added support for sub prototypes that never get GVs
# - added unquoting for special filehandle first arg in truncate
-# - print doubled rv2gv (a bug) as `*{*GV}' instead of illegal `**GV'
+# - print doubled rv2gv (a bug) as '*{*GV}' instead of illegal '**GV'
# - added semicolons at the ends of blocks
-# - added -l `#line' declaration option -- fixes cmd/subval.t 27,28
+# - added -l '#line' declaration option -- fixes cmd/subval.t 27,28
# Changes between 0.56 and 0.561:
# - fixed multiply-declared my var in pp_truncate (thanks to Sarathy)
# - used new B.pm symbolic constants (done by Nick Ing-Simmons)
# Changes after 0.57:
# - added parens in \&foo (patch by Albert Dvornik)
# Changes between 0.57 and 0.58:
-# - fixed `0' statements that weren't being printed
+# - fixed '0' statements that weren't being printed
# - added methods for use from other programs
# (based on patches from James Duncan and Hugo van der Sanden)
# - added -si and -sT to control indenting (also based on a patch from Hugo)
# Changes between 0.58 and 0.59
# - added support for Chip's OP_METHOD_NAMED
# - added support for Ilya's OPpTARGET_MY optimization
-# - elided arrows before `()' subscripts when possible
+# - elided arrows before '()' subscripts when possible
# Changes between 0.59 and 0.60
# - support for method attributes was added
# - some warnings fixed
# - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
# - more style options: brace style, hex vs. octal, quotes, ...
# - print big ints as hex/octal instead of decimal (heuristic?)
-# - handle `my $x if 0'?
+# - handle 'my $x if 0'?
# - version using op_next instead of op_first/sibling?
# - avoid string copies (pass arrays, one big join?)
# - here-docs?
# parens: -p
# linenums: -l
# unquote: -q
-# cuddle: ` ' or `\n', depending on -sC
+# cuddle: ' ' or '\n', depending on -sC
# indent_size: -si
# use_tabs: -sT
# ex_const: -sv
# they're inside an expression or at statement level, etc. (see
# chart below). When ops with children call deparse on them, they pass
# along their precedence. Fractional values are used to implement
-# associativity (`($x + $y) + $z' => `$x + $y + $y') and related
+# associativity ('($x + $y) + $z' => '$x + $y + $y') and related
# parentheses hacks. The major disadvantage of this scheme is that
# it doesn't know about right sides and left sides, so say if you
# assign a listop to a variable, it can't tell it's allowed to leave
# \cS - steal parens (see maybe_parens_unop)
# \n - newline and indent
# \t - increase indent
-# \b - decrease indent (`outdent')
+# \b - decrease indent ('outdent')
# \f - flush left (no indent)
# \cK - kill following semicolon, if any
return $name eq "nextstate" || $name eq "dbstate" || $name eq "setstate";
}
-sub is_miniwhile { # check for one-line loop (`foo() while $y--')
+sub is_miniwhile { # check for one-line loop ('foo() while $y--')
my $op = shift;
return (!null($op) and null($op->sibling)
and $op->name eq "null" and class($op) eq "UNOP"
}
}
-# same as above, but get around the `if it looks like a function' rule
+# same as above, but get around the 'if it looks like a function' rule
sub maybe_parens_unop {
my $self = shift;
my($name, $kid, $cx) = @_;
return $name . substr($kid, 1);
} elsif (substr($kid, 0, 1) eq "(") {
# avoid looks-like-a-function trap with extra parens
- # (`+' can lead to ambiguities)
+ # ('+' can lead to ambiguities)
return "$name(" . $kid . ")";
} else {
return "$name $kid";
$self->{'hints'} = $hints;
}
- # hack to check that the hint hash hasn't changed
if ($] > 5.009 &&
- "@{[sort %{$self->{'hinthash'} || {}}]}"
- ne "@{[sort %{$op->hints_hash->HASH || {}}]}") {
- push @text, declare_hinthash($self->{'hinthash'}, $op->hints_hash->HASH, $self->{indent_size});
+ @text != push @text, declare_hinthash(
+ $self->{'hinthash'}, $op->hints_hash->HASH,
+ $self->{indent_size}
+ )
+ ) {
$self->{'hinthash'} = $op->hints_hash->HASH;
}
my @decls;
for my $key (keys %$to) {
next if $ignored_hints{$key};
- if (!defined $from->{$key} or $from->{$key} ne $to->{$key}) {
- push @decls, qq(\$^H{'$key'} = q($to->{$key}););
+ if (!exists $from->{$key} or $from->{$key} ne $to->{$key}) {
+ push @decls,
+ qq(\$^H{) . single_delim("q", "'", $key) . qq(} = )
+ . (
+ defined $to->{$key}
+ ? single_delim("q", "'", $to->{$key})
+ : 'undef'
+ )
+ . qq(;);
}
}
for my $key (keys %$from) {
push @decls, qq(delete \$^H{'$key'};);
}
}
- @decls or return '';
+ @decls or return;
return join("\n" . (" " x $indent), "BEGIN {", @decls) . "\n}\n";
}
when => 'switch',
default => 'switch',
break => 'switch',
+ evalbytes=>'evalbytes',
+ __SUB__ => '__SUB__',
);
sub keyword {
my $name = shift;
return $name if $name =~ /^CORE::/; # just in case
if (exists $feature_keywords{$name}) {
- return
- $self->{'hinthash'}
- && $self->{'hinthash'}{"feature_$feature_keywords{$name}"}
- ? $name
- : "CORE::$name";
+ return "CORE::$name"
+ if !$self->{'hinthash'}
+ || !$self->{'hinthash'}{"feature_$feature_keywords{$name}"}
}
if (
- $name !~ /^(?:chom?p|exec|s(?:elect|ystem))\z/
+ $name !~ /^(?:chom?p|do|exec|glob|s(?:elect|ystem))\z/
&& !defined eval{prototype "CORE::$name"}
) { return $name }
if (
sub unop {
my $self = shift;
- my($op, $cx, $name) = @_;
+ my($op, $cx, $name, $nollafr) = @_;
my $kid;
if ($op->flags & OPf_KIDS) {
$kid = $op->first;
$kid = $kid->first;
}
+ if ($nollafr) {
+ ($kid = $self->deparse($kid, 16)) =~ s/^\cS//;
+ return $self->maybe_parens(
+ $self->keyword($name) . " $kid", $cx, 16
+ );
+ }
return $self->maybe_parens_unop($name, $kid, $cx);
} else {
return $self->keyword($name)
sub pp_alarm { unop(@_, "alarm") }
sub pp_sleep { maybe_targmy(@_, \&unop, "sleep") }
-sub pp_dofile { unop(@_, "do") }
-sub pp_entereval { unop(@_, "eval") }
+sub pp_dofile {
+ my $code = unop(@_, "do", 1); # llafr does not apply
+ if ($code =~ s/^do \{/do({/) { $code .= ')' }
+ $code;
+}
+sub pp_entereval {
+ unop(
+ @_,
+ $_[1]->private & OPpEVAL_BYTES ? $_[0]->keyword('evalbytes') : "eval"
+ )
+}
sub pp_ghbyname { unop(@_, "gethostbyname") }
sub pp_gnbyname { unop(@_, "getnetbyname") }
my $self = shift;
my($op, $cx, $name) = @_;
if (class($op) eq "UNOP") {
- # Genuine `-X' filetests are exempt from the LLAFR, but not
+ # Genuine '-X' filetests are exempt from the LLAFR, but not
# l?stat(); for the sake of clarity, give'em all parens
return $self->maybe_parens_unop($name, $op->first, $cx);
} elsif (class($op) =~ /^(SV|PAD)OP$/) {
my $op = shift;
my $name = $op->name;
if ($name eq "concat" and $op->first->name eq "concat") {
- # avoid spurious `=' -- see comment in pp_concat
+ # avoid spurious '=' -- see comment in pp_concat
return "concat";
}
if ($name eq "null" and class($op) eq "UNOP"
return $name . ($op->flags & OPf_STACKED ? "=" : "");
}
-# Left associative operators, like `+', for which
+# Left associative operators, like '+', for which
# $a + $b + $c is equivalent to ($a + $b) + $c
BEGIN {
}
}
-# Right associative operators, like `=', for which
+# Right associative operators, like '=', for which
# $a = $b = $c is equivalent to $a = ($b = $c)
BEGIN {
}
}
-# `.' is special because concats-of-concats are optimized to save copying
+# '.' is special because concats-of-concats are optimized to save copying
# by making all but the first concat stacked. The effect is as if the
-# programmer had written `($a . $b) .= $c', except legal.
+# programmer had written '($a . $b) .= $c', except legal.
sub pp_concat { maybe_targmy(@_, \&real_concat) }
sub real_concat {
my $self = shift;
return $self->maybe_parens("$left .$eq $right", $cx, $prec);
}
-# `x' is weird when the left arg is a list
+# 'x' is weird when the left arg is a list
sub pp_repeat {
my $self = shift;
my($op, $cx) = @_;
sub listop {
my $self = shift;
- my($op, $cx, $name) = @_;
+ my($op, $cx, $name, $kid, $nollafr) = @_;
my(@exprs);
my $parens = ($cx >= 5) || $self->{'parens'};
- my $kid = $op->first->sibling;
+ $kid ||= $op->first->sibling;
return $self->keyword($name) if null $kid;
my $first;
$name = "socketpair" if $name eq "sockpair";
if ($name eq "chmod" && $first =~ /^\d+$/) {
$first = sprintf("%#o", $first);
}
- $first = "+$first" if not $parens and substr($first, 0, 1) eq "(";
+ $first = "+$first"
+ if not $parens and not $nollafr and substr($first, 0, 1) eq "(";
push @exprs, $first;
$kid = $kid->sibling;
if (defined $proto && $proto =~ /^\*\*/ && $kid->name eq "rv2gv") {
return "$exprs[0] = $fullname"
. ($parens ? "($exprs[0])" : " $exprs[0]");
}
- if ($parens) {
+ if ($parens && $nollafr) {
+ return "($fullname " . join(", ", @exprs) . ")";
+ } elsif ($parens) {
return "$fullname(" . join(", ", @exprs) . ")";
} else {
return "$fullname " . join(", ", @exprs);
sub pp_bless { listop(@_, "bless") }
sub pp_atan2 { maybe_targmy(@_, \&listop, "atan2") }
-sub pp_substr { maybe_local(@_, listop(@_, "substr")) }
+sub pp_substr {
+ my ($self,$op,$cx) = @_;
+ if ($op->private & OPpSUBSTR_REPL_FIRST) {
+ return
+ listop($self, $op, 7, "substr", $op->first->sibling->sibling)
+ . " = "
+ . $self->deparse($op->first->sibling, 7);
+ }
+ maybe_local(@_, listop(@_, "substr"))
+}
sub pp_vec { maybe_local(@_, listop(@_, "vec")) }
sub pp_index { maybe_targmy(@_, \&listop, "index") }
sub pp_rindex { maybe_targmy(@_, \&listop, "rindex") }
sub pp_reverse { listop(@_, "reverse") }
sub pp_warn { listop(@_, "warn") }
sub pp_die { listop(@_, "die") }
-# Actually, return is exempt from the LLAFR (see examples in this very
-# module!), but for consistency's sake, ignore that fact
-sub pp_return { listop(@_, "return") }
+sub pp_return { listop(@_, "return", undef, 1) } # llafr does not apply
sub pp_open { listop(@_, "open") }
sub pp_pipe_op { listop(@_, "pipe") }
sub pp_tie { listop(@_, "tie") }
my $self = shift;
my($op, $cx) = @_;
my $text = $self->dq($op->first->sibling); # skip pushmark
+ my $keyword =
+ $op->flags & OPf_SPECIAL ? 'glob' : $self->keyword('glob');
if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
- or $text =~ /[<>]/) {
- return 'glob(' . single_delim('qq', '"', $text) . ')';
+ or $keyword =~ /^CORE::/
+ or $text =~ /[<>]/) {
+ return "$keyword(" . single_delim('qq', '"', $text) . ')';
} else {
return '<' . $text . '>';
}
my $self = shift;
my($op, $cx, $name) = @_;
my($expr, @exprs);
- my $kid = $op->first->sibling;
+ my $firstkid = my $kid = $op->first->sibling;
my $indir = "";
if ($op->flags & OPf_STACKED) {
$indir = $kid;
$indir = '{$b cmp $a} ';
}
for (; !null($kid); $kid = $kid->sibling) {
- $expr = $self->deparse($kid, 6);
+ $expr = $self->deparse($kid, !$indir && $kid == $firstkid && $name eq "sort" && $firstkid->name eq "entersub" ? 16 : 6);
push @exprs, $expr;
}
my $name2;
}
my $args = $indir . join(", ", @exprs);
- if ($indir ne "" and $name eq "sort") {
+ if ($indir ne "" && $name eq "sort") {
# We don't want to say "sort(f 1, 2, 3)", since perl -w will
# give bareword warnings in that case. Therefore if context
# requires, we'll put parens around the outside "(sort f 1, 2,
} else {
return "$name2 $args";
}
+ } elsif (
+ !$indir && $name eq "sort"
+ && $op->first->sibling->name eq 'entersub'
+ ) {
+ # We cannot say sort foo(bar), as foo will be interpreted as a
+ # comparison routine. We have to say sort(...) in that case.
+ return "$name2($args)";
} else {
return $self->maybe_parens_func($name2, $args, $cx, 5);
}
my($op, $cx) = @_;
my($expr, @exprs);
my $kid = $op->first->sibling; # skip pushmark
+ return '' if class($kid) eq 'NULL';
my $lop;
my $local = "either"; # could be local(...), my(...), state(...) or our(...)
for ($lop = $kid; !null($lop); $lop = $lop->sibling) {
# doesn't get flattened by the append_elem that adds the method,
# making a (object, arg1, arg2, ...) list where the object
# usually is. This can be distinguished from
- # `($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
+ # '($obj, $arg1, $arg2)->meth()' (which is legal if $arg2 is an
# object) because in the later the list is in scalar context
# as the left side of -> always is, while in the former
# the list is in list context as method arguments always are.
}
return { method => $meth, variable_method => ref($meth),
- object => $obj, args => \@exprs };
+ object => $obj, args => \@exprs },
+ $cx;
}
# compat function only
}
sub e_method {
- my ($self, $info) = @_;
+ my ($self, $info, $cx) = @_;
my $obj = $self->deparse($info->{object}, 24);
my $meth = $info->{method};
$meth = $self->deparse($meth, 1) if $info->{variable_method};
my $args = join(", ", map { $self->deparse($_, 6) } @{$info->{args}} );
+ if ($info->{object}->name eq 'scope' && want_list $info->{object}) {
+ # method { $object }
+ # This must be deparsed this way to preserve list context
+ # of $object.
+ my $need_paren = $cx >= 6;
+ return '(' x $need_paren
+ . $meth . substr($obj,2) # chop off the "do"
+ . " $args"
+ . ')' x $need_paren;
+ }
my $kid = $obj . "->" . $meth;
if (length $args) {
return $kid . "(" . $args . ")"; # parens mandatory
}
}
}
- return "&" if $proto and !$doneok; # too few args and no `;'
+ return "&" if $proto and !$doneok; # too few args and no ';'
return "&" if @args; # too many args
return ("", join ", ", @reals);
}
}
return "{" . join(", ", @elts) . "}";
} elsif (class($ref) eq "CV") {
+ BEGIN {
+# Commented out until after 5.15.6
+# if ($] > 5.0150051) {
+ require overloading;
+ unimport overloading;
+# }
+ }
+ # Remove the 1|| after 5.15.6
+ if ((1||$] > 5.0150051) && $self->{curcv} &&
+ $self->{curcv}->object_2svref == $ref->object_2svref) {
+ return $self->keyword("__SUB__");
+ }
return "sub " . $self->deparse_sub($ref);
}
if ($ref->FLAGS & SVs_SMG) {
if ($op->private & OPpCONST_ARYBASE) {
return '$[';
}
-# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
+# if ($op->private & OPpCONST_BARE) { # trouble with '=>' autoquoting
# return $self->const_sv($op)->PV;
# }
my $sv = $self->const_sv($op);
if (($succeed, $to) = balanced_delim($to) and $succeed) {
return "$from$to";
} else {
- for $delim ('/', '"', '#') { # note no `'' -- s''' is special
+ for $delim ('/', '"', '#') { # note no "'" -- s''' is special
return "$from$delim$to$delim" if index($to, $delim) == -1;
}
$to =~ s[/][\\/]g;
sub pp_pushre { matchop(@_, "m", "/") }
sub pp_qr { matchop(@_, "qr", "") }
+sub pp_runcv { unop(@_, "__SUB__"); }
+
sub pp_split {
my $self = shift;
my($op, $cx) = @_;
https://perl5.git.perl.org / perl5.git / blobdiff