[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);

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 OPf_KIDS;
# add to .xs for perl5.002
sub OPf_KIDS () { 4 }

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 = $ref;
	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);
a798dbf2	17
	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
	68	# sub OPf_KIDS;
	69	# add to .xs for perl5.002
	70	sub OPf_KIDS () { 4 }
	71
	72	sub class {
	73	my $obj = shift;
	74	my $name = ref $obj;
	75	$name =~ s/^.*:://;
	76	return $name;
	77	}
	78
	79	sub parents { \@parents }
	80
	81	# For debugging
	82	sub peekop {
	83	my $op = shift;
	84	return sprintf("%s (0x%x) %s", class($op), $$op, $op->ppaddr);
	85	}
	86
	87	sub walkoptree_slow {
	88	my($op, $method, $level) = @_;
	89	$op_count++; # just for statistics
	90	$level \|\|= 0;
	91	warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
	92	$op->$method($level);
	93	if ($$op && ($op->flags & OPf_KIDS)) {
	94	my $kid;
	95	unshift(@parents, $op);
	96	for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
	97	walkoptree_slow($kid, $method, $level + 1);
	98	}
	99	shift @parents;
100	}
101	}
102
103	sub compile_stats {
104	return "Total number of OPs processed: $op_count\n";
105	}
106
107	sub timing_info {
108	my ($sec, $min, $hr) = localtime;
109	my ($user, $sys) = times;
110	sprintf("%02d:%02d:%02d user=$user sys=$sys",
111	$hr, $min, $sec, $user, $sys);
112	}
113
114	my %symtable;
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);
138	$ppname = $op->ppaddr;
139	if ($ppname =~ /^pp_(or\|and\|mapwhile\|grepwhile\|entertry)$/) {
140	print $prefix, uc($1), " => {\n";
141	walkoptree_exec($op->other, $method, $level + 1);
142	print $prefix, "}\n";
143	} elsif ($ppname eq "pp_match" \|\| $ppname eq "pp_subst") {
144	my $pmreplstart = $op->pmreplstart;
145	if ($$pmreplstart) {
146	print $prefix, "PMREPLSTART => {\n";
147	walkoptree_exec($pmreplstart, $method, $level + 1);
148	print $prefix, "}\n";
149	}
150	} elsif ($ppname eq "pp_substcont") {
151	print $prefix, "SUBSTCONT => {\n";
152	walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
153	print $prefix, "}\n";
154	$op = $op->other;
155	} elsif ($ppname eq "pp_cond_expr") {
156	# pp_cond_expr never returns op_next
157	print $prefix, "TRUE => {\n";
158	walkoptree_exec($op->true, $method, $level + 1);
159	print $prefix, "}\n";
160	$op = $op->false;
161	redo;
162	} elsif ($ppname eq "pp_range") {
163	print $prefix, "TRUE => {\n";
164	walkoptree_exec($op->true, $method, $level + 1);
165	print $prefix, "}\n", $prefix, "FALSE => {\n";
166	walkoptree_exec($op->false, $method, $level + 1);
167	print $prefix, "}\n";
168	} elsif ($ppname eq "pp_enterloop") {
169	print $prefix, "REDO => {\n";
170	walkoptree_exec($op->redoop, $method, $level + 1);
171	print $prefix, "}\n", $prefix, "NEXT => {\n";
172	walkoptree_exec($op->nextop, $method, $level + 1);
173	print $prefix, "}\n", $prefix, "LAST => {\n";
174	walkoptree_exec($op->lastop, $method, $level + 1);
175	print $prefix, "}\n";
176	} elsif ($ppname eq "pp_subst") {
177	my $replstart = $op->pmreplstart;
178	if ($$replstart) {
179	print $prefix, "SUBST => {\n";
180	walkoptree_exec($replstart, $method, $level + 1);
181	print $prefix, "}\n";
182	}
183	}
184	}
185	}
186
187	sub walksymtable {
188	my ($symref, $method, $recurse, $prefix) = @_;
189	my $sym;
0cc1d052	190	my $ref;
a798dbf2	191	no strict 'vars';
a798dbf2	192	local(*glob);
0cc1d052	193	$prefix = '' unless defined $prefix;
	194	while (($sym, $ref) = each %$symref) {
	195	*glob = $ref;
a798dbf2	196	if ($sym =~ /::$/) {
	197	$sym = $prefix . $sym;
	198	if ($sym ne "main::" && &$recurse($sym)) {
	199	walksymtable(\%glob, $method, $recurse, $sym);
	200	}
	201	} else {
	202	svref_2object(\*glob)->EGV->$method();
	203	}
	204	}
	205	}
	206
	207	{
	208	package B::Section;
	209	my $output_fh;
	210	my %sections;
	211
	212	sub new {
	213	my ($class, $section, $symtable, $default) = @_;
	214	$output_fh \|\|= FileHandle->new_tmpfile;
	215	my $obj = bless [-1, $section, $symtable, $default], $class;
	216	$sections{$section} = $obj;
	217	return $obj;
	218	}
	219
	220	sub get {
	221	my ($class, $section) = @_;
	222	return $sections{$section};
	223	}
	224
	225	sub add {
	226	my $section = shift;
	227	while (defined($_ = shift)) {
	228	print $output_fh "$section->[1]\t$_\n";
	229	$section->[0]++;
	230	}
	231	}
	232
	233	sub index {
	234	my $section = shift;
	235	return $section->[0];
	236	}
	237
	238	sub name {
	239	my $section = shift;
	240	return $section->[1];
	241	}
	242
	243	sub symtable {
	244	my $section = shift;
	245	return $section->[2];
	246	}
	247
	248	sub default {
	249	my $section = shift;
	250	return $section->[3];
	251	}
	252
	253	sub output {
	254	my ($section, $fh, $format) = @_;
	255	my $name = $section->name;
	256	my $sym = $section->symtable \|\| {};
	257	my $default = $section->default;
	258
	259	seek($output_fh, 0, 0);
260	while (<$output_fh>) {
261	chomp;
262	s/^(.*?)\t//;
263	if ($1 eq $name) {
264	s{(s\\_[0-9a-f]+)} {
265	exists($sym->{$1}) ? $sym->{$1} : $default;
266	}ge;
267	printf $fh $format, $_;
268	}
269	}
270	}
271	}
272
273	bootstrap B;
274
275	1;
7f20e9dd	276
	277	__END__
	278
	279	=head1 NAME
	280
	281	B - The Perl Compiler
	282
	283	=head1 SYNOPSIS
	284
	285	use B;
	286
	287	=head1 DESCRIPTION
	288
