File Coverage

blib/lib/B/Utils.pm
Criterion Covered Total %
statement 24 187 12.8
branch 0 82 0.0
condition 0 72 0.0
subroutine 7 29 24.1
pod 10 11 90.9
total 41 381 10.8


line stmt bran cond sub pod time code
1             package B::Utils;
2              
3 1     1   22 use 5.006;
  1         9  
  1         9  
4 1     1   15 use strict;
  1         10  
  1         16  
5 1     1   17 use warnings;
  1         8  
  1         17  
6 1     1   110 use vars '$DEBUG';
  1         11  
  1         20  
7             our @EXPORT_OK = qw(all_starts all_roots anon_subs
8             walkoptree_simple walkoptree_filtered
9             walkallops_simple walkallops_filtered
10             carp croak
11             opgrep
12             );
13             sub import {
14 1     1   12   my $pack = shift;
15 1         10   my @exports = @_;
16 1         11   my $caller = caller;
17 1         11   my %EOK = map {$_ => 1} @EXPORT_OK;
  10         103  
18 1         72   for (@exports) {
19 0 0             unless ($EOK{$_}) {
20 0                 require Carp;
21 0                 Carp::croak(qq{"$_" is not exported by the $pack module});
22                 }
23 1     1   15     no strict 'refs';
  1         10  
  1         14  
24 0               *{"$caller\::$_"} = \&{"$pack\::$_"};
  0            
  0            
25               }
26             }
27              
28             our $VERSION = '0.05';
29              
30 1     1   16 use B qw(main_start main_root walksymtable class OPf_KIDS);
  1         9  
  1         20  
31              
32             my (%starts, %roots, @anon_subs);
33              
34             our @bad_stashes = qw(B Carp Exporter warnings Cwd Config CORE blib strict DynaLoader vars XSLoader AutoLoader base);
35              
36             sub null {
37 0     0 0       my $op = shift;
38 0               class( $op ) eq 'NULL';
39             }
40              
41             { my $_subsdone=0;
42             sub _init { # To ensure runtimeness.
43 0 0   0         return if $_subsdone;
44 0               %starts = ( '__MAIN__' => main_start() );
45 0               %roots = ( '__MAIN__' => main_root() );
46                 walksymtable(\%main::,
47                             '_push_starts',
48                             sub {
49 0 0   0                         return if scalar grep {$_[0] eq $_."::"} @bad_stashes;
  0            
50 0                               1;
51                             }, # Do not eat our own children!
52 0                           '');
53 0               push @anon_subs, { root => $_->ROOT, start => $_->START}
54 0                   for grep { class($_) eq "CV" } B::main_cv->PADLIST->ARRAY->ARRAY;
  0            
55 0               $_subsdone=1;
56             }
57             }
58              
59             =head1 NAME
60            
61             B::Utils - Helper functions for op tree manipulation
62            
63             =head1 SYNOPSIS
64            
65             use B::Utils;
66            
67             =head1 DESCRIPTION
68            
69             These functions make it easier to manipulate the op tree.
70            
71             =head1 FUNCTIONS
72            
73             =over 3
74            
75             =item C<all_starts>
76            
77             =item C<all_roots>
78            
79             Returns a hash of all of the starting ops or root ops of optrees, keyed
80             to subroutine name; the optree for main program is simply keyed to C<__MAIN__>.
81            
82             B<Note>: Certain "dangerous" stashes are not scanned for subroutines:
83             the list of such stashes can be found in C<@B::Utils::bad_stashes>. Feel
84             free to examine and/or modify this to suit your needs. The intention is
85             that a simple program which uses no modules other than C<B> and
86             C<B::Utils> would show no addition symbols.
87            
88             This does B<not> return the details of ops in anonymous subroutines
89             compiled at compile time. For instance, given
90            
91             $a = sub { ... };
92            
93             the subroutine will not appear in the hash. This is just as well, since
94             they're anonymous... If you want to get at them, use...
95            
96             =item C<anon_subs()>
97            
98             This returns an array of hash references. Each element has the keys
99             "start" and "root". These are the starting and root ops of all of
100             the anonymous subroutines in the program.
101            
102             =cut
103              
104 0     0 1   sub all_starts { _init(); return %starts; }
  0            
