B-DeparseTree
view release on metacpan or search on metacpan
example/fib.pl view on Meta::CPAN
#!/usr/bin/env perl
use rlib '../lib';
use B::DeparseTree;
use B::Deparse;
use Data::Printer;
use B::Concise;
sub fib($) {
my $x = shift;
return 1 if $x <= 1;
fib($x-1) + fib($x-2);
}
sub bar {
printf "fib(2)= %d, fib(3) = %d, fib(4) = %d\n", fib(2), fib(3), fib(4);
}
# my $walker = B::Concise::compile('-basic', '-src', 'fib', \&fib);
lib/B/DeparseTree/Fragment.pm view on Meta::CPAN
my $deparse = B::DeparseTree->new();
if ($funcname eq "DB::DB") {
$deparse->main2info;
} else {
$deparse->coderef2info(\&$funcname);
}
get_addr_info($deparse, $address);
}
sub get_addr($$)
{
my ($deparse, $addr) = @_;
return undef unless $addr;
return $deparse->{optree}{$addr};
}
sub get_addr_info($$)
{
my ($deparse, $addr) = @_;
my $op_info = get_addr($deparse, $addr);
return $op_info;
}
sub get_parent_op($)
{
my ($op_info) = @_;
return undef unless $op_info;
my $deparse = $op_info->{deparse};
# FIXME:
return $deparse->{ops}{$op_info->{addr}}{parent};
}
sub get_parent_addr_info($)
{
my ($op_info) = @_;
my $deparse = $op_info->{deparse};
# FIXME
# my $parent_op = get_parent_op($op_info);
my $parent_addr = $op_info->{parent};
return undef unless $parent_addr;
return $deparse->{optree}{$parent_addr};
}
sub get_prev_info($);
sub get_prev_info($)
{
my ($op_info) = @_;
return undef unless $op_info;
return $op_info->{prev_expr}
}
sub get_prev_addr_info($);
sub get_prev_addr_info($)
{
my ($op_info) = @_;
return undef unless $op_info;
if (!exists $op_info->{prev_expr}) {
my $parent_info = get_parent_addr_info($op_info);
if ($parent_info) {
return get_prev_addr_info($parent_info);
} else {
return undef;
}
}
return $op_info->{prev_expr}
}
sub underline_parent($$$) {
my ($child_text, $parent_text, $char) = @_;
my $start_pos = index($parent_text, $child_text);
return (' ' x $start_pos) . ($char x length($child_text));
}
# Return either 2 or 3 strings in an array reference.
# There are various cases to consider.
# 1. Child and parent texts are no more than a single line:
# return and the underline, two entries. For example:
# my ($a, $b) = (5, 6);
lib/B/DeparseTree/Fragment.pm view on Meta::CPAN
# $c;
# }
# return:
# if ($a) {...
# $b;
# ---...
# 5. Like 4, but the child is on the first line. A cross between
# 3 and 4. No elipses for the first line is needed, just one on the
# underline
#
sub trim_line_pair($$$$) {
my ($parent_text, $child_text, $parent_underline, $start_pos) = @_;
# If the parent text is longer than a line, use just the line.
# The underline indicator adds an elipsis to show it is elided.
my @parent_lines = split(/\n/, $parent_text);
my $i = 0;
if (scalar(@parent_lines) > 1) {
for ($i=0; $start_pos > length($parent_lines[$i]); $i++) {
my $l = length($parent_lines[$i]);
$start_pos -= ($l+1);
$parent_underline = substr($parent_underline, $l+1);
lib/B/DeparseTree/Fragment.pm view on Meta::CPAN
# don't have an equivalent concept in the source code, so we've
# artificially tagged a location that is reasonable. "pushmark"
# and "padrange" instructions would be in this category.
#
# In the last two examples, we show how we do elision. The ...
# in the parent text means that we have only given the first line
# of the parent text along with the line that the child fits in.
# if there is an elision in the child text it means that that
# spans more than one line.
sub extract_node_info($)
{
my ($info) = @_;
my $child_text = $info->{text};
my $parent_text = undef;
my $candidate_pair = undef;
my $marked_position = undef;
# Some opcodes like pushmark , padrange, and null,
# don't have an well-defined correspondence to a string in the
lib/B/DeparseTree/Fragment.pm view on Meta::CPAN
if (index($parent_text, $child_text, $start_index+1) < 0) {
# It is in there *uniquely*!
my $parent_underline = underline_parent($child_text, $parent_text, '~');
return trim_line_pair($parent_text, $child_text, $parent_underline, $start_index);
}
}
}
# Dump out full information of a node in relation to its
# parent
sub dump($) {
my ($deparse_tree) = @_;
my @addrs = sort keys %{$deparse_tree->{optree}};
for (my $i=0; $i < $#addrs; $i++) {
printf("%d: %s\n", $i, ('=' x 50));
my $info = get_addr_info($deparse_tree, $addrs[$i]);
if ($info) {
printf "0x%0x\n", $addrs[$i];
p $info ;
}
if ($info->{parent}) {
lib/B/DeparseTree/Fragment.pm view on Meta::CPAN
print join("\n", @$texts), "\n";
}
}
}
printf("%d: %s\n", $i, ('=' x 50));
}
}
# Dump out essention information of a node in relation to its
# parent
sub dump_relations($) {
my ($deparse_tree) = @_;
my @addrs = sort keys %{$deparse_tree->{optree}};
for (my $i=0; $i < $#addrs; $i++) {
my $info = get_addr_info($deparse_tree, $addrs[$i]);
next unless $info && $info->{parent};
my $parent = get_parent_addr_info($info);
next unless $parent;
printf("%d: %s\n", $i, ('=' x 50));
print "Child info:\n";
printf "\taddr: 0x%0x, parent: 0x%0x\n", $addrs[$i], $parent->{addr};
lib/B/DeparseTree/Fragment.pm view on Meta::CPAN
printf "\ttext: %s\n\n", $info->{text};
# p $parent ;
my $texts = extract_node_info($info);
if ($texts) {
print join("\n", @$texts), "\n";
}
printf("%d: %s\n", $i, ('=' x 50));
}
}
sub dump_tree($$);
# Dump out the entire texts in tree format
sub dump_tree($$) {
my ($deparse_tree, $info) = @_;
if (ref($info) and (ref($info->{texts}) eq 'ARRAY')) {
foreach my $child_info (@{$info->{texts}}) {
if (ref($child_info)) {
if (ref($child_info) eq 'ARRAY') {
p $child_info;
} elsif (ref($child_info) eq 'B::DeparseTree::TreeNode') {
dump_tree($deparse_tree, $child_info)
} else {
printf "Unknown child_info type %s\n", ref($child_info);
lib/B/DeparseTree/P518.pm view on Meta::CPAN
}
return $quoted ? "$array->" : $array;
} elsif (!$allow_arrow || B::Deparse::is_scalar $array) {
# $x[0], $$x[0], ...
return $self->deparse($array, 24)->{text};
} else {
return undef;
}
}
sub elem_or_slice_single_index($$)
{
my ($self, $idx, $parent) = @_;
my $idx_info = $self->deparse($idx, 1, $parent);
my $idx_str = $idx_info->{text};
# Outer parens in an array index will confuse perl
# if we're interpolating in a regular expression, i.e.
# /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
#
lib/B/DeparseTree/P522.pm view on Meta::CPAN
}
return $quoted ? "$array->" : $array;
} elsif (!$allow_arrow || B::Deparse::is_scalar $array) {
# $x[0], $$x[0], ...
return $self->deparse($array, 24)->{text};
} else {
return undef;
}
}
sub elem_or_slice_single_index($$)
{
my ($self, $idx, $parent) = @_;
my $idx_info = $self->deparse($idx, 1, $parent);
my $idx_str = $idx_info->{text};
# Outer parens in an array index will confuse perl
# if we're interpolating in a regular expression, i.e.
# /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
#
lib/B/DeparseTree/P522.pm view on Meta::CPAN
$idx_str =~ s/^([A-Za-z_]\w*)$/$1()/;
return info_from_text($idx_info->{op}, $self, $idx_str,
'elem_or_slice_single_index',
{body => [$idx_info]});
}
# a simplified version of elem_or_slice_array_name()
# for the use of pp_multideref
sub multideref_var_name($$$)
{
my ($self, $gv, $is_hash) = @_;
my ($name, $quoted) =
$self->stash_variable_name( $is_hash ? '%' : '@', $gv);
return $quoted ? "$name->"
: $name eq '#'
? '${#}' # avoid ${#}[1] => $#[1]
: '$' . $name;
}
lib/B/DeparseTree/P526.pm view on Meta::CPAN
}
return $quoted ? "$array->" : $array;
} elsif (!$allow_arrow || B::Deparse::is_scalar $array) {
# $x[0], $$x[0], ...
return $self->deparse($array, 24)->{text};
} else {
return undef;
}
}
sub elem_or_slice_single_index($$)
{
my ($self, $idx, $parent) = @_;
my $idx_info = $self->deparse($idx, 1, $parent);
my $idx_str = $idx_info->{text};
# Outer parens in an array index will confuse perl
# if we're interpolating in a regular expression, i.e.
# /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
#
lib/B/DeparseTree/P526.pm view on Meta::CPAN
$type = 'elem_arrow';
}
return info_from_list($op, $self, \@texts, '', $type, $opts);
}
Carp::confess("unhandled condition in elem");
}
# a simplified version of elem_or_slice_array_name()
# for the use of pp_multideref
sub multideref_var_name($$$)
{
my ($self, $gv, $is_hash) = @_;
my ($name, $quoted) =
$self->stash_variable_name( $is_hash ? '%' : '@', $gv);
return $quoted ? "$name->"
: $name eq '#'
? '${#}' # avoid ${#}[1] => $#[1]
: '$' . $name;
}
lib/B/DeparseTree/P526c.pm view on Meta::CPAN
}
return $quoted ? "$array->" : $array;
} elsif (!$allow_arrow || B::Deparse::is_scalar $array) {
# $x[0], $$x[0], ...
return $self->deparse($array, 24)->{text};
} else {
return undef;
}
}
sub elem_or_slice_single_index($$)
{
my ($self, $idx, $parent) = @_;
my $idx_info = $self->deparse($idx, 1, $parent);
my $idx_str = $idx_info->{text};
# Outer parens in an array index will confuse perl
# if we're interpolating in a regular expression, i.e.
# /$x$foo[(-1)]/ is *not* the same as /$x$foo[-1]/
#
lib/B/DeparseTree/P526c.pm view on Meta::CPAN
$idx_str =~ s/^([A-Za-z_]\w*)$/$1()/;
return info_from_text($idx_info->{op}, $self, $idx_str,
'elem_or_slice_single_index',
{body => [$idx_info]});
}
# a simplified version of elem_or_slice_array_name()
# for the use of pp_multideref
sub multideref_var_name($$$)
{
my ($self, $gv, $is_hash) = @_;
my ($name, $quoted) =
$self->stash_variable_name( $is_hash ? '%' : '@', $gv);
return $quoted ? "$name->"
: $name eq '#'
? '${#}' # avoid ${#}[1] => $#[1]
: '$' . $name;
}
lib/B/DeparseTree/PP.pm view on Meta::CPAN
}
sub pp_clonecv {
my $self = shift;
my($op, $cx) = @_;
my $sv = $self->padname_sv($op->targ);
my $name = substr $sv->PVX, 1; # skip &/$/@/%, like $self->padany
return $self->info_from_string("clonev my sub", $op, "my sub $name");
}
sub pp_delete($$$)
{
my($self, $op, $cx) = @_;
my $arg;
my ($info, $body, $type);
if ($op->private & B::OPpSLICE) {
if ($op->flags & B::OPf_SPECIAL) {
# Deleting from an array, not a hash
$info = $self->pp_aslice($op->first, 16);
$type = 'delete slice';
}
lib/B/DeparseTree/PP.pm view on Meta::CPAN
} else {
return $self->info_from_template("list", $op,
"%C", [[0, $#exprs, ', ']],
\@exprs,
{maybe_parens => [$self, $cx, 6],
other_ops => \@other_ops});
}
}
sub pp_padcv($$$) {
my($self, $op, $cx) = @_;
return info_from_text($op, $self, $self->padany($op), 'padcv', {});
}
sub pp_refgen
{
my($self, $op, $cx) = @_;
my $kid = $op->first;
if ($kid->name eq "null") {
my $other_ops = [$kid];
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
if (@_) {
croak "The ambient_pragmas method expects an even number of args";
}
$self->{'ambient_arybase'} = $arybase;
$self->{'ambient_warnings'} = $warning_bits;
$self->{'ambient_hints'} = $hint_bits;
$self->{'ambient_hinthash'} = $hinthash;
}
sub anon_hash_or_list($$$)
{
my ($self, $op, $cx) = @_;
my $name = $op->name;
my($pre, $post) = @{{"anonlist" => ["[","]"],
"anonhash" => ["{","}"]}->{$name}};
my($expr, @exprs);
my $first_op = $op->first;
$op = $first_op->sibling; # skip pushmark
for (; !B::Deparse::null($op); $op = $op->sibling) {
$expr = $self->deparse($op, 6, $op);
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
'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_format($$$)
{
my ($self, $form, $parent) = @_;
my @texts;
local($self->{'curcv'}) = $form;
local($self->{'curcvlex'});
local($self->{'in_format'}) = 1;
local(@$self{qw'curstash warnings hints hinthash'})
= @$self{qw'curstash warnings hints hinthash'};
my $op = $form->ROOT;
local $B::overlay = {};
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
}
push @texts, "\f".$self->combine2str("\n", \@body) if @body;
$op = $op->sibling;
}
$info->{text} = $self->combine2str(\@texts) . "\f.";
$info->{texts} = \@texts;
return $info;
}
sub dedup_func_parens($$)
{
my $self = shift;
my ($args_ref) = @_;
my @args = @$args_ref;
return (
scalar @args == 1 &&
substr($args[0]->{text}, 0, 1) eq '(' &&
substr($args[0]->{text}, 0, 1) eq ')');
}
sub dedup_parens_func($$$)
{
my $self = shift;
my $sub_info = shift;
my ($args_ref) = @_;
my @args = @$args_ref;
if (scalar @args == 1 && substr($args[0], 0, 1) eq '(' &&
substr($args[0], -1, 1) eq ')') {
return ($sub_info, $self->combine(', ', \@args), );
} else {
return ($sub_info, '(', $self->combine(', ', \@args), ')', );
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
return $self->deparse($right, $prec - .00001, $op);
} else {
return $self->deparse($right, $prec, $op);
}
}
# Iterate via sibling links a list of OP nodes starting with
# $first. Each OP is deparsed, with $op and $precedence each to get a
# node. Then the "prev" field in the node is set, and finally it is
# pushed onto the end of the $exprs reference ARRAY.
sub deparse_op_siblings($$$$$)
{
my ($self, $exprs, $kid, $op, $precedence) = @_;
my $prev_expr = undef;
$prev_expr = $exprs->[-1] if scalar @{$exprs};
for ( ; !B::Deparse::null($kid); $kid = $kid->sibling) {
my $expr = $self->deparse($kid, $precedence, $op);
if (defined $expr) {
$expr->{prev_expr} = $prev_expr;
$prev_expr = $expr;
push @$exprs, $expr;
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
for $delim ('/', '"', '#') { # note no '
return "$delim$from$delim$to$delim"
if index($to . $from, $delim) == -1;
}
$from =~ s[/][\\/]g;
$to =~ s[/][\\/]g;
return "/$from/$to/";
}
}
sub dq($$$)
{
my ($self, $op, $parent) = @_;
my $type = $op->name;
my $info;
if ($type eq "const") {
return info_from_text($op, $self, '$[', 'dq constant ary', {}) if $op->private & OPpCONST_ARYBASE;
return info_from_text($op, $self,
B::Deparse::uninterp(B::Deparse::escape_str(B::Deparse::unback($self->const_sv($op)->as_string))),
'dq constant', {});
} elsif ($type eq "concat") {
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
$type = 'elem_no_arrow';
} else {
push @texts, '->', $left, $idx_info->{text}, $right;
$type = 'elem_arrow';
}
return info_from_list($op, $self, \@texts, '', $type, $opts);
}
Carp::confess("unhandled condition in elem");
}
sub e_anoncode($$)
{
my ($self, $info) = @_;
my $sub_info = $self->deparse_sub($info->{code});
return $self->info_from_template('sub anonymous', $sub_info->{op},
'sub %c', [0], [$sub_info]);
}
# Handle filetest operators -r, stat, etc.
sub filetest
{
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
$fmt = "$name %c";
$type = "filetest $name";
}
return $self->info_from_template($type, $op, $fmt, undef, [$gv_node]);
} else {
# I don't think baseop filetests ever survive ck_filetest, but...
return $self->info_from_string("filetest $name", $op, $name);
}
}
sub for_loop($$$$) {
my ($self, $op, $cx, $parent) = @_;
my $init = $self->deparse($op, 1, $parent);
my $s = $op->sibling;
my $ll = $s->name eq "unstack" ? $s->sibling : $s->first->sibling;
return $self->loop_common($ll, $cx, $init);
}
# Returns in function (whose name is not passed as a parameter) will
# need to surround its argements (the first argument is $first_param)
# in parenthesis. To determine this, we also pass in the operator
# precedence, $prec, and the current expression context value, $cx
sub func_needs_parens($$$$)
{
my($self, $first_param, $cx, $prec) = @_;
return ($prec <= $cx) || (substr($first_param, 0, 1) eq "(") || $self->{'parens'};
}
sub givwhen
{
my($self, $op, $cx, $give_when) = @_;
my @arg_spec = ();
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
sub is_lexical_subs {
my (@ops) = shift;
for my $op (@ops) {
return 0 if $op->name !~ /\A(?:introcv|clonecv)\z/;
}
return 1;
}
# The version of null_op_list after 5.22
# Note: this uses "op" not "kid"
sub is_list_newer($$) {
my ($self, $op) = @_;
my $kid = $op->first;
return 1 if $kid->name eq 'pushmark';
return ($kid->name eq 'null'
&& $kid->targ == OP_PUSHMARK
&& B::Deparse::_op_is_or_was($op, B::Deparse::OP_LIST));
}
# The version of null_op_list before 5.22
# Note: this uses "kid", not "op"
sub is_list_older($) {
my ($self, $kid) = @_;
# Something may be funky where without the convesion we are getting ""
# as a return
return ($kid->name eq 'pushmark') ? 1 : 0;
}
# This handle logical ops: "if"/"until", "&&", "and", ...
# The one-line "while"/"until" is handled in pp_leave.
sub logop
{
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
$opts->{maybe_parens} = [$self, $cx, 20];
$type = 'matchop_binop';
} else {
@texts = ($re_str);
$type = 'matchop_unnop';
}
return info_from_list($op, $self, \@texts, '', $type, $opts);
}
# FIXME: remove this
sub map_texts($$)
{
my ($self, $args) = @_;
my @result ;
foreach my $expr (@$args) {
if (ref $expr eq 'ARRAY' and scalar(@$expr) == 2) {
# First item is hash and second item is op address.
push @result, [$expr->[0]{text}, $expr->[1]];
} else {
push @result, [$expr->{text}, $expr->{addr}];
}
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
"$my_str $text",
{maybe_parens => [$self, $cx, 16]});
}
} else {
return $self->info_from_string('not my', $op, $text);
}
}
# Possibly add () around $text depending on precedence $prec and
# context $cx. We return a string.
sub maybe_parens($$$$)
{
my($self, $text, $cx, $prec) = @_;
if (B::DeparseTree::TreeNode::parens_test($self, $cx, $prec)) {
$text = "($text)";
# In a unop, let parent reuse our parens; see maybe_parens_unop
# FIXME:
$text = "\cS" . $text if $cx == 16;
return $text;
} else {
return $text;
}
}
# FIXME: go back to default B::Deparse routine and return a string.
sub maybe_parens_func($$$$$)
{
my($self, $func, $params, $cx, $prec) = @_;
if ($prec <= $cx or substr($params, 0, 1) eq "(" or $self->{'parens'}) {
return ($func, '(', $params, ')');
} else {
return ($func, ' ', $params);
}
}
# Sort of like maybe_parens in that we may possibly add (). However we take
# an op rather than text, and return a tree node. Also, we get around
# the 'if it looks like a function' rule.
sub maybe_parens_unop($$$$$)
{
my ($self, $name, $op, $cx, $parent, $opts) = @_;
$opts = {} unless $opts;
my $info = $self->deparse($op, 1, $parent);
my $fmt;
my @exprs = ($info);
if ($name eq "umask" && $info->{text} =~ /^\d+$/) {
# Display umask numbers in octal.
# FIXME: add as a info_node option to run a transformation function
# such as the below
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
return $self->info_from_template("rcatline =",$op,
"%c = %c", undef, [$lhs, $rhs],
{ maybe_parens => [$self, $cx, 20],
prev_expr => $rhs });
} else {
return $self->deparse($kid, $cx, $op);
}
Carp::confess("unhandled condition in null");
}
sub pushmark_position($) {
my ($node) = @_;
my $l = undef;
if ($node->{parens}) {
return [0, 1];
} elsif (exists $node->{fmt}) {
# Match up to %c, %C, or %F after ( or {
if ($node->{fmt} =~ /^(.*)%[cCF]/) {
$l = length($1);
}
} else {
lib/B/DeparseTree/PPfns.pm view on Meta::CPAN
"do {\n%+%c\n%-}",
[0], [$body]);
}
} else {
$node = $self->lineseq($op, $cx, @kids);
}
$node->{other_ops} = \@other_ops if @other_ops;
return $node;
}
sub single_delim($$$$$)
{
my($self, $op, $q, $default, $str) = @_;
return $self->info_from_template("string $default .. $default (default)", $op,
"$default%c$default", [0],
[$str])
if $default and index($str, $default) == -1;
my $coreq = $self->keyword($q); # maybe CORE::q
if ($q ne 'qr') {
(my $succeed, $str) = balanced_delim($str);
lib/B/DeparseTree/Printer.pm view on Meta::CPAN
our($VERSION, @EXPORT, @ISA);
$VERSION = '3.2.0';
@ISA = qw(Exporter);
@EXPORT = qw(format_info format_info_walk);
use constant sep_string => ('=' x 40) . "\n";
# Elide string with ... if it is too long, and
# show control characters in string.
sub short_str($;$) {
my ($str, $maxwidth) = @_;
$maxwidth ||= 20;
if (length($str) > $maxwidth) {
my $chop = $maxwidth - 3;
$str = substr($str, 0, $chop) . '...' . substr($str, -$chop);
}
$str =~ s/\cK/\\cK/g;
$str =~ s/\f/\\f/g;
$str =~ s/\n/\\n/g;
$str =~ s/\t/\\t/g;
return $str
}
sub format_info_short($$)
{
my ($info, $show_body) = @_;
my %i = %{$info};
my $text;
my $op = $i{op};
if ($op) {
$text = sprintf(
"0x%x %s/%s: \"%s\"",
$$op,
lib/B/DeparseTree/Printer.pm view on Meta::CPAN
$text .= ("\n\t" .
join(",\n\t",
map(sprintf("0x%x %s '%s'", ${$_->{op}},
$_->{type}, short_str($_->{text})),
@{$i{body}})));
}
# FIXME: other ops
return $text;
}
sub format_info($)
{
my $info = shift;
my %i = %{$info};
my $fmt = <<EOF;
type :%s
op :%s
cop line: %s
parent : %s
text:
%s
lib/B/DeparseTree/Printer.pm view on Meta::CPAN
}
$text .= sprintf("need parens: %s\n",
B::DeparseTree::TreeNode::parens_test($info,
$maybe_parens{context},
$maybe_parens{precedence}) ?
'yes' : 'no');
}
return $text;
}
sub format_info_walk($$);
sub format_info_walk($$)
{
my ($info, $indent_level) = @_;
my $text = '';
$text = format_info_short($info, 0);
$indent_level += 2;
return $text unless exists $info->{body};
my @body = @{$info->{body}};
for (my $i=0; $i < scalar @body; $i++) {
my $info = $body[$i];
my $lead = "\n" . (' ' x $indent_level) . "[$i] ";
lib/B/DeparseTree/SyntaxTree.pm view on Meta::CPAN
indent_value
info2str
info_from_list
info_from_template
info_from_string
info_from_text
template_engine
template2str
);
sub combine($$$)
{
my ($self, $sep, $items) = @_;
# FIXME: loop over $item, testing type.
Carp::confess("should be a reference to a array: is $items") unless
ref $items eq 'ARRAY';
my @result = ();
foreach my $item (@$items) {
my $add;
if (ref $item) {
if (ref $item eq 'ARRAY' and scalar(@$item) == 2) {
lib/B/DeparseTree/SyntaxTree.pm view on Meta::CPAN
}
} else {
$add = $item;
}
push @result, $sep if @result && $sep;
push @result, $add;
}
return @result;
}
sub combine2str($$$)
{
my ($self, $sep, $items) = @_;
my $result = '';
foreach my $item (@$items) {
$result .= $sep if $result;
if (ref $item) {
if (ref $item eq 'ARRAY' and scalar(@$item) == 2) {
# First item is text and second item is op address.
$result .= $self->info2str($item->[0]);
} elsif (eval{$item->isa("B::DeparseTree::TreeNode")}) {
lib/B/DeparseTree/SyntaxTree.pm view on Meta::CPAN
# FIXME: add this and remove errors
if (index($item, '@B::DeparseTree::TreeNode') > 0) {
Carp::confess("\@B::DeparseTree::TreeNode as an item is probably wrong");
}
$result .= $item;
}
}
return $result;
}
sub expand_simple_spec($$)
{
my ($self, $fmt) = @_;
my $result = '';
while ((my $k=index($fmt, '%')) >= 0) {
$result .= substr($fmt, 0, $k);
my $spec = substr($fmt, $k, 2);
$fmt = substr($fmt, $k+2);
if ($spec eq '%%') {
$result .= '%';
lib/B/DeparseTree/SyntaxTree.pm view on Meta::CPAN
} elsif ($spec eq '%|') {
$result .= $self->indent_value();
} else {
Carp::confess("Unknown spec $spec")
}
}
$result .= $fmt if $fmt;
return $result;
}
sub indent_less($$) {
my ($self, $check_level) = @_;
$check_level = 0 if !defined $check_level;
$self->{level} -= $self->{'indent_size'};
my $level = $self->{level};
if ($check_level < 0) {
Carp::confess("mismatched indent/dedent") if $check_level;
$level = 0;
$self->{level} = 0;
}
return $self->indent_value();
}
sub indent_more($) {
my ($self) = @_;
$self->{level} += $self->{'indent_size'};
return $self->indent_value();
}
sub indent_value($) {
my ($self) = @_;
my $level = $self->{level};
if ($self->{'use_tabs'}) {
return "\t" x ($level / 8) . " " x ($level % 8);
} else {
return " " x $level;
}
}
sub info2str($$)
{
my ($self, $item) = @_;
my $result = '';
if (ref $item) {
if (ref $item eq 'ARRAY' and scalar(@$item) == 2) {
# This code is going away...
Carp::confess("fixme");
$result = $item->[0];
} elsif (eval{$item->isa("B::DeparseTree::TreeNode")}) {
if (exists $item->{fmt}) {
lib/B/DeparseTree/SyntaxTree.pm view on Meta::CPAN
if (index($item, '@B::DeparseTree::TreeNode') > 0) {
Carp::confess("\@B::DeparseTree::TreeNode as an item is probably wrong");
}
$result = $item;
}
return $result;
}
# Create an info structure from a list of strings
# FIXME: $deparse (or rather $self) should be first
sub info_from_list($$$$$$)
{
my ($op, $self, $texts, $sep, $type, $opts) = @_;
# Set undef in "texts" argument position because we are going to create
# our own text from the $texts.
my $info = B::DeparseTree::TreeNode->new($op, $self, $texts, undef,
$type, $opts);
$info->{sep} = $sep;
my $text = '';
foreach my $item (@$texts) {
lib/B/DeparseTree/SyntaxTree.pm view on Meta::CPAN
force => $obj->{'parens'},
parens => $parens ? 'true' : ''
};
$info->{text} = "($info->{text})" if exists $info->{text} and $parens;
}
return $info
}
# Create an info structure a template pattern
sub info_from_template($$$$$) {
my ($self, $type, $op, $fmt, $indexes, $args, $opts) = @_;
$opts = {} unless defined($opts);
# if (ref($args) ne "ARRAY") {
# use Enbugger "trepan"; Enbugger->stop;
# }
my @args = @$args;
my $info = B::DeparseTree::TreeNode->new($op, $self, $args, undef, $type, $opts);
$indexes = [0..$#args] unless defined $indexes;
$info->{'indexes'} = $indexes;
lib/B/DeparseTree/SyntaxTree.pm view on Meta::CPAN
force => $obj->{'parens'},
parens => $parens ? 'true' : ''
};
$info->{text} = "($info->{text})" if exists $info->{text} and $parens;
}
return $info;
}
# Create an info structure from a single string
sub info_from_string($$$$$)
{
my ($self, $type, $op, $str, $opts) = @_;
$opts ||= {};
return B::DeparseTree::TreeNode->new($op, $self, $str, undef,
$type, $opts);
}
# OBSOLETE: Create an info structure from a single string
# FIXME: remove this
sub info_from_text($$$$$)
{
my ($op, $self, $text, $type, $opts) = @_;
# Use this to smoke outt calls
# use Enbugger 'trepan'; Enbugger->stop;
return $self->info_from_string($type, $op, $text, $opts)
}
# List of suffix characters that are handled by "expand_simple_spec()".
use constant SIMPLE_SPEC => '%+-|';
# Extract the string at $args[$index] and if
# we are looking for that position include where we are in
# that position
sub get_info_and_str($$$)
{
my ($self, $index, $args) = @_;
my $info = $args->[$index];
my $str = $self->info2str($info);
return ($info, $str);
}
sub template_engine($$$$)
{
my ($self, $fmt, $indexes, $args, $find_addr) = @_;
# use Data::Dumper;
# print "-----\n";
# p $args;
# print "'======\n";
# print $fmt, "\n"
# print $args, "\n";
lib/B/DeparseTree/SyntaxTree.pm view on Meta::CPAN
$result .= $fmt if $fmt;
if ($find_addr != -2) {
# want result and position
return $result, $find_pos;
}
# want just result
return $result;
}
sub template2str($$) {
my ($self, $info) = @_;
return $self->template_engine($info->{fmt},
$info->{indexes},
$info->{texts});
}
1;
lib/B/DeparseTree/TreeMain.pm view on Meta::CPAN
@skipped_ops = @{$info->{other_ops}};
push @skipped_ops, $op->first;
} else {
@skipped_ops = ($op->first);
}
$info->{other_ops} = \@skipped_ops;
return $info;
}
sub update_node($$$$)
{
my ($self, $node, $prev_expr, $op) = @_;
$node->{prev_expr} = $prev_expr;
my $addr = $prev_expr->{addr};
if ($addr && ! exists $self->{optree}{$addr}) {
$self->{optree}{$addr} = $node if $op;
}
}
sub walk_lineseq
lib/B/DeparseTree/TreeMain.pm view on Meta::CPAN
$self->{'use_tabs'} = 1;
$opts = substr($opts, 1);
} elsif ($opt eq "v") {
$opts =~ s/^v([^.]*)(.|$)//;
$self->{'ex_const'} = $1;
}
}
}
# B::Deparse name is print_protos
sub extract_prototypes($)
{
my $self = shift;
my $ar;
my @ret;
foreach $ar (@{$self->{'protos_todo'}}) {
my $body;
if (defined $ar->[1]) {
if (ref $ar->[1]) {
# FIXME: better optree tracking?
# And use formatting markup?
lib/B/DeparseTree/TreeMain.pm view on Meta::CPAN
# "$other" is just the OP. Have it mark everything
# or "info".
$self->{optree}{$$other} = $info;
}
}
}
return $info;
}
# Deparse a subroutine
sub deparse_sub($$$$)
{
my ($self, $cv, $start_op) = @_;
# Sanity checks..
Carp::confess("NULL in deparse_sub") if !defined($cv) || $cv->isa("B::NULL");
Carp::confess("SPECIAL in deparse_sub") if $cv->isa("B::SPECIAL");
# First get protype and sub attribute information
local $self->{'curcop'} = $self->{'curcop'};
my $proto = '';
lib/B/DeparseTree/TreeMain.pm view on Meta::CPAN
my $node = $self->deparse_sub($cv, $parent);
$fmt .= '%c';
my $sub_node = $self->info_from_template($type, $cv, $fmt, [0], [$node]);
$node->{parent} = $sub_node->{addr};
$self->{optree}{$$cv} = $sub_node;
return $sub_node;
}
}
# Deparse a subroutine by name
sub deparse_subname($$)
{
my ($self, $funcname) = @_;
my $cv = svref_2object(\&$funcname);
my $info = $self->deparse_sub($cv);
my $sub_node = $self->info_from_template("sub $funcname", $cv, "sub $funcname %c",
undef, [$info]);
$self->{optree}{$$cv} = $sub_node;
return $sub_node;
}
lib/B/DeparseTree/TreeNode.pm view on Meta::CPAN
I<precedence> values; '' if not. We don't nest equal precedence
for unuary ops. The unary op precedence is given by
UNARY_OP_PRECEDENCE
=back
=back
=cut
sub parens_test($$$)
{
my ($obj, $cx, $prec) = @_;
return ($prec < $cx
# Unary ops which nest just fine
or ($prec == $cx && !exists $UNARY_PRECEDENCES{$cx}));
}
sub new($$$$$)
{
my ($class, $op, $deparse, $data, $sep, $type, $opts) = @_;
my $addr = -1;
if (ref($op)) {
if (ref($op) eq 'B::DeparseTree') {
# use Enbugger 'trepan'; Enbugger->stop;
Carp::confess("Rocky got the order of \$self, and \$op confused again");
$addr = -2;
} else {
eval { $addr = $$op };
lib/B/DeparseTree/TreeNode.pm view on Meta::CPAN
force => $obj->{'parens'},
parens => $parens ? 'true' : ''
};
$self->{text} = "($self->{text})" if exists $self->{text} and $parens;
}
return $self;
}
# Possibly add () around $text depending on precedence $prec and
# context $cx. We return a string.
sub maybe_parens($$$$)
{
my($self, $info, $cx, $prec) = @_;
if (parens_test($info, $cx, $prec)) {
$info->{text} = $self->combine('', "(", $info->{text}, ")");
# In a unop, let parent reuse our parens; see maybe_parens_unop
if ($cx == 16) {
$info->{parens} = 'reuse';
} else {
$info->{parens} = 'true';
}
return $info->{text};
} else {
$info->{parens} = '';
return $info->{text};
}
}
# Update $self->{other_ops} to add $info
sub update_other_ops($$)
{
my ($self, $info) = @_;
$self->{other_ops} ||= [];
my $other_ops = $self->{other_ops};
push @{$other_ops}, $info;
$self->{other_ops} = $other_ops;
}
# Demo code
unless(caller) {
scripts/bug-sample.pm view on Meta::CPAN
# Modify this and copy it to bug.pm for bug testing
# Use this as a default file to test for bugs
sub bug() {
# substr(my $a, 0, 0) = (foo(), bar());
return $x + $y;
}
1;
scripts/fib.pl view on Meta::CPAN
sub fib($) {
my $x = shift;
return 1 if $x <= 1;
fib($x-1) + fib($x-2);
}
printf "fib(2)= %d, fib(3) = %d, fib(4) = %d\n", fib(2), fib(3), fib(4);
t/helper.pm view on Meta::CPAN
# Deparse can't distinguish 'and' from '&&' etc
%infix_map = qw(and && or ||);
my (%SEEN, %SEEN_STRENGTH);
# test a keyword that is a binary infix operator, like 'cmp'.
# $parens - "$a op $b" is deparsed as "($a op $b)"
# $strong - keyword is strong
sub open_data($)
{
my ($default_fn) = @_;
my $short_name = $ARGV[0] || $default_fn;
my $test_data = File::Spec->catfile(data_dir, $short_name);
open(my $data_fh, "<", $test_data) || die "Can't open $test_data: $!";
my $lineno;
# Skip to __DATA__
for ($lineno = 1; <$data_fh> !~ /__DATA__/; $lineno++) {
;
}
return ($data_fh, $lineno);
}
use constant MAX_CORE_ERROR_COUNT => 1;
my $error_count = 0;
sub testit_full($$$$$$)
{
my ($keyword, $expr, $expected_expr, $lexsub, $filename, $lineno) = @_;
$expected_expr //= $expr;
$SEEN{$keyword} = 1;
# lex=0: () = foo($a,$b,$c)
# lex=1: my ($a,$b); () = foo($a,$b,$c)
# lex=2: () = foo(my $a,$b,$c)
#for my $lex (0, 1, 2) {
t/helper.pm view on Meta::CPAN
is $got_expr, $expected_expr, $desc;
if (++$error_count >= MAX_CORE_ERROR_COUNT) {
done_testing;
exit $error_count;
}
}
is $got_expr, $expected_expr, $desc;
}
}
sub testit($$$)
{
my ($keyword, $expr, $expected_expr) = @_;
my ($pkg, $filename, $line) = caller;
testit_full($keyword, $expr, $expected_expr, 0, $filename, $line);
}
# for a given keyword, create a sub of that name, then
# deparse "() = $expr", and see if it matches $expected_expr
# test a keyword that is a binary infix operator, like 'cmp'.
# $parens - "$a op $b" is deparsed as "($a op $b)"
# $strong - keyword is strong
sub do_infix_keyword($$$$$$)
{
my ($keyword, $parens, $strong, $filename, $line, $min_version) = @_;
print "WOOT $min_version" if defined($min_version);
return if defined($min_version) && $] <= $min_version;
$SEEN_STRENGTH{$keyword} = $strong;
my $expr = "(\$a $keyword \$b)";
my $nkey = $infix_map{$keyword} // $keyword;
my $exp = "\$a $nkey \$b";
$exp = "($exp)" if $parens;
t/helper.pm view on Meta::CPAN
testit_full $keyword, "$keyword(\$a, \$b)", "$keyword(\$a, \$b);", 1, $filename, $line;
}
# test a keyword that is a standard op/function, like 'index(...)'.
# narg - how many args to test it with
# $parens - "foo $a, $b" is deparsed as "foo($a, $b)"
# $dollar - an extra '$_' arg will appear in the deparsed output
# $strong - keyword is strong
sub do_std_keyword($$$$$$$$)
{
my ($keyword, $narg, $parens, $dollar, $strong, $filename, $line, $min_version) = @_;
return if defined($min_version) && $] <= $min_version;
$SEEN_STRENGTH{$keyword} = $strong;
for my $core (0,1) { # if true, add CORE:: to keyword being deparsed
my @code;
for my $do_exp(0, 1) { # first create expr, then expected-expr
my @args = map "\$$_", (undef,"a".."z")[1..$narg];
t/helper.pm view on Meta::CPAN
? "($args)"
: @args ? " $args" : "";
push @code, (($core && !($do_exp && $strong)) ? "CORE::" : "")
. "$keyword$args";
}
# code[0]: to run; code[1]: expected
testit_full $keyword, $code[0], $code[1], 0, $filename, $line;
}
}
sub test_ops($)
{
my($filename) = @_;
my ($data_fh, $line) = open_data($filename);
while (<$data_fh>) {
$line ++;
chomp;
s/#.*//;
next unless /\S/;
my @fields = split;
t/testdata/P520.pm view on Meta::CPAN
# lexical subroutine
use feature 'lexical_subs';
no warnings "experimental::lexical_subs";
my sub f {}
print f();
####
# Elements of %# should not be confused with $#{ array }
() = ${#}{'foo'};
####
# [perl #121050] Prototypes with whitespace
sub _121050(\$ \$) { }
_121050($a,$b);
sub _121050empty( ) {}
() = _121050empty() + 1;
>>>>
_121050 $a, $b;
() = _121050empty + 1;
####
# ensure aelemfast works in the range -128..127 and that there's no
t/testdata/P522.pm view on Meta::CPAN
####
# $; [perl #123357]
$_ = $;;
do {
$;
};
####
# Ampersand calls and scalar context
# OPTIONS -P
package prototest;
sub foo($$);
foo(bar(),baz());
>>>>
package prototest;
&foo(scalar bar(), scalar baz());
####
# coderef2text and prototyped sub calls [perl #123435]
is 'foo', 'oo';
####
# prototypes with unary precedence
package prototest;
sub dollar($) {}
sub optdollar(;$) {}
sub optoptdollar(;;$) {}
sub splat(*) {}
sub optsplat(;*) {}
sub optoptsplat(;;*) {}
sub bar(_) {}
sub optbar(;_) {}
sub optoptbar(;;_) {}
sub plus(+) {}
sub optplus(;+) {}
sub optoptplus(;;+) {}
sub wack(\$) {}
sub optwack(;\$) {}
sub optoptwack(;;\$) {}
sub wackbrack(\[$]) {}
sub optwackbrack(;\[$]) {}
sub optoptwackbrack(;;\[$]) {}
dollar($a < $b);
optdollar($a < $b);
optoptdollar($a < $b);
splat($a < $b); # Some of these deparse with ‘&’; if that changes, just
optsplat($a < $b); # change the tests.
optoptsplat($a < $b);
bar($a < $b);
optbar($a < $b);
optoptbar($a < $b);
plus($a < $b);
t/testdata/P524.pm view on Meta::CPAN
####
# $; [perl #123357]
$_ = $;;
do {
$;
};
####
# Ampersand calls and scalar context
# OPTIONS -P
package prototest;
sub foo($$);
foo(bar(),baz());
>>>>
package prototest;
&foo(scalar bar(), scalar baz());
####
# coderef2text and prototyped sub calls [perl #123435]
is 'foo', 'oo';
####
# prototypes with unary precedence
package prototest;
sub dollar($) {}
sub optdollar(;$) {}
sub optoptdollar(;;$) {}
sub splat(*) {}
sub optsplat(;*) {}
sub optoptsplat(;;*) {}
sub bar(_) {}
sub optbar(;_) {}
sub optoptbar(;;_) {}
sub plus(+) {}
sub optplus(;+) {}
sub optoptplus(;;+) {}
sub wack(\$) {}
sub optwack(;\$) {}
sub optoptwack(;;\$) {}
sub wackbrack(\[$]) {}
sub optwackbrack(;\[$]) {}
sub optoptwackbrack(;;\[$]) {}
dollar($a < $b);
optdollar($a < $b);
optoptdollar($a < $b);
splat($a < $b); # Some of these deparse with ‘&’; if that changes, just
optsplat($a < $b); # change the tests.
optoptsplat($a < $b);
bar($a < $b);
optbar($a < $b);
optoptbar($a < $b);
plus($a < $b);
t/testdata/P526.pm view on Meta::CPAN
####
# $; [perl #123357]
$_ = $;;
do {
$;
};
####
# Ampersand calls and scalar context
# OPTIONS -P
package prototest;
sub foo($$);
foo(bar(),baz());
>>>>
package prototest;
&foo(scalar bar(), scalar baz());
####
# coderef2text and prototyped sub calls [perl #123435]
is 'foo', 'oo';
####
# prototypes with unary precedence
package prototest;
sub dollar($) {}
sub optdollar(;$) {}
sub optoptdollar(;;$) {}
sub splat(*) {}
sub optsplat(;*) {}
sub optoptsplat(;;*) {}
sub bar(_) {}
sub optbar(;_) {}
sub optoptbar(;;_) {}
sub plus(+) {}
sub optplus(;+) {}
sub optoptplus(;;+) {}
sub wack(\$) {}
sub optwack(;\$) {}
sub optoptwack(;;\$) {}
sub wackbrack(\[$]) {}
sub optwackbrack(;\[$]) {}
sub optoptwackbrack(;;\[$]) {}
dollar($a < $b);
optdollar($a < $b);
optoptdollar($a < $b);
splat($a < $b); # Some of these deparse with ‘&’; if that changes, just
optsplat($a < $b); # change the tests.
optoptsplat($a < $b);
bar($a < $b);
optbar($a < $b);
optoptbar($a < $b);
plus($a < $b);
t/unit/02-node.t view on Meta::CPAN
use rlib '../../lib';
use Test::More;
note( "Testing B::DeparseTree B::DeparseTree::TreeNode" );
BEGIN {
use_ok( 'B::DeparseTree::TreeNode' );
}
package B::DeparseTree::TreeNodeTest;
sub new($) {
my ($class) = @_;
bless {}, $class;
}
sub combine2str($$$) {
my ($self, $sep, $texts) = @_;
join($sep, @$texts);
}
my $deparse = __PACKAGE__->new();
my $node = B::DeparseTree::TreeNode->new('op', $deparse, ['X'], 'test', {});
Test::More::cmp_ok $node->{'text'}, 'eq', 'X';
Test::More::note ( "parens_test() testing" );
( run in 0.429 second using v1.01-cache-2.11-cpan-65fba6d93b7 )