1a52ab62	289	The C<B> module supplies classes which allow a Perl program to delve
	290	into its own innards. It is the module used to implement the
	291	"backends" of the Perl compiler. Usage of the compiler does not
	292	require knowledge of this module: see the F<O> module for the
	293	user-visible part. The C<B> module is of use to those who want to
	294	write new compiler backends. This documentation assumes that the
	295	reader knows a fair amount about perl's internals including such
	296	things as SVs, OPs and the internal symbol table and syntax tree
	297	of a program.
	298
	299	=head1 OVERVIEW OF CLASSES
	300
	301	The C structures used by Perl's internals to hold SV and OP
	302	information (PVIV, AV, HV, ..., OP, SVOP, UNOP, ...) are modelled on a
	303	class hierarchy and the C<B> module gives access to them via a true
	304	object hierarchy. Structure fields which point to other objects
	305	(whether types of SV or types of OP) are represented by the C<B>
	306	module as Perl objects of the appropriate class. The bulk of the C<B>
	307	module is the methods for accessing fields of these structures. Note
	308	that all access is read-only: you cannot modify the internals by
	309	using this module.
	310
	311	=head2 SV-RELATED CLASSES
	312
	313	B::IV, B::NV, B::RV, B::PV, B::PVIV, B::PVNV, B::PVMG, B::BM, B::PVLV,
	314	B::AV, B::HV, B::CV, B::GV, B::FM, B::IO. These classes correspond in
	315	the obvious way to the underlying C structures of similar names. The
	316	inheritance hierarchy mimics the underlying C "inheritance". Access
	317	methods correspond to the underlying C macros for field access,
	318	usually with the leading "class indication" prefix removed (Sv, Av,
	319	Hv, ...). The leading prefix is only left in cases where its removal
	320	would cause a clash in method name. For example, C<GvREFCNT> stays
	321	as-is since its abbreviation would clash with the "superclass" method
	322	C<REFCNT> (corresponding to the C function C<SvREFCNT>).
	323
	324	=head2 B::SV METHODS
	325
	326	=over 4
	327
	328	=item REFCNT
	329
	330	=item FLAGS
	331
	332	=back
	333
	334	=head2 B::IV METHODS
	335
	336	=over 4
	337
	338	=item IV
	339
	340	=item IVX
	341
	342	=item needs64bits
	343
	344	=item packiv
	345
	346	=back
	347
	348	=head2 B::NV METHODS
	349
	350	=over 4
	351
	352	=item NV
