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

our $VERSION = '1.00';

use XSLoader ();
require Exporter;
@ISA = qw(Exporter);

# walkoptree_slow comes from B.pm (you are there),
# walkoptree comes from B.xs
@EXPORT_OK = qw(minus_c ppname save_BEGINs
		class peekop cast_I32 cstring cchar hash threadsv_names
		main_root main_start main_cv svref_2object opnumber
		amagic_generation
		walkoptree_slow walkoptree walkoptree_exec walksymtable
		parents comppadlist sv_undef compile_stats timing_info
		begin_av init_av end_av);

sub OPf_KIDS ();
use strict;
@B::SV::ISA = 'B::OBJECT';
@B::NULL::ISA = 'B::SV';
@B::PV::ISA = 'B::SV';
@B::IV::ISA = 'B::SV';
@B::NV::ISA = 'B::IV';
@B::RV::ISA = 'B::SV';
@B::PVIV::ISA = qw(B::PV B::IV);
@B::PVNV::ISA = qw(B::PV B::NV);
@B::PVMG::ISA = 'B::PVNV';
@B::PVLV::ISA = 'B::PVMG';
@B::BM::ISA = 'B::PVMG';
@B::AV::ISA = 'B::PVMG';
@B::GV::ISA = 'B::PVMG';
@B::HV::ISA = 'B::PVMG';
@B::CV::ISA = 'B::PVMG';
@B::IO::ISA = 'B::PVMG';
@B::FM::ISA = 'B::CV';

@B::OP::ISA = 'B::OBJECT';
@B::UNOP::ISA = 'B::OP';
@B::BINOP::ISA = 'B::UNOP';
@B::LOGOP::ISA = 'B::UNOP';
@B::LISTOP::ISA = 'B::BINOP';
@B::SVOP::ISA = 'B::OP';
@B::PADOP::ISA = 'B::OP';
@B::PVOP::ISA = 'B::OP';
@B::CVOP::ISA = 'B::OP';
@B::LOOP::ISA = 'B::LISTOP';
@B::PMOP::ISA = 'B::LISTOP';
@B::COP::ISA = 'B::OP';

@B::SPECIAL::ISA = 'B::OBJECT';

{
    # Stop "-w" from complaining about the lack of a real B::OBJECT class
    package B::OBJECT;
}

sub B::GV::SAFENAME {
  my $name = (shift())->NAME;

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

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

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

  return $name;
}

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

sub B::NULL::as_string() {""}
sub B::IV::as_string()   {goto &B::IV::int_value}
sub B::PV::as_string()   {goto &B::PV::PV}

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

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

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

sub parents { \@parents }

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

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

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

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

my %symtable;

sub clearsym {
    %symtable = ();
}

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

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

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

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

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

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

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

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

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

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

XSLoader::load 'B';

1;

__END__

=head1 NAME

B - The Perl Compiler

=head1 SYNOPSIS

	use B;

=head1 DESCRIPTION

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

=head1 OVERVIEW OF CLASSES

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

=head2 SV-RELATED CLASSES

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

=head2 B::SV METHODS

=over 4

=item REFCNT

=item FLAGS

=back

=head2 B::IV METHODS

=over 4

=item IV

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

=item IVX

=item UVX

=item int_value

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

=item needs64bits

=item packiv

=back

=head2 B::NV METHODS

=over 4

=item NV

=item NVX

=back

=head2 B::RV METHODS

=over 4

=item RV

=back

=head2 B::PV METHODS

=over 4

=item PV

This method is the one you usually want. It constructs a
string using the length and offset information in the struct:
for ordinary scalars it will return the string that you'd see
from Perl, even if it contains null characters.

=item PVX

This method is less often useful. It assumes that the string
stored in the struct is null-terminated, and disregards the
length information.

It is the appropriate method to use if you need to get the name
of a lexical variable from a padname array. Lexical variable names
are always stored with a null terminator, and the length field
(SvCUR) is overloaded for other purposes and can't be relied on here.

=back

=head2 B::PVMG METHODS

=over 4

=item MAGIC

=item SvSTASH

=back

=head2 B::MAGIC METHODS

=over 4

=item MOREMAGIC

=item PRIVATE

=item TYPE

=item FLAGS

=item OBJ

=item PTR

=back

=head2 B::PVLV METHODS

=over 4

=item TARGOFF

=item TARGLEN

=item TYPE

=item TARG

=back

=head2 B::BM METHODS

=over 4

=item USEFUL

=item PREVIOUS

=item RARE

=item TABLE

=back

=head2 B::GV METHODS

=over 4

=item is_empty

This method returns TRUE if the GP field of the GV is NULL.

=item NAME

=item SAFENAME

This method returns the name of the glob, but if the first
character of the name is a control character, then it converts
it to ^X first, so that *^G would return "^G" rather than "\cG".

It's useful if you want to print out the name of a variable.
If you restrict yourself to globs which exist at compile-time
then the result ought to be unambiguous, because code like
C<${"^G"} = 1> is compiled as two ops - a constant string and
a dereference (rv2gv) - so that the glob is created at runtime.

If you're working with globs at runtime, and need to disambiguate
*^G from *{"^G"}, then you should use the raw NAME method.

=item STASH

=item SV

