This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
B::Bytecode tweaks (from Simon Cozens <simon@brecon.co.uk>)
[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 use FileHandle;
9 use Carp;
10 use B qw(cstring cast_I32);
11 @ISA = qw(FileHandle);
12 sub readn {
13     my ($fh, $len) = @_;
14     my $data;
15     read($fh, $data, $len);
16     croak "reached EOF while reading $len bytes" unless length($data) == $len;
17     return $data;
18 }
19
20 sub GET_U8 {
21     my $fh = shift;
22     my $c = $fh->getc;
23     croak "reached EOF while reading U8" unless defined($c);
24     return ord($c);
25 }
26
27 sub GET_U16 {
28     my $fh = shift;
29     my $str = $fh->readn(2);
30     croak "reached EOF while reading U16" unless length($str) == 2;
31     return unpack("n", $str);
32 }
33
34 sub GET_NV {
35     my $fh = shift;
36     my $str = $fh->readn(8);
37     croak "reached EOF while reading NV" unless length($str) == 8;
38     return unpack("N", $str);
39 }
40
41 sub GET_U32 {
42     my $fh = shift;
43     my $str = $fh->readn(4);
44     croak "reached EOF while reading U32" unless length($str) == 4;
45     return unpack("N", $str);
46 }
47
48 sub GET_I32 {
49     my $fh = shift;
50     my $str = $fh->readn(4);
51     croak "reached EOF while reading I32" unless length($str) == 4;
52     return cast_I32(unpack("N", $str));
53 }
54
55 sub GET_objindex { 
56     my $fh = shift;
57     my $str = $fh->readn(4);
58     croak "reached EOF while reading objindex" unless length($str) == 4;
59     return unpack("N", $str);
60 }
61
62 sub GET_opindex { 
63     my $fh = shift;
64     my $str = $fh->readn(4);
65     croak "reached EOF while reading opindex" unless length($str) == 4;
66     return unpack("N", $str);
67 }
68
69 sub GET_svindex { 
70     my $fh = shift;
71     my $str = $fh->readn(4);
72     croak "reached EOF while reading svindex" unless length($str) == 4;
73     return unpack("N", $str);
74 }
75
76 sub GET_strconst {
77     my $fh = shift;
78     my ($str, $c);
79     while (defined($c = $fh->getc) && $c ne "\0") {
80         $str .= $c;
81     }
82     croak "reached EOF while reading strconst" unless defined($c);
83     return cstring($str);
84 }
85
86 sub GET_pvcontents {}
87
88 sub GET_PV {
89     my $fh = shift;
90     my $str;
91     my $len = $fh->GET_U32;
92     if ($len) {
93         read($fh, $str, $len);
94         croak "reached EOF while reading PV" unless length($str) == $len;
95         return cstring($str);
96     } else {
97         return '""';
98     }
99 }
100
101 sub GET_comment_t {
102     my $fh = shift;
103     my ($str, $c);
104     while (defined($c = $fh->getc) && $c ne "\n") {
105         $str .= $c;
106     }
107     croak "reached EOF while reading comment" unless defined($c);
108     return cstring($str);
109 }
110
111 sub GET_double {
112     my $fh = shift;
113     my ($str, $c);
114     while (defined($c = $fh->getc) && $c ne "\0") {
115         $str .= $c;
116     }
117     croak "reached EOF while reading double" unless defined($c);
118     return $str;
119 }
120
121 sub GET_none {}
122
123 sub GET_op_tr_array {
124     my $fh = shift;
125     my @ary = unpack("n256", $fh->readn(256 * 2));
126     return join(",", @ary);
127 }
128
129 sub GET_IV64 {
130     my $fh = shift;
131     my ($hi, $lo) = unpack("NN", $fh->readn(8));
132     return sprintf("0x%4x%04x", $hi, $lo); # cheat
133 }
134
135 package B::Disassembler;
136 use Exporter;
137 @ISA = qw(Exporter);
138 @EXPORT_OK = qw(disassemble_fh);
139 use Carp;
140 use strict;
141
142 use B::Asmdata qw(%insn_data @insn_name);
143
144 sub disassemble_fh {
145     my ($fh, $out) = @_;
146     my ($c, $getmeth, $insn, $arg);
147     bless $fh, "B::Disassembler::BytecodeStream";
148     while (defined($c = $fh->getc)) {
149         $c = ord($c);
150         $insn = $insn_name[$c];
151         if (!defined($insn) || $insn eq "unused") {
152             my $pos = $fh->tell - 1;
153             die "Illegal instruction code $c at stream offset $pos\n";
154         }
155         $getmeth = $insn_data{$insn}->[2];
156         $arg = $fh->$getmeth();
157         if (defined($arg)) {
158             &$out($insn, $arg);
159         } else {
160             &$out($insn);
161         }
162     }
163 }
164
165 1;
166
167 __END__
168
169 =head1 NAME
170
171 B::Disassembler - Disassemble Perl bytecode
172
173 =head1 SYNOPSIS
174
175         use Disassembler;
176
177 =head1 DESCRIPTION
178
179 See F<ext/B/B/Disassembler.pm>.
180
181 =head1 AUTHOR
182
183 Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
184
185 =cut