File Coverage

blib/lib/B/Disassembler.pm
Criterion Covered Total %
statement 145 236 61.4
branch 31 150 20.6
condition 8 33 24.2
subroutine 32 40 80.0
pod 0 5 0.0
total 216 464 46.5


line stmt bran cond sub pod time code
1             # Disassembler.pm
2             #
3             # Copyright (c) 1996 Malcolm Beattie
4             # Copyright (c) 2008,2009,2010,2011,2012 Reini Urban
5             #
6             # You may distribute under the terms of either the GNU General Public
7             # License or the Artistic License, as specified in the README file.
8              
9             $B::Disassembler::VERSION = '1.13';
10              
11             package B::Disassembler::BytecodeStream;
12              
13 1     1   907 use FileHandle;
  1         7712  
  1         5  
14 1     1   250 use Carp;
  1         2  
  1         44  
15 1     1   3 use Config qw(%Config);
  1         2  
  1         30  
16 1     1   3 use B qw(cstring cast_I32);
  1         1  
  1         806  
17             @ISA = qw(FileHandle);
18              
19             sub readn {
20 136     136   91 my ( $fh, $len ) = @_;
21 136         80 my $data;
22 136         156 read( $fh, $data, $len );
23 136 50       1257 croak "reached EOF while reading $len bytes" unless length($data) == $len;
24 136         178 return $data;
25             }
26              
27             sub GET_U8 {
28 28     28   23 my $fh = shift;
29 28         33 my $c = $fh->getc;
30 28 50       141 croak "reached EOF while reading U8" unless defined($c);
31 28         25 return ord($c);
32             }
33              
34             sub GET_U16 {
35 7     7   6 my $fh = shift;
36 7         8 my $str = $fh->readn(2);
37 7 50       11 croak "reached EOF while reading U16" unless length($str) == 2;
38              
39             # Todo: check byteorder
40 7         11 return unpack( "S", $str );
41             }
42              
43             sub GET_NV {
44 2     2   3 my $fh = shift;
45 2         2 my ( $str, $c );
46 2   66     3 while ( defined( $c = $fh->getc ) && $c ne "\0" ) {
47 20         134 $str .= $c;
48             }
49 2 50       15 croak "reached EOF while reading double" unless defined($c);
50 2         3 return $str;
51             }
52              
53             sub GET_U32 {
54 34     34   31 my $fh = shift;
55 34         33 my $str = $fh->readn(4);
56 34 50       43 croak "reached EOF while reading U32" unless length($str) == 4;
57              
58             # Todo: check byteorder
59 34         39 return unpack( "L", $str );
60             }
61              
62             sub GET_I32 {
63 5     5   2 my $fh = shift;
64 5         6 my $str = $fh->readn(4);
65 5 50       9 croak "reached EOF while reading I32" unless length($str) == 4;
66              
67             # Todo: check byteorder
68 5         7 return unpack( "l", $str );
69             }
70              
71             sub GET_objindex {
72 0     0   0 my $fh = shift;
73 0         0 my $str = $fh->readn(4);
74 0 0       0 croak "reached EOF while reading objindex" unless length($str) == 4;
75              
76             # Todo: check byteorder
77 0         0 return unpack( "L", $str );
78             }
79              
80             sub GET_opindex {
81 17     17   12 my $fh = shift;
82 17         17 my $str = $fh->readn(4);
83 17 50       23 croak "reached EOF while reading opindex" unless length($str) == 4;
84              
85             # Todo: check byteorder
86 17         19 return unpack( "L", $str );
87             }
88              
89             sub GET_svindex {
90 48     48   29 my $fh = shift;
91 48         50 my $str = $fh->readn(4);
92 48 50       60 croak "reached EOF while reading svindex" unless length($str) == 4;
93              
94             # Todo: check byteorder
95 48         48 return unpack( "L", $str );
96             }
97              
98             sub GET_pvindex {
99 10     10   8 my $fh = shift;
100 10         11 my $str = $fh->readn(4);
101 10 50       15 croak "reached EOF while reading pvindex" unless length($str) == 4;
102              
103             # Todo: check byteorder
104 10         11 return unpack( "L", $str );
105             }
106              
107             sub GET_hekindex {
108 0     0   0 my $fh = shift;
109 0         0 my $str = $fh->readn(4);
110 0 0       0 croak "reached EOF while reading hekindex" unless length($str) == 4;
111              
112             # Todo: check byteorder
113 0         0 return unpack( "L", $str );
114             }
115              
116             sub GET_strconst {
117 15     15   16 my $fh = shift;
118 15         10 my ( $str, $c );
119 15         9 $str = '';
120 15   66     26 while ( defined( $c = $fh->getc ) && $c ne "\0" ) {
121 48         354 $str .= $c;
122             }
123 15 50       104 croak "reached EOF while reading strconst" unless defined($c);
124 15         33 return cstring($str);
125             }
126              
127       4     sub GET_pvcontents { }
128              
129             sub GET_PV {
130 3     3   3 my $fh = shift;
131 3         4 my $str;
132 3         4 my $len = $fh->GET_U32;
133 3 100       7 if ($len) {
134 1         2 read( $fh, $str, $len );
135 1 50       8 croak "reached EOF while reading PV" unless length($str) == $len;
136 1         4 return cstring($str);
137             }
138             else {
139 2         3 return '""';
140             }
141             }
142              
143             sub GET_comment_t {
144 2     2   1 my $fh = shift;
145 2         2 my ( $str, $c );
146 2   66     3 while ( defined( $c = $fh->getc ) && $c ne "\n" ) {
147 18         123 $str .= $c;
148             }
149 2 50       19 croak "reached EOF while reading comment" unless defined($c);
150 2         5 return cstring($str);
151             }
152              
153             sub GET_double {
154 0     0   0 my $fh = shift;
155 0         0 my ( $str, $c );
156 0   0     0 while ( defined( $c = $fh->getc ) && $c ne "\0" ) {
157 0         0 $str .= $c;
158             }
159 0 0       0 croak "reached EOF while reading double" unless defined($c);
160 0         0 return $str;
161             }
162              
163       6     sub GET_none { }
164              
165             sub GET_op_tr_array {
166 2     2   5 my $fh = shift;
167 2         3 my $len = unpack "S", $fh->readn(2);
168 2         5 my @ary = unpack "S*", $fh->readn( $len * 2 );
169 2         94 return join( ",", $len, @ary );
170             }
171              
172             sub GET_IV64 {
173 9     9   6 my $fh = shift;
174 9         10 my $str = $fh->readn(8);
175 9 50       14 croak "reached EOF while reading I32" unless length($str) == 8;
176              
177             # Todo: check byteorder
178 9         9 my $i = unpack( "q", $str );
179 9 100       16 return $i > 8 ? sprintf "0x%09llx", $i : $i;
180             }
181              
182             sub GET_IV {
183             # Check the header settings, not the current settings.
184 9 50   9   15 $B::Disassembler::ivsize == 4 ? &GET_I32 : &GET_IV64;
185             # $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64;
186             }
187              
188             sub GET_PADOFFSET {
189             # Check the header settings, not the current settings.
190 0 0   0   0 $B::Disassembler::ptrsize == 8 ? &GET_IV64 : &GET_U32;
191             # $Config{ptrsize} == 8 ? &GET_IV64 : &GET_U32;
192             }
193              
194             sub GET_long {
195             # Check the header settings, not the current settings.
196             # B::Disassembler::ivsize or longsize if ge xxx?
197 0 0   0   0 if ($B::Disassembler::longsize) {
198 0 0       0 return $B::Disassembler::longsize == 8 ? &GET_IV64 : &GET_U32;
199             } else {
200             # return $Config{longsize} == 8 ? &GET_IV64 : &GET_U32;
201 0 0       0 return $B::Disassembler::ivsize == 8 ? &GET_IV64 : &GET_U32;
202             }
203             }
204              
205             sub GET_pmflags {
206 3     3   4 my $fh = shift;
207 3         3 my $size = 2;
208 3 50       5 if ($B::Disassembler::blversion ge '"0.07"') {
209 3 50       6 if ($B::Disassembler::perlversion ge '"5.013"') {
210 3         5 return $fh->GET_U32;
211             }
212             }
213 0         0 return $fh->GET_U16;
214             }
215              
216             package B::Disassembler;
217 1     1   5 use Exporter;
  1         0  
  1         49  
