ext/B/B/Disassembler.pm

   1 #      Disassembler.pm
   2 #
   3 #      Copyright (c) 1996 Malcolm Beattie
   4 #
   5 #      You may distribute under the terms of either the GNU General Public
   6 #      License or the Artistic License, as specified in the README file.
   7
   8 $B::Disassembler::VERSION = '1.05';
   9
  10 package B::Disassembler::BytecodeStream;
  11
  12 use FileHandle;
  13 use Carp;
  14 use Config qw(%Config);
  15 use B qw(cstring cast_I32);
  16 @ISA = qw(FileHandle);
  17 sub readn {
  18     my ($fh, $len) = @_;
  19     my $data;
  20     read($fh, $data, $len);
  21     croak "reached EOF while reading $len bytes" unless length($data) == $len;
  22     return $data;
  23 }
  24
  25 sub GET_U8 {
  26     my $fh = shift;
  27     my $c = $fh->getc;
  28     croak "reached EOF while reading U8" unless defined($c);
  29     return ord($c);
  30 }
  31
  32 sub GET_U16 {
  33     my $fh = shift;
  34     my $str = $fh->readn(2);
  35     croak "reached EOF while reading U16" unless length($str) == 2;
  36     return unpack("S", $str);
  37 }
  38
  39 sub GET_NV {
  40     my $fh = shift;
  41     my ($str, $c);
  42     while (defined($c = $fh->getc) && $c ne "\0") {
  43         $str .= $c;
  44     }
  45     croak "reached EOF while reading double" unless defined($c);
  46     return $str;
  47 }
  48
  49 sub GET_U32 {
  50     my $fh = shift;
  51     my $str = $fh->readn(4);
  52     croak "reached EOF while reading U32" unless length($str) == 4;
  53     return unpack("L", $str);
  54 }
  55
  56 sub GET_I32 {
  57     my $fh = shift;
  58     my $str = $fh->readn(4);
  59     croak "reached EOF while reading I32" unless length($str) == 4;
  60     return unpack("l", $str);
  61 }
  62
  63 sub GET_objindex {
  64     my $fh = shift;
  65     my $str = $fh->readn(4);
  66     croak "reached EOF while reading objindex" unless length($str) == 4;
  67     return unpack("L", $str);
  68 }
  69
  70 sub GET_opindex {
  71     my $fh = shift;
  72     my $str = $fh->readn(4);
  73     croak "reached EOF while reading opindex" unless length($str) == 4;
  74     return unpack("L", $str);
  75 }
  76
  77 sub GET_svindex {
  78     my $fh = shift;
  79     my $str = $fh->readn(4);
  80     croak "reached EOF while reading svindex" unless length($str) == 4;
  81     return unpack("L", $str);
  82 }
  83
  84 sub GET_pvindex {
  85     my $fh = shift;
  86     my $str = $fh->readn(4);
  87     croak "reached EOF while reading pvindex" unless length($str) == 4;
  88     return unpack("L", $str);
  89 }
  90
  91 sub GET_strconst {
  92     my $fh = shift;
  93     my ($str, $c);
  94     $str = '';
  95     while (defined($c = $fh->getc) && $c ne "\0") {
  96         $str .= $c;
  97     }
  98     croak "reached EOF while reading strconst" unless defined($c);
  99     return cstring($str);
 100 }
 101
 102 sub GET_pvcontents {}
 103
 104 sub GET_PV {
 105     my $fh = shift;
 106     my $str;
 107     my $len = $fh->GET_U32;
 108     if ($len) {
 109         read($fh, $str, $len);
 110         croak "reached EOF while reading PV" unless length($str) == $len;
 111         return cstring($str);
 112     } else {
 113         return '""';
 114     }
 115 }
 116
 117 sub GET_comment_t {
 118     my $fh = shift;
 119     my ($str, $c);
 120     while (defined($c = $fh->getc) && $c ne "\n") {
 121         $str .= $c;
 122     }
 123     croak "reached EOF while reading comment" unless defined($c);
 124     return cstring($str);
 125 }
 126
 127 sub GET_double {
 128     my $fh = shift;
 129     my ($str, $c);
 130     while (defined($c = $fh->getc) && $c ne "\0") {
 131         $str .= $c;
 132     }
 133     croak "reached EOF while reading double" unless defined($c);
 134     return $str;
 135 }
 136
 137 sub GET_none {}
 138
 139 sub GET_op_tr_array {
 140     my $fh = shift;
 141     my $len = unpack "S", $fh->readn(2);
 142     my @ary = unpack "S*", $fh->readn($len*2);
 143     return join(",", $len, @ary);
 144 }
 145
 146 sub GET_IV64 {
 147     my $fh = shift;
 148     my $str = $fh->readn(8);
 149     croak "reached EOF while reading I32" unless length($str) == 8;
 150     return sprintf "0x%09llx", unpack("q", $str);
 151 }
 152
 153 sub GET_IV {
 154     $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64;
 155 }
 156
 157 sub GET_PADOFFSET {
 158     $Config{ptrsize} == 8 ? &GET_IV64 : &GET_U32;
 159 }
 160
 161 sub GET_long {
 162     $Config{longsize} == 8 ? &GET_IV64 : &GET_U32;
 163 }
 164
 165
 166 package B::Disassembler;
 167 use Exporter;
 168 @ISA = qw(Exporter);
 169 @EXPORT_OK = qw(disassemble_fh get_header);
 170 use Carp;
 171 use strict;
 172
 173 use B::Asmdata qw(%insn_data @insn_name);
 174
 175 our( $magic, $archname, $blversion, $ivsize, $ptrsize );
 176
 177 sub dis_header($){
 178     my( $fh ) = @_;
 179     $magic = $fh->GET_U32();
 180     warn( "bad magic" ) if $magic != 0x43424c50;
 181     $archname  = $fh->GET_strconst();
 182     $blversion = $fh->GET_strconst();
 183     $ivsize    = $fh->GET_U32();
 184     $ptrsize   = $fh->GET_U32();
 185 }
 186
 187 sub get_header(){
 188     return( $magic, $archname, $blversion, $ivsize, $ptrsize);
 189 }
 190
 191 sub disassemble_fh {
 192     my ($fh, $out) = @_;
 193     my ($c, $getmeth, $insn, $arg);
 194     bless $fh, "B::Disassembler::BytecodeStream";
 195     dis_header( $fh );
 196     while (defined($c = $fh->getc)) {
 197         $c = ord($c);
 198         $insn = $insn_name[$c];
 199         if (!defined($insn) || $insn eq "unused") {
 200             my $pos = $fh->tell - 1;
 201             die "Illegal instruction code $c at stream offset $pos\n";
 202         }
 203         $getmeth = $insn_data{$insn}->[2];
 204         $arg = $fh->$getmeth();
 205         if (defined($arg)) {
 206             &$out($insn, $arg);
 207         } else {
 208             &$out($insn);
 209         }
 210     }
 211 }
 212
 213 1;
 214
 215 __END__
 216
 217 =head1 NAME
 218
 219 B::Disassembler - Disassemble Perl bytecode
 220
 221 =head1 SYNOPSIS
 222
 223         use Disassembler;
 224
 225 =head1 DESCRIPTION
 226
 227 See F<ext/B/B/Disassembler.pm>.
 228
 229 =head1 AUTHOR
 230
 231 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 232
 233 =cut