File Coverage

blib/lib/Games/Go/AGA/TDListDB.pm

Criterion	Covered	Total	%
statement	209	274	76.2
branch	57	116	49.1
condition	5	10	50.0
subroutine	44	53	83.0
pod	30	35	85.7
total	345	488	70.7

#===============================================================================
#         FILE:  Games::Go::AGA::TDListDB
#     ABSTRACT:  an SQL object for holding AGA TDList data
#       AUTHOR:  Reid Augustin (REID),
#      COMPANY:  LucidPort Technology, Inc.
#      CREATED:  12/02/2010 08:51:22 AM PST
#===============================================================================

use 5.010;
use strict;
use warnings;

package Games::Go::AGA::TDListDB;
use parent 'Exporter';
our @EXPORT_OK = qw(
    LAST_NAME
    FIRST_NAME
    ID
    MEMBERSHIP
    RANK
    DATE
    CLUB
    STATE
    EXTRA
);
our %EXPORT_TAGS = (all => \@EXPORT_OK);

use open qw( :utf8 :std );  # UTF8 for all files and STDIO
use IO::Handle;     # for autoflush
use Carp;
use DBI;
use Readonly;
use Try::Tiny;
use POSIX ":sys_wait_h";
use LWP::UserAgent;
use LWP::Protocol::https;
use Games::Go::AGA::Parse::TDList;
use Games::Go::AGA::Parse::Util qw( is_Rating );

our $VERSION = '0.032'; # VERSION

sub LAST_NAME  { 0 };
sub FIRST_NAME { 1 };
sub ID         { 2 };
sub MEMBERSHIP { 3 };
sub RANK       { 4 };
sub DATE       { 5 };
sub CLUB       { 6 };
sub STATE      { 7 };
sub EXTRA      { 8 };

Readonly my @columns => (
    {last_name  => 'VARCHAR(256)',             },
    {first_name => 'VARCHAR(256)',             },
    {id         => 'VARCHAR(256) NOT NULL PRIMARY KEY', },
    {membership => 'VARCHAR(256)',             },
    {rank       => 'VARCHAR(256)',             },
    {date       => 'VARCHAR(256)',             },
    {club       => 'VARCHAR(256)',             },
    {state      => 'VARCHAR(256)',             },
    {extra      => 'VARCHAR(256)',             },
);

my %pre_defaults = (
    url                    => 'https://www.usgo.org/ratings/TDListN.txt',
    dbdname                => 'tdlistdb.sqlite',
    table_name             => 'tdlist',
    extra_columns          => [],
    extra_columns_callback => sub { return () },
    max_update_errors      => 10,
    raw_filename           => 'TDList.txt',
    verbose                => 0,
);

__PACKAGE__->run( @ARGV ) if not caller();  # modulino

