ext/B/B.pm

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