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