#######################################################################
#
# DBD::MaddenNFL - a DBI driver for Madden NFL 2003+ database files.
# Copyright 2004 by George Greer
#
# Version 0.2	September 18th, 2004
#	- Fixed table JOINs. (by adding the 'NAME' table hash key)
#	- Changed to C-style decoding of fields. (should be faster)
# Version 0.1	August 12th, 2004
#	- Initial release.
#
# Based on DBD::DBM, Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org >
#
# You may freely distribute and/or modify this module under the terms
# of either the GNU General Public License (GPL) or the Artistic
# License, as specified in the Perl README file.
#
# Example: $dbh = DBI->connect('dbi:MaddenNFL:yourfranchise.fra')
#
# This file must be named "MaddenNFL.pm" for it to work.
# Field name case does not matter but table names must be capitalized.
#
#######################################################################

use strict;

use DBD::File;

# ===== PREAMBLE =====

package DBD::MaddenNFL;

use base qw(DBD::File);
use vars qw($VERSION $ATTRIBUTION $drh);

$VERSION     = '0.2';
$ATTRIBUTION = 'DBD::MaddenNFL by George Greer';

# no need to have driver() unless you need private methods
#
#sub driver ($;$) {}

sub CLONE
{
  undef $drh;
}


# ===== DRIVER =====

package DBD::MaddenNFL::dr;

use Fcntl qw(:flock);
use Config;

$DBD::MaddenNFL::dr::imp_data_size = 0;
@DBD::MaddenNFL::dr::ISA = qw(DBD::File::dr);

# you can get by without connect() if you don't have to check private
# attributes, DBD::File will gather the connection string arguements for you
#
sub connect ($$;$$$)
{
  my ($drh, $dbname, $user, $auth, $attr) = @_;

  open(FH, "+<$dbname") || return undef;
  flock(FH, LOCK_SH);

  my $longsize = $Config{'longsize'};

  # Determine database version (year of Madden NFL game).
  my ($data, $version, $main_header_size);
  read(FH, $data, $longsize);
  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 {
    return undef;
    # $dbh->set_err(1, "Unknown database version: DB ID# = %#08x\n", $db_id);
  }

  # Read database header information.
  read(FH, $data, $main_header_size * $longsize);
  my ($unk_1, $db_size, $is_zero, $db_tables, $unk_2) = unpack('L' . $main_header_size, $data);

  # Find table names and offets.
  my %tables;
  for (my $t = 0; $t < $db_tables; $t++) {
    read(FH, $data, 4 + $longsize);
    my ($table_name, $table_offset) = unpack('A4L', $data);
    my $startpos = $longsize +
		$main_header_size * $longsize +
		$db_tables * 8 +
		$table_offset +
		($version == 2003 ? 0 : 4);
    $tables{$table_name}->{'offset'} = $startpos;
  }

  # create a 'blank' dbh
  my $this = DBI::_new_dbh($drh, {
	Name => $dbname,
  });

  $this->STORE('Active', 1);
  $this->STORE('maddennfl_fh', *FH);
  $this->STORE('maddennfl_db_version', $version);
  $this->STORE('maddennfl_db_filesize', $db_size);
  $this->STORE('maddennfl_table_count', $db_tables);
  $this->STORE('maddennfl_tables', \%tables);
  $this->STORE('sql_flags', { 'dialect' => 'ANSI', 'select' => { 'join' => 1 } });
  return $this;
}


# you could put some :dr private methods here

# you may need to override some DBD::File::dr methods here
# but you can probably get away with just letting it do the work
# in most cases


# ===== DATABASE =====

package DBD::MaddenNFL::db;

$DBD::MaddenNFL::db::imp_data_size = 0;
@DBD::MaddenNFL::db::ISA = qw(DBD::File::db);

# the ::db::STORE method is what gets called when you set
# a lower-cased database handle attribute such as $dbh->{somekey}=$someval;
#
# STORE should check to make sure that "somekey" is a valid attribute name
# but only if it is really one of our attributes (starts with dbm_ or foo_)
# You can also check for valid values for the attributes if needed
# and/or perform other operations
#
sub STORE ($$$)
{
  my ($dbh, $attrib, $value) = @_;

  # use DBD::File's STORE unless its one of our own attributes
  #
  return $dbh->SUPER::STORE($attrib,$value) unless $attrib =~ /^maddennfl_/;

  # throw an error if it has our prefix but isn't a valid attr name
  #

  # check here if you need to validate values
  # or conceivably do other things as well
  #
  $dbh->{$attrib} = $value;
  return 1;
}


# and FETCH is done similar to STORE
#
sub FETCH ($$)
{
  my ($dbh, $attrib) = @_;

  return $dbh->SUPER::FETCH($attrib) unless $attrib =~ /^maddennfl_/;

  # throw an error if it has our prefix but isn't a valid attr name
  #

  # check here if you need to validate values
  # or conceivably do other things as well
  #
  return $dbh->{$attrib};
}


