[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_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::" && $sym ne "<none>::" && &$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

=item const_sv

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