6
our @EXPORT_OK = qw(all_starts all_roots anon_subs
7
walkoptree_simple walkoptree_filtered
8
walkallops_simple walkallops_filtered
16
my %EOK = map {$_ => 1} @EXPORT_OK;
20
Carp::croak(qq{"$_" is not exported by the $pack module});
23
*{"$caller\::$_"} = \&{"$pack\::$_"};
27
our $VERSION = '0.04_01'; # 0.04 with some Schwern patches
29
use B qw(main_start main_root walksymtable class OPf_KIDS);
31
my (%starts, %roots, @anon_subs);
33
our @bad_stashes = qw(B Carp DB Exporter warnings Cwd Config CORE blib strict DynaLoader vars XSLoader AutoLoader base);
36
sub _init { # To ensure runtimeness.
38
%starts = ( '__MAIN__' => main_start() );
39
%roots = ( '__MAIN__' => main_root() );
40
walksymtable(\%main::,
43
return if scalar grep {$_[0] eq $_."::"} @bad_stashes;
45
}, # Do not eat our own children!
47
push @anon_subs, { root => $_->ROOT, start => $_->START}
48
for grep { class($_) eq "CV" } B::main_cv->PADLIST->ARRAY->ARRAY;
55
B::Utils - Helper functions for op tree manipulation
63
These functions make it easier to manipulate the op tree.
73
Returns a hash of all of the starting ops or root ops of optrees, keyed
74
to subroutine name; the optree for main program is simply keyed to C<__MAIN__>.
76
B<Note>: Certain "dangerous" stashes are not scanned for subroutines:
77
the list of such stashes can be found in C<@B::Utils::bad_stashes>. Feel
78
free to examine and/or modify this to suit your needs. The intention is
79
that a simple program which uses no modules other than C<B> and
80
C<B::Utils> would show no addition symbols.
82
This does B<not> return the details of ops in anonymous subroutines
83
compiled at compile time. For instance, given
87
the subroutine will not appear in the hash. This is just as well, since
88
they're anonymous... If you want to get at them, use...
92
This returns an array of hash references. Each element has the keys
93
"start" and "root". These are the starting and root ops of all of
94
the anonymous subroutines in the program.
98
sub all_starts { _init(); return %starts; }
99
sub all_roots { _init(); return %roots; }
100
sub anon_subs { _init(); return @anon_subs }
102
sub B::GV::_push_starts {
103
my $name = $_[0]->STASH->NAME."::".$_[0]->SAFENAME;
104
return unless ${$_[0]->CV};
107
if ($cv->PADLIST->can("ARRAY") and $cv->PADLIST->ARRAY and $cv->PADLIST->ARRAY->can("ARRAY")) {
108
push @anon_subs, { root => $_->ROOT, start => $_->START}
109
for grep { class($_) eq "CV" } $cv->PADLIST->ARRAY->ARRAY;
111
return unless ${$cv->START} and ${$cv->ROOT};
112
$starts{$name} = $cv->START;
113
$roots{$name} = $cv->ROOT;
116
sub B::SPECIAL::_push_starts{}
118
=item C<< $op->oldname >>
120
Returns the name of the op, even if it is currently optimized to null.
121
This helps you understand the stucture of the op tree.
126
return substr(B::ppname($_[0]->targ),3) if $_[0]->name eq "null" and $_[0]->targ;
130
=item C<< $op->kids >>
132
Returns an array of all this op's non-null children, in order.
140
foreach my $type (qw(first last other)) {
141
my $kid = $op->$type();
142
next if !$kid || class($kid) eq 'NULL';
143
if( $kid->name eq 'null' ) {
144
push @rv, $kid->kids;
152
foreach my $more_op (@rv) {
153
my $next_op = $more_op;
154
while( $next_op->can("sibling") ) {
155
$next_op = $next_op->sibling;
156
last if !$next_op || class($next_op) eq 'NULL';
157
if( $next_op->name eq 'null' ) {
158
push @more_rv, $next_op->kids;
161
push @more_rv, $next_op;
166
return @rv, @more_rv;
170
=item C<< $op->first >>
172
=item C<< $op->last >>
174
=item C<< $op->other >>
176
Normally if you call first, last or other on anything which is not an
177
UNOP, BINOP or LOGOP respectivly it will die. This leads to lots of
180
$op->first if $op->can('first');
182
B::Utils provides every op with first, last and other methods which
183
will simply return nothing if it isn't relevent.
187
foreach my $type (qw(first last other)) {
189
*{'B::OP::'.$type} = sub {
191
if( $op->can("SUPER::$type") ) {
201
=item C<< $op->parent >>
203
Returns the parent node in the op tree, if possible. Currently "possible" means
204
"if the tree has already been optimized"; that is, if we're during a C<CHECK>
205
block. (and hence, if we have valid C<next> pointers.)
207
In the future, it may be possible to search for the parent before we have the
208
C<next> pointers in place, but it'll take me a while to figure out how to do
213
# This is probably the most efficient algorithm for finding the parent given the
214
# next node in execution order and the children of an op. You'll be glad to hear
215
# that it doesn't do a full search of the tree from the root, but it searches
216
# ever-higher subtrees using a breathtaking double recursion. It works on the
217
# principle that the C<next> pointer will always point to an op further northeast
218
# on the tree, and hence will be heading upwards toward the parent.
222
die "I'm not sure how to do this yet. I'm sure there is a way. If you know, please email me."
224
my (%deadend, $search);
226
my $node = shift || return undef;
228
# Go up a level if we've got stuck, and search (for the same
229
# $target) from a higher vantage point.
230
return $search->($node->parent) if exists $deadend{$node};
232
# Test the immediate children
233
return $node if scalar grep {$_ == $target} $node->kids;
237
defined($x = $search->($_)) and return $x for $node->kids;
239
# Not in this subtree.
245
$result = $search->($start) and return $result while $start = $start->next;
246
return $search->($start);
249
=item C<< $op->previous >>
251
Like C<< $op->next >>, but not quite.
255
sub B::OP::previous {
258
my (%deadend, $search);
260
my $node = shift || die;
261
return $search->(find_parent($node)) if exists $deadend{$node};
262
return $node if $node->{next}==$target;
265
($_->next == $target and return $_) for $node->kids;
266
defined($x = $search->($_)) and return $x for $node->{kids};
268
# Not in this subtree.
273
$result = $search->($start) and return $result
274
while $start = $start->next;
277
=item walkoptree_simple($op, \&callback, [$data])
279
The C<B> module provides various functions to walk the op tree, but
280
they're all rather difficult to use, requiring you to inject methods
281
into the C<B::OP> class. This is a very simple op tree walker with
282
more expected semantics.
284
The &callback is called at each op with the op itself passed in as the
285
first argument and any additional $data as the second.
287
All the C<walk> functions set C<$B::Utils::file> and C<$B::Utils::line>
288
to the appropriate values of file and line number in the program
289
being examined. Since only COPs contain this information it may be
290
unavailable in the first few callback calls.
296
# Make sure we reset $file and $line between runs.
297
sub walkoptree_simple {
298
($file, $line) = ('__none__', 0);
300
_walkoptree_simple(@_);
303
sub _walkoptree_simple {
304
my ($op, $callback, $data) = @_;
305
($file, $line) = ($op->file, $op->line) if $op->isa("B::COP");
306
$callback->($op,$data);
307
if ($$op && ($op->flags & OPf_KIDS)) {
309
for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
310
_walkoptree_simple($kid, $callback, $data);
315
=item walkoptree_filtered($op, \&filter, \&callback, [$data])
317
This is much the same as C<walkoptree_simple>, but will only call the
318
callback if the C<filter> returns true. The C<filter> is passed the
319
op in question as a parameter; the C<opgrep> function is fantastic
320
for building your own filters.
324
sub walkoptree_filtered {
325
($file, $line) = ('__none__', 0);
327
_walkoptree_filtered(@_);
330
sub _walkoptree_filtered {
331
my ($op, $filter, $callback, $data) = @_;
332
($file, $line) = ($op->file, $op->line) if $op->isa("B::COP");
333
$callback->($op,$data) if $filter->($op);
334
if ($$op && ($op->flags & OPf_KIDS)) {
336
for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
337
_walkoptree_filtered($kid, $filter, $callback, $data);
342
=item walkallops_simple(\&callback, [$data])
344
This combines C<walkoptree_simple> with C<all_roots> and C<anon_subs>
345
to examine every op in the program. C<$B::Utils::sub> is set to the
346
subroutine name if you're in a subroutine, C<__MAIN__> if you're in
347
the main program and C<__ANON__> if you're in an anonymous subroutine.
353
sub walkallops_simple {
354
my ($callback, $data) = @_;
356
for $sub (keys %roots) {
357
walkoptree_simple($roots{$sub}, $callback, $data);
361
walkoptree_simple($_->{root}, $callback, $data);
365
=item walkallops_filtered(\&filter, \&callback, [$data])
367
Same as above, but filtered.
371
sub walkallops_filtered {
372
my ($filter, $callback, $data) = @_;
374
for $sub (keys %roots) {
375
walkoptree_filtered($roots{$sub}, $filter, $callback, $data);
379
walkoptree_filtered($_->{root}, $filter, $callback, $data);
387
Warn and die, respectively, from the perspective of the position of the op in
388
the program. Sounds complicated, but it's exactly the kind of error reporting
389
you expect when you're grovelling through an op tree.
394
my $args = join '', @_;
395
$args = "Something's wrong " unless $args;
396
$args .= " at $file line $line.\n" unless substr($args, length($args) -1) eq "\n";
399
sub carp (@) { CORE::warn(_preparewarn(@_)) }
400
sub croak (@) { CORE::die(_preparewarn(@_)) }
402
=item opgrep(\%conditions, @ops)
404
Returns the ops which meet the given conditions. The conditions should be
408
{ name => "const", private => OPpCONST_BARE },
412
You can specify alternation by giving an arrayref of values:
414
@svs = opgrep ( { name => ["padsv", "gvsv"] }, @ops)
416
And you can specify inversion by making the first element of the arrayref
417
a "!". (Hint: if you want to say "anything", say "not nothing": C<["!"]>)
419
You may also specify the conditions to be matched in nearby ops.
422
sub { opgrep( {name => "exec",
425
sibling => { name => [qw(! exit warn die)] }
429
carp("Statement unlikely to be reached");
430
carp("\t(Maybe you meant system() when you said exec()?)\n");
436
Here are the things that can be tested:
438
name targ type seq flags private pmflags pmpermflags
439
first other last sibling next pmreplroot pmreplstart pmnext
444
my ($cref, @ops) = @_;
448
OPLOOP: for my $o (grep defined, @ops) {
449
# First, let's skim off ops of the wrong type.
450
for my $type (qw(first other last pmreplroot pmreplstart pmnext pmflags pmpermflags)) {
451
next OPLOOP if exists $conds{$type} and !$o->can($type);
454
for my $test (qw(name targ type seq flags private pmflags pmpermflags)) {
455
next unless exists $conds{$test};
456
next OPLOOP unless $o->can($test);
458
my @conds = ref $conds{$test} ? @{$conds{$test}} : $conds{$test};
460
if ($conds[0] eq "!") {
461
my @conds = @{$conds{$test}}; shift @conds;
462
next OPLOOP if grep {$o->$test eq $_} @conds;
464
next OPLOOP unless grep {$o->$test eq $_} @conds;
468
for my $neighbour (qw(first other last sibling next pmreplroot pmreplstart pmnext)) {
469
next unless exists $conds{$neighbour};
470
# We know it can, because we tested that above
472
next OPLOOP unless opgrep($conds{$neighbour}, $o->$neighbour);
490
Simon Cozens, C<simon@cpan.org>
494
I need to add more Fun Things, and possibly clean up some parts where
495
the (previous/parent) algorithm has catastrophic cases, but it's more
496
important to get this out right now than get it right.
500
L<B>, L<B::Generate>.