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

# walkoptree_slow comes from B.pm (you are there),
# walkoptree comes from B.xs
@EXPORT_OK = qw(minus_c ppname save_BEGINs
		class peekop cast_I32 cstring cchar hash threadsv_names
		main_root main_start main_cv svref_2object opnumber
		amagic_generation
		walkoptree_slow walkoptree walkoptree_exec walksymtable
		parents comppadlist sv_undef compile_stats timing_info
		begin_av init_av end_av);

sub OPf_KIDS ();
use strict;
@B::SV::ISA = 'B::OBJECT';
@B::NULL::ISA = 'B::SV';
@B::PV::ISA = 'B::SV';
@B::IV::ISA = 'B::SV';
@B::NV::ISA = 'B::IV';
@B::RV::ISA = 'B::SV';
@B::PVIV::ISA = qw(B::PV B::IV);
@B::PVNV::ISA = qw(B::PV B::NV);
@B::PVMG::ISA = 'B::PVNV';
@B::PVLV::ISA = 'B::PVMG';
@B::BM::ISA = 'B::PVMG';
@B::AV::ISA = 'B::PVMG';
@B::GV::ISA = 'B::PVMG';
@B::HV::ISA = 'B::PVMG';
@B::CV::ISA = 'B::PVMG';
@B::IO::ISA = 'B::PVMG';
@B::FM::ISA = 'B::CV';

@B::OP::ISA = 'B::OBJECT';
@B::UNOP::ISA = 'B::OP';
@B::BINOP::ISA = 'B::UNOP';
@B::LOGOP::ISA = 'B::UNOP';
@B::LISTOP::ISA = 'B::BINOP';
@B::SVOP::ISA = 'B::OP';
@B::PADOP::ISA = 'B::OP';
@B::PVOP::ISA = 'B::OP';
@B::CVOP::ISA = 'B::OP';
@B::LOOP::ISA = 'B::LISTOP';
@B::PMOP::ISA = 'B::LISTOP';
@B::COP::ISA = 'B::OP';

@B::SPECIAL::ISA = 'B::OBJECT';

{
    # Stop "-w" from complaining about the lack of a real B::OBJECT class
    package B::OBJECT;
}

sub B::GV::SAFENAME {
  my $name = (shift())->NAME;
  $name =~ s/^([\cA-\cZ])/"^".chr(64 + ord($1))/e;
  return $name;
}

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) = @_;
    $level ||= 0;
    my ($sym, $ppname);
    my $prefix = "    " x $level;
    for (; $$op; $op = $op->next) {
	$sym = objsym($op);
	if (defined($sym)) {
	    print $prefix, "goto $sym\n";
	    return;
	}
	savesym($op, sprintf("%s (0x%lx)", class($op), $$op));
	$op->$method($level);
	$ppname = $op->name;
	if ($ppname =~
	    /^(or|and|mapwhile|grepwhile|entertry|range|cond_expr)$/)
	{
	    print $prefix, uc($1), " => {\n";
	    walkoptree_exec($op->other, $method, $level + 1);
	    print $prefix, "}\n";
	} elsif ($ppname eq "match" || $ppname eq "subst") {
	    my $pmreplstart = $op->pmreplstart;
	    if ($$pmreplstart) {
		print $prefix, "PMREPLSTART => {\n";
		walkoptree_exec($pmreplstart, $method, $level + 1);
		print $prefix, "}\n";
	    }
	} elsif ($ppname eq "substcont") {
	    print $prefix, "SUBSTCONT => {\n";
	    walkoptree_exec($op->other->pmreplstart, $method, $level + 1);
	    print $prefix, "}\n";
	    $op = $op->other;
	} elsif ($ppname eq "enterloop") {
	    print $prefix, "REDO => {\n";
	    walkoptree_exec($op->redoop, $method, $level + 1);
	    print $prefix, "}\n", $prefix, "NEXT => {\n";
	    walkoptree_exec($op->nextop, $method, $level + 1);
	    print $prefix, "}\n", $prefix, "LAST => {\n";
	    walkoptree_exec($op->lastop,  $method, $level + 1);
	    print $prefix, "}\n";
	} elsif ($ppname eq "subst") {
	    my $replstart = $op->pmreplstart;
	    if ($$replstart) {
		print $prefix, "SUBST => {\n";
		walkoptree_exec($replstart, $method, $level + 1);
		print $prefix, "}\n";
	    }
	}
    }
}

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

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

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

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

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

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

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

