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

my $debug;
my $op_count = 0;
my @parents = ();

sub debug {
    my ($class, $value) = @_;
    $debug = $value;
    walkoptree_debug($value);
}

sub class {
    my $obj = shift;
    my $name = ref $obj;
    $name =~ s/^.*:://;
    return $name;
}

sub parents { \@parents }

# For debugging
sub peekop {
    my $op = shift;
    return sprintf("%s (0x%x) %s", class($op), $$op, $op->name);
}

sub walkoptree_slow {
    my($op, $method, $level) = @_;
    $op_count++; # just for statistics
    $level ||= 0;
    warn(sprintf("walkoptree: %d. %s\n", $level, peekop($op))) if $debug;
    $op->$method($level);
    if ($$op && ($op->flags & OPf_KIDS)) {
	my $kid;
	unshift(@parents, $op);
	for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
	    walkoptree_slow($kid, $method, $level + 1);
	}
	shift @parents;
    }
}

sub compile_stats {
    return "Total number of OPs processed: $op_count\n";
}

sub timing_info {
    my ($sec, $min, $hr) = localtime;
    my ($user, $sys) = times;
    sprintf("%02d:%02d:%02d user=$user sys=$sys",
	    $hr, $min, $sec, $user, $sys);
}

my %symtable;

sub clearsym {
    %symtable = ();
}

sub savesym {
    my ($obj, $value) = @_;
#    warn(sprintf("savesym: sym_%x => %s\n", $$obj, $value)); # debug
    $symtable{sprintf("sym_%x", $$obj)} = $value;
}

sub objsym {
    my $obj = shift;
    return $symtable{sprintf("sym_%x", $$obj)};
}

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

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

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

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

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

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

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

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

XSLoader::load 'B';

1;

__END__

=head1 NAME

B - The Perl Compiler

=head1 SYNOPSIS

	use B;

=head1 DESCRIPTION

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

=head1 OVERVIEW OF CLASSES

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

=head2 SV-RELATED CLASSES

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

=head2 B::SV METHODS

=over 4

=item REFCNT

=item FLAGS

=back

=head2 B::IV METHODS

=over 4

=item IV

=item IVX

=item needs64bits

=item packiv

=back

=head2 B::NV METHODS

=over 4

=item NV

=item NVX

=back

=head2 B::RV METHODS

=over 4

=item RV

=back

=head2 B::PV METHODS

=over 4

=item PV

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