File Coverage

lib/B/DeparseTree/TreeNode.pm
Criterion Covered Total %
statement 54 109 49.5
branch 21 58 36.2
condition 5 14 35.7
subroutine 9 13 69.2
pod 0 4 0.0
total 89 198 44.9


line stmt bran cond sub pod time code
1             # The underlying node structure of the abstract code tree built
2             # that is built.
3             # Copyright (c) 2015, 2018 Rocky Bernstein
4 8     8   49 use strict; use warnings;
  8     8   17  
  8         218  
  8         46  
  8         14  
  8         290  
5             package B::DeparseTree::TreeNode;
6 8     8   42 use Carp;
  8         14  
  8         414  
7 8     8   45 use Config;
  8         14  
  8         319  
8             my $is_cperl = $Config::Config{usecperl};
9 8     8   5167 use Data::Printer;
  8         315678  
  8         61  
10              
11 8     8   5381 use Hash::Util qw[ lock_hash ];
  8         22320  
  8         55  
12              
13             # A custom Data::Printer for a TreeNode object
14             sub _data_printer {
15 0     0   0 my ($self, $properties) = @_;
16 0         0 my $indent = "\n ";
17 0         0 my $subindent = $indent . ' ';
18 0         0 my $msg = "B::DeparseTree::TreeNode {";
19 0         0 foreach my $field (
20             qw(addr child_pos cop fmt indexes maybe_parens op other_ops
21             omit_next_semicolon_position prev_expr
22             parent text texts type)) {
23 0 0       0 next if not exists $self->{$field};
24 0         0 my $data = $self->{$field};
25 0 0       0 next if not defined $data;
26 0         0 $msg .= sprintf("%s%-10s:\t", $indent, $field);
27 0 0 0     0 if ($field eq 'addr' or $field eq 'parent') {
    0 0        
    0          
    0          
    0          
    0          
28 0         0 $msg .= sprintf("0x%x", $data);
29             } elsif ($field eq 'cop') {
30 0 0       0 if (defined $data) {
31 0         0 $msg .= sprintf("%s:%s", $data->file, $data->line);
32 0 0       0 $msg .= ", " . $data->name if $data->can("name");
33             }
34             } elsif ($field eq 'indexes') {
35 0         0 my $str = np @{$data};
  0         0  
36 0         0 my @lines = split(/\n/, $str);
37 0 0       0 if (@lines < 4) {
38 0         0 $str = sprintf("[%s]", join(", ", @{$data}));
  0         0  
39             } else {
40 0         0 $str = join($subindent, @lines);
41             }
42 0         0 $msg .= $str;
43             } elsif ($field eq 'op') {
44 0 0       0 $msg .= $data->name . ', ' if $data->can("name");
45 0         0 $msg .= $data;
46             } elsif ($field eq 'prev_expr') {
47             $msg .= sprintf("B::DeparseTree::TreeNode 0x%x %s",
48 0         0 $data->{addr}, $data->{type});
49             } elsif ($field eq 'texts' or $field eq 'other_ops') {
50 0 0       0 if (!@$data) {
51 0         0 $msg .= '[]';
52             } else {
53 0         0 $msg .= '[';
54 0         0 my $i=0;
55 0         0 foreach my $item (@$data) {
56 0         0 $msg .= sprintf("%s[%d]: ", $subindent, $i++);
57 0 0       0 if (ref($item) eq 'B::DeparseTree::TreeNode') {
58             $msg .= sprintf("B::DeparseTree::TreeNode 0x%x %s",
59 0         0 $item->{addr}, $item->{type});
60             } else {
61 0         0 $msg .= sprintf("%s", $item);
62             }
63             }
64 0         0 $msg .= $indent . ']';
65             }
66             } else {
67 0         0 $msg .= np $data;
68             }
69             }
70 0         0 $msg .= "\n}";
71 0         0 return $msg;
72             };
73              
74             # Set of unary precedences
75             our %UNARY_PRECEDENCES = (
76             4 => 1, # right not
77             16 => 'sub, %, @', # "sub", "%", "@'
78             21 => '~', # steal parens (see maybe_parens_unop)
79             );
80              
81             unless ($is_cperl) {
82             lock_hash %UNARY_PRECEDENCES;
83             }
84              
85              
86             our $VERSION = '3.2.0';
87             our @ISA = qw(Exporter);
88             our @EXPORT = qw(
89             new($$$$)
90             parens_test($$$)
91             %UNARY_PRECEDENCES
92             update_other_ops($$)
93             );
94              
95             =head2 Node structure
96              
97             Fields in a node structure:
98              
99             =over
100              
101             *item B
102              
103             The string name for the node. It can be used to determine the overall
104             structure. For example a 'binop' node will have a I with a node
105             left-hand side, the string operation name and a I right-hand
106             side. Right now the type names are a little funky, but over time I
107             hope these will less so.
108              
109             * item B (optional)
110              
111             A string indicating how to separate the the strings extracted from the
112             C field. The field is subject to format expansion. In particular
113             tt can have '%;' in it to indicate we are separating statements.
114             the body.
115              
116             * item B
117              
118             A reference to a list containing either:
119              
120             =over
121              
122             * item a tuple with a strings, and a op address
123             * a DeparseTreee::Node object
124              
125             =back
126              
127             * item B
128              
129             Text representation of the node. Eventually this will diasppear
130             and, you'll use one of the node-to-string conversion routines.
131              
132             * item B
133              
134             If this node is embedded in the parent above, whether we need to add parenthesis.
135             The keys is a hash ref hash reference
136              
137             =over
138              
139             =item B
140              
141             A number passed from the parent indicating its precedence context that
142             the expression is embedded it.
143              
144             =item B
145              
146             A number as determined by the operator at this level.
147              
148             =item B
149              
150             'true' if we should to add parenthesis based on I and
151             I values; '' if not. We don't nest equal precedence
152             for unuary ops. The unary op precedence is given by
153             UNARY_OP_PRECEDENCE
154              
155             =back
156              
157             =back
158             =cut
159              
160              
161             sub parens_test($$$)
162             {
163 3130     3130 0 5326 my ($obj, $cx, $prec) = @_;
164             return ($prec < $cx
165             # Unary ops which nest just fine
166 3130   66     14490 or ($prec == $cx && !exists $UNARY_PRECEDENCES{$cx}));
167             }
168              
169             sub new($$$$$)
170             {
171 26015     26015 0 46129 my ($class, $op, $deparse, $data, $sep, $type, $opts) = @_;
172 26015         30450 my $addr = -1;
173 26015 100       46312 if (ref($op)) {
174 23408 50       37873 if (ref($op) eq 'B::DeparseTree') {
175             # use Enbugger 'trepan'; Enbugger->stop;
176 0         0 Carp::confess("Rocky got the order of \$self, and \$op confused again");
177 0         0 $addr = -2;
178             } else {
179 23408         28351 eval { $addr = $$op };
  23408         32329  
180             }
181             }
182 26015         92844 my $self = bless {
183             addr => $addr,
184             op => $op,
185             deparse => $deparse,
186             type => $type,
187             }, $class;
188              
189 26015 100       46615 $self->{sep} = $sep if defined $sep;
190 26015 100       43190 if (ref($data)) {
    50          
191             # Passed in a ref ARRAY
192 12236         20042 $self->{texts} = $data;
193 12236 100       18772 $self->{text} = $deparse->combine2str($sep, $data) if defined $sep;
194             } elsif (defined $data) {
195             # Passed in a string
196 13779         24287 $self->{text} = $data;
197             } else {
198             # Leave {text} and {texts} uninitialized
199             }
200              
201 26015         39648 foreach my $optname (qw(child_pos
202             maybe_parens
203             omit_next_semicolon
204             other_ops
205             parent_ops
206             position
207             prev_expr)) {
208 182105 100       267300 $self->{$optname} = $opts->{$optname} if $opts->{$optname};
209             }
210 26015 100       40939 if (exists $self->{other_ops}) {
211 1313         2198 my $ary = $self->{other_ops};
212 1313 50       2786 unless (ref $ary eq 'ARRAY') {
213 0         0 Carp::confess("expecting other_ops to be a ref ARRAY; is $ary");
214             }
215 1313         1829 my $position = 0;
216 1313         2449 for my $other_addr (@$ary) {
217 1944 50       3951 if ($other_addr == $addr) {
218 0         0 Carp::confess("other_ops contains my address $addr at position $position");
219             }
220 1944         3128 $position++;
221             }
222             }
223 26015 100       38856 if ($opts->{maybe_parens}) {
224 1564         2373 my ($obj, $context, $precedence) = @{$opts->{maybe_parens}};
  1564         3666  
225 1564         3878 my $parens = parens_test($obj, $context, $precedence);
226             $self->{maybe_parens} = {
227             context => $context,
228             precedence => $precedence,
229 1564 100       9132 force => $obj->{'parens'},
230             parens => $parens ? 'true' : ''
231             };
232 1564 50 33     4293 $self->{text} = "($self->{text})" if exists $self->{text} and $parens;
233             }
234 26015         72033 return $self;
235             }
236              
237             # Possibly add () around $text depending on precedence $prec and
238             # context $cx. We return a string.
239             sub maybe_parens($$$$)
240             {
241 0     0 0 0 my($self, $info, $cx, $prec) = @_;
242 0 0       0 if (parens_test($info, $cx, $prec)) {
243 0         0 $info->{text} = $self->combine('', "(", $info->{text}, ")");
244             # In a unop, let parent reuse our parens; see maybe_parens_unop
245 0 0       0 if ($cx == 16) {
246 0         0 $info->{parens} = 'reuse';
247             } else {
248 0         0 $info->{parens} = 'true';
249             }
250 0         0 return $info->{text};
251             } else {
252 0         0 $info->{parens} = '';
253 0         0 return $info->{text};
254             }
255             }
256              
257             # Update $self->{other_ops} to add $info
258             sub update_other_ops($$)
259             {
260 5177     5177 0 8434 my ($self, $info) = @_;
261 5177   100     15452 $self->{other_ops} ||= [];
262 5177         6803 my $other_ops = $self->{other_ops};
263 5177         6049 push @{$other_ops}, $info;
  5177         8065  
264 5177         8981 $self->{other_ops} = $other_ops;
265             }
266              
267             # Demo code
268             unless(caller) {
269             my $old_pkg = __PACKAGE__;
270             package B::DeparseTree::TreeNodeDemo;
271             sub new($) {
272 0     0     my ($class) = @_;
273 0           bless {}, $class;
274             }
275             sub combine2str($$$) {
276 0     0     my ($self, $sep, $data) = @_;
277 0           join($sep, @$data);
278             }
279             my $deparse = __PACKAGE__->new();
280             my $node = $old_pkg->new('op', $deparse, ['X'], 'test', {});
281             print $node->{text}, "\n";
282             }
283             1;