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 | |
9 | our $VERSION = '1.00'; |
10 | |
a798dbf2 |
11 | use FileHandle; |
12 | use Carp; |
13 | use B qw(cstring cast_I32); |
14 | @ISA = qw(FileHandle); |
15 | sub readn { |
16 | my ($fh, $len) = @_; |
17 | my $data; |
18 | read($fh, $data, $len); |
19 | croak "reached EOF while reading $len bytes" unless length($data) == $len; |
20 | return $data; |
21 | } |
22 | |
23 | sub GET_U8 { |
24 | my $fh = shift; |
25 | my $c = $fh->getc; |
26 | croak "reached EOF while reading U8" unless defined($c); |
27 | return ord($c); |
28 | } |
29 | |
30 | sub GET_U16 { |
31 | my $fh = shift; |
32 | my $str = $fh->readn(2); |
33 | croak "reached EOF while reading U16" unless length($str) == 2; |
34 | return unpack("n", $str); |
35 | } |
36 | |
bc13eec9 |
37 | sub GET_NV { |
38 | my $fh = shift; |
39 | my $str = $fh->readn(8); |
40 | croak "reached EOF while reading NV" unless length($str) == 8; |
41 | return unpack("N", $str); |
42 | } |
43 | |
a798dbf2 |
44 | sub GET_U32 { |
45 | my $fh = shift; |
46 | my $str = $fh->readn(4); |
47 | croak "reached EOF while reading U32" unless length($str) == 4; |
48 | return unpack("N", $str); |
49 | } |
50 | |
51 | sub GET_I32 { |
52 | my $fh = shift; |
53 | my $str = $fh->readn(4); |
54 | croak "reached EOF while reading I32" unless length($str) == 4; |
55 | return cast_I32(unpack("N", $str)); |
56 | } |
57 | |
58 | sub GET_objindex { |
59 | my $fh = shift; |
60 | my $str = $fh->readn(4); |
61 | croak "reached EOF while reading objindex" unless length($str) == 4; |
62 | return unpack("N", $str); |
63 | } |
64 | |
a9a9fdd7 |
65 | sub GET_opindex { |
66 | my $fh = shift; |
67 | my $str = $fh->readn(4); |
68 | croak "reached EOF while reading opindex" unless length($str) == 4; |
69 | return unpack("N", $str); |
70 | } |
71 | |
72 | sub GET_svindex { |
73 | my $fh = shift; |
74 | my $str = $fh->readn(4); |
75 | croak "reached EOF while reading svindex" unless length($str) == 4; |
76 | return unpack("N", $str); |
77 | } |
78 | |
a798dbf2 |
79 | sub GET_strconst { |
80 | my $fh = shift; |
81 | my ($str, $c); |
82 | while (defined($c = $fh->getc) && $c ne "\0") { |
83 | $str .= $c; |
84 | } |
85 | croak "reached EOF while reading strconst" unless defined($c); |
86 | return cstring($str); |
87 | } |
88 | |
89 | sub GET_pvcontents {} |
90 | |
91 | sub GET_PV { |
92 | my $fh = shift; |
93 | my $str; |
94 | my $len = $fh->GET_U32; |
95 | if ($len) { |
96 | read($fh, $str, $len); |
97 | croak "reached EOF while reading PV" unless length($str) == $len; |
98 | return cstring($str); |
99 | } else { |
100 | return '""'; |
101 | } |
102 | } |
103 | |
d53d2b93 |
104 | sub GET_comment_t { |
a798dbf2 |
105 | my $fh = shift; |
106 | my ($str, $c); |
107 | while (defined($c = $fh->getc) && $c ne "\n") { |
108 | $str .= $c; |
109 | } |
110 | croak "reached EOF while reading comment" unless defined($c); |
111 | return cstring($str); |
112 | } |
113 | |
114 | sub GET_double { |
115 | my $fh = shift; |
116 | my ($str, $c); |
117 | while (defined($c = $fh->getc) && $c ne "\0") { |
118 | $str .= $c; |
119 | } |
120 | croak "reached EOF while reading double" unless defined($c); |
121 | return $str; |
122 | } |
123 | |
124 | sub GET_none {} |
125 | |
126 | sub GET_op_tr_array { |
127 | my $fh = shift; |
128 | my @ary = unpack("n256", $fh->readn(256 * 2)); |
129 | return join(",", @ary); |
130 | } |
131 | |
132 | sub GET_IV64 { |
133 | my $fh = shift; |
134 | my ($hi, $lo) = unpack("NN", $fh->readn(8)); |
135 | return sprintf("0x%4x%04x", $hi, $lo); # cheat |
136 | } |
137 | |
138 | package B::Disassembler; |
139 | use Exporter; |
140 | @ISA = qw(Exporter); |
141 | @EXPORT_OK = qw(disassemble_fh); |
142 | use Carp; |
143 | use strict; |
144 | |
145 | use B::Asmdata qw(%insn_data @insn_name); |
146 | |
147 | sub disassemble_fh { |
148 | my ($fh, $out) = @_; |
149 | my ($c, $getmeth, $insn, $arg); |
150 | bless $fh, "B::Disassembler::BytecodeStream"; |
151 | while (defined($c = $fh->getc)) { |
152 | $c = ord($c); |
153 | $insn = $insn_name[$c]; |
154 | if (!defined($insn) || $insn eq "unused") { |
155 | my $pos = $fh->tell - 1; |
156 | die "Illegal instruction code $c at stream offset $pos\n"; |
157 | } |
158 | $getmeth = $insn_data{$insn}->[2]; |
159 | $arg = $fh->$getmeth(); |
160 | if (defined($arg)) { |
161 | &$out($insn, $arg); |
162 | } else { |
163 | &$out($insn); |
164 | } |
165 | } |
166 | } |
167 | |
168 | 1; |
7f20e9dd |
169 | |
170 | __END__ |
171 | |
172 | =head1 NAME |
173 | |
174 | B::Disassembler - Disassemble Perl bytecode |
175 | |
176 | =head1 SYNOPSIS |
177 | |
178 | use Disassembler; |
179 | |
180 | =head1 DESCRIPTION |
181 | |
182 | See F<ext/B/B/Disassembler.pm>. |
183 | |
184 | =head1 AUTHOR |
185 | |
186 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> |
187 | |
188 | =cut |