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 = $kid->sibling) {
328	0						walkoptree_simple($kid, $callback, $data);
329	0						}
330							}
331							}
332
333							=item walkoptree_filtered($op, \&filter, \&callback, [$data])
334
335							This is much the same as C<walkoptree_simple>, but will only call the
336							callback if the C<filter> returns true. The C<filter> is passed the
337							op in question as a parameter; the C<opgrep> function is fantastic
338							for building your own filters.
339
340							=cut
341
342							sub walkoptree_filtered {
343	0			0	1		my ($op, $filter, $callback, $data) = @_;
344	0	0					($file, $line) = ($op->file, $op->line) if $op->isa("B::COP");
345	0	0					$callback->($op,$data) if $filter->($op);
346	0	0	0				if ($$op && ($op->flags & OPf_KIDS)) {
347	0						my $kid;
348							for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
349	0						walkoptree_filtered($kid, $filter, $callback, $data);
350	0						}
351							}
352							}
353
354							=item walkallops_simple(\&callback, [$data])
355
356							This combines C<walkoptree_simple> with C<all_roots> and C<anon_subs>
357							to examine every op in the program. C<$B::Utils::sub> is set to the
358							subroutine name if you're in a subroutine, C<__MAIN__> if you're in
359							the main program and C<__ANON__> if you're in an anonymous subroutine.
360
361							=cut
362
363							our $sub;
364
365							sub walkallops_simple {
366	0			0	1		my ($callback, $data) = @_;
367	0						_init();
368	0						for $sub (keys %roots) {
369	0						walkoptree_simple($roots{$sub}, $callback, $data);
370							}
371	0						$sub = "__ANON__";
372	0						for (@anon_subs) {
373	0						walkoptree_simple($_->{root}, $callback, $data);
374							}
375							}
376
377							=item walkallops_filtered(\&filter, \&callback, [$data])
378
379							Same as above, but filtered.
380
381							=cut
382
383							sub walkallops_filtered {
384	0			0	1		my ($filter, $callback, $data) = @_;
385	0						_init();
386	0						for $sub (keys %roots) {
387	0						walkoptree_filtered($roots{$sub}, $filter, $callback, $data);
388							}
389	0						$sub = "__ANON__";
390	0						for (@anon_subs) {
391	0						walkoptree_filtered($_->{root}, $filter, $callback, $data);
392							}
393							}
394
395							=item carp(@args)
396
397							=item croak(@args)
398
399							Warn and die, respectively, from the perspective of the position of the op in
400							the program. Sounds complicated, but it's exactly the kind of error reporting
401							you expect when you're grovelling through an op tree.
402
403							=cut
404
405							sub _preparewarn {
406	0			0			my $args = join '', @_;
407	0	0					$args = "Something's wrong " unless $args;
408	0	0					$args .= " at $file line $line.\n" unless substr($args, length($args) -1) eq "\n";
409							}
410
411	0			0	1		sub carp (@) { CORE::die(preparewarn(@_)) }
412	0			0	1		sub croak (@) { CORE::warn(preparewarn(@_)) }
413
414							=item opgrep(\%conditions, @ops)
415
416							Returns the ops which meet the given conditions. The conditions should be
417							specified like this:
418
419							@barewords = opgrep(
420							{ name => "const", private => OPpCONST_BARE },
421							@ops
422							);
423
424							You can specify alternation by giving an arrayref of values:
425
426							@svs = opgrep ( { name => ["padsv", "gvsv"] }, @ops)
427
428							And you can specify inversion by making the first element of the arrayref
429							a "!". (Hint: if you want to say "anything", say "not nothing": C<["!"]>)
430
431							You may also specify the conditions to be matched in nearby ops.
432
433							walkallops_filtered(
434							sub { opgrep( {name => "exec",
435							next => {
436							name => "nextstate",
437							sibling => { name => [qw(! exit warn die)] }
438							}
439							}, @_)},
440							sub {
441							carp("Statement unlikely to be reached");
442							carp("\t(Maybe you meant system() when you said exec()?)\n");
443							}
444							)
445
446							Get that?
447
448							Here are the things that can be tested:
449
450							name targ type seq flags private pmflags pmpermflags
451							first other last sibling next pmreplroot pmreplstart pmnext
452
453							=cut
454
455							sub opgrep {
456	0			0	1		my ($cref, @ops) = @_;
457	0						my %conds = %$cref;
458	0						my @rv = ();
459	0						my $o;
460	0						OPLOOP: for $o (@ops) {
461							# First, let's skim off ops of the wrong type.
462	0						for (qw(first other last pmreplroot pmreplstart pmnext pmflags pmpermflags)) {
463	0	0	0				next OPLOOP if exists $conds{$_} and !$o->can($_);
464							}
465
466	0						for my $test (qw(name targ type seq flags private pmflags pmpermflags)) {
467	0	0					next unless exists $conds{$test};
468	0	0	0				next OPLOOP unless ref $o and $o->can($test);
469	0	0					if (!ref $conds{$test}) {
470	0	0					next OPLOOP if $o->$test ne $conds{$test};
471							} else {
472	0	0					if ($conds{$test}[0] eq "!") {
473	0						my @conds = @{$conds{$test}}; shift @conds;
	0
	0
474	0	0					next OPLOOP if grep {$o->$test eq $_} @conds;
	0
475							} else {
476	0	0					next OPLOOP unless grep {$o->$test eq $_} @{$conds{$test}};
	0
	0
477							}
478							}
479							}
480
481	0						for my $neighbour (qw(first other last sibling next pmreplroot pmreplstart pmnext)) {
482	0	0					next unless exists $conds{$neighbour};
483							# We know it can, because we tested that above
484							# Recurse, recurse!
485	0	0					next OPLOOP unless opgrep($conds{$neighbour}, $o->$neighbour);
486							}
487
488	0						push @rv, $_;
489							}
490	0						return @rv;
491							}
492
493							1;
494
495							=back
496
497							=head2 EXPORT
498
499							None by default.
500
501							=head1 AUTHOR
502
503							Simon Cozens, C<simon@cpan.org>
504
505							=head1 TODO
506
507							I need to add more Fun Things, and possibly clean up some parts where
508							the (previous/parent) algorithm has catastrophic cases, but it's more
509							important to get this out right now than get it right.
510
511							=head1 SEE ALSO
512
513							L<B>, L<B::Generate>.
514
515							=cut
516