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