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