#!/usr/bin/perl -w

# Version 0.1 (not originally intended for public consumption)
# by George Greer <greerga@m-l.org>
#
# License: public domain with no warranty.
# If it breaks, you get to keep both pieces.

# Teams
# 1015 = Draft
# 1014 = Retired? Free?
# 1010 = Pro Bowl (AFC? NFC?)
# 1011 = Pro Bowl (AFC? NFC?)
# 1009 = Retired? Free ?

use strict;
#use Digest::Adler32;
#use String::CRC32;
use Fcntl ':seek';
use Carp;
use IO::File;

my $a32 = undef; # Digest::Adler32->new;

if (@ARGV < 1) {
  print "Usage: $0 file-to-read\n";
  exit 1;
}
my $filename = $ARGV[0];
my $table = @ARGV >= 2 ? $ARGV[1] : '';
my $crc_mode = @ARGV >= 3 ? $ARGV[2] : 'adler'; # sum crc adler

$| = 1;
my $size_long = 4;
my %size_table = (
   1 =>  4,  2 =>  4,  3 =>  4,
   4 =>  4,  5 =>  4,  6 =>  4,
   7 =>  4,  8 =>  4,  9 =>  4,
  10 =>  4, 11 =>  4, 12 =>  4, 13 => 4,
  14 =>  5, 15 =>  5, 16 =>  5,
  17 =>  6, 18 =>  6, 19 =>  6,
  20 =>  7, 21 =>  7, 22 =>  7, 23 => 7,
  24 =>  8, 25 =>  8, 26 =>  8,
  27 =>  9, 28 =>  9, 29 =>  9,
  30 => 10, 31 => 10, 32 => 10,
);

my $dbf = new IO::File;
$dbf->open("< $filename") || die "$filename: $!\n";
db_print($dbf, $table);
$dbf->close;

# -----

sub db_print
{
  my ($db, $print_table) = @_;

  my $version;
  my $main_header_size;
  my $data;

  read($db, $data, $size_long);
  my ($db_id) = unpack('L', $data);
  if ($db_id == 0x07004244) {
    $version = 2003;
    $main_header_size = 4;
  } elsif ($db_id == 0x08004244) {
    $version = 2004;
    $main_header_size = 5;
  } else {
    printf("DB ID# = %#08x\n", $db_id);
    die "Unexpected DB id# $db_id.";
  }

  read($db, $data, $main_header_size * $size_long);

  # === HEADER ===
  my ($unk_1, $db_size, $is_zero, $db_tables, $unk_2) = unpack('L' . $main_header_size, $data);
  $unk_2 ||= 0;

  # Do not yet know second field.
  assert($is_zero == 0);	# Don't know why, but it is.
  printf "%u: u_1=%u/%#08x, size=$db_size, zero=$is_zero, tables=$db_tables, u_2=%u/%#08x\n", $version, $unk_1, $unk_1, $unk_2, $unk_2;

  # === TABLE INDEX ===
  my $endpos = $size_long + $main_header_size * $size_long + $db_tables * 8 + 4;
  for (my $t = 0; $t < $db_tables; $t++) {
    read($db, $data, 4 + $size_long);
    my ($table_name, $table_offset) = unpack('A4L', $data);
    if (!$print_table || $print_table eq $table_name) {
      my $pos = tell($db);
      my $startpos = $size_long + $main_header_size * $size_long + $db_tables * 8 + $table_offset + 4;
      if ($endpos && $startpos != $endpos) {
        print "$table_name: e=$endpos s=$startpos: Seeked position does not match resulting position.\n";
      }
      table_print($db, $version, $table_name, $startpos, $unk_1);
      $endpos = tell($db);
      seek($db, $pos, SEEK_SET);
    }
  }

  # === END ===
}


