deparse.pm

Altera recommends the following system configuration: * Pentium II 400 with 512-MB system memory (fa

# B::Deparse.pm
# Copyright (c) 1998, 1999, 2000 Stephen McCamant. All rights reserved.
# This module is free software; you can redistribute and/or modify
# 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 'cluck', 'croak';
use B qw(class main_root main_start main_cv svref_2object opnumber
	 OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
	 OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL
	 OPpLVAL_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
	 OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
	 SVf_IOK SVf_NOK SVf_ROK SVf_POK
         CVf_METHOD CVf_LOCKED CVf_LVALUE
	 PMf_KEEP PMf_GLOBAL PMf_CONTINUE PMf_EVAL PMf_ONCE
	 PMf_MULTILINE PMf_SINGLELINE PMf_FOLD PMf_EXTENDED);
$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
# - 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 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")
#   base/lex.t 25-27
#   comp/term.t 11
# - left/right context
# - 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, ...
# - print big ints as hex/octal instead of decimal (heuristic?)
# - handle `my $x if 0'?
# - include values of variables (e.g. set in BEGIN)
# - coordinate with Data::Dumper (both directions? see previous)
# - version using op_next instead of op_first/sibling?
# - avoid string copies (pass arrays, one big join?)
# - auto-apply `-u'?
# - -uPackage:: descend recursively?
# - here-docs?
# - <DATA>?

# Tests that will always fail:
# comp/redef.t -- all (redefinition happens at compile time)

# 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;
    return class($op) eq "NULL";
}

sub todo {
    my $self = shift;
    my($gv, $cv, $is_form) = @_;
    my $seq;
    if (!null($cv->START) and is_state($cv->START)) {
	$seq = $cv->START->cop_seq;
    } else {
	$seq = 0;
    }
    push @{$self->{'subs_todo'}}, [$seq, $gv, $is_form];
}

sub next_todo {
    my $self = shift;
    my $ent = shift @{$self->{'subs_todo'}};
    my $name = $self->gv_name($ent->[1]);
    if ($ent->[2]) {
	return "format $name =\n"
	    . $self->deparse_format($ent->[1]->FORM). "\n";
    } else {
	return "sub $name " . $self->deparse_sub($ent->[1]->CV);
    }
}

sub walk_tree {
    my($op, $sub) = @_;
    $sub->($op);
    if ($op->flags & OPf_KIDS) {
	my $kid;
	for ($kid = $op->first; not null $kid; $kid = $kid->sibling) {
	    walk_tree($kid, $sub);
	}
    }
}

sub walk_sub {
    my $self = shift;
    my $cv = shift;
    my $op = $cv->ROOT;
    $op = shift if null $op;
    return if !$op or null $op;
    walk_tree($op, sub {
	my $op = shift;
	if ($op->name eq "gv") {
	    my $gv = $self->gv_or_padgv($op);
	    if ($op->next->name eq "entersub") {
		return if $self->{'subs_done'}{$$gv}++;
		return if class($gv->CV) eq "SPECIAL";
		$self->todo($gv, $gv->CV, 0);
		$self->walk_sub($gv->CV);
	    } elsif ($op->next->name eq "enterwrite"
		     or ($op->next->name eq "rv2gv"
			 and $op->next->next->name eq "enterwrite")) {
		return if $self->{'forms_done'}{$$gv}++;
		return if class($gv->FORM) eq "SPECIAL";
		$self->todo($gv, $gv->FORM, 1);
		$self->walk_sub($gv->FORM);
	    }
	}
    });
}

sub stash_subs {
    my $self = shift;
    my $pack = shift;
    my(%stash, @ret);
    { no strict 'refs'; %stash = svref_2object(\%{$pack . "::"})->ARRAY }
    if ($pack eq "main") {
	$pack = "";
    } else {
	$pack = $pack . "::";
    }
    my($key, $val);
    while (($key, $val) = each %stash) {
	my $class = class($val);
	if ($class eq "PV") {
	    # Just a prototype
	    push @{$self->{'protos_todo'}}, [$pack . $key, $val->PV];
	} elsif ($class eq "IV") {
	    # Just a name
	    push @{$self->{'protos_todo'}}, [$pack . $key, undef];	    
	} elsif ($class eq "GV") {
	    if (class($val->CV) ne "SPECIAL") {
		next if $self->{'subs_done'}{$$val}++;
		$self->todo($val, $val->CV, 0);
		$self->walk_sub($val->CV);
	    }
	    if (class($val->FORM) ne "SPECIAL") {
		next if $self->{'forms_done'}{$$val}++;
		$self->todo($val, $val->FORM, 1);
		$self->walk_sub($val->FORM);
	    }
	}
    }
}

