# This is part of ypp-sc-tools, a set of third-party tools for assisting # players of Yohoho Puzzle Pirates. # # Copyright (C) 2009 Ian Jackson # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation, either version 3 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program. If not, see . # # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and # are used without permission. This program is not endorsed or # sponsored by Three Rings. package CommodsDatabase; # Valid calling sequences: # db_setocean('Midnight') # [ db_filename() => 'OCEAN-Midnight.db' also OK at any later time ] # [ db_writer() ] helpful but not essential # db_connect() # [ db_onconflict(sub { .... }) ] essential if just dieing is not OK # $dbh->do(...), $dbh->prepare(...), db_doall("stmt;stmt;"), etc. use strict; use warnings; use DBI; use POSIX; use Commods; BEGIN { use Exporter (); our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); $VERSION = 1.00; @ISA = qw(Exporter); @EXPORT = qw(&db_setocean &db_writer &db_connect $dbh &db_filename &db_doall &db_onconflict &dbr_filename &dbr_connect &db_connect_core &dumptab_head &dumptab_row_hashref &db_chkcommit &db_check_referential_integrity); %EXPORT_TAGS = ( ); @EXPORT_OK = qw(); } sub dbr_filename ($$) { my ($datadir,$oceanname) = @_; return "$datadir/OCEAN-$oceanname.db"; } sub dbr_connect ($$) { my ($datadir,$ocean) = @_; return db_connect_core(dbr_filename($datadir,$ocean)); } sub db_connect_core ($) { my ($fn)= @_; my $h= DBI->connect("dbi:SQLite:$fn",'','', { AutoCommit=>0, RaiseError=>1, ShowErrorStatement=>1, unicode=>1 }) or die "$fn $DBI::errstr ?"; return $h; # default timeout is 30s which is plenty } our $dbfn; our $dbh; sub db_setocean ($) { my ($oceanname) = @_; $dbfn= dbr_filename('.',$oceanname); } sub db_filename () { return $dbfn; } sub db_onconflict (&) { my ($conflictproc) = @_; $dbh->{HandleError}= sub { my ($emsg,$dbh,$val1) = @_; my $native_ecode= $dbh->err(); &$conflictproc($emsg) if grep { $_ == $native_ecode } qw(5 6); # 5==SQLITE_BUSY, 6==SQLITE_LOCKED according to the SQLite3 # API documentation, .../capi3ref.html#extended-result-codes. return 0; # RaiseError happens next. }; } our $writerlockh; sub db_writer () { my $lockfn= "Writer.lock"; $writerlockh= new IO::File "$lockfn", "w" or die "$lockfn $!"; my $flockall= pack 's!s!LLLLLL', F_WRLCK, SEEK_SET, 0,0,0,0,0,0; # should work everywhere to lock the whole file, provided that # l_type and l_whence are `short int' and come first in that order, # and that start, len and pid are no more than 64 bits each. my $r= fcntl($writerlockh, F_SETLKW, $flockall); $r or die "$lockfn fcntl $!"; } sub db_connect () { $dbh= db_connect_core($dbfn); } sub db_doall ($) { foreach my $cmd (split /\;/, $_[0]) { $dbh->do("$cmd;") if $cmd =~ m/\S/; } } #---------- table dump helper ---------- sub dumptab_head ($$$) { my ($fh,$w,$cols) = @_; printf $fh "|%-${w}s", $_ foreach @$cols; print $fh "|\n"; print $fh "+",('-'x$w) foreach @$cols; print $fh "+\n"; } sub dumptab_row_hashref ($$$$) { my ($fh,$w,$cols,$row) = @_; printf $fh "|%-$w.${w}s", (defined $row->{$_} ? $row->{$_} : 'NULL') foreach @$cols; print $fh "\n"; } #---------- referential integrity constraints ---------- # SQLite doesn't support foreign key constraints so we do it by steam: sub nooutput ($) { my ($stmts) = @_; my $ekindcount= 0; my $letxt= ''; foreach my $stmt (split /\;/, $stmts) { next unless $stmt =~ /\S/; my $etxt= ''; $stmt =~ s/^([ \t]*\#.*)$/ $etxt .= $1."\n"; ''; /mge; $etxt= $letxt unless length $etxt; $letxt= $etxt; $stmt =~ s/^\s+//; $stmt =~ s/\s+$//; my $sth= $dbh->prepare($stmt); $sth->execute(); my $row; my $ecount= 0; my @cols= @{ $sth->{NAME_lc} }; my $w= 11; while ($row= $sth->fetchrow_hashref) { if (!$ecount++) { print STDERR "REFERENTIAL INTEGRITY ERROR\n"; print STDERR "\n$etxt\n $stmt\n\n"; dumptab_head(\*STDERR,$w,\@cols); } if ($ecount>5) { print STDERR "...\n"; last; } dumptab_row_hashref(\*STDERR,$w,\@cols,$row); } next unless $ecount; $ekindcount++; print STDERR "\n\n"; } die "REFERENTIAL INTEGRITY ERRORS $ekindcount\n" if $ekindcount; } sub db_check_referential_integrity ($) { my ($full) = @_; # non-full is done only for market data updates; it avoids # detecting errors which are essentially missing metadata and # old schemas, etc. foreach my $bs (qw(buy sell)) { nooutput(< 0 GROUP BY ordval HAVING count(*) > 1; # For every class, posinclass is dense from 1 to maxposinclass, # apart from the commods for which it is zero. SELECT commodclass,commodclassid,posinclass,count(*) FROM commods JOIN commodclasses USING (commodclassid) WHERE posinclass > 0 GROUP BY commodclassid,posinclass HAVING count(*) > 1; SELECT commodclass,commodclassid,count(*) FROM commods JOIN commodclasses USING (commodclassid) WHERE posinclass > 0 GROUP BY commodclassid HAVING count(*) != maxposinclass; SELECT * FROM commods JOIN commodclasses USING (commodclassid) WHERE posinclass < 0 OR posinclass > maxposinclass; END } } sub db_chkcommit ($) { my ($full) = @_; db_check_referential_integrity($full); $dbh->commit(); } 1;