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
CommitLineData
a798dbf2
MB
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;
8use FileHandle;
9use Carp;
10use B qw(cstring cast_I32);
11@ISA = qw(FileHandle);
12sub 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
20sub 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
27sub 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
bc13eec9
GS
34sub 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
a798dbf2
MB
41sub 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
48sub 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
55sub 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
a9a9fdd7
NT
62sub 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
69sub 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
a798dbf2
MB
76sub 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
86sub GET_pvcontents {}
87
88sub 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
d53d2b93 101sub GET_comment_t {
a798dbf2
MB
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
111sub 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
121sub GET_none {}
122
123sub GET_op_tr_array {
124 my $fh = shift;
125 my @ary = unpack("n256", $fh->readn(256 * 2));
126 return join(",", @ary);
127}
128
129sub 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
135package B::Disassembler;
136use Exporter;
137@ISA = qw(Exporter);
138@EXPORT_OK = qw(disassemble_fh);
139use Carp;
140use strict;
141
142use B::Asmdata qw(%insn_data @insn_name);
143
144sub 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
1651;
7f20e9dd
GS
166
167__END__
168
169=head1 NAME
170
171B::Disassembler - Disassemble Perl bytecode
172
173=head1 SYNOPSIS
174
175 use Disassembler;
176
177=head1 DESCRIPTION
178
179See F<ext/B/B/Disassembler.pm>.
180
181=head1 AUTHOR
182
183Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
184
185=cut