home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _59030d4160e26e45e23589a3dc0dc24c < prev    next >
Encoding:
Text File  |  2000-03-15  |  3.9 KB  |  179 lines
  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
  179.