sub table_print
{
  my ($db, $version, $table_name, $table_start_offset, $tu1) = @_;
  my $data;

  printf "table $table_name	[%10lu/%#08x]\n", $table_start_offset, $table_start_offset;
  seek($db, $table_start_offset, SEEK_SET);

  # Starting CRC value. (guess)
  my $crc = 1;
#  my $crc = 1060406741;
  my $header_size = $version == 2003 ? 6 : 9;

  # === HEADER ===
  read($db, $data, $size_long * $header_size);
  $crc = checksum($crc, $data, $size_long * $header_size);
  my ($u_1, $rec_len, $rec_bits, $rec_alc, $rec_cnt, $s_1, $s_2, $field_cnt,
	$idx_cnt, $s_3, $c_1, $c_2, $u2k4_1, $u2k4_2, $u_2, $u_3);
  if ($version == 2003) {
    ($u_1, $rec_len, $rec_bits, $rec_alc, $rec_cnt, $s_1, $s_2,
	$field_cnt, $idx_cnt, $s_3) = unpack('L3S4C2S', $data);
    printf "  u_1 = %9u, (RL-u,RB-u,RA-s,RC-s) s_1 = %5u, s_2 = %5u\n", $u_1, $s_1, $s_2;
    printf "  (FC-c) (IC-c), s_3 = %5u [L3 S4 C2 S2]\n", $s_3;
  } elsif ($version == 2004) {
    (	$u_1, $rec_len, $rec_bits, $u_2,	# L4
	$rec_alc, $rec_cnt,			# S2
	$u_3, $field_cnt, $c_1, $s_1,		# LC2S
	$u2k4_1, $u2k4_2			# L2
	) = unpack('L4S2LC2SL2', $data);
    $idx_cnt = $s_2 = $s_3 = 0;
    print "u1=$u_1 rl=$rec_len rb=$rec_bits u2=$u_2 ra=$rec_alc rc=$rec_cnt u3=$u_3, fc=$field_cnt u4=$u2k4_1 u5=$u2k4_2\n";
  }
  print "  fields = $field_cnt, record length = $rec_len ($rec_bits), records: alloc'd = $rec_alc / used = $rec_cnt, idx = $idx_cnt\n";

  # === FIELD READING ===
  my @fields;
  for (my $f = 0; $f < $field_cnt; $f++) {
    read($db, $data, $size_long * 4);
    $crc = checksum($crc, $data, $size_long * 4);
    my ($f_flags, $f_offset, $f_name, $f_bits) = unpack('L2a4L', $data);
#    print "$f: $f_flags, $f_offset, $f_name, $f_bits\n";
    push(@fields, { 'name' => $f_name, 'offset' => $f_offset,
		'size' => $f_bits, 'flags' => $f_flags });
  }

  # === FIELD DISPLAY ===
  @fields = sort { $a->{'offset'} <=> $b->{'offset'} } @fields;
  foreach my $f (@fields) {
    printf "  field %4s, offset %4u(%2u), bits %3u, %08x\n",
		$f->{'name'}, $f->{'offset'}, $f->{'offset'} % 32,
		$f->{'size'}, $f->{'flags'};
  }

  # === OUTPUT TITLES ===
  print "\t: ";
  foreach my $field (@fields) {
    if ($field->{'flags'} == 0) {
      printf '%-*s ', $field->{'size'} / 8, $field->{'name'};
    } else {
      # Bug: can go over 32.
      printf '%*s ', $size_table{$field->{'size'}} || 20, $field->{'name'};
    }
  }
  print "\n";

  # === DATA ===
  my $debug_bits = 0;
  my $data_start_offset = tell($db);
  for (my $recno = 0; $recno < $rec_alc; $recno++) {
    read($db, $data, $rec_len);
    $crc = checksum($crc, $data, $rec_len);

    # Don't print unallocated records, but checksum them.
    next if ($recno >= $rec_cnt);

    printf "%8lu: ", tell($db) - $data_start_offset - $rec_len;
    my $bits = unpack('b*', $data);
    print "1: [$bits] [", length $bits, "]\n" if (($debug_bits & 1) == 1);
    for (my $fieldno = 0; $fieldno < $field_cnt; $fieldno++) {
      my $f = $fields[$fieldno];
      if ($f->{'flags'} == 0) {
        # String
        die 'string not 8-byte aligned' if ($f->{'offset'} % 8 != 0);
        die 'string not 8-byte long'    if ($f->{'size'}   % 8 != 0);
        printf '%-*s ', $f->{'size'} / 8,
		unpack('Z*', substr($data, $f->{'offset'} / 8, $f->{'size'} / 8));
      } elsif ($f->{'flags'} >= 1 && $f->{'flags'} <= 4) {
        # Bit munging. 1 = big?, 2 = ?, 3 = ?, 4 = ?

        my $field_bits = substr($bits, $f->{'offset'}, $f->{'size'});
print "2: [$field_bits] [", length $field_bits, "]\n" if (($debug_bits & 2) == 2);
        my $modbits = zero_pad($field_bits);
print "3: [$modbits] [", length $modbits, "]\n" if (($debug_bits & 4) == 4);
        my $wantbits = pack('b*', $modbits);
print "4: [$wantbits]\n" if (($debug_bits & 8) == 8);
        my $value = unpack(
		#	$f->{'flags'} == 4 ? 'f' :
			$f->{'size'} <=  8 ? 'C' :
			$f->{'size'} <= 16 ? 'S' :
			$f->{'size'} <= 32 ? 'L' : 'L*', $wantbits);
print "5: [$value] [", $f->{'size'} <= 8 ? 'C' : $f->{'size'} <= 16 ? 'S' : $f->{'size'} <= 32 ? 'L' : 'L*', "]\n" if (($debug_bits & 16) == 16);
        printf "%*s ", $size_table{$f->{'size'}} || 20, $value;
      } else {
        die 'unknown type: ' . $f->{'flags'};
      }
    }
    print "\n";
  }

  # === SUMMARY ===
  my $active_rec_alc = $rec_alc;
  if (($u_1 & 0x10) != 0) {
    # for u_1 in (26, 30) -- meaning???
    $active_rec_alc = 0;
  }

  # Skip any unallocated records.
#  if ($active_rec_alc > $rec_cnt) {
#    seek($db, ($active_rec_alc - $rec_cnt) * $rec_len, SEEK_CUR);
#  }

  for (my $idx_n = 0; $idx_n < $idx_cnt; $idx_n++) {
    read($db, $data, 16);
    my ($idx_n_field, $idx_n_2, $idx_n_3, $idx_n_4) = unpack('C4L3', $data);
    printf "  Index %u: %4s %10u %10u %10u\n", $idx_n, $idx_n_field, $idx_n_2, $idx_n_3, $idx_n_4;
  }

  printf "  Total size = %u, Calc size = %u, End = %u\n",
		tell($db) - $table_start_offset + 4,
		$size_long * 6 +		# Header
		$size_long * 4 * $field_cnt +	# Fields
		$active_rec_alc * $rec_len +	# Records
		$idx_cnt * 16 +			# Indicies
		$size_long,			# CRC
		tell($db)
		;
  read($db, $data, $size_long);
  my $table_crc = unpack('L', $data);
  printf "  Table CRC = %0#10x, Calc CRC = %0#10x\n", $table_crc, checksum_result($crc);
  printf "t=%4s of=%8u u1=%2u rln=%4u rbt=%5u rac=%5u rct=%4u s1=%2u s2=%5u fct=%3u ict=%1u s3=%2u tcrc=%#010x ccrc=%#010x hs=%2d fs=%4d ds=%6d is=%2d\n", $table_name, $table_start_offset, $u_1, $rec_len, $rec_bits, $rec_alc, $rec_cnt, $s_1, $s_2, $field_cnt, $idx_cnt, $s_3, $table_crc, checksum_result($crc), $size_long * 6, $size_long * 4 * $field_cnt, $rec_cnt * $rec_len, $idx_cnt * 16;
  checksum_reset($crc);
}

