summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/B/Disassembler.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/B/Disassembler.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/B/Disassembler.pm233
1 files changed, 233 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/B/Disassembler.pm b/Master/tlpkg/tlperl/lib/B/Disassembler.pm
new file mode 100644
index 00000000000..e1993aa9537
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/B/Disassembler.pm
@@ -0,0 +1,233 @@
+# Disassembler.pm
+#
+# Copyright (c) 1996 Malcolm Beattie
+#
+# You may distribute under the terms of either the GNU General Public
+# License or the Artistic License, as specified in the README file.
+
+$B::Disassembler::VERSION = '1.05';
+
+package B::Disassembler::BytecodeStream;
+
+use FileHandle;
+use Carp;
+use Config qw(%Config);
+use B qw(cstring cast_I32);
+@ISA = qw(FileHandle);
+sub readn {
+ my ($fh, $len) = @_;
+ my $data;
+ read($fh, $data, $len);
+ croak "reached EOF while reading $len bytes" unless length($data) == $len;
+ return $data;
+}
+
+sub GET_U8 {
+ my $fh = shift;
+ my $c = $fh->getc;
+ croak "reached EOF while reading U8" unless defined($c);
+ return ord($c);
+}
+
+sub GET_U16 {
+ my $fh = shift;
+ my $str = $fh->readn(2);
+ croak "reached EOF while reading U16" unless length($str) == 2;
+ return unpack("S", $str);
+}
+
+sub GET_NV {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\0") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading double" unless defined($c);
+ return $str;
+}
+
+sub GET_U32 {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading U32" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_I32 {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading I32" unless length($str) == 4;
+ return unpack("l", $str);
+}
+
+sub GET_objindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading objindex" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_opindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading opindex" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_svindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading svindex" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_pvindex {
+ my $fh = shift;
+ my $str = $fh->readn(4);
+ croak "reached EOF while reading pvindex" unless length($str) == 4;
+ return unpack("L", $str);
+}
+
+sub GET_strconst {
+ my $fh = shift;
+ my ($str, $c);
+ $str = '';
+ while (defined($c = $fh->getc) && $c ne "\0") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading strconst" unless defined($c);
+ return cstring($str);
+}
+
+sub GET_pvcontents {}
+
+sub GET_PV {
+ my $fh = shift;
+ my $str;
+ my $len = $fh->GET_U32;
+ if ($len) {
+ read($fh, $str, $len);
+ croak "reached EOF while reading PV" unless length($str) == $len;
+ return cstring($str);
+ } else {
+ return '""';
+ }
+}
+
+sub GET_comment_t {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\n") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading comment" unless defined($c);
+ return cstring($str);
+}
+
+sub GET_double {
+ my $fh = shift;
+ my ($str, $c);
+ while (defined($c = $fh->getc) && $c ne "\0") {
+ $str .= $c;
+ }
+ croak "reached EOF while reading double" unless defined($c);
+ return $str;
+}
+
+sub GET_none {}
+
+sub GET_op_tr_array {
+ my $fh = shift;
+ my $len = unpack "S", $fh->readn(2);
+ my @ary = unpack "S*", $fh->readn($len*2);
+ return join(",", $len, @ary);
+}
+
+sub GET_IV64 {
+ my $fh = shift;
+ my $str = $fh->readn(8);
+ croak "reached EOF while reading I32" unless length($str) == 8;
+ return sprintf "0x%09llx", unpack("q", $str);
+}
+
+sub GET_IV {
+ $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64;
+}
+
+sub GET_PADOFFSET {
+ $Config{ptrsize} == 8 ? &GET_IV64 : &GET_U32;
+}
+
+sub GET_long {
+ $Config{longsize} == 8 ? &GET_IV64 : &GET_U32;
+}
+
+
+package B::Disassembler;
+use Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(disassemble_fh get_header);
+use Carp;
+use strict;
+
+use B::Asmdata qw(%insn_data @insn_name);
+
+our( $magic, $archname, $blversion, $ivsize, $ptrsize );
+
+sub dis_header($){
+ my( $fh ) = @_;
+ $magic = $fh->GET_U32();
+ warn( "bad magic" ) if $magic != 0x43424c50;
+ $archname = $fh->GET_strconst();
+ $blversion = $fh->GET_strconst();
+ $ivsize = $fh->GET_U32();
+ $ptrsize = $fh->GET_U32();
+}
+
+sub get_header(){
+ return( $magic, $archname, $blversion, $ivsize, $ptrsize);
+}
+
+sub disassemble_fh {
+ my ($fh, $out) = @_;
+ my ($c, $getmeth, $insn, $arg);
+ bless $fh, "B::Disassembler::BytecodeStream";
+ dis_header( $fh );
+ while (defined($c = $fh->getc)) {
+ $c = ord($c);
+ $insn = $insn_name[$c];
+ if (!defined($insn) || $insn eq "unused") {
+ my $pos = $fh->tell - 1;
+ die "Illegal instruction code $c at stream offset $pos\n";
+ }
+ $getmeth = $insn_data{$insn}->[2];
+ $arg = $fh->$getmeth();
+ if (defined($arg)) {
+ &$out($insn, $arg);
+ } else {
+ &$out($insn);
+ }
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+B::Disassembler - Disassemble Perl bytecode
+
+=head1 SYNOPSIS
+
+ use Disassembler;
+
+=head1 DESCRIPTION
+
+See F<ext/B/B/Disassembler.pm>.
+
+=head1 AUTHOR
+
+Malcolm Beattie, C<mbeattie@sable.ox.ac.uk>
+
+=cut