1N/A# Disassembler.pm
1N/A#
1N/A# Copyright (c) 1996 Malcolm Beattie
1N/A#
1N/A# You may distribute under the terms of either the GNU General Public
1N/A# License or the Artistic License, as specified in the README file.
1N/Apackage B::Disassembler::BytecodeStream;
1N/A
1N/Aour $VERSION = '1.03';
1N/A
1N/Ause FileHandle;
1N/Ause Carp;
1N/Ause Config qw(%Config);
1N/Ause B qw(cstring cast_I32);
1N/A@ISA = qw(FileHandle);
1N/Asub readn {
1N/A my ($fh, $len) = @_;
1N/A my $data;
1N/A read($fh, $data, $len);
1N/A croak "reached EOF while reading $len bytes" unless length($data) == $len;
1N/A return $data;
1N/A}
1N/A
1N/Asub GET_U8 {
1N/A my $fh = shift;
1N/A my $c = $fh->getc;
1N/A croak "reached EOF while reading U8" unless defined($c);
1N/A return ord($c);
1N/A}
1N/A
1N/Asub GET_U16 {
1N/A my $fh = shift;
1N/A my $str = $fh->readn(2);
1N/A croak "reached EOF while reading U16" unless length($str) == 2;
1N/A return unpack("S", $str);
1N/A}
1N/A
1N/Asub GET_NV {
1N/A my $fh = shift;
1N/A my ($str, $c);
1N/A while (defined($c = $fh->getc) && $c ne "\0") {
1N/A $str .= $c;
1N/A }
1N/A croak "reached EOF while reading double" unless defined($c);
1N/A return $str;
1N/A}
1N/A
1N/Asub GET_U32 {
1N/A my $fh = shift;
1N/A my $str = $fh->readn(4);
1N/A croak "reached EOF while reading U32" unless length($str) == 4;
1N/A return unpack("L", $str);
1N/A}
1N/A
1N/Asub GET_I32 {
1N/A my $fh = shift;
1N/A my $str = $fh->readn(4);
1N/A croak "reached EOF while reading I32" unless length($str) == 4;
1N/A return unpack("l", $str);
1N/A}
1N/A
1N/Asub GET_objindex {
1N/A my $fh = shift;
1N/A my $str = $fh->readn(4);
1N/A croak "reached EOF while reading objindex" unless length($str) == 4;
1N/A return unpack("L", $str);
1N/A}
1N/A
1N/Asub GET_opindex {
1N/A my $fh = shift;
1N/A my $str = $fh->readn(4);
1N/A croak "reached EOF while reading opindex" unless length($str) == 4;
1N/A return unpack("L", $str);
1N/A}
1N/A
1N/Asub GET_svindex {
1N/A my $fh = shift;
1N/A my $str = $fh->readn(4);
1N/A croak "reached EOF while reading svindex" unless length($str) == 4;
1N/A return unpack("L", $str);
1N/A}
1N/A
1N/Asub GET_pvindex {
1N/A my $fh = shift;
1N/A my $str = $fh->readn(4);
1N/A croak "reached EOF while reading pvindex" unless length($str) == 4;
1N/A return unpack("L", $str);
1N/A}
1N/A
1N/Asub GET_strconst {
1N/A my $fh = shift;
1N/A my ($str, $c);
1N/A $str = '';
1N/A while (defined($c = $fh->getc) && $c ne "\0") {
1N/A $str .= $c;
1N/A }
1N/A croak "reached EOF while reading strconst" unless defined($c);
1N/A return cstring($str);
1N/A}
1N/A
1N/Asub GET_pvcontents {}
1N/A
1N/Asub GET_PV {
1N/A my $fh = shift;
1N/A my $str;
1N/A my $len = $fh->GET_U32;
1N/A if ($len) {
1N/A read($fh, $str, $len);
1N/A croak "reached EOF while reading PV" unless length($str) == $len;
1N/A return cstring($str);
1N/A } else {
1N/A return '""';
1N/A }
1N/A}
1N/A
1N/Asub GET_comment_t {
1N/A my $fh = shift;
1N/A my ($str, $c);
1N/A while (defined($c = $fh->getc) && $c ne "\n") {
1N/A $str .= $c;
1N/A }
1N/A croak "reached EOF while reading comment" unless defined($c);
1N/A return cstring($str);
1N/A}
1N/A
1N/Asub GET_double {
1N/A my $fh = shift;
1N/A my ($str, $c);
1N/A while (defined($c = $fh->getc) && $c ne "\0") {
1N/A $str .= $c;
1N/A }
1N/A croak "reached EOF while reading double" unless defined($c);
1N/A return $str;
1N/A}
1N/A
1N/Asub GET_none {}
1N/A
1N/Asub GET_op_tr_array {
1N/A my $fh = shift;
1N/A my $len = unpack "S", $fh->readn(2);
1N/A my @ary = unpack "S*", $fh->readn($len*2);
1N/A return join(",", $len, @ary);
1N/A}
1N/A
1N/Asub GET_IV64 {
1N/A my $fh = shift;
1N/A my $str = $fh->readn(8);
1N/A croak "reached EOF while reading I32" unless length($str) == 8;
1N/A return sprintf "0x%09llx", unpack("q", $str);
1N/A}
1N/A
1N/Asub GET_IV {
1N/A $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64;
1N/A}
1N/A
1N/Asub B::::GET_PADOFFSET {
1N/A $Config{ptrsize} == 8 ? &B::GET_IV64 : &B::GET_U32;
1N/A}
1N/A
1N/Asub B::::GET_long {
1N/A $Config{longsize} == 8 ? &B::GET_IV64 : &B::GET_U32;
1N/A}
1N/A
1N/A
1N/Apackage B::Disassembler;
1N/Ause Exporter;
1N/A@ISA = qw(Exporter);
1N/A@EXPORT_OK = qw(disassemble_fh get_header);
1N/Ause Carp;
1N/Ause strict;
1N/A
1N/Ause B::Asmdata qw(%insn_data @insn_name);
1N/A
1N/Aour( $magic, $archname, $blversion, $ivsize, $ptrsize );
1N/A
1N/Asub dis_header($){
1N/A my( $fh ) = @_;
1N/A $magic = $fh->GET_U32();
1N/A warn( "bad magic" ) if $magic != 0x43424c50;
1N/A $archname = $fh->GET_strconst();
1N/A $blversion = $fh->GET_strconst();
1N/A $ivsize = $fh->GET_U32();
1N/A $ptrsize = $fh->GET_U32();
1N/A}
1N/A
1N/Asub get_header(){
1N/A return( $magic, $archname, $blversion, $ivsize, $ptrsize);
1N/A}
1N/A
1N/Asub disassemble_fh {
1N/A my ($fh, $out) = @_;
1N/A my ($c, $getmeth, $insn, $arg);
1N/A bless $fh, "B::Disassembler::BytecodeStream";
1N/A dis_header( $fh );
1N/A while (defined($c = $fh->getc)) {
1N/A $c = ord($c);
1N/A $insn = $insn_name[$c];
1N/A if (!defined($insn) || $insn eq "unused") {
1N/A my $pos = $fh->tell - 1;
1N/A die "Illegal instruction code $c at stream offset $pos\n";
1N/A }
1N/A $getmeth = $insn_data{$insn}->[2];
1N/A $arg = $fh->$getmeth();
1N/A if (defined($arg)) {
1N/A &$out($insn, $arg);
1N/A } else {
1N/A &$out($insn);
1N/A }
1N/A }
1N/A}
1N/A
1N/A1;
1N/A
1N/A__END__
1N/A
1N/A=head1 NAME
1N/A
1N/AB::Disassembler - Disassemble Perl bytecode
1N/A
1N/A=head1 SYNOPSIS
1N/A
1N/A use Disassembler;
1N/A
1N/A=head1 DESCRIPTION
1N/A
1N/ASee F<ext/B/B/Disassembler.pm>.
1N/A
1N/A=head1 AUTHOR
1N/A
1N/AMalcolm Beattie, C<mbeattie@sable.ox.ac.uk>
1N/A
1N/A=cut