[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::PADOP::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 FILE

=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 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::PADOP, 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

=item gv

=back

=head2 B::PADOP METHOD

=over 4

=item padix

=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';
a798dbf2	42	@B::SVOP::ISA = 'B::OP';
7934575e	43	@B::PADOP::ISA = 'B::OP';
a798dbf2	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
b195d487	445	=item FILE
b195d487	446
1a52ab62	447	=item FILEGV
	448
	449	=item GvREFCNT
	450
	451	=item FLAGS
	452
	453	=back
	454
	455	=head2 B::IO METHODS
	456
	457	=over 4
	458
	459	=item LINES
	460
	461	=item PAGE
	462
	463	=item PAGE_LEN
	464
	465	=item LINES_LEFT
	466
	467	=item TOP_NAME
	468
	469	=item TOP_GV
	470
	471	=item FMT_NAME
	472
	473	=item FMT_GV
	474
	475	=item BOTTOM_NAME
	476
	477	=item BOTTOM_GV
	478
	479	=item SUBPROCESS
	480
	481	=item IoTYPE
	482
	483	=item IoFLAGS
	484
	485	=back
	486
	487	=head2 B::AV METHODS
	488
	489	=over 4
	490
	491	=item FILL
	492
	493	=item MAX
	494
	495	=item OFF
	496
	497	=item ARRAY
	498
	499	=item AvFLAGS
	500
	501	=back
	502
	503	=head2 B::CV METHODS
	504
	505	=over 4
	506
	507	=item STASH
	508
	509	=item START
	510
511	=item ROOT
512
513	=item GV
514
1a52ab62	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,
7934575e	552	B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
1a52ab62	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
7934575e	651	=item gv
7934575e	652
1a52ab62	653	=back
1a52ab62	654
7934575e	655	=head2 B::PADOP METHOD
1a52ab62	656
	657	=over 4
	658
7934575e	659	=item padix
1a52ab62	660
	661	=back
	662
	663	=head2 B::PVOP METHOD
	664
	665	=over 4
	666
	667	=item pv
	668
	669	=back
	670
	671	=head2 B::LOOP METHODS
	672
	673	=over 4
	674
	675	=item redoop
	676
	677	=item nextop
	678
	679	=item lastop
	680
	681	=back
	682
	683	=head2 B::COP METHODS
	684
	685	=over 4
	686
	687	=item label
	688
	689	=item stash
	690
	691	=item filegv
	692
	693	=item cop_seq
	694
	695	=item arybase
	696
	697	=item line
	698
	699	=back
	700
	701	=head1 FUNCTIONS EXPORTED BY C<B>
	702
	703	The C<B> module exports a variety of functions: some are simple
	704	utility functions, others provide a Perl program with a way to
	705	get an initial "handle" on an internal object.
	706
	707	=over 4
	708
	709	=item main_cv
	710
	711	Return the (faked) CV corresponding to the main part of the Perl
	712	program.
	713
31d7d75a	714	=item init_av
	715
	716	Returns the AV object (i.e. in class B::AV) representing INIT blocks.
	717
1a52ab62	718	=item main_root
	719
	720	Returns the root op (i.e. an object in the appropriate B::OP-derived
	721	class) of the main part of the Perl program.
	722
	723	=item main_start
	724
	725	Returns the starting op of the main part of the Perl program.
	726
	727	=item comppadlist
	728
	729	Returns the AV object (i.e. in class B::AV) of the global comppadlist.
	730
	731	=item sv_undef
	732
	733	Returns the SV object corresponding to the C variable C<sv_undef>.
	734
	735	=item sv_yes
	736
	737	Returns the SV object corresponding to the C variable C<sv_yes>.
	738
	739	=item sv_no
	740
	741	Returns the SV object corresponding to the C variable C<sv_no>.
	742
56eca212	743	=item amagic_generation
	744
	745	Returns the SV object corresponding to the C variable C<amagic_generation>.
	746
1a52ab62	747	=item walkoptree(OP, METHOD)
	748
	749	Does a tree-walk of the syntax tree based at OP and calls METHOD on
	750	each op it visits. Each node is visited before its children. If
	751	C<walkoptree_debug> (q.v.) has been called to turn debugging on then
	752	the method C<walkoptree_debug> is called on each op before METHOD is
	753	called.
	754
	755	=item walkoptree_debug(DEBUG)
	756
	757	Returns the current debugging flag for C<walkoptree>. If the optional
	758	DEBUG argument is non-zero, it sets the debugging flag to that. See
	759	the description of C<walkoptree> above for what the debugging flag
	760	does.
	761
	762	=item walksymtable(SYMREF, METHOD, RECURSE)
	763
	764	Walk the symbol table starting at SYMREF and call METHOD on each
	765	symbol visited. When the walk reached package symbols "Foo::" it
	766	invokes RECURSE and only recurses into the package if that sub
	767	returns true.
	768
	769	=item svref_2object(SV)
	770
	771	Takes any Perl variable and turns it into an object in the
	772	appropriate B::OP-derived or B::SV-derived class. Apart from functions
	773	such as C<main_root>, this is the primary way to get an initial
	774	"handle" on a internal perl data structure which can then be followed
	775	with the other access methods.
	776
	777	=item ppname(OPNUM)
	778
	779	Return the PP function name (e.g. "pp_add") of op number OPNUM.
	780
	781	=item hash(STR)
	782
	783	Returns a string in the form "0x..." representing the value of the
	784	internal hash function used by perl on string STR.
	785
	786	=item cast_I32(I)
	787
	788	Casts I to the internal I32 type used by that perl.
	789
	790
	791	=item minus_c
	792
	793	Does the equivalent of the C<-c> command-line option. Obviously, this
	794	is only useful in a BEGIN block or else the flag is set too late.
	795
	796
	797	=item cstring(STR)
	798
	799	Returns a double-quote-surrounded escaped version of STR which can
	800	be used as a string in C source code.
	801
	802	=item class(OBJ)
	803
	804	Returns the class of an object without the part of the classname
	805	preceding the first "::". This is used to turn "B::UNOP" into
	806	"UNOP" for example.
	807
	808	=item threadsv_names
	809
	810	In a perl compiled for threads, this returns a list of the special
811	per-thread threadsv variables.
812
1a52ab62	813	=back
7f20e9dd	814
	815	=head1 AUTHOR
	816
	817	Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
	818
	819	=cut