sub print_protos {
    my $self = shift;
    my $ar;
    my @ret;
    foreach $ar (@{$self->{'protos_todo'}}) {
	my $proto = (defined $ar->[1] ? " (". $ar->[1] . ")" : "");
	push @ret, "sub " . $ar->[0] .  "$proto;\n";
    }
    delete $self->{'protos_todo'};
    return @ret;
}

sub style_opts {
    my $self = shift;
    my $opts = shift;
    my $opt;
    while (length($opt = substr($opts, 0, 1))) {
	if ($opt eq "C") {
	    $self->{'cuddle'} = " ";
	    $opts = substr($opts, 1);
	} elsif ($opt eq "i") {
	    $opts =~ s/^i(\d+)//;
	    $self->{'indent_size'} = $1;
	} elsif ($opt eq "T") {
	    $self->{'use_tabs'} = 1;
	    $opts = substr($opts, 1);
	} elsif ($opt eq "v") {
	    $opts =~ s/^v([^.]*)(.|$)//;
	    $self->{'ex_const'} = $1;
	}
    }
}

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    $self->{'subs_todo'} = [];
    $self->{'curstash'} = "main";
    $self->{'cuddle'} = "\n";
    $self->{'indent_size'} = 4;
    $self->{'use_tabs'} = 0;
    $self->{'expand'} = 0;
    $self->{'unquote'} = 0;
    $self->{'linenums'} = 0;
    $self->{'parens'} = 0;
    $self->{'ex_const'} = "'???'";
    while (my $arg = shift @_) {
	if (substr($arg, 0, 2) eq "-u") {
	    $self->stash_subs(substr($arg, 2));
	} elsif ($arg eq "-p") {
	    $self->{'parens'} = 1;
	} elsif ($arg eq "-l") {
	    $self->{'linenums'} = 1;
	} elsif ($arg eq "-q") {
	    $self->{'unquote'} = 1;
	} elsif (substr($arg, 0, 2) eq "-s") {
	    $self->style_opts(substr $arg, 2);
	} elsif ($arg =~ /^-x(\d)$/) {
	    $self->{'expand'} = $1;
	}
    }
    return $self;
}

sub compile {
    my(@args) = @_;
    return sub { 
	my $self = B::Deparse->new(@args);
	$self->stash_subs("main");
	$self->{'curcv'} = main_cv;
	$self->walk_sub(main_cv, main_start);
	print $self->print_protos;
	@{$self->{'subs_todo'}} =
	  sort {$a->[0] <=> $b->[0]} @{$self->{'subs_todo'}};
	print $self->indent($self->deparse(main_root, 0)), "\n"
	  unless null main_root;
	my @text;
	while (scalar(@{$self->{'subs_todo'}})) {
	    push @text, $self->next_todo;
	}
	print $self->indent(join("", @text)), "\n" if @text;
    }
}

sub coderef2text {
    my $self = shift;
    my $sub = shift;
    croak "Usage: ->coderef2text(CODEREF)" unless ref($sub) eq "CODE";
    return $self->indent($self->deparse_sub(svref_2object($sub)));
}

sub deparse {
    my $self = shift;
    my($op, $cx) = @_;
#    cluck if class($op) eq "NULL";
#    cluck unless $op;
#    return $self->$ {\("pp_" . $op->name)}($op, $cx);
    my $meth = "pp_" . $op->name;
    return $self->$meth($op, $cx);
}

sub indent {
    my $self = shift;
    my $txt = shift;
    my @lines = split(/\n/, $txt);
    my $leader = "";
    my $level = 0;
    my $line;
    for $line (@lines) {
	my $cmd = substr($line, 0, 1);
	if ($cmd eq "\t" or $cmd eq "\b") {
	    $level += ($cmd eq "\t" ? 1 : -1) * $self->{'indent_size'};
	    if ($self->{'use_tabs'}) {
		$leader = "\t" x ($level / 8) . " " x ($level % 8);
	    } else {
		$leader = " " x $level;
	    }
	    $line = substr($line, 1);
	}
	if (substr($line, 0, 1) eq "\f") {
	    $line = substr($line, 1); # no indent
	} else {
	    $line = $leader . $line;