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^])/"^".chr(64 ^ ord($1))/e;
  70   return $name;
  71 }
  72
  73 sub B::IV::int_value {
  74   my ($self) = @_;
  75   return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV);
  76 }
  77
  78 my $debug;
  79 my $op_count = 0;
  80 my @parents = ();
  81
  82 sub debug {
  83     my ($class, $value) = @_;
  84     $debug = $value;
  85     walkoptree_debug($value);
  86 }
  87
  88 sub class {
  89     my $obj = shift;
  90     my $name = ref $obj;
  91     $name =~ s/^.*:://;
  92     return $name;
  93 }
  94
  95 sub parents { \@parents }
  96
  97 # For debugging
  98 sub peekop {
  99     my $op = shift;
 100     return sprintf("%s (0x%x) %s", class($op), $$op, $op->name);
 101 }
 102
 103 sub 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
 119 sub compile_stats {
 120     return "Total number of OPs processed: $op_count\n";
 121 }
 122
 123 sub 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
 130 my %symtable;
 131
 132 sub clearsym {
 133     %symtable = ();
 134 }
 135
 136 sub 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
 142 sub objsym {
 143     my $obj = shift;
 144     return $symtable{sprintf("sym_%x", $$obj)};
 145 }
 146
 147 sub 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
 198 sub 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
 284 XSLoader::load 'B';
 285
 286 1;
 287
 288 __END__
 289
 290 =head1 NAME
 291
 292 B - The Perl Compiler
 293
 294 =head1 SYNOPSIS
 295
 296         use B;
 297
 298 =head1 DESCRIPTION
 299
 300 The C<B> module supplies classes which allow a Perl program to delve
 301 into its own innards. It is the module used to implement the
 302 "backends" of the Perl compiler. Usage of the compiler does not
 303 require knowledge of this module: see the F<O> module for the
 304 user-visible part. The C<B> module is of use to those who want to
 305 write new compiler backends. This documentation assumes that the
 306 reader knows a fair amount about perl's internals including such
 307 things as SVs, OPs and the internal symbol table and syntax tree
 308 of a program.
 309
 310 =head1 OVERVIEW OF CLASSES
 311
 312 The C structures used by Perl's internals to hold SV and OP
 313 information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a
 314 class hierarchy and the C<B> module gives access to them via a true
 315 object hierarchy. Structure fields which point to other objects
 316 (whether types of SV or types of OP) are represented by the C<B>
 317 module as Perl objects of the appropriate class. The bulk of the C<B>
 318 module is the methods for accessing fields of these structures. Note
 319 that all access is read-only: you cannot modify the internals by
 320 using this module.
 321
 322 =head2 SV-RELATED CLASSES
 323
 324 B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV,
 325 B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in
 326 the obvious way to the underlying C structures of similar names. The
 327 inheritance hierarchy mimics the underlying C "inheritance". Access
 328 methods correspond to the underlying C macros for field access,
 329 usually with the leading "class indication" prefix removed (Sv, Av,
 330 Hv, ...). The leading prefix is only left in cases where its removal
 331 would cause a clash in method name. For example, C<GvREFCNT> stays
 332 as-is since its abbreviation would clash with the "superclass" method
 333 C<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
 351 Returns the value of the IV, I<interpreted as
 352 a signed integer>. This will be misleading
 353 if C<FLAGS & SVf_IVisUV>. Perhaps you want the
 354 C<int_value> method instead?
 355
 356 =item IVX
 357
 358 =item UVX
 359
 360 =item int_value
 361
 362 This method returns the value of the IV as an integer.
 363 It differs from C<IV> in that it returns the correct
 364 value regardless of whether it's stored signed or
 365 unsigned.
 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
 397 This method is the one you usually want. It constructs a
 398 string using the length and offset information in the struct:
 399 for ordinary scalars it will return the string that you'd see
 400 from Perl, even if it contains null characters.
 401
 402 =item PVX
 403
 404 This method is less often useful. It assumes that the string
 405 stored in the struct is null-terminated, and disregards the
 406 length information.
 407
 408 It is the appropriate method to use if you need to get the name
 409 of a lexical variable from a padname array. Lexical variable names
 410 are 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
 477 This method returns TRUE if the GP field of the GV is NULL.
 478
 479 =item NAME
 480
 481 =item SAFENAME
 482
 483 This method returns the name of the glob, but if the first
 484 character of the name is a control character, then it converts
 485 it to ^X first, so that *^G would return "^G" rather than "\cG".
 486
 487 It's useful if you want to print out the name of a variable.
 488 If you restrict yourself to globs which exist at compile-time
 489 then the result ought to be unambiguous, because code like
 490 C<${"^G"} = 1> is compiled as two ops - a constant string and
 491 a dereference (rv2gv) - so that the glob is created at runtime.
 492
 493 If 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 =item const_sv
 601
 602 =back
 603
 604 =head2 B::HV METHODS
 605
 606 =over 4
 607
 608 =item FILL
 609
 610 =item MAX
 611
 612 =item KEYS
 613
 614 =item RITER
 615
 616 =item NAME
 617
 618 =item PMROOT
 619
 620 =item ARRAY
 621
 622 =back
 623
 624 =head2 OP-RELATED CLASSES
 625
 626 B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP,
 627 B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
 628 These classes correspond in
 629 the obvious way to the underlying C structures of similar names. The
 630 inheritance hierarchy mimics the underlying C "inheritance". Access
 631 methods correspond to the underlying C structre field names, with the
 632 leading "class indication" prefix removed (op_).
 633
 634 =head2 B::OP METHODS
 635
 636 =over 4
 637
 638 =item next
 639
 640 =item sibling
 641
 642 =item name
 643
 644 This returns the op name as a string (e.g. "add", "rv2av").
 645
 646 =item ppaddr
 647
 648 This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]",
 649 "PL_ppaddr[OP_RV2AV]").
 650
 651 =item desc
 652
 653 This returns the op description from the global C PL_op_desc array
 654 (e.g. "addition" "array deref").
 655
 656 =item targ
 657
 658 =item type
 659
 660 =item seq
 661
 662 =item flags
 663
 664 =item private
 665
 666 =back
 667
 668 =head2 B::UNOP METHOD
 669
 670 =over 4
 671
 672 =item first
 673
 674 =back
 675
 676 =head2 B::BINOP METHOD
 677
 678 =over 4
 679
 680 =item last
 681
 682 =back
 683
 684 =head2 B::LOGOP METHOD
 685
 686 =over 4
 687
 688 =item other
 689
 690 =back
 691
 692 =head2 B::LISTOP METHOD
 693
 694 =over 4
 695
 696 =item children
 697
 698 =back
 699
 700 =head2 B::PMOP METHODS
 701
 702 =over 4
 703
 704 =item pmreplroot
 705
 706 =item pmreplstart
 707
 708 =item pmnext
 709
 710 =item pmregexp
 711
 712 =item pmflags
 713
 714 =item pmpermflags
 715
 716 =item precomp
 717
 718 =back
 719
 720 =head2 B::SVOP METHOD
 721
 722 =over 4
 723
 724 =item sv
 725
 726 =item gv
 727
 728 =back
 729
 730 =head2 B::PADOP METHOD
 731
 732 =over 4
 733
 734 =item padix
 735
 736 =back
 737
 738 =head2 B::PVOP METHOD
 739
 740 =over 4
 741
 742 =item pv
 743
 744 =back
 745
 746 =head2 B::LOOP METHODS
 747
 748 =over 4
 749
 750 =item redoop
 751
 752 =item nextop
 753
 754 =item lastop
 755
 756 =back
 757
 758 =head2 B::COP METHODS
 759
 760 =over 4
 761
 762 =item label
 763
 764 =item stash
 765
 766 =item file
 767
 768 =item cop_seq
 769
 770 =item arybase
 771
 772 =item line
 773
 774 =back
 775
 776 =head1 FUNCTIONS EXPORTED BY C<B>
 777
 778 The C<B> module exports a variety of functions: some are simple
 779 utility functions, others provide a Perl program with a way to
 780 get an initial "handle" on an internal object.
 781
 782 =over 4
 783
 784 =item main_cv
 785
 786 Return the (faked) CV corresponding to the main part of the Perl
 787 program.
 788
 789 =item init_av
 790
 791 Returns the AV object (i.e. in class B::AV) representing INIT blocks.
 792
 793 =item main_root
 794
 795 Returns the root op (i.e. an object in the appropriate B::OP-derived
 796 class) of the main part of the Perl program.
 797
 798 =item main_start
 799
 800 Returns the starting op of the main part of the Perl program.
 801
 802 =item comppadlist
 803
 804 Returns the AV object (i.e. in class B::AV) of the global comppadlist.
 805
 806 =item sv_undef
 807
 808 Returns the SV object corresponding to the C variable C<sv_undef>.
 809
 810 =item sv_yes
 811
 812 Returns the SV object corresponding to the C variable C<sv_yes>.
 813
 814 =item sv_no
 815
 816 Returns the SV object corresponding to the C variable C<sv_no>.
 817
 818 =item amagic_generation
 819
 820 Returns the SV object corresponding to the C variable C<amagic_generation>.
 821
 822 =item walkoptree(OP, METHOD)
 823
 824 Does a tree-walk of the syntax tree based at OP and calls METHOD on
 825 each op it visits. Each node is visited before its children. If
 826 C<walkoptree_debug> (q.v.) has been called to turn debugging on then
 827 the method C<walkoptree_debug> is called on each op before METHOD is
 828 called.
 829
 830 =item walkoptree_debug(DEBUG)
 831
 832 Returns the current debugging flag for C<walkoptree>. If the optional
 833 DEBUG argument is non-zero, it sets the debugging flag to that. See
 834 the description of C<walkoptree> above for what the debugging flag
 835 does.
 836
 837 =item walksymtable(SYMREF, METHOD, RECURSE)
 838
 839 Walk the symbol table starting at SYMREF and call METHOD on each
 840 symbol visited. When the walk reached package symbols "Foo::" it
 841 invokes RECURSE and only recurses into the package if that sub
 842 returns true.
 843
 844 =item svref_2object(SV)
 845
 846 Takes any Perl variable and turns it into an object in the
 847 appropriate B::OP-derived or B::SV-derived class. Apart from functions
 848 such as C<main_root>, this is the primary way to get an initial
 849 "handle" on a internal perl data structure which can then be followed
 850 with the other access methods.
 851
 852 =item ppname(OPNUM)
 853
 854 Return the PP function name (e.g. "pp_add") of op number OPNUM.
 855
 856 =item hash(STR)
 857
 858 Returns a string in the form "0x..." representing the value of the
 859 internal hash function used by perl on string STR.
 860
 861 =item cast_I32(I)
 862
 863 Casts I to the internal I32 type used by that perl.
 864
 865
 866 =item minus_c
 867
 868 Does the equivalent of the C<-c> command-line option. Obviously, this
 869 is only useful in a BEGIN block or else the flag is set too late.
 870
 871
 872 =item cstring(STR)
 873
 874 Returns a double-quote-surrounded escaped version of STR which can
 875 be used as a string in C source code.
 876
 877 =item class(OBJ)
 878
 879 Returns the class of an object without the part of the classname
 880 preceding the first "::". This is used to turn "B::UNOP" into
 881 "UNOP" for example.
 882
 883 =item threadsv_names
 884
 885 In a perl compiled for threads, this returns a list of the special
 886 per-thread threadsv variables.
 887
 888 =back
 889
 890 =head1 AUTHOR
 891
 892 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 893
 894 =cut