File Coverage

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

Criterion	Covered	Total	%
statement	242	323	74.9
branch	71	134	52.9
condition	5	15	33.3
subroutine	43	51	84.3
pod	24	32	75.0
total	385	555	69.3

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

use 5.010;
use strict;
use warnings;

package Games::Go::AGA::TDListDB;

use open qw( :utf8 :std );  # UTF8 for all files and STDIO
use IO::Handle;     # for autoflush
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 );
use Readonly;

our $VERSION = '0.048'; # VERSION

Readonly my $BUF_MAX  => 4096;

# list the names of the default database field index subroutines, in order
my @_column_names = (qw(
    last_name
    first_name
    id
    membership
    rank
    date
    club
    state
    extra
));
my %_column_idx = (
    last_name  => 0,
    first_name => 1,
    id         => 2,
    membership => 3,
    rank       => 4,
    date       => 5,
    club       => 6,
    state      => 7,
    extra      => 8,
);

# list of default column names
sub column_idx {
    my ($self, $which) = @_;

    if (@_ >= 2) {
        return $_column_idx{lc $which};
    }
    return wantarray
        ?  @_column_names
        : \@_column_names;
}

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

my $usage = qq(

TDListDB [ -tdlist_file filename ] [ -sqlite_file filename ]
         [ -url url | AGA ] [ -verbose ] [ -help ]

Options may be abbreviated to their first letter.

By default, TDListDB.pm updates from a file in the current
directory named TDList.txt.  Specify -tdlist_file to update
from a different file, or specify -url to update from a
website.  -url AGA updates from the usual AGA website at
    https://www.usgo.org/ratings/TDListN.txt

);

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

    require Getopt::Long;
    Getopt::Long->import(qw( :config pass_through ));

    my $verbose;
    my $url;
    exit 0 if (not GetOptions(
        'tdlist_file=s', => \$pre_defaults{raw_filename},   # update from file
        'sqlite_file=s', => \$pre_defaults{dbdname},        # sqlite file
        'url=s',         => \$url,                          # URL to update from
        'verbose',       => \$verbose,
        'help'           => sub { print $usage; exit 0; },
    ));

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

    if ($url) {
        if (uc $url ne 'AGA') {
            $tdlist->url($url);
        }
        $url = $tdlist->url;
        print "Updating $dbfile from AGA ($url)\n";
        $tdlist->update_from_AGA();
        exit;
    }
    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') {
            $self->my_print("Must set a code-ref in extra_columns_callback\n");
            die;
        }
        $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 {
                $self->my_print("No dbdname for SQLite file\n");
                die;
            }
        }
        $self->{db} = $new;
        $self->_db_schema();   # make sure table exists
    }

    return $self->{db};
}

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

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

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

    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->[$self->column_idx('rank')] += 0 if (is_Rating($player->[$self->column_idx('rank')]));   # numify ratings
    return wantarray
        ? @{$player->[0]}
        : $player->[0];
}

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

    $new[$self->column_idx('id')] = $self->next_tmp_id(1) if (not $new[$self->column_idx('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;
    my $url = $self->url;
    $self->my_print("Starting $fname fetch from $url at ", scalar localtime, "\n") if ($self->verbose);
    $self->{ua}->mirror($url, $fname);
    $self->my_print("... fetch done at ", scalar localtime, "\n") if ($self->verbose);
    $self->update_from_file($fname);

    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)) {
            $self->my_print("Error opening $fname for reading: $!\n");
            die;
        }
    }
    $self->fh($fh);

    my $parser = Games::Go::AGA::Parse::TDList->new();
    my $verbose = $self->verbose;
    $self->my_print("Starting database update at ", scalar localtime, "\n") if ($verbose);
    $self->db->do('BEGIN');
    my $error_count = 0;
    my $ii = 0;
    my $ID = $self->column_idx('id');
    while (1) {
        $ii++;
        my $line = $self->next_line;
        last if (not defined $line);
        next if (not $line);

        if ($verbose) {
            $self->my_print('.')  if ($ii % 1000 == 0);
            $self->my_print("\n") if ($ii % 40000 == 0);
        }
        try {   # in case a line crashes, print error but continue
#$self->my_print("parse $line") if ($verbose);
            $parser->parse($line);
            my $update = $parser->as_array;
            if ($update->[$self->column_idx('last_name')] or $update->[$self->column_idx('first_name')]) {
                push @{$update}, $self->extra_columns_callback->($self, $update);
                if ($update->[$ID]) {
                    if ($update->[$ID] =~ m/tmp/i) {
                        die "TMP IDs not allowed in TDList input";
                    }
                }
                else {
                    $self->sth('select_by_name')->execute($update->[$self->column_idx('last_name')], $update->[$self->column_idx('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});
                }
            }
            else {
                die "no name parsed from $line";
            }
        }
        catch {
            $error_count++;
            my $error = $_;
            $self->my_print("Error at line $ii: $error");
        };
        if ($error_count >= $self->max_update_errors) {
            $self->my_print("$error_count errors - aborting\n");
            last;
        }
    }
    $self->db->do('COMMIT');  # make sure we do this!
    $self->update_time(time);
}

# file might not have lines.  enforce lines here
sub next_line {
    my ($self) = @_;

    my $offset = $self->{buf_offset};
    if ($self->{buf_end} - $offset <= 160) {
        $self->get_fh_chunk;
        $offset = $self->{buf_offset};
    }
    return if ($offset >= $self->{buf_end});
    my $eol_idx;
    if ($self->{has_lines}) {
        $eol_idx = index($self->{buf}, "\n", $offset);
        if ($eol_idx < 0) {
            die "no EOL";       # shouldn't happen
        }
    }
    else {
        # assume 80 characters per line
        $eol_idx = $offset + 80;
        # but not past the end of the buffer
        $eol_idx = $self->{buf_end} if ($eol_idx > $self->{buf_end});
        $eol_idx--;
    }
    my $len = $eol_idx - $offset;
    my $line = substr $self->{buf}, $offset, $len;
    $self->{buf_offset} += $len + 1;
    return $line;
}

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

    if (@_ > 1) {
        $self->{fh} = $new;
        delete $self->{has_lines};
        if ($new and ref $new) {
            $self->{buf} = '';
            $self->{buf_offset} = $self->{buf_end} = 0;
            $self->get_fh_chunk;
            $self->{has_lines} = (index($self->{buf}, "\n") >= 0);
        }
    }
    return $self->{fh};
}

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

    # how much is still left?
    my $left = $self->{buf_end} - $self->{buf_offset};
    # shift unused part of buf down to the beginning
    substr($self->{buf}, 0, $self->{buf_offset}, '');
    # read in a new chunk
    my $new = read $self->fh, $self->{buf}, $BUF_MAX - $left, $left;
    if (not defined $new) {
        die "Read error: $!";
    }
    $self->{buf_end} = $left + $new;
    $self->{buf_offset} = 0;
}

# 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,
        ),
    );
}

sub my_print {
    my $self = shift;

    $self->print_cb->(@_);
}

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

    $self->{print_cb} = $new if (@_ > 1);
    return $self->{print_cb} || sub { print @_ };
}

1;

__END__