Deparse.pm revision 7c478bd95313f5f23a4c958a745db2134aa03244
# B::Deparse.pm
# Copyright (c) 1998-2000, 2002, 2003 Stephen McCamant. All rights reserved.
# it under the same terms as Perl itself.
# This is based on the module of the same name by Malcolm Beattie,
# but essentially none of his code remains.
package B::Deparse;
use Carp;
# Not sure if I really should have this as maint's version, given that Deparse
# differs from blead. (latter has // support)
$VERSION = 0.66;
use strict;
use vars qw/$AUTOLOAD/;
use warnings ();
# Changes between 0.50 and 0.51:
# - fixed nulled leave with live enter in sort { }
# - fixed reference constants (\"str")
# - handle empty programs gracefully
# - handle infinte loops (for (;;) {}, while (1) {})
# - differentiate between `for my $x ...' and `my $x; for $x ...'
# - various minor cleanups
# - moved globals into an object
# - 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 pp_threadsv (special variables under USE_5005THREADS)
# - added documentation
# Changes between 0.52 and 0.53:
# - many changes adding precedence contexts and associativity
# - 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,
# thanks to Gisle Aas
# Changes between 0.54 and 0.55:
# - added support for new qr// construct
# - added support for new pp_regcreset OP
# Changes between 0.55 and 0.56:
# - 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 precedence in conditional of ?:
# - 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'
# - added semicolons at the ends of blocks
# 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 between 0.561 and 0.57:
# - stylistic changes to symbolic constant stuff
# - handled scope in s///e replacement code
# - added unquote option for expanding "" into concats, etc.
# - split method and proto parts of pp_entersub into separate functions
# - various minor cleanups
# 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
# - 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)
# - added -sv to print something else instead of '???'
# - preliminary version of utf8 tr/// handling
# Changes after 0.58:
# - uses of $op->ppaddr changed to new $op->name (done by Sarathy)
# - added support for Hugo's new OP_SETSTATE (like nextstate)
# 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
# Changes between 0.59 and 0.60
# - support for method attribues was added
# - some warnings fixed
# - separate recognition of constant subs
# - rewrote continue block handling, now recoginizing for loops
# - added more control of expanding control structures
# Changes between 0.60 and 0.61 (mostly by Robin Houston)
# - many bug-fixes
# - support for pragmas and 'use'
# - support for the little-used $[ variable
# - support for __DATA__ sections
# - UTF8 support
# - BEGIN, CHECK, INIT and END blocks
# - scoping of subroutine declarations fixed
# - compile-time output from the input program can be suppressed, so that the
# output is just the deparsed code. (a change to O.pm in fact)
# - our() declarations
# - *all* the known bugs are now listed in the BUGS section
# - comprehensive test mechanism (TEST -deparse)
# Changes between 0.62 and 0.63 (mostly by Rafael Garcia-Suarez)
# - bug-fixes
# - new switch -P
# - support for command-line switches (-l, -0, etc.)
# Changes between 0.63 and 0.64
# - support for //, CHECK blocks, and assertions
# - improved handling of foreach loops and lexicals
# - option to use Data::Dumper for constants
# - more bug fixes
# - discovered lots more bugs not yet fixed
# Todo:
# (See also BUGS section at the end of this file)
#
# - finish tr/// changes
# - add option for even more parens (generalize \&foo change)
# - copy comments (look at real text with $^P?)
# - avoid semis in one-statement blocks
# - associativity of &&=, ||=, ?:
# - ',' => '=>' (auto-unquote?)
# - break long lines ("\r" as discretionary break?)
# - configurable syntax highlighting: ANSI color, HTML, TeX, etc.
# - more style options: brace style, hex vs. octal, quotes, ...
# - handle `my $x if 0'?
# - avoid string copies (pass arrays, one big join?)
# - here-docs?
# Current test.deparse failures
# comp/assertions 38 - disabled assertions should be like "my($x) if 0"
# 'sub f : assertion {}; no assertions; my $x=1; {f(my $x=2); print "$x\n"}'
# perl -Ifoo -e 'print @INC'
# 'use warnings; BEGIN {${^WARNING_BITS} eq "U"x12;} use warnings::register'
# 'my $x : shared = 5'
# 'BEGIN{*CORE::GLOBAL::require=sub {}} require v5.6'
# c.f. 'BEGIN { *f = sub {0} }; f 2'
# 'use charnames ":short"; $x="\N{latin:a with acute}"'
# 'sub f { f($x) }'
# Object fields (were globals):
#
# avoid_local:
# (local($a), local($b)) and local($a, $b) have the same internal
# representation but the short form looks better. We notice we can
# use a large-scale local when checking the list, but need to prevent
# individual locals too. This hash holds the addresses of OPs that
# have already had their local-ness accounted for. The same thing
# is done with my().
#
# curcv:
# CV for current sub (or main program) being deparsed
#
# curcvlex:
# Cached hash of lexical variables for curcv: keys are names,
# each value is an array of pairs, indicating the cop_seq of scopes
# in which a var of that name is valid.
#
# curcop:
# COP for statement being deparsed
#
# curstash:
# name of the current package for deparsed code
#
# subs_todo:
# array of [cop_seq, CV, is_format?] for subs and formats we still
# want to deparse
#
# protos_todo:
# as above, but [name, prototype] for subs that never got a GV
#
# subs_done, forms_done:
# keys are addresses of GVs for subs and formats we've already
# deparsed (or at least put into subs_todo)
#
# subs_declared
# keys are names of subs for which we've printed declarations.
# That means we can omit parentheses from the arguments.
#
# subs_deparsed
# Keeps track of fully qualified names of all deparsed subs.
#
# parens: -p
# linenums: -l
# unquote: -q
# cuddle: ` ' or `\n', depending on -sC
# indent_size: -si
# use_tabs: -sT
# ex_const: -sv
# A little explanation of how precedence contexts and associativity
# work:
#
# deparse() calls each per-op subroutine with an argument $cx (short
# for context, but not the same as the cx* in the perl core), which is
# a number describing the op's parents in terms of precedence, whether
# 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
# 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
# the parens off the listop.
# Precedences:
# 26 [TODO] inside interpolation context ("")
# 25 left terms and list operators (leftward)
# 24 left ->
# 23 nonassoc ++ --
# 22 right **
# 21 right ! ~ \ and unary + and -
# 20 left =~ !~
# 19 left * / % x
# 18 left + - .
# 17 left << >>
# 16 nonassoc named unary operators
# 15 nonassoc < > <= >= lt gt le ge
# 14 nonassoc == != <=> eq ne cmp
# 13 left &
# 12 left | ^
# 11 left &&
# 10 left ||
# 9 nonassoc .. ...
# 8 right ?:
# 7 right = += -= *= etc.
# 6 left , =>
# 5 nonassoc list operators (rightward)
# 4 right not
# 3 left and
# 2 left or xor
# 1 statement modifiers
# 0.5 statements, but still print scopes as do { ... }
# 0 statement level
# Nonprinting characters with special meaning:
# \cS - steal parens (see maybe_parens_unop)
# \n - newline and indent
# \t - increase indent
# \b - decrease indent (`outdent')
# \f - flush left (no indent)
# \cK - kill following semicolon, if any
sub null {
my $op = shift;
}
sub todo {
my $self = shift;
my $seq;
if ($cv->OUTSIDE_SEQ) {
} else {
$seq = 0;
}
}
}
sub next_todo {
my $self = shift;
if ($ent->[2]) {
return "format $name =\n"
} else {
if ($name eq "BEGIN") {
return () if 0 == length($use_dec);
return $use_dec;
}
}
my $l = '';
if ($self->{'linenums'}) {
$l = "\n\f#line $line \"$file\"\n";
}
my $p = '';
$p = "package $stash;\n";
}
}
}
}
# Return a "use" declaration for this BEGIN block, if appropriate
sub begin_is_use {
#require B::Debug;
#B::walkoptree($cv->ROOT, "debug");
my $module;
# Actually it should always be a bareword
$module =~ s[/][::]g;
}
else {
}
my $version;
# We have a version parameter; skip nextstate & pushmark
# Includes PVIV and PVNV
} else {
# version specified as a v-string
}
}
return "use $module $version ();\n" if defined $version;
return "use $module ();\n";
}
# See if there are import arguments
my $args = '';
# Pull out the arguments
}
my $use = 'use';
my $method_named = $svop;
if ($method_name eq "unimport") {
$use = 'no';
}
# Certain pragmas are dealt with using hint bits,
# so we ignore them here
return "";
}
return "$use $module $version ($args);\n";
} elsif (defined $version) {
return "$use $module $version;\n";
} elsif (length $args) {
return "$use $module ($args);\n";
} else {
return "$use $module;\n";
}
}
sub stash_subs {
if (!defined $pack) {
$pack = '';
$stash = \%::;
}
else {
$pack =~ s/(::)?$/::/;
no strict 'refs';
}
if ($class eq "PV") {
# Just a prototype. As an ugly but fairly effective way
# to find out if it belongs here is to see if the AUTOLOAD
# (if any) for the stash was defined in one of our files.
my $A = $stash{"AUTOLOAD"};
}
} elsif ($class eq "IV") {
# Just a name. As above.
my $A = $stash{"AUTOLOAD"};
}
} elsif ($class eq "GV") {
}
}
}
}
}
}
sub print_protos {
my $self = shift;
my $ar;
my @ret;
}
delete $self->{'protos_todo'};
return @ret;
}
sub style_opts {
my $self = shift;
my $opts = shift;
my $opt;
if ($opt eq "C") {
} elsif ($opt eq "i") {
$opts =~ s/^i(\d+)//;
} elsif ($opt eq "T") {
} elsif ($opt eq "v") {
$opts =~ s/^v([^.]*)(.|$)//;
}
}
}
sub new {
my $class = shift;
$self->{'curcop'} = undef;
$self->{'files'} = {};
$self->{'subs_todo'} = [];
while (my $arg = shift @_) {
if ($arg eq "-d") {
} elsif ($arg =~ /^-f(.*)/) {
} elsif ($arg eq "-l") {
} elsif ($arg eq "-p") {
} elsif ($arg eq "-P") {
} elsif ($arg eq "-q") {
} elsif ($arg =~ /^-x(\d)$/) {
}
}
return $self;
}
{
# Mask out the bits that L<warnings::register> uses
my $WARN_MASK;
BEGIN {
}
sub WARN_MASK () {
return $WARN_MASK;
}
}
# Initialise the contextual information, either from
# defaults provided with the ambient_pragmas method,
# or from perl's own defaults otherwise.
sub init {
my $self = shift;
: undef;
# also a convenient place to clear out subs_declared
delete $self->{'subs_declared'};
}
sub compile {
my(@args) = @_;
return sub {
# First deparse command-line args
if (defined $^I) { # deparse -i
print q(BEGIN { $^I = ).perlstring($^I).qq(; }\n);
}
if ($^W) { # deparse -w
print qq(BEGIN { \$^W = $^W; }\n);
}
}
}
$self->stash_subs();
local($SIG{"__DIE__"}) =
sub {
if ($self->{'curcop'}) {
print STDERR "While deparsing $file near line $line,\n";
}
};
$self->{'curcvlex'} = undef;
print $self->print_protos;
@{$self->{'subs_todo'}} =
my @text;
while (scalar(@{$self->{'subs_todo'}})) {
}
# Print __DATA__ section, if necessary
no strict 'refs';
print "package $laststash;\n"
print "__DATA__\n";
print readline(*{$laststash."::DATA"});
}
}
}
sub coderef2text {
my $self = shift;
my $sub = shift;
}
sub ambient_pragmas {
my $self = shift;
while (@_ > 1) {
my $name = shift();
my $val = shift();
if ($name eq 'strict') {
require strict;
if ($val eq 'none') {
next();
}
my @names;
if ($val eq "all") {
}
elsif (ref $val) {
}
else {
}
}
elsif ($name eq '$[') {
}
elsif ($name eq 'integer'
|| $name eq 'bytes'
|| $name eq 'utf8') {
require "$name.pm";
if ($val) {
}
else {
}
}
elsif ($name eq 're') {
require re;
if ($val eq 'none') {
next();
}
my @names;
if ($val eq 'all') {
}
elsif (ref $val) {
}
else {
}
}
elsif ($name eq 'warnings') {
if ($val eq 'none') {
next();
}
my @names;
if (ref $val) {
}
else {
}
}
elsif ($name eq 'warning_bits') {
$warning_bits = $val;
}
elsif ($name eq 'hint_bits') {
}
else {
croak "Unknown pragma type: $name";
}
}
if (@_) {
croak "The ambient_pragmas method expects an even number of args";
}
}
# This method is the inner loop, so try to keep it simple
sub deparse {
my $self = shift;
}
sub indent {
my $self = shift;
my $txt = shift;
my $leader = "";
my $level = 0;
my $line;
if ($self->{'use_tabs'}) {
} else {
}
}
} else {
}
}
return join("\n", @lines);
}
sub deparse_sub {
my $self = shift;
my $cv = shift;
my $proto = "";
}
$proto .= ": ";
}
local($self->{'curcvlex'});
local(@$self{qw'curstash warnings hints'})
= @$self{qw'curstash warnings hints'};
my $body;
my @ops;
push @ops, $o;
}
if (defined $scope_en) {
}
}
else {
}
}
else {
if ($$sv) {
# uh-oh. inlinable sub... format it differently
} else { # XSUB? (or just a declaration)
return "$proto;\n";
}
}
}
sub deparse_format {
my $self = shift;
my $form = shift;
my @text;
local($self->{'curcvlex'});
local(@$self{qw'curstash warnings hints'})
= @$self{qw'curstash warnings hints'};
my $kid;
my @exprs;
}
}
}
sub is_scope {
my $op = shift;
}
sub is_state {
}
sub is_miniwhile { # check for one-line loop (`foo() while $y--')
my $op = shift;
));
}
# Check if the op and its sibling are the initialization and the rest of a
# for (..;..;..) { ... } loop
sub is_for_loop {
my $op = shift;
# This OP might be almost anything, though it won't be a
# nextstate. (It's the initialization, so in the canonical case it
# will be an sassign.) The sibling is a lineseq whose first child
# is a nextstate and whose second is a leaveloop.
}
}
return 0;
}
sub is_scalar {
my $op = shift;
}
sub maybe_parens {
my $self = shift;
or $self->{'parens'})
{
$text = "($text)";
# In a unop, let parent reuse our parens; see maybe_parens_unop
return $text;
} else {
return $text;
}
}
# same as above, but get around the `if it looks like a function' rule
sub maybe_parens_unop {
my $self = shift;
}
return "$name($kid)";
} else {
}
# use kid's parens
# avoid looks-like-a-function trap with extra parens
# (`+' can lead to ambiguities)
} else {
return "$name $kid";
}
}
}
sub maybe_parens_func {
my $self = shift;
return "$func($text)";
} else {
return "$func $text";
}
}
sub maybe_local {
my $self = shift;
if( $our_local eq 'our' ) {
die "Unexpected our($text)\n" unless $text =~ /^\W(\w+::)*\w+\z/;
$text =~ s/(\w+::)+//;
}
if (want_scalar($op)) {
return "$our_local $text";
} else {
}
} else {
return $text;
}
}
sub maybe_targmy {
my $self = shift;
} else {
}
}
sub padname_sv {
my $self = shift;
my $targ = shift;
}
sub maybe_my {
my $self = shift;
if (want_scalar($op)) {
return "my $text";
} else {
}
} else {
return $text;
}
}
# The following OPs don't have functions:
# pp_padany -- does not exist after parsing
sub AUTOLOAD {
warn "unexpected OP_".uc $AUTOLOAD;
return "XXX";
} else {
die "Undefined subroutine $AUTOLOAD called";
}
}
sub DESTROY {} # Do not AUTOLOAD
# $root should be the op which represents the root of whatever
# we're sequencing here. If it's undefined, then we don't append
# any subroutine declarations to the deparsed ops, otherwise we
# append appropriate declarations.
sub lineseq {
my $limit_seq;
if (defined $root) {
my $nseq;
}
if defined($self->{'limit_seq'})
for (my $i = 0; $i < @ops; $i++) {
$expr = "";
$i++;
if ($i > $#ops) {
last;
}
}
{
$i++;
next;
}
}
}
$expr =~ s/;\n?\z//;
}
my $subs = "";
}
}
sub scopeop {
my $kid;
my @kids;
local(@$self{qw'curstash warnings hints'})
if ($real_block) {
if (is_miniwhile($kid)) {
if ($name eq "and") {
$name = "while";
} elsif ($name eq "or") {
$name = "until";
} else { # no conditional -> while 1 or until 0
}
return "$body $name $cond";
}
} else {
}
}
} else {
}
}
# This is a special case of scopeop and lineseq, for the case of the
# main_root. The difference is that we print the output statements as
# soon as we get them, for the sake of impatient users.
sub deparse_root {
my $self = shift;
my($op) = @_;
local(@$self{qw'curstash warnings hints'})
= @$self{qw'curstash warnings hints'};
my @kids;
}
for (my $i = 0; $i < @kids; $i++) {
my $expr = "";
$i++;
if ($i > $#kids) {
last;
}
}
if (is_for_loop($kids[$i])) {
$i++;
next;
}
$expr =~ s/;\n?\z//;
$expr .= ";";
print "\n" unless $i == $#kids;
}
}
# The BEGIN {} is used here because otherwise this code isn't executed
# when you run B::Deparse on itself.
my %globalnames;
"ENV", "ARGV", "ARGVOUT", "_"); }
sub gv_name {
my $self = shift;
my $gv = shift;
{
$stash = "";
} else {
}
if ($name =~ /^(\^..|{)/) {
}
}
# Return the name to use for a stash variable.
# If a lexical with the same name is in scope, it may need to be
# fully-qualified.
sub stash_variable {
return "$prefix$name" if $name =~ /::/;
return "$prefix$name";
}
return "$prefix$name";
}
sub lex_in_scope {
}
return 0;
}
sub populate_curcvlex {
my $self = shift;
# an undef CV still in lexical chain
for (my $i=0; $i<@ns; ++$i) {
# Probably that pesky lexical @_
next;
}
? (0, 999999)
}
}
}
# Recurses down the tree, looking for pad variable introductions and COPs
sub find_scope {
carp("Undefined op in find_scope") if !defined $op;
}
elsif (is_state($o)) {
my $c = $o->cop_seq;
}
}
}
}
# Returns a list of subs which should be inserted before the COP
sub cop_subs {
# If we have nephews, then our sequence number indicates
# the cop_seq of the end of some sort of scope.
}
}
sub seq_subs {
my @text;
#push @text, "# ($seq)\n";
return "" if !defined $seq;
while (scalar(@{$self->{'subs_todo'}})
}
return @text;
}
# Notice how subs and formats are inserted between statements here;
# also $[ assignments and pragmas.
sub pp_nextstate {
my $self = shift;
my @text;
push @text, "package $stash;\n";
}
}
my $warning_bits;
}
}
$warning_bits = undef;
}
else {
}
if (defined ($warning_bits) and
}
}
# This should go after of any branches that add statements, to
# increase the chances that it refers to the same line it did in
# the original program.
if ($self->{'linenums'}) {
}
return join("", @text);
}
sub declare_warnings {
return "use warnings;\n";
}
return "no warnings;\n";
}
}
sub declare_hints {
my $decls = "";
$decls .= "use $pragma;\n";
}
$decls .= "no $pragma;\n";
}
return $decls;
}
sub hint_pragmas {
my ($bits) = @_;
my @pragmas;
return @pragmas;
}
sub pp_dbstate { pp_nextstate(@_) }
sub pp_setstate { pp_nextstate(@_) }
sub baseop {
my $self = shift;
return $name;
}
sub pp_stub {
my $self = shift;
if ($cx >= 1) {
return "()";
}
else {
return "();";
}
}
sub POSTFIX () { 1 }
# I couldn't think of a good short name, but this is the category of
# symbolic unary operators with interesting precedence
sub pfixop {
my $self = shift;
}
sub real_negate {
my $self = shift;
# avoid --$x
} else {
}
}
sub pp_i_negate { pp_negate(@_) }
sub pp_not {
my $self = shift;
if ($cx <= 4) {
} else {
}
}
sub unop {
my $self = shift;
my $kid;
if (defined prototype("CORE::$name")
&& prototype("CORE::$name") =~ /^;?\*/
}
} else {
}
}
sub pp_exists {
my $self = shift;
my $arg;
# Checking for the existence of a subroutine
}
# Array element, not hash element
}
$cx, 16);
}
sub pp_delete {
my $self = shift;
my $arg;
# Deleting from an array, not a hash
$cx, 16);
}
$cx, 16);
} else {
# Deleting from an array, not a hash
$cx, 16);
}
$cx, 16);
}
}
sub pp_require {
my $self = shift;
{
$name =~ s[/][::]g;
return "require $name";
} else {
}
}
sub pp_scalar {
my $self = shift;
# XXX Was a here-doc
}
}
sub padval {
my $self = shift;
my $targ = shift;
}
sub pp_refgen {
my $self = shift;
}
return "sub " .
{
# The @a in \(@a) isn't in ref context, but only when the
# parens are there.
} elsif ($sib_name eq 'entersub') {
# Always show parens for \(&func()), but only with -p otherwise
return "\\$text";
}
}
}
}
sub pp_srefgen { pp_refgen(@_) }
sub pp_readline {
my $self = shift;
}
sub pp_rcatline {
my $self = shift;
my($op) = @_;
}
# Unary operators that can occur as pseudo-listops inside double quotes
sub dq_unop {
my $self = shift;
my $kid;
# If there's more than one kid, the first is an ex-pushmark.
} else {
}
}
sub loopex {
my $self = shift;
return $name;
# Note -- loop exits are actually exempt from the
# looks-like-a-func rule, but a few extra parens won't hurt
}
}
sub ftst {
my $self = shift;
# Genuine `-X' filetests are exempt from the LLAFR, but not
# l?stat(); for the sake of clarity, give'em all parens
} else { # I don't think baseop filetests ever survive ck_ftst, but...
return $name;
}
}
sub SWAP_CHILDREN () { 1 }
sub assoc_class {
my $op = shift;
# avoid spurious `=' -- see comment in pp_concat
return "concat";
}
{
# Like all conditional constructs, OP_ANDs and OP_ORs are topped
# with a null that's used as the common end point of the two
# flows of control. For precedence purposes, ignore it.
# (COND_EXPRs have these too, but we don't bother with
# their associativity).
}
}
# Left associative operators, like `+', for which
# $a + $b + $c is equivalent to ($a + $b) + $c
BEGIN {
'divide' => 19, 'i_divide' => 19,
'modulo' => 19, 'i_modulo' => 19,
'repeat' => 19,
'add' => 18, 'i_add' => 18,
'subtract' => 18, 'i_subtract' => 18,
'concat' => 18,
'left_shift' => 17, 'right_shift' => 17,
'bit_and' => 13,
'bit_or' => 12, 'bit_xor' => 12,
'and' => 3,
'or' => 2, 'xor' => 2,
);
}
sub deparse_binop_left {
my $self = shift;
{
} else {
}
}
# Right associative operators, like `=', for which
# $a = $b = $c is equivalent to $a = ($b = $c)
BEGIN {
'sassign=' => 7, 'aassign=' => 7,
'multiply=' => 7, 'i_multiply=' => 7,
'divide=' => 7, 'i_divide=' => 7,
'modulo=' => 7, 'i_modulo=' => 7,
'repeat=' => 7,
'add=' => 7, 'i_add=' => 7,
'subtract=' => 7, 'i_subtract=' => 7,
'concat=' => 7,
'left_shift=' => 7, 'right_shift=' => 7,
'bit_and=' => 7,
'bit_or=' => 7, 'bit_xor=' => 7,
'andassign' => 7,
'orassign' => 7,
);
}
sub deparse_binop_right {
my $self = shift;
{
} else {
}
}
sub binop {
my $self = shift;
my $eq = "";
$eq = "=";
$prec = 7;
}
if ($flags & SWAP_CHILDREN) {
}
&& $left !~ /^(my|our|local|)[\@\(]/;
}
# `.' 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.
sub real_concat {
my $self = shift;
my $eq = "";
my $prec = 18;
$eq = "=";
$prec = 7;
}
}
# `x' is weird when the left arg is a list
sub pp_repeat {
my $self = shift;
my $eq = "";
my $prec = 19;
$eq = "=";
$prec = 7;
}
my @exprs;
}
} else {
}
}
sub range {
my $self = shift;
}
sub pp_flop {
my $self = shift;
}
sub logop {
my $self = shift;
{ # if ($a) {$b}
return "$blockname ($left) {\n\t$right\n\b}\cK";
return "$right $blockname $left";
} else { # $a and $b
}
}
# xor is syntactically a logop, but it's really a binop (contrary to
# old versions of opcode.pl). Syntax is what matters here.
sub logassignop {
my $self = shift;
}
sub listop {
my $self = shift;
my(@exprs);
my $first;
my $proto = prototype("CORE::$name");
if (defined $proto
&& $proto =~ /^;?\*/
}
else {
}
}
}
}
if ($parens) {
} else {
}
}
# Actually, return is exempt from the LLAFR (see examples in this very
# module!), but for consistency's sake, ignore that fact
sub pp_glob {
my $self = shift;
if ($text =~ /^\$?(\w|::|\`)+$/ # could look like a readline
or $text =~ /[<>]/) {
} else {
}
}
# Truncate is special because OPf_SPECIAL makes a bareword first arg
# be a filehandle. This could probably be better fixed in the core
# by moving the GV lookup into ck_truc.
sub pp_truncate {
my $self = shift;
my(@exprs);
my $fh;
# $kid is an OP_CONST
} else {
}
if ($parens) {
return "truncate($fh, $len)";
} else {
return "truncate $fh, $len";
}
}
sub indirop {
my $self = shift;
my $indir = "";
} else {
}
}
: '{$a <=> $b} ';
}
$indir = '{$b cmp $a} ';
}
}
return "$exprs[0] = sort $indir $exprs[0]";
}
# 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,
# 3)". Unfortunately, we'll currently think the parens are
# neccessary more often that they really are, because we don't
# distinguish which side of an assignment we're on.
if ($cx >= 5) {
return "($name $args)";
} else {
return "$name $args";
}
} else {
}
}
sub mapop {
my $self = shift;
} else {
}
}
}
sub pp_list {
my $self = shift;
my $lop;
# This assumes that no other private flags equal 128, and that
# 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.
# I suspect that open and exit can too.
{
last;
}
$local = "my";
$local = "our";
$local = "local";
}
}
if ($local) {
} else {
}
} else {
}
}
if ($local) {
} else {
}
}
sub is_ifelse_cont {
my $op = shift;
}
sub pp_cond_expr {
my $self = shift;
}
my $head = "if ($cond) {\n\t$true\n\b}";
my @elsifs;
push @elsifs, "elsif ($newcond) {\n\t$newtrue\n\b}";
}
} else {
$false = "\cK";
}
}
sub loop_common {
my $self = shift;
local(@$self{qw'curstash warnings hints'})
= @$self{qw'curstash warnings hints'};
my $head = "";
my $bare = 0;
my $body;
my $cond = undef;
$cond = "";
} else {
$bare = 1;
}
{
} else {
}
} else { # regular my() variable
}
# our declarations don't have package names
$var =~ s/^(.).*::/$1/;
$var = "our $var";
}
}
$head = "foreach $var ($ary) ";
$head = "$name ($cond) ";
return "{;}"; # {} could be a hashref
}
# If there isn't a continue block, then the next pointer for the loop
# will point to the unstack, which is kid's last child, except
# in a bare loop, when it will point to the leaveloop. When neither of
# these conditions hold, then the second-to-last child is the continue
# block (or the last in a bare loop).
my $cont;
if ($bare) {
} else {
}
}
my @states;
}
$cont = "\cK";
} else {
}
} else {
return "" if !defined $body;
if (length $init) {
$head = "for ($init; $cond;) ";
}
$cont = "\cK";
}
$body =~ s/;?$/;\n/;
}
sub for_loop {
my $self = shift;
}
sub pp_leavetry {
my $self = shift;
}
sub pp_null {
my $self = shift;
# old value is lost
$cx, 7);
$cx, 20);
$cx, 18);
} else {
}
}
sub padname {
my $self = shift;
my $targ = shift;
}
sub padany {
my $self = shift;
my $op = shift;
}
sub pp_padsv {
my $self = shift;
}
my @threadsv_names;
BEGIN {
"&", "`", "'", "+", "/", ".", ",", "\\", '"', ";",
"^", "-", "%", "=", "|", "~", ":", "^A", "^E",
"!", "@");
}
sub pp_threadsv {
my $self = shift;
}
sub gv_or_padgv {
my $self = shift;
my $op = shift;
} else { # class($op) eq "SVOP"
}
}
sub pp_gvsv {
my $self = shift;
}
sub pp_gv {
my $self = shift;
}
sub pp_aelemfast {
my $self = shift;
my $name;
$name =~ s/^@/\$/;
}
else {
}
}
sub rv2x {
my $self = shift;
carp("Unexpected op in pp_rv2x");
return 'XXX';
}
if ($str =~ /^\$([^\w\d])\z/) {
# "$$+" isn't a legal way to write the scalar dereference
# of $+, since the lexer can't tell you aren't trying to
# do something like "$$ + 1" to get one more than your
# PID. Either "${$+}" or "$${+}" are workable
# disambiguations, but if the programmer did the former,
# they'd be in the "else" clause below rather than here.
# It's not clear if this should somehow be unified with
# the code in dq and re_dq that also adds lexer
# disambiguation braces.
}
} else {
}
}
# skip rv2av
sub pp_av2arylen {
my $self = shift;
} else {
}
}
# skip down to the old, ex-rv2cv
sub pp_rv2cv {
{
}
else {
}
}
sub list_const {
my $self = shift;
if (@a == 0) {
return "()";
} elsif (@a == 1) {
return $a[0];
} elsif ( @a > 2 and !grep(!/^-?\d+$/, @a)) {
# collapse (-1,0,1,2) into (-1..2)
my ($s, $e) = @a[0,-1];
my $i = $s;
unless grep $i++ != $_, @a;
}
}
sub pp_rv2av {
my $self = shift;
} else {
}
}
sub is_subscriptable {
my $op = shift;
return 1;
return is_subscriptable($kid);
} else {
return 0;
}
}
sub elem {
my $self = shift;
}
if ($array !~ /::/) {
}
} else {
# $x[20][3]{hi} or expr->[20]
}
# Outer parens in an array index will confuse perl
# if we're interpolating in a regular expression, i.e.
# /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
#
# If $self->{parens}, then an initial '(' will
# definitely be paired with a final ')'. If
# !$self->{parens}, the misleading parens won't
# have been added in the first place.
#
# [You might think that we could get "(...)...(...)"
# where the initial and final parens do not match
# each other. But we can't, because the above would
# only happen if there's an infix binop between the
# two pairs of parens, and *that* means that the whole
# expression would be parenthesized as well.]
#
# Hash-element braces will autoquote a bareword inside themselves.
# We need to make sure that C<$hash{warn()}> doesn't come out as
# C<$hash{warn}>, which has a quite different meaning. Currently
# B::Deparse will always quote strings, even if the string was a
# bareword in the original (i.e. the OPpCONST_BARE flag is ignored
# for constant strings.) So we can cheat slightly here - if we see
# a bareword, we know that it is supposed to be a function call.
#
}
sub pp_gelem {
my $self = shift;
}
sub slice {
my $self = shift;
my $last;
} else { # ex-hslice inside delete()
}
} else {
}
}
} else {
}
}
sub pp_lslice {
my $self = shift;
return "($list)" . "[$idx]";
}
sub want_scalar {
my $op = shift;
}
sub want_list {
my $op = shift;
}
sub method {
my $self = shift;
# When an indirect object isn't a bareword but the args are in
# parens, the parens aren't part of the method syntax (the LLAFR
# doesn't apply), but they make a list with OPf_PARENS set that
# 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
# 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.
# (Good thing there aren't method prototypes!)
}
} else {
}
}
} else {
# As of 5.005_58, this case is probably obsoleted by the
# method_named case above
} else {
}
}
if (length $args) {
} else {
return $kid;
}
}
# returns "&" if the prototype doesn't match the args,
# or ("", $args_after_prototype_demunging) if it does.
sub check_proto {
my $self = shift;
my $doneok = 0;
my @reals;
# An unbackslashed @ or % gobbles up the rest of the args
while ($proto) {
$proto =~ s/^(\\?[\$\@&%*]|\\\[[\$\@&%*]+\]|;)//;
my $chr = $1;
if ($chr eq "") {
return "&" if @args;
} elsif ($chr eq ";") {
$doneok = 1;
@args = ();
} else {
last unless $arg;
if ($chr eq "\$") {
if (want_scalar $arg) {
} else {
return "&";
}
} elsif ($chr eq "&") {
} else {
return "&";
}
} elsif ($chr eq "*") {
{
} else {
}
} else {
return "&";
}
$chr =~ tr/\\[]//d;
or ($chr =~ /@/
or ($chr =~ /%/
#or ($chr =~ /&/ # This doesn't work
# && $real->first->name eq "rv2cv")
or ($chr =~ /\*/
{
} else {
return "&";
}
}
}
}
}
sub pp_entersub {
my $self = shift;
my $prefix = "";
my $amper = "";
$prefix = "do ";
$amper = "&";
}
}
my $simple = 0;
my $proto = undef;
$amper = "&";
}
$amper = "&";
} else {
$prefix = "";
}
# Doesn't matter how many prototypes there are, if
# they haven't happened yet!
my $declared;
{
no strict 'refs';
no warnings 'uninitialized';
|| (
&& !exists
);
# Avoid "too early to check prototype" warning
}
}
my $args;
if ($amper eq "&") {
}
} else {
}
} else {
}
} else {
# glob() invocations can be translated into calls of
# CORE::GLOBAL::glob with a second parameter, a number.
# Reverse this.
if ($kid eq "CORE::GLOBAL::glob") {
$kid = "glob";
$args =~ s/\s*,[^,]+$//;
}
# It's a syntax error to call CORE::GLOBAL::foo without a prefix,
# so it must have been translated from a keyword call. Translate
# it back.
if (!$declared) {
} elsif ($dproto eq "") {
return $kid;
# is_scalar is an excessively conservative test here:
# really, we should be comparing to the precedence of the
# top operator of $exprs[0] (ala unop()), but that would
# take some major code restructuring to do right.
} else {
}
}
}
# escape things that cause interpolation in double quotes,
# but not character escapes
sub uninterp {
my($str) = @_;
return $str;
}
{
my $bal;
BEGIN {
use re "eval";
# Matches any string which is balanced with respect to {braces}
$bal = qr(
(?:
[^\\{}]
| \\\\
| \\[{}]
| \{(??{$bal})\}
)*
)x;
}
# the same, but treat $|, $), $( and $ at the end of the string differently
sub re_uninterp {
my($str) = @_;
$str =~ s/
( ^|\G # $1
| [^\\]
)
( # $2
(?:\\\\)*
)
( # $3
(\(\?\??\{$bal\}\)) # $4
| [\$\@]
(?!\||\)|\(|$)
| \\[uUlLQE]
)
return $str;
}
# This is for regular expressions with the /x modifier
# We have to leave comments unmangled.
sub re_uninterp_extended {
my($str) = @_;
$str =~ s/
( ^|\G # $1
| [^\\]
)
( # $2
(?:\\\\)*
)
( # $3
( \(\?\??\{$bal\}\) # $4 (skip over (?{}) and (??{}) blocks)
| \#[^\n]* # (skip over comments)
)
| [\$\@]
(?!\||\)|\(|$|\s)
| \\[uUlLQE]
)
return $str;
}
}
my %unctrl = # portable to to EBCDIC
(
"\c@" => '\c@', # unused
"\cA" => '\cA',
"\cB" => '\cB',
"\cC" => '\cC',
"\cD" => '\cD',
"\cE" => '\cE',
"\cF" => '\cF',
"\cG" => '\cG',
"\cH" => '\cH',
"\cI" => '\cI',
"\cJ" => '\cJ',
"\cK" => '\cK',
"\cL" => '\cL',
"\cM" => '\cM',
"\cN" => '\cN',
"\cO" => '\cO',
"\cP" => '\cP',
"\cQ" => '\cQ',
"\cR" => '\cR',
"\cS" => '\cS',
"\cT" => '\cT',
"\cU" => '\cU',
"\cV" => '\cV',
"\cW" => '\cW',
"\cX" => '\cX',
"\cY" => '\cY',
"\cZ" => '\cZ',
"\c[" => '\c[', # unused
"\c\\" => '\c\\', # unused
"\c]" => '\c]', # unused
"\c_" => '\c_', # unused
);
# character escapes, but not delimiters that might need to be escaped
sub escape_str { # ASCII, UTF8
my($str) = @_;
$str =~ s/\a/\\a/g;
# $str =~ s/\cH/\\b/g; # \b means something different in a regex
$str =~ s/\t/\\t/g;
$str =~ s/\n/\\n/g;
$str =~ s/\e/\\e/g;
$str =~ s/\f/\\f/g;
$str =~ s/\r/\\r/g;
return $str;
}
# For regexes with the /x modifier.
# Leave whitespace unmangled.
sub escape_extended_re {
my($str) = @_;
$str =~ s/([[:^print:]])/
($1 =~ y! \t\n!!) ? $1 : sprintf("\\%03o", ord($1))/ge;
$str =~ s/\n/\n\f/g;
return $str;
}
# Don't do this for regexen
sub unback {
my($str) = @_;
$str =~ s/\\/\\\\/g;
return $str;
}
# Remove backslashes which precede literal control characters,
# to avoid creating ambiguity when we escape the latter.
sub re_unback {
my($str) = @_;
# the insane complexity here is due to the behaviour of "\c\"
return $str;
}
sub balanced_delim {
my($str) = @_;
for $c (@str) {
if ($c eq $open) {
$cnt++;
} elsif ($c eq $close) {
$cnt--;
if ($cnt < 0) {
# qq()() isn't ")("
$fail = 1;
last;
}
}
}
}
return ("", $str);
}
sub single_delim {
if ($q ne 'qr') {
return "$q$str" if $succeed;
}
}
if ($default) {
return "$default$str$default";
} else {
$str =~ s[/][\\/]g;
return "$q/$str/";
}
}
my $max_prec;
# Split a floating point number into an integer mantissa and a binary
# exponent. Assumes you've already made sure the number isn't zero or
# some weird infinity or NaN.
sub split_float {
my($f) = @_;
my $exponent = 0;
if ($f == int($f)) {
while ($f % 2 == 0) {
$f /= 2;
$exponent++;
}
} else {
while ($f != int($f)) {
$f *= 2;
$exponent--;
}
}
my $mantissa = sprintf("%.0f", $f);
}
sub const {
my $self = shift;
if ($self->{'use_dumper'}) {
}
# sv_undef, sv_yes, sv_no
return 'undef';
}
# convert a version object into the "v1.2.3" string in its V magic
}
}
return $str;
if ($nv == 0) {
# positive zero
return "0";
} else {
# negative zero
}
if ($nv > 0) {
# positive infinity
} else {
# negative infinity
}
# NaN
# the normal kind
return "sin(9**9**9)";
# the inverted kind
} else {
# some other kind
return qq'unpack("F", pack("h*", "$hex"))';
}
}
# first, try the default stringification
my $str = "$nv";
# failing that, try using more precision
# if (pack("F", $str) ne pack("F", $nv)) {
# not representable in decimal with whatever sprintf()
# and atof() Perl is using here.
}
}
return $str;
my @elts;
for my $k (sort keys %hash) {
}
}
}
}
}
if ($str =~ /[^ -~]/) { # ASCII for non-printing
} else {
}
} else {
return "undef";
}
}
sub const_dumper {
my $self = shift;
if ($str =~ /^\$v/) {
} else {
return $str;
}
}
sub const_sv {
my $self = shift;
my $op = shift;
# the constant could be in the pad (under useithreads)
return $sv;
}
sub pp_const {
my $self = shift;
return '$[';
}
# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
# return $self->const_sv($op)->PV;
# }
}
sub dq {
my $self = shift;
my $op = shift;
if ($type eq "const") {
} elsif ($type eq "concat") {
# Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]", "$foo\::bar"
($last =~ /^[A-Z\\\^\[\]_?]/ &&
|| ($last =~ /^[:'{\[\w_]/ && #'
} elsif ($type eq "uc") {
} elsif ($type eq "lc") {
} elsif ($type eq "ucfirst") {
} elsif ($type eq "lcfirst") {
} elsif ($type eq "quotemeta") {
} elsif ($type eq "join") {
} else {
}
}
sub pp_backtick {
my $self = shift;
# skip pushmark
}
sub dquote {
my $self = shift;
}
# OP_STRINGIFY is a listop, but it only ever has one arg
# tr/// and s/// (and tr[][], tr[]//, tr###, etc)
sub double_delim {
return "/$from/$to/";
return "$from$to";
} else {
}
$to =~ s[/][\\/]g;
return "$from/$to/";
}
} else {
return "$delim$from$delim$to$delim"
}
$from =~ s[/][\\/]g;
$to =~ s[/][\\/]g;
return "/$from/$to/";
}
}
# Only used by tr///, so backslashes hyphens
sub pchr { # ASCII
my($n) = @_;
if ($n == ord '\\') {
return '\\\\';
} elsif ($n == ord "-") {
return "\\-";
} elsif ($n >= ord(' ') and $n <= ord('~')) {
return chr($n);
} elsif ($n == ord "\a") {
return '\\a';
} elsif ($n == ord "\b") {
return '\\b';
} elsif ($n == ord "\t") {
return '\\t';
} elsif ($n == ord "\n") {
return '\\n';
} elsif ($n == ord "\e") {
return '\\e';
} elsif ($n == ord "\f") {
return '\\f';
} elsif ($n == ord "\r") {
return '\\r';
} elsif ($n >= ord("\cA") and $n <= ord("\cZ")) {
return '\\c' . chr(ord("@") + $n);
} else {
# return '\x' . sprintf("%02x", $n);
return '\\' . sprintf("%03o", $n);
}
}
sub collapse {
my(@chars) = @_;
for ($c = 0; $c < @chars; $c++) {
if ($c <= $#chars - 2 and $chars[$c + 1] == $tr + 1 and
{
for (; $c <= $#chars-1 and $chars[$c + 1] == $chars[$c] + 1; $c++)
{}
$str .= "-";
}
}
return $str;
}
sub tr_decode_byte {
{
if ($tr >= 0) {
@from = ord("-");
} else { # -2 ==> delete
$delhyphen = 1;
}
}
for ($c = 0; $c < @table; $c++) {
if ($tr >= 0) {
} elsif ($tr == -2) {
push @delfrom, $c;
}
}
if ($flags & OPpTRANS_COMPLEMENT) {
my @newfrom = ();
my %from;
for ($c = 0; $c < 256; $c++) {
}
}
pop @to while $#to and $to[$#to] == $to[$#to -1];
}
}
sub tr_chr {
my $x = shift;
if ($x == ord "-") {
return "\\-";
} elsif ($x == ord "\\") {
return "\\\\";
} else {
return chr $x;
}
}
# XXX This doesn't yet handle all cases correctly either
sub tr_decode_utf8 {
my $final = undef;
my $line;
if (length $max) {
} else {
}
} else {
}
}
for my $i (0 .. $#from) {
last;
$from[$i][1]--;
$to[$i][1]--;
unshift @from, ord '-';
unshift @to, ord '-';
last;
}
}
for my $i (0 .. $#delfrom) {
last;
$delfrom[$i][1]--;
push @delfrom, ord '-';
last;
}
}
}
if ($flags & OPpTRANS_COMPLEMENT) {
my @newfrom;
my $next = 0;
for my $i (0 .. $#from) {
}
@from = ();
}
}
}
if ($diff > 1) {
} elsif ($diff == 1) {
} else {
}
}
if ($diff > 1) {
} elsif ($diff == 1) {
} else {
}
}
#$final = sprintf("%04x", $final) if defined $final;
#$none = sprintf("%04x", $none) if defined $none;
#$extra = sprintf("%04x", $extra) if defined $extra;
#print STDERR "final: $final\n none: $none\nextra: $extra\n";
#print STDERR $swash{'LIST'}->PV;
}
sub pp_trans {
my $self = shift;
} else { # class($op) eq "SVOP"
}
my $flags = "";
}
# Like dq(), but different
sub re_dq {
my $self = shift;
if ($type eq "const") {
if $extended;
} elsif ($type eq "concat") {
# Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
($last =~ /^[A-Z\\\^\[\]_?]/ &&
} elsif ($type eq "uc") {
} elsif ($type eq "lc") {
} elsif ($type eq "ucfirst") {
} elsif ($type eq "lcfirst") {
} elsif ($type eq "quotemeta") {
} elsif ($type eq "join") {
} else {
}
}
sub pure_string {
if ($type eq 'const') {
return 1;
}
}
elsif ($type eq 'join') {
}
elsif ($type eq 'concat') {
}
return 1;
}
return 1;
}
else {
return 0;
}
return 1;
}
sub regcomp {
my $self = shift;
}
sub pp_regcomp {
}
# osmic acid -- see osmium tetroxide
my %matchwords;
'cox', 'go', 'is', 'ism', 'iso', 'mig', 'mix', 'osmic', 'ox', 'sic',
'sig', 'six', 'smog', 'so', 'soc', 'sog', 'xi');
sub matchop {
my $self = shift;
$binop = 1;
}
my $quote = 1;
if ($extended) {
} else {
}
} else {
}
my $flags = "";
$re =~ s/\?/\\?/g;
$re = "?$re?";
} elsif ($quote) {
}
if ($binop) {
} else {
return $re;
}
}
sub pp_split {
my $self = shift;
# For our kid (an OP_PUSHRE), pmreplroot is never actually the
# root of a replacement; it's either empty, or abused to point to
# the GV for an array we split into (an optimization to save
# assignment overhead). Depending on whether we're using ithreads,
# this OP* holds either a GV* or a PADOFFSET. Luckily, B.xs
# figures out for us which it is.
my $gv = 0;
if (ref($replroot) eq "B::GV") {
}
}
# handle special case of split(), and split(" ") that compiles to /\s+/
}
if ($ary) {
} else {
return $expr;
}
}
# oxime -- any of various compounds obtained chiefly by the action of
# hydroxylamine on aldehydes and ketones and characterized by the
# bivalent grouping C=NOH [Webster's Tenth]
my %substwords;
'es', 'ex', 'exes', 'gee', 'go', 'goes', 'ie', 'ism', 'iso', 'me',
'meese', 'meso', 'mig', 'mix', 'os', 'ox', 'oxime', 'see', 'seem',
'seg', 'sex', 'sig', 'six', 'smog', 'sog', 'some', 'xi');
sub pp_subst {
my $self = shift;
$binop = 1;
}
my $flags = "";
} else {
$flags .= "e";
}
} else {
}
}
if ($extended) {
}
else {
}
} else {
}
if ($binop) {
$cx, 20);
} else {
}
}
1;
=head1 NAME
B::Deparse - Perl compiler backend to produce perl code
=head1 SYNOPSIS
B<perl> B<-MO=Deparse>[B<,-d>][B<,-f>I<FILE>][B<,-p>][B<,-q>][B<,-l>]
[B<,-s>I<LETTERS>][B<,-x>I<LEVEL>] I<prog.pl>
=head1 DESCRIPTION
B::Deparse is a backend module for the Perl compiler that generates
perl source code, based on the internal compiled structure that perl
itself creates after parsing a program. The output of B::Deparse won't
be exactly the same as the original source, since perl doesn't keep
track of comments or whitespace, and there isn't a one-to-one
correspondence between perl's syntactical constructions and their
compiled form, but it will often be close. When you use the B<-p>
option, the output also includes parentheses even when they are not
required by precedence, which can make it easy to see if perl is
parsing your expressions the way you intended.
While B::Deparse goes to some lengths to try to figure out what your
original program was doing, some parts of the language can still trip
it up; it still fails even on some parts of Perl's own test suite. If
you encounter a failure other than the most common ones described in
the BUGS section below, you can help contribute to B::Deparse's
ongoing development by submitting a bug report with a small
example.
=head1 OPTIONS
As with all compiler backend options, these must follow directly after
the '-MO=Deparse', separated by a comma but not any white space.
=over 4
=item B<-d>
Output data values (when they appear as constants) using Data::Dumper.
Without this option, B::Deparse will use some simple routines of its
own for the same purpose. Currently, Data::Dumper is better for some
kinds of data (such as complex structures with sharing and
self-reference) while the built-in routines are better for others
(such as odd floating-point values).
=item B<-f>I<FILE>
Normally, B::Deparse deparses the main code of a program, and all the subs
defined in the same file. To include subs defined in other files, pass the
B<-f> option with the filename. You can pass the B<-f> option several times, to
include more than one secondary file. (Most of the time you don't want to
use it at all.) You can also use this option to include subs which are
defined in the scope of a B<#line> directive with two parameters.
=item B<-l>
Add '#line' declarations to the output based on the line and file
locations of the original code.
=item B<-p>
Print extra parentheses. Without this option, B::Deparse includes
parentheses in its output only when they are needed, based on the
structure of your program. With B<-p>, it uses parentheses (almost)
whenever they would be legal. This can be useful if you are used to
LISP, or if you want to see how perl parses your input. If you say
if ($var & 0x7f == 65) {print "Gimme an A!"}
print ($which ? $a : $b), "\n";
$name = $ENV{USER} or "Bob";
C<B::Deparse,-p> will print
if (($var & 0)) {
print('Gimme an A!')
};
(print(($which ? $a : $b)), '???');
(($name = $ENV{'USER'}) or '???')
which probably isn't what you intended (the C<'???'> is a sign that
perl optimized away a constant value).
=item B<-P>
Disable prototype checking. With this option, all function calls are
deparsed as if no prototype was defined for them. In other words,
perl -MO=Deparse,-P -e 'sub foo (\@) { 1 } foo @x'
will print
sub foo (\@) {
1;
}
&foo(\@x);
making clear how the parameters are actually passed to C<foo>.
=item B<-q>
Expand double-quoted strings into the corresponding combinations of
concatenation, uc, ucfirst, lc, lcfirst, quotemeta, and join. For
instance, print
print "Hello, $world, @ladies, \u$gentlemen\E, \u\L$me!";
as
print 'Hello, ' . $world . ', ' . join($", @ladies) . ', '
. ucfirst($gentlemen) . ', ' . ucfirst(lc $me . '!');
Note that the expanded form represents the way perl handles such
constructions internally -- this option actually turns off the reverse
translation that B::Deparse usually does. On the other hand, note that
C<$x = "$y"> is not the same as C<$x = $y>: the former makes the value
of $y into a string before doing the assignment.
=item B<-s>I<LETTERS>
Tweak the style of B::Deparse's output. The letters should follow
directly after the 's', with no space or punctuation. The following
options are available:
=over 4
=item B<C>
Cuddle C<elsif>, C<else>, and C<continue> blocks. For example, print
if (...) {
...
} else {
...
}
instead of
if (...) {
...
}
else {
...
}
The default is not to cuddle.
=item B<i>I<NUMBER>
Indent lines by multiples of I<NUMBER> columns. The default is 4 columns.
=item B<T>
Use tabs for each 8 columns of indent. The default is to use only spaces.
For instance, if the style options are B<-si4T>, a line that's indented
3 times will be preceded by one tab and four spaces; if the options were
B<-si8T>, the same line would be preceded by three tabs.
=item B<v>I<STRING>B<.>
Print I<STRING> for the value of a constant that can't be determined
because it was optimized away (mnemonic: this happens when a constant
is used in B<v>oid context). The end of the string is marked by a period.
The string should be a valid perl expression, generally a constant.
Note that unless it's a number, it probably needs to be quoted, and on
a command line quotes need to be protected from the shell. Some
conventional values include 0, 1, 42, '', 'foo', and
'Useless use of constant omitted' (which may need to be
B<-sv"'Useless use of constant omitted'.">
or something similar depending on your shell). The default is '???'.
If you're using B::Deparse on a module or other file that's require'd,
you shouldn't use a value that evaluates to false, since the customary
true constant at the end of a module will be in void context when the
file is compiled as a main program.
=back
=item B<-x>I<LEVEL>
Expand conventional syntax constructions into equivalent ones that expose
their internal operation. I<LEVEL> should be a digit, with higher values
meaning more expansion. As with B<-q>, this actually involves turning off
special cases in B::Deparse's normal operations.
If I<LEVEL> is at least 3, C<for> loops will be translated into equivalent
while loops with continue blocks; for instance
for ($i = 0; $i < 10; ++$i) {
print $i;
}
turns into
$i = 0;
while ($i < 10) {
print $i;
} continue {
++$i
}
Note that in a few cases this translation can't be perfectly carried back
into the source code -- if the loop's initializer declares a my variable,
for instance, it won't have the correct scope outside of the loop.
If I<LEVEL> is at least 5, C<use> declarations will be translated into
C<BEGIN> blocks containing calls to C<require> and C<import>; for
instance,
use strict 'refs';
turns into
sub BEGIN {
require strict;
do {
'strict'->import('refs')
};
}
If I<LEVEL> is at least 7, C<if> statements will be translated into
equivalent expressions using C<&&>, C<?:> and C<do {}>; for instance
print 'hi' if $nice;
if ($nice) {
print 'hi';
}
if ($nice) {
print 'hi';
} else {
print 'bye';
}
turns into
$nice and print 'hi';
$nice and do { print 'hi' };
$nice ? do { print 'hi' } : do { print 'bye' };
Long sequences of elsifs will turn into nested ternary operators, which
B::Deparse doesn't know how to indent nicely.
=back
=head1 USING B::Deparse AS A MODULE
=head2 Synopsis
use B::Deparse;
$deparse = B::Deparse->new("-p", "-sC");
$body = $deparse->coderef2text(\&func);
eval "sub func $body"; # the inverse operation
=head2 Description
B::Deparse can also be used on a sub-by-sub basis from other perl
programs.
=head2 new
$deparse = B::Deparse->new(OPTIONS)
Create an object to store the state of a deparsing operation and any
options. The options are the same as those that can be given on the
command line (see L</OPTIONS>); options that are separated by commas
after B<-MO=Deparse> should be given as separate strings. Some
options, like B<-u>, don't make sense for a single subroutine, so
don't pass them.
=head2 ambient_pragmas
$deparse->ambient_pragmas(strict => 'all', '$[' => $[);
The compilation of a subroutine can be affected by a few compiler
directives, B<pragmas>. These are:
=over 4
=item *
use strict;
=item *
use warnings;
=item *
Assigning to the special variable $[
=item *
use integer;
=item *
use bytes;
=item *
use utf8;
=item *
use re;
=back
Ordinarily, if you use B::Deparse on a subroutine which has
been compiled in the presence of one or more of these pragmas,
the output will include statements to turn on the appropriate
directives. So if you then compile the code returned by coderef2text,
it will behave the same way as the subroutine which you deparsed.
However, you may know that you intend to use the results in a
particular context, where some pragmas are already in scope. In
this case, you use the B<ambient_pragmas> method to describe the
assumptions you wish to make.
Not all of the options currently have any useful effect. See
L</BUGS> for more details.
The parameters it accepts are:
=over 4
=item strict
Takes a string, possibly containing several values separated
by whitespace. The special values "all" and "none" mean what you'd
expect.
$deparse->ambient_pragmas(strict => 'subs refs');
=item $[
Takes a number, the value of the array base $[.
=item bytes
=item utf8
=item integer
If the value is true, then the appropriate pragma is assumed to
be in the ambient scope, otherwise not.
=item re
Takes a string, possibly containing a whitespace-separated list of
values. The values "all" and "none" are special. It's also permissible
to pass an array reference here.
$deparser->ambient_pragmas(re => 'eval');
=item warnings
Takes a string, possibly containing a whitespace-separated list of
values. The values "all" and "none" are special, again. It's also
permissible to pass an array reference here.
$deparser->ambient_pragmas(warnings => [qw[void io]]);
If one of the values is the string "FATAL", then all the warnings
in that list will be considered fatal, just as with the B<warnings>
pragma itself. Should you need to specify that some warnings are
fatal, and others are merely enabled, you can pass the B<warnings>
parameter twice:
$deparser->ambient_pragmas(
warnings => 'all',
);
See L<perllexwarn> for more information about lexical warnings.
=item hint_bits
=item warning_bits
These two parameters are used to specify the ambient pragmas in
the format used by the special variables $^H and ${^WARNING_BITS}.
They exist principally so that you can write code like:
{ my ($hint_bits, $warning_bits);
BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
$deparser->ambient_pragmas (
hint_bits => $hint_bits,
warning_bits => $warning_bits,
'$[' => 0 + $[
); }
which specifies that the ambient pragmas are exactly those which
are in scope at the point of calling.
=back
=head2 coderef2text
$body = $deparse->coderef2text(\&func)
$body = $deparse->coderef2text(sub ($$) { ... })
Return source code for the body of a subroutine (a block, optionally
preceded by a prototype in parens), given a reference to the
sub. Because a subroutine can have no names, or more than one name,
this method doesn't return a complete subroutine definition -- if you
want to eval the result, you should prepend "sub subname ", or "sub "
for an anonymous function constructor. Unless the sub was defined in
the main:: package, the code will include a package declaration.
=head1 BUGS
=over 4
=item *
The only pragmas to be completely supported are: C<use warnings>,
C<use strict 'refs'>, C<use bytes>, and C<use integer>. (C<$[>, which
behaves like a pragma, is also supported.)
Excepting those listed above, we're currently unable to guarantee that
B::Deparse will produce a pragma at the correct point in the program.
(Specifically, pragmas at the beginning of a block often appear right
before the start of the block instead.)
Since the effects of pragmas are often lexically scoped, this can mean
that the pragma holds sway over a different portion of the program
than in the input file.
=item *
In fact, the above is a specific instance of a more general problem:
we can't guarantee to produce BEGIN blocks or C<use> declarations in
exactly the right place. So if you use a module which affects compilation
(such as by over-riding keywords, overloading constants or whatever)
then the output code might not work as intended.
This is the most serious outstanding problem, and will require some help
from the Perl core to fix.
=item *
If a keyword is over-ridden, and your program explicitly calls
the built-in version by using CORE::keyword, the output of B::Deparse
will not reflect this. If you run the resulting code, it will call
the over-ridden version rather than the built-in one. (Maybe there
should be an option to B<always> print keyword calls as C<CORE::name>.)
=item *
Some constants don't print correctly either with or without B<-d>.
For instance, neither B::Deparse nor Data::Dumper know how to print
dual-valued scalars correctly, as in:
use constant E2BIG => ($!=7); $y = E2BIG; print $y, 0+$y;
=item *
An input file that uses source filtering probably won't be deparsed into
runnable code, because it will still include the B<use> declaration
for the source filtering module, even though the code that is
produced is already ordinary Perl which shouldn't be filtered again.
=item *
There are probably many more bugs on non-ASCII platforms (EBCDIC).
=back
=head1 AUTHOR
Stephen McCamant <smcc@CSUA.Berkeley.EDU>, based on an earlier version
by Malcolm Beattie <mbeattie@sable.ox.ac.uk>, with contributions from
Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael
Garcia-Suarez.
=cut