lib/perl5/5.6.1/msys/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 =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
 624 B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP,
 625 B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
 626 These classes correspond in
 627 the obvious way to the underlying C structures of similar names. The
 628 inheritance hierarchy mimics the underlying C "inheritance". Access
 629 methods correspond to the underlying C structre field names, with the
 630 leading "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
 642 This returns the op name as a string (e.g. "add", "rv2av").
 643
 644 =item ppaddr
 645
 646 This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]",
 647 "PL_ppaddr[OP_RV2AV]").
 648
 649 =item desc
 650
 651 This 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
 776 The C<B> module exports a variety of functions: some are simple
 777 utility functions, others provide a Perl program with a way to
 778 get an initial "handle" on an internal object.
 779
 780 =over 4
 781
 782 =item main_cv
 783
 784 Return the (faked) CV corresponding to the main part of the Perl
 785 program.
 786
 787 =item init_av
 788
 789 Returns the AV object (i.e. in class B::AV) representing INIT blocks.
 790
 791 =item main_root
 792
 793 Returns the root op (i.e. an object in the appropriate B::OP-derived
 794 class) of the main part of the Perl program.
 795
 796 =item main_start
 797
 798 Returns the starting op of the main part of the Perl program.
 799
 800 =item comppadlist
 801
 802 Returns the AV object (i.e. in class B::AV) of the global comppadlist.
 803
 804 =item sv_undef
 805
 806 Returns the SV object corresponding to the C variable C<sv_undef>.
 807
 808 =item sv_yes
 809
 810 Returns the SV object corresponding to the C variable C<sv_yes>.
 811
 812 =item sv_no
 813
 814 Returns the SV object corresponding to the C variable C<sv_no>.
 815
 816 =item amagic_generation
 817
 818 Returns the SV object corresponding to the C variable C<amagic_generation>.
 819
 820 =item walkoptree(OP, METHOD)
 821
 822 Does a tree-walk of the syntax tree based at OP and calls METHOD on
 823 each op it visits. Each node is visited before its children. If
 824 C<walkoptree_debug> (q.v.) has been called to turn debugging on then
 825 the method C<walkoptree_debug> is called on each op before METHOD is
 826 called.
 827
 828 =item walkoptree_debug(DEBUG)
 829
 830 Returns the current debugging flag for C<walkoptree>. If the optional
 831 DEBUG argument is non-zero, it sets the debugging flag to that. See
 832 the description of C<walkoptree> above for what the debugging flag
 833 does.
 834
 835 =item walksymtable(SYMREF, METHOD, RECURSE)
 836
 837 Walk the symbol table starting at SYMREF and call METHOD on each
 838 symbol visited. When the walk reached package symbols "Foo::" it
 839 invokes RECURSE and only recurses into the package if that sub
 840 returns true.
 841
 842 =item svref_2object(SV)
 843
 844 Takes any Perl variable and turns it into an object in the
 845 appropriate B::OP-derived or B::SV-derived class. Apart from functions
 846 such 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
 848 with the other access methods.
 849
 850 =item ppname(OPNUM)
 851
 852 Return the PP function name (e.g. "pp_add") of op number OPNUM.
 853
 854 =item hash(STR)
 855
 856 Returns a string in the form "0x..." representing the value of the
 857 internal hash function used by perl on string STR.
 858
 859 =item cast_I32(I)
 860
 861 Casts I to the internal I32 type used by that perl.
 862
 863
 864 =item minus_c
 865
 866 Does the equivalent of the C<-c> command-line option. Obviously, this
 867 is only useful in a BEGIN block or else the flag is set too late.
 868
 869
 870 =item cstring(STR)
 871
 872 Returns a double-quote-surrounded escaped version of STR which can
 873 be used as a string in C source code.
 874
 875 =item class(OBJ)
 876
 877 Returns the class of an object without the part of the classname
 878 preceding the first "::". This is used to turn "B::UNOP" into
 879 "UNOP" for example.
 880
 881 =item threadsv_names
 882
 883 In a perl compiled for threads, this returns a list of the special
 884 per-thread threadsv variables.
 885
 886 =back
 887
 888 =head1 AUTHOR
 889
 890 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 891
 892 =cut