From 2ccd5fb21cdc33e772612922fd9bb1901c703941 Mon Sep 17 00:00:00 2001
From: rgrjr <rgrjr@d31e2699-5ff4-0310-a27c-f18f2fbe73fe>
Date: Sat, 1 Mar 2008 19:58:28 +0000
Subject: [PATCH] * tools/dev/pbc_header.pl:    + Use Digest::MD5 instead of
 Digest::Perl::MD5, which is no longer      bundled.  There is also no need
 for "use lib" on that account.    + (show_pbc_file_info):  Update header
 dumping to add new fields.    + Fix doc typos, add ref to pdump.

git-svn-id: https://svn.perl.org/parrot/trunk@26165 d31e2699-5ff4-0310-a27c-f18f2fbe73fe
---
 tools/dev/pbc_header.pl | 84 +++++++++++++++++++++++++++++++++++++++++--------
 1 file changed, 71 insertions(+), 13 deletions(-)

diff --git a/tools/dev/pbc_header.pl b/tools/dev/pbc_header.pl
index 004d6fa6f5..63f856f4d9 100644
--- a/tools/dev/pbc_header.pl
+++ b/tools/dev/pbc_header.pl
@@ -21,17 +21,22 @@ The F<PBC_COMPAT> file is used to maintain Parrot bytecode
 compatability. During release preparation (and other changes to
 PBC_COMPAT) the fingerprint of existing bytecode files is invalidated.
 
-This utility updates the version and finperprint information in the bytecode,
+This utility updates the version and fingerprint information in the bytecode,
 but can of course not assure that it will run correctly, when incompatible
 changes were done.
 
-If no options are given a summary of the PBC header is printed to STDOUT.
+If no options are given, a summary of the PBC header is printed to STDOUT.
+
+=head1 SEE ALSO
+
+The C<pdump> utility does a much more thorough job of showing bytecode file
+headers.
 
 =cut
 
 use Getopt::Long;
-use lib 'lib';
-use Digest::Perl::MD5 qw(md5);
+use Digest::MD5 qw(md5);
+
 my %opt;
 &main;
 
@@ -74,17 +79,70 @@ sub update_fp {
 sub pbc_info {
     for my $f (@ARGV) {
         open my $F, "<", "$f" or die "Can't open $f: $!";
-        my $header;
-        read $F, $header, 16;
-        my (@fields) = qw( wordsize byteorder major minor
-            intvalsize floattype );
         print "$f\n";
-        for my $i ( 0 .. 5 ) {
-            my $c = substr $header, $i, 1;
-            $c = unpack 'c', $c;
-            printf "\t%-12s= %s\n", $fields[$i], $c;
-        }
+
+	show_pbc_file_info($F);
+    }
+}
+
+my @pbc_header_type_names;
+BEGIN {
+    @pbc_header_type_names = qw( directory default fixup constant
+				 bytecode annotations pic dependencies );
+}
+
+sub show_pbc_file_info {
+    my $F = shift;
+
+    # [bad assumption?  -- rgr, 10-Feb-08.]
+    my $word_size = 4;
+    my $word_unpack = 'V';
+    my $packfile_offset = 0;
+
+    my $read_pbc_words = sub {
+	my ($n_words) = @_;
+
+	my @result;
+	my $bytes;
+	read $F, $bytes, $n_words*$word_size;
+	for my $i (0 .. $n_words-1) {
+	    my $word = substr $bytes, $word_size*$i, $word_size;
+	    push(@result, unpack $word_unpack, $word);
+	}
+	@result;
+    };
+
+    # Display single_byte fields.
+    my (@byte_fields) = qw(wordsize byteorder floattype
+			   parrot_major parrot_minor parrot_patch
+			   bc_major bc_minor
+			   uuid_type uuid_size );
+    my $n_byte_fields = @byte_fields;
+    my $header;
+    read $F, $header, $n_byte_fields+8;
+    $packfile_offset += ($n_byte_fields+8)/$word_size;
+    for my $i ( 0 .. $n_byte_fields-1 ) {
+	my $c = substr $header, $i+8, 1;
+	$c = unpack 'c', $c;
+	printf "\t%-14s= %3d\n", $byte_fields[$i], $c;
     }
+
+    # Show the UUID, if any, followed by the header padding.
+    my $uuid_type = ord substr $header, $n_byte_fields+6;
+    my $uuid_len = ord substr $header, $n_byte_fields+7;
+    my $leftover = (18+$uuid_len) % 16;
+    my $n = $leftover == 0 ? 0 : 16 - $leftover;
+    my $uuid;
+    read $F, $uuid, $uuid_len+$n;
+    $packfile_offset += ($uuid_len+$n)/$word_size;
+    if ($uuid_type) {
+	printf "\t%-14s= '%s'\n", 'UUID', unpack "${n}H", $uuid;
+    }
+    printf "\t%-14s= %3d\n", 'pad', $n;
+
+    # Show the directory format header.
+    printf "\t%-14s= %d, %d, %d, %d\n", 'dir_format', $read_pbc_words->(4);
+    $packfile_offset += 4;
 }
 
 sub main {
-- 
2.11.4.GIT