« back to all changes in this revision
Viewing changes to lib/B/BUtils.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/BUtils.pm
1
# forked version of B::Utils; needs to merge it ASAP
2
package B::Utils;
3
4
use 5.006;
5
use warnings;
6
use vars '$DEBUG';
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
my $pack = __PACKAGE__; shift;
15
my @exports = @_;
16
my $caller = caller;
17
my %EOK = map {$_ => 1} @EXPORT_OK;
18
for (@exports) {
19
unless ($EOK{$_}) {
20
require Carp;
21
Carp::croak(qq{"$_" is not exported by the $pack module});
22
}
23
no strict 'refs';
24
*{"$caller\::$_"} = \&{"$pack\::$_"};
25
}
26
}
27
28
our $VERSION = '0.04_02'; # 0.04 with some Schwern patches
29
30
use B qw(main_start main_root walksymtable class OPf_KIDS);
31
32
my (%starts, %roots, @anon_subs);
33
34
our @bad_stashes = qw(B Carp DB Exporter warnings Cwd Config CORE blib strict DynaLoader vars XSLoader AutoLoader base);
35
36
sub null {
37
my $op = shift;
38
class( $op ) eq 'NULL';
39
}
40
41
{ my $_subsdone=0;
42
sub _init { # To ensure runtimeness.
43
return if $_subsdone;
44
%starts = ( '__MAIN__' => main_start() );
45
%roots = ( '__MAIN__' => main_root() );
46
walksymtable(\%main::,
47
'_push_starts',
48
sub {
49
return if scalar grep {$_[0] eq $_."::"} @bad_stashes;
50
1;
51
}, # Do not eat our own children!
52
'');
53
push @anon_subs, { root => $_->ROOT, start => $_->START}
54
for grep { class($_) eq "CV" } B::main_cv->PADLIST->ARRAY->ARRAY;
55
$_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
sub all_starts { _init(); return %starts; }
105
sub all_roots { _init(); return %roots; }
106
sub anon_subs { _init(); return @anon_subs }
107
108
sub B::GV::_push_starts {
109
my $name = $_[0]->STASH->NAME."::".$_[0]->SAFENAME;
110
return unless ${$_[0]->CV};
111
my $cv = $_[0]->CV;
112
113
if ($cv->PADLIST->can("ARRAY") and $cv->PADLIST->ARRAY and $cv->PADLIST->ARRAY->can("ARRAY")) {
114
push @anon_subs, { root => $_->ROOT, start => $_->START}
115
for grep { class($_) eq "CV" } $cv->PADLIST->ARRAY->ARRAY;
116
}
117
return unless ${$cv->START} and ${$cv->ROOT};
118
$starts{$name} = $cv->START;
119
$roots{$name} = $cv->ROOT;
120
};
121
122
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
return substr(B::ppname($_[0]->targ),3) if $_[0]->name eq "null" and $_[0]->targ;
133
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
my $op = shift;
144
my @rv = ();
145
146
foreach my $type (qw(first last other)) {
147
my $kid = $op->$type();
148
next if !$kid || class($kid) eq 'NULL';
149
if( $kid->name eq 'null' ) {
150
push @rv, $kid->kids;
151
}
152
else {
153
push @rv, $kid;
154
}
155
}
156
157
my @more_rv = ();
158
foreach my $more_op (@rv) {
159
my $next_op = $more_op;
160
while( $next_op->can("sibling") ) {
161
$next_op = $next_op->sibling;
162
last if !$next_op || class($next_op) eq 'NULL';
163
if( $next_op->name eq 'null' ) {
164
push @more_rv, $next_op->kids;
165
}
166
else {
167
push @more_rv, $next_op;
168
}
169
}
170
}
171
172
return @rv, @more_rv;
173
}
174
175
=item C<< $op->first >>
176
177
=item C<< $op->last >>
178
179
=item C<< $op->other >>
180
181
Normally if you call first, last or other on anything which is not an
182
UNOP, BINOP or LOGOP respectivly it will die. This leads to lots of
183
code like:
184
185
$op->first if $op->can('first');
186
187
B::Utils provides every op with first, last and other methods which
188
will simply return nothing if it isn't relevent.
189
190
=cut
191
192
foreach my $type (qw(first last other)) {
193
no strict 'refs';
194
*{'B::OP::'.$type} = sub {
195
my($op) = shift;
196
if( $op->can("SUPER::$type") ) {
197
return $op->$type();
198
}
199
else {
200
return;
201
}
202
}
203
}
204
205
=item C<< $op->parent >>
206
207
Returns the parent node in the op tree, if possible. Currently "possible" means
208
"if the tree has already been optimized"; that is, if we're during a C<CHECK>
209
block. (and hence, if we have valid C<next> pointers.)
210
211
In the future, it may be possible to search for the parent before we have the
212
C<next> pointers in place, but it'll take me a while to figure out how to do
213
that.
214
215
=cut
216
217
sub B::OP::parent {
218
my $target = shift;
219
printf( "parent %s %s=(0x%07x)\n",
220
B::class( $target),
221
$target->oldname,
222
$$target )
223
if $DEBUG;
224
225
die "I'm not sure how to do this yet. I'm sure there is a way. If you know, please email me."
226
if (!$target->seq);
227
228
my (%deadend, $search_kids);
229
$search_kids = sub {
230
my $node = shift || return undef;
231
232
printf( "Searching from %s %s=(0x%07x)\n",
233
class($node)||'?',
234
$node->oldname,
235
$$node )
236
if $DEBUG;
237
238
# Go up a level if we've got stuck, and search (for the same
239
# $target) from a higher vantage point.
240
return $search->($node->parent) if exists $deadend{$node};
241
242
# Test the immediate children
243
return $node if scalar grep {$_ == $target} $node->kids;
244
245
# Recurse
246
my $x;
247
defined($x = $search->($_)) and return $x for $node->kids;
248
249
# Not in this subtree.
250
$deadend{$node}++;
251
return undef;
252
};
253
my $result;
254
my $start = $target;
255
$result = $search->($start) and return $result while $start = $start->next;
256
return $search->($start);
257
}
258
259
=item C<< $op->previous >>
260
261
Like C<< $op->next >>, but not quite.
262
263
=cut
264
265
sub B::OP::previous {
266
my $target = shift;
267
my $start = $target;
268
my (%deadend, $search);
269
$search = sub {
270
my $node = shift || die;
271
return $search->(find_parent($node)) if exists $deadend{$node};
272
return $node if $node->{next}==$target;
273
# Recurse
274
my $x;
275
($_->next == $target and return $_) for $node->kids;
276
defined($x = $search->($_)) and return $x for $node->{kids};
277
278
# Not in this subtree.
279
$deadend{$node}++;
280
return undef;
281
};
282
my $result;
283
$result = $search->($start) and return $result
284
while $start = $start->next;
285
}
286
287
=item walkoptree_simple($op, \&callback, [$data])
288
289
The C<B> module provides various functions to walk the op tree, but
290
they're all rather difficult to use, requiring you to inject methods
291
into the C<B::OP> class. This is a very simple op tree walker with
292
more expected semantics.
293
294
The &callback is called at each op with the op itself passed in as the
295
first argument and any additional $data as the second.
296
297
All the C<walk> functions set C<$B::Utils::file> and C<$B::Utils::line>
298
to the appropriate values of file and line number in the program
299
being examined. Since only COPs contain this information it may be
300
unavailable in the first few callback calls.
301
302
=cut
303
304
our ($file, $line);
305
306
# Make sure we reset $file and $line between runs.
307
sub walkoptree_simple {
308
($file, $line) = ('__none__', 0);
309
310
_walkoptree_simple(@_);
311
}
312
313
sub _walkoptree_simple {
314
my ($op, $callback, $data) = @_;
315
($file, $line) = ($op->file, $op->line) if $op->isa("B::COP");
316
$callback->($op,$data);
317
if ($$op && ($op->flags & OPf_KIDS)) {
318
my $kid;
319
for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
320
_walkoptree_simple($kid, $callback, $data);
321
}
322
}
323
}
324
325
=item walkoptree_filtered($op, \&filter, \&callback, [$data])
326
327
This is much the same as C<walkoptree_simple>, but will only call the
328
callback if the C<filter> returns true. The C<filter> is passed the
329
op in question as a parameter; the C<opgrep> function is fantastic
330
for building your own filters.
331
332
=cut
333
334
sub walkoptree_filtered {
335
($file, $line) = ('__none__', 0);
336
337
_walkoptree_filtered(@_);
338
}
339
340
sub _walkoptree_filtered {
341
my ($op, $filter, $callback, $data) = @_;
342
($file, $line) = ($op->file, $op->line) if $op->isa("B::COP");
343
$callback->($op,$data) if $filter->($op);
344
if ($$op && ($op->flags & OPf_KIDS)) {
345
my $kid;
346
for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
347
_walkoptree_filtered($kid, $filter, $callback, $data);
348
}
349
}
350
}
351
352
=item walkallops_simple(\&callback, [$data])
353
354
This combines C<walkoptree_simple> with C<all_roots> and C<anon_subs>
355
to examine every op in the program. C<$B::Utils::sub> is set to the
356
subroutine name if you're in a subroutine, C<__MAIN__> if you're in
357
the main program and C<__ANON__> if you're in an anonymous subroutine.
358
359
=cut
360
361
our $sub;
362
363
sub walkallops_simple {
364
my ($callback, $data) = @_;
365
_init();
366
for $sub (keys %roots) {
367
walkoptree_simple($roots{$sub}, $callback, $data);
368
}
369
$sub = "__ANON__";
370
for (@anon_subs) {
371
walkoptree_simple($_->{root}, $callback, $data);
372
}
373
}
374
375
=item walkallops_filtered(\&filter, \&callback, [$data])
376
377
Same as above, but filtered.
378
379
=cut
380
381
sub walkallops_filtered {
382
my ($filter, $callback, $data) = @_;
383
_init();
384
for $sub (keys %roots) {
385
walkoptree_filtered($roots{$sub}, $filter, $callback, $data);
386
}
387
$sub = "__ANON__";
388
for (@anon_subs) {
389
walkoptree_filtered($_->{root}, $filter, $callback, $data);
390
}
391
}
392
393
=item carp(@args)
394
395
=item croak(@args)
396
397
Warn and die, respectively, from the perspective of the position of the op in
398
the program. Sounds complicated, but it's exactly the kind of error reporting
399
you expect when you're grovelling through an op tree.
400
401
=cut
402
403
sub _preparewarn {
404
my $args = join '', @_;
405
$args = "Something's wrong " unless $args;
406
$args .= " at $file line $line.\n" unless substr($args, length($args) -1) eq "\n";
407
}
408
409
sub carp (@) { CORE::warn(_preparewarn(@_)) }
410
sub croak (@) { CORE::die(_preparewarn(@_)) }
411
412
=item opgrep(\%conditions, @ops)
413
414
Returns the ops which meet the given conditions. The conditions should be
415
specified like this:
416
417
@barewords = opgrep(
418
{ name => "const", private => OPpCONST_BARE },
419
@ops
420
);
421
422
You can specify alternation by giving an arrayref of values:
423
424
@svs = opgrep ( { name => ["padsv", "gvsv"] }, @ops)
425
426
And you can specify inversion by making the first element of the arrayref
427
a "!". (Hint: if you want to say "anything", say "not nothing": C<["!"]>)
428
429
You may also specify the conditions to be matched in nearby ops.
430
431
walkallops_filtered(
432
sub { opgrep( {name => "exec",
433
next => {
434
name => "nextstate",
435
sibling => { name => [qw(! exit warn die)] }
436
}
437
}, @_)},
438
sub {
439
carp("Statement unlikely to be reached");
440
carp("\t(Maybe you meant system() when you said exec()?)\n");
441
}
442
)
443
444
Get that?
445
446
Here are the things that can be tested:
447
448
name targ type seq flags private pmflags pmpermflags
449
first other last sibling next pmreplroot pmreplstart pmnext
450
451
=cut
452
453
sub opgrep {
454
my ($cref, @ops) = @_;
455
my %conds = %$cref;
456
my @rv = ();
457
458
OPLOOP: for my $o (grep defined, @ops) {
459
# First, let's skim off ops of the wrong type.
460
for my $type (qw(first other last pmreplroot pmreplstart pmnext pmflags pmpermflags)) {
461
next OPLOOP if exists $conds{$type} and !$o->can($type);
462
}
463
464
for my $test (qw(name targ type seq flags private pmflags pmpermflags)) {
465
next unless exists $conds{$test};
466
next OPLOOP unless $o->can($test);
467
468
my @conds = ref $conds{$test} ? @{$conds{$test}} : $conds{$test};
469
470
if ($conds[0] eq "!") {
471
my @conds = @{$conds{$test}}; shift @conds;
472
next OPLOOP if grep {$o->$test eq $_} @conds;
473
} else {
474
next OPLOOP unless grep {$o->$test eq $_} @conds;
475
}
476
}
477
478
for my $neighbour (qw(first other last sibling next pmreplroot pmreplstart pmnext)) {
479
next unless exists $conds{$neighbour};
480
# We know it can, because we tested that above
481
# Recurse, recurse!
482
next OPLOOP unless opgrep($conds{$neighbour}, $o->$neighbour);
483
}
484
485
push @rv, $o;
486
}
487
return @rv;
488
}
489
490
package B::BUtils;
491
492
@ISA = qw(B::Utils);
493
494
1;
495
496
=back
497
498
=head2 EXPORT
499
500
None by default.
501
502
=head1 AUTHOR
503
504
Simon Cozens, C<simon@cpan.org>
505
506
=head1 TODO
507
508
I need to add more Fun Things, and possibly clean up some parts where
509
the (previous/parent) algorithm has catastrophic cases, but it's more
510
important to get this out right now than get it right.
511
512
=head1 SEE ALSO
513
514
L<B>, L<B::Generate>.
515
516
=cut
Loggerhead is a web-based interface for Breezy
Version: 2.0.1