This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
a565e5d0841f4d81576c0703f291ddb6f2bbb0d2
[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 package B::Disassembler::BytecodeStream;
8
9 our $VERSION = '1.03';
10
11 use FileHandle;
12 use Carp;
13 use Config qw(%Config);
14 use B qw(cstring cast_I32);
15 @ISA = qw(FileHandle);
16 sub 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
24 sub 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
31 sub 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
38 sub 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
48 sub 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
55 sub 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
62 sub 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
69 sub 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
76 sub 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
83 sub 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
90 sub 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
101 sub GET_pvcontents {}
102
103 sub 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
116 sub 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
126 sub 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
136 sub GET_none {}
137
138 sub 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
145 sub 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
152 sub GET_IV {
153     $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64;
154 }
155
156 sub B::::GET_PADOFFSET {
157     $Config{ptrsize} == 8 ? &B::GET_IV64 : &B::GET_U32;
158 }
159
160 sub B::::GET_long {
161     $Config{longsize} == 8 ? &B::GET_IV64 : &B::GET_U32;
162 }
163
164
165 package B::Disassembler;
166 use Exporter;
167 @ISA = qw(Exporter);
168 @EXPORT_OK = qw(disassemble_fh get_header);
169 use Carp;
170 use strict;
171
172 use B::Asmdata qw(%insn_data @insn_name);
173
174 our( $magic, $archname, $blversion, $ivsize, $ptrsize );
175
176 sub 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
186 sub get_header(){
187     return( $magic, $archname, $blversion, $ivsize, $ptrsize);
188 }
189
190 sub 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
212 1;
213
214 __END__
215
216 =head1 NAME
217
218 B::Disassembler - Disassemble Perl bytecode
219
220 =head1 SYNOPSIS
221
222         use Disassembler;
223
224 =head1 DESCRIPTION
225
226 See F<ext/B/B/Disassembler.pm>.
227
228 =head1 AUTHOR
229
230 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
231
232 =cut