1# forked version of B::Utils; needs to merge it ASAP 2package B::Utils; 3 4use 5.006; 5use warnings; 6use vars '$DEBUG'; 7our @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 ); 13sub 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 28our $VERSION = '0.04_02'; # 0.04 with some Schwern patches 29 30use B qw(main_start main_root walksymtable class OPf_KIDS); 31 32my (%starts, %roots, @anon_subs); 33 34our @bad_stashes = qw(B Carp DB Exporter warnings Cwd Config CORE blib strict DynaLoader vars XSLoader AutoLoader base); 35 36sub null { 37 my $op = shift; 38 class( $op ) eq 'NULL'; 39} 40 41{ my $_subsdone=0; 42sub _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 61B::Utils - Helper functions for op tree manipulation 62 63=head1 SYNOPSIS 64 65 use B::Utils; 66 67=head1 DESCRIPTION 68 69These 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 79Returns a hash of all of the starting ops or root ops of optrees, keyed 80to subroutine name; the optree for main program is simply keyed to C<__MAIN__>. 81 82B<Note>: Certain "dangerous" stashes are not scanned for subroutines: 83the list of such stashes can be found in C<@B::Utils::bad_stashes>. Feel 84free to examine and/or modify this to suit your needs. The intention is 85that a simple program which uses no modules other than C<B> and 86C<B::Utils> would show no addition symbols. 87 88This does B<not> return the details of ops in anonymous subroutines 89compiled at compile time. For instance, given 90 91 $a = sub { ... }; 92 93the subroutine will not appear in the hash. This is just as well, since 94they're anonymous... If you want to get at them, use... 95 96=item C<anon_subs()> 97 98This 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 100the anonymous subroutines in the program. 101 102=cut 103 104sub all_starts { _init(); return %starts; } 105sub all_roots { _init(); return %roots; } 106sub anon_subs { _init(); return @anon_subs } 107 108sub 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 122sub B::SPECIAL::_push_starts{} 123 124=item C<< $op->oldname >> 125 126Returns the name of the op, even if it is currently optimized to null. 127This helps you understand the stucture of the op tree. 128 129=cut 130 131sub 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 138Returns an array of all this op's non-null children, in order. 139 140=cut 141 142sub 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 181Normally if you call first, last or other on anything which is not an 182UNOP, BINOP or LOGOP respectivly it will die. This leads to lots of 183code like: 184 185 $op->first if $op->can('first'); 186 187B::Utils provides every op with first, last and other methods which 188will simply return nothing if it isn't relevent. 189 190=cut 191 192foreach 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 207Returns 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> 209block. (and hence, if we have valid C<next> pointers.) 210 211In the future, it may be possible to search for the parent before we have the 212C<next> pointers in place, but it'll take me a while to figure out how to do 213that. 214 215=cut 216 217sub 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 261Like C<< $op->next >>, but not quite. 262 263=cut 264 265sub 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 289The C<B> module provides various functions to walk the op tree, but 290they're all rather difficult to use, requiring you to inject methods 291into the C<B::OP> class. This is a very simple op tree walker with 292more expected semantics. 293 294The &callback is called at each op with the op itself passed in as the 295first argument and any additional $data as the second. 296 297All the C<walk> functions set C<$B::Utils::file> and C<$B::Utils::line> 298to the appropriate values of file and line number in the program 299being examined. Since only COPs contain this information it may be 300unavailable in the first few callback calls. 301 302=cut 303 304our ($file, $line); 305 306# Make sure we reset $file and $line between runs. 307sub walkoptree_simple { 308 ($file, $line) = ('__none__', 0); 309 310 _walkoptree_simple(@_); 311} 312 313sub _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 327This is much the same as C<walkoptree_simple>, but will only call the 328callback if the C<filter> returns true. The C<filter> is passed the 329op in question as a parameter; the C<opgrep> function is fantastic 330for building your own filters. 331 332=cut 333 334sub walkoptree_filtered { 335 ($file, $line) = ('__none__', 0); 336 337 _walkoptree_filtered(@_); 338} 339 340sub _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 354This combines C<walkoptree_simple> with C<all_roots> and C<anon_subs> 355to examine every op in the program. C<$B::Utils::sub> is set to the 356subroutine name if you're in a subroutine, C<__MAIN__> if you're in 357the main program and C<__ANON__> if you're in an anonymous subroutine. 358 359=cut 360 361our $sub; 362 363sub 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 377Same as above, but filtered. 378 379=cut 380 381sub 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 397Warn and die, respectively, from the perspective of the position of the op in 398the program. Sounds complicated, but it's exactly the kind of error reporting 399you expect when you're grovelling through an op tree. 400 401=cut 402 403sub _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 409sub carp (@) { CORE::warn(_preparewarn(@_)) } 410sub croak (@) { CORE::die(_preparewarn(@_)) } 411 412=item opgrep(\%conditions, @ops) 413 414Returns the ops which meet the given conditions. The conditions should be 415specified like this: 416 417 @barewords = opgrep( 418 { name => "const", private => OPpCONST_BARE }, 419 @ops 420 ); 421 422You can specify alternation by giving an arrayref of values: 423 424 @svs = opgrep ( { name => ["padsv", "gvsv"] }, @ops) 425 426And you can specify inversion by making the first element of the arrayref 427a "!". (Hint: if you want to say "anything", say "not nothing": C<["!"]>) 428 429You 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 444Get that? 445 446Here 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 453sub 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 490package B::BUtils; 491 492@ISA = qw(B::Utils); 493 4941; 495 496=back 497 498=head2 EXPORT 499 500None by default. 501 502=head1 AUTHOR 503 504Simon Cozens, C<simon@cpan.org> 505 506=head1 TODO 507 508I need to add more Fun Things, and possibly clean up some parts where 509the (previous/parent) algorithm has catastrophic cases, but it's more 510important to get this out right now than get it right. 511 512=head1 SEE ALSO 513 514L<B>, L<B::Generate>. 515 516=cut 517