[p5sagit/p5-mst-13.2.git] / ext / B / B.pm

#      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(minus_c ppname
		class peekop cast_I32 cstring cchar hash threadsv_names
		main_root main_start main_cv svref_2object opnumber amagic_generation
		walkoptree walkoptree_slow walkoptree_exec walksymtable
		parents comppadlist sv_undef compile_stats timing_info init_av);
sub OPf_KIDS ();
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::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 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->name);
}

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 clearsym {
    %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->name;
	if ($ppname =~
	    /^(or|and|mapwhile|grepwhile|entertry|range|cond_expr)$/)
	{
	    print $prefix, uc($1), " => {\n";
	    walkoptree_exec($op->other, $method, $level + 1);
	    print $prefix, "}\n";
	} elsif ($ppname eq "match" || $ppname eq "subst") {
	    my $pmreplstart = $op->pmreplstart;
	    if ($$pmreplstart) {
		print $prefix, "PMREPLSTART => {\n";
		walkoptree_exec($pmreplstart, $method, $level + 1);
		print $prefix, "}\n";
	    }
	} elsif ($ppname eq "substcont") {
	    print $prefix, "SUBSTCONT => {\n";
	    walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
	    print $prefix, "}\n";
	    $op = $op->other;
	} elsif ($ppname eq "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 "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;
    my $ref;
    no strict 'vars';
    local(*glob);
    $prefix = '' unless defined $prefix;
    while (($sym, $ref) = each %$symref) {
	*glob = "*main::".$prefix.$sym;
	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

=item CvFLAGS

=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::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 name

This returns the op name as a string (e.g. "add", "rv2av").

=item ppaddr

This returns the function name as a string (e.g. Perl_pp_add,
Perl_pp_rv2av).

=item desc

This returns the op description from the global C PL_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::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 init_av

Returns the AV object (i.e. in class B::AV) representing INIT blocks.

=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 amagic_generation

Returns the SV object corresponding to the C variable C<amagic_generation>.

=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.

=back

=head1 AUTHOR

Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>

=cut
Commit	Line	Data
a798dbf2	1	# B.pm
a798dbf2	2	#
1a52ab62	3	# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
a798dbf2	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	require DynaLoader;
	10	require Exporter;
	11	@ISA = qw(Exporter DynaLoader);
e8edd1e6	12	@EXPORT_OK = qw(minus_c ppname
a798dbf2	13	class peekop cast_I32 cstring cchar hash threadsv_names
56eca212	14	main_root main_start main_cv svref_2object opnumber amagic_generation
a798dbf2	15	walkoptree walkoptree_slow walkoptree_exec walksymtable
31d7d75a	16	parents comppadlist sv_undef compile_stats timing_info init_av);
4c1f658f	17	sub OPf_KIDS ();
a798dbf2	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';
276493cb	34	@B::IO::ISA = 'B::PVMG';
276493cb	35	@B::FM::ISA = 'B::CV';
a798dbf2	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';
a798dbf2	41	@B::LISTOP::ISA = 'B::BINOP';
	42	@B::SVOP::ISA = 'B::OP';
	43	@B::GVOP::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
a798dbf2	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;
3f872cb9	79	return sprintf("%s (0x%x) %s", class($op), $$op, $op->name);
a798dbf2	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;
2b8dc4d2	110
	111	sub clearsym {
	112	%symtable = ();
	113	}
	114
a798dbf2	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);
3f872cb9	138	$ppname = $op->name;
1a67a97c	139	if ($ppname =~
3f872cb9	140	/^(or\|and\|mapwhile\|grepwhile\|entertry\|range\|cond_expr)$/)
1a67a97c	141	{
a798dbf2	142	print $prefix, uc($1), " => {\n";
	143	walkoptree_exec($op->other, $method, $level + 1);
	144	print $prefix, "}\n";
3f872cb9	145	} elsif ($ppname eq "match" \|\| $ppname eq "subst") {
a798dbf2	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	}
3f872cb9	152	} elsif ($ppname eq "substcont") {
a798dbf2	153	print $prefix, "SUBSTCONT => {\n";
	154	walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
	155	print $prefix, "}\n";
	156	$op = $op->other;
3f872cb9	157	} elsif ($ppname eq "enterloop") {
a798dbf2	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";
3f872cb9	165	} elsif ($ppname eq "subst") {
a798dbf2	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;
0cc1d052	179	my $ref;
a798dbf2	180	no strict 'vars';
a798dbf2	181	local(*glob);
0cc1d052	182	$prefix = '' unless defined $prefix;
0cc1d052	183	while (($sym, $ref) = each %$symref) {
8bac7e00	184	glob = "main::".$prefix.$sym;
a798dbf2	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	bootstrap B;
263
264	1;
7f20e9dd	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
1a52ab62	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 NAME
424
425	=item STASH
426
427	=item SV
428
429	=item IO
430
431	=item FORM
432
433	=item AV
434
435	=item HV
436
437	=item EGV
438
439	=item CV
440
441	=item CVGEN
442
443	=item LINE
444
445	=item FILEGV
446
447	=item GvREFCNT
448
449	=item FLAGS
450
451	=back
452
453	=head2 B::IO METHODS
454
455	=over 4
456
457	=item LINES
458
459	=item PAGE
460
461	=item PAGE_LEN
462
463	=item LINES_LEFT
464
465	=item TOP_NAME
466
467	=item TOP_GV
468
469	=item FMT_NAME
470
471	=item FMT_GV
472
473	=item BOTTOM_NAME
474
475	=item BOTTOM_GV
476
477	=item SUBPROCESS
478
479	=item IoTYPE
480
481	=item IoFLAGS
482
483	=back
484
485	=head2 B::AV METHODS
486
487	=over 4
488
489	=item FILL
490
491	=item MAX
492
493	=item OFF
494
495	=item ARRAY
496
497	=item AvFLAGS
498
499	=back
500
501	=head2 B::CV METHODS
502
503	=over 4
504
505	=item STASH
506
507	=item START
508
509	=item ROOT
510
511	=item GV
512
513	=item FILEGV
514
515	=item DEPTH
516
517	=item PADLIST
518
519	=item OUTSIDE
520
521	=item XSUB
522
523	=item XSUBANY
524
5cfd8ad4	525	=item CvFLAGS
5cfd8ad4	526
1a52ab62	527	=back
	528
	529	=head2 B::HV METHODS
	530
	531	=over 4
	532
	533	=item FILL
	534
	535	=item MAX
	536
	537	=item KEYS
	538
	539	=item RITER
	540
	541	=item NAME
	542
	543	=item PMROOT
	544
	545	=item ARRAY
	546
	547	=back
	548
	549	=head2 OP-RELATED CLASSES
	550
1a67a97c	551	B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP,
1a52ab62	552	B::SVOP, B::GVOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
	553	These classes correspond in
	554	the obvious way to the underlying C structures of similar names. The
	555	inheritance hierarchy mimics the underlying C "inheritance". Access
	556	methods correspond to the underlying C structre field names, with the
	557	leading "class indication" prefix removed (op_).
	558
	559	=head2 B::OP METHODS
	560
	561	=over 4
	562
	563	=item next
	564
	565	=item sibling
	566
3f872cb9	567	=item name
	568
	569	This returns the op name as a string (e.g. "add", "rv2av").
	570
1a52ab62	571	=item ppaddr
1a52ab62	572
3f872cb9	573	This returns the function name as a string (e.g. Perl_pp_add,
3f872cb9	574	Perl_pp_rv2av).
1a52ab62	575
	576	=item desc
	577
4369b173	578	This returns the op description from the global C PL_op_desc array
1a52ab62	579	(e.g. "addition" "array deref").
	580
	581	=item targ
	582
	583	=item type
	584
	585	=item seq
	586
	587	=item flags
	588
	589	=item private
	590
	591	=back
	592
	593	=head2 B::UNOP METHOD
	594
	595	=over 4
	596
	597	=item first
	598
	599	=back
	600
	601	=head2 B::BINOP METHOD
	602
	603	=over 4
	604
	605	=item last
	606
	607	=back
	608
	609	=head2 B::LOGOP METHOD
	610
	611	=over 4
	612
	613	=item other
	614
	615	=back
	616
1a52ab62	617	=head2 B::LISTOP METHOD
	618
	619	=over 4
	620
	621	=item children
	622
	623	=back
	624
	625	=head2 B::PMOP METHODS
	626
	627	=over 4
	628
	629	=item pmreplroot
	630
	631	=item pmreplstart
	632
	633	=item pmnext
	634
	635	=item pmregexp
	636
	637	=item pmflags
	638
	639	=item pmpermflags
	640
	641	=item precomp
	642
	643	=back
	644
	645	=head2 B::SVOP METHOD
	646
	647	=over 4
	648
	649	=item sv
	650
	651	=back
	652
	653	=head2 B::GVOP METHOD
	654
	655	=over 4
	656
	657	=item gv
	658
	659	=back
	660
	661	=head2 B::PVOP METHOD
	662
	663	=over 4
	664
	665	=item pv
	666
	667	=back
	668
	669	=head2 B::LOOP METHODS
	670
	671	=over 4
	672
	673	=item redoop
	674
	675	=item nextop
	676
	677	=item lastop
	678
	679	=back
	680
681	=head2 B::COP METHODS
682
683	=over 4
684
685	=item label
686
687	=item stash
688
689	=item filegv
690
691	=item cop_seq
692
693	=item arybase
694
695	=item line
696
697	=back
698
699	=head1 FUNCTIONS EXPORTED BY C<B>
700
701	The C<B> module exports a variety of functions: some are simple
702	utility functions, others provide a Perl program with a way to
703	get an initial "handle" on an internal object.
704
705	=over 4
706
707	=item main_cv
708
709	Return the (faked) CV corresponding to the main part of the Perl
710	program.
711
31d7d75a	712	=item init_av
	713
	714	Returns the AV object (i.e. in class B::AV) representing INIT blocks.
	715
1a52ab62	716	=item main_root
	717
	718	Returns the root op (i.e. an object in the appropriate B::OP-derived
	719	class) of the main part of the Perl program.
	720
	721	=item main_start
	722
	723	Returns the starting op of the main part of the Perl program.
	724
	725	=item comppadlist
	726
	727	Returns the AV object (i.e. in class B::AV) of the global comppadlist.
	728
	729	=item sv_undef
	730
	731	Returns the SV object corresponding to the C variable C<sv_undef>.
	732
	733	=item sv_yes
	734
	735	Returns the SV object corresponding to the C variable C<sv_yes>.
	736
	737	=item sv_no
	738
	739	Returns the SV object corresponding to the C variable C<sv_no>.
	740
56eca212	741	=item amagic_generation
	742
	743	Returns the SV object corresponding to the C variable C<amagic_generation>.
	744
1a52ab62	745	=item walkoptree(OP, METHOD)
	746
	747	Does a tree-walk of the syntax tree based at OP and calls METHOD on
	748	each op it visits. Each node is visited before its children. If
	749	C<walkoptree_debug> (q.v.) has been called to turn debugging on then
	750	the method C<walkoptree_debug> is called on each op before METHOD is
	751	called.
	752
	753	=item walkoptree_debug(DEBUG)
	754
	755	Returns the current debugging flag for C<walkoptree>. If the optional
	756	DEBUG argument is non-zero, it sets the debugging flag to that. See
	757	the description of C<walkoptree> above for what the debugging flag
	758	does.
	759
	760	=item walksymtable(SYMREF, METHOD, RECURSE)
	761
	762	Walk the symbol table starting at SYMREF and call METHOD on each
	763	symbol visited. When the walk reached package symbols "Foo::" it
	764	invokes RECURSE and only recurses into the package if that sub
	765	returns true.
	766
	767	=item svref_2object(SV)
	768
	769	Takes any Perl variable and turns it into an object in the
	770	appropriate B::OP-derived or B::SV-derived class. Apart from functions
	771	such as C<main_root>, this is the primary way to get an initial
	772	"handle" on a internal perl data structure which can then be followed
	773	with the other access methods.
	774
	775	=item ppname(OPNUM)
	776
	777	Return the PP function name (e.g. "pp_add") of op number OPNUM.
	778
	779	=item hash(STR)
	780
	781	Returns a string in the form "0x..." representing the value of the
	782	internal hash function used by perl on string STR.
	783
	784	=item cast_I32(I)
	785
	786	Casts I to the internal I32 type used by that perl.
	787
	788
	789	=item minus_c
	790
	791	Does the equivalent of the C<-c> command-line option. Obviously, this
	792	is only useful in a BEGIN block or else the flag is set too late.
	793
	794
	795	=item cstring(STR)
	796
	797	Returns a double-quote-surrounded escaped version of STR which can
	798	be used as a string in C source code.
	799
	800	=item class(OBJ)
	801
	802	Returns the class of an object without the part of the classname
	803	preceding the first "::". This is used to turn "B::UNOP" into
	804	"UNOP" for example.
	805
	806	=item threadsv_names
	807
	808	In a perl compiled for threads, this returns a list of the special
809	per-thread threadsv variables.
810
1a52ab62	811	=back
7f20e9dd	812
	813	=head1 AUTHOR
	814
	815	Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
	816
	817	=cut