[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
		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, $_;
	    }
	}
    }
}

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