[p5sagit/p5-mst-13.2.git] / ext / B / B.pm

#      B.pm
#
#      Copyright (c) 1996, 1997, 1998 Malcolm Beattie
#
#      You may distribute under the terms of either the GNU General Public
#      License or the Artistic License, as specified in the README file.
#
package B;
require DynaLoader;
require Exporter;
@ISA = qw(Exporter DynaLoader);
@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
		class peekop cast_I32 cstring cchar hash threadsv_names
		main_root main_start main_cv svref_2object opnumber
		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::CONDOP::ISA = 'B::UNOP';
@B::LISTOP::ISA = 'B::BINOP';
@B::SVOP::ISA = 'B::OP';
@B::GVOP::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->ppaddr);
}

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 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->ppaddr;
	if ($ppname =~ /^pp_(or|and|mapwhile|grepwhile|entertry)$/) {
	    print $prefix, uc($1), " => {\n";
	    walkoptree_exec($op->other, $method, $level + 1);
	    print $prefix, "}\n";
	} elsif ($ppname eq "pp_match" || $ppname eq "pp_subst") {
	    my $pmreplstart = $op->pmreplstart;
	    if ($$pmreplstart) {
		print $prefix, "PMREPLSTART => {\n";
		walkoptree_exec($pmreplstart, $method, $level + 1);
		print $prefix, "}\n";
	    }
	} elsif ($ppname eq "pp_substcont") {
	    print $prefix, "SUBSTCONT => {\n";
	    walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
	    print $prefix, "}\n";
	    $op = $op->other;
	} elsif ($ppname eq "pp_cond_expr") {
	    # pp_cond_expr never returns op_next
	    print $prefix, "TRUE => {\n";
	    walkoptree_exec($op->true, $method, $level + 1);
	    print $prefix, "}\n";
	    $op = $op->false;
	    redo;
	} elsif ($ppname eq "pp_range") {
	    print $prefix, "TRUE => {\n";
	    walkoptree_exec($op->true, $method, $level + 1);
	    print $prefix, "}\n", $prefix, "FALSE => {\n";
	    walkoptree_exec($op->false, $method, $level + 1);
	    print $prefix, "}\n";
	} elsif ($ppname eq "pp_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 "pp_subst") {
	    my $replstart = $op->pmreplstart;
	    if ($$replstart) {
		print $prefix, "SUBST => {\n";
		walkoptree_exec($replstart, $method, $level + 1);
		print $prefix, "}\n";
	    }
	}
    }
}

sub walksymtable {
    my ($symref, $method, $recurse, $prefix) = @_;
    my $sym;
    my $ref;
    no strict 'vars';
    local(*glob);
    $prefix = '' unless defined $prefix;
    while (($sym, $ref) = each %$symref) {
	*glob = "*main::".$prefix.$sym;
	if ($sym =~ /::$/) {
	    $sym = $prefix . $sym;
	    if ($sym ne "main::" && &$recurse($sym)) {
		walksymtable(\%glob, $method, $recurse, $sym);
	    }
	} else {
	    svref_2object(\*glob)->EGV->$method();
	}
    }
}

{
    package B::Section;
    my $output_fh;
    my %sections;
    
    sub new {
	my ($class, $section, $symtable, $default) = @_;
	$output_fh ||= FileHandle->new_tmpfile;
	my $obj = bless [-1, $section, $symtable, $default], $class;
	$sections{$section} = $obj;
	return $obj;
    }
    
    sub get {
	my ($class, $section) = @_;
	return $sections{$section};
    }

    sub add {
	my $section = shift;
	while (defined($_ = shift)) {
	    print $output_fh "$section->[1]\t$_\n";
	    $section->[0]++;
	}
    }

    sub index {
	my $section = shift;
	return $section->[0];
    }

    sub name {
	my $section = shift;
	return $section->[1];
    }

    sub symtable {
	my $section = shift;
	return $section->[2];
    }
	
    sub default {
	my $section = shift;
	return $section->[3];
    }
	
    sub output {
	my ($section, $fh, $format) = @_;
	my $name = $section->name;
	my $sym = $section->symtable || {};
	my $default = $section->default;

	seek($output_fh, 0, 0);
	while (<$output_fh>) {
	    chomp;
	    s/^(.*?)\t//;
	    if ($1 eq $name) {
		s{(s\\_[0-9a-f]+)} {
		    exists($sym->{$1}) ? $sym->{$1} : $default;
		}ge;
		printf $fh $format, $_;
	    }
	}
    }
}

