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