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<[email protected]>
|
---|
232 |
|
---|
233 | =cut
|
---|