bootstrap B;

1;

__END__

=head1 NAME

B - The Perl Compiler

=head1 SYNOPSIS

	use B;

=head1 DESCRIPTION

The C<B> module supplies classes which allow a Perl program to delve
into its own innards. It is the module used to implement the
"backends" of the Perl compiler. Usage of the compiler does not
require knowledge of this module: see the F<O> module for the
user-visible part. The C<B> module is of use to those who want to
write new compiler backends. This documentation assumes that the
reader knows a fair amount about perl's internals including such
things as SVs, OPs and the internal symbol table and syntax tree
of a program.

=head1 OVERVIEW OF CLASSES

The C structures used by Perl's internals to hold SV and OP
information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a
class hierarchy and the C<B> module gives access to them via a true
object hierarchy. Structure fields which point to other objects
(whether types of SV or types of OP) are represented by the C<B>
module as Perl objects of the appropriate class. The bulk of the C<B>
module is the methods for accessing fields of these structures. Note
that all access is read-only: you cannot modify the internals by
using this module.

=head2 SV-RELATED CLASSES

B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV,
B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in
the obvious way to the underlying C structures of similar names. The
inheritance hierarchy mimics the underlying C "inheritance". Access
methods correspond to the underlying C macros for field access,
usually with the leading "class indication" prefix removed (Sv, Av,
Hv, ...). The leading prefix is only left in cases where its removal
would cause a clash in method name. For example, C<GvREFCNT> stays
as-is since its abbreviation would clash with the "superclass" method
C<REFCNT> (corresponding to the C function C<SvREFCNT>).

=head2 B::SV METHODS

=over 4

=item REFCNT

=item FLAGS

=back

=head2 B::IV METHODS

=over 4

=item IV

=item IVX

=item needs64bits

=item packiv

=back

=head2 B::NV METHODS

=over 4

=item NV

=item NVX

=back

=head2 B::RV METHODS

=over 4

=item RV

=back

=head2 B::PV METHODS

=over 4

=item PV

=back

=head2 B::PVMG METHODS

=over 4

=item MAGIC

=item SvSTASH

=back

=head2 B::MAGIC METHODS

=over 4

=item MOREMAGIC

=item PRIVATE

=item TYPE

=item FLAGS

=item OBJ

=item PTR

=back

=head2 B::PVLV METHODS

=over 4

=item TARGOFF

=item TARGLEN

=item TYPE

=item TARG

=back

=head2 B::BM METHODS

=over 4

=item USEFUL

=item PREVIOUS

=item RARE

=item TABLE

=back

=head2 B::GV METHODS

=over 4

=item NAME

=item STASH

=item SV

=item IO

=item FORM

=item AV

=item HV

=item EGV

=item CV

=item CVGEN

=item LINE

=item 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 FILEGV

=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::CONDOP, B::LISTOP, B::PMOP,
B::SVOP, B::GVOP, 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 ppaddr