sub new {
    my ($class, %args) = @_;

    my $self = {};
    bless $self, (ref $class || $class);

    while (my ($key, $value) = each %pre_defaults) {
        $value = delete $args{$key} if (exists $args{$key});
        $self->$key($value);
    }

    my $db = $self->db(delete $args{db});

    for my $key (keys %args) {  # any leftovers?
        $self->$key($args{$key});
    }

    # SQL for finding players by name
    $self->sth('select_by_name',
        $db->prepare(
            join('',
                'SELECT * FROM ',
                $self->table_name,
                ' WHERE last_name  = ?',
                ' AND   first_name = ?',
            ),
        ),
    );

    # and a statement for inserting new players
    $self->sth('insert_player',
        $db->prepare(
            join('',
                'INSERT INTO ',
                $self->table_name,
                ' ( ',
                    $self->sql_columns,
                ' ) ',
                'VALUES ( ',
                    $self->sql_insert_qs,
                ' )',
            ),
        ),
    );

    # SQL for updating when player is already in DB
    $self->sth('update_id',
        $db->prepare(
            join('',
                'UPDATE ',
                $self->table_name,
                ' SET ',
                $self->sql_update_qs,
                ' WHERE id = ?',
            ),
        ),
    );

    # SQL for finding IDs
    $self->sth('select_id',
        $db->prepare(
            join('',
                'SELECT * FROM ',
                $self->table_name,
                ' WHERE id = ?',
            ),
        ),
    );

    # SQL for getting and setting DB update time
    $self->sth('select_time',
        $db->prepare(
            join('',
                'SELECT update_time FROM ',
                $self->table_name_meta,
                ' WHERE key = 1',
            ),
        ),
    );
    $self->sth('update_time',
        $db->prepare(
            join('',
                'UPDATE ',
                $self->table_name_meta,
                ' SET update_time = ?',
                ' WHERE key = 1',
            ),
        ),
    );

    # SQL to get/set next_tmp marker
    $self->sth('select_next_tmp',
        $db->prepare(
            join('',
                'SELECT next_tmp_id FROM ',
                $self->table_name_meta,
                ' WHERE key = 1',
            ),
        ),
    );
    $self->sth('update_next_tmp',
        $db->prepare(
            join('',
                'UPDATE ',
                $self->table_name_meta,
                ' SET next_tmp_id = ?',
                ' WHERE key = 1',
            ),
        )
    );

    $self->init(\%args); # in case any subclass needs initialization

    map {
        if (not $self->can($_)) {
            my $ref = ref $self;
            confess("$ref can't '->$_'\n");
        }
        $self->$_($args{$_});
    } keys %args;

    return $self;
}

sub run {
    my ($class) = @_;

    my $tdlist = $class->new();
    my $filename = $tdlist->raw_filename;
    my $dbfile = $tdlist->dbdname;
    STDOUT->autoflush(1);

    if ($ARGV[0]) {
        if ($ARGV[0] eq 'AGA') {
            my $url = $tdlist->url;
            print "Updating $dbfile from AGA ($url)\n";
            $tdlist->update_from_AGA();
            exit;
        }
        $filename = $ARGV[0] if (-f $ARGV[0]);
    }
    print "Updating $dbfile from file ($filename)\n";
    $tdlist->update_from_file($filename);
}

# stub for subclass to override
sub init {
    my ($self) = @_;
}

sub verbose {
    my ($self, $new) = @_;

    if (@_ > 1) {
        $self->{verbose} = $new;
    }

    return $self->{verbose};
}

sub raw_filename {
    my ($self, $new) = @_;

    if (@_ > 1) {
        $self->{raw_filename} = $new;
    }

    return $self->{raw_filename};
}

sub dbdname {
    my ($self, $new) = @_;

    if (@_ > 1) {
        $self->{dbdname} = $new;
    }

    return $self->{dbdname};
}

sub table_name {
    my ($self, $new) = @_;

    if (@_ > 1) {
        $self->{table_name} = $new;
    }

    return quotemeta $self->{table_name};
}

sub table_name_meta {
    my ($self) = @_;

    return $self->table_name . '_meta';
}

sub url {
    my ($self, $new) = @_;

    if (@_ > 1) {
        $self->{url} = $new;
    }

    return $self->{url};
}

sub background {
    my ($self, $new) = @_;

    if (@_ > 1) {
        $self->{background} = $new;
    }

    return $self->{background};
}

sub max_update_errors {
    my ($self, $new) = @_;

    if (@_ > 1) {
        $self->{max_update_errors} = $new;
    }

    return $self->{max_update_errors};
}

sub extra_columns_callback {
    my ($self, @new) = @_;

    if (@_ > 1) {
        if (ref $new[0] ne 'CODE') {
            croak("Must set a code-ref in extra_columns_callback\n");
        }
        $self->{extra_columns_callback} = $new[0];
    }
    return $self->{extra_columns_callback};
}

sub extra_columns {
    my ($self, @new) = @_;

    if (@_ > 1) {
        if (ref $new[0] eq 'ARRAY') {
            $self->{extra_columns} = $new[0];
        }
        else {
            $self->{extra_columns} = \@new;
        }
    }
    return wantarray ? @{$self->{extra_columns}} : $self->{extra_columns};
}

