Deparse.pm revision 7c478bd95313f5f23a4c958a745db2134aa03244
# B::Deparse.pm
# Copyright (c) 1998, 1999, 2000 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;
$VERSION = 0.60;
use strict;
# 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_THREADS)
# - 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
# Todo:
# - finish tr/// changes
# - add option for even more parens (generalize \&foo change)
# - {} around variables in strings ("${var}letters")
# - recognize `use utf8', `use integer', etc
# - treat top-level block specially for incremental output
# - interpret high bit chars in string as utf8 \x{...} (when?)
# - 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'?
# - include values of variables (e.g. set in BEGIN)
# - coordinate with Data::Dumper (both directions? see previous)
# - avoid string copies (pass arrays, one big join?)
# - auto-apply `-u'?
# - -uPackage:: descend recursively?
# - here-docs?
# - <DATA>?
# Tests that will always fail:
# 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
#
# curstash:
# name of the current package for deparsed code
#
# subs_todo:
# array of [cop_seq, GV, 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)
#
# 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 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;
} else {
$seq = 0;
}
}
sub next_todo {
my $self = shift;
if ($ent->[2]) {
return "format $name =\n"
} else {
}
}
sub walk_tree {
my $kid;
}
}
}
sub walk_sub {
my $self = shift;
my $cv = shift;
my $op = shift;
}
}
});
}
sub stash_subs {
my $self = shift;
my $pack = shift;
if ($pack eq "main") {
$pack = "";
} else {
}
if ($class eq "PV") {
# Just a prototype
} elsif ($class eq "IV") {
# Just a name
} 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->{'subs_todo'} = [];
while (my $arg = shift @_) {
} elsif ($arg eq "-p") {
} elsif ($arg eq "-l") {
} elsif ($arg eq "-q") {
} elsif ($arg =~ /^-x(\d)$/) {
}
}
return $self;
}
sub compile {
my(@args) = @_;
return sub {
print $self->print_protos;
@{$self->{'subs_todo'}} =
my @text;
while (scalar(@{$self->{'subs_todo'}})) {
}
}
}
sub coderef2text {
my $self = shift;
my $sub = shift;
}
sub deparse {
my $self = shift;
# cluck if class($op) eq "NULL";
# cluck unless $op;
# return $self->$ {\("pp_" . $op->name)}($op, $cx);
}
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 .= ": ";
}
# skip leavesub
return $proto . "{\n\t" .
} else { # XSUB?
return $proto . "{}\n";
}
}
sub deparse_format {
my $self = shift;
my $form = shift;
my @text;
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;
));
}
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;
} 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 (want_scalar($op)) {
return "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
# pp_rcatline -- does not exist
sub pp_enter { # see also leave
cluck "unexpected OP_ENTER";
return "XXX";
}
sub pp_pushmark { # see also list
cluck "unexpected OP_PUSHMARK";
return "XXX";
}
sub pp_leavesub { # see also deparse_sub
cluck "unexpected OP_LEAVESUB";
return "XXX";
}
sub pp_leavewrite { # see also deparse_format
cluck "unexpected OP_LEAVEWRITE";
return "XXX";
}
sub pp_method { # see also entersub
cluck "unexpected OP_METHOD";
return "XXX";
}
sub pp_regcmaybe { # see also regcomp
cluck "unexpected OP_REGCMAYBE";
return "XXX";
}
sub pp_regcreset { # see also regcomp
cluck "unexpected OP_REGCRESET";
return "XXX";
}
sub pp_substcont { # see also subst
cluck "unexpected OP_SUBSTCONT";
return "XXX";
}
sub pp_grepstart { # see also grepwhile
cluck "unexpected OP_GREPSTART";
return "XXX";
}
sub pp_mapstart { # see also mapwhile
cluck "unexpected OP_MAPSTART";
return "XXX";
}
sub pp_flip { # see also flop
cluck "unexpected OP_FLIP";
return "XXX";
}
sub pp_iter { # see also leaveloop
cluck "unexpected OP_ITER";
return "XXX";
}
sub pp_enteriter { # see also leaveloop
cluck "unexpected OP_ENTERITER";
return "XXX";
}
sub pp_enterloop { # see also leaveloop
cluck "unexpected OP_ENTERLOOP";
return "XXX";
}
sub pp_leaveeval { # see also entereval
cluck "unexpected OP_LEAVEEVAL";
return "XXX";
}
sub pp_entertry { # see also leavetry
cluck "unexpected OP_ENTERTRY";
return "XXX";
}
sub lineseq {
my $self = shift;
my(@ops) = @_;
for (my $i = 0; $i < @ops; $i++) {
$expr = "";
$i++;
last if $i > $#ops;
}
{
$i++;
next;
}
}
return join(";\n", @exprs);
}
sub scopeop {
my $kid;
my @kids;
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 {
}
}
# 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 =~ /^\^../) {
}
}
# Notice how subs and formats are inserted between statements here
sub pp_nextstate {
my $self = shift;
my @text;
while (scalar(@{$self->{'subs_todo'}})
}
push @text, "package $stash;\n";
}
if ($self->{'linenums'}) {
}
return join("", @text);
}
sub pp_dbstate { pp_nextstate(@_) }
sub pp_setstate { pp_nextstate(@_) }
sub baseop {
my $self = shift;
return $name;
}
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;
} else {
}
}
sub pp_exists {
my $self = shift;
$cx, 16);
}
sub pp_delete {
my $self = shift;
my $arg;
$cx, 16);
} else {
$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;
#cluck "curcv was undef" unless $self->{curcv};
}
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;
}
# 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) {
}
}
# `.' 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);
}
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 {
}
}
}
$cx, 5);
}
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.
{
last;
}
$local = "my";
$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;
my $head = "";
my $bare = 0;
my $body;
my $cond = undef;
$cond = "";
} else {
$bare = 1;
}
{
} else {
}
} else { # regular my() variable
{
# If the scope of this variable closes at the last
# statement of the loop, it must have been
# declared here.
}
}
}
$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 penultimate child, except
# in a bare loop, when it will point to the leaveloop. When neither of
# these conditions hold, then the third-to-last child in the continue
# block (or the last in a bare loop).
my $cont;
if ($bare) {
} else {
}
}
my @states;
}
$cont = "\cK";
} else {
}
} else {
$cont = "\cK";
}
}
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);
} 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;
}
sub rv2x {
my $self = shift;
}
# skip rv2av
sub pp_av2arylen {
my $self = shift;
} else {
}
}
# skip down to the old, ex-rv2cv
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;
}
} else {
# $x[20][3]{hi} or expr->[20]
}
}
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 ($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 "&";
}
or ($chr eq "\@"
or ($chr eq "%"
#or ($chr eq "&" # This doesn't work
# && $real->first->name eq "rv2cv")
or ($chr eq "*"
{
} 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 = "";
}
my $args;
if ($amper eq "&") {
}
} else {
}
} else {
}
} else {
return $kid;
} else {
}
}
}
# escape things that cause interpolation in double quotes,
# but not character escapes
sub uninterp {
my($str) = @_;
return $str;
}
# the same, but treat $|, $), and $ at the end of the string differently
sub re_uninterp {
my($str) = @_;
return $str;
}
# character escapes, but not delimiters that might need to be escaped
sub escape_str { # ASCII
my($str) = @_;
$str =~ s/\a/\\a/g;
# $str =~ s/\cH/\\b/g; # \b means someting 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;
}
# Don't do this for regexen
sub unback {
my($str) = @_;
$str =~ s/\\/\\\\/g;
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 {
return "$q$str" if $succeed;
}
if ($default) {
return "$default$str$default";
} else {
$str =~ s[/][\\/]g;
return "$q/$str/";
}
}
sub const {
my $sv = shift;
} else {
if ($str =~ /[^ -~]/) { # ASCII for non-printing
} else {
}
}
}
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;
# if ($op->private & OPpCONST_BARE) { # trouble with `=>' autoquoting
# return $self->const_sv($op)->PV;
# }
# return const($sv);
}
sub dq {
my $self = shift;
my $op = shift;
if ($type eq "const") {
} elsif ($type eq "concat") {
# Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
if ($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/";
}
}
sub pchr { # ASCII
my($n) = @_;
if ($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;
}
# and backslashes.
sub tr_decode_byte {
{
if ($tr >= 0) {
@from = ord("-");
} else { # -2 ==> delete
$delhyphen = 1;
}
}
for ($c = 0; $c < 256; $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 "\\-";
} 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;
my $op = shift;
if ($type eq "const") {
} elsif ($type eq "concat") {
# Disambiguate "${foo}bar", "${foo}{bar}", "${foo}[1]"
if ($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_regcomp {
my $self = shift;
}
# 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;
}
} else {
}
my $flags = "";
$re =~ s/\?/\\?/g;
$re = "?$re?";
} else {
}
if ($binop) {
} else {
return $re;
}
}
sub pp_split {
my $self = shift;
if ($ {$kid->pmreplroot}) {
}
}
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 {
}
}
} 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<,-u>I<PACKAGE>][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.
Please note that this module is mainly new and untested code and is
still under development, so it may change in the future.
=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<-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<-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<-u>I<PACKAGE>
Normally, B::Deparse deparses the main code of a program, all the subs
called by the main program (and all the subs called by them,
recursively), and any other subs in the main:: package. To include
subs in other packages that aren't called directly, such as AUTOLOAD,
DESTROY, other subs called automatically by perl, and methods (which
aren't resolved to subs until runtime), use the B<-u> option. The
argument to B<-u> is the name of a package, and should follow directly
after the 'u'. Multiple B<-u> options may be given, separated by
commas. Note that unlike some other backends, B::Deparse doesn't
(yet) try to guess automatically when B<-u> is needed -- you must
invoke it yourself.
=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, 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 7, 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 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
See the 'to do' list at the beginning of the module file.
=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, Hugo van
der Sanden, Gurusamy Sarathy, and Nick Ing-Simmons.
=cut