XSLoader::load 'B';

1;

__END__

=head1 NAME

B - The Perl Compiler

=head1 SYNOPSIS

	use B;

=head1 DESCRIPTION

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

=head1 OVERVIEW OF CLASSES

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

=head2 SV-RELATED CLASSES

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

=head2 B::SV METHODS

=over 4

=item REFCNT

=item FLAGS

=back

=head2 B::IV METHODS

=over 4

=item IV

=item IVX

=item needs64bits

=item packiv

=back

=head2 B::NV METHODS

=over 4

=item NV

=item NVX

=back

=head2 B::RV METHODS

=over 4

=item RV

=back

=head2 B::PV METHODS

=over 4

=item PV

This method is the one you usually want. It constructs a
string using the length and offset information in the struct:
for ordinary scalars it will return the string that you'd see
from Perl, even if it contains null characters.

=item PVX

This method is less often useful. It assumes that the string
stored in the struct is null-terminated, and disregards the
length information.

It is the appropriate method to use if you need to get the name
of a lexical variable from a padname array. Lexical variable names
are always stored with a null terminator, and the length field
(SvCUR) is overloaded for other purposes and can't be relied on here.

=back

=head2 B::PVMG METHODS

=over 4

=item MAGIC

=item SvSTASH

=back

=head2 B::MAGIC METHODS

=over 4

=item MOREMAGIC

=item PRIVATE

=item TYPE

=item FLAGS

=item OBJ

=item PTR

=back

=head2 B::PVLV METHODS

=over 4

=item TARGOFF

=item TARGLEN

=item TYPE

=item TARG

=back

=head2 B::BM METHODS

=over 4

=item USEFUL

=item PREVIOUS

=item RARE

=item TABLE

=back

=head2 B::GV METHODS

=over 4

=item is_empty

This method returns TRUE if the GP field of the GV is NULL.

=item NAME

=item SAFENAME

This method returns the name of the glob, but if the first
character of the name is a control character, then it converts
it to ^X first, so that *^G would return "^G" rather than "\cG".

It's useful if you want to print out the name of a variable.
If you restrict yourself to globs which exist at compile-time
then the result ought to be unambiguous, because code like
C<${"^G"} = 1> is compiled as two ops - a constant string and
a dereference (rv2gv) - so that the glob is created at runtime.

If you're working with globs at runtime, and need to disambiguate
*^G from *{"^G"}, then you should use the raw NAME method.

=item STASH

=item SV

=item IO

=item FORM

=item AV

=item HV

=item EGV

=item CV

=item CVGEN

=item LINE

=item FILE

=item FILEGV

=item GvREFCNT

=item FLAGS

=back

=head2 B::IO METHODS

=over 4

=item LINES

=item PAGE

=item PAGE_LEN

=item LINES_LEFT

=item TOP_NAME

=item TOP_GV

=item FMT_NAME

=item FMT_GV

=item BOTTOM_NAME

=item BOTTOM_GV

=item SUBPROCESS

=item IoTYPE

=item IoFLAGS

=back

=head2 B::AV METHODS

=over 4

=item FILL

=item MAX

=item OFF

=item ARRAY

=item AvFLAGS

=back

=head2 B::CV METHODS

=over 4

=item STASH

=item START

=item ROOT

=item GV

=item FILE

=item DEPTH

=item PADLIST

=item OUTSIDE

=item XSUB

=item XSUBANY

=item CvFLAGS

