[p5sagit/p5-mst-13.2.git] / ext / B / B.pm

#      B.pm
#
#      Copyright (c) 1996, 1997, 1998 Malcolm Beattie
#
#      You may distribute under the terms of either the GNU General Public
#      License or the Artistic License, as specified in the README file.
#
package B;
use XSLoader ();
require Exporter;
@ISA = qw(Exporter);

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

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

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

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

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

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

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

  $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".
	chr( 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 a internal perl data structure which can then be followed
with the other access methods.

=item ppname(OPNUM)

Return the PP function name (e.g. "pp_add") of op number OPNUM.

=item hash(STR)

Returns a string in the form "0x..." representing the value of the
internal hash function used by perl on string STR.

=item cast_I32(I)

Casts I to the internal I32 type used by that perl.


=item minus_c

Does the equivalent of the C<-c> command-line option. Obviously, this
is only useful in a BEGIN block or else the flag is set too late.


=item cstring(STR)

Returns a double-quote-surrounded escaped version of STR which can
be used as a string in C source code.

=item class(OBJ)

Returns the class of an object without the part of the classname
preceding the first "::". This is used to turn "B::UNOP" into
"UNOP" for example.

=item threadsv_names

In a perl compiled for threads, this returns a list of the special
per-thread threadsv variables.

=back

=head1 AUTHOR

Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>

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