summaryrefslogtreecommitdiffstats
path: root/contrib/perl5/ext/B/B.pm
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/perl5/ext/B/B.pm')
-rw-r--r--contrib/perl5/ext/B/B.pm825
1 files changed, 825 insertions, 0 deletions
diff --git a/contrib/perl5/ext/B/B.pm b/contrib/perl5/ext/B/B.pm
new file mode 100644
index 0000000..d5137d4
--- /dev/null
+++ b/contrib/perl5/ext/B/B.pm
@@ -0,0 +1,825 @@
+# B.pm
+#
+# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+#
+package B;
+require DynaLoader;
+require Exporter;
+@ISA = qw(Exporter DynaLoader);
+@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
+ class peekop cast_I32 cstring cchar hash threadsv_names
+ main_root main_start main_cv svref_2object
+ walkoptree walkoptree_slow walkoptree_exec walksymtable
+ parents comppadlist sv_undef compile_stats timing_info);
+
+use strict;
+@B::SV::ISA = 'B::OBJECT';
+@B::NULL::ISA = 'B::SV';
+@B::PV::ISA = 'B::SV';
+@B::IV::ISA = 'B::SV';
+@B::NV::ISA = 'B::IV';
+@B::RV::ISA = 'B::SV';
+@B::PVIV::ISA = qw(B::PV B::IV);
+@B::PVNV::ISA = qw(B::PV B::NV);
+@B::PVMG::ISA = 'B::PVNV';
+@B::PVLV::ISA = 'B::PVMG';
+@B::BM::ISA = 'B::PVMG';
+@B::AV::ISA = 'B::PVMG';
+@B::GV::ISA = 'B::PVMG';
+@B::HV::ISA = 'B::PVMG';
+@B::CV::ISA = 'B::PVMG';
+@B::IO::ISA = 'B::PVMG';
+@B::FM::ISA = 'B::CV';
+
+@B::OP::ISA = 'B::OBJECT';
+@B::UNOP::ISA = 'B::OP';
+@B::BINOP::ISA = 'B::UNOP';
+@B::LOGOP::ISA = 'B::UNOP';
+@B::CONDOP::ISA = 'B::UNOP';
+@B::LISTOP::ISA = 'B::BINOP';
+@B::SVOP::ISA = 'B::OP';
+@B::GVOP::ISA = 'B::OP';
+@B::PVOP::ISA = 'B::OP';
+@B::CVOP::ISA = 'B::OP';
+@B::LOOP::ISA = 'B::LISTOP';
+@B::PMOP::ISA = 'B::LISTOP';
+@B::COP::ISA = 'B::OP';
+
+@B::SPECIAL::ISA = 'B::OBJECT';
+
+{
+ # Stop "-w" from complaining about the lack of a real B::OBJECT class
+ package B::OBJECT;
+}
+
+my $debug;
+my $op_count = 0;
+my @parents = ();
+
+sub debug {
+ my ($class, $value) = @_;
+ $debug = $value;
+ walkoptree_debug($value);
+}
+
+# sub OPf_KIDS;
+# add to .xs for perl5.002
+sub OPf_KIDS () { 4 }
+
+sub class {
+ my $obj = shift;
+ my $name = ref $obj;
+ $name =~ s/^.*:://;
+ return $name;
+}
+
+sub parents { \@parents }
+
+# For debugging
+sub peekop {
+ my $op = shift;
+ return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
+}
+
+sub walkoptree_slow {
+ my($op, $method, $level) = @_;
+ $op_count++; # just for statistics
+ $level ||= 0;
+ warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
+ $op->$method($level);
+ if ($$op && ($op->flags & OPf_KIDS)) {
+ my $kid;
+ unshift(@parents, $op);
+ for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
+ walkoptree_slow($kid, $method, $level + 1);
+ }
+ shift @parents;
+ }
+}
+
+sub compile_stats {
+ return "Total number of OPs processed: $op_count\n";
+}
+
+sub timing_info {
+ my ($sec, $min, $hr) = localtime;
+ my ($user, $sys) = times;
+ sprintf("%02d:%02d:%02d user=$user sys=$sys",
+ $hr, $min, $sec, $user, $sys);
+}
+
+my %symtable;
+sub savesym {
+ my ($obj, $value) = @_;
+# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
+ $symtable{sprintf("sym_%x", $$obj)} = $value;
+}
+
+sub objsym {
+ my $obj = shift;
+ return $symtable{sprintf("sym_%x", $$obj)};
+}
+
+sub walkoptree_exec {
+ my ($op, $method, $level) = @_;
+ my ($sym, $ppname);
+ my $prefix = " " x $level;
+ for (; $$op; $op = $op->next) {
+ $sym = objsym($op);
+ if (defined($sym)) {
+ print $prefix, "goto $sym\n";
+ return;
+ }
+ savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
+ $op->$method($level);
+ $ppname = $op->ppaddr;
+ if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
+ print $prefix, uc($1), " => {\n";
+ walkoptree_exec($op->other, $method, $level + 1);
+ print $prefix, "}\n";
+ } elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
+ my $pmreplstart = $op->pmreplstart;
+ if ($$pmreplstart) {
+ print $prefix, "PMREPLSTART => {\n";
+ walkoptree_exec($pmreplstart, $method, $level + 1);
+ print $prefix, "}\n";
+ }
+ } elsif ($ppname eq "pp_substcont") {
+ print $prefix, "SUBSTCONT => {\n";
+ walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
+ print $prefix, "}\n";
+ $op = $op->other;
+ } elsif ($ppname eq "pp_cond_expr") {
+ # pp_cond_expr never returns op_next
+ print $prefix, "TRUE => {\n";
+ walkoptree_exec($op->true, $method, $level + 1);
+ print $prefix, "}\n";
+ $op = $op->false;
+ redo;
+ } elsif ($ppname eq "pp_range") {
+ print $prefix, "TRUE => {\n";
+ walkoptree_exec($op->true, $method, $level + 1);
+ print $prefix, "}\n", $prefix, "FALSE => {\n";
+ walkoptree_exec($op->false, $method, $level + 1);
+ print $prefix, "}\n";
+ } elsif ($ppname eq "pp_enterloop") {
+ print $prefix, "REDO => {\n";
+ walkoptree_exec($op->redoop, $method, $level + 1);
+ print $prefix, "}\n", $prefix, "NEXT => {\n";
+ walkoptree_exec($op->nextop, $method, $level + 1);
+ print $prefix, "}\n", $prefix, "LAST => {\n";
+ walkoptree_exec($op->lastop, $method, $level + 1);
+ print $prefix, "}\n";
+ } elsif ($ppname eq "pp_subst") {
+ my $replstart = $op->pmreplstart;
+ if ($$replstart) {
+ print $prefix, "SUBST => {\n";
+ walkoptree_exec($replstart, $method, $level + 1);
+ print $prefix, "}\n";
+ }
+ }
+ }
+}
+
+sub walksymtable {
+ my ($symref, $method, $recurse, $prefix) = @_;
+ my $sym;
+ no strict 'vars';
+ local(*glob);
+ while (($sym, *glob) = each %$symref) {
+ if ($sym =~ /::$/) {
+ $sym = $prefix . $sym;
+ if ($sym ne "main::" && &$recurse($sym)) {
+ walksymtable(\%glob, $method, $recurse, $sym);
+ }
+ } else {
+ svref_2object(\*glob)->EGV->$method();
+ }
+ }
+}
+
+{
+ package B::Section;
+ my $output_fh;
+ my %sections;
+
+ sub new {
+ my ($class, $section, $symtable, $default) = @_;
+ $output_fh ||= FileHandle->new_tmpfile;
+ my $obj = bless [-1, $section, $symtable, $default], $class;
+ $sections{$section} = $obj;
+ return $obj;
+ }
+
+ sub get {
+ my ($class, $section) = @_;
+ return $sections{$section};
+ }
+
+ sub add {
+ my $section = shift;
+ while (defined($_ = shift)) {
+ print $output_fh "$section->[1]\t$_\n";
+ $section->[0]++;
+ }
+ }
+
+ sub index {
+ my $section = shift;
+ return $section->[0];
+ }
+
+ sub name {
+ my $section = shift;
+ return $section->[1];
+ }
+
+ sub symtable {
+ my $section = shift;
+ return $section->[2];
+ }
+
+ sub default {
+ my $section = shift;
+ return $section->[3];
+ }
+
+ sub output {
+ my ($section, $fh, $format) = @_;
+ my $name = $section->name;
+ my $sym = $section->symtable || {};
+ my $default = $section->default;
+
+ seek($output_fh, 0, 0);
+ while (<$output_fh>) {
+ chomp;
+ s/^(.*?)\t//;
+ if ($1 eq $name) {
+ s{(s\\_[0-9a-f]+)} {
+ exists($sym->{$1}) ? $sym->{$1} : $default;
+ }ge;
+ printf $fh $format, $_;
+ }
+ }
+ }
+}
+
+bootstrap B;
+
+1;
+
+__END__
+
+=head1 NAME
+
+B - The Perl Compiler
+
+=head1 SYNOPSIS
+
+ use B;
+
+=head1 DESCRIPTION
+
+The C<B> module supplies classes which allow a Perl program to delve
+into its own innards. It is the module used to implement the
+"backends" of the Perl compiler. Usage of the compiler does not
+require knowledge of this module: see the F<O> module for the
+user-visible part. The C<B> module is of use to those who want to
+write new compiler backends. This documentation assumes that the
+reader knows a fair amount about perl's internals including such
+things as SVs, OPs and the internal symbol table and syntax tree
+of a program.
+
+=head1 OVERVIEW OF CLASSES
+
+The C structures used by Perl's internals to hold SV and OP
+information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a
+class hierarchy and the C<B> module gives access to them via a true
+object hierarchy. Structure fields which point to other objects
+(whether types of SV or types of OP) are represented by the C<B>
+module as Perl objects of the appropriate class. The bulk of the C<B>
+module is the methods for accessing fields of these structures. Note
+that all access is read-only: you cannot modify the internals by
+using this module.
+
+=head2 SV-RELATED CLASSES
+
+B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV,
+B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in
+the obvious way to the underlying C structures of similar names. The
+inheritance hierarchy mimics the underlying C "inheritance". Access
+methods correspond to the underlying C macros for field access,
+usually with the leading "class indication" prefix removed (Sv, Av,
+Hv, ...). The leading prefix is only left in cases where its removal
+would cause a clash in method name. For example, C<GvREFCNT> stays
+as-is since its abbreviation would clash with the "superclass" method
+C<REFCNT> (corresponding to the C function C<SvREFCNT>).
+
+=head2 B::SV METHODS
+
+=over 4
+
+=item REFCNT
+
+=item FLAGS
+
+=back
+
+=head2 B::IV METHODS
+
+=over 4
+
+=item IV
+
+=item IVX
+
+=item needs64bits
+
+=item packiv
+
+=back
+
+=head2 B::NV METHODS
+
+=over 4
+
+=item NV
+
+=item NVX
+
+=back
+
+=head2 B::RV METHODS
+
+=over 4
+
+=item RV
+
+=back
+
+=head2 B::PV METHODS
+
+=over 4
+
+=item PV
+
+=back
+
+=head2 B::PVMG METHODS
+
+=over 4
+
+=item MAGIC
+
+=item SvSTASH
+
+=back
+
+=head2 B::MAGIC METHODS
+
+=over 4
+
+=item MOREMAGIC
+
+=item PRIVATE
+
+=item TYPE
+
+=item FLAGS
+
+=item OBJ
+
+=item PTR
+
+=back
+
+=head2 B::PVLV METHODS
+
+=over 4
+
+=item TARGOFF
+
+=item TARGLEN
+
+=item TYPE
+
+=item TARG
+
+=back
+
+=head2 B::BM METHODS
+
+=over 4
+
+=item USEFUL
+
+=item PREVIOUS
+
+=item RARE
+
+=item TABLE
+
+=back
+
+=head2 B::GV METHODS
+
+=over 4
+
+=item NAME
+
+=item STASH
+
+=item SV
+
+=item IO
+
+=item FORM
+
+=item AV
+
+=item HV
+
+=item EGV
+
+=item CV
+
+=item CVGEN
+
+=item LINE
+
+=item FILEGV
+
+=item GvREFCNT
+
+=item FLAGS
+
+=back
+
+=head2 B::IO METHODS
+
+=over 4
+
+=item LINES
+
+=item PAGE
+
+=item PAGE_LEN
+
+=item LINES_LEFT
+
+=item TOP_NAME
+
+=item TOP_GV
+
+=item FMT_NAME
+
+=item FMT_GV
+
+=item BOTTOM_NAME
+
+=item BOTTOM_GV
+
+=item SUBPROCESS
+
+=item IoTYPE
+
+=item IoFLAGS
+
+=back
+
+=head2 B::AV METHODS
+
+=over 4
+
+=item FILL
+
+=item MAX
+
+=item OFF
+
+=item ARRAY
+
+=item AvFLAGS
+
+=back
+
+=head2 B::CV METHODS
+
+=over 4
+
+=item STASH
+
+=item START
+
+=item ROOT
+
+=item GV
+
+=item FILEGV
+
+=item DEPTH
+
+=item PADLIST
+
+=item OUTSIDE
+
+=item XSUB
+
+=item XSUBANY
+
+=back
+
+=head2 B::HV METHODS
+
+=over 4
+
+=item FILL
+
+=item MAX
+
+=item KEYS
+
+=item RITER
+
+=item NAME
+
+=item PMROOT
+
+=item ARRAY
+
+=back
+
+=head2 OP-RELATED CLASSES
+
+B::OP, B::UNOP, B::BINOP, B::LOGOP, B::CONDOP, B::LISTOP, B::PMOP,
+B::SVOP, B::GVOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
+These classes correspond in
+the obvious way to the underlying C structures of similar names. The
+inheritance hierarchy mimics the underlying C "inheritance". Access
+methods correspond to the underlying C structre field names, with the
+leading "class indication" prefix removed (op_).
+
+=head2 B::OP METHODS
+
+=over 4
+
+=item next
+
+=item sibling
+
+=item ppaddr
+
+This returns the function name as a string (e.g. pp_add, pp_rv2av).
+
+=item desc
+
+This returns the op description from the global C op_desc array
+(e.g. "addition" "array deref").
+
+=item targ
+
+=item type
+
+=item seq
+
+=item flags
+
+=item private
+
+=back
+
+=head2 B::UNOP METHOD
+
+=over 4
+
+=item first
+
+=back
+
+=head2 B::BINOP METHOD
+
+=over 4
+
+=item last
+
+=back
+
+=head2 B::LOGOP METHOD
+
+=over 4
+
+=item other
+
+=back
+
+=head2 B::CONDOP METHODS
+
+=over 4
+
+=item true
+
+=item false
+
+=back
+
+=head2 B::LISTOP METHOD
+
+=over 4
+
+=item children
+
+=back
+
+=head2 B::PMOP METHODS
+
+=over 4
+
+=item pmreplroot
+
+=item pmreplstart
+
+=item pmnext
+
+=item pmregexp
+
+=item pmflags
+
+=item pmpermflags
+
+=item precomp
+
+=back
+
+=head2 B::SVOP METHOD
+
+=over 4
+
+=item sv
+
+=back
+
+=head2 B::GVOP METHOD
+
+=over 4
+
+=item gv
+
+=back
+
+=head2 B::PVOP METHOD
+
+=over 4
+
+=item pv
+
+=back
+
+=head2 B::LOOP METHODS
+
+=over 4
+
+=item redoop
+
+=item nextop
+
+=item lastop
+
+=back
+
+=head2 B::COP METHODS
+
+=over 4
+
+=item label
+
+=item stash
+
+=item filegv
+
+=item cop_seq
+
+=item arybase
+
+=item line
+
+=back
+
+=head1 FUNCTIONS EXPORTED BY C<B>
+
+The C<B> module exports a variety of functions: some are simple
+utility functions, others provide a Perl program with a way to
+get an initial "handle" on an internal object.
+
+=over 4
+
+=item main_cv
+
+Return the (faked) CV corresponding to the main part of the Perl
+program.
+
+=item main_root
+
+Returns the root op (i.e. an object in the appropriate B::OP-derived
+class) of the main part of the Perl program.
+
+=item main_start
+
+Returns the starting op of the main part of the Perl program.
+
+=item comppadlist
+
+Returns the AV object (i.e. in class B::AV) of the global comppadlist.
+
+=item sv_undef
+
+Returns the SV object corresponding to the C variable C<sv_undef>.
+
+=item sv_yes
+
+Returns the SV object corresponding to the C variable C<sv_yes>.
+
+=item sv_no
+
+Returns the SV object corresponding to the C variable C<sv_no>.
+
+=item walkoptree(OP, METHOD)
+
+Does a tree-walk of the syntax tree based at OP and calls METHOD on
+each op it visits. Each node is visited before its children. If
+C<walkoptree_debug> (q.v.) has been called to turn debugging on then
+the method C<walkoptree_debug> is called on each op before METHOD is
+called.
+
+=item walkoptree_debug(DEBUG)
+
+Returns the current debugging flag for C<walkoptree>. If the optional
+DEBUG argument is non-zero, it sets the debugging flag to that. See
+the description of C<walkoptree> above for what the debugging flag
+does.
+
+=item walksymtable(SYMREF, METHOD, RECURSE)
+
+Walk the symbol table starting at SYMREF and call METHOD on each
+symbol visited. When the walk reached package symbols "Foo::" it
+invokes RECURSE and only recurses into the package if that sub
+returns true.
+
+=item svref_2object(SV)
+
+Takes any Perl variable and turns it into an object in the
+appropriate B::OP-derived or B::SV-derived class. Apart from functions
+such as C<main_root>, this is the primary way to get an initial
+"handle" on a internal perl data structure which can then be followed
+with the other access methods.
+
+=item ppname(OPNUM)
+
+Return the PP function name (e.g. "pp_add") of op number OPNUM.
+
+=item hash(STR)
+
+Returns a string in the form "0x..." representing the value of the
+internal hash function used by perl on string STR.
+
+=item cast_I32(I)
+
+Casts I to the internal I32 type used by that perl.
+
+
+=item minus_c
+
+Does the equivalent of the C<-c> command-line option. Obviously, this
+is only useful in a BEGIN block or else the flag is set too late.
+
+
+=item cstring(STR)
+
+Returns a double-quote-surrounded escaped version of STR which can
+be used as a string in C source code.
+
+=item class(OBJ)
+
+Returns the class of an object without the part of the classname
+preceding the first "::". This is used to turn "B::UNOP" into
+"UNOP" for example.
+
+=item threadsv_names
+
+In a perl compiled for threads, this returns a list of the special
+per-thread threadsv variables.
+
+=item byteload_fh(FILEHANDLE)
+
+Load the contents of FILEHANDLE as bytecode. See documentation for
+the B<Bytecode> module in F<B::Backend> for how to generate bytecode.
+
+=back
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut
OpenPOWER on IntegriCloud