Re: [perl #22984] perl-5.8.1-RC2: TEST -bytecompile won't work at all

[p5sagit/p5-mst-13.2.git] / ext / B / B / Disassembler.pm

diff --git a/ext/B/B/Disassembler.pm b/ext/B/B/Disassembler.pm
index d054a2d..a563715 100644 (file)
--- a/ext/B/B/Disassembler.pm
+++ b/ext/B/B/Disassembler.pm
@@ -5,8 +5,12 @@
 #      You may distribute under the terms of either the GNU General Public
 #      License or the Artistic License, as specified in the README file.
 package B::Disassembler::BytecodeStream;
+
+our $VERSION = '1.01';
+
 use FileHandle;
 use Carp;
+use Config qw(%Config);
 use B qw(cstring cast_I32);
 @ISA = qw(FileHandle);
 sub readn {
@@ -28,47 +32,65 @@ sub GET_U16 {
     my $fh = shift;
     my $str = $fh->readn(2);
     croak "reached EOF while reading U16" unless length($str) == 2;
-    return unpack("n", $str);
+    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("N", $str);
+    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 cast_I32(unpack("N", $str));
+    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("N", $str);
+    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("N", $str);
+    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("N", $str);
+    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;
     }
@@ -115,29 +137,52 @@ sub GET_none {}
 
 sub GET_op_tr_array {
     my $fh = shift;
-    my @ary = unpack("n256", $fh->readn(256 * 2));
+    my $len = unpack "S", $fh->readn(2);
+    my @ary = unpack "S*", $fh->readn($len*2);
     return join(",", @ary);
 }
 
 sub GET_IV64 {
     my $fh = shift;
-    my ($hi, $lo) = unpack("NN", $fh->readn(8));
-    return sprintf("0x%4x%04x", $hi, $lo); # cheat
+    my ($hi, $lo) = unpack("LL", $fh->readn(8));
+    return sprintf("0x%x%08x", $hi, $lo); # cheat
+}
+
+sub GET_IV {
+    $Config{ivsize} == 4 ? &GET_I32 : &GET_IV64;
 }
 
 package B::Disassembler;
 use Exporter;
 @ISA = qw(Exporter);
-@EXPORT_OK = qw(disassemble_fh);
+@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, $byteorder );
+
+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();
+    $byteorder = $fh->GET_strconst();
+}
+
+sub get_header(){
+    return( $magic, $archname, $blversion, $ivsize, $ptrsize, $byteorder );
+}
+
 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];