218             @ISA = qw(Exporter);
219             our @EXPORT_OK = qw(disassemble_fh get_header print_insn print_insn_bare @opname);
220 1     1   6 use Carp;
  1         3  
  1         36  
221 1     1   3 use strict;
  1         1  
  1         22  
222 1     1   3 use B::Asmdata qw(%insn_data @insn_name);
  1         1  
  1         80  
223 1     1   492 use Opcode qw(opset_to_ops full_opset);
  1         3116  
  1         66  
224 1     1   6 use Config qw(%Config);
  1         1  
  1         24  
225 1     1   580 use B::Concise;
  1         6162  
  1         66  
226              
227             BEGIN {
228 1 50   1   5 if ( $] < 5.009 ) {
229 0         0 B::Asmdata->import(qw(@specialsv_name));
230             }
231             else {
232 1         1211 B->import(qw(@specialsv_name));
233             }
234             }
235              
236             my $ix;
237             my $opname;
238             our @opname = opset_to_ops(full_opset);
239             our (
240             $magic, $archname, $blversion, $ivsize,
241             $ptrsize, $longsize, $byteorder, $archflag, $perlversion
242             );
243             # >=5.12
244             our @svnames = ("NULL"); # 0
245             push @svnames, "BIND" if $] >= 5.009 and $] < 5.019002; # 1
246             push @svnames, ("IV", "NV"); # 2,3
247             push @svnames, "RV" if $] < 5.011; #
248             push @svnames, "PV";
249             push @svnames, "INVLIST" if $] >= 5.019002; # 4
250             push @svnames, ("PVIV", "PVNV", "PVMG"); # 4-7
251             push @svnames, "BM" if $] < 5.009;
252             push @svnames, "REGEXP" if $] >= 5.011; # 8
253             push @svnames, "GV" if $] >= 5.009; # 9
254             push @svnames, ("PVLV", "AV", "HV", "CV"); # 10-13
255             push @svnames, "GV" if $] < 5.009;
256             push @svnames, ("FM", "IO"); # 14,15
257              
258             sub dis_header($) {
259 1     1 0 1 my ($fh) = @_;
260 1         5 my $str = $fh->readn(3);
261 1 50       3 if ($str eq '#! ') {
262 0         0 $str .= $fh->GET_comment_t;
263 0         0 $str .= $fh->GET_comment_t;
264 0         0 $magic = $fh->GET_U32;
265             } else {
266 1         2 $str .= $fh->readn(1);
267 1         18 $magic = unpack( "L", $str );
268             }
269 1 50       3 warn("bad magic") if $magic != 0x43424c50;
270 1         4 $archname = $fh->GET_strconst();
271 1         7 $blversion = $fh->GET_strconst();
272 1         3 $ivsize = $fh->GET_U32();
273 1         2 $ptrsize = $fh->GET_U32();
274 1 50       6 if ( $blversion ge '"0.06_03"' ) {
275 1         2 $longsize = $fh->GET_U32();
276             }
277 1 50 33     4 if ( $blversion gt '"0.06"' or $blversion eq '"0.04"' ) {
278 1         3 $byteorder = $fh->GET_strconst();
279             }
280 1 50       4 if ( $blversion ge '"0.06_05"' ) {
281 1         3 $archflag = $fh->GET_U16();
282             }
283 1 50       2 if ( $blversion ge '"0.06_06"' ) {
284 1         2 $perlversion = $fh->GET_strconst();
285             }
286             }
287              
288             sub get_header() {
289 0     0 0 0 my @result = (
290             $magic, $archname, $blversion, $ivsize,
291             $ptrsize, $byteorder, $longsize, $archflag,
292             $perlversion
293             );
294 0 0       0 if (wantarray) {
295 0         0 return @result;
296             }
297             else {
298 0         0 my $hash = {
299             magic => $magic,
300             archname => $archname,
301             blversion => $blversion,
302             ivsize => $ivsize,
303             ptrsize => $ptrsize,
304             };
305 0         0 for (qw(magic archname blversion ivsize ptrsize byteorder
306             longsize archflag perlversion))
307             {
308 0 0       0 $hash->{$_} = $$_ if defined $$_;
309             }
310 0         0 return $hash;
311             }
312             }
313              
314             sub print_insn {
315 0     0 0 0 my ( $insn, $arg, $comment ) = @_;
316 0 0       0 undef $comment unless $comment;
317 0 0       0 if ( defined($arg) ) {
318             # threaded or unthreaded
319 0 0 0     0 if ( $insn eq 'newopx' or $insn eq 'ldop' and $] > 5.007) {
    0 0        
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
320 0         0 my $type = $arg >> 7;
321 0         0 my $size = $arg - ( $type << 7 );
322 0 0       0 $arg .= sprintf( " \t# size:%d, type:%d %s", $size, $type) if $comment;
323 0         0 $opname = $opname[$type];
324 0         0 printf "\n# [%s %d]\n", $opname, $ix++;
325             }
326             elsif ( !$comment ) {
327             ;
328             }
329             elsif ( $insn eq 'comment' ) {
330 0         0 $arg .= "comment $arg";
331 0 0       0 $arg .= " \t#" . $comment if $comment ne '1';
332             }
333             elsif ( $insn eq 'stpv' ) {
334 0 0       0 $arg .= "\t# " . $comment if $comment ne '1';
335 0         0 printf "# -%s- %d\n", 'PV', $ix++;
336             }
337             elsif ( $insn eq 'newsvx' ) {
338 0         0 my $type = $arg & 0xff; # SVTYPEMASK
339 0         0 $arg .= sprintf("\t# type=%d,flags=0x%x", $type, $arg);
340 0 0       0 $arg .= $comment if $comment ne '1';
341 0         0 printf "\n# [%s %d]\n", $svnames[$type], $ix++;
342             }
343             elsif ( $insn eq 'newpadlx' ) {
344 0 0       0 $arg .= "\t# " . $comment if $comment ne '1';
345 0         0 printf "\n# [%s %d]\n", "PADLIST", $ix++;
346             }
347             elsif ( $insn eq 'newpadnlx' ) {
348 0 0       0 $arg .= "\t# " . $comment if $comment ne '1';
349 0         0 printf "\n# [%s %d]\n", "PADNAMELIST", $ix++;
350             }
351             elsif ( $insn eq 'newpadnx' ) {
352 0 0       0 $arg .= "\t# " . $comment if $comment ne '1';
353 0         0 printf "\n# [%s %d]\n", "PADNAME", $ix++;
354             }
355             elsif ( $insn eq 'gv_stashpvx' ) {
356 0 0       0 $arg .= "\t# " . $comment if $comment ne '1';
357 0         0 printf "\n# [%s %d]\n", "STASH", $ix++;
358             }
359             elsif ( $insn eq 'ldspecsvx' ) {
360 0         0 $arg .= "\t# $specialsv_name[$arg]";
361 0 0       0 $arg .= $comment if $comment ne '1';
362 0         0 printf "\n# [%s %d]\n", "SPECIAL", $ix++;
363             }
364             elsif ( $insn eq 'ldsv' ) {
365 0 0       0 $arg .= "\t# " . $comment if $comment ne '1';
366 0         0 printf "# -%s-\n", 'GP/AV/HV/NULL/MG';
367             }
368             elsif ( $insn eq 'gv_fetchpvx' ) {
369 0 0       0 $arg .= "\t# " . $comment if $comment ne '1';
370 0         0 printf "\n# [%s %d]\n", 'GV', $ix++;
371             }
372             elsif ( $insn eq 'sv_magic' ) {
373 0         0 $arg .= sprintf( "\t# '%s'", chr($arg) );
374             }
375             elsif ( $insn =~ /_flags/ ) {
376 0         0 my $f = $arg;
377 0 0       0 $arg .= sprintf( "\t# 0x%x", $f ) if $comment;
378 0 0 0     0 $arg .= " ".B::Concise::op_flags($f) if $insn eq 'op_flags' and $comment;
379             }
380             elsif ( $comment and $insn eq 'op_private' ) {
381 0         0 my $f = $arg;
382 0         0 $arg .= sprintf( "\t# 0x%x", $f );
383 0         0 $arg .= " ".B::Concise::private_flags($opname, $f);
384             }
385             elsif ( $insn eq 'op_type' and $] < 5.007 ) {
386 0         0 my $type = $arg;
387 0         0 $arg .= sprintf( "\t# [ %s ]", $opname[$type] );
388             }
389             else {
390 0 0       0 $arg .= "\t# " . $comment if $comment ne '1';
391             }
392 0         0 printf "%s %s\n", $insn, $arg;
393             }
394             else {
395 0 0       0 $insn .= "\t# " . $comment if $comment ne '1';
396 0         0 print $insn, "\n";
397             }
398             }
399              
400             sub print_insn_bare {
401 0     0 0 0 my ( $insn, $arg ) = @_;
402 0 0       0 if ( defined($arg) ) {
403 0         0 printf "%s %s\n", $insn, $arg;
404             }
405             else {
406 0         0 print $insn, "\n";
407             }
408             }
409              
410             sub disassemble_fh {
411 1     1 0 26 my $fh = shift;
412 1         1 my $out = shift;
413 1         1 my $verbose = shift;
414 1         2 my ( $c, $getmeth, $insn, $arg );
415 1         1 $ix = 1;
416 1         5 bless $fh, "B::Disassembler::BytecodeStream";
417 1         3 dis_header($fh);
418 1 50       2 if ($verbose) {
419 0         0 printf "#magic 0x%x\n", $magic; #0x43424c50
420 0         0 printf "#archname %s\n", $archname;
421 0         0 printf "#blversion %s\n", $blversion;
422 0         0 printf "#ivsize %d\n", $ivsize;
423 0         0 printf "#ptrsize %d\n", $ptrsize;
424 0 0       0 printf "#byteorder %s\n", $byteorder if $byteorder;
425 0 0       0 printf "#longsize %d\n", $longsize if $longsize;
426 0 0       0 printf "#archflag %d\n", $archflag if defined $archflag;
427 0 0       0 printf "#perlversion %s\n", $perlversion if $perlversion;
428 0         0 print "\n";
429             }
430 1         3 while ( defined( $c = $fh->getc ) ) {
431 181         1967 $c = ord($c);
432 181         150 $insn = $insn_name[$c];
433 181 50 33     467 if ( !defined($insn) || $insn eq "unused" ) {
434 0         0 my $pos = $fh->tell - 1;
435 0         0 warn "Illegal instruction code $c at stream offset $pos.\n";
436             }
437 181         152 $getmeth = $insn_data{$insn}->[2];
438             #warn "EOF at $insn $getmeth" if $fh->eof();
439 181         231 $arg = $fh->$getmeth();
440 181 100       179 if ( defined($arg) ) {
441 171         173 &$out( $insn, $arg, $verbose );
442             }
443             else {
444 10         13 &$out( $insn, undef, $verbose );
445             }
446             }
447             }
448              
449             1;
450              
451             __END__