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

  # The regex below corresponds to the isCONTROLVAR macro
  # from toke.c

  $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".
	chr( utf8::unicode_to_native( 64 ^ ord($1) ))/e;

  # When we say unicode_to_native we really mean ascii_to_native,
  # which matters iff this is a non-ASCII platform (EBCDIC).

  return $name;
}

sub B::IV::int_value {
  my ($self) = @_;
  return (($self->FLAGS() & SVf_IVisUV()) ? $self->UVX : $self->IV);
}

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

Returns the value of the IV, I<interpreted as
a signed integer>. This will be misleading
if C<FLAGS & SVf_IVisUV>. Perhaps you want the
C<int_value> method instead?

=item IVX

=item UVX

=item int_value

This method returns the value of the IV as an integer.
It differs from C<IV> in that it returns the correct
value regardless of whether it's stored signed or
unsigned.

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