diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/B/Disassembler.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/B/Disassembler.pm | 233 |
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 |