sub assert
{
  croak 'assertion failed' if (!$_[0]);
}

sub zero_pad
{
  my ($val) = @_;
  my $len = length $val;

  if ($len < 16) {
    $val .= ('0' x (8 - ($len % 8)));
  } elsif ($len > 16 && $len < 32) {
    $val .= ('0' x (32 - $len));
  } elsif ($len % 8 == 0) {
    ;
  } else {
    die "size over 32";
  }
  return $val;
}

sub checksum_reset
{
  if ($crc_mode ne 'adler') {
    $_[0] = 0;
  } elsif ($a32) {
    $a32->digest;
  } else {
    $_[0] = 1;
  }
}

sub checksum_result
{
  my ($crc) = @_;
  if ($crc_mode ne 'adler') {
    return $crc;
  } else {
    return $a32 ? $$a32 : $crc;
  }
}

sub checksum
{
  my ($init, $buf, $len) = @_;

  if ($crc_mode eq 'sum') {
    # Checksum
    for (my $x = 0; $x < $len; $x++) {
      $init += ord substr($buf, $x, 1);
    }
  } elsif ($crc_mode eq 'crc') {
    # CRC32
    $init = crc32(substr($buf, 0, $len), $init);
  } elsif ($crc_mode eq 'adler') {
    # Adler-32
    if ($a32) {
      $a32->add($buf);
    } else {
      $init = update_adler32($init, $buf, $len);
    }
  }
  return $init;
}

sub update_adler32
{
  my $base = 65521;
  my ($adler, $buf, $len) = @_;
  my $s1 = $adler & 0xffff;
  my $s2 = ($adler >> 16) & 0xffff;

  for (my $n = 0; $n < $len; $n++) {
    $s1 = ($s1 + ord(substr($buf, $n, 1))) % $base;
    $s2 = ($s2 + $s1) % $base;
  }
  return ($s2 << 16) + $s1;
}
