Commit | Line | Data |
a798dbf2 |
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; |
28b605d8 |
8 | |
f4abc3e7 |
9 | our $VERSION = '1.01'; |
28b605d8 |
10 | |
a798dbf2 |
11 | use FileHandle; |
12 | use Carp; |
f4abc3e7 |
13 | use Config qw(%Config); |
a798dbf2 |
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; |
f4abc3e7 |
35 | return unpack("S", $str); |
a798dbf2 |
36 | } |
37 | |
bc13eec9 |
38 | sub GET_NV { |
39 | my $fh = shift; |
f4abc3e7 |
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; |
bc13eec9 |
46 | } |
47 | |
a798dbf2 |
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; |
f4abc3e7 |
52 | return unpack("L", $str); |
a798dbf2 |
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; |
e53790c1 |
59 | return unpack("l", $str); |
a798dbf2 |
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; |
f4abc3e7 |
66 | return unpack("L", $str); |
a798dbf2 |
67 | } |
68 | |
a9a9fdd7 |
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; |
f4abc3e7 |
73 | return unpack("L", $str); |
a9a9fdd7 |
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; |
f4abc3e7 |
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); |
a9a9fdd7 |
88 | } |
89 | |
a798dbf2 |
90 | sub GET_strconst { |
91 | my $fh = shift; |
92 | my ($str, $c); |
f4abc3e7 |
93 | $str = ''; |
a798dbf2 |
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 | |
d53d2b93 |
116 | sub GET_comment_t { |
a798dbf2 |
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; |
f4abc3e7 |
140 | my @ary = unpack("S256", $fh->readn(256 * 2)); |
a798dbf2 |
141 | return join(",", @ary); |
142 | } |
143 | |
144 | sub GET_IV64 { |
145 | my $fh = shift; |
f4abc3e7 |
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; |
a798dbf2 |
152 | } |
153 | |
154 | package B::Disassembler; |
155 | use Exporter; |
156 | @ISA = qw(Exporter); |
f4abc3e7 |
157 | @EXPORT_OK = qw(disassemble_fh get_header); |
a798dbf2 |
158 | use Carp; |
159 | use strict; |
160 | |
161 | use B::Asmdata qw(%insn_data @insn_name); |
162 | |
f4abc3e7 |
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 | |
a798dbf2 |
180 | sub disassemble_fh { |
181 | my ($fh, $out) = @_; |
182 | my ($c, $getmeth, $insn, $arg); |
183 | bless $fh, "B::Disassembler::BytecodeStream"; |
f4abc3e7 |
184 | dis_header( $fh ); |
a798dbf2 |
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; |
7f20e9dd |
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 |