Commit | Line | Data |
---|---|---|
a798dbf2 MB |
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 | |
3353beaa | 9 | our $VERSION = '1.03'; |
28b605d8 | 10 | |
a798dbf2 MB |
11 | use FileHandle; |
12 | use Carp; | |
f4abc3e7 | 13 | use Config qw(%Config); |
a798dbf2 MB |
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 MB |
36 | } |
37 | ||
bc13eec9 GS |
38 | sub GET_NV { |
39 | my $fh = shift; | |
f4abc3e7 JH |
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 GS |
46 | } |
47 | ||
a798dbf2 MB |
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 MB |
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 MB |
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 MB |
67 | } |
68 | ||
a9a9fdd7 NT |
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 NT |
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 JH |
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 NT |
88 | } |
89 | ||
a798dbf2 MB |
90 | sub GET_strconst { |
91 | my $fh = shift; | |
92 | my ($str, $c); | |
f4abc3e7 | 93 | $str = ''; |
a798dbf2 MB |
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 MB |
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; | |
1df34986 AE |
140 | my $len = unpack "S", $fh->readn(2); |
141 | my @ary = unpack "S*", $fh->readn($len*2); | |
566ece03 | 142 | return join(",", $len, @ary); |
a798dbf2 MB |
143 | } |
144 | ||
145 | sub GET_IV64 { | |
146 | my $fh = shift; | |
566ece03 JH |
147 | my $str = $fh->readn(8); |
148 | croak "reached EOF while reading I32" unless length($str) == 8; | |
149 | return sprintf "0x%09llx", unpack("q", $str); | |
f4abc3e7 JH |
150 | } |
151 | ||
152 | sub GET_IV { | |
153 | $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64; | |
a798dbf2 MB |
154 | } |
155 | ||
113d5bd9 JH |
156 | sub B::::GET_PADOFFSET { |
157 | $Config{ptrsize} == 8 ? &B::GET_IV64 : &B::GET_U32; | |
158 | } | |
159 | ||
160 | sub B::::GET_long { | |
161 | $Config{longsize} == 8 ? &B::GET_IV64 : &B::GET_U32; | |
162 | } | |
163 | ||
164 | ||
a798dbf2 MB |
165 | package B::Disassembler; |
166 | use Exporter; | |
167 | @ISA = qw(Exporter); | |
f4abc3e7 | 168 | @EXPORT_OK = qw(disassemble_fh get_header); |
a798dbf2 MB |
169 | use Carp; |
170 | use strict; | |
171 | ||
172 | use B::Asmdata qw(%insn_data @insn_name); | |
173 | ||
a243a48e | 174 | our( $magic, $archname, $blversion, $ivsize, $ptrsize ); |
f4abc3e7 JH |
175 | |
176 | sub dis_header($){ | |
177 | my( $fh ) = @_; | |
178 | $magic = $fh->GET_U32(); | |
179 | warn( "bad magic" ) if $magic != 0x43424c50; | |
180 | $archname = $fh->GET_strconst(); | |
181 | $blversion = $fh->GET_strconst(); | |
182 | $ivsize = $fh->GET_U32(); | |
183 | $ptrsize = $fh->GET_U32(); | |
f4abc3e7 JH |
184 | } |
185 | ||
186 | sub get_header(){ | |
a243a48e | 187 | return( $magic, $archname, $blversion, $ivsize, $ptrsize); |
f4abc3e7 JH |
188 | } |
189 | ||
a798dbf2 MB |
190 | sub disassemble_fh { |
191 | my ($fh, $out) = @_; | |
192 | my ($c, $getmeth, $insn, $arg); | |
193 | bless $fh, "B::Disassembler::BytecodeStream"; | |
f4abc3e7 | 194 | dis_header( $fh ); |
a798dbf2 MB |
195 | while (defined($c = $fh->getc)) { |
196 | $c = ord($c); | |
197 | $insn = $insn_name[$c]; | |
198 | if (!defined($insn) || $insn eq "unused") { | |
199 | my $pos = $fh->tell - 1; | |
200 | die "Illegal instruction code $c at stream offset $pos\n"; | |
201 | } | |
202 | $getmeth = $insn_data{$insn}->[2]; | |
203 | $arg = $fh->$getmeth(); | |
204 | if (defined($arg)) { | |
205 | &$out($insn, $arg); | |
206 | } else { | |
207 | &$out($insn); | |
208 | } | |
209 | } | |
210 | } | |
211 | ||
212 | 1; | |
7f20e9dd GS |
213 | |
214 | __END__ | |
215 | ||
216 | =head1 NAME | |
217 | ||
218 | B::Disassembler - Disassemble Perl bytecode | |
219 | ||
220 | =head1 SYNOPSIS | |
221 | ||
222 | use Disassembler; | |
223 | ||
224 | =head1 DESCRIPTION | |
225 | ||
226 | See F<ext/B/B/Disassembler.pm>. | |
227 | ||
228 | =head1 AUTHOR | |
229 | ||
230 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> | |
231 | ||
232 | =cut |