105 0     0 1   sub all_roots { _init(); return %roots; }
  0            
106 0     0 1   sub anon_subs { _init(); return @anon_subs }
  0            
107              
108             sub B::GV::_push_starts {
109 0     0         my $name = $_[0]->STASH->NAME."::".$_[0]->SAFENAME;
110 0 0             return unless ${$_[0]->CV};
  0            
111 0               my $cv = $_[0]->CV;
112              
113 0 0 0           if ($cv->PADLIST->can("ARRAY") and $cv->PADLIST->ARRAY and $cv->PADLIST->ARRAY->can("ARRAY")) {
      0        
114 0                   push @anon_subs, { root => $_->ROOT, start => $_->START}
115 0                       for grep { class($_) eq "CV" } $cv->PADLIST->ARRAY->ARRAY;
  0            
116                 }
117 0 0 0           return unless ${$cv->START} and ${$cv->ROOT};
  0            
  0            
118 0               $starts{$name} = $cv->START;
119 0               $roots{$name} = $cv->ROOT;
120             };
121              
122 0     0     sub B::SPECIAL::_push_starts{}
123              
124             =item C<< $op->oldname >>
125            
126             Returns the name of the op, even if it is currently optimized to null.
127             This helps you understand the stucture of the op tree.
128            
129             =cut
130              
131             sub B::OP::oldname {
132 0 0 0 0         return substr(B::ppname($_[0]->targ),3) if $_[0]->name eq "null" and $_[0]->targ;
133 0               return $_[0]->name;
134             }
135              
136             =item C<< $op->kids >>
137            
138             Returns an array of all this op's non-null children, in order.
139            
140             =cut
141              
142             sub B::OP::kids {
143 0     0         my $op = shift;
144 0               my @rv;
145 0 0             if (class($op) eq "LISTOP") {
146 0                   $op = $op->first;
147 0   0               push @rv, $op while $op->can("sibling") and $op = $op->sibling and $$op;
      0        
148 0                   return @rv;
149                 }
150 0 0 0           push @rv, $op->first if $op->can("first") and $op->first and ${$op->first};
  0   0        
151 0 0 0           push @rv, $op->last if $op->can("last") and $op->last and ${$op->last};
  0   0        
152 0 0 0           push @rv, $op->other if $op->can("other") and $op->other and ${$op->other};
  0   0        
153 0               return @rv;
154             }
155              
156             =item C<< $op->parent >>
157            
158             Returns the parent node in the op tree, if possible. Currently "possible" means
159             "if the tree has already been optimized"; that is, if we're during a C<CHECK>
160             block. (and hence, if we have valid C<next> pointers.)
161            
162             In the future, it may be possible to search for the parent before we have the
163             C<next> pointers in place, but it'll take me a while to figure out how to do
164             that.
165            
166             =cut
167              
168             sub B::OP::parent {
169 0     0         my $target = shift;
170 0 0             printf( "parent %s %s=(0x%07x)\n",
171             B::class( $target),
172             $target->oldname,
173             $$target )
174             if $DEBUG;
175              
176 0 0             die "I'm not sure how to do this yet. I'm sure there is a way. If you know, please email me."
177                     if (!$target->seq);
178              
179 0               my (%deadend, $search_kids);
180                 $search_kids = sub {
181 0   0 0             my $node = shift || return undef;
182            
183 0 0 0       printf( "Searching from %s %s=(0x%07x)\n",
184             class($node)||'?',
185             $node->oldname,
186             $$node )
187             if $DEBUG;
188            
189             # Go up a level if we've got stuck, and search (for the same
190             # $target) from a higher vantage point.
191 0 0                 if ( exists $deadend{ $node } )
192             {
193 0 0         printf( " search parent %s %s=(0x%07x)\n",
194             B::class( $node ),
195             $node->oldname,
196             $$node )
197             if $DEBUG;
198 0           return $search_kids->( $node->parent );
199             }
200            
201             # Test the immediate children, but only children we haven't visited
202             # already.
203 0           my @new_kids = ( grep !$deadend{ $_ },
204             $node->kids );
205 0 0         if ( scalar grep $$_ == $$target, @new_kids )
206             {
207 0           return $node;
208             }
209            
210             # Recurse and examine each child, in turn.
211 0 0 0       print( " search kids\n"
212             . join( "",
213             map sprintf( " %s %s=(0x%07x)\n",
214             B::class( $_ ),
215             $_->oldname,
216             $$_ ),
217             @new_kids ) )
218             if $DEBUG and @new_kids;
219            
220 0           for ( @new_kids )
221             {
222 0           my $x = $search_kids->( $_ );
223 0 0         return $x if $x;
224             }
225            
226             # Not in this subtree.
227 0                   $deadend{$node}++;
228 0                   return undef;
229 0               };
230 0               my $start = $target;
231                 
232             # Skip to the farthest sibling and make a list of each with the most
233             # recent at the beginning of the list.
234                 
235             # I am planning ahead for the day when it turns out that the parent
236             # cannot be found in the last sibling somewhere. Maybe it is just a
237             # null? I would like to be able to back track up the tree to find a
238             # ->next node that will bring us to northeast of (or even better,
239             # directly to) the parent.
240 0               my @siblings = $start;
241 0   0           while ( $start and
  0            
242             ${$start->sibling} )
243                 {
244 0           $start = $start->sibling;
245 0           unshift @siblings, $start;
246 0 0 0       printf( "->sibling %s %s=(0x%07x)\n",
247             class($start)||'null',
248             $start->oldname,
249             $$start )
250             if $DEBUG;
251                 }
252                 
253             # Now search each sibling as noted from above.
254 0               for $start ( @siblings )
255                 {
256 0           my $next = $start;
257 0           while ( $$next )
258             {
259 0 0         printf( "->next %s %s=(0x%07x)\n",
260             B::class( $next ),
261             $next->oldname,
262             $$next )
263             if $DEBUG;
264            
265 0           my $result = $search_kids->( $next );
266 0 0         return $result if $result;
267             }
268             continue
269             {
270 0           $next = $next->next;
271             }
272                 }
273                 
274             # Having reached here... I give up?
275 0               undef;
276             }
277              
278             =item C<< $op->previous >>
279            
280             Like C<< $op->next >>, but not quite.
281            
282             =cut
283              
284             sub B::OP::previous {
285 0     0         my $target = shift;
286 0               my $start = $target;
287 0               my (%deadend, $search);
288                 $search = sub {
289 0   0 0             my $node = shift || die;
290 0 0                 return $search->(find_parent($node)) if exists $deadend{$node};
291 0 0                 return $node if $node->{next}==$target;
292             # Recurse
293 0                   my $x;
294 0   0               ($_->next == $target and return $_) for $node->kids;
  0            
295 0   0               defined($x = $search->($_)) and return $x for $node->{kids};
  0            
296              
297             # Not in this subtree.
298 0                   $deadend{$node}++;
299 0                   return undef;
300 0              };
301 0              my $result;
302 0   0          $result = $search->($start) and return $result
303                     while $start = $start->next;
304             }
305              
306             =item walkoptree_simple($op, \&callback, [$data])
307            
308             The C<B> module provides various functions to walk the op tree, but
309             they're all rather difficult to use, requiring you to inject methods
310             into the C<B::OP> class. This is a very simple op tree walker with
311             more expected semantics.
312            
313             All the C<walk> functions set C<B::Utils::file> and C<B::Utils::line>
314             to the appropriate values of file and line number in the program
315             being examined.
316            
317             =cut
318              
319             our ($file, $line) = ("__none__",0);
320              
321             sub walkoptree_simple {
322 0     0 1       my ($op, $callback, $data) = @_;
323 0 0             ($file, $line) = ($op->file, $op->line) if $op->isa("B::COP");
324 0               $callback->($op,$data);
325 0 0 0           if ($$op && ($op->flags & OPf_KIDS)) {
326 0                   my $kid;
327                     for ($kid = $op->first; $$kid; $kid