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
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.03';
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 B::::GET_PADOFFSET {
158     $Config{ptrsize} == 8 ? &B::GET_IV64 : &B::GET_U32;
159 }
160
161 sub B::::GET_long {
162     $Config{longsize} == 8 ? &B::GET_IV64 : &B::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<mbeattie@sable.ox.ac.uk>
232
233 =cut