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, 0 insertions, 233 deletions
diff --git a/Master/tlpkg/tlperl/lib/B/Disassembler.pm b/Master/tlpkg/tlperl/lib/B/Disassembler.pm
deleted file mode 100644
index e1993aa9537..00000000000
--- a/Master/tlpkg/tlperl/lib/B/Disassembler.pm
+++ /dev/null
@@ -1,233 +0,0 @@
-# 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