This returns the function name as a string (e.g. pp_add, 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::CONDOP METHODS

=over 4

=item true

=item false

=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

=back

=head2 B::GVOP METHOD

=over 4

=item gv

=back

=head2 B::PVOP METHOD

=over 4

=item pv

=back

=head2 B::LOOP METHODS

=over 4

=item redoop

=item nextop

=item lastop

=back

=head2 B::COP METHODS

=over 4

=item label

=item stash

=item filegv

=item cop_seq

=item arybase

=item line

=back

=head1 FUNCTIONS EXPORTED BY C<B>

The C<B> module exports a variety of functions: some are simple
utility functions, others provide a Perl program with a way to
get an initial "handle" on an internal object.

=over 4

=item main_cv

Return the (faked) CV corresponding to the main part of the Perl
program.

=item init_av

Returns the AV object (i.e. in class B::AV) representing INIT blocks.

=item main_root

Returns the root op (i.e. an object in the appropriate B::OP-derived
class) of the main part of the Perl program.

=item main_start

Returns the starting op of the main part of the Perl program.

=item comppadlist

Returns the AV object (i.e. in class B::AV) of the global comppadlist.

=item sv_undef

Returns the SV object corresponding to the C variable C<sv_undef>.

=item sv_yes

Returns the SV object corresponding to the C variable C<sv_yes>.

=item sv_no

Returns the SV object corresponding to the C variable C<sv_no>.

=item 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.

=item byteload_fh(FILEHANDLE)

Load the contents of FILEHANDLE as bytecode. See documentation for
the B<Bytecode> module in F<B::Backend> for how to generate bytecode.

=back

=head1 AUTHOR

Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>

=cut
Commit	Line	Data
a798dbf2	1	# B.pm
a798dbf2	2	#
1a52ab62	3	# Copyright (c) 1996, 1997, 1998 Malcolm Beattie
a798dbf2	4	#
	5	# You may distribute under the terms of either the GNU General Public
	6	# License or the Artistic License, as specified in the README file.
	7	#
	8	package B;
	9	require DynaLoader;
	10	require Exporter;
	11	@ISA = qw(Exporter DynaLoader);
	12	@EXPORT_OK = qw(byteload_fh byteload_string minus_c ppname
	13	class peekop cast_I32 cstring cchar hash threadsv_names
0cc1d052	14	main_root main_start main_cv svref_2object opnumber
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';
	41	@B::CONDOP::ISA = 'B::UNOP';
	42	@B::LISTOP::ISA = 'B::BINOP';
	43	@B::SVOP::ISA = 'B::OP';
	44	@B::GVOP::ISA = 'B::OP';
	45	@B::PVOP::ISA = 'B::OP';
	46	@B::CVOP::ISA = 'B::OP';
	47	@B::LOOP::ISA = 'B::LISTOP';
	48	@B::PMOP::ISA = 'B::LISTOP';
	49	@B::COP::ISA = 'B::OP';
	50
	51	@B::SPECIAL::ISA = 'B::OBJECT';
	52
	53	{
	54	# Stop "-w" from complaining about the lack of a real B::OBJECT class
	55	package B::OBJECT;
	56	}
	57
	58	my $debug;
	59	my $op_count = 0;
	60	my @parents = ();
	61
	62	sub debug {
	63	my ($class, $value) = @_;
	64	$debug = $value;
	65	walkoptree_debug($value);
	66	}
	67
a798dbf2	68	sub class {
	69	my $obj = shift;
	70	my $name = ref $obj;
	71	$name =~ s/^.*:://;
	72	return $name;
	73	}
	74
	75	sub parents { \@parents }
	76
	77	# For debugging
	78	sub peekop {
	79	my $op = shift;
	80	return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
	81	}
	82
	83	sub walkoptree_slow {
	84	my($op, $method, $level) = @_;
	85	$op_count++; # just for statistics
	86	$level \|\|= 0;
	87	warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
	88	$op->$method($level);
	89	if ($$op && ($op->flags & OPf_KIDS)) {
	90	my $kid;
	91	unshift(@parents, $op);
	92	for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
	93	walkoptree_slow($kid, $method, $level + 1);
	94	}
	95	shift @parents;
	96	}
	97	}
	98
	99	sub compile_stats {
	100	return "Total number of OPs processed: $op_count\n";
	101	}
	102
	103	sub timing_info {
	104	my ($sec, $min, $hr) = localtime;
	105	my ($user, $sys) = times;
	106	sprintf("%02d:%02d:%02d user=$user sys=$sys",
	107	$hr, $min, $sec, $user, $sys);
	108	}
	109
	110	my %symtable;
	111	sub savesym {
	112	my ($obj, $value) = @_;
	113	# warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
	114	$symtable{sprintf("sym_%x", $$obj)} = $value;
	115	}
	116
	117	sub objsym {
	118	my $obj = shift;
	119	return $symtable{sprintf("sym_%x", $$obj)};
	120	}
	121
	122	sub walkoptree_exec {
	123	my ($op, $method, $level) = @_;
	124	my ($sym, $ppname);
	125	my $prefix = " " x $level;
	126	for (; $$op; $op = $op->next) {
	127	$sym = objsym($op);
	128	if (defined($sym)) {
	129	print $prefix, "goto $sym\n";
	130	return;
	131	}
132	savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
133	$op->$method($level);
134	$ppname = $op->ppaddr;
135	if ($ppname =~ /^pp_(or\|and\|mapwhile\|grepwhile\|entertry)$/) {
136	print $prefix, uc($1), " => {\n";
137	walkoptree_exec($op->other, $method, $level + 1);
138	print $prefix, "}\n";
139	} elsif ($ppname eq "pp_match" \|\| $ppname eq "pp_subst") {
140	my $pmreplstart = $op->pmreplstart;
141	if ($$pmreplstart) {
142	print $prefix, "PMREPLSTART => {\n";
143	walkoptree_exec($pmreplstart, $method, $level + 1);
144	print $prefix, "}\n";
145	}
146	} elsif ($ppname eq "pp_substcont") {
147	print $prefix, "SUBSTCONT => {\n";
148	walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
149	print $prefix, "}\n";
150	$op = $op->other;
151	} elsif ($ppname eq "pp_cond_expr") {
152	# pp_cond_expr never returns op_next
153	print $prefix, "TRUE => {\n";
154	walkoptree_exec($op->true, $method, $level + 1);
155	print $prefix, "}\n";
156	$op = $op->false;
157	redo;
158	} elsif ($ppname eq "pp_range") {
159	print $prefix, "TRUE => {\n";
160	walkoptree_exec($op->true, $method, $level + 1);
161	print $prefix, "}\n", $prefix, "FALSE => {\n";
162	walkoptree_exec($op->false, $method, $level + 1);
163	print $prefix, "}\n";
164	} elsif ($ppname eq "pp_enterloop") {
165	print $prefix, "REDO => {\n";
166	walkoptree_exec($op->redoop, $method, $level + 1);
167	print $prefix, "}\n", $prefix, "NEXT => {\n";
168	walkoptree_exec($op->nextop, $method, $level + 1);
169	print $prefix, "}\n", $prefix, "LAST => {\n";
170	walkoptree_exec($op->lastop, $method, $level + 1);
171	print $prefix, "}\n";
172	} elsif ($ppname eq "pp_subst") {
173	my $replstart = $op->pmreplstart;
174	if ($$replstart) {
175	print $prefix, "SUBST => {\n";
176	walkoptree_exec($replstart, $method, $level + 1);
177	print $prefix, "}\n";
178	}
179	}
180	}
181	}
182
183	sub walksymtable {
184	my ($symref, $method, $recurse, $prefix) = @_;
185	my $sym;
0cc1d052	186	my $ref;
a798dbf2	187	no strict 'vars';
a798dbf2	188	local(*glob);
0cc1d052	189	$prefix = '' unless defined $prefix;
0cc1d052	190	while (($sym, $ref) = each %$symref) {
8bac7e00	191	glob = "main::".$prefix.$sym;
a798dbf2	192	if ($sym =~ /::$/) {
	193	$sym = $prefix . $sym;
	194	if ($sym ne "main::" && &$recurse($sym)) {
	195	walksymtable(\%glob, $method, $recurse, $sym);
	196	}
	197	} else {
	198	svref_2object(\*glob)->EGV->$method();
	199	}
	200	}
	201	}
	202
	203	{
	204	package B::Section;
	205	my $output_fh;
	206	my %sections;
	207
	208	sub new {
	209	my ($class, $section, $symtable, $default) = @_;
	210	$output_fh \|\|= FileHandle->new_tmpfile;
	211	my $obj = bless [-1, $section, $symtable, $default], $class;
	212	$sections{$section} = $obj;
	213	return $obj;
	214	}
	215
	216	sub get {
	217	my ($class, $section) = @_;
	218	return $sections{$section};
	219	}
	220
	221	sub add {
	222	my $section = shift;
	223	while (defined($_ = shift)) {
	224	print $output_fh "$section->[1]\t$_\n";
	225	$section->[0]++;
	226	}
	227	}
	228
	229	sub index {
	230	my $section = shift;
	231	return $section->[0];
	232	}
	233
	234	sub name {
	235	my $section = shift;
	236	return $section->[1];
	237	}
	238
	239	sub symtable {
	240	my $section = shift;
	241	return $section->[2];
	242	}
	243
	244	sub default {
	245	my $section = shift;
	246	return $section->[3];
	247	}
	248
	249	sub output {
	250	my ($section, $fh, $format) = @_;
	251	my $name = $section->name;
	252	my $sym = $section->symtable \|\| {};
	253	my $default = $section->default;
	254
	255	seek($output_fh, 0, 0);
256	while (<$output_fh>) {
257	chomp;
258	s/^(.*?)\t//;
259	if ($1 eq $name) {
260	s{(s\\_[0-9a-f]+)} {
261	exists($sym->{$1}) ? $sym->{$1} : $default;
262	}ge;
263	printf $fh $format, $_;
264	}
265	}
266	}
267	}
268
269	bootstrap B;
270
271	1;
7f20e9dd	272
	273	__END__
	274
	275	=head1 NAME
	276
	277	B - The Perl Compiler
	278
	279	=head1 SYNOPSIS
	280
	281	use B;
	282
	283	=head1 DESCRIPTION
	284
1a52ab62	285	The C<B> module supplies classes which allow a Perl program to delve
	286	into its own innards. It is the module used to implement the
	287	"backends" of the Perl compiler. Usage of the compiler does not
	288	require knowledge of this module: see the F<O> module for the
	289	user-visible part. The C<B> module is of use to those who want to
	290	write new compiler backends. This documentation assumes that the
	291	reader knows a fair amount about perl's internals including such
	292	things as SVs, OPs and the internal symbol table and syntax tree
	293	of a program.
	294
	295	=head1 OVERVIEW OF CLASSES
	296
	297	The C structures used by Perl's internals to hold SV and OP
	298	information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a
	299	class hierarchy and the C<B> module gives access to them via a true
	300	object hierarchy. Structure fields which point to other objects
	301	(whether types of SV or types of OP) are represented by the C<B>
	302	module as Perl objects of the appropriate class. The bulk of the C<B>
	303	module is the methods for accessing fields of these structures. Note
	304	that all access is read-only: you cannot modify the internals by
	305	using this module.
	306
	307	=head2 SV-RELATED CLASSES
	308
	309	B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV,
	310	B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in
	311	the obvious way to the underlying C structures of similar names. The
	312	inheritance hierarchy mimics the underlying C "inheritance". Access
	313	methods correspond to the underlying C macros for field access,
	314	usually with the leading "class indication" prefix removed (Sv, Av,
	315	Hv, ...). The leading prefix is only left in cases where its removal
	316	would cause a clash in method name. For example, C<GvREFCNT> stays
	317	as-is since its abbreviation would clash with the "superclass" method
	318	C<REFCNT> (corresponding to the C function C<SvREFCNT>).
	319
	320	=head2 B::SV METHODS
	321
	322	=over 4
	323
	324	=item REFCNT
	325
	326	=item FLAGS
	327
	328	=back
	329
	330	=head2 B::IV METHODS
	331
	332	=over 4
	333
	334	=item IV
	335
	336	=item IVX
	337
	338	=item needs64bits
	339
	340	=item packiv
	341
	342	=back
	343
	344	=head2 B::NV METHODS
	345
	346	=over 4
	347
	348	=item NV
349
350	=item NVX
351
352	=back
353
354	=head2 B::RV METHODS
355
356	=over 4
357
358	=item RV
359
360	=back
361
362	=head2 B::PV METHODS
363
364	=over 4
365
366	=item PV
367
368	=back
369
370	=head2 B::PVMG METHODS
371
372	=over 4
373
374	=item MAGIC
375
376	=item SvSTASH
377
378	=back
379
380	=head2 B::MAGIC METHODS
381
382	=over 4
383
384	=item MOREMAGIC
385
386	=item PRIVATE
387
388	=item TYPE
389
390	=item FLAGS
391
392	=item OBJ
393
394	=item PTR
395
396	=back
397
398	=head2 B::PVLV METHODS
399
400	=over 4
401
402	=item TARGOFF
403
404	=item TARGLEN
405
406	=item TYPE
407
408	=item TARG
409
410	=back
411
412	=head2 B::BM METHODS
413
414	=over 4
415
416	=item USEFUL
417
418	=item PREVIOUS
419
420	=item RARE
421
422	=item TABLE
423
424	=back
425
426	=head2 B::GV METHODS
427
428	=over 4
429
430	=item NAME
431
432	=item STASH
433
434	=item SV
435
436	=item IO
437
438	=item FORM
439
440	=item AV
441
442	=item HV
443
444	=item EGV
445
446	=item CV
447
448	=item CVGEN
449
450	=item LINE
451
452	=item FILEGV
453
454	=item GvREFCNT
455
456	=item FLAGS
457
458	=back
459
460	=head2 B::IO METHODS
461
462	=over 4
463
464	=item LINES
465
466	=item PAGE
467
468	=item PAGE_LEN
469
470	=item LINES_LEFT
471
472	=item TOP_NAME
473
474	=item TOP_GV
475
476	=item FMT_NAME
477
478	=item FMT_GV
479
480	=item BOTTOM_NAME
481
482	=item BOTTOM_GV
483
484	=item SUBPROCESS
485
486	=item IoTYPE
487
488	=item IoFLAGS
489
490	=back
491
492	=head2 B::AV METHODS
493
494	=over 4
495
496	=item FILL
497
498	=item MAX
499
500	=item OFF
501
502	=item ARRAY
503
504	=item AvFLAGS
505
506	=back
507
508	=head2 B::CV METHODS
509
510	=over 4
511
512	=item STASH
513
514	=item START
515
516	=item ROOT
517
518	=item GV
519
520	=item FILEGV
521
522	=item DEPTH
523
524	=item PADLIST
525
526	=item OUTSIDE
527
528	=item XSUB
529
530	=item XSUBANY
531
5cfd8ad4	532	=item CvFLAGS
5cfd8ad4	533
1a52ab62	534	=back
	535
	536	=head2 B::HV METHODS
	537
	538	=over 4
	539
	540	=item FILL
	541
	542	=item MAX
	543
	544	=item KEYS
	545
	546	=item RITER
	547
	548	=item NAME
	549
	550	=item PMROOT
	551
	552	=item ARRAY
	553
	554	=back
	555
	556	=head2 OP-RELATED CLASSES
	557
	558	B::OP, B::UNOP, B::BINOP, B::LOGOP, B::CONDOP, B::LISTOP, B::PMOP,
	559	B::SVOP, B::GVOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
	560	These classes correspond in
	561	the obvious way to the underlying C structures of similar names. The
	562	inheritance hierarchy mimics the underlying C "inheritance". Access
	563	methods correspond to the underlying C structre field names, with the
	564	leading "class indication" prefix removed (op_).
	565
	566	=head2 B::OP METHODS
	567
	568	=over 4
	569
	570	=item next
	571
	572	=item sibling
	573
	574	=item ppaddr
	575
	576	This returns the function name as a string (e.g. pp_add, pp_rv2av).
	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
	619	=head2 B::CONDOP METHODS
	620
	621	=over 4
	622
	623	=item true
	624
	625	=item false
	626
	627	=back
	628
	629	=head2 B::LISTOP METHOD
	630
	631	=over 4
	632
	633	=item children
	634
	635	=back
	636
	637	=head2 B::PMOP METHODS
	638
	639	=over 4
	640
	641	=item pmreplroot
	642
	643	=item pmreplstart
	644
645	=item pmnext
646
647	=item pmregexp
648
649	=item pmflags
650
651	=item pmpermflags
652
653	=item precomp
654
655	=back
656
657	=head2 B::SVOP METHOD
658
659	=over 4
660
661	=item sv
662
663	=back
664
665	=head2 B::GVOP METHOD
666
667	=over 4
668
669	=item gv
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
701	=item filegv
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
	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
819	=item byteload_fh(FILEHANDLE)
820
821	Load the contents of FILEHANDLE as bytecode. See documentation for
822	the B<Bytecode> module in F<B::Backend> for how to generate bytecode.
823
824	=back
7f20e9dd	825
	826	=head1 AUTHOR
	827
	828	Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
	829
	830	=cut