xref: /onnv-gate/usr/src/cmd/perl/5.8.4/distrib/ext/B/B/Disassembler.pm (revision 0:68f95e015346) 
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.
7package B::Disassembler::BytecodeStream;
8
9our $VERSION = '1.03';
10
11use FileHandle;
12use Carp;
13use Config qw(%Config);
14use B qw(cstring cast_I32);
15@ISA = qw(FileHandle);
16sub 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
24sub 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
31sub GET_U16 {
32    my $fh = shift;
33    my $str = $fh->readn(2);
34    croak "reached EOF while reading U16" unless length($str) == 2;
35    return unpack("S", $str);
36}
37
38sub GET_NV {
39    my $fh = shift;
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;
46}
47
48sub GET_U32 {
49    my $fh = shift;
50    my $str = $fh->readn(4);
51    croak "reached EOF while reading U32" unless length($str) == 4;
52    return unpack("L", $str);
53}
54
55sub GET_I32 {
56    my $fh = shift;
57    my $str = $fh->readn(4);
58    croak "reached EOF while reading I32" unless length($str) == 4;
59    return unpack("l", $str);
60}
61
62sub GET_objindex {
63    my $fh = shift;
64    my $str = $fh->readn(4);
65    croak "reached EOF while reading objindex" unless length($str) == 4;
66    return unpack("L", $str);
67}
68
69sub GET_opindex {
70    my $fh = shift;
71    my $str = $fh->readn(4);
72    croak "reached EOF while reading opindex" unless length($str) == 4;
73    return unpack("L", $str);
74}
75
76sub GET_svindex {
77    my $fh = shift;
78    my $str = $fh->readn(4);
79    croak "reached EOF while reading svindex" unless length($str) == 4;
80    return unpack("L", $str);
81}
82
83sub 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);
88}
89
90sub GET_strconst {
91    my $fh = shift;
92    my ($str, $c);
93    $str = '';
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
101sub GET_pvcontents {}
102
103sub 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
116sub GET_comment_t {
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
126sub 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
136sub GET_none {}
137
138sub GET_op_tr_array {
139    my $fh = shift;
140    my $len = unpack "S", $fh->readn(2);
141    my @ary = unpack "S*", $fh->readn($len*2);
142    return join(",", $len, @ary);
143}
144
145sub GET_IV64 {
146    my $fh = shift;
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);
150}
151
152sub GET_IV {
153    $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64;
154}
155
156sub B::::GET_PADOFFSET {
157    $Config{ptrsize} == 8 ? &B::GET_IV64 : &B::GET_U32;
158}
159
160sub B::::GET_long {
161    $Config{longsize} == 8 ? &B::GET_IV64 : &B::GET_U32;
162}
163
164
165package B::Disassembler;
166use Exporter;
167@ISA = qw(Exporter);
168@EXPORT_OK = qw(disassemble_fh get_header);
169use Carp;
170use strict;
171
172use B::Asmdata qw(%insn_data @insn_name);
173
174our( $magic, $archname, $blversion, $ivsize, $ptrsize );
175
176sub 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();
184}
185
186sub get_header(){
187    return( $magic, $archname, $blversion, $ivsize, $ptrsize);
188}
189
190sub disassemble_fh {
191    my ($fh, $out) = @_;
192    my ($c, $getmeth, $insn, $arg);
193    bless $fh, "B::Disassembler::BytecodeStream";
194    dis_header( $fh );
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
2121;
213
214__END__
215
216=head1 NAME
217
218B::Disassembler - Disassemble Perl bytecode
219
220=head1 SYNOPSIS
221
222	use Disassembler;
223
224=head1 DESCRIPTION
225
226See F<ext/B/B/Disassembler.pm>.
227
228=head1 AUTHOR
229
230Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
231
232=cut
233