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