[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);
@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 walkoptree_slow 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;
}

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) = @_;
    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

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