=item const_sv

=back

=head2 B::HV METHODS

=over 4

=item FILL

=item MAX

=item KEYS

=item RITER

=item NAME

=item PMROOT

=item ARRAY

=back

=head2 OP-RELATED CLASSES

B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP,
B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
These classes correspond in
the obvious way to the underlying C structures of similar names. The
inheritance hierarchy mimics the underlying C "inheritance". Access
methods correspond to the underlying C structre field names, with the
leading "class indication" prefix removed (op_).

=head2 B::OP METHODS

=over 4

=item next

=item sibling

=item name

This returns the op name as a string (e.g. "add", "rv2av").

=item ppaddr

This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]",
"PL_ppaddr[OP_RV2AV]").

=item desc

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

=item targ

=item type

=item seq

=item flags

=item private

=back

=head2 B::UNOP METHOD

=over 4

=item first

=back

=head2 B::BINOP METHOD

=over 4

=item last

=back

=head2 B::LOGOP METHOD

=over 4

=item other

=back

=head2 B::LISTOP METHOD

=over 4

=item children

=back

=head2 B::PMOP METHODS

=over 4

=item pmreplroot

=item pmreplstart

=item pmnext

=item pmregexp

=item pmflags

=item pmpermflags

=item precomp

=back

=head2 B::SVOP METHOD

=over 4

=item sv

=item gv

=back

=head2 B::PADOP METHOD

=over 4

=item padix

=back

=head2 B::PVOP METHOD

=over 4

=item pv

=back

=head2 B::LOOP METHODS

=over 4

=item redoop

=item nextop

=item lastop

=back

=head2 B::COP METHODS

=over 4

=item label

=item stash

=item file

=item cop_seq

=item arybase

=item line

=back

=head1 FUNCTIONS EXPORTED BY C<B>

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

=over 4

=item main_cv

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

=item init_av

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

=item main_root

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

=item main_start

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

=item comppadlist

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

=item sv_undef

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

=item sv_yes

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

=item sv_no

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

=item amagic_generation

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

=item walkoptree(OP, METHOD)

Does a tree-walk of the syntax tree based at OP and calls METHOD on
each op it visits. Each node is visited before its children. If
C<walkoptree_debug> (q.v.) has been called to turn debugging on then
the method C<walkoptree_debug> is called on each op before METHOD is
called.

=item walkoptree_debug(DEBUG)

Returns the current debugging flag for C<walkoptree>. If the optional
DEBUG argument is non-zero, it sets the debugging flag to that. See
the description of C<walkoptree> above for what the debugging flag
does.

=item walksymtable(SYMREF, METHOD, RECURSE)

Walk the symbol table starting at SYMREF and call METHOD on each
symbol visited. When the walk reached package symbols "Foo::" it
invokes RECURSE and only recurses into the package if that sub
returns true.

=item svref_2object(SV)

Takes any Perl variable and turns it into an object in the
appropriate B::OP-derived or B::SV-derived class. Apart from functions
such as C<main_root>, this is the primary way to get an initial
"handle" on a internal perl data structure which can then be followed
with the other access methods.

=item ppname(OPNUM)

Return the PP function name (e.g. "pp_add") of op number OPNUM.

=item hash(STR)

Returns a string in the form "0x..." representing the value of the
internal hash function used by perl on string STR.

=item cast_I32(I)

Casts I to the internal I32 type used by that perl.


=item minus_c

Does the equivalent of the C<-c> command-line option. Obviously, this
is only useful in a BEGIN block or else the flag is set too late.


=item cstring(STR)

Returns a double-quote-surrounded escaped version of STR which can
be used as a string in C source code.

=item class(OBJ)

Returns the class of an object without the part of the classname
preceding the first "::". This is used to turn "B::UNOP" into
"UNOP" for example.

=item threadsv_names

In a perl compiled for threads, this returns a list of the special
per-thread threadsv variables.

=back

=head1 AUTHOR

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

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