[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 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. Perl_pp_add,
Perl_pp_rv2av).

=item desc

This returns the op description from the global C PL_op_desc array
(e.g. "addition" "array deref").

=item targ

=item type

=item seq

=item flags

=item private

=back

=head2 B::UNOP METHOD

=over 4

=item first

=back

=head2 B::BINOP METHOD

=over 4

=item last

=back

=head2 B::LOGOP METHOD

=over 4

=item other

=back

=head2 B::LISTOP METHOD

=over 4

=item children

=back

=head2 B::PMOP METHODS

=over 4

=item pmreplroot

=item pmreplstart

=item pmnext

=item pmregexp

=item pmflags

=item pmpermflags

=item precomp

=back

=head2 B::SVOP METHOD

=over 4

=item sv

=item gv

=back

=head2 B::PADOP METHOD

=over 4

=item padix

=back

=head2 B::PVOP METHOD

=over 4

=item pv

=back

=head2 B::LOOP METHODS

=over 4

=item redoop

=item nextop

=item lastop

=back

=head2 B::COP METHODS

=over 4

=item label

=item stash

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