#######################################################################
#
# DBD::MaddenNFL - a DBI driver for Madden NFL 2003+ database files.
# Copyright 2004 by George Greer
#
# 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.
#
#######################################################################

use strict;

use DBD::File;

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

package DBD::MaddenNFL;

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

$VERSION     = '0.1';
$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);
  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 $dbh = $data->{'Database'};
  my $tname = $table || $self->{tables}->[0]->{'name'};
  my $longsize = $Config{'longsize'};

  my $dbt = $dbh->{'maddennfl_tables'}->{$tname};
  my $fh = $dbh->{'maddennfl_fh'};
  my $db_version = $dbh->{'maddennfl_db_version'};
  my $readdata;
  my %table_header_size = (2003 => 6, 2004 => 9);

  # First read the table header to find out the number of columns.
  seek($fh, $dbt->{'offset'}, SEEK_SET);
  read($fh, $readdata, $longsize * $table_header_size{$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 ($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 ($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'},
  };

  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 ($$$) {
    my($self, $data, $params) = @_;
    my $dbh   = $data->{Database};
    my($table,$tname,@where_args);

       my($eval,$all_cols) = $self->open_tables($data, 0, 1);
       return undef unless $eval;
       $eval->params($params);
       $self->verify_columns($eval, $all_cols);
       $table = $eval->table($self->tables(0)->name());
       @where_args = ($eval,$self->tables(0)->name());

    my($affected) = 0;
    my(@rows, $array);
    if ( $table->can('delete_one_row') ) {
        while (my $array = $table->fetch_row($data)) {
            if ($self->eval_where(@where_args,$array)) {
                ++$affected;
                $array = $self->{fetched_value} if $self->{fetched_from_key};
                $table->delete_one_row($data,$array);
                return ($affected, 0) if $self->{fetched_from_key};
            }
        }
        return ($affected, 0);
    }
    while ($array = $table->fetch_row($data)) {
        if ($self->eval_where($table,$array)) {
            ++$affected;
        } else {
            push(@rows, $array);
        }
    }
    $table->seek($data, 0, 0);
    foreach $array (@rows) {
        $table->push_row($data, $array);
    }
    $table->truncate($data);
    return ($affected, 0);
}


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

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

# 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'} + $self->{'rec_size'} * $self->{'rec_count'}) {
    return undef;
  }

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

  my @data;
  my $bits = unpack('b*', $readdata);
  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-byte aligned' if ($f->{'offset'} % 8 != 0);
      die 'string not 8-byte 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) {
      my $field_bits = substr($bits, $f->{'offset'}, $f->{'size'});
      my $modbits = zero_pad($field_bits);
      my $wantbits = pack('b*', $modbits);
      my $value = unpack(
                #       $f->{'flags'} == 4 ? 'f' :
                        $f->{'size'} <=  8 ? 'C' :
                        $f->{'size'} <= 16 ? 'S' :
                        $f->{'size'} <= 32 ? 'L' : 'L*', $wantbits);
      push(@data, $value);
    } else {
      die 'unknown type: ' . $f->{'flags'};
    }
  }

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


# Helper for fetch_row().
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;
}


# 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;
  if ($self->{mldbm}) {
    $self->{hash}->{$key}= $row_aryref;
  } else {
    $self->{hash}->{$key}=$row_aryref->[0];
  }
  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>"
                                    ;
}


# fetch_one_row, delete_one_row, update_one_row
# are optimized for hash-style lookup without looping;
# if you don't need them, omit them, they're optional
# but, in that case you may need to define
# truncate() and seek(), see below
#
sub fetch_one_row ($$;$)
{
  my ($self, $key_only, $value) = @_;
  return $self->{'col_names'}->[0] if ($key_only);

  # XXX: Actually fetch the value here.
  return [ $value, $self->{'hash'}->{$value} ];
}


sub delete_one_row ($$$)
{
  # Don't know how to update the CRC so this would just corrupt the DB.
  return;

  my ($self, $data, $aryref) = @_;
}


sub update_one_row ($$$)
{
  # Can't do this either: read-only database.
  return;

  my ($self, $data, $aryref) = @_;
  my $key = shift @$aryref;
  return undef unless defined $key;
  if (ref $aryref->[0] eq 'ARRAY') {
    return $self->{'hash'}->{$key} = $aryref;
  }
  $self->{hash}->{$key} = $aryref->[0];
}


# 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;