353
354	=item NVX
355
356	=back
357
358	=head2 B::RV METHODS
359
360	=over 4
361
362	=item RV
363
364	=back
365
366	=head2 B::PV METHODS
367
368	=over 4
369
370	=item PV
371
372	=back
373
374	=head2 B::PVMG METHODS
375
376	=over 4
377
378	=item MAGIC
379
380	=item SvSTASH
381
382	=back
383
384	=head2 B::MAGIC METHODS
385
386	=over 4
387
388	=item MOREMAGIC
389
390	=item PRIVATE
391
392	=item TYPE
393
394	=item FLAGS
395
396	=item OBJ
397
398	=item PTR
399
400	=back
401
402	=head2 B::PVLV METHODS
403
404	=over 4
405
406	=item TARGOFF
407
408	=item TARGLEN
409
410	=item TYPE
411
412	=item TARG
413
414	=back
415
416	=head2 B::BM METHODS
417
418	=over 4
419
420	=item USEFUL
421
422	=item PREVIOUS
423
424	=item RARE
425
426	=item TABLE
427
428	=back
429
430	=head2 B::GV METHODS
431
432	=over 4
433
434	=item NAME
435
436	=item STASH
437
438	=item SV
439
440	=item IO
441
442	=item FORM
443
444	=item AV
445
446	=item HV
447
448	=item EGV
449
450	=item CV
451
452	=item CVGEN
453
454	=item LINE
455
456	=item FILEGV
457
458	=item GvREFCNT
459
460	=item FLAGS
461
462	=back
463
464	=head2 B::IO METHODS
465
466	=over 4
467
468	=item LINES
469
470	=item PAGE
471
472	=item PAGE_LEN
473
474	=item LINES_LEFT
475
476	=item TOP_NAME
477
478	=item TOP_GV
479
480	=item FMT_NAME
481
482	=item FMT_GV
483
484	=item BOTTOM_NAME
485
486	=item BOTTOM_GV
487
488	=item SUBPROCESS
489
490	=item IoTYPE
491
492	=item IoFLAGS
493
494	=back
495
496	=head2 B::AV METHODS
497
498	=over 4
499
500	=item FILL
501
502	=item MAX
503
504	=item OFF
505
506	=item ARRAY
507
508	=item AvFLAGS
509
510	=back
511
512	=head2 B::CV METHODS
513
514	=over 4
515
516	=item STASH
517
518	=item START
519
520	=item ROOT
521
522	=item GV
523
524	=item FILEGV
525
526	=item DEPTH
527
528	=item PADLIST
529
530	=item OUTSIDE
531
532	=item XSUB
533
534	=item XSUBANY
535
5cfd8ad4	536	=item CvFLAGS
5cfd8ad4	537
1a52ab62	538	=back
	539
	540	=head2 B::HV METHODS
	541
	542	=over 4
	543
	544	=item FILL
	545
	546	=item MAX
	547
	548	=item KEYS
	549
	550	=item RITER
	551
	552	=item NAME
	553
	554	=item PMROOT
	555
	556	=item ARRAY
	557
	558	=back
	559
	560	=head2 OP-RELATED CLASSES
	561
	562	B::OP, B::UNOP, B::BINOP, B::LOGOP, B::CONDOP, B::LISTOP, B::PMOP,
	563	B::SVOP, B::GVOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
	564	These classes correspond in
	565	the obvious way to the underlying C structures of similar names. The
	566	inheritance hierarchy mimics the underlying C "inheritance". Access
	567	methods correspond to the underlying C structre field names, with the
	568	leading "class indication" prefix removed (op_).
	569
	570	=head2 B::OP METHODS
	571
	572	=over 4
	573
	574	=item next
	575
	576	=item sibling
	577
	578	=item ppaddr
	579
	580	This returns the function name as a string (e.g. pp_add, pp_rv2av).
	581
	582	=item desc
	583
