Commit | Line | Data |
---|---|---|
920dae64 AT |
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 | ||
8 | $B::Disassembler::VERSION = '1.05'; | |
9 | ||
10 | package B::Disassembler::BytecodeStream; | |
11 | ||
12 | use FileHandle; | |
13 | use Carp; | |
14 | use Config qw(%Config); | |
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; | |
36 | return unpack("S", $str); | |
37 | } | |
38 | ||
39 | sub GET_NV { | |
40 | my $fh = shift; | |
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; | |
47 | } | |
48 | ||
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; | |
53 | return unpack("L", $str); | |
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; | |
60 | return unpack("l", $str); | |
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; | |
67 | return unpack("L", $str); | |
68 | } | |
69 | ||
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; | |
74 | return unpack("L", $str); | |
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; | |
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); | |
89 | } | |
90 | ||
91 | sub GET_strconst { | |
92 | my $fh = shift; | |
93 | my ($str, $c); | |
94 | $str = ''; | |
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 | ||
117 | sub GET_comment_t { | |
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; | |
141 | my $len = unpack "S", $fh->readn(2); | |
142 | my @ary = unpack "S*", $fh->readn($len*2); | |
143 | return join(",", $len, @ary); | |
144 | } | |
145 | ||
146 | sub GET_IV64 { | |
147 | my $fh = shift; | |
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); | |
151 | } | |
152 | ||
153 | sub GET_IV { | |
154 | $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64; | |
155 | } | |
156 | ||
157 | sub GET_PADOFFSET { | |
158 | $Config{ptrsize} == 8 ? &GET_IV64 : &GET_U32; | |
159 | } | |
160 | ||
161 | sub GET_long { | |
162 | $Config{longsize} == 8 ? &GET_IV64 : &GET_U32; | |
163 | } | |
164 | ||
165 | ||
166 | package B::Disassembler; | |
167 | use Exporter; | |
168 | @ISA = qw(Exporter); | |
169 | @EXPORT_OK = qw(disassemble_fh get_header); | |
170 | use Carp; | |
171 | use strict; | |
172 | ||
173 | use B::Asmdata qw(%insn_data @insn_name); | |
174 | ||
175 | our( $magic, $archname, $blversion, $ivsize, $ptrsize ); | |
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(); | |
185 | } | |
186 | ||
187 | sub get_header(){ | |
188 | return( $magic, $archname, $blversion, $ivsize, $ptrsize); | |
189 | } | |
190 | ||
191 | sub disassemble_fh { | |
192 | my ($fh, $out) = @_; | |
193 | my ($c, $getmeth, $insn, $arg); | |
194 | bless $fh, "B::Disassembler::BytecodeStream"; | |
195 | dis_header( $fh ); | |
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; | |
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 |