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