sub db {
    my ($self, $new) = @_;

    if (@_ > 1) {
        if (not $new) {
            if (my $fname = $self->dbdname) {
                $new = DBI->connect(          # connect to your database, create if needed
                    "dbi:SQLite:dbname=$fname", # DSN: dbi, driver, database file
                    "",                          # no user
                    "",                          # no password
                    {
                        AutoCommit => 1,
                        RaiseError => 1,         # complain if something goes wrong
                    },
                )
            }
            else {
                croak("No dbdname for SQLite file\n");
            }
        }
        $self->{db} = $new;
        $self->_db_schema();   # make sure table exists
    }

    return $self->{db};
}

# library of statement handles
sub sth {
    my ($self, $name, $new) = @_;

    croak("Statement handle name is required\n") if (not $name);
    if (@_ > 2) {
        $self->{sth}{$name} = $new;
    }

    my $sth = $self->{sth}{$name};
    croak("No statement handle called '$name'\n") if (not $sth);

    return $sth;
}

sub _db_schema {
    my ($self) = @_;

    $self->db->do(
        join('',
            'CREATE TABLE IF NOT EXISTS ',
            $self->table_name,
            ' (',
                $self->sql_column_types,
            ' )',
        ),
    );

    $self->db->do(join '',
        'CREATE TABLE IF NOT EXISTS ',
        $self->table_name_meta,
        ' (',
            'key         INTEGER PRIMARY KEY, ',
            'update_time VARCHAR(12), ',
            'next_tmp_id VARCHAR(12)',
        ' )',
    );

    $self->db->do(join '',
        'INSERT OR IGNORE INTO ',
        $self->table_name_meta,
        ' (',
            'key, ',
            'update_time, ',
            'next_tmp_id',
        ' ) VALUES ( 1, 0, 1 )',
    );
}

sub update_time {
    my ($self, $new) = @_;

    if (@_ > 1) {
        $self->sth('update_time')->execute($new);
    }
    $self->sth('select_time')->execute();
    my $time = $self->sth('select_time')->fetchall_arrayref();
    $time = $time->[0][0];
    return $time || 0;
}

sub select_id {
    my ($self, $id) = @_;

    $self->sth('select_id')->execute($id);
    # ID is primary index, so can only be one - fetch into first array
    # element:
    my ($player) = $self->sth('select_id')->fetchall_arrayref;
    $player->[RANK] += 0 if (is_Rating($player->[RANK]));   # numify ratings
    return wantarray
        ? @{$player->[0]}
        : $player->[0];
}

sub insert_player {
    my ($self, @new) = @_;

    $new[ID] = $self->next_tmp_id(1) if (not $new[ID]);
    $self->sth('insert_player')->execute(@new);
    return wantarray
        ? @new
        : \@new;
}

sub next_tmp_id {
    my ($self, $used) = @_;

    $self->sth('select_next_tmp')->execute;
    my $next_tmp = $self->sth('select_next_tmp')->fetchall_arrayref;
    $next_tmp = $next_tmp->[0][0];
    $next_tmp ||= 1;
    while ($self->select_id("TMP$next_tmp")) {
        $next_tmp++
    }

    if ($used) {    # is the caller planning on allocating this one?
        $self->sth('update_next_tmp')->execute($next_tmp + 1);
    }
    return "TMP$next_tmp";
}

# reap any child zombies from earlier update_from_AGA calls
sub reap {
    my $kid;
    my $reaped = 0;
    do {
        $kid = waitpid(-1, WNOHANG);
        $reaped++ if ($kid > 0);
    } while $kid > 0;
    return $reaped;
}

sub update_from_AGA {
    my ($self) = @_;

    my $pid;
    if ($self->background) {
        $pid = fork;
        die "fork failed: $!\n" if not defined $pid;
    }
    if ($pid) {
        # parent process
        return;
    }

    if (not $self->{ua}) {
        $self->{ua} = LWP::UserAgent->new;
    }

    my $fname = $self->raw_filename;
    print "Starting $fname fetch at ", scalar localtime, "\n" if ($self->verbose);
    $self->{ua}->mirror($self->url, $fname);
    print "... fetch done at ", scalar localtime, "\n" if ($self->verbose);
    my $fh;
    open($fh, '<', $fname)
        or croak("Error opening $fname for reading: $!\n");
    $self->update_from_file($fh);
    close $fh;

    exit if (defined $pid); # exit if this is a spawned child ($pid == 0)
}