sub disconnect
{
  my ($self) = @_;
  close($self->{'maddennfl_fh'});
  $self->STORE('Active', 0);
  return 1;
}

# you may need to override some DBD::File::db methods here
# but you can probably get away with just letting it do the work
# in most cases


# ===== STATEMENT =====

package DBD::MaddenNFL::st;
$DBD::MaddenNFL::st::imp_data_size = 0;
@DBD::MaddenNFL::st::ISA = qw(DBD::File::st);

# you could put some :st private methods here

# you may need to over-ride some DBD::File::st methods here
# but you can probably get away with just letting it do the work
# in most cases

package DBD::MaddenNFL::Statement;

use base qw(DBD::File::Statement);
use IO::File;  # for locking only
use Fcntl qw(:flock);

use Config;

# you must define open_table;
# it is done at the start of all executes;
# it doesn't necessarily have to "open" anything;
# you must define the $tbl and at least the col_names and col_nums;
# anything else you put in depends on what you need in your
# ::Table methods below; you must bless the $tbl into the
# appropriate class as shown
#
# see also the comments inside open_table() showing the difference
# between global, per-table, and default settings
#
sub open_table ($$$$$)
{
  my ($self, $data, $table, $createMode, $lockMode) = @_;

  my $longsize = $Config{'longsize'};
  my $dbh = $data->{'Database'};
  my $dbt = $dbh->{'maddennfl_tables'}->{$table};
  my $fh = $dbh->{'maddennfl_fh'};

  die "No table '$table'" if (!$dbt);

  # First read the table header to find out the number of columns.
  my $readdata;
  my %table_header_size = (2003 => 6, 2004 => 9);
  seek($fh, $dbt->{'offset'}, SEEK_SET);
  read($fh, $readdata, $longsize * $table_header_size{$dbh->{'maddennfl_db_version'}});

  # Now parse that header into bite-size chunks.
  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 ($dbh->{'maddennfl_db_version'} == 2003) {
    ($u_1, $rec_len, $rec_bits, $rec_alc, $rec_cnt, $u_2,
        $field_cnt, $idx_cnt, $s_3) = unpack('L3S2LC2S', $readdata);
  } elsif ($dbh->{'maddennfl_db_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', $readdata);
    $idx_cnt = $s_2 = $s_3 = 0;
  }

  # Now read the actual field names (and types).
  my @col_names;
  my $dbtf = $dbt->{'fields'};
  for (my $f = 0; $f < $field_cnt; $f++) {
    read($fh, $readdata, $longsize * 4);
    my ($f_flags, $f_offset, $f_name, $f_bits) = unpack('L2a4L', $readdata);
    $f_name = uc $f_name;
    push(@col_names, $f_name);
    $dbtf->{$f_name}->{'offset'} = $f_offset;
    $dbtf->{$f_name}->{'size'}   = $f_bits;
    $dbtf->{$f_name}->{'flags'}  = $f_flags;
  }

  # and lastly, put them in the proper order.
  @col_names = sort {
		$dbtf->{$a}->{'offset'} <=> $dbtf->{$b}->{'offset'}
	} @col_names;

  # Number the columns.
  my $i = 0;
  my %col_nums = map { $_ => $i++ } @col_names;

  my $tbl = {
	'col_nums'	=> \%col_nums,
	'col_names'	=> \@col_names,
	'rec_size'	=> $rec_len,
	'rec_count'	=> $rec_cnt,
	'rec_alloc'	=> $rec_alc,
	'field_count'	=> $field_cnt,
	'fields'	=> $dbtf,
	'offset'	=> $dbt->{'offset'},
	'offset_end'	=> $dbt->{'offset'} + $rec_len * $rec_cnt,
	'NAME'		=> $table,
  };

  my $class = ref($self);
  $class =~ s/::Statement/::Table/;
  bless($tbl, $class);
  return $tbl;
}


# DELETE is only needed for backward compat with old SQL::Statement
# it can be removed when the next SQL::Statement is released
#
# It is an example though of how you can subclass SQL::Statement/Nano
# in your DBD ... if you needed to, you could override CREATE
# SELECT, etc.
#
sub DELETE ($$$) {
  # DBD::MaddenNFL - Writing to database not currently supported.
  return undef;
#    my($self, $data, $params) = @_;
#    my $dbh   = $data->{Database};
#    return ($affected, 0);
}


# ===== TABLE =====

package DBD::MaddenNFL::Table;
use base qw(DBD::File::Table);

use Config;

# you must define drop
# it is called from execute of a SQL DROP statement
#
sub drop ($$) {
  # You wouldn't want to do this even if I understood the Madden CRC.
  return 1;
}


