1921 lines
59 KiB
Perl
1921 lines
59 KiB
Perl
|
package B::Concise;
|
||
|
# Copyright (C) 2000-2003 Stephen McCamant. All rights reserved.
|
||
|
# This program is free software; you can redistribute and/or modify it
|
||
|
# under the same terms as Perl itself.
|
||
|
|
||
|
# Note: we need to keep track of how many use declarations/BEGIN
|
||
|
# blocks this module uses, so we can avoid printing them when user
|
||
|
# asks for the BEGIN blocks in her program. Update the comments and
|
||
|
# the count in concise_specials if you add or delete one. The
|
||
|
# -MO=Concise counts as use #1.
|
||
|
|
||
|
use strict; # use #2
|
||
|
use warnings; # uses #3 and #4, since warnings uses Carp
|
||
|
|
||
|
use Exporter (); # use #5
|
||
|
|
||
|
our $VERSION = "1.004";
|
||
|
our @ISA = qw(Exporter);
|
||
|
our @EXPORT_OK = qw( set_style set_style_standard add_callback
|
||
|
concise_subref concise_cv concise_main
|
||
|
add_style walk_output compile reset_sequence );
|
||
|
our %EXPORT_TAGS =
|
||
|
( io => [qw( walk_output compile reset_sequence )],
|
||
|
style => [qw( add_style set_style_standard )],
|
||
|
cb => [qw( add_callback )],
|
||
|
mech => [qw( concise_subref concise_cv concise_main )], );
|
||
|
|
||
|
# use #6
|
||
|
use B qw(class ppname main_start main_root main_cv cstring svref_2object
|
||
|
SVf_IOK SVf_NOK SVf_POK SVf_IVisUV SVf_FAKE OPf_KIDS OPf_SPECIAL
|
||
|
OPf_STACKED
|
||
|
OPpSPLIT_ASSIGN OPpSPLIT_LEX
|
||
|
CVf_ANON CVf_LEXICAL CVf_NAMED
|
||
|
PAD_FAKELEX_ANON PAD_FAKELEX_MULTI SVf_ROK);
|
||
|
|
||
|
my %style =
|
||
|
("terse" =>
|
||
|
["(?(#label =>\n)?)(*( )*)#class (#addr) #name (?([#targ])?) "
|
||
|
. "#svclass~(?((#svaddr))?)~#svval~(?(label \"#coplabel\")?)\n",
|
||
|
"(*( )*)goto #class (#addr)\n",
|
||
|
"#class pp_#name"],
|
||
|
"concise" =>
|
||
|
["#hyphseq2 (*( (x( ;)x))*)<#classsym> #exname#arg(?([#targarglife])?)"
|
||
|
. "~#flags(?(/#private)?)(?(:#hints)?)(x(;~->#next)x)\n"
|
||
|
, " (*( )*) goto #seq\n",
|
||
|
"(?(<#seq>)?)#exname#arg(?([#targarglife])?)"],
|
||
|
"linenoise" =>
|
||
|
["(x(;(*( )*))x)#noise#arg(?([#targarg])?)(x( ;\n)x)",
|
||
|
"gt_#seq ",
|
||
|
"(?(#seq)?)#noise#arg(?([#targarg])?)"],
|
||
|
"debug" =>
|
||
|
["#class (#addr)\n\top_next\t\t#nextaddr\n\t(?(op_other\t#otheraddr\n\t)?)"
|
||
|
. "op_sibling\t#sibaddr\n\t"
|
||
|
. "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n"
|
||
|
. "\top_flags\t#flagval\n\top_private\t#privval\t#hintsval\n"
|
||
|
. "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
|
||
|
. "(?(\top_sv\t\t#svaddr\n)?)",
|
||
|
" GOTO #addr\n",
|
||
|
"#addr"],
|
||
|
"env" => [$ENV{B_CONCISE_FORMAT}, $ENV{B_CONCISE_GOTO_FORMAT},
|
||
|
$ENV{B_CONCISE_TREE_FORMAT}],
|
||
|
);
|
||
|
|
||
|
# Renderings, ie how Concise prints, is controlled by these vars
|
||
|
# primary:
|
||
|
our $stylename; # selects current style from %style
|
||
|
my $order = "basic"; # how optree is walked & printed: basic, exec, tree
|
||
|
|
||
|
# rendering mechanics:
|
||
|
# these 'formats' are the line-rendering templates
|
||
|
# they're updated from %style when $stylename changes
|
||
|
my ($format, $gotofmt, $treefmt);
|
||
|
|
||
|
# lesser players:
|
||
|
my $base = 36; # how <sequence#> is displayed
|
||
|
my $big_endian = 1; # more <sequence#> display
|
||
|
my $tree_style = 0; # tree-order details
|
||
|
my $banner = 1; # print banner before optree is traversed
|
||
|
my $do_main = 0; # force printing of main routine
|
||
|
my $show_src; # show source code
|
||
|
|
||
|
# another factor: can affect all styles!
|
||
|
our @callbacks; # allow external management
|
||
|
|
||
|
set_style_standard("concise");
|
||
|
|
||
|
my $curcv;
|
||
|
my $cop_seq_base;
|
||
|
|
||
|
sub set_style {
|
||
|
($format, $gotofmt, $treefmt) = @_;
|
||
|
#warn "set_style: deprecated, use set_style_standard instead\n"; # someday
|
||
|
die "expecting 3 style-format args\n" unless @_ == 3;
|
||
|
}
|
||
|
|
||
|
sub add_style {
|
||
|
my ($newstyle,@args) = @_;
|
||
|
die "style '$newstyle' already exists, choose a new name\n"
|
||
|
if exists $style{$newstyle};
|
||
|
die "expecting 3 style-format args\n" unless @args == 3;
|
||
|
$style{$newstyle} = [@args];
|
||
|
$stylename = $newstyle; # update rendering state
|
||
|
}
|
||
|
|
||
|
sub set_style_standard {
|
||
|
($stylename) = @_; # update rendering state
|
||
|
die "err: style '$stylename' unknown\n" unless exists $style{$stylename};
|
||
|
set_style(@{$style{$stylename}});
|
||
|
}
|
||
|
|
||
|
sub add_callback {
|
||
|
push @callbacks, @_;
|
||
|
}
|
||
|
|
||
|
# output handle, used with all Concise-output printing
|
||
|
our $walkHandle; # public for your convenience
|
||
|
BEGIN { $walkHandle = \*STDOUT }
|
||
|
|
||
|
sub walk_output { # updates $walkHandle
|
||
|
my $handle = shift;
|
||
|
return $walkHandle unless $handle; # allow use as accessor
|
||
|
|
||
|
if (ref $handle eq 'SCALAR') {
|
||
|
require Config;
|
||
|
die "no perlio in this build, can't call walk_output (\\\$scalar)\n"
|
||
|
unless $Config::Config{useperlio};
|
||
|
# in 5.8+, open(FILEHANDLE,MODE,REFERENCE) writes to string
|
||
|
open my $tmp, '>', $handle; # but cant re-set existing STDOUT
|
||
|
$walkHandle = $tmp; # so use my $tmp as intermediate var
|
||
|
return $walkHandle;
|
||
|
}
|
||
|
my $iotype = ref $handle;
|
||
|
die "expecting argument/object that can print\n"
|
||
|
unless $iotype eq 'GLOB' or $iotype and $handle->can('print');
|
||
|
$walkHandle = $handle;
|
||
|
}
|
||
|
|
||
|
sub concise_subref {
|
||
|
my($order, $coderef, $name) = @_;
|
||
|
my $codeobj = svref_2object($coderef);
|
||
|
|
||
|
return concise_stashref(@_)
|
||
|
unless ref($codeobj) =~ '^B::(?:CV|FM)\z';
|
||
|
concise_cv_obj($order, $codeobj, $name);
|
||
|
}
|
||
|
|
||
|
sub concise_stashref {
|
||
|
my($order, $h) = @_;
|
||
|
my $name = svref_2object($h)->NAME;
|
||
|
foreach my $k (sort keys %$h) {
|
||
|
next unless defined $h->{$k};
|
||
|
my $coderef = ref $h->{$k} eq 'CODE' ? $h->{$k}
|
||
|
: ref\$h->{$k} eq 'GLOB' ? *{$h->{$k}}{CODE} || next
|
||
|
: next;
|
||
|
reset_sequence();
|
||
|
print "FUNC: *", $name, "::", $k, "\n";
|
||
|
my $codeobj = svref_2object($coderef);
|
||
|
next unless ref $codeobj eq 'B::CV';
|
||
|
eval { concise_cv_obj($order, $codeobj, $k) };
|
||
|
warn "err $@ on $codeobj" if $@;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
# This should have been called concise_subref, but it was exported
|
||
|
# under this name in versions before 0.56
|
||
|
*concise_cv = \&concise_subref;
|
||
|
|
||
|
sub concise_cv_obj {
|
||
|
my ($order, $cv, $name) = @_;
|
||
|
# name is either a string, or a CODE ref (copy of $cv arg??)
|
||
|
|
||
|
$curcv = $cv;
|
||
|
|
||
|
if (ref($cv->XSUBANY) =~ /B::(\w+)/) {
|
||
|
print $walkHandle "$name is a constant sub, optimized to a $1\n";
|
||
|
return;
|
||
|
}
|
||
|
if ($cv->XSUB) {
|
||
|
print $walkHandle "$name is XS code\n";
|
||
|
return;
|
||
|
}
|
||
|
if (class($cv->START) eq "NULL") {
|
||
|
no strict 'refs';
|
||
|
if (ref $name eq 'CODE') {
|
||
|
print $walkHandle "coderef $name has no START\n";
|
||
|
}
|
||
|
elsif (exists &$name) {
|
||
|
print $walkHandle "$name exists in stash, but has no START\n";
|
||
|
}
|
||
|
else {
|
||
|
print $walkHandle "$name not in symbol table\n";
|
||
|
}
|
||
|
return;
|
||
|
}
|
||
|
sequence($cv->START);
|
||
|
if ($order eq "exec") {
|
||
|
walk_exec($cv->START);
|
||
|
}
|
||
|
elsif ($order eq "basic") {
|
||
|
# walk_topdown($cv->ROOT, sub { $_[0]->concise($_[1]) }, 0);
|
||
|
my $root = $cv->ROOT;
|
||
|
unless (ref $root eq 'B::NULL') {
|
||
|
walk_topdown($root, sub { $_[0]->concise($_[1]) }, 0);
|
||
|
} else {
|
||
|
print $walkHandle "B::NULL encountered doing ROOT on $cv. avoiding disaster\n";
|
||
|
}
|
||
|
} else {
|
||
|
print $walkHandle tree($cv->ROOT, 0);
|
||
|
}
|
||
|
}
|
||
|
|
||
|
sub concise_main {
|
||
|
my($order) = @_;
|
||
|
sequence(main_start);
|
||
|
$curcv = main_cv;
|
||
|
if ($order eq "exec") {
|
||
|
return if class(main_start) eq "NULL";
|
||
|
walk_exec(main_start);
|
||
|
} elsif ($order eq "tree") {
|
||
|
return if class(main_root) eq "NULL";
|
||
|
print $walkHandle tree(main_root, 0);
|
||
|
} elsif ($order eq "basic") {
|
||
|
return if class(main_root) eq "NULL";
|
||
|
walk_topdown(main_root,
|
||
|
sub { $_[0]->concise($_[1]) }, 0);
|
||
|
}
|
||
|
}
|
||
|
|
||
|
sub concise_specials {
|
||
|
my($name, $order, @cv_s) = @_;
|
||
|
my $i = 1;
|
||
|
if ($name eq "BEGIN") {
|
||
|
splice(@cv_s, 0, 8); # skip 7 BEGIN blocks in this file. NOW 8 ??
|
||
|
} elsif ($name eq "CHECK") {
|
||
|
pop @cv_s; # skip the CHECK block that calls us
|
||
|
}
|
||
|
for my $cv (@cv_s) {
|
||
|
print $walkHandle "$name $i:\n";
|
||
|
$i++;
|
||
|
concise_cv_obj($order, $cv, $name);
|
||
|
}
|
||
|
}
|
||
|
|
||
|
my $start_sym = "\e(0"; # "\cN" sometimes also works
|
||
|
my $end_sym = "\e(B"; # "\cO" respectively
|
||
|
|
||
|
my @tree_decorations =
|
||
|
([" ", "--", "+-", "|-", "| ", "`-", "-", 1],
|
||
|
[" ", "-", "+", "+", "|", "`", "", 0],
|
||
|
[" ", map("$start_sym$_$end_sym", "qq", "wq", "tq", "x ", "mq", "q"), 1],
|
||
|
[" ", map("$start_sym$_$end_sym", "q", "w", "t", "x", "m"), "", 0],
|
||
|
);
|
||
|
|
||
|
my @render_packs; # collect -stash=<packages>
|
||
|
|
||
|
sub compileOpts {
|
||
|
# set rendering state from options and args
|
||
|
my (@options,@args);
|
||
|
if (@_) {
|
||
|
@options = grep(/^-/, @_);
|
||
|
@args = grep(!/^-/, @_);
|
||
|
}
|
||
|
for my $o (@options) {
|
||
|
# mode/order
|
||
|
if ($o eq "-basic") {
|
||
|
$order = "basic";
|
||
|
} elsif ($o eq "-exec") {
|
||
|
$order = "exec";
|
||
|
} elsif ($o eq "-tree") {
|
||
|
$order = "tree";
|
||
|
}
|
||
|
# tree-specific
|
||
|
elsif ($o eq "-compact") {
|
||
|
$tree_style |= 1;
|
||
|
} elsif ($o eq "-loose") {
|
||
|
$tree_style &= ~1;
|
||
|
} elsif ($o eq "-vt") {
|
||
|
$tree_style |= 2;
|
||
|
} elsif ($o eq "-ascii") {
|
||
|
$tree_style &= ~2;
|
||
|
}
|
||
|
# sequence numbering
|
||
|
elsif ($o =~ /^-base(\d+)$/) {
|
||
|
$base = $1;
|
||
|
} elsif ($o eq "-bigendian") {
|
||
|
$big_endian = 1;
|
||
|
} elsif ($o eq "-littleendian") {
|
||
|
$big_endian = 0;
|
||
|
}
|
||
|
# miscellaneous, presentation
|
||
|
elsif ($o eq "-nobanner") {
|
||
|
$banner = 0;
|
||
|
} elsif ($o eq "-banner") {
|
||
|
$banner = 1;
|
||
|
}
|
||
|
elsif ($o eq "-main") {
|
||
|
$do_main = 1;
|
||
|
} elsif ($o eq "-nomain") {
|
||
|
$do_main = 0;
|
||
|
} elsif ($o eq "-src") {
|
||
|
$show_src = 1;
|
||
|
}
|
||
|
elsif ($o =~ /^-stash=(.*)/) {
|
||
|
my $pkg = $1;
|
||
|
no strict 'refs';
|
||
|
if (! %{$pkg.'::'}) {
|
||
|
eval "require $pkg";
|
||
|
} else {
|
||
|
require Config;
|
||
|
if (!$Config::Config{usedl}
|
||
|
&& keys %{$pkg.'::'} == 1
|
||
|
&& $pkg->can('bootstrap')) {
|
||
|
# It is something that we're statically linked to, but hasn't
|
||
|
# yet been used.
|
||
|
eval "require $pkg";
|
||
|
}
|
||
|
}
|
||
|
push @render_packs, $pkg;
|
||
|
}
|
||
|
# line-style options
|
||
|
elsif (exists $style{substr($o, 1)}) {
|
||
|
$stylename = substr($o, 1);
|
||
|
set_style_standard($stylename);
|
||
|
} else {
|
||
|
warn "Option $o unrecognized";
|
||
|
}
|
||
|
}
|
||
|
return (@args);
|
||
|
}
|
||
|
|
||
|
sub compile {
|
||
|
my (@args) = compileOpts(@_);
|
||
|
return sub {
|
||
|
my @newargs = compileOpts(@_); # accept new rendering options
|
||
|
warn "disregarding non-options: @newargs\n" if @newargs;
|
||
|
|
||
|
for my $objname (@args) {
|
||
|
next unless $objname; # skip null args to avoid noisy responses
|
||
|
|
||
|
if ($objname eq "BEGIN") {
|
||
|
concise_specials("BEGIN", $order,
|
||
|
B::begin_av->isa("B::AV") ?
|
||
|
B::begin_av->ARRAY : ());
|
||
|
} elsif ($objname eq "INIT") {
|
||
|
concise_specials("INIT", $order,
|
||
|
B::init_av->isa("B::AV") ?
|
||
|
B::init_av->ARRAY : ());
|
||
|
} elsif ($objname eq "CHECK") {
|
||
|
concise_specials("CHECK", $order,
|
||
|
B::check_av->isa("B::AV") ?
|
||
|
B::check_av->ARRAY : ());
|
||
|
} elsif ($objname eq "UNITCHECK") {
|
||
|
concise_specials("UNITCHECK", $order,
|
||
|
B::unitcheck_av->isa("B::AV") ?
|
||
|
B::unitcheck_av->ARRAY : ());
|
||
|
} elsif ($objname eq "END") {
|
||
|
concise_specials("END", $order,
|
||
|
B::end_av->isa("B::AV") ?
|
||
|
B::end_av->ARRAY : ());
|
||
|
}
|
||
|
else {
|
||
|
# convert function names to subrefs
|
||
|
if (ref $objname) {
|
||
|
print $walkHandle "B::Concise::compile($objname)\n"
|
||
|
if $banner;
|
||
|
concise_subref($order, ($objname)x2);
|
||
|
next;
|
||
|
} else {
|
||
|
$objname = "main::" . $objname unless $objname =~ /::/;
|
||
|
no strict 'refs';
|
||
|
my $glob = \*$objname;
|
||
|
unless (*$glob{CODE} || *$glob{FORMAT}) {
|
||
|
print $walkHandle "$objname:\n" if $banner;
|
||
|
print $walkHandle "err: unknown function ($objname)\n";
|
||
|
return;
|
||
|
}
|
||
|
if (my $objref = *$glob{CODE}) {
|
||
|
print $walkHandle "$objname:\n" if $banner;
|
||
|
concise_subref($order, $objref, $objname);
|
||
|
}
|
||
|
if (my $objref = *$glob{FORMAT}) {
|
||
|
print $walkHandle "$objname (FORMAT):\n"
|
||
|
if $banner;
|
||
|
concise_subref($order, $objref, $objname);
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
for my $pkg (@render_packs) {
|
||
|
no strict 'refs';
|
||
|
concise_stashref($order, \%{$pkg.'::'});
|
||
|
}
|
||
|
|
||
|
if (!@args or $do_main or @render_packs) {
|
||
|
print $walkHandle "main program:\n" if $do_main;
|
||
|
concise_main($order);
|
||
|
}
|
||
|
return @args; # something
|
||
|
}
|
||
|
}
|
||
|
|
||
|
my %labels;
|
||
|
my $lastnext; # remembers op-chain, used to insert gotos
|
||
|
|
||
|
my %opclass = ('OP' => "0", 'UNOP' => "1", 'BINOP' => "2", 'LOGOP' => "|",
|
||
|
'LISTOP' => "@", 'PMOP' => "/", 'SVOP' => "\$", 'GVOP' => "*",
|
||
|
'PVOP' => '"', 'LOOP' => "{", 'COP' => ";", 'PADOP' => "#",
|
||
|
'METHOP' => '.', UNOP_AUX => '+');
|
||
|
|
||
|
no warnings 'qw'; # "Possible attempt to put comments..."; use #7
|
||
|
my @linenoise =
|
||
|
qw'# () sc ( @? 1 $* gv *{ m$ m@ m% m? p/ *$ $ $# & a& pt \\ s\\ rf bl
|
||
|
` *? <> ?? ?/ r/ c/ // qr s/ /c y/ = @= C sC Cp sp df un BM po +1 +I
|
||
|
-1 -I 1+ I+ 1- I- ** * i* / i/ %$ i% x + i+ - i- . " << >> < i<
|
||
|
> i> <= i, >= i. == i= != i! <? i? s< s> s, s. s= s! s? b& b^ b| -0 -i
|
||
|
! ~ a2 si cs rd sr e^ lg sq in %x %o ab le ss ve ix ri sf FL od ch cy
|
||
|
uf lf uc lc qm @ [f [ @[ eh vl ky dl ex % ${ @{ uk pk st jn ) )[ a@
|
||
|
a% sl +] -] [- [+ so rv GS GW MS MW .. f. .f && || ^^ ?: &= |= -> s{ s}
|
||
|
v} ca wa di rs ;; ; ;d }{ { } {} f{ it {l l} rt }l }n }r dm }g }e ^o
|
||
|
^c ^| ^# um bm t~ u~ ~d DB db ^s se ^g ^r {w }w pf pr ^O ^K ^R ^W ^d ^v
|
||
|
^e ^t ^k t. fc ic fl .s .p .b .c .l .a .h g1 s1 g2 s2 ?. l? -R -W -X -r
|
||
|
-w -x -e -o -O -z -s -M -A -C -S -c -b -f -d -p -l -u -g -k -t -T -B cd
|
||
|
co cr u. cm ut r. l@ s@ r@ mD uD oD rD tD sD wD cD f$ w$ p$ sh e$ k$ g3
|
||
|
g4 s4 g5 s5 T@ C@ L@ G@ A@ S@ Hg Hc Hr Hw Mg Mc Ms Mr Sg Sc So rq do {e
|
||
|
e} {t t} g6 G6 6e g7 G7 7e g8 G8 8e g9 G9 9e 6s 7s 8s 9s 6E 7E 8E 9E Pn
|
||
|
Pu GP SP EP Gn Gg GG SG EG g0 c$ lk t$ ;s n> // /= CO';
|
||
|
|
||
|
my $chars = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ";
|
||
|
|
||
|
sub op_flags { # common flags (see BASOP.op_flags in op.h)
|
||
|
my($x) = @_;
|
||
|
my(@v);
|
||
|
push @v, "v" if ($x & 3) == 1;
|
||
|
push @v, "s" if ($x & 3) == 2;
|
||
|
push @v, "l" if ($x & 3) == 3;
|
||
|
push @v, "K" if $x & 4;
|
||
|
push @v, "P" if $x & 8;
|
||
|
push @v, "R" if $x & 16;
|
||
|
push @v, "M" if $x & 32;
|
||
|
push @v, "S" if $x & 64;
|
||
|
push @v, "*" if $x & 128;
|
||
|
return join("", @v);
|
||
|
}
|
||
|
|
||
|
sub base_n {
|
||
|
my $x = shift;
|
||
|
return "-" . base_n(-$x) if $x < 0;
|
||
|
my $str = "";
|
||
|
do { $str .= substr($chars, $x % $base, 1) } while $x = int($x / $base);
|
||
|
$str = reverse $str if $big_endian;
|
||
|
return $str;
|
||
|
}
|
||
|
|
||
|
my %sequence_num;
|
||
|
my $seq_max = 1;
|
||
|
|
||
|
sub reset_sequence {
|
||
|
# reset the sequence
|
||
|
%sequence_num = ();
|
||
|
$seq_max = 1;
|
||
|
$lastnext = 0;
|
||
|
}
|
||
|
|
||
|
sub seq {
|
||
|
my($op) = @_;
|
||
|
return "-" if not exists $sequence_num{$$op};
|
||
|
return base_n($sequence_num{$$op});
|
||
|
}
|
||
|
|
||
|
sub walk_topdown {
|
||
|
my($op, $sub, $level) = @_;
|
||
|
$sub->($op, $level);
|
||
|
if ($op->flags & OPf_KIDS) {
|
||
|
for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
|
||
|
walk_topdown($kid, $sub, $level + 1);
|
||
|
}
|
||
|
}
|
||
|
if (class($op) eq "PMOP") {
|
||
|
my $maybe_root = $op->code_list;
|
||
|
if ( ref($maybe_root) and $maybe_root->isa("B::OP")
|
||
|
and not $op->flags & OPf_KIDS) {
|
||
|
walk_topdown($maybe_root, $sub, $level + 1);
|
||
|
}
|
||
|
$maybe_root = $op->pmreplroot;
|
||
|
if (ref($maybe_root) and $maybe_root->isa("B::OP")) {
|
||
|
# It really is the root of the replacement, not something
|
||
|
# else stored here for lack of space elsewhere
|
||
|
walk_topdown($maybe_root, $sub, $level + 1);
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
|
||
|
sub walklines {
|
||
|
my($ar, $level) = @_;
|
||
|
for my $l (@$ar) {
|
||
|
if (ref($l) eq "ARRAY") {
|
||
|
walklines($l, $level + 1);
|
||
|
} else {
|
||
|
$l->concise($level);
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
|
||
|
sub walk_exec {
|
||
|
my($top, $level) = @_;
|
||
|
my %opsseen;
|
||
|
my @lines;
|
||
|
my @todo = ([$top, \@lines]);
|
||
|
while (@todo and my($op, $targ) = @{shift @todo}) {
|
||
|
for (; $$op; $op = $op->next) {
|
||
|
last if $opsseen{$$op}++;
|
||
|
push @$targ, $op;
|
||
|
my $name = $op->name;
|
||
|
if (class($op) eq "LOGOP") {
|
||
|
my $ar = [];
|
||
|
push @$targ, $ar;
|
||
|
push @todo, [$op->other, $ar];
|
||
|
} elsif ($name eq "subst" and $ {$op->pmreplstart}) {
|
||
|
my $ar = [];
|
||
|
push @$targ, $ar;
|
||
|
push @todo, [$op->pmreplstart, $ar];
|
||
|
} elsif ($name =~ /^enter(loop|iter)$/) {
|
||
|
$labels{${$op->nextop}} = "NEXT";
|
||
|
$labels{${$op->lastop}} = "LAST";
|
||
|
$labels{${$op->redoop}} = "REDO";
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
walklines(\@lines, 0);
|
||
|
}
|
||
|
|
||
|
# The structure of this routine is purposely modeled after op.c's peep()
|
||
|
sub sequence {
|
||
|
my($op) = @_;
|
||
|
my $oldop = 0;
|
||
|
return if class($op) eq "NULL" or exists $sequence_num{$$op};
|
||
|
for (; $$op; $op = $op->next) {
|
||
|
last if exists $sequence_num{$$op};
|
||
|
my $name = $op->name;
|
||
|
$sequence_num{$$op} = $seq_max++;
|
||
|
if (class($op) eq "LOGOP") {
|
||
|
sequence($op->other);
|
||
|
} elsif (class($op) eq "LOOP") {
|
||
|
sequence($op->redoop);
|
||
|
sequence( $op->nextop);
|
||
|
sequence($op->lastop);
|
||
|
} elsif ($name eq "subst" and $ {$op->pmreplstart}) {
|
||
|
sequence($op->pmreplstart);
|
||
|
}
|
||
|
$oldop = $op;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
sub fmt_line { # generate text-line for op.
|
||
|
my($hr, $op, $text, $level) = @_;
|
||
|
|
||
|
$_->($hr, $op, \$text, \$level, $stylename) for @callbacks;
|
||
|
|
||
|
return '' if $hr->{SKIP}; # suppress line if a callback said so
|
||
|
return '' if $hr->{goto} and $hr->{goto} eq '-'; # no goto nowhere
|
||
|
|
||
|
# spec: (?(text1#varText2)?)
|
||
|
$text =~ s/\(\?\(([^\#]*?)\#(\w+)([^\#]*?)\)\?\)/
|
||
|
$hr->{$2} ? $1.$hr->{$2}.$3 : ""/eg;
|
||
|
|
||
|
# spec: (x(exec_text;basic_text)x)
|
||
|
$text =~ s/\(x\((.*?);(.*?)\)x\)/$order eq "exec" ? $1 : $2/egs;
|
||
|
|
||
|
# spec: (*(text)*)
|
||
|
$text =~ s/\(\*\(([^;]*?)\)\*\)/$1 x $level/egs;
|
||
|
|
||
|
# spec: (*(text1;text2)*)
|
||
|
$text =~ s/\(\*\((.*?);(.*?)\)\*\)/$1 x ($level - 1) . $2 x ($level>0)/egs;
|
||
|
|
||
|
# convert #Var to tag=>val form: Var\t#var
|
||
|
$text =~ s/\#([A-Z][a-z]+)(\d+)?/\t\u$1\t\L#$1$2/gs;
|
||
|
|
||
|
# spec: #varN
|
||
|
$text =~ s/\#([a-zA-Z]+)(\d+)/sprintf("%-$2s", $hr->{$1})/eg;
|
||
|
|
||
|
$text =~ s/\#([a-zA-Z]+)/$hr->{$1}/eg; # populate #var's
|
||
|
$text =~ s/[ \t]*~+[ \t]*/ /g; # squeeze tildes
|
||
|
|
||
|
$text = "# $hr->{src}\n$text" if $show_src and $hr->{src};
|
||
|
|
||
|
chomp $text;
|
||
|
return "$text\n" if $text ne "" and $order ne "tree";
|
||
|
return $text; # suppress empty lines
|
||
|
}
|
||
|
|
||
|
|
||
|
|
||
|
# use require rather than use here to avoid disturbing tests that dump
|
||
|
# BEGIN blocks
|
||
|
require B::Op_private;
|
||
|
|
||
|
|
||
|
|
||
|
our %hints; # used to display each COP's op_hints values
|
||
|
|
||
|
# strict refs, subs, vars
|
||
|
@hints{0x2,0x200,0x400,0x20,0x40,0x80} = ('$', '&', '*', 'x$', 'x&', 'x*');
|
||
|
# integers, locale, bytes
|
||
|
@hints{0x1,0x4,0x8,0x10} = ('i', 'l', 'b');
|
||
|
# block scope, localise %^H, $^OPEN (in), $^OPEN (out)
|
||
|
@hints{0x100,0x20000,0x40000,0x80000} = ('{','%','<','>');
|
||
|
# overload new integer, float, binary, string, re
|
||
|
@hints{0x1000,0x2000,0x4000,0x8000,0x10000} = ('I', 'F', 'B', 'S', 'R');
|
||
|
# taint and eval
|
||
|
@hints{0x100000,0x200000} = ('T', 'E');
|
||
|
# filetest access, use utf8, unicode_strings feature
|
||
|
@hints{0x400000,0x800000,0x800} = ('X', 'U', 'us');
|
||
|
|
||
|
# pick up the feature hints constants.
|
||
|
# Note that we're relying on non-API parts of feature.pm,
|
||
|
# but its less naughty than just blindly copying those constants into
|
||
|
# this src file.
|
||
|
#
|
||
|
require feature;
|
||
|
|
||
|
sub hints_flags {
|
||
|
my($x) = @_;
|
||
|
my @s;
|
||
|
for my $flag (sort {$b <=> $a} keys %hints) {
|
||
|
if ($hints{$flag} and $x & $flag and $x >= $flag) {
|
||
|
$x -= $flag;
|
||
|
push @s, $hints{$flag};
|
||
|
}
|
||
|
}
|
||
|
if ($x & $feature::hint_mask) {
|
||
|
push @s, "fea=" . (($x & $feature::hint_mask) >> $feature::hint_shift);
|
||
|
$x &= ~$feature::hint_mask;
|
||
|
}
|
||
|
push @s, sprintf "0x%x", $x if $x;
|
||
|
return join(",", @s);
|
||
|
}
|
||
|
|
||
|
|
||
|
# return a string like 'LVINTRO,1' for the op $name with op_private
|
||
|
# value $x
|
||
|
|
||
|
sub private_flags {
|
||
|
my($name, $x) = @_;
|
||
|
my $entry = $B::Op_private::bits{$name};
|
||
|
return $x ? "$x" : '' unless $entry;
|
||
|
|
||
|
my @flags;
|
||
|
my $bit;
|
||
|
for ($bit = 7; $bit >= 0; $bit--) {
|
||
|
next unless exists $entry->{$bit};
|
||
|
my $e = $entry->{$bit};
|
||
|
if (ref($e) eq 'HASH') {
|
||
|
# bit field
|
||
|
|
||
|
my ($bitmin, $bitmax, $bitmask, $enum, $label) =
|
||
|
@{$e}{qw(bitmin bitmax bitmask enum label)};
|
||
|
$bit = $bitmin;
|
||
|
next if defined $label && $label eq '-'; # display as raw number
|
||
|
|
||
|
my $val = $x & $bitmask;
|
||
|
$x &= ~$bitmask;
|
||
|
$val >>= $bitmin;
|
||
|
|
||
|
if (defined $enum) {
|
||
|
# try to convert numeric $val into symbolic
|
||
|
my @enum = @$enum;
|
||
|
while (@enum) {
|
||
|
my $ix = shift @enum;
|
||
|
my $name = shift @enum;
|
||
|
my $label = shift @enum;
|
||
|
if ($val == $ix) {
|
||
|
$val = $label;
|
||
|
last;
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
next if $val eq '0'; # don't display anonymous zero values
|
||
|
push @flags, defined $label ? "$label=$val" : $val;
|
||
|
|
||
|
}
|
||
|
else {
|
||
|
# flag bit
|
||
|
my $label = $B::Op_private::labels{$e};
|
||
|
next if defined $label && $label eq '-'; # display as raw number
|
||
|
if ($x & (1<<$bit)) {
|
||
|
$x -= (1<<$bit);
|
||
|
push @flags, $label;
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
|
||
|
push @flags, $x if $x; # display unknown bits numerically
|
||
|
return join ",", @flags;
|
||
|
}
|
||
|
|
||
|
sub concise_sv {
|
||
|
my($sv, $hr, $preferpv) = @_;
|
||
|
$hr->{svclass} = class($sv);
|
||
|
$hr->{svclass} = "UV"
|
||
|
if $hr->{svclass} eq "IV" and $sv->FLAGS & SVf_IVisUV;
|
||
|
Carp::cluck("bad concise_sv: $sv") unless $sv and $$sv;
|
||
|
$hr->{svaddr} = sprintf("%#x", $$sv);
|
||
|
if ($hr->{svclass} eq "GV" && $sv->isGV_with_GP()) {
|
||
|
my $gv = $sv;
|
||
|
my $stash = $gv->STASH;
|
||
|
if (class($stash) eq "SPECIAL") {
|
||
|
$stash = "<none>";
|
||
|
}
|
||
|
else {
|
||
|
$stash = $stash->NAME;
|
||
|
}
|
||
|
if ($stash eq "main") {
|
||
|
$stash = "";
|
||
|
} else {
|
||
|
$stash = $stash . "::";
|
||
|
}
|
||
|
$hr->{svval} = "*$stash" . $gv->SAFENAME;
|
||
|
return "*$stash" . $gv->SAFENAME;
|
||
|
} else {
|
||
|
while (class($sv) eq "IV" && $sv->FLAGS & SVf_ROK) {
|
||
|
$hr->{svval} .= "\\";
|
||
|
$sv = $sv->RV;
|
||
|
}
|
||
|
if (class($sv) eq "SPECIAL") {
|
||
|
$hr->{svval} .= ["Null", "sv_undef", "sv_yes", "sv_no",
|
||
|
'', '', '', "sv_zero"]->[$$sv];
|
||
|
} elsif ($preferpv
|
||
|
&& ($sv->FLAGS & SVf_POK)) {
|
||
|
$hr->{svval} .= cstring($sv->PV);
|
||
|
} elsif ($sv->FLAGS & SVf_NOK) {
|
||
|
$hr->{svval} .= $sv->NV;
|
||
|
} elsif ($sv->FLAGS & SVf_IOK) {
|
||
|
$hr->{svval} .= $sv->int_value;
|
||
|
} elsif ($sv->FLAGS & SVf_POK) {
|
||
|
$hr->{svval} .= cstring($sv->PV);
|
||
|
} elsif (class($sv) eq "HV") {
|
||
|
$hr->{svval} .= 'HASH';
|
||
|
} elsif (class($sv) eq "AV") {
|
||
|
$hr->{svval} .= 'ARRAY';
|
||
|
} elsif (class($sv) eq "CV") {
|
||
|
if ($sv->CvFLAGS & CVf_ANON) {
|
||
|
$hr->{svval} .= 'CODE';
|
||
|
} elsif ($sv->CvFLAGS & CVf_NAMED) {
|
||
|
$hr->{svval} .= "&";
|
||
|
unless ($sv->CvFLAGS & CVf_LEXICAL) {
|
||
|
my $stash = $sv->STASH;
|
||
|
unless (class($stash) eq "SPECIAL") {
|
||
|
$hr->{svval} .= $stash->NAME . "::";
|
||
|
}
|
||
|
}
|
||
|
$hr->{svval} .= $sv->NAME_HEK;
|
||
|
} else {
|
||
|
$hr->{svval} .= "&";
|
||
|
$sv = $sv->GV;
|
||
|
my $stash = $sv->STASH;
|
||
|
unless (class($stash) eq "SPECIAL") {
|
||
|
$hr->{svval} .= $stash->NAME . "::";
|
||
|
}
|
||
|
$hr->{svval} .= $sv->SAFENAME;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
$hr->{svval} = 'undef' unless defined $hr->{svval};
|
||
|
my $out = $hr->{svclass};
|
||
|
return $out .= " $hr->{svval}" ;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
my %srclines;
|
||
|
|
||
|
sub fill_srclines {
|
||
|
my $fullnm = shift;
|
||
|
if ($fullnm eq '-e') {
|
||
|
$srclines{$fullnm} = [ $fullnm, "-src not supported for -e" ];
|
||
|
return;
|
||
|
}
|
||
|
open (my $fh, '<', $fullnm)
|
||
|
or warn "# $fullnm: $!, (chdirs not supported by this feature yet)\n"
|
||
|
and return;
|
||
|
my @l = <$fh>;
|
||
|
chomp @l;
|
||
|
unshift @l, $fullnm; # like @{_<$fullnm} in debug, array starts at 1
|
||
|
$srclines{$fullnm} = \@l;
|
||
|
}
|
||
|
|
||
|
# Given a pad target, return the pad var's name and cop range /
|
||
|
# fakeness, or failing that, its target number.
|
||
|
# e.g.
|
||
|
# ('$i', '$i:5,7')
|
||
|
# or
|
||
|
# ('$i', '$i:fake:a')
|
||
|
# or
|
||
|
# ('t5', 't5')
|
||
|
|
||
|
sub padname {
|
||
|
my ($targ) = @_;
|
||
|
|
||
|
my ($targarg, $targarglife);
|
||
|
my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$targ];
|
||
|
if (defined $padname and class($padname) ne "SPECIAL" and
|
||
|
$padname->LEN)
|
||
|
{
|
||
|
$targarg = $padname->PVX;
|
||
|
if ($padname->FLAGS & SVf_FAKE) {
|
||
|
# These changes relate to the jumbo closure fix.
|
||
|
# See changes 19939 and 20005
|
||
|
my $fake = '';
|
||
|
$fake .= 'a'
|
||
|
if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_ANON;
|
||
|
$fake .= 'm'
|
||
|
if $padname->PARENT_FAKELEX_FLAGS & PAD_FAKELEX_MULTI;
|
||
|
$fake .= ':' . $padname->PARENT_PAD_INDEX
|
||
|
if $curcv->CvFLAGS & CVf_ANON;
|
||
|
$targarglife = "$targarg:FAKE:$fake";
|
||
|
}
|
||
|
else {
|
||
|
my $intro = $padname->COP_SEQ_RANGE_LOW - $cop_seq_base;
|
||
|
my $finish = int($padname->COP_SEQ_RANGE_HIGH) - $cop_seq_base;
|
||
|
$finish = "end" if $finish == 999999999 - $cop_seq_base;
|
||
|
$targarglife = "$targarg:$intro,$finish";
|
||
|
}
|
||
|
} else {
|
||
|
$targarglife = $targarg = "t" . $targ;
|
||
|
}
|
||
|
return $targarg, $targarglife;
|
||
|
}
|
||
|
|
||
|
|
||
|
|
||
|
sub concise_op {
|
||
|
my ($op, $level, $format) = @_;
|
||
|
my %h;
|
||
|
$h{exname} = $h{name} = $op->name;
|
||
|
$h{NAME} = uc $h{name};
|
||
|
$h{class} = class($op);
|
||
|
$h{extarg} = $h{targ} = $op->targ;
|
||
|
$h{extarg} = "" unless $h{extarg};
|
||
|
$h{privval} = $op->private;
|
||
|
# for null ops, targ holds the old type
|
||
|
my $origname = $h{name} eq "null" && $h{targ}
|
||
|
? substr(ppname($h{targ}), 3)
|
||
|
: $h{name};
|
||
|
$h{private} = private_flags($origname, $op->private);
|
||
|
if ($op->folded) {
|
||
|
$h{private} &&= "$h{private},";
|
||
|
$h{private} .= "FOLD";
|
||
|
}
|
||
|
|
||
|
if ($h{name} ne $origname) { # a null op
|
||
|
$h{exname} = "ex-$origname";
|
||
|
$h{extarg} = "";
|
||
|
} elsif ($h{private} =~ /\bREFC\b/) {
|
||
|
# targ holds a reference count
|
||
|
my $refs = "ref" . ($h{targ} != 1 ? "s" : "");
|
||
|
$h{targarglife} = $h{targarg} = "$h{targ} $refs";
|
||
|
} elsif ($h{targ}) {
|
||
|
my $count = $h{name} eq 'padrange'
|
||
|
? ($op->private & $B::Op_private::defines{'OPpPADRANGE_COUNTMASK'})
|
||
|
: 1;
|
||
|
my (@targarg, @targarglife);
|
||
|
for my $i (0..$count-1) {
|
||
|
my ($targarg, $targarglife) = padname($h{targ} + $i);
|
||
|
push @targarg, $targarg;
|
||
|
push @targarglife, $targarglife;
|
||
|
}
|
||
|
$h{targarg} = join '; ', @targarg;
|
||
|
$h{targarglife} = join '; ', @targarglife;
|
||
|
}
|
||
|
|
||
|
$h{arg} = "";
|
||
|
$h{svclass} = $h{svaddr} = $h{svval} = "";
|
||
|
if ($h{class} eq "PMOP") {
|
||
|
my $extra = '';
|
||
|
my $precomp = $op->precomp;
|
||
|
if (defined $precomp) {
|
||
|
$precomp = cstring($precomp); # Escape literal control sequences
|
||
|
$precomp = "/$precomp/";
|
||
|
} else {
|
||
|
$precomp = "";
|
||
|
}
|
||
|
if ($op->name eq 'subst') {
|
||
|
if (class($op->pmreplstart) ne "NULL") {
|
||
|
undef $lastnext;
|
||
|
$extra = " replstart->" . seq($op->pmreplstart);
|
||
|
}
|
||
|
}
|
||
|
elsif ($op->name eq 'split') {
|
||
|
if ( ($op->private & OPpSPLIT_ASSIGN) # @array = split
|
||
|
&& (not $op->flags & OPf_STACKED)) # @{expr} = split
|
||
|
{
|
||
|
# with C<@array = split(/pat/, str);>,
|
||
|
# array is stored in /pat/'s pmreplroot; either
|
||
|
# as an integer index into the pad (for a lexical array)
|
||
|
# or as GV for a package array (which will be a pad index
|
||
|
# on threaded builds)
|
||
|
|
||
|
if ($op->private & $B::Op_private::defines{'OPpSPLIT_LEX'}) {
|
||
|
my $off = $op->pmreplroot; # union with op_pmtargetoff
|
||
|
my ($name, $full) = padname($off);
|
||
|
$extra = " => $full";
|
||
|
}
|
||
|
else {
|
||
|
# union with op_pmtargetoff, op_pmtargetgv
|
||
|
my $gv = $op->pmreplroot;
|
||
|
if (!ref($gv)) {
|
||
|
# the value is actually a pad offset
|
||
|
$gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$gv]->NAME;
|
||
|
}
|
||
|
else {
|
||
|
# unthreaded: its a GV
|
||
|
$gv = $gv->NAME;
|
||
|
}
|
||
|
$extra = " => \@$gv";
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
$h{arg} = "($precomp$extra)";
|
||
|
} elsif ($h{class} eq "PVOP" and $h{name} !~ '^transr?\z') {
|
||
|
$h{arg} = '("' . $op->pv . '")';
|
||
|
$h{svval} = '"' . $op->pv . '"';
|
||
|
} elsif ($h{class} eq "COP") {
|
||
|
my $label = $op->label;
|
||
|
$h{coplabel} = $label;
|
||
|
$label = $label ? "$label: " : "";
|
||
|
my $loc = $op->file;
|
||
|
my $pathnm = $loc;
|
||
|
$loc =~ s[.*/][];
|
||
|
my $ln = $op->line;
|
||
|
$loc .= ":$ln";
|
||
|
my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
|
||
|
$h{arg} = "($label$stash $cseq $loc)";
|
||
|
if ($show_src) {
|
||
|
fill_srclines($pathnm) unless exists $srclines{$pathnm};
|
||
|
my $line = $srclines{$pathnm}[$ln] // "-src unavailable under -e";
|
||
|
$h{src} = "$ln: $line";
|
||
|
}
|
||
|
} elsif ($h{class} eq "LOOP") {
|
||
|
$h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
|
||
|
. " redo->" . seq($op->redoop) . ")";
|
||
|
} elsif ($h{class} eq "LOGOP") {
|
||
|
undef $lastnext;
|
||
|
$h{arg} = "(other->" . seq($op->other) . ")";
|
||
|
$h{otheraddr} = sprintf("%#x", $ {$op->other});
|
||
|
if ($h{name} eq "argdefelem") {
|
||
|
# targ used for element index
|
||
|
$h{targarglife} = $h{targarg} = "";
|
||
|
$h{arg} .= "[" . $op->targ . "]";
|
||
|
}
|
||
|
}
|
||
|
elsif ($h{class} eq "SVOP" or $h{class} eq "PADOP") {
|
||
|
unless ($h{name} eq 'aelemfast' and $op->flags & OPf_SPECIAL) {
|
||
|
my $idx = ($h{class} eq "SVOP") ? $op->targ : $op->padix;
|
||
|
if ($h{class} eq "PADOP" or !${$op->sv}) {
|
||
|
my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$idx];
|
||
|
$h{arg} = "[" . concise_sv($sv, \%h, 0) . "]";
|
||
|
$h{targarglife} = $h{targarg} = "";
|
||
|
} else {
|
||
|
$h{arg} = "(" . concise_sv($op->sv, \%h, 0) . ")";
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
elsif ($h{class} eq "METHOP") {
|
||
|
my $prefix = '';
|
||
|
if ($h{name} eq 'method_redir' or $h{name} eq 'method_redir_super') {
|
||
|
my $rclass_sv = $op->rclass;
|
||
|
$rclass_sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$rclass_sv]
|
||
|
unless ref $rclass_sv;
|
||
|
$prefix .= 'PACKAGE "'.$rclass_sv->PV.'", ';
|
||
|
}
|
||
|
if ($h{name} ne "method") {
|
||
|
if (${$op->meth_sv}) {
|
||
|
$h{arg} = "($prefix" . concise_sv($op->meth_sv, \%h, 1) . ")";
|
||
|
} else {
|
||
|
my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->targ];
|
||
|
$h{arg} = "[$prefix" . concise_sv($sv, \%h, 1) . "]";
|
||
|
$h{targarglife} = $h{targarg} = "";
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
elsif ($h{class} eq "UNOP_AUX") {
|
||
|
$h{arg} = "(" . $op->string($curcv) . ")";
|
||
|
}
|
||
|
|
||
|
$h{seq} = $h{hyphseq} = seq($op);
|
||
|
$h{seq} = "" if $h{seq} eq "-";
|
||
|
$h{opt} = $op->opt;
|
||
|
$h{label} = $labels{$$op};
|
||
|
$h{next} = $op->next;
|
||
|
$h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
|
||
|
$h{nextaddr} = sprintf("%#x", $ {$op->next});
|
||
|
$h{sibaddr} = sprintf("%#x", $ {$op->sibling});
|
||
|
$h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
|
||
|
$h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");
|
||
|
|
||
|
$h{classsym} = $opclass{$h{class}};
|
||
|
$h{flagval} = $op->flags;
|
||
|
$h{flags} = op_flags($op->flags);
|
||
|
if ($op->can("hints")) {
|
||
|
$h{hintsval} = $op->hints;
|
||
|
$h{hints} = hints_flags($h{hintsval});
|
||
|
} else {
|
||
|
$h{hintsval} = $h{hints} = '';
|
||
|
}
|
||
|
$h{addr} = sprintf("%#x", $$op);
|
||
|
$h{typenum} = $op->type;
|
||
|
$h{noise} = $linenoise[$op->type];
|
||
|
|
||
|
return fmt_line(\%h, $op, $format, $level);
|
||
|
}
|
||
|
|
||
|
sub B::OP::concise {
|
||
|
my($op, $level) = @_;
|
||
|
if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
|
||
|
# insert a 'goto' line
|
||
|
my $synth = {"seq" => seq($lastnext), "class" => class($lastnext),
|
||
|
"addr" => sprintf("%#x", $$lastnext),
|
||
|
"goto" => seq($lastnext), # simplify goto '-' removal
|
||
|
};
|
||
|
print $walkHandle fmt_line($synth, $op, $gotofmt, $level+1);
|
||
|
}
|
||
|
$lastnext = $op->next;
|
||
|
print $walkHandle concise_op($op, $level, $format);
|
||
|
}
|
||
|
|
||
|
# B::OP::terse (see Terse.pm) now just calls this
|
||
|
sub b_terse {
|
||
|
my($op, $level) = @_;
|
||
|
|
||
|
# This isn't necessarily right, but there's no easy way to get
|
||
|
# from an OP to the right CV. This is a limitation of the
|
||
|
# ->terse() interface style, and there isn't much to do about
|
||
|
# it. In particular, we can die in concise_op if the main pad
|
||
|
# isn't long enough, or has the wrong kind of entries, compared to
|
||
|
# the pad a sub was compiled with. The fix for that would be to
|
||
|
# make a backwards compatible "terse" format that never even
|
||
|
# looked at the pad, just like the old B::Terse. I don't think
|
||
|
# that's worth the effort, though.
|
||
|
$curcv = main_cv unless $curcv;
|
||
|
|
||
|
if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
|
||
|
# insert a 'goto'
|
||
|
my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
|
||
|
"addr" => sprintf("%#x", $$lastnext)};
|
||
|
print # $walkHandle
|
||
|
fmt_line($h, $op, $style{"terse"}[1], $level+1);
|
||
|
}
|
||
|
$lastnext = $op->next;
|
||
|
print # $walkHandle
|
||
|
concise_op($op, $level, $style{"terse"}[0]);
|
||
|
}
|
||
|
|
||
|
sub tree {
|
||
|
my $op = shift;
|
||
|
my $level = shift;
|
||
|
my $style = $tree_decorations[$tree_style];
|
||
|
my($space, $single, $kids, $kid, $nokid, $last, $lead, $size) = @$style;
|
||
|
my $name = concise_op($op, $level, $treefmt);
|
||
|
if (not $op->flags & OPf_KIDS) {
|
||
|
return $name . "\n";
|
||
|
}
|
||
|
my @lines;
|
||
|
for (my $kid = $op->first; $$kid; $kid = $kid->sibling) {
|
||
|
push @lines, tree($kid, $level+1);
|
||
|
}
|
||
|
my $i;
|
||
|
for ($i = $#lines; substr($lines[$i], 0, 1) eq " "; $i--) {
|
||
|
$lines[$i] = $space . $lines[$i];
|
||
|
}
|
||
|
if ($i > 0) {
|
||
|
$lines[$i] = $last . $lines[$i];
|
||
|
while ($i-- > 1) {
|
||
|
if (substr($lines[$i], 0, 1) eq " ") {
|
||
|
$lines[$i] = $nokid . $lines[$i];
|
||
|
} else {
|
||
|
$lines[$i] = $kid . $lines[$i];
|
||
|
}
|
||
|
}
|
||
|
$lines[$i] = $kids . $lines[$i];
|
||
|
} else {
|
||
|
$lines[0] = $single . $lines[0];
|
||
|
}
|
||
|
return("$name$lead" . shift @lines,
|
||
|
map(" " x (length($name)+$size) . $_, @lines));
|
||
|
}
|
||
|
|
||
|
# *** Warning: fragile kludge ahead ***
|
||
|
# Because the B::* modules run in the same interpreter as the code
|
||
|
# they're compiling, their presence tends to distort the view we have of
|
||
|
# the code we're looking at. In particular, perl gives sequence numbers
|
||
|
# to COPs. If the program we're looking at were run on its own, this
|
||
|
# would start at 1. Because all of B::Concise and all the modules it
|
||
|
# uses are compiled first, though, by the time we get to the user's
|
||
|
# program the sequence number is already pretty high, which could be
|
||
|
# distracting if you're trying to tell OPs apart. Therefore we'd like to
|
||
|
# subtract an offset from all the sequence numbers we display, to
|
||
|
# restore the simpler view of the world. The trick is to know what that
|
||
|
# offset will be, when we're still compiling B::Concise! If we
|
||
|
# hardcoded a value, it would have to change every time B::Concise or
|
||
|
# other modules we use do. To help a little, what we do here is compile
|
||
|
# a little code at the end of the module, and compute the base sequence
|
||
|
# number for the user's program as being a small offset later, so all we
|
||
|
# have to worry about are changes in the offset.
|
||
|
|
||
|
# When you say "perl -MO=Concise -e '$a'", the output should look like:
|
||
|
|
||
|
# 4 <@> leave[t1] vKP/REFC ->(end)
|
||
|
# 1 <0> enter ->2
|
||
|
#^ smallest OP sequence number should be 1
|
||
|
# 2 <;> nextstate(main 1 -e:1) v ->3
|
||
|
# ^ smallest COP sequence number should be 1
|
||
|
# - <1> ex-rv2sv vK/1 ->4
|
||
|
# 3 <$> gvsv(*a) s ->4
|
||
|
|
||
|
# If the second of the marked numbers there isn't 1, it means you need
|
||
|
# to update the corresponding magic number in the next line.
|
||
|
# Remember, this needs to stay the last things in the module.
|
||
|
|
||
|
my $cop_seq_mnum = 12;
|
||
|
$cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
|
||
|
|
||
|
1;
|
||
|
|
||
|
__END__
|
||
|
|
||
|
=head1 NAME
|
||
|
|
||
|
B::Concise - Walk Perl syntax tree, printing concise info about ops
|
||
|
|
||
|
=head1 SYNOPSIS
|
||
|
|
||
|
perl -MO=Concise[,OPTIONS] foo.pl
|
||
|
|
||
|
use B::Concise qw(set_style add_callback);
|
||
|
|
||
|
=head1 DESCRIPTION
|
||
|
|
||
|
This compiler backend prints the internal OPs of a Perl program's syntax
|
||
|
tree in one of several space-efficient text formats suitable for debugging
|
||
|
the inner workings of perl or other compiler backends. It can print OPs in
|
||
|
the order they appear in the OP tree, in the order they will execute, or
|
||
|
in a text approximation to their tree structure, and the format of the
|
||
|
information displayed is customizable. Its function is similar to that of
|
||
|
perl's B<-Dx> debugging flag or the B<B::Terse> module, but it is more
|
||
|
sophisticated and flexible.
|
||
|
|
||
|
=head1 EXAMPLE
|
||
|
|
||
|
Here's two outputs (or 'renderings'), using the -exec and -basic
|
||
|
(i.e. default) formatting conventions on the same code snippet.
|
||
|
|
||
|
% perl -MO=Concise,-exec -e '$a = $b + 42'
|
||
|
1 <0> enter
|
||
|
2 <;> nextstate(main 1 -e:1) v
|
||
|
3 <#> gvsv[*b] s
|
||
|
4 <$> const[IV 42] s
|
||
|
* 5 <2> add[t3] sK/2
|
||
|
6 <#> gvsv[*a] s
|
||
|
7 <2> sassign vKS/2
|
||
|
8 <@> leave[1 ref] vKP/REFC
|
||
|
|
||
|
In this -exec rendering, each opcode is executed in the order shown.
|
||
|
The add opcode, marked with '*', is discussed in more detail.
|
||
|
|
||
|
The 1st column is the op's sequence number, starting at 1, and is
|
||
|
displayed in base 36 by default. Here they're purely linear; the
|
||
|
sequences are very helpful when looking at code with loops and
|
||
|
branches.
|
||
|
|
||
|
The symbol between angle brackets indicates the op's type, for
|
||
|
example; <2> is a BINOP, <@> a LISTOP, and <#> is a PADOP, which is
|
||
|
used in threaded perls. (see L</"OP class abbreviations">).
|
||
|
|
||
|
The opname, as in B<'add[t1]'>, may be followed by op-specific
|
||
|
information in parentheses or brackets (ex B<'[t1]'>).
|
||
|
|
||
|
The op-flags (ex B<'sK/2'>) are described in (L</"OP flags
|
||
|
abbreviations">).
|
||
|
|
||
|
% perl -MO=Concise -e '$a = $b + 42'
|
||
|
8 <@> leave[1 ref] vKP/REFC ->(end)
|
||
|
1 <0> enter ->2
|
||
|
2 <;> nextstate(main 1 -e:1) v ->3
|
||
|
7 <2> sassign vKS/2 ->8
|
||
|
* 5 <2> add[t1] sK/2 ->6
|
||
|
- <1> ex-rv2sv sK/1 ->4
|
||
|
3 <$> gvsv(*b) s ->4
|
||
|
4 <$> const(IV 42) s ->5
|
||
|
- <1> ex-rv2sv sKRM*/1 ->7
|
||
|
6 <$> gvsv(*a) s ->7
|
||
|
|
||
|
The default rendering is top-down, so they're not in execution order.
|
||
|
This form reflects the way the stack is used to parse and evaluate
|
||
|
expressions; the add operates on the two terms below it in the tree.
|
||
|
|
||
|
Nullops appear as C<ex-opname>, where I<opname> is an op that has been
|
||
|
optimized away by perl. They're displayed with a sequence-number of
|
||
|
'-', because they are not executed (they don't appear in previous
|
||
|
example), they're printed here because they reflect the parse.
|
||
|
|
||
|
The arrow points to the sequence number of the next op; they're not
|
||
|
displayed in -exec mode, for obvious reasons.
|
||
|
|
||
|
Note that because this rendering was done on a non-threaded perl, the
|
||
|
PADOPs in the previous examples are now SVOPs, and some (but not all)
|
||
|
of the square brackets have been replaced by round ones. This is a
|
||
|
subtle feature to provide some visual distinction between renderings
|
||
|
on threaded and un-threaded perls.
|
||
|
|
||
|
|
||
|
=head1 OPTIONS
|
||
|
|
||
|
Arguments that don't start with a hyphen are taken to be the names of
|
||
|
subroutines or formats to render; if no
|
||
|
such functions are specified, the main
|
||
|
body of the program (outside any subroutines, and not including use'd
|
||
|
or require'd files) is rendered. Passing C<BEGIN>, C<UNITCHECK>,
|
||
|
C<CHECK>, C<INIT>, or C<END> will cause all of the corresponding
|
||
|
special blocks to be printed. Arguments must follow options.
|
||
|
|
||
|
Options affect how things are rendered (ie printed). They're presented
|
||
|
here by their visual effect, 1st being strongest. They're grouped
|
||
|
according to how they interrelate; within each group the options are
|
||
|
mutually exclusive (unless otherwise stated).
|
||
|
|
||
|
=head2 Options for Opcode Ordering
|
||
|
|
||
|
These options control the 'vertical display' of opcodes. The display
|
||
|
'order' is also called 'mode' elsewhere in this document.
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item B<-basic>
|
||
|
|
||
|
Print OPs in the order they appear in the OP tree (a preorder
|
||
|
traversal, starting at the root). The indentation of each OP shows its
|
||
|
level in the tree, and the '->' at the end of the line indicates the
|
||
|
next opcode in execution order. This mode is the default, so the flag
|
||
|
is included simply for completeness.
|
||
|
|
||
|
=item B<-exec>
|
||
|
|
||
|
Print OPs in the order they would normally execute (for the majority
|
||
|
of constructs this is a postorder traversal of the tree, ending at the
|
||
|
root). In most cases the OP that usually follows a given OP will
|
||
|
appear directly below it; alternate paths are shown by indentation. In
|
||
|
cases like loops when control jumps out of a linear path, a 'goto'
|
||
|
line is generated.
|
||
|
|
||
|
=item B<-tree>
|
||
|
|
||
|
Print OPs in a text approximation of a tree, with the root of the tree
|
||
|
at the left and 'left-to-right' order of children transformed into
|
||
|
'top-to-bottom'. Because this mode grows both to the right and down,
|
||
|
it isn't suitable for large programs (unless you have a very wide
|
||
|
terminal).
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head2 Options for Line-Style
|
||
|
|
||
|
These options select the line-style (or just style) used to render
|
||
|
each opcode, and dictates what info is actually printed into each line.
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item B<-concise>
|
||
|
|
||
|
Use the author's favorite set of formatting conventions. This is the
|
||
|
default, of course.
|
||
|
|
||
|
=item B<-terse>
|
||
|
|
||
|
Use formatting conventions that emulate the output of B<B::Terse>. The
|
||
|
basic mode is almost indistinguishable from the real B<B::Terse>, and the
|
||
|
exec mode looks very similar, but is in a more logical order and lacks
|
||
|
curly brackets. B<B::Terse> doesn't have a tree mode, so the tree mode
|
||
|
is only vaguely reminiscent of B<B::Terse>.
|
||
|
|
||
|
=item B<-linenoise>
|
||
|
|
||
|
Use formatting conventions in which the name of each OP, rather than being
|
||
|
written out in full, is represented by a one- or two-character abbreviation.
|
||
|
This is mainly a joke.
|
||
|
|
||
|
=item B<-debug>
|
||
|
|
||
|
Use formatting conventions reminiscent of CPAN module B<B::Debug>; these aren't
|
||
|
very concise at all.
|
||
|
|
||
|
=item B<-env>
|
||
|
|
||
|
Use formatting conventions read from the environment variables
|
||
|
C<B_CONCISE_FORMAT>, C<B_CONCISE_GOTO_FORMAT>, and C<B_CONCISE_TREE_FORMAT>.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head2 Options for tree-specific formatting
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item B<-compact>
|
||
|
|
||
|
Use a tree format in which the minimum amount of space is used for the
|
||
|
lines connecting nodes (one character in most cases). This squeezes out
|
||
|
a few precious columns of screen real estate.
|
||
|
|
||
|
=item B<-loose>
|
||
|
|
||
|
Use a tree format that uses longer edges to separate OP nodes. This format
|
||
|
tends to look better than the compact one, especially in ASCII, and is
|
||
|
the default.
|
||
|
|
||
|
=item B<-vt>
|
||
|
|
||
|
Use tree connecting characters drawn from the VT100 line-drawing set.
|
||
|
This looks better if your terminal supports it.
|
||
|
|
||
|
=item B<-ascii>
|
||
|
|
||
|
Draw the tree with standard ASCII characters like C<+> and C<|>. These don't
|
||
|
look as clean as the VT100 characters, but they'll work with almost any
|
||
|
terminal (or the horizontal scrolling mode of less(1)) and are suitable
|
||
|
for text documentation or email. This is the default.
|
||
|
|
||
|
=back
|
||
|
|
||
|
These are pairwise exclusive, i.e. compact or loose, vt or ascii.
|
||
|
|
||
|
=head2 Options controlling sequence numbering
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item B<-base>I<n>
|
||
|
|
||
|
Print OP sequence numbers in base I<n>. If I<n> is greater than 10, the
|
||
|
digit for 11 will be 'a', and so on. If I<n> is greater than 36, the digit
|
||
|
for 37 will be 'A', and so on until 62. Values greater than 62 are not
|
||
|
currently supported. The default is 36.
|
||
|
|
||
|
=item B<-bigendian>
|
||
|
|
||
|
Print sequence numbers with the most significant digit first. This is the
|
||
|
usual convention for Arabic numerals, and the default.
|
||
|
|
||
|
=item B<-littleendian>
|
||
|
|
||
|
Print sequence numbers with the least significant digit first. This is
|
||
|
obviously mutually exclusive with bigendian.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head2 Other options
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item B<-src>
|
||
|
|
||
|
With this option, the rendering of each statement (starting with the
|
||
|
nextstate OP) will be preceded by the 1st line of source code that
|
||
|
generates it. For example:
|
||
|
|
||
|
1 <0> enter
|
||
|
# 1: my $i;
|
||
|
2 <;> nextstate(main 1 junk.pl:1) v:{
|
||
|
3 <0> padsv[$i:1,10] vM/LVINTRO
|
||
|
# 3: for $i (0..9) {
|
||
|
4 <;> nextstate(main 3 junk.pl:3) v:{
|
||
|
5 <0> pushmark s
|
||
|
6 <$> const[IV 0] s
|
||
|
7 <$> const[IV 9] s
|
||
|
8 <{> enteriter(next->j last->m redo->9)[$i:1,10] lKS
|
||
|
k <0> iter s
|
||
|
l <|> and(other->9) vK/1
|
||
|
# 4: print "line ";
|
||
|
9 <;> nextstate(main 2 junk.pl:4) v
|
||
|
a <0> pushmark s
|
||
|
b <$> const[PV "line "] s
|
||
|
c <@> print vK
|
||
|
# 5: print "$i\n";
|
||
|
...
|
||
|
|
||
|
=item B<-stash="somepackage">
|
||
|
|
||
|
With this, "somepackage" will be required, then the stash is
|
||
|
inspected, and each function is rendered.
|
||
|
|
||
|
=back
|
||
|
|
||
|
The following options are pairwise exclusive.
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item B<-main>
|
||
|
|
||
|
Include the main program in the output, even if subroutines were also
|
||
|
specified. This rendering is normally suppressed when a subroutine
|
||
|
name or reference is given.
|
||
|
|
||
|
=item B<-nomain>
|
||
|
|
||
|
This restores the default behavior after you've changed it with '-main'
|
||
|
(it's not normally needed). If no subroutine name/ref is given, main is
|
||
|
rendered, regardless of this flag.
|
||
|
|
||
|
=item B<-nobanner>
|
||
|
|
||
|
Renderings usually include a banner line identifying the function name
|
||
|
or stringified subref. This suppresses the printing of the banner.
|
||
|
|
||
|
TBC: Remove the stringified coderef; while it provides a 'cookie' for
|
||
|
each function rendered, the cookies used should be 1,2,3.. not a
|
||
|
random hex-address. It also complicates string comparison of two
|
||
|
different trees.
|
||
|
|
||
|
=item B<-banner>
|
||
|
|
||
|
restores default banner behavior.
|
||
|
|
||
|
=item B<-banneris> => subref
|
||
|
|
||
|
TBC: a hookpoint (and an option to set it) for a user-supplied
|
||
|
function to produce a banner appropriate for users needs. It's not
|
||
|
ideal, because the rendering-state variables, which are a natural
|
||
|
candidate for use in concise.t, are unavailable to the user.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head2 Option Stickiness
|
||
|
|
||
|
If you invoke Concise more than once in a program, you should know that
|
||
|
the options are 'sticky'. This means that the options you provide in
|
||
|
the first call will be remembered for the 2nd call, unless you
|
||
|
re-specify or change them.
|
||
|
|
||
|
=head1 ABBREVIATIONS
|
||
|
|
||
|
The concise style uses symbols to convey maximum info with minimal
|
||
|
clutter (like hex addresses). With just a little practice, you can
|
||
|
start to see the flowers, not just the branches, in the trees.
|
||
|
|
||
|
=head2 OP class abbreviations
|
||
|
|
||
|
These symbols appear before the op-name, and indicate the
|
||
|
B:: namespace that represents the ops in your Perl code.
|
||
|
|
||
|
0 OP (aka BASEOP) An OP with no children
|
||
|
1 UNOP An OP with one child
|
||
|
+ UNOP_AUX A UNOP with auxillary fields
|
||
|
2 BINOP An OP with two children
|
||
|
| LOGOP A control branch OP
|
||
|
@ LISTOP An OP that could have lots of children
|
||
|
/ PMOP An OP with a regular expression
|
||
|
$ SVOP An OP with an SV
|
||
|
" PVOP An OP with a string
|
||
|
{ LOOP An OP that holds pointers for a loop
|
||
|
; COP An OP that marks the start of a statement
|
||
|
# PADOP An OP with a GV on the pad
|
||
|
. METHOP An OP with method call info
|
||
|
|
||
|
=head2 OP flags abbreviations
|
||
|
|
||
|
OP flags are either public or private. The public flags alter the
|
||
|
behavior of each opcode in consistent ways, and are represented by 0
|
||
|
or more single characters.
|
||
|
|
||
|
v OPf_WANT_VOID Want nothing (void context)
|
||
|
s OPf_WANT_SCALAR Want single value (scalar context)
|
||
|
l OPf_WANT_LIST Want list of any length (list context)
|
||
|
Want is unknown
|
||
|
K OPf_KIDS There is a firstborn child.
|
||
|
P OPf_PARENS This operator was parenthesized.
|
||
|
(Or block needs explicit scope entry.)
|
||
|
R OPf_REF Certified reference.
|
||
|
(Return container, not containee).
|
||
|
M OPf_MOD Will modify (lvalue).
|
||
|
S OPf_STACKED Some arg is arriving on the stack.
|
||
|
* OPf_SPECIAL Do something weird for this op (see op.h)
|
||
|
|
||
|
Private flags, if any are set for an opcode, are displayed after a '/'
|
||
|
|
||
|
8 <@> leave[1 ref] vKP/REFC ->(end)
|
||
|
7 <2> sassign vKS/2 ->8
|
||
|
|
||
|
They're opcode specific, and occur less often than the public ones, so
|
||
|
they're represented by short mnemonics instead of single-chars; see
|
||
|
B::Op_private and F<regen/op_private> for more details.
|
||
|
|
||
|
=head1 FORMATTING SPECIFICATIONS
|
||
|
|
||
|
For each line-style ('concise', 'terse', 'linenoise', etc.) there are
|
||
|
3 format-specs which control how OPs are rendered.
|
||
|
|
||
|
The first is the 'default' format, which is used in both basic and exec
|
||
|
modes to print all opcodes. The 2nd, goto-format, is used in exec
|
||
|
mode when branches are encountered. They're not real opcodes, and are
|
||
|
inserted to look like a closing curly brace. The tree-format is tree
|
||
|
specific.
|
||
|
|
||
|
When a line is rendered, the correct format-spec is copied and scanned
|
||
|
for the following items; data is substituted in, and other
|
||
|
manipulations like basic indenting are done, for each opcode rendered.
|
||
|
|
||
|
There are 3 kinds of items that may be populated; special patterns,
|
||
|
#vars, and literal text, which is copied verbatim. (Yes, it's a set
|
||
|
of s///g steps.)
|
||
|
|
||
|
=head2 Special Patterns
|
||
|
|
||
|
These items are the primitives used to perform indenting, and to
|
||
|
select text from amongst alternatives.
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item B<(x(>I<exec_text>B<;>I<basic_text>B<)x)>
|
||
|
|
||
|
Generates I<exec_text> in exec mode, or I<basic_text> in basic mode.
|
||
|
|
||
|
=item B<(*(>I<text>B<)*)>
|
||
|
|
||
|
Generates one copy of I<text> for each indentation level.
|
||
|
|
||
|
=item B<(*(>I<text1>B<;>I<text2>B<)*)>
|
||
|
|
||
|
Generates one fewer copies of I<text1> than the indentation level, followed
|
||
|
by one copy of I<text2> if the indentation level is more than 0.
|
||
|
|
||
|
=item B<(?(>I<text1>B<#>I<var>I<Text2>B<)?)>
|
||
|
|
||
|
If the value of I<var> is true (not empty or zero), generates the
|
||
|
value of I<var> surrounded by I<text1> and I<Text2>, otherwise
|
||
|
nothing.
|
||
|
|
||
|
=item B<~>
|
||
|
|
||
|
Any number of tildes and surrounding whitespace will be collapsed to
|
||
|
a single space.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head2 # Variables
|
||
|
|
||
|
These #vars represent opcode properties that you may want as part of
|
||
|
your rendering. The '#' is intended as a private sigil; a #var's
|
||
|
value is interpolated into the style-line, much like "read $this".
|
||
|
|
||
|
These vars take 3 forms:
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item B<#>I<var>
|
||
|
|
||
|
A property named 'var' is assumed to exist for the opcodes, and is
|
||
|
interpolated into the rendering.
|
||
|
|
||
|
=item B<#>I<var>I<N>
|
||
|
|
||
|
Generates the value of I<var>, left justified to fill I<N> spaces.
|
||
|
Note that this means while you can have properties 'foo' and 'foo2',
|
||
|
you cannot render 'foo2', but you could with 'foo2a'. You would be
|
||
|
wise not to rely on this behavior going forward ;-)
|
||
|
|
||
|
=item B<#>I<Var>
|
||
|
|
||
|
This ucfirst form of #var generates a tag-value form of itself for
|
||
|
display; it converts '#Var' into a 'Var => #var' style, which is then
|
||
|
handled as described above. (Imp-note: #Vars cannot be used for
|
||
|
conditional-fills, because the => #var transform is done after the check
|
||
|
for #Var's value).
|
||
|
|
||
|
=back
|
||
|
|
||
|
The following variables are 'defined' by B::Concise; when they are
|
||
|
used in a style, their respective values are plugged into the
|
||
|
rendering of each opcode.
|
||
|
|
||
|
Only some of these are used by the standard styles, the others are
|
||
|
provided for you to delve into optree mechanics, should you wish to
|
||
|
add a new style (see L</add_style> below) that uses them. You can
|
||
|
also add new ones using L</add_callback>.
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item B<#addr>
|
||
|
|
||
|
The address of the OP, in hexadecimal.
|
||
|
|
||
|
=item B<#arg>
|
||
|
|
||
|
The OP-specific information of the OP (such as the SV for an SVOP, the
|
||
|
non-local exit pointers for a LOOP, etc.) enclosed in parentheses.
|
||
|
|
||
|
=item B<#class>
|
||
|
|
||
|
The B-determined class of the OP, in all caps.
|
||
|
|
||
|
=item B<#classsym>
|
||
|
|
||
|
A single symbol abbreviating the class of the OP.
|
||
|
|
||
|
=item B<#coplabel>
|
||
|
|
||
|
The label of the statement or block the OP is the start of, if any.
|
||
|
|
||
|
=item B<#exname>
|
||
|
|
||
|
The name of the OP, or 'ex-foo' if the OP is a null that used to be a foo.
|
||
|
|
||
|
=item B<#extarg>
|
||
|
|
||
|
The target of the OP, or nothing for a nulled OP.
|
||
|
|
||
|
=item B<#firstaddr>
|
||
|
|
||
|
The address of the OP's first child, in hexadecimal.
|
||
|
|
||
|
=item B<#flags>
|
||
|
|
||
|
The OP's flags, abbreviated as a series of symbols.
|
||
|
|
||
|
=item B<#flagval>
|
||
|
|
||
|
The numeric value of the OP's flags.
|
||
|
|
||
|
=item B<#hints>
|
||
|
|
||
|
The COP's hint flags, rendered with abbreviated names if possible. An empty
|
||
|
string if this is not a COP. Here are the symbols used:
|
||
|
|
||
|
$ strict refs
|
||
|
& strict subs
|
||
|
* strict vars
|
||
|
x$ explicit use/no strict refs
|
||
|
x& explicit use/no strict subs
|
||
|
x* explicit use/no strict vars
|
||
|
i integers
|
||
|
l locale
|
||
|
b bytes
|
||
|
{ block scope
|
||
|
% localise %^H
|
||
|
< open in
|
||
|
> open out
|
||
|
I overload int
|
||
|
F overload float
|
||
|
B overload binary
|
||
|
S overload string
|
||
|
R overload re
|
||
|
T taint
|
||
|
E eval
|
||
|
X filetest access
|
||
|
U utf-8
|
||
|
|
||
|
us use feature 'unicode_strings'
|
||
|
fea=NNN feature bundle number
|
||
|
|
||
|
=item B<#hintsval>
|
||
|
|
||
|
The numeric value of the COP's hint flags, or an empty string if this is not
|
||
|
a COP.
|
||
|
|
||
|
=item B<#hyphseq>
|
||
|
|
||
|
The sequence number of the OP, or a hyphen if it doesn't have one.
|
||
|
|
||
|
=item B<#label>
|
||
|
|
||
|
'NEXT', 'LAST', or 'REDO' if the OP is a target of one of those in exec
|
||
|
mode, or empty otherwise.
|
||
|
|
||
|
=item B<#lastaddr>
|
||
|
|
||
|
The address of the OP's last child, in hexadecimal.
|
||
|
|
||
|
=item B<#name>
|
||
|
|
||
|
The OP's name.
|
||
|
|
||
|
=item B<#NAME>
|
||
|
|
||
|
The OP's name, in all caps.
|
||
|
|
||
|
=item B<#next>
|
||
|
|
||
|
The sequence number of the OP's next OP.
|
||
|
|
||
|
=item B<#nextaddr>
|
||
|
|
||
|
The address of the OP's next OP, in hexadecimal.
|
||
|
|
||
|
=item B<#noise>
|
||
|
|
||
|
A one- or two-character abbreviation for the OP's name.
|
||
|
|
||
|
=item B<#private>
|
||
|
|
||
|
The OP's private flags, rendered with abbreviated names if possible.
|
||
|
|
||
|
=item B<#privval>
|
||
|
|
||
|
The numeric value of the OP's private flags.
|
||
|
|
||
|
=item B<#seq>
|
||
|
|
||
|
The sequence number of the OP. Note that this is a sequence number
|
||
|
generated by B::Concise.
|
||
|
|
||
|
=item B<#opt>
|
||
|
|
||
|
Whether or not the op has been optimized by the peephole optimizer.
|
||
|
|
||
|
=item B<#sibaddr>
|
||
|
|
||
|
The address of the OP's next youngest sibling, in hexadecimal.
|
||
|
|
||
|
=item B<#svaddr>
|
||
|
|
||
|
The address of the OP's SV, if it has an SV, in hexadecimal.
|
||
|
|
||
|
=item B<#svclass>
|
||
|
|
||
|
The class of the OP's SV, if it has one, in all caps (e.g., 'IV').
|
||
|
|
||
|
=item B<#svval>
|
||
|
|
||
|
The value of the OP's SV, if it has one, in a short human-readable format.
|
||
|
|
||
|
=item B<#targ>
|
||
|
|
||
|
The numeric value of the OP's targ.
|
||
|
|
||
|
=item B<#targarg>
|
||
|
|
||
|
The name of the variable the OP's targ refers to, if any, otherwise the
|
||
|
letter t followed by the OP's targ in decimal.
|
||
|
|
||
|
=item B<#targarglife>
|
||
|
|
||
|
Same as B<#targarg>, but followed by the COP sequence numbers that delimit
|
||
|
the variable's lifetime (or 'end' for a variable in an open scope) for a
|
||
|
variable.
|
||
|
|
||
|
=item B<#typenum>
|
||
|
|
||
|
The numeric value of the OP's type, in decimal.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head1 One-Liner Command tips
|
||
|
|
||
|
=over 4
|
||
|
|
||
|
=item perl -MO=Concise,bar foo.pl
|
||
|
|
||
|
Renders only bar() from foo.pl. To see main, drop the ',bar'. To see
|
||
|
both, add ',-main'
|
||
|
|
||
|
=item perl -MDigest::MD5=md5 -MO=Concise,md5 -e1
|
||
|
|
||
|
Identifies md5 as an XS function. The export is needed so that BC can
|
||
|
find it in main.
|
||
|
|
||
|
=item perl -MPOSIX -MO=Concise,_POSIX_ARG_MAX -e1
|
||
|
|
||
|
Identifies _POSIX_ARG_MAX as a constant sub, optimized to an IV.
|
||
|
Although POSIX isn't entirely consistent across platforms, this is
|
||
|
likely to be present in virtually all of them.
|
||
|
|
||
|
=item perl -MPOSIX -MO=Concise,a -e 'print _POSIX_SAVED_IDS'
|
||
|
|
||
|
This renders a print statement, which includes a call to the function.
|
||
|
It's identical to rendering a file with a use call and that single
|
||
|
statement, except for the filename which appears in the nextstate ops.
|
||
|
|
||
|
=item perl -MPOSIX -MO=Concise,a -e 'sub a{_POSIX_SAVED_IDS}'
|
||
|
|
||
|
This is B<very> similar to previous, only the first two ops differ. This
|
||
|
subroutine rendering is more representative, insofar as a single main
|
||
|
program will have many subs.
|
||
|
|
||
|
=item perl -MB::Concise -e 'B::Concise::compile("-exec","-src", \%B::Concise::)->()'
|
||
|
|
||
|
This renders all functions in the B::Concise package with the source
|
||
|
lines. It eschews the O framework so that the stashref can be passed
|
||
|
directly to B::Concise::compile(). See -stash option for a more
|
||
|
convenient way to render a package.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head1 Using B::Concise outside of the O framework
|
||
|
|
||
|
The common (and original) usage of B::Concise was for command-line
|
||
|
renderings of simple code, as given in EXAMPLE. But you can also use
|
||
|
B<B::Concise> from your code, and call compile() directly, and
|
||
|
repeatedly. By doing so, you can avoid the compile-time only
|
||
|
operation of O.pm, and even use the debugger to step through
|
||
|
B::Concise::compile() itself.
|
||
|
|
||
|
Once you're doing this, you may alter Concise output by adding new
|
||
|
rendering styles, and by optionally adding callback routines which
|
||
|
populate new variables, if such were referenced from those (just
|
||
|
added) styles.
|
||
|
|
||
|
=head2 Example: Altering Concise Renderings
|
||
|
|
||
|
use B::Concise qw(set_style add_callback);
|
||
|
add_style($yourStyleName => $defaultfmt, $gotofmt, $treefmt);
|
||
|
add_callback
|
||
|
( sub {
|
||
|
my ($h, $op, $format, $level, $stylename) = @_;
|
||
|
$h->{variable} = some_func($op);
|
||
|
});
|
||
|
$walker = B::Concise::compile(@options,@subnames,@subrefs);
|
||
|
$walker->();
|
||
|
|
||
|
=head2 set_style()
|
||
|
|
||
|
B<set_style> accepts 3 arguments, and updates the three format-specs
|
||
|
comprising a line-style (basic-exec, goto, tree). It has one minor
|
||
|
drawback though; it doesn't register the style under a new name. This
|
||
|
can become an issue if you render more than once and switch styles.
|
||
|
Thus you may prefer to use add_style() and/or set_style_standard()
|
||
|
instead.
|
||
|
|
||
|
=head2 set_style_standard($name)
|
||
|
|
||
|
This restores one of the standard line-styles: C<terse>, C<concise>,
|
||
|
C<linenoise>, C<debug>, C<env>, into effect. It also accepts style
|
||
|
names previously defined with add_style().
|
||
|
|
||
|
=head2 add_style ()
|
||
|
|
||
|
This subroutine accepts a new style name and three style arguments as
|
||
|
above, and creates, registers, and selects the newly named style. It is
|
||
|
an error to re-add a style; call set_style_standard() to switch between
|
||
|
several styles.
|
||
|
|
||
|
=head2 add_callback ()
|
||
|
|
||
|
If your newly minted styles refer to any new #variables, you'll need
|
||
|
to define a callback subroutine that will populate (or modify) those
|
||
|
variables. They are then available for use in the style you've
|
||
|
chosen.
|
||
|
|
||
|
The callbacks are called for each opcode visited by Concise, in the
|
||
|
same order as they are added. Each subroutine is passed five
|
||
|
parameters.
|
||
|
|
||
|
1. A hashref, containing the variable names and values which are
|
||
|
populated into the report-line for the op
|
||
|
2. the op, as a B<B::OP> object
|
||
|
3. a reference to the format string
|
||
|
4. the formatting (indent) level
|
||
|
5. the selected stylename
|
||
|
|
||
|
To define your own variables, simply add them to the hash, or change
|
||
|
existing values if you need to. The level and format are passed in as
|
||
|
references to scalars, but it is unlikely that they will need to be
|
||
|
changed or even used.
|
||
|
|
||
|
=head2 Running B::Concise::compile()
|
||
|
|
||
|
B<compile> accepts options as described above in L</OPTIONS>, and
|
||
|
arguments, which are either coderefs, or subroutine names.
|
||
|
|
||
|
It constructs and returns a $treewalker coderef, which when invoked,
|
||
|
traverses, or walks, and renders the optrees of the given arguments to
|
||
|
STDOUT. You can reuse this, and can change the rendering style used
|
||
|
each time; thereafter the coderef renders in the new style.
|
||
|
|
||
|
B<walk_output> lets you change the print destination from STDOUT to
|
||
|
another open filehandle, or into a string passed as a ref (unless
|
||
|
you've built perl with -Uuseperlio).
|
||
|
|
||
|
my $walker = B::Concise::compile('-terse','aFuncName', \&aSubRef); # 1
|
||
|
walk_output(\my $buf);
|
||
|
$walker->(); # 1 renders -terse
|
||
|
set_style_standard('concise'); # 2
|
||
|
$walker->(); # 2 renders -concise
|
||
|
$walker->(@new); # 3 renders whatever
|
||
|
print "3 different renderings: terse, concise, and @new: $buf\n";
|
||
|
|
||
|
When $walker is called, it traverses the subroutines supplied when it
|
||
|
was created, and renders them using the current style. You can change
|
||
|
the style afterwards in several different ways:
|
||
|
|
||
|
1. call C<compile>, altering style or mode/order
|
||
|
2. call C<set_style_standard>
|
||
|
3. call $walker, passing @new options
|
||
|
|
||
|
Passing new options to the $walker is the easiest way to change
|
||
|
amongst any pre-defined styles (the ones you add are automatically
|
||
|
recognized as options), and is the only way to alter rendering order
|
||
|
without calling compile again. Note however that rendering state is
|
||
|
still shared amongst multiple $walker objects, so they must still be
|
||
|
used in a coordinated manner.
|
||
|
|
||
|
=head2 B::Concise::reset_sequence()
|
||
|
|
||
|
This function (not exported) lets you reset the sequence numbers (note
|
||
|
that they're numbered arbitrarily, their goal being to be human
|
||
|
readable). Its purpose is mostly to support testing, i.e. to compare
|
||
|
the concise output from two identical anonymous subroutines (but
|
||
|
different instances). Without the reset, B::Concise, seeing that
|
||
|
they're separate optrees, generates different sequence numbers in
|
||
|
the output.
|
||
|
|
||
|
=head2 Errors
|
||
|
|
||
|
Errors in rendering (non-existent function-name, non-existent coderef)
|
||
|
are written to the STDOUT, or wherever you've set it via
|
||
|
walk_output().
|
||
|
|
||
|
Errors using the various *style* calls, and bad args to walk_output(),
|
||
|
result in die(). Use an eval if you wish to catch these errors and
|
||
|
continue processing.
|
||
|
|
||
|
=head1 AUTHOR
|
||
|
|
||
|
Stephen McCamant, E<lt>smcc@CSUA.Berkeley.EDUE<gt>.
|
||
|
|
||
|
=cut
|