contrib/perl5/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_strconst {
  56     my $fh = shift;
  57     my ($str, $c);
  58     while (defined($c = $fh->getc) && $c ne "\0") {
  59         $str .= $c;
  60     }
  61     croak "reached EOF while reading strconst" unless defined($c);
  62     return cstring($str);
  63 }
  64
  65 sub GET_pvcontents {}
  66
  67 sub GET_PV {
  68     my $fh = shift;
  69     my $str;
  70     my $len = $fh->GET_U32;
  71     if ($len) {
  72         read($fh, $str, $len);
  73         croak "reached EOF while reading PV" unless length($str) == $len;
  74         return cstring($str);
  75     } else {
  76         return '""';
  77     }
  78 }
  79
  80 sub GET_comment_t {
  81     my $fh = shift;
  82     my ($str, $c);
  83     while (defined($c = $fh->getc) && $c ne "\n") {
  84         $str .= $c;
  85     }
  86     croak "reached EOF while reading comment" unless defined($c);
  87     return cstring($str);
  88 }
  89
  90 sub GET_double {
  91     my $fh = shift;
  92     my ($str, $c);
  93     while (defined($c = $fh->getc) && $c ne "\0") {
  94         $str .= $c;
  95     }
  96     croak "reached EOF while reading double" unless defined($c);
  97     return $str;
  98 }
  99
 100 sub GET_none {}
 101
 102 sub GET_op_tr_array {
 103     my $fh = shift;
 104     my @ary = unpack("n256", $fh->readn(256 * 2));
 105     return join(",", @ary);
 106 }
 107
 108 sub GET_IV64 {
 109     my $fh = shift;
 110     my ($hi, $lo) = unpack("NN", $fh->readn(8));
 111     return sprintf("0x%4x%04x", $hi, $lo); # cheat
 112 }
 113
 114 package B::Disassembler;
 115 use Exporter;
 116 @ISA = qw(Exporter);
 117 @EXPORT_OK = qw(disassemble_fh);
 118 use Carp;
 119 use strict;
 120
 121 use B::Asmdata qw(%insn_data @insn_name);
 122
 123 sub disassemble_fh {
 124     my ($fh, $out) = @_;
 125     my ($c, $getmeth, $insn, $arg);
 126     bless $fh, "B::Disassembler::BytecodeStream";
 127     while (defined($c = $fh->getc)) {
 128         $c = ord($c);
 129         $insn = $insn_name[$c];
 130         if (!defined($insn) || $insn eq "unused") {
 131             my $pos = $fh->tell - 1;
 132             die "Illegal instruction code $c at stream offset $pos\n";
 133         }
 134         $getmeth = $insn_data{$insn}->[2];
 135         $arg = $fh->$getmeth();
 136         if (defined($arg)) {
 137             &$out($insn, $arg);
 138         } else {
 139             &$out($insn);
 140         }
 141     }
 142 }
 143
 144 1;
 145
 146 __END__
 147
 148 =head1 NAME
 149
 150 B::Disassembler - Disassemble Perl bytecode
 151
 152 =head1 SYNOPSIS
 153
 154         use Disassembler;
 155
 156 =head1 DESCRIPTION
 157
 158 See F<ext/B/B/Disassembler.pm>.
 159
 160 =head1 AUTHOR
 161
 162 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
 163
 164 =cut