[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;
use XSLoader ();
require Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(minus_c ppname save_BEGINs
		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
		begin_av init_av end_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, $_;
	    }
	}
    }
}

XSLoader::load '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 is_empty

This method returns TRUE if the GP field of the GV is NULL.

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

=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. "PL_ppaddr[OP_ADD]",
"PL_ppaddr[OP_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 file

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