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