1# B.pm 2# 3# Copyright (c) 1996, 1997, 1998 Malcolm Beattie 4# 5# You may distribute under the terms of either the GNU General Public 6# License or the Artistic License, as specified in the README file. 7# 8package B; 9use XSLoader (); 10require Exporter; 11@ISA = qw(Exporter); 12 13# walkoptree_slow comes from B.pm (you are there), 14# walkoptree comes from B.xs 15@EXPORT_OK = qw(minus_c ppname save_BEGINs 16 class peekop cast_I32 cstring cchar hash threadsv_names 17 main_root main_start main_cv svref_2object opnumber 18 amagic_generation 19 walkoptree_slow walkoptree walkoptree_exec walksymtable 20 parents comppadlist sv_undef compile_stats timing_info 21 begin_av init_av end_av); 22 23sub OPf_KIDS (); 24use strict; 25@B::SV::ISA = 'B::OBJECT'; 26@B::NULL::ISA = 'B::SV'; 27@B::PV::ISA = 'B::SV'; 28@B::IV::ISA = 'B::SV'; 29@B::NV::ISA = 'B::IV'; 30@B::RV::ISA = 'B::SV'; 31@B::PVIV::ISA = qw(B::PV B::IV); 32@B::PVNV::ISA = qw(B::PV B::NV); 33@B::PVMG::ISA = 'B::PVNV'; 34@B::PVLV::ISA = 'B::PVMG'; 35@B::BM::ISA = 'B::PVMG'; 36@B::AV::ISA = 'B::PVMG'; 37@B::GV::ISA = 'B::PVMG'; 38@B::HV::ISA = 'B::PVMG'; 39@B::CV::ISA = 'B::PVMG'; 40@B::IO::ISA = 'B::PVMG'; 41@B::FM::ISA = 'B::CV'; 42 43@B::OP::ISA = 'B::OBJECT'; 44@B::UNOP::ISA = 'B::OP'; 45@B::BINOP::ISA = 'B::UNOP'; 46@B::LOGOP::ISA = 'B::UNOP'; 47@B::LISTOP::ISA = 'B::BINOP'; 48@B::SVOP::ISA = 'B::OP'; 49@B::PADOP::ISA = 'B::OP'; 50@B::PVOP::ISA = 'B::OP'; 51@B::CVOP::ISA = 'B::OP'; 52@B::LOOP::ISA = 'B::LISTOP'; 53@B::PMOP::ISA = 'B::LISTOP'; 54@B::COP::ISA = 'B::OP'; 55 56@B::SPECIAL::ISA = 'B::OBJECT'; 57 58{ 59 # Stop "-w" from complaining about the lack of a real B::OBJECT class 60 package B::OBJECT; 61} 62 63sub B::GV::SAFENAME { 64 my $name = (shift())->NAME; 65 66 # The regex below corresponds to the isCONTROLVAR macro 67 # from toke.c 68 69 $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e; 70 return $name; 71} 72 73sub B::IV::int_value { 74 my ($self) = @_; 75 return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV); 76} 77 78my $debug; 79my $op_count = 0; 80my @parents = (); 81 82sub debug { 83 my ($class, $value) = @_; 84 $debug = $value; 85 walkoptree_debug($value); 86} 87 88sub class { 89 my $obj = shift; 90 my $name = ref $obj; 91 $name =~ s/^.*:://; 92 return $name; 93} 94 95sub parents { \@parents } 96 97# For debugging 98sub peekop { 99 my $op = shift; 100 return sprintf("%s (0x%x) %s", class($op), $$op, $op->name); 101} 102 103sub walkoptree_slow { 104 my($op, $method, $level) = @_; 105 $op_count++; # just for statistics 106 $level ||= 0; 107 warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug; 108 $op->$method($level); 109 if ($$op && ($op->flags & OPf_KIDS)) { 110 my $kid; 111 unshift(@parents, $op); 112 for ($kid = $op->first; $$kid; $kid = $kid->sibling) { 113 walkoptree_slow($kid, $method, $level + 1); 114 } 115 shift @parents; 116 } 117} 118 119sub compile_stats { 120 return "Total number of OPs processed: $op_count\n"; 121} 122 123sub timing_info { 124 my ($sec, $min, $hr) = localtime; 125 my ($user, $sys) = times; 126 sprintf("%02d:%02d:%02d user=$user sys=$sys", 127 $hr, $min, $sec, $user, $sys); 128} 129 130my %symtable; 131 132sub clearsym { 133 %symtable = (); 134} 135 136sub savesym { 137 my ($obj, $value) = @_; 138# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug 139 $symtable{sprintf("sym_%x", $$obj)} = $value; 140} 141 142sub objsym { 143 my $obj = shift; 144 return $symtable{sprintf("sym_%x", $$obj)}; 145} 146 147sub walkoptree_exec { 148 my ($op, $method, $level) = @_; 149 $level ||= 0; 150 my ($sym, $ppname); 151 my $prefix = " " x $level; 152 for (; $$op; $op = $op->next) { 153 $sym = objsym($op); 154 if (defined($sym)) { 155 print $prefix, "goto $sym\n"; 156 return; 157 } 158 savesym($op, sprintf("%s (0x%lx)", class($op), $$op)); 159 $op->$method($level); 160 $ppname = $op->name; 161 if ($ppname =~ 162 /^(or|and|mapwhile|grepwhile|entertry|range|cond_expr)$/) 163 { 164 print $prefix, uc($1), " => {\n"; 165 walkoptree_exec($op->other, $method, $level + 1); 166 print $prefix, "}\n"; 167 } elsif ($ppname eq "match" || $ppname eq "subst") { 168 my $pmreplstart = $op->pmreplstart; 169 if ($$pmreplstart) { 170 print $prefix, "PMREPLSTART => {\n"; 171 walkoptree_exec($pmreplstart, $method, $level + 1); 172 print $prefix, "}\n"; 173 } 174 } elsif ($ppname eq "substcont") { 175 print $prefix, "SUBSTCONT => {\n"; 176 walkoptree_exec($op->other->pmreplstart, $method, $level + 1); 177 print $prefix, "}\n"; 178 $op = $op->other; 179 } elsif ($ppname eq "enterloop") { 180 print $prefix, "REDO => {\n"; 181 walkoptree_exec($op->redoop, $method, $level + 1); 182 print $prefix, "}\n", $prefix, "NEXT => {\n"; 183 walkoptree_exec($op->nextop, $method, $level + 1); 184 print $prefix, "}\n", $prefix, "LAST => {\n"; 185 walkoptree_exec($op->lastop, $method, $level + 1); 186 print $prefix, "}\n"; 187 } elsif ($ppname eq "subst") { 188 my $replstart = $op->pmreplstart; 189 if ($$replstart) { 190 print $prefix, "SUBST => {\n"; 191 walkoptree_exec($replstart, $method, $level + 1); 192 print $prefix, "}\n"; 193 } 194 } 195 } 196} 197 198sub walksymtable { 199 my ($symref, $method, $recurse, $prefix) = @_; 200 my $sym; 201 my $ref; 202 no strict 'vars'; 203 local(*glob); 204 $prefix = '' unless defined $prefix; 205 while (($sym, $ref) = each %$symref) { 206 *glob = "*main::".$prefix.$sym; 207 if ($sym =~ /::$/) { 208 $sym = $prefix . $sym; 209 if ($sym ne "main::" && $sym ne "<none>::" && &$recurse($sym)) { 210 walksymtable(\%glob, $method, $recurse, $sym); 211 } 212 } else { 213 svref_2object(\*glob)->EGV->$method(); 214 } 215 } 216} 217 218{ 219 package B::Section; 220 my $output_fh; 221 my %sections; 222 223 sub new { 224 my ($class, $section, $symtable, $default) = @_; 225 $output_fh ||= FileHandle->new_tmpfile; 226 my $obj = bless [-1, $section, $symtable, $default], $class; 227 $sections{$section} = $obj; 228 return $obj; 229 } 230 231 sub get { 232 my ($class, $section) = @_; 233 return $sections{$section}; 234 } 235 236 sub add { 237 my $section = shift; 238 while (defined($_ = shift)) { 239 print $output_fh "$section->[1]\t$_\n"; 240 $section->[0]++; 241 } 242 } 243 244 sub index { 245 my $section = shift; 246 return $section->[0]; 247 } 248 249 sub name { 250 my $section = shift; 251 return $section->[1]; 252 } 253 254 sub symtable { 255 my $section = shift; 256 return $section->[2]; 257 } 258 259 sub default { 260 my $section = shift; 261 return $section->[3]; 262 } 263 264 sub output { 265 my ($section, $fh, $format) = @_; 266 my $name = $section->name; 267 my $sym = $section->symtable || {}; 268 my $default = $section->default; 269 270 seek($output_fh, 0, 0); 271 while (<$output_fh>) { 272 chomp; 273 s/^(.*?)\t//; 274 if ($1 eq $name) { 275 s{(s\\_[0-9a-f]+)} { 276 exists($sym->{$1}) ? $sym->{$1} : $default; 277 }ge; 278 printf $fh $format, $_; 279 } 280 } 281 } 282} 283 284XSLoader::load 'B'; 285 2861; 287 288__END__ 289 290=head1 NAME 291 292B - The Perl Compiler 293 294=head1 SYNOPSIS 295 296 use B; 297 298=head1 DESCRIPTION 299 300The C<B> module supplies classes which allow a Perl program to delve 301into its own innards. It is the module used to implement the 302"backends" of the Perl compiler. Usage of the compiler does not 303require knowledge of this module: see the F<O> module for the 304user-visible part. The C<B> module is of use to those who want to 305write new compiler backends. This documentation assumes that the 306reader knows a fair amount about perl's internals including such 307things as SVs, OPs and the internal symbol table and syntax tree 308of a program. 309 310=head1 OVERVIEW OF CLASSES 311 312The C structures used by Perl's internals to hold SV and OP 313information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a 314class hierarchy and the C<B> module gives access to them via a true 315object hierarchy. Structure fields which point to other objects 316(whether types of SV or types of OP) are represented by the C<B> 317module as Perl objects of the appropriate class. The bulk of the C<B> 318module is the methods for accessing fields of these structures. Note 319that all access is read-only: you cannot modify the internals by 320using this module. 321 322=head2 SV-RELATED CLASSES 323 324B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV, 325B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in 326the obvious way to the underlying C structures of similar names. The 327inheritance hierarchy mimics the underlying C "inheritance". Access 328methods correspond to the underlying C macros for field access, 329usually with the leading "class indication" prefix removed (Sv, Av, 330Hv, ...). The leading prefix is only left in cases where its removal 331would cause a clash in method name. For example, C<GvREFCNT> stays 332as-is since its abbreviation would clash with the "superclass" method 333C<REFCNT> (corresponding to the C function C<SvREFCNT>). 334 335=head2 B::SV METHODS 336 337=over 4 338 339=item REFCNT 340 341=item FLAGS 342 343=back 344 345=head2 B::IV METHODS 346 347=over 4 348 349=item IV 350 351Returns the value of the IV, I<interpreted as 352a signed integer>. This will be misleading 353if C<FLAGS & SVf_IVisUV>. Perhaps you want the 354C<int_value> method instead? 355 356=item IVX 357 358=item UVX 359 360=item int_value 361 362This method returns the value of the IV as an integer. 363It differs from C<IV> in that it returns the correct 364value regardless of whether it's stored signed or 365unsigned. 366 367=item needs64bits 368 369=item packiv 370 371=back 372 373=head2 B::NV METHODS 374 375=over 4 376 377=item NV 378 379=item NVX 380 381=back 382 383=head2 B::RV METHODS 384 385=over 4 386 387=item RV 388 389=back 390 391=head2 B::PV METHODS 392 393=over 4 394 395=item PV 396 397This method is the one you usually want. It constructs a 398string using the length and offset information in the struct: 399for ordinary scalars it will return the string that you'd see 400from Perl, even if it contains null characters. 401 402=item PVX 403 404This method is less often useful. It assumes that the string 405stored in the struct is null-terminated, and disregards the 406length information. 407 408It is the appropriate method to use if you need to get the name 409of a lexical variable from a padname array. Lexical variable names 410are always stored with a null terminator, and the length field 411(SvCUR) is overloaded for other purposes and can't be relied on here. 412 413=back 414 415=head2 B::PVMG METHODS 416 417=over 4 418 419=item MAGIC 420 421=item SvSTASH 422 423=back 424 425=head2 B::MAGIC METHODS 426 427=over 4 428 429=item MOREMAGIC 430 431=item PRIVATE 432 433=item TYPE 434 435=item FLAGS 436 437=item OBJ 438 439=item PTR 440 441=back 442 443=head2 B::PVLV METHODS 444 445=over 4 446 447=item TARGOFF 448 449=item TARGLEN 450 451=item TYPE 452 453=item TARG 454 455=back 456 457=head2 B::BM METHODS 458 459=over 4 460 461=item USEFUL 462 463=item PREVIOUS 464 465=item RARE 466 467=item TABLE 468 469=back 470 471=head2 B::GV METHODS 472 473=over 4 474 475=item is_empty 476 477This method returns TRUE if the GP field of the GV is NULL. 478 479=item NAME 480 481=item SAFENAME 482 483This method returns the name of the glob, but if the first 484character of the name is a control character, then it converts 485it to ^X first, so that *^G would return "^G" rather than "\cG". 486 487It's useful if you want to print out the name of a variable. 488If you restrict yourself to globs which exist at compile-time 489then the result ought to be unambiguous, because code like 490C<${"^G"} = 1> is compiled as two ops - a constant string and 491a dereference (rv2gv) - so that the glob is created at runtime. 492 493If you're working with globs at runtime, and need to disambiguate 494*^G from *{"^G"}, then you should use the raw NAME method. 495 496=item STASH 497 498=item SV 499 500=item IO 501 502=item FORM 503 504=item AV 505 506=item HV 507 508=item EGV 509 510=item CV 511 512=item CVGEN 513 514=item LINE 515 516=item FILE 517 518=item FILEGV 519 520=item GvREFCNT 521 522=item FLAGS 523 524=back 525 526=head2 B::IO METHODS 527 528=over 4 529 530=item LINES 531 532=item PAGE 533 534=item PAGE_LEN 535 536=item LINES_LEFT 537 538=item TOP_NAME 539 540=item TOP_GV 541 542=item FMT_NAME 543 544=item FMT_GV 545 546=item BOTTOM_NAME 547 548=item BOTTOM_GV 549 550=item SUBPROCESS 551 552=item IoTYPE 553 554=item IoFLAGS 555 556=back 557 558=head2 B::AV METHODS 559 560=over 4 561 562=item FILL 563 564=item MAX 565 566=item OFF 567 568=item ARRAY 569 570=item AvFLAGS 571 572=back 573 574=head2 B::CV METHODS 575 576=over 4 577 578=item STASH 579 580=item START 581 582=item ROOT 583 584=item GV 585 586=item FILE 587 588=item DEPTH 589 590=item PADLIST 591 592=item OUTSIDE 593 594=item XSUB 595 596=item XSUBANY 597 598=item CvFLAGS 599 600=back 601 602=head2 B::HV METHODS 603 604=over 4 605 606=item FILL 607 608=item MAX 609 610=item KEYS 611 612=item RITER 613 614=item NAME 615 616=item PMROOT 617 618=item ARRAY 619 620=back 621 622=head2 OP-RELATED CLASSES 623 624B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP, 625B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP. 626These classes correspond in 627the obvious way to the underlying C structures of similar names. The 628inheritance hierarchy mimics the underlying C "inheritance". Access 629methods correspond to the underlying C structre field names, with the 630leading "class indication" prefix removed (op_). 631 632=head2 B::OP METHODS 633 634=over 4 635 636=item next 637 638=item sibling 639 640=item name 641 642This returns the op name as a string (e.g. "add", "rv2av"). 643 644=item ppaddr 645 646This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]", 647"PL_ppaddr[OP_RV2AV]"). 648 649=item desc 650 651This returns the op description from the global C PL_op_desc array 652(e.g. "addition" "array deref"). 653 654=item targ 655 656=item type 657 658=item seq 659 660=item flags 661 662=item private 663 664=back 665 666=head2 B::UNOP METHOD 667 668=over 4 669 670=item first 671 672=back 673 674=head2 B::BINOP METHOD 675 676=over 4 677 678=item last 679 680=back 681 682=head2 B::LOGOP METHOD 683 684=over 4 685 686=item other 687 688=back 689 690=head2 B::LISTOP METHOD 691 692=over 4 693 694=item children 695 696=back 697 698=head2 B::PMOP METHODS 699 700=over 4 701 702=item pmreplroot 703 704=item pmreplstart 705 706=item pmnext 707 708=item pmregexp 709 710=item pmflags 711 712=item pmpermflags 713 714=item precomp 715 716=back 717 718=head2 B::SVOP METHOD 719 720=over 4 721 722=item sv 723 724=item gv 725 726=back 727 728=head2 B::PADOP METHOD 729 730=over 4 731 732=item padix 733 734=back 735 736=head2 B::PVOP METHOD 737 738=over 4 739 740=item pv 741 742=back 743 744=head2 B::LOOP METHODS 745 746=over 4 747 748=item redoop 749 750=item nextop 751 752=item lastop 753 754=back 755 756=head2 B::COP METHODS 757 758=over 4 759 760=item label 761 762=item stash 763 764=item file 765 766=item cop_seq 767 768=item arybase 769 770=item line 771 772=back 773 774=head1 FUNCTIONS EXPORTED BY C<B> 775 776The C<B> module exports a variety of functions: some are simple 777utility functions, others provide a Perl program with a way to 778get an initial "handle" on an internal object. 779 780=over 4 781 782=item main_cv 783 784Return the (faked) CV corresponding to the main part of the Perl 785program. 786 787=item init_av 788 789Returns the AV object (i.e. in class B::AV) representing INIT blocks. 790 791=item main_root 792 793Returns the root op (i.e. an object in the appropriate B::OP-derived 794class) of the main part of the Perl program. 795 796=item main_start 797 798Returns the starting op of the main part of the Perl program. 799 800=item comppadlist 801 802Returns the AV object (i.e. in class B::AV) of the global comppadlist. 803 804=item sv_undef 805 806Returns the SV object corresponding to the C variable C<sv_undef>. 807 808=item sv_yes 809 810Returns the SV object corresponding to the C variable C<sv_yes>. 811 812=item sv_no 813 814Returns the SV object corresponding to the C variable C<sv_no>. 815 816=item amagic_generation 817 818Returns the SV object corresponding to the C variable C<amagic_generation>. 819 820=item walkoptree(OP, METHOD) 821 822Does a tree-walk of the syntax tree based at OP and calls METHOD on 823each op it visits. Each node is visited before its children. If 824C<walkoptree_debug> (q.v.) has been called to turn debugging on then 825the method C<walkoptree_debug> is called on each op before METHOD is 826called. 827 828=item walkoptree_debug(DEBUG) 829 830Returns the current debugging flag for C<walkoptree>. If the optional 831DEBUG argument is non-zero, it sets the debugging flag to that. See 832the description of C<walkoptree> above for what the debugging flag 833does. 834 835=item walksymtable(SYMREF, METHOD, RECURSE) 836 837Walk the symbol table starting at SYMREF and call METHOD on each 838symbol visited. When the walk reached package symbols "Foo::" it 839invokes RECURSE and only recurses into the package if that sub 840returns true. 841 842=item svref_2object(SV) 843 844Takes any Perl variable and turns it into an object in the 845appropriate B::OP-derived or B::SV-derived class. Apart from functions 846such as C<main_root>, this is the primary way to get an initial 847"handle" on a internal perl data structure which can then be followed 848with the other access methods. 849 850=item ppname(OPNUM) 851 852Return the PP function name (e.g. "pp_add") of op number OPNUM. 853 854=item hash(STR) 855 856Returns a string in the form "0x..." representing the value of the 857internal hash function used by perl on string STR. 858 859=item cast_I32(I) 860 861Casts I to the internal I32 type used by that perl. 862 863 864=item minus_c 865 866Does the equivalent of the C<-c> command-line option. Obviously, this 867is only useful in a BEGIN block or else the flag is set too late. 868 869 870=item cstring(STR) 871 872Returns a double-quote-surrounded escaped version of STR which can 873be used as a string in C source code. 874 875=item class(OBJ) 876 877Returns the class of an object without the part of the classname 878preceding the first "::". This is used to turn "B::UNOP" into 879"UNOP" for example. 880 881=item threadsv_names 882 883In a perl compiled for threads, this returns a list of the special 884per-thread threadsv variables. 885 886=back 887 888=head1 AUTHOR 889 890Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> 891 892=cut 893