dslinux/user/perl/ext/B/B Asmdata.pm Assembler.pm Bblock.pm Bytecode.pm C.pm CC.pm Concise.pm Debug.pm Deparse.pm Disassembler.pm Lint.pm Showlex.pm Stackobj.pm Stash.pm Terse.pm Xref.pm assemble cc_harness disassemble makeliblinks
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 17:59:08 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/ext/B/B
In directory antilope:/tmp/cvs-serv17422/ext/B/B
Added Files:
Asmdata.pm Assembler.pm Bblock.pm Bytecode.pm C.pm CC.pm
Concise.pm Debug.pm Deparse.pm Disassembler.pm Lint.pm
Showlex.pm Stackobj.pm Stash.pm Terse.pm Xref.pm assemble
cc_harness disassemble makeliblinks
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: Lint.pm ---
package B::Lint;
our $VERSION = '1.03';
=head1 NAME
B::Lint - Perl lint
=head1 SYNOPSIS
perl -MO=Lint[,OPTIONS] foo.pl
=head1 DESCRIPTION
The B::Lint module is equivalent to an extended version of the B<-w>
option of B<perl>. It is named after the program F<lint> which carries
out a similar process for C programs.
=head1 OPTIONS AND LINT CHECKS
Option words are separated by commas (not whitespace) and follow the
usual conventions of compiler backend options. Following any options
(indicated by a leading B<->) come lint check arguments. Each such
argument (apart from the special B<all> and B<none> options) is a
word representing one possible lint check (turning on that check) or
is B<no-foo> (turning off that check). Before processing the check
arguments, a standard list of checks is turned on. Later options
override earlier ones. Available options are:
=over 8
=item B<context>
Produces a warning whenever an array is used in an implicit scalar
context. For example, both of the lines
$foo = length(@bar);
$foo = @bar;
will elicit a warning. Using an explicit B<scalar()> silences the
warning. For example,
$foo = scalar(@bar);
=item B<implicit-read> and B<implicit-write>
These options produce a warning whenever an operation implicitly
reads or (respectively) writes to one of Perl's special variables.
For example, B<implicit-read> will warn about these:
/foo/;
and B<implicit-write> will warn about these:
s/foo/bar/;
Both B<implicit-read> and B<implicit-write> warn about this:
for (@a) { ... }
=item B<bare-subs>
This option warns whenever a bareword is implicitly quoted, but is also
the name of a subroutine in the current package. Typical mistakes that it will
trap are:
use constant foo => 'bar';
@a = ( foo => 1 );
$b{foo} = 2;
Neither of these will do what a naive user would expect.
=item B<dollar-underscore>
This option warns whenever C<$_> is used either explicitly anywhere or
as the implicit argument of a B<print> statement.
=item B<private-names>
This option warns on each use of any variable, subroutine or
method name that lives in a non-current package but begins with
an underscore ("_"). Warnings aren't issued for the special case
of the single character name "_" by itself (e.g. C<$_> and C<@_>).
=item B<undefined-subs>
This option warns whenever an undefined subroutine is invoked.
This option will only catch explicitly invoked subroutines such
as C<foo()> and not indirect invocations such as C<&$subref()>
or C<$obj-E<gt>meth()>. Note that some programs or modules delay
definition of subs until runtime by means of the AUTOLOAD
mechanism.
=item B<regexp-variables>
This option warns whenever one of the regexp variables C<$`>, C<$&> or C<$'>
is used. Any occurrence of any of these variables in your
program can slow your whole program down. See L<perlre> for
details.
=item B<all>
Turn all warnings on.
=item B<none>
Turn all warnings off.
=back
=head1 NON LINT-CHECK OPTIONS
=over 8
=item B<-u Package>
Normally, Lint only checks the main code of the program together
with all subs defined in package main. The B<-u> option lets you
include other package names whose subs are then checked by Lint.
=back
=head1 BUGS
This is only a very preliminary version.
This module doesn't work correctly on thread-enabled perls.
=head1 AUTHOR
Malcolm Beattie, mbeattie at sable.ox.ac.uk.
=cut
use strict;
use B qw(walkoptree_slow main_root walksymtable svref_2object parents
OPf_WANT_LIST OPf_WANT OPf_STACKED G_ARRAY SVf_POK
);
my $file = "unknown"; # shadows current filename
my $line = 0; # shadows current line number
my $curstash = "main"; # shadows current stash
# Lint checks
my %check;
my %implies_ok_context;
BEGIN {
map($implies_ok_context{$_}++,
qw(scalar av2arylen aelem aslice helem hslice
keys values hslice defined undef delete));
}
# Lint checks turned on by default
my @default_checks = qw(context);
my %valid_check;
# All valid checks
BEGIN {
map($valid_check{$_}++,
qw(context implicit_read implicit_write dollar_underscore
private_names bare_subs undefined_subs regexp_variables));
}
# Debugging options
my ($debug_op);
my %done_cv; # used to mark which subs have already been linted
my @extra_packages; # Lint checks mainline code and all subs which are
# in main:: or in one of these packages.
sub warning {
my $format = (@_ < 2) ? "%s" : shift;
warn sprintf("$format at %s line %d\n", @_, $file, $line);
}
# This gimme can't cope with context that's only determined
# at runtime via dowantarray().
sub gimme {
my $op = shift;
my $flags = $op->flags;
if ($flags & OPf_WANT) {
return(($flags & OPf_WANT) == OPf_WANT_LIST ? 1 : 0);
}
return undef;
}
sub B::OP::lint {}
sub B::COP::lint {
my $op = shift;
if ($op->name eq "nextstate") {
$file = $op->file;
$line = $op->line;
$curstash = $op->stash->NAME;
}
}
sub B::UNOP::lint {
my $op = shift;
my $opname = $op->name;
if ($check{context} && ($opname eq "rv2av" || $opname eq "rv2hv")) {
my $parent = parents->[0];
my $pname = $parent->name;
return if gimme($op) || $implies_ok_context{$pname};
# Two special cases to deal with: "foreach (@foo)" and "delete $a{$b}"
# null out the parent so we have to check for a parent of pp_null and
# a grandparent of pp_enteriter or pp_delete
if ($pname eq "null") {
my $gpname = parents->[1]->name;
return if $gpname eq "enteriter" || $gpname eq "delete";
}
warning("Implicit scalar context for %s in %s",
$opname eq "rv2av" ? "array" : "hash", $parent->desc);
}
if ($check{private_names} && $opname eq "method") {
my $methop = $op->first;
if ($methop->name eq "const") {
my $method = $methop->sv->PV;
if ($method =~ /^_/ && !defined(&{"$curstash\::$method"})) {
warning("Illegal reference to private method name $method");
}
}
}
}
sub B::PMOP::lint {
my $op = shift;
if ($check{implicit_read}) {
if ($op->name eq "match" && !($op->flags & OPf_STACKED)) {
warning('Implicit match on $_');
}
}
if ($check{implicit_write}) {
if ($op->name eq "subst" && !($op->flags & OPf_STACKED)) {
warning('Implicit substitution on $_');
}
}
}
sub B::LOOP::lint {
my $op = shift;
if ($check{implicit_read} || $check{implicit_write}) {
if ($op->name eq "enteriter") {
my $last = $op->last;
if ($last->name eq "gv" && $last->gv->NAME eq "_") {
warning('Implicit use of $_ in foreach');
}
}
}
}
sub B::SVOP::lint {
my $op = shift;
if ( $check{bare_subs} && $op->name eq 'const'
&& $op->private & 64 ) # OPpCONST_BARE = 64 in op.h
{
my $sv = $op->sv;
if( $sv->FLAGS & SVf_POK && exists &{$curstash.'::'.$sv->PV} ) {
warning "Bare sub name '" . $sv->PV . "' interpreted as string";
}
}
if ($check{dollar_underscore} && $op->name eq "gvsv"
&& $op->gv->NAME eq "_")
{
warning('Use of $_');
}
if ($check{private_names}) {
my $opname = $op->name;
if ($opname eq "gv" || $opname eq "gvsv") {
my $gv = $op->gv;
if ($gv->NAME =~ /^_./ && $gv->STASH->NAME ne $curstash) {
warning('Illegal reference to private name %s', $gv->NAME);
}
} elsif ($opname eq "method_named") {
my $method = $op->gv->PV;
if ($method =~ /^_./) {
warning("Illegal reference to private method name $method");
}
}
}
if ($check{undefined_subs}) {
if ($op->name eq "gv"
&& $op->next->name eq "entersub")
{
my $gv = $op->gv;
my $subname = $gv->STASH->NAME . "::" . $gv->NAME;
no strict 'refs';
if (!defined(&$subname)) {
$subname =~ s/^main:://;
warning('Undefined subroutine %s called', $subname);
}
}
}
if ($check{regexp_variables} && $op->name eq "gvsv") {
my $name = $op->gv->NAME;
if ($name =~ /^[&'`]$/) {
warning('Use of regexp variable $%s', $name);
}
}
}
sub B::GV::lintcv {
my $gv = shift;
my $cv = $gv->CV;
#warn sprintf("lintcv: %s::%s (done=%d)\n",
# $gv->STASH->NAME, $gv->NAME, $done_cv{$$cv});#debug
return if !$$cv || $done_cv{$$cv}++;
my $root = $cv->ROOT;
#warn " root = $root (0x$$root)\n";#debug
walkoptree_slow($root, "lint") if $$root;
}
sub do_lint {
my %search_pack;
walkoptree_slow(main_root, "lint") if ${main_root()};
# Now do subs in main
no strict qw(vars refs);
local(*glob);
for my $sym (keys %main::) {
next if $sym =~ /::$/;
*glob = $main::{$sym};
svref_2object(\*glob)->EGV->lintcv;
}
# Now do subs in non-main packages given by -u options
map { $search_pack{$_} = 1 } @extra_packages;
walksymtable(\%{"main::"}, "lintcv", sub {
my $package = shift;
$package =~ s/::$//;
#warn "Considering $package\n";#debug
return exists $search_pack{$package};
});
}
sub compile {
my @options = @_;
my ($option, $opt, $arg);
# Turn on default lint checks
for $opt (@default_checks) {
$check{$opt} = 1;
}
OPTION:
while ($option = shift @options) {
if ($option =~ /^-(.)(.*)/) {
$opt = $1;
$arg = $2;
} else {
unshift @options, $option;
last OPTION;
}
if ($opt eq "-" && $arg eq "-") {
shift @options;
last OPTION;
} elsif ($opt eq "D") {
$arg ||= shift @options;
foreach $arg (split(//, $arg)) {
if ($arg eq "o") {
B->debug(1);
} elsif ($arg eq "O") {
$debug_op = 1;
}
}
} elsif ($opt eq "u") {
$arg ||= shift @options;
push(@extra_packages, $arg);
}
}
foreach $opt (@default_checks, @options) {
$opt =~ tr/-/_/;
if ($opt eq "all") {
%check = %valid_check;
}
elsif ($opt eq "none") {
%check = ();
}
else {
if ($opt =~ s/^no_//) {
$check{$opt} = 0;
}
else {
$check{$opt} = 1;
}
warn "No such check: $opt\n" unless defined $valid_check{$opt};
}
}
# Remaining arguments are things to check
return \&do_lint;
}
1;
--- NEW FILE: Terse.pm ---
package B::Terse;
our $VERSION = '1.03_01';
use strict;
use B qw(class);
use B::Asmdata qw(@specialsv_name);
use B::Concise qw(concise_subref set_style_standard);
use Carp;
sub terse {
my ($order, $subref) = @_;
set_style_standard("terse");
if ($order eq "exec") {
concise_subref('exec', $subref);
} else {
concise_subref('basic', $subref);
}
}
sub compile {
my @args = @_;
my $order = @args ? shift(@args) : "";
$order = "-exec" if $order eq "exec";
unshift @args, $order if $order ne "";
B::Concise::compile("-terse", @args);
}
sub indent {
my ($level) = @_ ? shift : 0;
return " " x $level;
}
# Don't use this, at least on OPs in subroutines: it has no way of
# getting to the pad, and will give wrong answers or crash.
sub B::OP::terse {
carp "B::OP::terse is deprecated; use B::Concise instead";
B::Concise::b_terse(@_);
}
sub B::SV::terse {
my($sv, $level) = (@_, 0);
my %info;
B::Concise::concise_sv($sv, \%info);
my $s = indent($level)
. B::Concise::fmt_line(\%info, $sv,
"#svclass~(?((#svaddr))?)~#svval", 0);
chomp $s;
print "$s\n" unless defined wantarray;
$s;
}
sub B::NULL::terse {
my ($sv, $level) = (@_, 0);
my $s = indent($level) . sprintf "%s (0x%lx)", class($sv), $$sv;
print "$s\n" unless defined wantarray;
$s;
}
sub B::SPECIAL::terse {
my ($sv, $level) = (@_, 0);
my $s = indent($level)
. sprintf( "%s #%d %s", class($sv), $$sv, $specialsv_name[$$sv]);
print "$s\n" unless defined wantarray;
$s;
}
1;
__END__
=head1 NAME
B::Terse - Walk Perl syntax tree, printing terse info about ops
=head1 SYNOPSIS
perl -MO=Terse[,OPTIONS] foo.pl
=head1 DESCRIPTION
This version of B::Terse is really just a wrapper that calls B::Concise
with the B<-terse> option. It is provided for compatibility with old scripts
(and habits) but using B::Concise directly is now recommended instead.
For compatibility with the old B::Terse, this module also adds a
method named C<terse> to B::OP and B::SV objects. The B::SV method is
largely compatible with the old one, though authors of new software
might be advised to choose a more user-friendly output format. The
B::OP C<terse> method, however, doesn't work well. Since B::Terse was
first written, much more information in OPs has migrated to the
scratchpad datastructure, but the C<terse> interface doesn't have any
way of getting to the correct pad. As a kludge, the new version will
always use the pad for the main program, but for OPs in subroutines
this will give the wrong answer or crash.
=head1 AUTHOR
The original version of B::Terse was written by Malcolm Beattie,
E<lt>mbeattie at sable.ox.ac.ukE<gt>. This wrapper was written by Stephen
McCamant, E<lt>smcc at MIT.EDUE<gt>.
=cut
--- NEW FILE: cc_harness ---
use Config;
$libdir = $ENV{PERL_SRC} || "$Config{installarchlib}/CORE";
if (!grep(/^-[cS]$/, @ARGV)) {
$linkargs = sprintf("%s $libdir/$Config{libperl} %s",
@Config{qw(ldflags libs)});
}
$cccmd = "$Config{cc} $Config{ccflags} -I$libdir @ARGV $linkargs";
print "$cccmd\n";
exec $cccmd;
--- NEW FILE: C.pm ---
# C.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::C;
our $VERSION = '1.04_01';
package B::C::Section;
use B ();
use base B::Section;
sub new
{
[...2233 lines suppressed...]
=head1 EXAMPLES
perl -MO=C,-ofoo.c foo.pl
perl cc_harness -o foo foo.c
Note that C<cc_harness> lives in the C<B> subdirectory of your perl
library directory. The utility called C<perlcc> may also be used to
help make use of this compiler.
perl -MO=C,-v,-DcA,-l2048 bar.pl > /dev/null
=head1 BUGS
Plenty. Current status: experimental.
=head1 AUTHOR
Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
=cut
--- NEW FILE: disassemble ---
use B::Disassembler qw(disassemble_fh);
use FileHandle;
my $fh;
if (@ARGV == 0) {
$fh = \*STDIN;
} elsif (@ARGV == 1) {
$fh = new FileHandle "<$ARGV[0]";
} else {
die "Usage: disassemble [filename]\n";
}
sub print_insn {
my ($insn, $arg) = @_;
if (defined($arg)) {
printf "%s %s\n", $insn, $arg;
} else {
print $insn, "\n";
}
}
disassemble_fh($fh, \&print_insn);
--- NEW FILE: CC.pm ---
# CC.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::CC;
our $VERSION = '1.00_01';
use Config;
use strict;
use B qw(main_start main_root class comppadlist peekop svref_2object
timing_info init_av sv_undef amagic_generation
OPf_WANT_LIST OPf_WANT OPf_MOD OPf_STACKED OPf_SPECIAL
OPpASSIGN_BACKWARDS OPpLVAL_INTRO OPpDEREF_AV OPpDEREF_HV
OPpDEREF OPpFLIP_LINENUM G_ARRAY G_SCALAR
CXt_NULL CXt_SUB CXt_EVAL CXt_LOOP CXt_SUBST CXt_BLOCK
[...1966 lines suppressed...]
with standard Perl but gives a compile-time error with compiled Perl.
=head2 Arithmetic
Compiled Perl programs use native C arithmetic much more frequently
than standard perl. Operations on large numbers or on boundary
cases may produce different behaviour.
=head2 Deprecated features
Features of standard perl such as C<$[> which have been deprecated
in standard perl since Perl5 was released have not been implemented
in the compiler.
=head1 AUTHOR
Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
=cut
--- NEW FILE: Xref.pm ---
package B::Xref;
our $VERSION = '1.01';
=head1 NAME
B::Xref - Generates cross reference reports for Perl programs
=head1 SYNOPSIS
perl -MO=Xref[,OPTIONS] foo.pl
=head1 DESCRIPTION
The B::Xref module is used to generate a cross reference listing of all
definitions and uses of variables, subroutines and formats in a Perl program.
It is implemented as a backend for the Perl compiler.
The report generated is in the following format:
File filename1
Subroutine subname1
Package package1
object1 line numbers
object2 line numbers
...
Package package2
...
Each B<File> section reports on a single file. Each B<Subroutine> section
reports on a single subroutine apart from the special cases
"(definitions)" and "(main)". These report, respectively, on subroutine
definitions found by the initial symbol table walk and on the main part of
the program or module external to all subroutines.
The report is then grouped by the B<Package> of each variable,
subroutine or format with the special case "(lexicals)" meaning
lexical variables. Each B<object> name (implicitly qualified by its
containing B<Package>) includes its type character(s) at the beginning
where possible. Lexical variables are easier to track and even
included dereferencing information where possible.
The C<line numbers> are a comma separated list of line numbers (some
preceded by code letters) where that object is used in some way.
Simple uses aren't preceded by a code letter. Introductions (such as
where a lexical is first defined with C<my>) are indicated with the
letter "i". Subroutine and method calls are indicated by the character
"&". Subroutine definitions are indicated by "s" and format
definitions by "f".
=head1 OPTIONS
Option words are separated by commas (not whitespace) and follow the
usual conventions of compiler backend options.
=over 8
=item C<-oFILENAME>
Directs output to C<FILENAME> instead of standard output.
=item C<-r>
Raw output. Instead of producing a human-readable report, outputs a line
in machine-readable form for each definition/use of a variable/sub/format.
=item C<-d>
Don't output the "(definitions)" sections.
=item C<-D[tO]>
(Internal) debug options, probably only useful if C<-r> included.
The C<t> option prints the object on the top of the stack as it's
being tracked. The C<O> option prints each operator as it's being
processed in the execution order of the program.
=back
=head1 BUGS
Non-lexical variables are quite difficult to track through a program.
Sometimes the type of a non-lexical variable's use is impossible to
determine. Introductions of non-lexical non-scalars don't seem to be
reported properly.
=head1 AUTHOR
Malcolm Beattie, mbeattie at sable.ox.ac.uk.
=cut
use strict;
use Config;
use B qw(peekop class comppadlist main_start svref_2object walksymtable
OPpLVAL_INTRO SVf_POK OPpOUR_INTRO cstring
);
sub UNKNOWN { ["?", "?", "?"] }
my @pad; # lexicals in current pad
# as ["(lexical)", type, name]
my %done; # keyed by $$op: set when each $op is done
my $top = UNKNOWN; # shadows top element of stack as
# [pack, type, name] (pack can be "(lexical)")
my $file; # shadows current filename
my $line; # shadows current line number
my $subname; # shadows current sub name
my %table; # Multi-level hash to record all uses etc.
my @todo = (); # List of CVs that need processing
my %code = (intro => "i", used => "",
subdef => "s", subused => "&",
formdef => "f", meth => "->");
# Options
my ($debug_op, $debug_top, $nodefs, $raw);
sub process {
my ($var, $event) = @_;
my ($pack, $type, $name) = @$var;
if ($type eq "*") {
if ($event eq "used") {
return;
} elsif ($event eq "subused") {
$type = "&";
}
}
$type =~ s/(.)\*$/$1/g;
if ($raw) {
printf "%-16s %-12s %5d %-12s %4s %-16s %s\n",
$file, $subname, $line, $pack, $type, $name, $event;
} else {
# Wheee
push(@{$table{$file}->{$subname}->{$pack}->{$type.$name}->{$event}},
$line);
}
}
sub load_pad {
my $padlist = shift;
my ($namelistav, $vallistav, @namelist, $ix);
@pad = ();
return if class($padlist) eq "SPECIAL";
($namelistav,$vallistav) = $padlist->ARRAY;
@namelist = $namelistav->ARRAY;
for ($ix = 1; $ix < @namelist; $ix++) {
my $namesv = $namelist[$ix];
next if class($namesv) eq "SPECIAL";
my ($type, $name) = $namesv->PV =~ /^(.)([^\0]*)(\0.*)?$/;
$pad[$ix] = ["(lexical)", $type || '?', $name || '?'];
}
if ($Config{useithreads}) {
my (@vallist);
@vallist = $vallistav->ARRAY;
for ($ix = 1; $ix < @vallist; $ix++) {
my $valsv = $vallist[$ix];
next unless class($valsv) eq "GV";
# these pad GVs don't have corresponding names, so same @pad
# array can be used without collisions
$pad[$ix] = [$valsv->STASH->NAME, "*", $valsv->NAME];
}
}
}
sub xref {
my $start = shift;
my $op;
for ($op = $start; $$op; $op = $op->next) {
last if $done{$$op}++;
warn sprintf("top = [%s, %s, %s]\n", @$top) if $debug_top;
warn peekop($op), "\n" if $debug_op;
my $opname = $op->name;
if ($opname =~ /^(or|and|mapwhile|grepwhile|range|cond_expr)$/) {
xref($op->other);
} elsif ($opname eq "match" || $opname eq "subst") {
xref($op->pmreplstart);
} elsif ($opname eq "substcont") {
xref($op->other->pmreplstart);
$op = $op->other;
redo;
} elsif ($opname eq "enterloop") {
xref($op->redoop);
xref($op->nextop);
xref($op->lastop);
} elsif ($opname eq "subst") {
xref($op->pmreplstart);
} else {
no strict 'refs';
my $ppname = "pp_$opname";
&$ppname($op) if defined(&$ppname);
}
}
}
sub xref_cv {
my $cv = shift;
my $pack = $cv->GV->STASH->NAME;
$subname = ($pack eq "main" ? "" : "$pack\::") . $cv->GV->NAME;
load_pad($cv->PADLIST);
xref($cv->START);
$subname = "(main)";
}
sub xref_object {
my $cvref = shift;
xref_cv(svref_2object($cvref));
}
sub xref_main {
$subname = "(main)";
load_pad(comppadlist);
xref(main_start);
while (@todo) {
xref_cv(shift @todo);
}
}
sub pp_nextstate {
my $op = shift;
$file = $op->file;
$line = $op->line;
$top = UNKNOWN;
}
sub pp_padsv {
my $op = shift;
$top = $pad[$op->targ];
process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
}
sub pp_padav { pp_padsv(@_) }
sub pp_padhv { pp_padsv(@_) }
sub deref {
my ($op, $var, $as) = @_;
$var->[1] = $as . $var->[1];
process($var, $op->private & OPpOUR_INTRO ? "intro" : "used");
}
sub pp_rv2cv { deref(shift, $top, "&"); }
sub pp_rv2hv { deref(shift, $top, "%"); }
sub pp_rv2sv { deref(shift, $top, "\$"); }
sub pp_rv2av { deref(shift, $top, "\@"); }
sub pp_rv2gv { deref(shift, $top, "*"); }
sub pp_gvsv {
my $op = shift;
my $gv;
if ($Config{useithreads}) {
$top = $pad[$op->padix];
$top = UNKNOWN unless $top;
$top->[1] = '$';
}
else {
$gv = $op->gv;
$top = [$gv->STASH->NAME, '$', $gv->SAFENAME];
}
process($top, $op->private & OPpLVAL_INTRO ||
$op->private & OPpOUR_INTRO ? "intro" : "used");
}
sub pp_gv {
my $op = shift;
my $gv;
if ($Config{useithreads}) {
$top = $pad[$op->padix];
$top = UNKNOWN unless $top;
$top->[1] = '*';
}
else {
$gv = $op->gv;
$top = [$gv->STASH->NAME, "*", $gv->SAFENAME];
}
process($top, $op->private & OPpLVAL_INTRO ? "intro" : "used");
}
sub pp_const {
my $op = shift;
my $sv = $op->sv;
# constant could be in the pad (under useithreads)
if ($$sv) {
$top = ["?", "",
(class($sv) ne "SPECIAL" && $sv->FLAGS & SVf_POK)
? cstring($sv->PV) : "?"];
}
else {
$top = $pad[$op->targ];
$top = UNKNOWN unless $top;
}
}
sub pp_method {
my $op = shift;
$top = ["(method)", "->".$top->[1], $top->[2]];
}
sub pp_entersub {
my $op = shift;
if ($top->[1] eq "m") {
process($top, "meth");
} else {
process($top, "subused");
}
$top = UNKNOWN;
}
#
# Stuff for cross referencing definitions of variables and subs
#
sub B::GV::xref {
my $gv = shift;
my $cv = $gv->CV;
if ($$cv) {
#return if $done{$$cv}++;
$file = $gv->FILE;
$line = $gv->LINE;
process([$gv->STASH->NAME, "&", $gv->NAME], "subdef");
push(@todo, $cv);
}
my $form = $gv->FORM;
if ($$form) {
return if $done{$$form}++;
$file = $gv->FILE;
$line = $gv->LINE;
process([$gv->STASH->NAME, "", $gv->NAME], "formdef");
}
}
sub xref_definitions {
my ($pack, %exclude);
return if $nodefs;
$subname = "(definitions)";
foreach $pack (qw(B O AutoLoader DynaLoader XSLoader Config DB VMS
strict vars FileHandle Exporter Carp PerlIO::Layer
attributes utf8 warnings)) {
$exclude{$pack."::"} = 1;
}
no strict qw(vars refs);
walksymtable(\%{"main::"}, "xref", sub { !defined($exclude{$_[0]}) });
}
sub output {
return if $raw;
my ($file, $subname, $pack, $name, $ev, $perfile, $persubname,
$perpack, $pername, $perev);
foreach $file (sort(keys(%table))) {
$perfile = $table{$file};
print "File $file\n";
foreach $subname (sort(keys(%$perfile))) {
$persubname = $perfile->{$subname};
print " Subroutine $subname\n";
foreach $pack (sort(keys(%$persubname))) {
$perpack = $persubname->{$pack};
print " Package $pack\n";
foreach $name (sort(keys(%$perpack))) {
$pername = $perpack->{$name};
my @lines;
foreach $ev (qw(intro formdef subdef meth subused used)) {
$perev = $pername->{$ev};
if (defined($perev) && @$perev) {
my $code = $code{$ev};
push(@lines, map("$code$_", @$perev));
}
}
printf " %-16s %s\n", $name, join(", ", @lines);
}
}
}
}
}
sub compile {
my @options = @_;
my ($option, $opt, $arg);
OPTION:
while ($option = shift @options) {
if ($option =~ /^-(.)(.*)/) {
$opt = $1;
$arg = $2;
} else {
unshift @options, $option;
last OPTION;
}
if ($opt eq "-" && $arg eq "-") {
shift @options;
last OPTION;
} elsif ($opt eq "o") {
$arg ||= shift @options;
open(STDOUT, ">$arg") or return "$arg: $!\n";
} elsif ($opt eq "d") {
$nodefs = 1;
} elsif ($opt eq "r") {
$raw = 1;
} elsif ($opt eq "D") {
$arg ||= shift @options;
foreach $arg (split(//, $arg)) {
if ($arg eq "o") {
B->debug(1);
} elsif ($arg eq "O") {
$debug_op = 1;
} elsif ($arg eq "t") {
$debug_top = 1;
}
}
}
}
if (@options) {
return sub {
my $objname;
xref_definitions();
foreach $objname (@options) {
$objname = "main::$objname" unless $objname =~ /::/;
eval "xref_object(\\&$objname)";
die "xref_object(\\&$objname) failed: $@" if $@;
}
output();
}
} else {
return sub {
xref_definitions();
xref_main();
output();
}
}
}
1;
--- NEW FILE: Deparse.pm ---
# B::Deparse.pm
# Copyright (c) 1998-2000, 2002, 2003 Stephen McCamant. All rights reserved.
# This module is free software; you can redistribute and/or modify
# it under the same terms as Perl itself.
# This is based on the module of the same name by Malcolm Beattie,
# but essentially none of his code remains.
package B::Deparse;
use Carp;
use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
OPf_WANT OPf_WANT_VOID OPf_WANT_SCALAR OPf_WANT_LIST
OPf_KIDS OPf_REF OPf_STACKED OPf_SPECIAL OPf_MOD
OPpLVAL_INTRO OPpOUR_INTRO OPpENTERSUB_AMPER OPpSLICE OPpCONST_BARE
OPpTRANS_SQUASH OPpTRANS_DELETE OPpTRANS_COMPLEMENT OPpTARGET_MY
OPpCONST_ARYBASE OPpEXISTS_SUB OPpSORT_NUMERIC OPpSORT_INTEGER
OPpSORT_REVERSE OPpSORT_INPLACE OPpSORT_DESCEND OPpITER_REVERSED
SVf_IOK SVf_NOK SVf_ROK SVf_POK SVpad_OUR SVf_FAKE SVs_RMG SVs_SMG
CVf_METHOD CVf_LOCKED CVf_LVALUE CVf_ASSERTION
[...4603 lines suppressed...]
my $x if 0;
which is not, consequently, deparsed correctly.
=item *
There are probably many more bugs on non-ASCII platforms (EBCDIC).
=back
=head1 AUTHOR
Stephen McCamant <smcc at CSUA.Berkeley.EDU>, based on an earlier version
by Malcolm Beattie <mbeattie at sable.ox.ac.uk>, with contributions from
Gisle Aas, James Duncan, Albert Dvornik, Robin Houston, Dave Mitchell,
Hugo van der Sanden, Gurusamy Sarathy, Nick Ing-Simmons, and Rafael
Garcia-Suarez.
=cut
--- NEW FILE: Showlex.pm ---
package B::Showlex;
our $VERSION = '1.02';
use strict;
use B qw(svref_2object comppadlist class);
use B::Terse ();
use B::Concise ();
#
# Invoke as
# perl -MO=Showlex,foo bar.pl
# to see the names of lexical variables used by &foo
# or as
# perl -MO=Showlex bar.pl
# to see the names of file scope lexicals used by bar.pl
#
# borrowed from B::Concise
our $walkHandle = \*STDOUT;
sub walk_output { # updates $walkHandle
$walkHandle = B::Concise::walk_output(@_);
#print "got $walkHandle";
#print $walkHandle "using it";
$walkHandle;
}
sub shownamearray {
my ($name, $av) = @_;
my @els = $av->ARRAY;
my $count = @els;
my $i;
print $walkHandle "$name has $count entries\n";
for ($i = 0; $i < $count; $i++) {
my $sv = $els[$i];
if (class($sv) ne "SPECIAL") {
printf $walkHandle "$i: %s (0x%lx) %s\n", class($sv), $$sv, $sv->PVX;
} else {
printf $walkHandle "$i: %s\n", $sv->terse;
#printf $walkHandle "$i: %s\n", B::Concise::concise_sv($sv);
}
}
}
sub showvaluearray {
my ($name, $av) = @_;
my @els = $av->ARRAY;
my $count = @els;
my $i;
print $walkHandle "$name has $count entries\n";
for ($i = 0; $i < $count; $i++) {
printf $walkHandle "$i: %s\n", $els[$i]->terse;
#print $walkHandle "$i: %s\n", B::Concise::concise_sv($els[$i]);
}
}
sub showlex {
my ($objname, $namesav, $valsav) = @_;
shownamearray("Pad of lexical names for $objname", $namesav);
showvaluearray("Pad of lexical values for $objname", $valsav);
}
my ($newlex, $nosp1); # rendering state vars
sub newlex { # drop-in for showlex
my ($objname, $names, $vals) = @_;
my @names = $names->ARRAY;
my @vals = $vals->ARRAY;
my $count = @names;
print $walkHandle "$objname Pad has $count entries\n";
printf $walkHandle "0: %s\n", $names[0]->terse unless $nosp1;
for (my $i = 1; $i < $count; $i++) {
printf $walkHandle "$i: %s = %s\n", $names[$i]->terse, $vals[$i]->terse
unless $nosp1 and $names[$i]->terse =~ /SPECIAL/;
}
}
sub showlex_obj {
my ($objname, $obj) = @_;
$objname =~ s/^&main::/&/;
showlex($objname, svref_2object($obj)->PADLIST->ARRAY) if !$newlex;
newlex ($objname, svref_2object($obj)->PADLIST->ARRAY) if $newlex;
}
sub showlex_main {
showlex("comppadlist", comppadlist->ARRAY) if !$newlex;
newlex ("main", comppadlist->ARRAY) if $newlex;
}
sub compile {
my @options = grep(/^-/, @_);
my @args = grep(!/^-/, @_);
for my $o (@options) {
$newlex = 1 if $o eq "-newlex";
$nosp1 = 1 if $o eq "-nosp";
}
return \&showlex_main unless @args;
return sub {
my $objref;
foreach my $objname (@args) {
next unless $objname; # skip nulls w/o carping
if (ref $objname) {
print $walkHandle "B::Showlex::compile($objname)\n";
$objref = $objname;
} else {
$objname = "main::$objname" unless $objname =~ /::/;
print $walkHandle "$objname:\n";
no strict 'refs';
die "err: unknown function ($objname)\n"
unless *{$objname}{CODE};
$objref = \&$objname;
}
showlex_obj($objname, $objref);
}
}
}
1;
__END__
=head1 NAME
B::Showlex - Show lexical variables used in functions or files
=head1 SYNOPSIS
perl -MO=Showlex[,-OPTIONS][,SUBROUTINE] foo.pl
=head1 DESCRIPTION
When a comma-separated list of subroutine names is given as options, Showlex
prints the lexical variables used in those subroutines. Otherwise, it prints
the file-scope lexicals in the file.
=head1 EXAMPLES
Traditional form:
$ perl -MO=Showlex -e 'my ($i,$j,$k)=(1,"foo")'
Pad of lexical names for comppadlist has 4 entries
0: SPECIAL #1 &PL_sv_undef
1: PVNV (0x9db0fb0) $i
2: PVNV (0x9db0f38) $j
3: PVNV (0x9db0f50) $k
Pad of lexical values for comppadlist has 5 entries
0: SPECIAL #1 &PL_sv_undef
1: NULL (0x9da4234)
2: NULL (0x9db0f2c)
3: NULL (0x9db0f44)
4: NULL (0x9da4264)
-e syntax OK
New-style form:
$ perl -MO=Showlex,-newlex -e 'my ($i,$j,$k)=(1,"foo")'
main Pad has 4 entries
0: SPECIAL #1 &PL_sv_undef
1: PVNV (0xa0c4fb8) "$i" = NULL (0xa0b8234)
2: PVNV (0xa0c4f40) "$j" = NULL (0xa0c4f34)
3: PVNV (0xa0c4f58) "$k" = NULL (0xa0c4f4c)
-e syntax OK
New form, no specials, outside O framework:
$ perl -MB::Showlex -e \
'my ($i,$j,$k)=(1,"foo"); B::Showlex::compile(-newlex,-nosp)->()'
main Pad has 4 entries
1: PVNV (0x998ffb0) "$i" = IV (0x9983234) 1
2: PVNV (0x998ff68) "$j" = PV (0x998ff5c) "foo"
3: PVNV (0x998ff80) "$k" = NULL (0x998ff74)
Note that this example shows the values of the lexicals, whereas the other
examples did not (as they're compile-time only).
=head2 OPTIONS
The C<-newlex> option produces a more readable C<< name => value >> format,
and is shown in the second example above.
The C<-nosp> option eliminates reporting of SPECIALs, such as C<0: SPECIAL
#1 &PL_sv_undef> above. Reporting of SPECIALs can sometimes overwhelm
your declared lexicals.
=head1 SEE ALSO
C<B::Showlex> can also be used outside of the O framework, as in the third
example. See C<B::Concise> for a fuller explanation of reasons.
=head1 TODO
Some of the reported info, such as hex addresses, is not particularly
valuable. Other information would be more useful for the typical
programmer, such as line-numbers, pad-slot reuses, etc.. Given this,
-newlex isnt a particularly good flag-name.
=head1 AUTHOR
Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
=cut
--- NEW FILE: Stash.pm ---
# Stash.pm -- show what stashes are loaded
# vishalb at hotmail.com
package B::Stash;
our $VERSION = '1.00';
=pod
=head1 NAME
B::Stash - show what stashes are loaded
=cut
BEGIN { %Seen = %INC }
CHECK {
my @arr=scan($main::{"main::"});
@arr=map{s/\:\:$//;$_ eq "<none>"?():$_;} @arr;
print "-umain,-u", join (",-u", at arr) ,"\n";
}
sub scan{
my $start=shift;
my $prefix=shift;
$prefix = '' unless defined $prefix;
my @return;
foreach my $key ( keys %{$start}){
# print $prefix,$key,"\n";
if ($key =~ /::$/){
unless ($start eq ${$start}{$key} or $key eq "B::" ){
push @return, $key unless omit($prefix.$key);
foreach my $subscan ( scan(${$start}{$key},$prefix.$key)){
push @return, "$key".$subscan;
}
}
}
}
return @return;
}
sub omit{
my $module = shift;
my %omit=("DynaLoader::" => 1 , "XSLoader::" => 1, "CORE::" => 1 ,
"CORE::GLOBAL::" => 1, "UNIVERSAL::" => 1 );
return 1 if $omit{$module};
if ($module eq "IO::" or $module eq "IO::Handle::"){
$module =~ s/::/\//g;
return 1 unless $INC{$module};
}
return 0;
}
1;
--- NEW FILE: Asmdata.pm ---
# -#- buffer-read-only: t -#-
#
# Copyright (c) 1996-1999 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.
#
#
#
# This file is autogenerated from bytecode.pl. Changes made here will be lost.
#
package B::Asmdata;
our $VERSION = '1.01';
use Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name);
our(%insn_data, @insn_name, @optype, @specialsv_name);
@optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP PADOP PVOP LOOP COP);
@specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no pWARN_ALL pWARN_NONE);
# XXX insn_data is initialised this way because with a large
# %insn_data = (foo => [...], bar => [...], ...) initialiser
# I get a hard-to-track-down stack underflow and segfault.
$insn_data{comment} = [35, \&PUT_comment_t, "GET_comment_t"];
$insn_data{nop} = [10, \&PUT_none, "GET_none"];
$insn_data{ret} = [0, \&PUT_none, "GET_none"];
$insn_data{ldsv} = [1, \&PUT_svindex, "GET_svindex"];
$insn_data{ldop} = [2, \&PUT_opindex, "GET_opindex"];
$insn_data{stsv} = [3, \&PUT_U32, "GET_U32"];
$insn_data{stop} = [4, \&PUT_U32, "GET_U32"];
$insn_data{stpv} = [5, \&PUT_U32, "GET_U32"];
$insn_data{ldspecsv} = [6, \&PUT_U8, "GET_U8"];
$insn_data{ldspecsvx} = [7, \&PUT_U8, "GET_U8"];
$insn_data{newsv} = [8, \&PUT_U8, "GET_U8"];
$insn_data{newsvx} = [9, \&PUT_U32, "GET_U32"];
$insn_data{newop} = [11, \&PUT_U8, "GET_U8"];
$insn_data{newopx} = [12, \&PUT_U16, "GET_U16"];
$insn_data{newopn} = [13, \&PUT_U8, "GET_U8"];
$insn_data{newpv} = [14, \&PUT_PV, "GET_PV"];
$insn_data{pv_cur} = [15, \&PUT_PADOFFSET, "GET_PADOFFSET"];
$insn_data{pv_free} = [16, \&PUT_none, "GET_none"];
$insn_data{sv_upgrade} = [17, \&PUT_U8, "GET_U8"];
$insn_data{sv_refcnt} = [18, \&PUT_U32, "GET_U32"];
$insn_data{sv_refcnt_add} = [19, \&PUT_I32, "GET_I32"];
$insn_data{sv_flags} = [20, \&PUT_U32, "GET_U32"];
$insn_data{xrv} = [21, \&PUT_svindex, "GET_svindex"];
$insn_data{xpv} = [22, \&PUT_none, "GET_none"];
$insn_data{xpv_cur} = [23, \&PUT_PADOFFSET, "GET_PADOFFSET"];
$insn_data{xpv_len} = [24, \&PUT_PADOFFSET, "GET_PADOFFSET"];
$insn_data{xiv} = [25, \&PUT_IV, "GET_IV"];
$insn_data{xnv} = [26, \&PUT_NV, "GET_NV"];
$insn_data{xlv_targoff} = [27, \&PUT_PADOFFSET, "GET_PADOFFSET"];
$insn_data{xlv_targlen} = [28, \&PUT_PADOFFSET, "GET_PADOFFSET"];
$insn_data{xlv_targ} = [29, \&PUT_svindex, "GET_svindex"];
$insn_data{xlv_type} = [30, \&PUT_U8, "GET_U8"];
$insn_data{xbm_useful} = [31, \&PUT_I32, "GET_I32"];
$insn_data{xbm_previous} = [32, \&PUT_U16, "GET_U16"];
$insn_data{xbm_rare} = [33, \&PUT_U8, "GET_U8"];
$insn_data{xfm_lines} = [34, \&PUT_IV, "GET_IV"];
$insn_data{xio_lines} = [36, \&PUT_IV, "GET_IV"];
$insn_data{xio_page} = [37, \&PUT_IV, "GET_IV"];
$insn_data{xio_page_len} = [38, \&PUT_IV, "GET_IV"];
$insn_data{xio_lines_left} = [39, \&PUT_IV, "GET_IV"];
$insn_data{xio_top_name} = [40, \&PUT_pvindex, "GET_pvindex"];
$insn_data{xio_top_gv} = [41, \&PUT_svindex, "GET_svindex"];
$insn_data{xio_fmt_name} = [42, \&PUT_pvindex, "GET_pvindex"];
$insn_data{xio_fmt_gv} = [43, \&PUT_svindex, "GET_svindex"];
$insn_data{xio_bottom_name} = [44, \&PUT_pvindex, "GET_pvindex"];
$insn_data{xio_bottom_gv} = [45, \&PUT_svindex, "GET_svindex"];
$insn_data{xio_subprocess} = [46, \&PUT_U16, "GET_U16"];
$insn_data{xio_type} = [47, \&PUT_U8, "GET_U8"];
$insn_data{xio_flags} = [48, \&PUT_U8, "GET_U8"];
$insn_data{xcv_xsubany} = [49, \&PUT_svindex, "GET_svindex"];
$insn_data{xcv_stash} = [50, \&PUT_svindex, "GET_svindex"];
$insn_data{xcv_start} = [51, \&PUT_opindex, "GET_opindex"];
$insn_data{xcv_root} = [52, \&PUT_opindex, "GET_opindex"];
$insn_data{xcv_gv} = [53, \&PUT_svindex, "GET_svindex"];
$insn_data{xcv_file} = [54, \&PUT_pvindex, "GET_pvindex"];
$insn_data{xcv_depth} = [55, \&PUT_long, "GET_long"];
$insn_data{xcv_padlist} = [56, \&PUT_svindex, "GET_svindex"];
$insn_data{xcv_outside} = [57, \&PUT_svindex, "GET_svindex"];
$insn_data{xcv_outside_seq} = [58, \&PUT_U32, "GET_U32"];
$insn_data{xcv_flags} = [59, \&PUT_U16, "GET_U16"];
$insn_data{av_extend} = [60, \&PUT_PADOFFSET, "GET_PADOFFSET"];
$insn_data{av_pushx} = [61, \&PUT_svindex, "GET_svindex"];
$insn_data{av_push} = [62, \&PUT_svindex, "GET_svindex"];
$insn_data{xav_fill} = [63, \&PUT_PADOFFSET, "GET_PADOFFSET"];
$insn_data{xav_max} = [64, \&PUT_PADOFFSET, "GET_PADOFFSET"];
$insn_data{xav_flags} = [65, \&PUT_U8, "GET_U8"];
$insn_data{xhv_riter} = [66, \&PUT_I32, "GET_I32"];
$insn_data{xhv_name} = [67, \&PUT_pvindex, "GET_pvindex"];
$insn_data{xhv_pmroot} = [68, \&PUT_opindex, "GET_opindex"];
$insn_data{hv_store} = [69, \&PUT_svindex, "GET_svindex"];
$insn_data{sv_magic} = [70, \&PUT_U8, "GET_U8"];
$insn_data{mg_obj} = [71, \&PUT_svindex, "GET_svindex"];
$insn_data{mg_private} = [72, \&PUT_U16, "GET_U16"];
$insn_data{mg_flags} = [73, \&PUT_U8, "GET_U8"];
$insn_data{mg_name} = [74, \&PUT_pvcontents, "GET_pvcontents"];
$insn_data{mg_namex} = [75, \&PUT_svindex, "GET_svindex"];
$insn_data{xmg_stash} = [76, \&PUT_svindex, "GET_svindex"];
$insn_data{gv_fetchpv} = [77, \&PUT_strconst, "GET_strconst"];
$insn_data{gv_fetchpvx} = [78, \&PUT_strconst, "GET_strconst"];
$insn_data{gv_stashpv} = [79, \&PUT_strconst, "GET_strconst"];
$insn_data{gv_stashpvx} = [80, \&PUT_strconst, "GET_strconst"];
$insn_data{gp_sv} = [81, \&PUT_svindex, "GET_svindex"];
$insn_data{gp_refcnt} = [82, \&PUT_U32, "GET_U32"];
$insn_data{gp_refcnt_add} = [83, \&PUT_I32, "GET_I32"];
$insn_data{gp_av} = [84, \&PUT_svindex, "GET_svindex"];
$insn_data{gp_hv} = [85, \&PUT_svindex, "GET_svindex"];
$insn_data{gp_cv} = [86, \&PUT_svindex, "GET_svindex"];
$insn_data{gp_file} = [87, \&PUT_pvindex, "GET_pvindex"];
$insn_data{gp_io} = [88, \&PUT_svindex, "GET_svindex"];
$insn_data{gp_form} = [89, \&PUT_svindex, "GET_svindex"];
$insn_data{gp_cvgen} = [90, \&PUT_U32, "GET_U32"];
$insn_data{gp_line} = [91, \&PUT_U32, "GET_U32"];
$insn_data{gp_share} = [92, \&PUT_svindex, "GET_svindex"];
$insn_data{xgv_flags} = [93, \&PUT_U8, "GET_U8"];
$insn_data{op_next} = [94, \&PUT_opindex, "GET_opindex"];
$insn_data{op_sibling} = [95, \&PUT_opindex, "GET_opindex"];
$insn_data{op_ppaddr} = [96, \&PUT_strconst, "GET_strconst"];
$insn_data{op_targ} = [97, \&PUT_PADOFFSET, "GET_PADOFFSET"];
$insn_data{op_type} = [98, \&PUT_U16, "GET_U16"];
$insn_data{op_seq} = [99, \&PUT_U16, "GET_U16"];
$insn_data{op_flags} = [100, \&PUT_U8, "GET_U8"];
$insn_data{op_private} = [101, \&PUT_U8, "GET_U8"];
$insn_data{op_first} = [102, \&PUT_opindex, "GET_opindex"];
$insn_data{op_last} = [103, \&PUT_opindex, "GET_opindex"];
$insn_data{op_other} = [104, \&PUT_opindex, "GET_opindex"];
$insn_data{op_pmreplroot} = [105, \&PUT_opindex, "GET_opindex"];
$insn_data{op_pmreplstart} = [106, \&PUT_opindex, "GET_opindex"];
$insn_data{op_pmnext} = [107, \&PUT_opindex, "GET_opindex"];
$insn_data{op_pmstashpv} = [108, \&PUT_pvindex, "GET_pvindex"];
$insn_data{op_pmreplrootpo} = [109, \&PUT_PADOFFSET, "GET_PADOFFSET"];
$insn_data{op_pmstash} = [110, \&PUT_svindex, "GET_svindex"];
$insn_data{op_pmreplrootgv} = [111, \&PUT_svindex, "GET_svindex"];
$insn_data{pregcomp} = [112, \&PUT_pvcontents, "GET_pvcontents"];
$insn_data{op_pmflags} = [113, \&PUT_U16, "GET_U16"];
$insn_data{op_pmpermflags} = [114, \&PUT_U16, "GET_U16"];
$insn_data{op_pmdynflags} = [115, \&PUT_U8, "GET_U8"];
$insn_data{op_sv} = [116, \&PUT_svindex, "GET_svindex"];
$insn_data{op_padix} = [117, \&PUT_PADOFFSET, "GET_PADOFFSET"];
$insn_data{op_pv} = [118, \&PUT_pvcontents, "GET_pvcontents"];
$insn_data{op_pv_tr} = [119, \&PUT_op_tr_array, "GET_op_tr_array"];
$insn_data{op_redoop} = [120, \&PUT_opindex, "GET_opindex"];
$insn_data{op_nextop} = [121, \&PUT_opindex, "GET_opindex"];
$insn_data{op_lastop} = [122, \&PUT_opindex, "GET_opindex"];
$insn_data{cop_label} = [123, \&PUT_pvindex, "GET_pvindex"];
$insn_data{cop_stashpv} = [124, \&PUT_pvindex, "GET_pvindex"];
$insn_data{cop_file} = [125, \&PUT_pvindex, "GET_pvindex"];
$insn_data{cop_stash} = [126, \&PUT_svindex, "GET_svindex"];
$insn_data{cop_filegv} = [127, \&PUT_svindex, "GET_svindex"];
$insn_data{cop_seq} = [128, \&PUT_U32, "GET_U32"];
$insn_data{cop_arybase} = [129, \&PUT_I32, "GET_I32"];
$insn_data{cop_line} = [130, \&PUT_U32, "GET_U32"];
$insn_data{cop_io} = [131, \&PUT_svindex, "GET_svindex"];
$insn_data{cop_warnings} = [132, \&PUT_svindex, "GET_svindex"];
$insn_data{main_start} = [133, \&PUT_opindex, "GET_opindex"];
$insn_data{main_root} = [134, \&PUT_opindex, "GET_opindex"];
$insn_data{main_cv} = [135, \&PUT_svindex, "GET_svindex"];
$insn_data{curpad} = [136, \&PUT_svindex, "GET_svindex"];
$insn_data{push_begin} = [137, \&PUT_svindex, "GET_svindex"];
$insn_data{push_init} = [138, \&PUT_svindex, "GET_svindex"];
$insn_data{push_end} = [139, \&PUT_svindex, "GET_svindex"];
$insn_data{curstash} = [140, \&PUT_svindex, "GET_svindex"];
$insn_data{defstash} = [141, \&PUT_svindex, "GET_svindex"];
$insn_data{data} = [142, \&PUT_U8, "GET_U8"];
$insn_data{incav} = [143, \&PUT_svindex, "GET_svindex"];
$insn_data{load_glob} = [144, \&PUT_svindex, "GET_svindex"];
$insn_data{regex_padav} = [145, \&PUT_svindex, "GET_svindex"];
$insn_data{dowarn} = [146, \&PUT_U8, "GET_U8"];
$insn_data{comppad_name} = [147, \&PUT_svindex, "GET_svindex"];
$insn_data{xgv_stash} = [148, \&PUT_svindex, "GET_svindex"];
$insn_data{signal} = [149, \&PUT_strconst, "GET_strconst"];
$insn_data{formfeed} = [150, \&PUT_svindex, "GET_svindex"];
my ($insn_name, $insn_data);
while (($insn_name, $insn_data) = each %insn_data) {
$insn_name[$insn_data->[0]] = $insn_name;
}
# Fill in any gaps
@insn_name = map($_ || "unused", @insn_name);
1;
__END__
=head1 NAME
B::Asmdata - Autogenerated data about Perl ops, used to generate bytecode
=head1 SYNOPSIS
use B::Asmdata qw(%insn_data @insn_name @optype @specialsv_name);
=head1 DESCRIPTION
Provides information about Perl ops in order to generate bytecode via
a bunch of exported variables. Its mostly used by B::Assembler and
B::Disassembler.
=over 4
=item %insn_data
my($bytecode_num, $put_sub, $get_meth) = @$insn_data{$op_name};
For a given $op_name (for example, 'cop_label', 'sv_flags', etc...)
you get an array ref containing the bytecode number of the op, a
reference to the subroutine used to 'PUT', and the name of the method
used to 'GET'.
=for _private
Add more detail about what $put_sub and $get_meth are and how to use them.
=item @insn_name
my $op_name = $insn_name[$bytecode_num];
A simple mapping of the bytecode number to the name of the op.
Suitable for using with %insn_data like so:
my $op_info = $insn_data{$insn_name[$bytecode_num]};
=item @optype
my $op_type = $optype[$op_type_num];
A simple mapping of the op type number to its type (like 'COP' or 'BINOP').
=item @specialsv_name
my $sv_name = $specialsv_name[$sv_index];
Certain SV types are considered 'special'. They're represented by
B::SPECIAL and are referred to by a number from the specialsv_list.
This array maps that number back to the name of the SV (like 'Nullsv'
or '&PL_sv_undef').
=back
=head1 AUTHOR
Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
=cut
# ex: set ro:
--- NEW FILE: Stackobj.pm ---
# Stackobj.pm
#
# Copyright (c) 1996 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::Stackobj;
our $VERSION = '1.00';
use Exporter ();
@ISA = qw(Exporter);
@EXPORT_OK = qw(set_callback T_UNKNOWN T_DOUBLE T_INT VALID_UNSIGNED
VALID_INT VALID_DOUBLE VALID_SV REGISTER TEMPORARY);
%EXPORT_TAGS = (types => [qw(T_UNKNOWN T_DOUBLE T_INT)],
flags => [qw(VALID_INT VALID_DOUBLE VALID_SV
VALID_UNSIGNED REGISTER TEMPORARY)]);
use Carp qw(confess);
use strict;
use B qw(class SVf_IOK SVf_NOK SVf_IVisUV);
# Types
sub T_UNKNOWN () { 0 }
sub T_DOUBLE () { 1 }
sub T_INT () { 2 }
sub T_SPECIAL () { 3 }
# Flags
sub VALID_INT () { 0x01 }
sub VALID_UNSIGNED () { 0x02 }
sub VALID_DOUBLE () { 0x04 }
sub VALID_SV () { 0x08 }
sub REGISTER () { 0x10 } # no implicit write-back when calling subs
sub TEMPORARY () { 0x20 } # no implicit write-back needed at all
sub SAVE_INT () { 0x40 } #if int part needs to be saved at all
sub SAVE_DOUBLE () { 0x80 } #if double part needs to be saved at all
#
# Callback for runtime code generation
#
my $runtime_callback = sub { confess "set_callback not yet called" };
sub set_callback (&) { $runtime_callback = shift }
sub runtime { &$runtime_callback(@_) }
#
# Methods
#
sub write_back { confess "stack object does not implement write_back" }
sub invalidate { shift->{flags} &= ~(VALID_INT |VALID_UNSIGNED | VALID_DOUBLE) }
sub as_sv {
my $obj = shift;
if (!($obj->{flags} & VALID_SV)) {
$obj->write_back;
$obj->{flags} |= VALID_SV;
}
return $obj->{sv};
}
sub as_int {
my $obj = shift;
if (!($obj->{flags} & VALID_INT)) {
$obj->load_int;
$obj->{flags} |= VALID_INT|SAVE_INT;
}
return $obj->{iv};
}
sub as_double {
my $obj = shift;
if (!($obj->{flags} & VALID_DOUBLE)) {
$obj->load_double;
$obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
}
return $obj->{nv};
}
sub as_numeric {
my $obj = shift;
return $obj->{type} == T_INT ? $obj->as_int : $obj->as_double;
}
sub as_bool {
my $obj=shift;
if ($obj->{flags} & VALID_INT ){
return $obj->{iv};
}
if ($obj->{flags} & VALID_DOUBLE ){
return $obj->{nv};
}
return sprintf("(SvTRUE(%s))", $obj->as_sv) ;
}
#
# Debugging methods
#
sub peek {
my $obj = shift;
my $type = $obj->{type};
my $flags = $obj->{flags};
my @flags;
if ($type == T_UNKNOWN) {
$type = "T_UNKNOWN";
} elsif ($type == T_INT) {
$type = "T_INT";
} elsif ($type == T_DOUBLE) {
$type = "T_DOUBLE";
} else {
$type = "(illegal type $type)";
}
push(@flags, "VALID_INT") if $flags & VALID_INT;
push(@flags, "VALID_DOUBLE") if $flags & VALID_DOUBLE;
push(@flags, "VALID_SV") if $flags & VALID_SV;
push(@flags, "REGISTER") if $flags & REGISTER;
push(@flags, "TEMPORARY") if $flags & TEMPORARY;
@flags = ("none") unless @flags;
return sprintf("%s type=$type flags=%s sv=$obj->{sv}",
class($obj), join("|", @flags));
}
sub minipeek {
my $obj = shift;
my $type = $obj->{type};
my $flags = $obj->{flags};
if ($type == T_INT || $flags & VALID_INT) {
return $obj->{iv};
} elsif ($type == T_DOUBLE || $flags & VALID_DOUBLE) {
return $obj->{nv};
} else {
return $obj->{sv};
}
}
#
# Caller needs to ensure that set_int, set_double,
# set_numeric and set_sv are only invoked on legal lvalues.
#
sub set_int {
my ($obj, $expr,$unsigned) = @_;
runtime("$obj->{iv} = $expr;");
$obj->{flags} &= ~(VALID_SV | VALID_DOUBLE);
$obj->{flags} |= VALID_INT|SAVE_INT;
$obj->{flags} |= VALID_UNSIGNED if $unsigned;
}
sub set_double {
my ($obj, $expr) = @_;
runtime("$obj->{nv} = $expr;");
$obj->{flags} &= ~(VALID_SV | VALID_INT);
$obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
}
sub set_numeric {
my ($obj, $expr) = @_;
if ($obj->{type} == T_INT) {
$obj->set_int($expr);
} else {
$obj->set_double($expr);
}
}
sub set_sv {
my ($obj, $expr) = @_;
runtime("SvSetSV($obj->{sv}, $expr);");
$obj->invalidate;
$obj->{flags} |= VALID_SV;
}
#
# Stackobj::Padsv
#
@B::Stackobj::Padsv::ISA = 'B::Stackobj';
sub B::Stackobj::Padsv::new {
my ($class, $type, $extra_flags, $ix, $iname, $dname) = @_;
$extra_flags |= SAVE_INT if $extra_flags & VALID_INT;
$extra_flags |= SAVE_DOUBLE if $extra_flags & VALID_DOUBLE;
bless {
type => $type,
flags => VALID_SV | $extra_flags,
sv => "PL_curpad[$ix]",
iv => "$iname",
nv => "$dname"
}, $class;
}
sub B::Stackobj::Padsv::load_int {
my $obj = shift;
if ($obj->{flags} & VALID_DOUBLE) {
runtime("$obj->{iv} = $obj->{nv};");
} else {
runtime("$obj->{iv} = SvIV($obj->{sv});");
}
$obj->{flags} |= VALID_INT|SAVE_INT;
}
sub B::Stackobj::Padsv::load_double {
my $obj = shift;
$obj->write_back;
runtime("$obj->{nv} = SvNV($obj->{sv});");
$obj->{flags} |= VALID_DOUBLE|SAVE_DOUBLE;
}
sub B::Stackobj::Padsv::save_int {
my $obj = shift;
return $obj->{flags} & SAVE_INT;
}
sub B::Stackobj::Padsv::save_double {
my $obj = shift;
return $obj->{flags} & SAVE_DOUBLE;
}
sub B::Stackobj::Padsv::write_back {
my $obj = shift;
my $flags = $obj->{flags};
return if $flags & VALID_SV;
if ($flags & VALID_INT) {
if ($flags & VALID_UNSIGNED ){
runtime("sv_setuv($obj->{sv}, $obj->{iv});");
}else{
runtime("sv_setiv($obj->{sv}, $obj->{iv});");
}
} elsif ($flags & VALID_DOUBLE) {
runtime("sv_setnv($obj->{sv}, $obj->{nv});");
} else {
confess "write_back failed for lexical @{[$obj->peek]}\n";
}
$obj->{flags} |= VALID_SV;
}
#
# Stackobj::Const
#
@B::Stackobj::Const::ISA = 'B::Stackobj';
sub B::Stackobj::Const::new {
my ($class, $sv) = @_;
my $obj = bless {
flags => 0,
sv => $sv # holds the SV object until write_back happens
}, $class;
if ( ref($sv) eq "B::SPECIAL" ){
$obj->{type}= T_SPECIAL;
}else{
my $svflags = $sv->FLAGS;
if ($svflags & SVf_IOK) {
$obj->{flags} = VALID_INT|VALID_DOUBLE;
$obj->{type} = T_INT;
if ($svflags & SVf_IVisUV){
$obj->{flags} |= VALID_UNSIGNED;
$obj->{nv} = $obj->{iv} = $sv->UVX;
}else{
$obj->{nv} = $obj->{iv} = $sv->IV;
}
} elsif ($svflags & SVf_NOK) {
$obj->{flags} = VALID_INT|VALID_DOUBLE;
$obj->{type} = T_DOUBLE;
$obj->{iv} = $obj->{nv} = $sv->NV;
} else {
$obj->{type} = T_UNKNOWN;
}
}
return $obj;
}
sub B::Stackobj::Const::write_back {
my $obj = shift;
return if $obj->{flags} & VALID_SV;
# Save the SV object and replace $obj->{sv} by its C source code name
$obj->{sv} = $obj->{sv}->save;
$obj->{flags} |= VALID_SV|VALID_INT|VALID_DOUBLE;
}
sub B::Stackobj::Const::load_int {
my $obj = shift;
if (ref($obj->{sv}) eq "B::RV"){
$obj->{iv} = int($obj->{sv}->RV->PV);
}else{
$obj->{iv} = int($obj->{sv}->PV);
}
$obj->{flags} |= VALID_INT;
}
sub B::Stackobj::Const::load_double {
my $obj = shift;
if (ref($obj->{sv}) eq "B::RV"){
$obj->{nv} = $obj->{sv}->RV->PV + 0.0;
}else{
$obj->{nv} = $obj->{sv}->PV + 0.0;
}
$obj->{flags} |= VALID_DOUBLE;
}
sub B::Stackobj::Const::invalidate {}
#
# Stackobj::Bool
#
@B::Stackobj::Bool::ISA = 'B::Stackobj';
sub B::Stackobj::Bool::new {
my ($class, $preg) = @_;
my $obj = bless {
type => T_INT,
flags => VALID_INT|VALID_DOUBLE,
iv => $$preg,
nv => $$preg,
preg => $preg # this holds our ref to the pseudo-reg
}, $class;
return $obj;
}
sub B::Stackobj::Bool::write_back {
my $obj = shift;
return if $obj->{flags} & VALID_SV;
$obj->{sv} = "($obj->{iv} ? &PL_sv_yes : &PL_sv_no)";
$obj->{flags} |= VALID_SV;
}
# XXX Might want to handle as_double/set_double/load_double?
sub B::Stackobj::Bool::invalidate {}
1;
__END__
=head1 NAME
B::Stackobj - Helper module for CC backend
=head1 SYNOPSIS
use B::Stackobj;
=head1 DESCRIPTION
See F<ext/B/README>.
=head1 AUTHOR
Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
=cut
--- NEW FILE: makeliblinks ---
use File::Find;
use Config;
if (@ARGV != 2) {
warn <<"EOT";
Usage: makeliblinks libautodir targetdir
where libautodir is the architecture-dependent auto directory
(e.g. $Config::Config{archlib}/auto).
EOT
exit 2;
}
my ($libautodir, $targetdir) = @ARGV;
# Calculate relative path prefix from $targetdir to $libautodir
sub relprefix {
my ($to, $from) = @_;
my $up;
for ($up = 0; substr($to, 0, length($from)) ne $from; $up++) {
$from =~ s(
[^/]+ (?# a group of non-slashes)
/* (?# maybe with some trailing slashes)
$ (?# at the end of the path)
)()x;
}
return (("../" x $up) . substr($to, length($from)));
}
my $relprefix = relprefix($libautodir, $targetdir);
my ($dlext, $lib_ext) = @Config::Config{qw(dlext lib_ext)};
sub link_if_library {
if (/\.($dlext|$lib_ext)$/o) {
my $ext = $1;
my $name = $File::Find::name;
if (substr($name, 0, length($libautodir) + 1) ne "$libautodir/") {
die "directory of $name doesn't match $libautodir\n";
}
substr($name, 0, length($libautodir) + 1) = '';
my @parts = split(m(/), $name);
if ($parts[-1] ne "$parts[-2].$ext") {
die "module name $_ doesn't match its directory $libautodir\n";
}
pop @parts;
my $libpath = "$targetdir/lib" . join("__", @parts) . ".$ext";
print "$libpath -> $relprefix/$name\n";
symlink("$relprefix/$name", $libpath)
or warn "above link failed with error: $!\n";
}
}
find(\&link_if_library, $libautodir);
exit 0;
--- NEW FILE: Debug.pm ---
package B::Debug;
our $VERSION = '1.02_01';
use strict;
use B qw(peekop class walkoptree walkoptree_exec
main_start main_root cstring sv_undef);
use B::Asmdata qw(@specialsv_name);
my %done_gv;
sub B::OP::debug {
my ($op) = @_;
printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type;
%s (0x%lx)
op_next 0x%x
op_sibling 0x%x
op_ppaddr %s
op_targ %d
op_type %d
EOT
if ($] > 5.009) {
printf <<'EOT', $op->opt, $op->static;
op_opt %d
op_static %d
EOT
} else {
printf <<'EOT', $op->seq;
op_seq %d
EOT
}
printf <<'EOT', $op->flags, $op->private;
op_flags %d
op_private %d
EOT
}
sub B::UNOP::debug {
my ($op) = @_;
$op->B::OP::debug();
printf "\top_first\t0x%x\n", ${$op->first};
}
sub B::BINOP::debug {
my ($op) = @_;
$op->B::UNOP::debug();
printf "\top_last\t\t0x%x\n", ${$op->last};
}
sub B::LOOP::debug {
my ($op) = @_;
$op->B::BINOP::debug();
printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop};
op_redoop 0x%x
op_nextop 0x%x
op_lastop 0x%x
EOT
}
sub B::LOGOP::debug {
my ($op) = @_;
$op->B::UNOP::debug();
printf "\top_other\t0x%x\n", ${$op->other};
}
sub B::LISTOP::debug {
my ($op) = @_;
$op->B::BINOP::debug();
printf "\top_children\t%d\n", $op->children;
}
sub B::PMOP::debug {
my ($op) = @_;
$op->B::LISTOP::debug();
printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot};
printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
printf "\top_pmnext\t0x%x\n", ${$op->pmnext};
printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);
printf "\top_pmflags\t0x%x\n", $op->pmflags;
$op->pmreplroot->debug;
}
sub B::COP::debug {
my ($op) = @_;
$op->B::OP::debug();
my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);
cop_label %s
cop_stashpv %s
cop_file %s
cop_seq %d
cop_arybase %d
cop_line %d
cop_warnings 0x%x
cop_io %s
EOT
}
sub B::SVOP::debug {
my ($op) = @_;
$op->B::OP::debug();
printf "\top_sv\t\t0x%x\n", ${$op->sv};
$op->sv->debug;
}
sub B::PVOP::debug {
my ($op) = @_;
$op->B::OP::debug();
printf "\top_pv\t\t%s\n", cstring($op->pv);
}
sub B::PADOP::debug {
my ($op) = @_;
$op->B::OP::debug();
printf "\top_padix\t\t%ld\n", $op->padix;
}
sub B::NULL::debug {
my ($sv) = @_;
if ($$sv == ${sv_undef()}) {
print "&sv_undef\n";
} else {
printf "NULL (0x%x)\n", $$sv;
}
}
sub B::SV::debug {
my ($sv) = @_;
if (!$$sv) {
print class($sv), " = NULL\n";
return;
}
printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;
%s (0x%x)
REFCNT %d
FLAGS 0x%x
EOT
}
sub B::RV::debug {
my ($rv) = @_;
B::SV::debug($rv);
printf <<'EOT', ${$rv->RV};
RV 0x%x
EOT
$rv->RV->debug;
}
sub B::PV::debug {
my ($sv) = @_;
$sv->B::SV::debug();
my $pv = $sv->PV();
printf <<'EOT', cstring($pv), length($pv);
xpv_pv %s
xpv_cur %d
EOT
}
sub B::IV::debug {
my ($sv) = @_;
$sv->B::SV::debug();
printf "\txiv_iv\t\t%d\n", $sv->IV;
}
sub B::NV::debug {
my ($sv) = @_;
$sv->B::IV::debug();
printf "\txnv_nv\t\t%s\n", $sv->NV;
}
sub B::PVIV::debug {
my ($sv) = @_;
$sv->B::PV::debug();
printf "\txiv_iv\t\t%d\n", $sv->IV;
}
sub B::PVNV::debug {
my ($sv) = @_;
$sv->B::PVIV::debug();
printf "\txnv_nv\t\t%s\n", $sv->NV;
}
sub B::PVLV::debug {
my ($sv) = @_;
$sv->B::PVNV::debug();
printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
}
sub B::BM::debug {
my ($sv) = @_;
$sv->B::PVNV::debug();
printf "\txbm_useful\t%d\n", $sv->USEFUL;
printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
}
sub B::CV::debug {
my ($sv) = @_;
$sv->B::PVNV::debug();
my ($stash) = $sv->STASH;
my ($start) = $sv->START;
my ($root) = $sv->ROOT;
my ($padlist) = $sv->PADLIST;
my ($file) = $sv->FILE;
my ($gv) = $sv->GV;
printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;
STASH 0x%x
START 0x%x
ROOT 0x%x
GV 0x%x
FILE %s
DEPTH %d
PADLIST 0x%x
OUTSIDE 0x%x
OUTSIDE_SEQ %d
EOT
$start->debug if $start;
$root->debug if $root;
$gv->debug if $gv;
$padlist->debug if $padlist;
}
sub B::AV::debug {
my ($av) = @_;
$av->B::SV::debug;
my(@array) = $av->ARRAY;
print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
printf <<'EOT', scalar(@array), $av->MAX, $av->OFF;
FILL %d
MAX %d
OFF %d
EOT
printf <<'EOT', $av->AvFLAGS if $] < 5.009;
AvFLAGS %d
EOT
}
sub B::GV::debug {
my ($gv) = @_;
if ($done_gv{$$gv}++) {
printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
return;
}
my ($sv) = $gv->SV;
my ($av) = $gv->AV;
my ($cv) = $gv->CV;
$gv->B::SV::debug;
printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS;
NAME %s
STASH %s (0x%x)
SV 0x%x
GvREFCNT %d
FORM 0x%x
AV 0x%x
HV 0x%x
EGV 0x%x
CV 0x%x
CVGEN %d
LINE %d
FILE %s
GvFLAGS 0x%x
EOT
$sv->debug if $sv;
$av->debug if $av;
$cv->debug if $cv;
}
sub B::SPECIAL::debug {
my $sv = shift;
print $specialsv_name[$$sv], "\n";
}
sub compile {
my $order = shift;
B::clearsym();
if ($order && $order eq "exec") {
return sub { walkoptree_exec(main_start, "debug") }
} else {
return sub { walkoptree(main_root, "debug") }
}
}
1;
__END__
=head1 NAME
B::Debug - Walk Perl syntax tree, printing debug info about ops
=head1 SYNOPSIS
perl -MO=Debug[,OPTIONS] foo.pl
=head1 DESCRIPTION
See F<ext/B/README>.
=head1 AUTHOR
Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
=cut
--- NEW FILE: Bblock.pm ---
package B::Bblock;
our $VERSION = '1.02_01';
use Exporter ();
@ISA = "Exporter";
@EXPORT_OK = qw(find_leaders);
use B qw(peekop walkoptree walkoptree_exec
main_root main_start svref_2object
OPf_SPECIAL OPf_STACKED );
use B::Concise qw(concise_cv concise_main set_style_standard);
use strict;
my $bblock;
my @bblock_ends;
sub mark_leader {
my $op = shift;
if ($$op) {
$bblock->{$$op} = $op;
}
}
sub remove_sortblock{
foreach (keys %$bblock){
my $leader=$$bblock{$_};
delete $$bblock{$_} if( $leader == 0);
}
}
sub find_leaders {
my ($root, $start) = @_;
$bblock = {};
mark_leader($start) if ( ref $start ne "B::NULL" );
walkoptree($root, "mark_if_leader") if ((ref $root) ne "B::NULL") ;
remove_sortblock();
return $bblock;
}
# Debugging
sub walk_bblocks {
my ($root, $start) = @_;
my ($op, $lastop, $leader, $bb);
$bblock = {};
mark_leader($start);
walkoptree($root, "mark_if_leader");
my @leaders = values %$bblock;
while ($leader = shift @leaders) {
$lastop = $leader;
$op = $leader->next;
while ($$op && !exists($bblock->{$$op})) {
$bblock->{$$op} = $leader;
$lastop = $op;
$op = $op->next;
}
push(@bblock_ends, [$leader, $lastop]);
}
foreach $bb (@bblock_ends) {
($leader, $lastop) = @$bb;
printf "%s .. %s\n", peekop($leader), peekop($lastop);
for ($op = $leader; $$op != $$lastop; $op = $op->next) {
printf " %s\n", peekop($op);
}
printf " %s\n", peekop($lastop);
}
}
sub walk_bblocks_obj {
my $cvref = shift;
my $cv = svref_2object($cvref);
walk_bblocks($cv->ROOT, $cv->START);
}
sub B::OP::mark_if_leader {}
sub B::COP::mark_if_leader {
my $op = shift;
if ($op->label) {
mark_leader($op);
}
}
sub B::LOOP::mark_if_leader {
my $op = shift;
mark_leader($op->next);
mark_leader($op->nextop);
mark_leader($op->redoop);
mark_leader($op->lastop->next);
}
sub B::LOGOP::mark_if_leader {
my $op = shift;
my $opname = $op->name;
mark_leader($op->next);
if ($opname eq "entertry") {
mark_leader($op->other->next);
} else {
mark_leader($op->other);
}
}
sub B::LISTOP::mark_if_leader {
my $op = shift;
my $first=$op->first;
$first=$first->next while ($first->name eq "null");
mark_leader($op->first) unless (exists( $bblock->{$$first}));
mark_leader($op->next);
if ($op->name eq "sort" and $op->flags & OPf_SPECIAL
and $op->flags & OPf_STACKED){
my $root=$op->first->sibling->first;
my $leader=$root->first;
$bblock->{$$leader} = 0;
}
}
sub B::PMOP::mark_if_leader {
my $op = shift;
if ($op->name ne "pushre") {
my $replroot = $op->pmreplroot;
if ($$replroot) {
mark_leader($replroot);
mark_leader($op->next);
mark_leader($op->pmreplstart);
}
}
}
# PMOP stuff omitted
sub compile {
my @options = @_;
B::clearsym();
if (@options) {
return sub {
my $objname;
foreach $objname (@options) {
$objname = "main::$objname" unless $objname =~ /::/;
eval "walk_bblocks_obj(\\&$objname)";
die "walk_bblocks_obj(\\&$objname) failed: $@" if $@;
print "-------\n";
set_style_standard("terse");
eval "concise_cv('exec', \\&$objname)";
die "concise_cv('exec', \\&$objname) failed: $@" if $@;
}
}
} else {
return sub {
walk_bblocks(main_root, main_start);
print "-------\n";
set_style_standard("terse");
concise_main("exec");
};
}
}
# Basic block leaders:
# Any COP (pp_nextstate) with a non-NULL label
# [The op after a pp_enter] Omit
# [The op after a pp_entersub. Don't count this one.]
# The ops pointed at by nextop, redoop and lastop->op_next of a LOOP
# The ops pointed at by op_next and op_other of a LOGOP, except
# for pp_entertry which has op_next and op_other->op_next
# The op pointed at by op_pmreplstart of a PMOP
# The op pointed at by op_other->op_pmreplstart of pp_substcont?
# [The op after a pp_return] Omit
1;
__END__
=head1 NAME
B::Bblock - Walk basic blocks
=head1 SYNOPSIS
# External interface
perl -MO=Bblock[,OPTIONS] foo.pl
# Programmatic API
use B::Bblock qw(find_leaders);
my $leaders = find_leaders($root_op, $start_op);
=head1 DESCRIPTION
This module is used by the B::CC back end. It walks "basic blocks".
A basic block is a series of operations which is known to execute from
start to finish, with no possibility of branching or halting.
It can be used either stand alone or from inside another program.
=for _private
Somebody who understands the stand-alone options document them, please.
=head2 Functions
=over 4
=item B<find_leaders>
my $leaders = find_leaders($root_op, $start_op);
Given the root of the op tree and an op from which to start
processing, it will return a hash ref representing all the ops which
start a block.
=for _private
The above description may be somewhat wrong.
The values of %$leaders are the op objects themselves. Keys are $$op
addresses.
=for _private
Above cribbed from B::CC's comments. What's a $$op address?
=back
=head1 AUTHOR
Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
=cut
--- NEW FILE: Concise.pm ---
package B::Concise;
# Copyright (C) 2000-2003 Stephen McCamant. All rights reserved.
# This program is free software; you can redistribute and/or modify it
# under the same terms as Perl itself.
# Note: we need to keep track of how many use declarations/BEGIN
# blocks this module uses, so we can avoid printing them when user
# asks for the BEGIN blocks in her program. Update the comments and
# the count in concise_specials if you add or delete one. The
# -MO=Concise counts as use #1.
use strict; # use #2
use warnings; # uses #3 and #4, since warnings uses Carp
use Exporter (); # use #5
our $VERSION = "0.66";
our @ISA = qw(Exporter);
our @EXPORT_OK = qw( set_style set_style_standard add_callback
[...1589 lines suppressed...]
the concise output from two identical anonymous subroutines (but
different instances). Without the reset, B::Concise, seeing that
they're separate optrees, generates different sequence numbers in
the output.
=head2 Errors
Errors in rendering (non-existent function-name, non-existent coderef)
are written to the STDOUT, or wherever you've set it via
walk_output().
Errors using the various *style* calls, and bad args to walk_output(),
result in die(). Use an eval if you wish to catch these errors and
continue processing.
=head1 AUTHOR
Stephen McCamant, E<lt>smcc at CSUA.Berkeley.EDUE<gt>.
=cut
--- NEW FILE: assemble ---
use B::Assembler qw(assemble_fh);
use FileHandle;
my ($filename, $fh, $out);
if ($ARGV[0] eq "-d") {
B::Assembler::debug(1);
shift;
}
$out = \*STDOUT;
if (@ARGV == 0) {
$fh = \*STDIN;
$filename = "-";
} elsif (@ARGV == 1) {
$filename = $ARGV[0];
$fh = new FileHandle "<$filename";
} elsif (@ARGV == 2) {
$filename = $ARGV[0];
$fh = new FileHandle "<$filename";
$out = new FileHandle ">$ARGV[1]";
} else {
die "Usage: assemble [filename] [outfilename]\n";
}
binmode $out;
$SIG{__WARN__} = sub { warn "$filename:@_" };
$SIG{__DIE__} = sub { die "$filename: @_" };
assemble_fh($fh, sub { print $out @_ });
--- NEW FILE: Assembler.pm ---
# Assembler.pm
#
# Copyright (c) 1996 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::Assembler;
use Exporter;
use B qw(ppname);
use B::Asmdata qw(%insn_data @insn_name);
use Config qw(%Config);
require ByteLoader; # we just need its $VERSION
no warnings; # XXX
@ISA = qw(Exporter);
@EXPORT_OK = qw(assemble_fh newasm endasm assemble asm);
$VERSION = 0.07;
use strict;
my %opnumber;
my ($i, $opname);
for ($i = 0; defined($opname = ppname($i)); $i++) {
$opnumber{$opname} = $i;
}
my($linenum, $errors, $out); # global state, set up by newasm
sub error {
my $str = shift;
warn "$linenum: $str\n";
$errors++;
}
my $debug = 0;
sub debug { $debug = shift }
sub limcheck($$$$){
my( $val, $lo, $hi, $loc ) = @_;
if( $val < $lo || $hi < $val ){
error "argument for $loc outside [$lo, $hi]: $val";
$val = $hi;
}
return $val;
}
#
# First define all the data conversion subs to which Asmdata will refer
#
sub B::Asmdata::PUT_U8 {
my $arg = shift;
my $c = uncstring($arg);
if (defined($c)) {
if (length($c) != 1) {
error "argument for U8 is too long: $c";
$c = substr($c, 0, 1);
}
} else {
$arg = limcheck( $arg, 0, 0xff, 'U8' );
$c = chr($arg);
}
return $c;
}
sub B::Asmdata::PUT_U16 {
my $arg = limcheck( $_[0], 0, 0xffff, 'U16' );
pack("S", $arg);
}
sub B::Asmdata::PUT_U32 {
my $arg = limcheck( $_[0], 0, 0xffffffff, 'U32' );
pack("L", $arg);
}
sub B::Asmdata::PUT_I32 {
my $arg = limcheck( $_[0], -0x80000000, 0x7fffffff, 'I32' );
pack("l", $arg);
}
sub B::Asmdata::PUT_NV { sprintf("%s\0", $_[0]) } # "%lf" looses precision and pack('d',...)
# may not even be portable between compilers
sub B::Asmdata::PUT_objindex { # could allow names here
my $arg = limcheck( $_[0], 0, 0xffffffff, '*index' );
pack("L", $arg);
}
sub B::Asmdata::PUT_svindex { &B::Asmdata::PUT_objindex }
sub B::Asmdata::PUT_opindex { &B::Asmdata::PUT_objindex }
sub B::Asmdata::PUT_pvindex { &B::Asmdata::PUT_objindex }
sub B::Asmdata::PUT_strconst {
my $arg = shift;
my $str = uncstring($arg);
if (!defined($str)) {
error "bad string constant: $arg";
$str = '';
}
if ($str =~ s/\0//g) {
error "string constant argument contains NUL: $arg";
$str = '';
}
return $str . "\0";
}
sub B::Asmdata::PUT_pvcontents {
my $arg = shift;
error "extraneous argument: $arg" if defined $arg;
return "";
}
sub B::Asmdata::PUT_PV {
my $arg = shift;
my $str = uncstring($arg);
if( ! defined($str) ){
error "bad string argument: $arg";
$str = '';
}
return pack("L", length($str)) . $str;
}
sub B::Asmdata::PUT_comment_t {
my $arg = shift;
$arg = uncstring($arg);
error "bad string argument: $arg" unless defined($arg);
if ($arg =~ s/\n//g) {
error "comment argument contains linefeed: $arg";
}
return $arg . "\n";
}
sub B::Asmdata::PUT_double { sprintf("%s\0", $_[0]) } # see PUT_NV above
sub B::Asmdata::PUT_none {
my $arg = shift;
error "extraneous argument: $arg" if defined $arg;
return "";
}
sub B::Asmdata::PUT_op_tr_array {
my @ary = split /\s*,\s*/, shift;
return pack "S*", @ary;
}
sub B::Asmdata::PUT_IV64 {
return pack "Q", shift;
}
sub B::Asmdata::PUT_IV {
$Config{ivsize} == 4 ? &B::Asmdata::PUT_I32 : &B::Asmdata::PUT_IV64;
}
sub B::Asmdata::PUT_PADOFFSET {
$Config{ptrsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
}
sub B::Asmdata::PUT_long {
$Config{longsize} == 8 ? &B::Asmdata::PUT_IV64 : &B::Asmdata::PUT_U32;
}
my %unesc = (n => "\n", r => "\r", t => "\t", a => "\a",
b => "\b", f => "\f", v => "\013");
sub uncstring {
my $s = shift;
$s =~ s/^"// and $s =~ s/"$// or return undef;
$s =~ s/\\(\d\d\d|.)/length($1) == 3 ? chr(oct($1)) : ($unesc{$1}||$1)/eg;
return $s;
}
sub strip_comments {
my $stmt = shift;
# Comments only allowed in instructions which don't take string arguments
# Treat string as a single line so .* eats \n characters.
$stmt =~ s{
^\s* # Ignore leading whitespace
(
[^"]* # A double quote '"' indicates a string argument. If we
# find a double quote, the match fails and we strip nothing.
)
\s*\# # Any amount of whitespace plus the comment marker...
.*$ # ...which carries on to end-of-string.
}{$1}sx; # Keep only the instruction and optional argument.
return $stmt;
}
# create the ByteCode header: magic, archname, ByteLoader $VERSION, ivsize,
# ptrsize, byteorder
# nvtype is irrelevant (floats are stored as strings)
# byteorder is strconst not U32 because of varying size issues
sub gen_header {
my $header = "";
$header .= B::Asmdata::PUT_U32(0x43424c50); # 'PLBC'
$header .= B::Asmdata::PUT_strconst('"' . $Config{archname}. '"');
$header .= B::Asmdata::PUT_strconst(qq["$ByteLoader::VERSION"]);
$header .= B::Asmdata::PUT_U32($Config{ivsize});
$header .= B::Asmdata::PUT_U32($Config{ptrsize});
$header;
}
sub parse_statement {
my $stmt = shift;
my ($insn, $arg) = $stmt =~ m{
^\s* # allow (but ignore) leading whitespace
(.*?) # Instruction continues up until...
(?: # ...an optional whitespace+argument group
\s+ # first whitespace.
(.*) # The argument is all the rest (newlines included).
)?$ # anchor at end-of-line
}sx;
if (defined($arg)) {
if ($arg =~ s/^0x(?=[0-9a-fA-F]+$)//) {
$arg = hex($arg);
} elsif ($arg =~ s/^0(?=[0-7]+$)//) {
$arg = oct($arg);
} elsif ($arg =~ /^pp_/) {
$arg =~ s/\s*$//; # strip trailing whitespace
my $opnum = $opnumber{$arg};
if (defined($opnum)) {
$arg = $opnum;
} else {
error qq(No such op type "$arg");
$arg = 0;
}
}
}
return ($insn, $arg);
}
sub assemble_insn {
my ($insn, $arg) = @_;
my $data = $insn_data{$insn};
if (defined($data)) {
my ($bytecode, $putsub) = @{$data}[0, 1];
my $argcode = &$putsub($arg);
return chr($bytecode).$argcode;
} else {
error qq(no such instruction "$insn");
return "";
}
}
sub assemble_fh {
my ($fh, $out) = @_;
my $line;
my $asm = newasm($out);
while ($line = <$fh>) {
assemble($line);
}
endasm();
}
sub newasm {
my($outsub) = @_;
die "Invalid printing routine for B::Assembler\n" unless ref $outsub eq 'CODE';
die <<EOD if ref $out;
Can't have multiple byteassembly sessions at once!
(perhaps you forgot an endasm()?)
EOD
$linenum = $errors = 0;
$out = $outsub;
$out->(gen_header());
}
sub endasm {
if ($errors) {
die "There were $errors assembly errors\n";
}
$linenum = $errors = $out = 0;
}
sub assemble {
my($line) = @_;
my ($insn, $arg);
$linenum++;
chomp $line;
if ($debug) {
my $quotedline = $line;
$quotedline =~ s/\\/\\\\/g;
$quotedline =~ s/"/\\"/g;
$out->(assemble_insn("comment", qq("$quotedline")));
}
if( $line = strip_comments($line) ){
($insn, $arg) = parse_statement($line);
$out->(assemble_insn($insn, $arg));
if ($debug) {
$out->(assemble_insn("nop", undef));
}
}
}
### temporary workaround
sub asm {
return if $_[0] =~ /\s*\W/;
if (defined $_[1]) {
return if $_[1] eq "0" and
$_[0] !~ /^(?:newsvx?|av_pushx?|av_extend|xav_flags)$/;
return if $_[1] eq "1" and $_[0] =~ /^(?:sv_refcnt)$/;
}
assemble "@_";
}
1;
__END__
=head1 NAME
B::Assembler - Assemble Perl bytecode
=head1 SYNOPSIS
use B::Assembler qw(newasm endasm assemble);
newasm(\&printsub); # sets up for assembly
assemble($buf); # assembles one line
endasm(); # closes down
use B::Assembler qw(assemble_fh);
assemble_fh($fh, \&printsub); # assemble everything in $fh
=head1 DESCRIPTION
See F<ext/B/B/Assembler.pm>.
=head1 AUTHORS
Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
Per-statement interface by Benjamin Stuhl, C<sho_pi at hotmail.com>
=cut
--- NEW FILE: Bytecode.pm ---
# B::Bytecode.pm
# Copyright (c) 2003 Enache Adrian. All rights reserved.
# This module is free software; you can redistribute and/or modify
# it under the same terms as Perl itself.
# Based on the original Bytecode.pm module written by Malcolm Beattie.
package B::Bytecode;
our $VERSION = '1.01_01';
use strict;
use Config;
use B qw(class main_cv main_root main_start cstring comppadlist
defstash curstash begin_av init_av end_av inc_gv warnhook diehook
dowarn SVt_PVGV SVt_PVHV OPf_SPECIAL OPf_STACKED OPf_MOD
OPpLVAL_INTRO SVf_FAKE SVf_READONLY);
use B::Asmdata qw(@specialsv_name);
use B::Assembler qw(asm newasm endasm);
#################################################
my ($varix, $opix, $savebegins, %walked, %files, @cloop);
my %strtab = (0,0);
my %svtab = (0,0);
my %optab = (0,0);
my %spectab = (0,0);
my $tix = 1;
sub asm;
sub nice ($) { }
BEGIN {
my $ithreads = $Config{'useithreads'} eq 'define';
eval qq{
sub ITHREADS() { $ithreads }
sub VERSION() { $] }
}; die $@ if $@;
}
#################################################
sub pvstring {
my $pv = shift;
defined($pv) ? cstring ($pv."\0") : "\"\"";
}
sub pvix {
my $str = pvstring shift;
my $ix = $strtab{$str};
defined($ix) ? $ix : do {
asm "newpv", $str;
asm "stpv", $strtab{$str} = $tix;
$tix++;
}
}
sub B::OP::ix {
my $op = shift;
my $ix = $optab{$$op};
defined($ix) ? $ix : do {
nice "[".$op->name." $tix]";
asm "newopx", $op->size | $op->type <<7;
$optab{$$op} = $opix = $ix = $tix++;
$op->bsave($ix);
$ix;
}
}
sub B::SPECIAL::ix {
my $spec = shift;
my $ix = $spectab{$$spec};
defined($ix) ? $ix : do {
nice '['.$specialsv_name[$$spec].']';
asm "ldspecsvx", $$spec;
$spectab{$$spec} = $varix = $tix++;
}
}
sub B::SV::ix {
my $sv = shift;
my $ix = $svtab{$$sv};
defined($ix) ? $ix : do {
nice '['.class($sv).']';
asm "newsvx", $sv->FLAGS;
$svtab{$$sv} = $varix = $ix = $tix++;
$sv->bsave($ix);
$ix;
}
}
sub B::GV::ix {
my ($gv,$desired) = @_;
my $ix = $svtab{$$gv};
defined($ix) ? $ix : do {
if ($gv->GP) {
my ($svix, $avix, $hvix, $cvix, $ioix, $formix);
nice "[GV]";
my $name = $gv->STASH->NAME . "::" . $gv->NAME;
asm "gv_fetchpvx", cstring $name;
$svtab{$$gv} = $varix = $ix = $tix++;
asm "sv_flags", $gv->FLAGS;
asm "sv_refcnt", $gv->REFCNT;
asm "xgv_flags", $gv->GvFLAGS;
asm "gp_refcnt", $gv->GvREFCNT;
asm "load_glob", $ix if $name eq "CORE::GLOBAL::glob";
return $ix
unless $desired || desired $gv;
$svix = $gv->SV->ix;
$avix = $gv->AV->ix;
$hvix = $gv->HV->ix;
# XXX {{{{
my $cv = $gv->CV;
$cvix = $$cv && defined $files{$cv->FILE} ? $cv->ix : 0;
my $form = $gv->FORM;
$formix = $$form && defined $files{$form->FILE} ? $form->ix : 0;
$ioix = $name !~ /STDOUT$/ ? $gv->IO->ix : 0;
# }}}} XXX
nice "-GV-",
asm "ldsv", $varix = $ix unless $ix == $varix;
asm "gp_sv", $svix;
asm "gp_av", $avix;
asm "gp_hv", $hvix;
asm "gp_cv", $cvix;
asm "gp_io", $ioix;
asm "gp_cvgen", $gv->CVGEN;
asm "gp_form", $formix;
asm "gp_file", pvix $gv->FILE;
asm "gp_line", $gv->LINE;
asm "formfeed", $svix if $name eq "main::\cL";
} else {
nice "[GV]";
asm "newsvx", $gv->FLAGS;
$svtab{$$gv} = $varix = $ix = $tix++;
my $stashix = $gv->STASH->ix;
$gv->B::PVMG::bsave($ix);
asm "xgv_flags", $gv->GvFLAGS;
asm "xgv_stash", $stashix;
}
$ix;
}
}
sub B::HV::ix {
my $hv = shift;
my $ix = $svtab{$$hv};
defined($ix) ? $ix : do {
my ($ix,$i, at array);
my $name = $hv->NAME;
if ($name) {
nice "[STASH]";
asm "gv_stashpvx", cstring $name;
asm "sv_flags", $hv->FLAGS;
$svtab{$$hv} = $varix = $ix = $tix++;
asm "xhv_name", pvix $name;
# my $pmrootix = $hv->PMROOT->ix; # XXX
asm "ldsv", $varix = $ix unless $ix == $varix;
# asm "xhv_pmroot", $pmrootix; # XXX
} else {
nice "[HV]";
asm "newsvx", $hv->FLAGS;
$svtab{$$hv} = $varix = $ix = $tix++;
my $stashix = $hv->SvSTASH->ix;
for (@array = $hv->ARRAY) {
next if $i = not $i;
$_ = $_->ix;
}
nice "-HV-",
asm "ldsv", $varix = $ix unless $ix == $varix;
($i = not $i) ? asm ("newpv", pvstring $_) : asm("hv_store", $_)
for @array;
if (VERSION < 5.009) {
asm "xnv", $hv->NVX;
}
asm "xmg_stash", $stashix;
asm "xhv_riter", $hv->RITER;
}
asm "sv_refcnt", $hv->REFCNT;
$ix;
}
}
sub B::NULL::ix {
my $sv = shift;
$$sv ? $sv->B::SV::ix : 0;
}
sub B::NULL::opwalk { 0 }
#################################################
sub B::NULL::bsave {
my ($sv,$ix) = @_;
nice '-'.class($sv).'-',
asm "ldsv", $varix = $ix unless $ix == $varix;
asm "sv_refcnt", $sv->REFCNT;
}
sub B::SV::bsave;
*B::SV::bsave = *B::NULL::bsave;
sub B::RV::bsave {
my ($sv,$ix) = @_;
my $rvix = $sv->RV->ix;
$sv->B::NULL::bsave($ix);
asm "xrv", $rvix;
}
sub B::PV::bsave {
my ($sv,$ix) = @_;
$sv->B::NULL::bsave($ix);
asm "newpv", pvstring $sv->PVBM;
asm "xpv";
}
sub B::IV::bsave {
my ($sv,$ix) = @_;
$sv->B::NULL::bsave($ix);
asm "xiv", $sv->IVX;
}
sub B::NV::bsave {
my ($sv,$ix) = @_;
$sv->B::NULL::bsave($ix);
asm "xnv", sprintf "%.40g", $sv->NVX;
}
sub B::PVIV::bsave {
my ($sv,$ix) = @_;
$sv->POK ?
$sv->B::PV::bsave($ix):
$sv->ROK ?
$sv->B::RV::bsave($ix):
$sv->B::NULL::bsave($ix);
if (VERSION >= 5.009) {
# See note below in B::PVNV::bsave
return if $sv->isa('B::AV');
return if $sv->isa('B::HV');
}
asm "xiv", !ITHREADS && $sv->FLAGS & (SVf_FAKE|SVf_READONLY) ?
"0 but true" : $sv->IVX;
}
sub B::PVNV::bsave {
my ($sv,$ix) = @_;
$sv->B::PVIV::bsave($ix);
if (VERSION >= 5.009) {
# Magical AVs end up here, but AVs now don't have an NV slot actually
# allocated. Hence don't write out assembly to store the NV slot if
# we're actually an array.
return if $sv->isa('B::AV');
# Likewise HVs have no NV slot actually allocated.
# I don't think that they can get here, but better safe than sorry
return if $sv->isa('B::HV');
}
asm "xnv", sprintf "%.40g", $sv->NVX;
}
sub B::PVMG::domagic {
my ($sv,$ix) = @_;
nice '-MAGICAL-';
my @mglist = $sv->MAGIC;
my (@mgix, @namix);
for (@mglist) {
push @mgix, $_->OBJ->ix;
push @namix, $_->PTR->ix if $_->LENGTH == B::HEf_SVKEY;
}
nice '-'.class($sv).'-',
asm "ldsv", $varix = $ix unless $ix == $varix;
for (@mglist) {
asm "sv_magic", cstring $_->TYPE;
asm "mg_obj", shift @mgix;
my $length = $_->LENGTH;
if ($length == B::HEf_SVKEY) {
asm "mg_namex", shift @namix;
} elsif ($length) {
asm "newpv", pvstring $_->PTR;
asm "mg_name";
}
}
}
sub B::PVMG::bsave {
my ($sv,$ix) = @_;
my $stashix = $sv->SvSTASH->ix;
$sv->B::PVNV::bsave($ix);
asm "xmg_stash", $stashix;
$sv->domagic($ix) if $sv->MAGICAL;
}
sub B::PVLV::bsave {
my ($sv,$ix) = @_;
my $targix = $sv->TARG->ix;
$sv->B::PVMG::bsave($ix);
asm "xlv_targ", $targix;
asm "xlv_targoff", $sv->TARGOFF;
asm "xlv_targlen", $sv->TARGLEN;
asm "xlv_type", $sv->TYPE;
}
sub B::BM::bsave {
my ($sv,$ix) = @_;
$sv->B::PVMG::bsave($ix);
asm "xpv_cur", $sv->CUR;
asm "xbm_useful", $sv->USEFUL;
asm "xbm_previous", $sv->PREVIOUS;
asm "xbm_rare", $sv->RARE;
}
sub B::IO::bsave {
my ($io,$ix) = @_;
my $topix = $io->TOP_GV->ix;
my $fmtix = $io->FMT_GV->ix;
my $bottomix = $io->BOTTOM_GV->ix;
$io->B::PVMG::bsave($ix);
asm "xio_lines", $io->LINES;
asm "xio_page", $io->PAGE;
asm "xio_page_len", $io->PAGE_LEN;
asm "xio_lines_left", $io->LINES_LEFT;
asm "xio_top_name", pvix $io->TOP_NAME;
asm "xio_top_gv", $topix;
asm "xio_fmt_name", pvix $io->FMT_NAME;
asm "xio_fmt_gv", $fmtix;
asm "xio_bottom_name", pvix $io->BOTTOM_NAME;
asm "xio_bottom_gv", $bottomix;
asm "xio_subprocess", $io->SUBPROCESS;
asm "xio_type", ord $io->IoTYPE;
# asm "xio_flags", ord($io->IoFLAGS) & ~32; # XXX XXX
}
sub B::CV::bsave {
my ($cv,$ix) = @_;
my $stashix = $cv->STASH->ix;
my $gvix = $cv->GV->ix;
my $padlistix = $cv->PADLIST->ix;
my $outsideix = $cv->OUTSIDE->ix;
my $constix = $cv->CONST ? $cv->XSUBANY->ix : 0;
my $startix = $cv->START->opwalk;
my $rootix = $cv->ROOT->ix;
$cv->B::PVMG::bsave($ix);
asm "xcv_stash", $stashix;
asm "xcv_start", $startix;
asm "xcv_root", $rootix;
asm "xcv_xsubany", $constix;
asm "xcv_gv", $gvix;
asm "xcv_file", pvix $cv->FILE if $cv->FILE; # XXX AD
asm "xcv_padlist", $padlistix;
asm "xcv_outside", $outsideix;
asm "xcv_flags", $cv->CvFLAGS;
asm "xcv_outside_seq", $cv->OUTSIDE_SEQ;
asm "xcv_depth", $cv->DEPTH;
}
sub B::FM::bsave {
my ($form,$ix) = @_;
$form->B::CV::bsave($ix);
asm "xfm_lines", $form->LINES;
}
sub B::AV::bsave {
my ($av,$ix) = @_;
return $av->B::PVMG::bsave($ix) if $av->MAGICAL;
my @array = $av->ARRAY;
$_ = $_->ix for @array;
my $stashix = $av->SvSTASH->ix;
nice "-AV-",
asm "ldsv", $varix = $ix unless $ix == $varix;
asm "av_extend", $av->MAX if $av->MAX >= 0;
asm "av_pushx", $_ for @array;
asm "sv_refcnt", $av->REFCNT;
if (VERSION < 5.009) {
asm "xav_flags", $av->AvFLAGS;
}
asm "xmg_stash", $stashix;
}
sub B::GV::desired {
my $gv = shift;
my ($cv, $form);
$files{$gv->FILE} && $gv->LINE
|| ${$cv = $gv->CV} && $files{$cv->FILE}
|| ${$form = $gv->FORM} && $files{$form->FILE}
}
sub B::HV::bwalk {
my $hv = shift;
return if $walked{$$hv}++;
my %stash = $hv->ARRAY;
while (my($k,$v) = each %stash) {
if ($v->SvTYPE == SVt_PVGV) {
my $hash = $v->HV;
if ($$hash && $hash->NAME) {
$hash->bwalk;
}
$v->ix(1) if desired $v;
} else {
nice "[prototype]";
asm "gv_fetchpvx", cstring $hv->NAME . "::$k";
$svtab{$$v} = $varix = $tix;
$v->bsave($tix++);
asm "sv_flags", $v->FLAGS;
}
}
}
######################################################
sub B::OP::bsave_thin {
my ($op, $ix) = @_;
my $next = $op->next;
my $nextix = $optab{$$next};
$nextix = 0, push @cloop, $op unless defined $nextix;
if ($ix != $opix) {
nice '-'.$op->name.'-',
asm "ldop", $opix = $ix;
}
asm "op_next", $nextix;
asm "op_targ", $op->targ if $op->type; # tricky
asm "op_flags", $op->flags;
asm "op_private", $op->private;
}
sub B::OP::bsave;
*B::OP::bsave = *B::OP::bsave_thin;
sub B::UNOP::bsave {
my ($op, $ix) = @_;
my $name = $op->name;
my $flags = $op->flags;
my $first = $op->first;
my $firstix =
$name =~ /fl[io]p/
# that's just neat
|| (!ITHREADS && $name eq 'regcomp')
# trick for /$a/o in pp_regcomp
|| $name eq 'rv2sv'
&& $op->flags & OPf_MOD
&& $op->private & OPpLVAL_INTRO
# change #18774 made my life hard
? $first->ix
: 0;
$op->B::OP::bsave($ix);
asm "op_first", $firstix;
}
sub B::BINOP::bsave {
my ($op, $ix) = @_;
if ($op->name eq 'aassign' && $op->private & B::OPpASSIGN_HASH()) {
my $last = $op->last;
my $lastix = do {
local *B::OP::bsave = *B::OP::bsave_fat;
local *B::UNOP::bsave = *B::UNOP::bsave_fat;
$last->ix;
};
asm "ldop", $lastix unless $lastix == $opix;
asm "op_targ", $last->targ;
$op->B::OP::bsave($ix);
asm "op_last", $lastix;
} else {
$op->B::OP::bsave($ix);
}
}
# not needed if no pseudohashes
*B::BINOP::bsave = *B::OP::bsave if VERSION >= 5.009;
# deal with sort / formline
sub B::LISTOP::bsave {
my ($op, $ix) = @_;
my $name = $op->name;
sub blocksort() { OPf_SPECIAL|OPf_STACKED }
if ($name eq 'sort' && ($op->flags & blocksort) == blocksort) {
my $first = $op->first;
my $pushmark = $first->sibling;
my $rvgv = $pushmark->first;
my $leave = $rvgv->first;
my $leaveix = $leave->ix;
my $rvgvix = $rvgv->ix;
asm "ldop", $rvgvix unless $rvgvix == $opix;
asm "op_first", $leaveix;
my $pushmarkix = $pushmark->ix;
asm "ldop", $pushmarkix unless $pushmarkix == $opix;
asm "op_first", $rvgvix;
my $firstix = $first->ix;
asm "ldop", $firstix unless $firstix == $opix;
asm "op_sibling", $pushmarkix;
$op->B::OP::bsave($ix);
asm "op_first", $firstix;
} elsif ($name eq 'formline') {
$op->B::UNOP::bsave_fat($ix);
} else {
$op->B::OP::bsave($ix);
}
}
# fat versions
sub B::OP::bsave_fat {
my ($op, $ix) = @_;
my $siblix = $op->sibling->ix;
$op->B::OP::bsave_thin($ix);
asm "op_sibling", $siblix;
# asm "op_seq", -1; XXX don't allocate OPs piece by piece
}
sub B::UNOP::bsave_fat {
my ($op,$ix) = @_;
my $firstix = $op->first->ix;
$op->B::OP::bsave($ix);
asm "op_first", $firstix;
}
sub B::BINOP::bsave_fat {
my ($op,$ix) = @_;
my $last = $op->last;
my $lastix = $op->last->ix;
if (VERSION < 5.009 && $op->name eq 'aassign' && $last->name eq 'null') {
asm "ldop", $lastix unless $lastix == $opix;
asm "op_targ", $last->targ;
}
$op->B::UNOP::bsave($ix);
asm "op_last", $lastix;
}
sub B::LOGOP::bsave {
my ($op,$ix) = @_;
my $otherix = $op->other->ix;
$op->B::UNOP::bsave($ix);
asm "op_other", $otherix;
}
sub B::PMOP::bsave {
my ($op,$ix) = @_;
my ($rrop, $rrarg, $rstart);
# my $pmnextix = $op->pmnext->ix; # XXX
if (ITHREADS) {
if ($op->name eq 'subst') {
$rrop = "op_pmreplroot";
$rrarg = $op->pmreplroot->ix;
$rstart = $op->pmreplstart->ix;
} elsif ($op->name eq 'pushre') {
$rrop = "op_pmreplrootpo";
$rrarg = $op->pmreplroot;
}
$op->B::BINOP::bsave($ix);
asm "op_pmstashpv", pvix $op->pmstashpv;
} else {
$rrop = "op_pmreplrootgv";
$rrarg = $op->pmreplroot->ix;
$rstart = $op->pmreplstart->ix if $op->name eq 'subst';
my $stashix = $op->pmstash->ix;
$op->B::BINOP::bsave($ix);
asm "op_pmstash", $stashix;
}
asm $rrop, $rrarg if $rrop;
asm "op_pmreplstart", $rstart if $rstart;
asm "op_pmflags", $op->pmflags;
asm "op_pmpermflags", $op->pmpermflags;
asm "op_pmdynflags", $op->pmdynflags;
# asm "op_pmnext", $pmnextix; # XXX
asm "newpv", pvstring $op->precomp;
asm "pregcomp";
}
sub B::SVOP::bsave {
my ($op,$ix) = @_;
my $svix = $op->sv->ix;
$op->B::OP::bsave($ix);
asm "op_sv", $svix;
}
sub B::PADOP::bsave {
my ($op,$ix) = @_;
$op->B::OP::bsave($ix);
asm "op_padix", $op->padix;
}
sub B::PVOP::bsave {
my ($op,$ix) = @_;
$op->B::OP::bsave($ix);
return unless my $pv = $op->pv;
if ($op->name eq 'trans') {
asm "op_pv_tr", join ',', length($pv)/2, unpack("s*", $pv);
} else {
asm "newpv", pvstring $pv;
asm "op_pv";
}
}
sub B::LOOP::bsave {
my ($op,$ix) = @_;
my $nextix = $op->nextop->ix;
my $lastix = $op->lastop->ix;
my $redoix = $op->redoop->ix;
$op->B::BINOP::bsave($ix);
asm "op_redoop", $redoix;
asm "op_nextop", $nextix;
asm "op_lastop", $lastix;
}
sub B::COP::bsave {
my ($cop,$ix) = @_;
my $warnix = $cop->warnings->ix;
my $ioix = $cop->io->ix;
if (ITHREADS) {
$cop->B::OP::bsave($ix);
asm "cop_stashpv", pvix $cop->stashpv;
asm "cop_file", pvix $cop->file;
} else {
my $stashix = $cop->stash->ix;
my $fileix = $cop->filegv->ix(1);
$cop->B::OP::bsave($ix);
asm "cop_stash", $stashix;
asm "cop_filegv", $fileix;
}
asm "cop_label", pvix $cop->label if $cop->label; # XXX AD
asm "cop_seq", $cop->cop_seq;
asm "cop_arybase", $cop->arybase;
asm "cop_line", $cop->line;
asm "cop_warnings", $warnix;
asm "cop_io", $ioix;
}
sub B::OP::opwalk {
my $op = shift;
my $ix = $optab{$$op};
defined($ix) ? $ix : do {
my $ix;
my @oplist = $op->oplist;
push @cloop, undef;
$ix = $_->ix while $_ = pop @oplist;
while ($_ = pop @cloop) {
asm "ldop", $optab{$$_};
asm "op_next", $optab{${$_->next}};
}
$ix;
}
}
#################################################
sub save_cq {
my $av;
if (($av=begin_av)->isa("B::AV")) {
if ($savebegins) {
for ($av->ARRAY) {
next unless $_->FILE eq $0;
asm "push_begin", $_->ix;
}
} else {
for ($av->ARRAY) {
next unless $_->FILE eq $0;
# XXX BEGIN { goto A while 1; A: }
for (my $op = $_->START; $$op; $op = $op->next) {
next unless $op->name eq 'require' ||
# this kludge needed for tests
$op->name eq 'gv' && do {
my $gv = class($op) eq 'SVOP' ?
$op->gv :
(($_->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
$$gv && $gv->NAME =~ /use_ok|plan/
};
asm "push_begin", $_->ix;
last;
}
}
}
}
if (($av=init_av)->isa("B::AV")) {
for ($av->ARRAY) {
next unless $_->FILE eq $0;
asm "push_init", $_->ix;
}
}
if (($av=end_av)->isa("B::AV")) {
for ($av->ARRAY) {
next unless $_->FILE eq $0;
asm "push_end", $_->ix;
}
}
}
sub compile {
my ($head, $scan, $T_inhinc, $keep_syn);
my $cwd = '';
$files{$0} = 1;
sub keep_syn {
$keep_syn = 1;
*B::OP::bsave = *B::OP::bsave_fat;
*B::UNOP::bsave = *B::UNOP::bsave_fat;
*B::BINOP::bsave = *B::BINOP::bsave_fat;
*B::LISTOP::bsave = *B::LISTOP::bsave_fat;
}
sub bwarn { print STDERR "Bytecode.pm: @_\n" }
for (@_) {
if (/^-S/) {
*newasm = *endasm = sub { };
*asm = sub { print " @_\n" };
*nice = sub ($) { print "\n at _\n" };
} elsif (/^-H/) {
require ByteLoader;
$head = "#! $^X\nuse ByteLoader $ByteLoader::VERSION;\n";
} elsif (/^-k/) {
keep_syn;
} elsif (/^-o(.*)$/) {
open STDOUT, ">$1" or die "open $1: $!";
} elsif (/^-f(.*)$/) {
$files{$1} = 1;
} elsif (/^-s(.*)$/) {
$scan = length($1) ? $1 : $0;
} elsif (/^-b/) {
$savebegins = 1;
# this is here for the testsuite
} elsif (/^-TI/) {
$T_inhinc = 1;
} elsif (/^-TF(.*)/) {
my $thatfile = $1;
*B::COP::file = sub { $thatfile };
} else {
bwarn "Ignoring '$_' option";
}
}
if ($scan) {
my $f;
if (open $f, $scan) {
while (<$f>) {
/^#\s*line\s+\d+\s+("?)(.*)\1/ and $files{$2} = 1;
/^#/ and next;
if (/\bgoto\b\s*[^&]/ && !$keep_syn) {
bwarn "keeping the syntax tree: \"goto\" op found";
keep_syn;
}
}
} else {
bwarn "cannot rescan '$scan'";
}
close $f;
}
binmode STDOUT;
return sub {
print $head if $head;
newasm sub { print @_ };
defstash->bwalk;
asm "main_start", main_start->opwalk;
asm "main_root", main_root->ix;
asm "main_cv", main_cv->ix;
asm "curpad", (comppadlist->ARRAY)[1]->ix;
asm "signal", cstring "__WARN__" # XXX
if warnhook->ix;
asm "incav", inc_gv->AV->ix if $T_inhinc;
save_cq;
asm "incav", inc_gv->AV->ix if $T_inhinc;
asm "dowarn", dowarn;
{
no strict 'refs';
nice "<DATA>";
my $dh = *{defstash->NAME."::DATA"};
unless (eof $dh) {
local undef $/;
asm "data", ord 'D';
print <$dh>;
} else {
asm "ret";
}
}
endasm;
}
}
1;
=head1 NAME
B::Bytecode - Perl compiler's bytecode backend
=head1 SYNOPSIS
B<perl -MO=Bytecode>[B<,-H>][B<,-o>I<script.plc>] I<script.pl>
=head1 DESCRIPTION
Compiles a Perl script into a bytecode format that could be loaded
later by the ByteLoader module and executed as a regular Perl script.
=head1 EXAMPLE
$ perl -MO=Bytecode,-H,-ohi -e 'print "hi!\n"'
$ perl hi
hi!
=head1 OPTIONS
=over 4
=item B<-b>
Save all the BEGIN blocks. Normally only BEGIN blocks that C<require>
other files (ex. C<use Foo;>) are saved.
=item B<-H>
prepend a C<use ByteLoader VERSION;> line to the produced bytecode.
=item B<-k>
keep the syntax tree - it is stripped by default.
=item B<-o>I<outfile>
put the bytecode in <outfile> instead of dumping it to STDOUT.
=item B<-s>
scan the script for C<# line ..> directives and for <goto LABEL>
expressions. When gotos are found keep the syntax tree.
=back
=head1 KNOWN BUGS
=over 4
=item *
C<BEGIN { goto A: while 1; A: }> won't even compile.
=item *
C<?...?> and C<reset> do not work as expected.
=item *
variables in C<(?{ ... })> constructs are not properly scoped.
=item *
scripts that use source filters will fail miserably.
=back
=head1 NOTICE
There are also undocumented bugs and options.
THIS CODE IS HIGHLY EXPERIMENTAL. USE AT YOUR OWN RISK.
=head1 AUTHORS
Originally written by Malcolm Beattie <mbeattie at sable.ox.ac.uk> and
modified by Benjamin Stuhl <sho_pi at hotmail.com>.
Rewritten by Enache Adrian <enache at rdslink.ro>, 2003 a.d.
=cut
--- NEW FILE: Disassembler.pm ---
# Disassembler.pm
#
# Copyright (c) 1996 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.
$B::Disassembler::VERSION = '1.05';
package B::Disassembler::BytecodeStream;
use FileHandle;
use Carp;
use Config qw(%Config);
use B qw(cstring cast_I32);
@ISA = qw(FileHandle);
sub readn {
my ($fh, $len) = @_;
my $data;
read($fh, $data, $len);
croak "reached EOF while reading $len bytes" unless length($data) == $len;
return $data;
}
sub GET_U8 {
my $fh = shift;
my $c = $fh->getc;
croak "reached EOF while reading U8" unless defined($c);
return ord($c);
}
sub GET_U16 {
my $fh = shift;
my $str = $fh->readn(2);
croak "reached EOF while reading U16" unless length($str) == 2;
return unpack("S", $str);
}
sub GET_NV {
my $fh = shift;
my ($str, $c);
while (defined($c = $fh->getc) && $c ne "\0") {
$str .= $c;
}
croak "reached EOF while reading double" unless defined($c);
return $str;
}
sub GET_U32 {
my $fh = shift;
my $str = $fh->readn(4);
croak "reached EOF while reading U32" unless length($str) == 4;
return unpack("L", $str);
}
sub GET_I32 {
my $fh = shift;
my $str = $fh->readn(4);
croak "reached EOF while reading I32" unless length($str) == 4;
return unpack("l", $str);
}
sub GET_objindex {
my $fh = shift;
my $str = $fh->readn(4);
croak "reached EOF while reading objindex" unless length($str) == 4;
return unpack("L", $str);
}
sub GET_opindex {
my $fh = shift;
my $str = $fh->readn(4);
croak "reached EOF while reading opindex" unless length($str) == 4;
return unpack("L", $str);
}
sub GET_svindex {
my $fh = shift;
my $str = $fh->readn(4);
croak "reached EOF while reading svindex" unless length($str) == 4;
return unpack("L", $str);
}
sub GET_pvindex {
my $fh = shift;
my $str = $fh->readn(4);
croak "reached EOF while reading pvindex" unless length($str) == 4;
return unpack("L", $str);
}
sub GET_strconst {
my $fh = shift;
my ($str, $c);
$str = '';
while (defined($c = $fh->getc) && $c ne "\0") {
$str .= $c;
}
croak "reached EOF while reading strconst" unless defined($c);
return cstring($str);
}
sub GET_pvcontents {}
sub GET_PV {
my $fh = shift;
my $str;
my $len = $fh->GET_U32;
if ($len) {
read($fh, $str, $len);
croak "reached EOF while reading PV" unless length($str) == $len;
return cstring($str);
} else {
return '""';
}
}
sub GET_comment_t {
my $fh = shift;
my ($str, $c);
while (defined($c = $fh->getc) && $c ne "\n") {
$str .= $c;
}
croak "reached EOF while reading comment" unless defined($c);
return cstring($str);
}
sub GET_double {
my $fh = shift;
my ($str, $c);
while (defined($c = $fh->getc) && $c ne "\0") {
$str .= $c;
}
croak "reached EOF while reading double" unless defined($c);
return $str;
}
sub GET_none {}
sub GET_op_tr_array {
my $fh = shift;
my $len = unpack "S", $fh->readn(2);
my @ary = unpack "S*", $fh->readn($len*2);
return join(",", $len, @ary);
}
sub GET_IV64 {
my $fh = shift;
my $str = $fh->readn(8);
croak "reached EOF while reading I32" unless length($str) == 8;
return sprintf "0x%09llx", unpack("q", $str);
}
sub GET_IV {
$Config{ivsize} == 4 ? &GET_I32 : &GET_IV64;
}
sub GET_PADOFFSET {
$Config{ptrsize} == 8 ? &GET_IV64 : &GET_U32;
}
sub GET_long {
$Config{longsize} == 8 ? &GET_IV64 : &GET_U32;
}
package B::Disassembler;
use Exporter;
@ISA = qw(Exporter);
@EXPORT_OK = qw(disassemble_fh get_header);
use Carp;
use strict;
use B::Asmdata qw(%insn_data @insn_name);
our( $magic, $archname, $blversion, $ivsize, $ptrsize );
sub dis_header($){
my( $fh ) = @_;
$magic = $fh->GET_U32();
warn( "bad magic" ) if $magic != 0x43424c50;
$archname = $fh->GET_strconst();
$blversion = $fh->GET_strconst();
$ivsize = $fh->GET_U32();
$ptrsize = $fh->GET_U32();
}
sub get_header(){
return( $magic, $archname, $blversion, $ivsize, $ptrsize);
}
sub disassemble_fh {
my ($fh, $out) = @_;
my ($c, $getmeth, $insn, $arg);
bless $fh, "B::Disassembler::BytecodeStream";
dis_header( $fh );
while (defined($c = $fh->getc)) {
$c = ord($c);
$insn = $insn_name[$c];
if (!defined($insn) || $insn eq "unused") {
my $pos = $fh->tell - 1;
die "Illegal instruction code $c at stream offset $pos\n";
}
$getmeth = $insn_data{$insn}->[2];
$arg = $fh->$getmeth();
if (defined($arg)) {
&$out($insn, $arg);
} else {
&$out($insn);
}
}
}
1;
__END__
=head1 NAME
B::Disassembler - Disassemble Perl bytecode
=head1 SYNOPSIS
use Disassembler;
=head1 DESCRIPTION
See F<ext/B/B/Disassembler.pm>.
=head1 AUTHOR
Malcolm Beattie, C<mbeattie at sable.ox.ac.uk>
=cut
More information about the dslinux-commit
mailing list