« back to all changes in this revision
Viewing changes to lib/B/Utils.pm
- browse files at revision 5
- compare with another revision
- download diff
- download tarball
- view history from revision 5
- Committer: Bazaar Package Importer
- Author(s): Jay Bonci
- Date: 2007-07-03 13:02:51 UTC
- mfrom: (1.2.3 upstream)
- Revision ID: james.westby@ubuntu.com-20070703130251-a3lwdwadryajtfkk
Tags: 0.31-1
* New upstream release
* Bumped policy version to 3.7.2.2 (No other changes)
* Build-Depends-Indep to Build-Depends to satisfy lintian
* Changed debian/rules so that make clean is only conditionally ignored
* Bumped policy version to 3.7.2.2 (No other changes)
* Build-Depends-Indep to Build-Depends to satisfy lintian
* Changed debian/rules so that make clean is only conditionally ignored
- files added:
- lib/B/BUtils.pm
- files removed:
- lib/B/Utils.pm
- files modified:
- Build.PL
added
removed
lib/B/Utils.pm
1
package B::Utils;
2
3
use 5.006;
4
use strict;
5
use warnings;
6
our @EXPORT_OK = qw(all_starts all_roots anon_subs
7
walkoptree_simple walkoptree_filtered
8
walkallops_simple walkallops_filtered
9
carp croak
10
opgrep
11
);
12
sub import {
13
my $pack = shift;
14
my @exports = @_;
15
my $caller = caller;
16
my %EOK = map {$_ => 1} @EXPORT_OK;
17
for (@exports) {
18
unless ($EOK{$_}) {
19
require Carp;
20
Carp::croak(qq{"$_" is not exported by the $pack module});
21
}
22
no strict 'refs';
23
*{"$caller\::$_"} = \&{"$pack\::$_"};
24
}
25
}
26
27
our $VERSION = '0.04_01'; # 0.04 with some Schwern patches
28
29
use B qw(main_start main_root walksymtable class OPf_KIDS);
30
31
my (%starts, %roots, @anon_subs);
32
33
our @bad_stashes = qw(B Carp DB Exporter warnings Cwd Config CORE blib strict DynaLoader vars XSLoader AutoLoader base);
34
35
{ my $_subsdone=0;
36
sub _init { # To ensure runtimeness.
37
return if $_subsdone;
38
%starts = ( '__MAIN__' => main_start() );
39
%roots = ( '__MAIN__' => main_root() );
40
walksymtable(\%main::,
41
'_push_starts',
42
sub {
43
return if scalar grep {$_[0] eq $_."::"} @bad_stashes;
44
1;
45
}, # Do not eat our own children!
46
'');
47
push @anon_subs, { root => $_->ROOT, start => $_->START}
48
for grep { class($_) eq "CV" } B::main_cv->PADLIST->ARRAY->ARRAY;
49
$_subsdone=1;
50
}
51
}
52
53
=head1 NAME
54
55
B::Utils - Helper functions for op tree manipulation
56
57
=head1 SYNOPSIS
58
59
use B::Utils;
60
61
=head1 DESCRIPTION
62
63
These functions make it easier to manipulate the op tree.
64
65
=head1 FUNCTIONS
66
67
=over 3
68
69
=item C<all_starts>
70
71
=item C<all_roots>
72
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__>.
75
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.
81
82
This does B<not> return the details of ops in anonymous subroutines
83
compiled at compile time. For instance, given
84
85
$a = sub { ... };
86
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...
89
90
=item C<anon_subs()>
91
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.
95
96
=cut
97
98
sub all_starts { _init(); return %starts; }
99
sub all_roots { _init(); return %roots; }
100
sub anon_subs { _init(); return @anon_subs }
101
102
sub B::GV::_push_starts {
103
my $name = $_[0]->STASH->NAME."::".$_[0]->SAFENAME;
104
return unless ${$_[0]->CV};
105
my $cv = $_[0]->CV;
106
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;
110
}
111
return unless ${$cv->START} and ${$cv->ROOT};
112
$starts{$name} = $cv->START;
113
$roots{$name} = $cv->ROOT;
114
};
115
116
sub B::SPECIAL::_push_starts{}
117
118
=item C<< $op->oldname >>
119
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.
122
123
=cut
124
125
sub B::OP::oldname {
126
return substr(B::ppname($_[0]->targ),3) if $_[0]->name eq "null" and $_[0]->targ;
127
return $_[0]->name;
128
}
129
130
=item C<< $op->kids >>
131
132
Returns an array of all this op's non-null children, in order.
133
134
=cut
135
136
sub B::OP::kids {
137
my $op = shift;
138
my @rv = ();
139
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;
145
}
146
else {
147
push @rv, $kid;
148
}
149
}
150
151
my @more_rv = ();
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;
159
}
160
else {
161
push @more_rv, $next_op;
162
}
163
}
164
}
165
166
return @rv, @more_rv;
167
}
168
169
170
=item C<< $op->first >>
171
172
=item C<< $op->last >>
173
174
=item C<< $op->other >>
175
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
178
code like:
179
180
$op->first if $op->can('first');
181
182
B::Utils provides every op with first, last and other methods which
183
will simply return nothing if it isn't relevent.
184
185
=cut
186
187
foreach my $type (qw(first last other)) {
188
no strict 'refs';
189
*{'B::OP::'.$type} = sub {
190
my($op) = shift;
191
if( $op->can("SUPER::$type") ) {
192
return $op->$type();
193
}
194
else {
195
return;
196
}
197
}
198
}
199
200
201
=item C<< $op->parent >>
202
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.)
206
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
209
that.
210
211
=cut
212
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.
219
220
sub B::OP::parent {
221
my $target = shift;
222
die "I'm not sure how to do this yet. I'm sure there is a way. If you know, please email me."
223
if (!$target->seq);
224
my (%deadend, $search);
225
$search = sub {
226
my $node = shift || return undef;
227
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};
231
232
# Test the immediate children
233
return $node if scalar grep {$_ == $target} $node->kids;
234
235
# Recurse
236
my $x;
237
defined($x = $search->($_)) and return $x for $node->kids;
238
239
# Not in this subtree.
240
$deadend{$node}++;
241
return undef;
242
};
243
my $result;
244
my $start = $target;
245
$result = $search->($start) and return $result while $start = $start->next;
246
return $search->($start);
247
}
248
249
=item C<< $op->previous >>
250
251
Like C<< $op->next >>, but not quite.
252
253
=cut
254
255
sub B::OP::previous {
256
my $target = shift;
257
my $start = $target;
258
my (%deadend, $search);
259
$search = sub {
260
my $node = shift || die;
261
return $search->(find_parent($node)) if exists $deadend{$node};
262
return $node if $node->{next}==$target;
263
# Recurse
264
my $x;
265
($_->next == $target and return $_) for $node->kids;
266
defined($x = $search->($_)) and return $x for $node->{kids};
267
268
# Not in this subtree.
269
$deadend{$node}++;
270
return undef;
271
};
272
my $result;
273
$result = $search->($start) and return $result
274
while $start = $start->next;
275
}
276
277
=item walkoptree_simple($op, \&callback, [$data])
278
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.
283
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.
286
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.
291
292
=cut
293
294
our ($file, $line);
295
296
# Make sure we reset $file and $line between runs.
297
sub walkoptree_simple {
298
($file, $line) = ('__none__', 0);
299
300
_walkoptree_simple(@_);
301
}
302
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)) {
308
my $kid;
309
for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
310
_walkoptree_simple($kid, $callback, $data);
311
}
312
}
313
}
314
315
=item walkoptree_filtered($op, \&filter, \&callback, [$data])
316
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.
321
322
=cut
323
324
sub walkoptree_filtered {
325
($file, $line) = ('__none__', 0);
326
327
_walkoptree_filtered(@_);
328
}
329
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)) {
335
my $kid;
336
for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
337
_walkoptree_filtered($kid, $filter, $callback, $data);
338
}
339
}
340
}
341
342
=item walkallops_simple(\&callback, [$data])
343
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.
348
349
=cut
350
351
our $sub;
352
353
sub walkallops_simple {
354
my ($callback, $data) = @_;
355
_init();
356
for $sub (keys %roots) {
357
walkoptree_simple($roots{$sub}, $callback, $data);
358
}
359
$sub = "__ANON__";
360
for (@anon_subs) {
361
walkoptree_simple($_->{root}, $callback, $data);
362
}
363
}
364
365
=item walkallops_filtered(\&filter, \&callback, [$data])
366
367
Same as above, but filtered.
368
369
=cut
370
371
sub walkallops_filtered {
372
my ($filter, $callback, $data) = @_;
373
_init();
374
for $sub (keys %roots) {
375
walkoptree_filtered($roots{$sub}, $filter, $callback, $data);
376
}
377
$sub = "__ANON__";
378
for (@anon_subs) {
379
walkoptree_filtered($_->{root}, $filter, $callback, $data);
380
}
381
}
382
383
=item carp(@args)
384
385
=item croak(@args)
386
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.
390
391
=cut
392
393
sub _preparewarn {
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";
397
}
398
399
sub carp (@) { CORE::warn(_preparewarn(@_)) }
400
sub croak (@) { CORE::die(_preparewarn(@_)) }
401
402
=item opgrep(\%conditions, @ops)
403
404
Returns the ops which meet the given conditions. The conditions should be
405
specified like this:
406
407
@barewords = opgrep(
408
{ name => "const", private => OPpCONST_BARE },
409
@ops
410
);
411
412
You can specify alternation by giving an arrayref of values:
413
414
@svs = opgrep ( { name => ["padsv", "gvsv"] }, @ops)
415
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<["!"]>)
418
419
You may also specify the conditions to be matched in nearby ops.
420
421
walkallops_filtered(
422
sub { opgrep( {name => "exec",
423
next => {
424
name => "nextstate",
425
sibling => { name => [qw(! exit warn die)] }
426
}
427
}, @_)},
428
sub {
429
carp("Statement unlikely to be reached");
430
carp("\t(Maybe you meant system() when you said exec()?)\n");
431
}
432
)
433
434
Get that?
435
436
Here are the things that can be tested:
437
438
name targ type seq flags private pmflags pmpermflags
439
first other last sibling next pmreplroot pmreplstart pmnext
440
441
=cut
442
443
sub opgrep {
444
my ($cref, @ops) = @_;
445
my %conds = %$cref;
446
my @rv = ();
447
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);
452
}
453
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);
457
458
my @conds = ref $conds{$test} ? @{$conds{$test}} : $conds{$test};
459
460
if ($conds[0] eq "!") {
461
my @conds = @{$conds{$test}}; shift @conds;
462
next OPLOOP if grep {$o->$test eq $_} @conds;
463
} else {
464
next OPLOOP unless grep {$o->$test eq $_} @conds;
465
}
466
}
467
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
471
# Recurse, recurse!
472
next OPLOOP unless opgrep($conds{$neighbour}, $o->$neighbour);
473
}
474
475
push @rv, $o;
476
}
477
return @rv;
478
}
479
480
1;
481
482
=back
483
484
=head2 EXPORT
485
486
None by default.
487
488
=head1 AUTHOR
489
490
Simon Cozens, C<simon@cpan.org>
491
492
=head1 TODO
493
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.
497
498
=head1 SEE ALSO
499
500
L<B>, L<B::Generate>.
501
502
=cut
Loggerhead is a web-based interface for Breezy
Version: 2.0.1