4369b173	584	This returns the op description from the global C PL_op_desc array
1a52ab62	585	(e.g. "addition" "array deref").
	586
	587	=item targ
	588
	589	=item type
	590
	591	=item seq
	592
	593	=item flags
	594
	595	=item private
	596
	597	=back
	598
	599	=head2 B::UNOP METHOD
	600
	601	=over 4
	602
	603	=item first
	604
	605	=back
	606
	607	=head2 B::BINOP METHOD
	608
	609	=over 4
	610
	611	=item last
	612
	613	=back
	614
	615	=head2 B::LOGOP METHOD
	616
	617	=over 4
	618
	619	=item other
	620
	621	=back
	622
	623	=head2 B::CONDOP METHODS
	624
	625	=over 4
	626
	627	=item true
	628
	629	=item false
	630
	631	=back
	632
	633	=head2 B::LISTOP METHOD
	634
	635	=over 4
	636
	637	=item children
	638
	639	=back
	640
	641	=head2 B::PMOP METHODS
	642
	643	=over 4
	644
	645	=item pmreplroot
	646
	647	=item pmreplstart
	648
649	=item pmnext
650
651	=item pmregexp
652
653	=item pmflags
654
655	=item pmpermflags
656
657	=item precomp
658
659	=back
660
661	=head2 B::SVOP METHOD
662
663	=over 4
664
665	=item sv
666
667	=back
668
669	=head2 B::GVOP METHOD
670
671	=over 4
672
673	=item gv
674
675	=back
676
677	=head2 B::PVOP METHOD
678
679	=over 4
680
681	=item pv
682
683	=back
684
685	=head2 B::LOOP METHODS
686
687	=over 4
688
689	=item redoop
690
691	=item nextop
692
693	=item lastop
694
695	=back
696
697	=head2 B::COP METHODS
698
699	=over 4
700
701	=item label
702
703	=item stash
704
705	=item filegv
706
707	=item cop_seq
708
709	=item arybase
710
711	=item line
712
713	=back
714
715	=head1 FUNCTIONS EXPORTED BY C<B>
716
717	The C<B> module exports a variety of functions: some are simple
718	utility functions, others provide a Perl program with a way to
719	get an initial "handle" on an internal object.
720
721	=over 4
722
723	=item main_cv
724
725	Return the (faked) CV corresponding to the main part of the Perl
726	program.
727
31d7d75a	728	=item init_av
	729
	730	Returns the AV object (i.e. in class B::AV) representing INIT blocks.
	731
1a52ab62	732	=item main_root
	733
	734	Returns the root op (i.e. an object in the appropriate B::OP-derived
	735	class) of the main part of the Perl program.
	736
	737	=item main_start
	738
	739	Returns the starting op of the main part of the Perl program.
	740
	741	=item comppadlist
	742
	743	Returns the AV object (i.e. in class B::AV) of the global comppadlist.
	744
	745	=item sv_undef
	746
	747	Returns the SV object corresponding to the C variable C<sv_undef>.
	748
	749	=item sv_yes
	750
	751	Returns the SV object corresponding to the C variable C<sv_yes>.
	752
	753	=item sv_no
	754
	755	Returns the SV object corresponding to the C variable C<sv_no>.
	756
	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
823	=item byteload_fh(FILEHANDLE)
824
825	Load the contents of FILEHANDLE as bytecode. See documentation for
826	the B<Bytecode> module in F<B::Backend> for how to generate bytecode.
827
828	=back
7f20e9dd	829
	830	=head1 AUTHOR
	831
	832	Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
	833
	834	=cut