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