=item IO

=item FORM

=item AV

=item HV

=item EGV

=item CV

=item CVGEN

=item LINE

=item FILE

=item FILEGV

=item GvREFCNT

=item FLAGS

=back

=head2 B::IO METHODS

=over 4

=item LINES

=item PAGE

=item PAGE_LEN

=item LINES_LEFT

=item TOP_NAME

=item TOP_GV

=item FMT_NAME

=item FMT_GV

=item BOTTOM_NAME

=item BOTTOM_GV

=item SUBPROCESS

=item IoTYPE

=item IoFLAGS

=back

=head2 B::AV METHODS

=over 4

=item FILL

=item MAX

=item OFF

=item ARRAY

=item AvFLAGS

=back

=head2 B::CV METHODS

=over 4

=item STASH

=item START

=item ROOT

=item GV

=item FILE

=item DEPTH

=item PADLIST

=item OUTSIDE

=item XSUB

=item XSUBANY

=item CvFLAGS

=item const_sv

=back

=head2 B::HV METHODS

=over 4

=item FILL

=item MAX

=item KEYS

=item RITER

=item NAME

=item PMROOT

=item ARRAY

=back

=head2 OP-RELATED CLASSES

B::OP, B::UNOP, B::BINOP, B::LOGOP, B::LISTOP, B::PMOP,
B::SVOP, B::PADOP, B::PVOP, B::CVOP, B::LOOP, B::COP.
These classes correspond in
the obvious way to the underlying C structures of similar names. The
inheritance hierarchy mimics the underlying C "inheritance". Access
methods correspond to the underlying C structre field names, with the
leading "class indication" prefix removed (op_).

=head2 B::OP METHODS

=over 4

=item next

=item sibling

=item name

This returns the op name as a string (e.g. "add", "rv2av").

=item ppaddr

This returns the function name as a string (e.g. "PL_ppaddr[OP_ADD]",
"PL_ppaddr[OP_RV2AV]").

=item desc

This returns the op description from the global C PL_op_desc array
(e.g. "addition" "array deref").

=item targ

=item type

=item seq

=item flags

=item private

=back

=head2 B::UNOP METHOD

=over 4

=item first

=back

=head2 B::BINOP METHOD

=over 4

=item last

=back

=head2 B::LOGOP METHOD

=over 4

=item other

=back

=head2 B::LISTOP METHOD

=over 4

=item children

=back

=head2 B::PMOP METHODS

=over 4

=item pmreplroot

=item pmreplstart

=item pmnext

=item pmregexp

=item pmflags

=item pmpermflags

=item precomp

=back

=head2 B::SVOP METHOD

=over 4

=item sv

=item gv

=back

=head2 B::PADOP METHOD

=over 4

=item padix

=back

=head2 B::PVOP METHOD

=over 4

=item pv

=back

=head2 B::LOOP METHODS

=over 4

=item redoop

=item nextop

=item lastop

=back

=head2 B::COP METHODS

=over 4

=item label

=item stash

=item file

=item cop_seq

=item arybase

=item line

=back

=head1 FUNCTIONS EXPORTED BY C<B>

The C<B> module exports a variety of functions: some are simple
utility functions, others provide a Perl program with a way to
get an initial "handle" on an internal object.

=over 4

=item main_cv

Return the (faked) CV corresponding to the main part of the Perl
program.

=item init_av

Returns the AV object (i.e. in class B::AV) representing INIT blocks.

=item main_root

Returns the root op (i.e. an object in the appropriate B::OP-derived
class) of the main part of the Perl program.

=item main_start

Returns the starting op of the main part of the Perl program.

=item comppadlist

Returns the AV object (i.e. in class B::AV) of the global comppadlist.

=item sv_undef

Returns the SV object corresponding to the C variable C<sv_undef>.

=item sv_yes

Returns the SV object corresponding to the C variable C<sv_yes>.

=item sv_no

Returns the SV object corresponding to the C variable C<sv_no>.

=item amagic_generation

Returns the SV object corresponding to the C variable C<amagic_generation>.

=item walkoptree(OP, METHOD)

Does a tree-walk of the syntax tree based at OP and calls METHOD on
each op it visits. Each node is visited before its children. If
C<walkoptree_debug> (q.v.) has been called to turn debugging on then
the method C<walkoptree_debug> is called on each op before METHOD is
called.

=item walkoptree_debug(DEBUG)

Returns the current debugging flag for C<walkoptree>. If the optional
DEBUG argument is non-zero, it sets the debugging flag to that. See
the description of C<walkoptree> above for what the debugging flag
does.

=item walksymtable(SYMREF, METHOD, RECURSE, PREFIX)

Walk the symbol table starting at SYMREF and call METHOD on each
symbol (a B::GV object) visited.  When the walk reaches package
symbols (such as "Foo::") it invokes RECURSE, passing in the symbol
name, and only recurses into the package if that sub returns true.

PREFIX is the name of the SYMREF you're walking.

For example...

  # Walk CGI's symbol table calling print_subs on each symbol.
  # Only recurse into CGI::Util::
  walksymtable(\%CGI::, 'print_subs', sub { $_[0] eq 'CGI::Util::' },
               'CGI::');

print_subs() is a B::GV method you have declared.


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