# you must define fetch_row, it is called on all fetches;
# it MUST return undef when no rows are left to fetch;
# checking for $ary[0] is specific to hashes so you'll
# probably need some other kind of check for nothing-left.
# as Janis might say: "undef's just another word for
# nothing left to fetch" :-)
#
sub fetch_row ($$$) {
  my ($self, $data, $row) = @_;
  my $dbh = $data->{'Database'};
  my $fh = $dbh->{'maddennfl_fh'};
  my $readdata;

  # Last record check.
  if (tell($fh) >= $self->{'offset_end'}) {
    return undef;
  }

  read($fh, $readdata, $self->{'rec_size'});

  my @data;
  foreach my $field (@{$self->{'col_names'}}) {
    my $f = $self->{'fields'}->{$field};
    die "$field: not found" if (!$f);
    if ($f->{'flags'} == 0) {
      # String.
      die 'string not 8-bit aligned' if ($f->{'offset'} % 8 != 0);
      die 'string not 8-bit long'    if ($f->{'size'}   % 8 != 0);
      push(@data, unpack('Z*', substr($readdata, $f->{'offset'} / 8, $f->{'size'} / 8)));
    } elsif ($f->{'flags'} >= 1 && $f->{'flags'} <= 4) {
      push(@data, resolve_number($f, $readdata));
    } else {
      die 'unknown type: ' . $f->{'flags'};
    }
  }

  $self->{'row'} = @data ? \@data : undef;
}


# Helper for fetch_row().
sub resolve_number
{
  my ($f, $data) = @_;

  my $longsize = $Config{'longsize'};
  my $bucket = int($f->{'offset'} / 32);
  my $oshift = $f->{'offset'} % 32;
  my $data_bits = $f->{'size'} + $oshift > 32 ? 32 - $oshift : $f->{'size'};
  my $mask = (1 << $data_bits) - 1;

  my $bitdata = (unpack('L', substr($data, $bucket * $longsize, $longsize)) >> $oshift) & $mask;
  if ($oshift + $f->{'size'} > 32) {
    $bitdata |= (unpack('L', substr($data, ($bucket + 1) * $longsize, $longsize)) & ((1 << ($f->{'size'} - $data_bits)) - 1)) << (32 - $oshift);
  }

  return $bitdata;
}


# you must define push_row
# it is called on inserts and updates
#
sub push_row ($$$) {
  # Don't understand Madden NFL CRC so this would just corrupt the file.
  return 1;

  my ($self, $data, $row_aryref) = @_;
  my $key = shift @$row_aryref;
  # ...
  return 1;
}


# this is where you grab the column names from a CREATE statement
# if you don't need to do that, it must be defined but can be empty
#
sub push_names ($$$)
{
  # Don't need to create tables in Madden NFL either.
  return 1;

    my($self, $data, $row_aryref) = @_;
    $data->{Database}->{dbm_tables}->{$self->{table_name}}->{c_cols}
       = $row_aryref;
    next unless $self->{store_metadata};
    my $stmt = $data->{f_stmt};
    my $col_names = join ',', @{$row_aryref};
    my $schema = $data->{Database}->{Statement};
       $schema =~ s/^[^\(]+\((.+)\)$/$1/s;
       $schema = $stmt->schema_str if $stmt->can('schema_str');
    $self->{hash}->{"_metadata \0"} = "<dbd_metadata>"
                                    . "<schema>$schema</schema>"
                                    . "<col_names>$col_names</col_names>"
                                    . "</dbd_metadata>"
                                    ;
}


# you may not need to explicitly DESTROY the ::Table
# put cleanup code to run when the execute is done
#
sub DESTROY ($)
{
  # Nothing special for a table since it is part of the master database file.
}


# truncate() and seek() must be defined to satisfy DBI::SQL::Nano
# *IF* you define the *_one_row methods above, truncate() and
# seek() can be empty or you can use them without actually
# truncating or seeking anything but if you don't define the
# *_one_row methods, you may need to define these
#
# if you need to do something after a series of
# deletes or updates, you can put it in truncate()
# which is called at the end of executing
#
#sub truncate ($$) {
#  # Would put the CRC-updating code here if I understood the algorithm.
#  my ($self, $data) = @_;
#  1;
#}


# seek() is only needed if you use IO::File
# though it could be used for other non-file operations
# that you need to do before "writes" or truncate()
#
#sub seek ($$$$)
#{
#  my ($self, $data, $pos, $whence) = @_;
#}


# Th, th, th, that's all folks!  See DBD::File and DBD::CSV for other
# examples of creating pure perl DBDs.  I hope this helped.
# Now it's time to go forth and create your own DBD!
# Remember to check in with dbi-dev@perl.org before you get too far.
# We may be able to make suggestions or point you to other related
# projects.

1;