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