This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
$B::Disassembler::VERSION
[perl5.git] / ext / B / B / Disassembler.pm
CommitLineData
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.
28b605d8 7
cbf966ef
AT
8$B::Disassembler::VERSION = '1.03';
9
10package B::Disassembler::BytecodeStream;
28b605d8 11
a798dbf2
MB
12use FileHandle;
13use Carp;
f4abc3e7 14use Config qw(%Config);
a798dbf2
MB
15use B qw(cstring cast_I32);
16@ISA = qw(FileHandle);
17sub 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
25sub 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
32sub 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
MB
37}
38
bc13eec9
GS
39sub GET_NV {
40 my $fh = shift;
f4abc3e7
JH
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
GS
47}
48
a798dbf2
MB
49sub 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
MB
54}
55
56sub 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
MB
61}
62
63sub 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
MB
68}
69
a9a9fdd7
NT
70sub 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
NT
75}
76
77sub GET_svindex {
78 my $fh = shift;
79 my $str = $fh->readn(4);
80 croak "reached EOF while reading svindex" unless length($str) == 4;
f4abc3e7
JH
81 return unpack("L", $str);
82}
83
84sub 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
NT
89}
90
a798dbf2
MB
91sub GET_strconst {
92 my $fh = shift;
93 my ($str, $c);
f4abc3e7 94 $str = '';
a798dbf2
MB
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
102sub GET_pvcontents {}
103
104sub 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 117sub GET_comment_t {
a798dbf2
MB
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
127sub 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
137sub GET_none {}
138
139sub GET_op_tr_array {
140 my $fh = shift;
1df34986
AE
141 my $len = unpack "S", $fh->readn(2);
142 my @ary = unpack "S*", $fh->readn($len*2);
566ece03 143 return join(",", $len, @ary);
a798dbf2
MB
144}
145
146sub GET_IV64 {
147 my $fh = shift;
566ece03
JH
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
JH
151}
152
153sub GET_IV {
154 $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64;
a798dbf2
MB
155}
156
113d5bd9
JH
157sub B::::GET_PADOFFSET {
158 $Config{ptrsize} == 8 ? &B::GET_IV64 : &B::GET_U32;
159}
160
161sub B::::GET_long {
162 $Config{longsize} == 8 ? &B::GET_IV64 : &B::GET_U32;
163}
164
165
a798dbf2
MB
166package B::Disassembler;
167use Exporter;
168@ISA = qw(Exporter);
f4abc3e7 169@EXPORT_OK = qw(disassemble_fh get_header);
a798dbf2
MB
170use Carp;
171use strict;
172
173use B::Asmdata qw(%insn_data @insn_name);
174
a243a48e 175our( $magic, $archname, $blversion, $ivsize, $ptrsize );
f4abc3e7
JH
176
177sub 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
JH
185}
186
187sub get_header(){
a243a48e 188 return( $magic, $archname, $blversion, $ivsize, $ptrsize);
f4abc3e7
JH
189}
190
a798dbf2
MB
191sub disassemble_fh {
192 my ($fh, $out) = @_;
193 my ($c, $getmeth, $insn, $arg);
194 bless $fh, "B::Disassembler::BytecodeStream";
f4abc3e7 195 dis_header( $fh );
a798dbf2
MB
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
2131;
7f20e9dd
GS
214
215__END__
216
217=head1 NAME
218
219B::Disassembler - Disassemble Perl bytecode
220
221=head1 SYNOPSIS
222
223 use Disassembler;
224
225=head1 DESCRIPTION
226
227See F<ext/B/B/Disassembler.pm>.
228
229=head1 AUTHOR
230
231Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
232
233=cut