sub update_from_file {
    my ($self, $fh) = @_;

    if (not ref $fh) {
        my $fname = $fh;
        $fh = undef;
        if (not open($fh, '<', $fname)) {
            croak("Error opening $fname for reading: $!\n");
        }
    }

    my $parser = Games::Go::AGA::Parse::TDList->new();
    my $verbose = $self->verbose;
    print "Starting database update at ", scalar localtime, "\n" if ($verbose);
    $self->db->do('BEGIN');
    my @errors;
    my $ii = 0;
    while (my $line = <$fh>) {
        if ($verbose) {
            print '.' if (++$ii % 1000 == 0);
            print "\n" if ($ii % 40000 == 0);
        }
        try {   # in case a line crashes, print error but continue
#print "parse $line" if ($verbose);
            $parser->parse($line);
            my $update = $parser->as_array;
            if ($update->[LAST_NAME] or $update->[FIRST_NAME]) {
                push @{$update}, $self->extra_columns_callback->($self, $update);
                if ($update->[ID]) {
                    if ($update->[ID] =~ m/tmp/i) {
                        croak "TMP IDs not allowed in TDList input"
                    }
                }
                else {
                    $self->sth('select_by_name')->execute($update->[LAST_NAME], $update->[FIRST_NAME]);
                    my $players = $self->sth('select_by_name')->fetchall_arrayref;
                    for my $player (@{$players}) {
                        if ($player->[ID] =~ m/tmp/i) {
                            $update->[ID] = $player->[ID];  # already in DB (hope it's the same guy!)
                        }
                    }
                    if (not $update->[ID]) {
                        $update->[ID] = $self->next_tmp_id(1);
                    }
                }
                if ($self->select_id($update->[ID])) {
                    # ID is already in database, do an update
                    $self->sth('update_id')->execute(
                        @{$update},     # new values for all columns
                        $update->[ID],  # player ID (for WHERE condition)
                    );
                }
                else {
                    # ID is not in database, insert new record
                    $self->insert_player(@{$update});
                }
            }
        }
        catch {
            push @errors, $_;
            print $_ if ($verbose);
        };
        if (@errors >= $self->max_update_errors) {
            push @errors, "Too many errors - aborting\n";
            last;
        }
    }
    $self->db->do('COMMIT');  # make sure we do this!
    $self->update_time(time);
    if (@errors > 1) {
        unshift @errors, scalar @errors . " errors during update:\n";
    }
    croak(join "\n", @errors) if(@errors);
}

# sql columns (without column types)
sub sql_columns {
    my ($self, $joiner) = @_;

    $joiner = ', ' if (not defined $joiner);
    return join($joiner,
        map({ keys %{$_} }
            @columns,
            $self->extra_columns,
        ),
    );
}

# sql columns with column types
sub sql_column_types {
    my ($self, $joiner) = @_;

    $joiner = ', ' if (not defined $joiner);

    return join($joiner,
        map({join ' ', each %{$_}}
            @columns,
            $self->extra_columns,
        ),
    );
}

# '?, ' place-holder question marks for each column,
#    appropriate for an UPDATE or INSERT query
sub sql_update_qs {
    my ($self, $joiner) = @_;

    $joiner = ', ' if (not defined $joiner);

    return join($joiner,
        map({ (keys(%{$_}))[0] . ' = ?' }
            @columns,
            $self->extra_columns,
        ),
    );
}

# place-holder question marks for each column,
#    appropriate for an INSERT query
sub sql_insert_qs {
    my ($self, $joiner) = @_;

    $joiner = ', ' if (not defined $joiner);

    return join($joiner,
        map({ '?' }     # one question mark per column
            @columns,
            $self->extra_columns,
        ),
    );
}

1;

__END__