1 # This is part of ypp-sc-tools, a set of third-party tools for assisting
2 # players of Yohoho Puzzle Pirates.
4 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
6 # This program is free software: you can redistribute it and/or modify
7 # it under the terms of the GNU General Public License as published by
8 # the Free Software Foundation, either version 3 of the License, or
9 # (at your option) any later version.
11 # This program is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU General Public License for more details.
16 # You should have received a copy of the GNU General Public License
17 # along with this program. If not, see <http://www.gnu.org/licenses/>.
19 # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
20 # are used without permission. This program is not endorsed or
21 # sponsored by Three Rings.
23 package CommodsDatabase;
25 # Valid calling sequences:
26 # db_setocean('Midnight')
27 # [ db_filename() => 'OCEAN-Midnight.db' also OK at any later time ]
28 # [ db_writer() ] helpful but not essential
30 # [ db_onconflict(sub { .... }) ] essential if just dieing is not OK
31 # $dbh->do(...), $dbh->prepare(...), db_doall("stmt;stmt;"), etc.
43 our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
46 @EXPORT = qw(&db_setocean &db_writer &db_connect $dbh
47 &db_filename &db_doall &db_onconflict
48 &dbr_filename &dbr_connect &db_connect_core
49 &db_chkcommit &db_check_referential_integrity);
55 sub dbr_filename ($$) {
56 my ($datadir,$oceanname) = @_;
57 return "$datadir/OCEAN-$oceanname.db";
59 sub dbr_connect ($$) {
60 my ($datadir,$ocean) = @_;
61 return db_connect_core(dbr_filename($datadir,$ocean));
64 sub db_connect_core ($) {
66 my $h= DBI->connect("dbi:SQLite:$fn",'','',
68 RaiseError=>1, ShowErrorStatement=>1,
70 or die "$fn $DBI::errstr ?";
72 # default timeout is 30s which is plenty
80 $dbfn= dbr_filename('.',$oceanname);
86 sub db_onconflict (&) {
87 my ($conflictproc) = @_;
88 $dbh->{HandleError}= sub {
89 my ($emsg,$dbh,$val1) = @_;
90 my $native_ecode= $dbh->err();
91 &$conflictproc($emsg) if grep { $_ == $native_ecode } qw(5 6);
92 # 5==SQLITE_BUSY, 6==SQLITE_LOCKED according to the SQLite3
93 # API documentation, .../capi3ref.html#extended-result-codes.
94 return 0; # RaiseError happens next.
101 my $lockfn= "Writer.lock";
102 $writerlockh= new IO::File "$lockfn", "w" or die "$lockfn $!";
104 my $flockall= pack 's!s!LLLLLL', F_WRLCK, SEEK_SET, 0,0,0,0,0,0;
105 # should work everywhere to lock the whole file, provided that
106 # l_type and l_whence are `short int' and come first in that order,
107 # and that start, len and pid are no more than 64 bits each.
109 my $r= fcntl($writerlockh, F_SETLKW, $flockall);
110 $r or die "$lockfn fcntl $!";
114 $dbh= db_connect_core($dbfn);
118 foreach my $cmd (split /\;/, $_[0]) {
119 $dbh->do("$cmd;") if $cmd =~ m/\S/;
123 #---------- referential integrity constraints ----------
125 # SQLite doesn't support foreign key constraints so we do it by steam:
131 foreach my $stmt (split /\;/, $stmts) {
132 next unless $stmt =~ /\S/;
135 $stmt =~ s/^([ \t]*\#.*)$/ $etxt .= $1."\n"; ''; /mge;
136 $etxt= $letxt unless length $etxt;
139 $stmt =~ s/^\s+//; $stmt =~ s/\s+$//;
140 my $sth= $dbh->prepare($stmt);
144 my @cols= @{ $sth->{NAME_lc} };
146 while ($row= $sth->fetchrow_hashref) {
148 print STDERR "REFERENTIAL INTEGRITY ERROR\n";
149 print STDERR "\n$etxt\n $stmt\n\n";
150 printf STDERR "|%-${w}s", $_ foreach @cols; print STDERR "|\n";
151 print STDERR "+",('-'x$w) foreach @cols; print STDERR "+\n";
153 if ($ecount>5) { print STDERR "...\n"; last; }
154 printf STDERR "|%-$w.${w}s",
155 (defined $row->{$_} ? $row->{$_} : 'NULL')
164 die "REFERENTIAL INTEGRITY ERRORS $ekindcount\n"
168 sub db_check_referential_integrity () {
169 foreach my $bs (qw(buy sell)) {
172 # Every buy/sell must refer to an entry in commods, islands, and stalls:
173 SELECT * FROM $bs NATURAL LEFT JOIN commods WHERE commodname IS NULL;
174 SELECT * FROM $bs NATURAL LEFT JOIN islands WHERE islandname IS NULL;
175 SELECT * FROM $bs LEFT JOIN STALLS USING (stallid) WHERE stallname IS NULL;
177 # Every buy/sell must be part of an upload:
178 SELECT * FROM $bs NATURAL LEFT JOIN uploads WHERE timestamp IS NULL;
180 # The islandid in stalls must be the same as the islandid in buy/sell:
181 SELECT * FROM $bs JOIN stalls USING (stallid)
182 WHERE $bs.islandid != stalls.islandid;
186 foreach my $end (qw(aiid biid)) {
187 foreach my $tab (qw(dists routes)) {
190 # Every row in dists and routes must refer to two existing rows in islands:
191 SELECT * FROM $tab d LEFT JOIN islands ON (d.$end=islandid)
192 WHERE islandname IS NULL;
199 # Every pair of islands must have an entry in dists:
200 SELECT * FROM islands ia JOIN islands ib LEFT JOIN dists
201 ON (ia.islandid=aiid and ib.islandid=biid)
204 # Every stall and upload must refer to an island:
205 SELECT * FROM stalls NATURAL LEFT JOIN islands WHERE islandname IS NULL;
206 SELECT * FROM uploads NATURAL LEFT JOIN islands WHERE islandname IS NULL;
208 # Every commod which refers to a commodclass refers to an existing one:
209 SELECT * FROM commods WHERE commodclass NOT IN
210 (SELECT commodclass FROM commodclasses);
212 # There are no empty commodclasses:
213 SELECT * FROM commodclasses NATURAL LEFT JOIN commods
214 WHERE commodname IS NULL;
216 # Ordvals which are not zero are unique:
217 SELECT ordval,count(*) FROM COMMODS
218 WHERE ordval IS NOT NULL AND ordval != 0
225 sub db_chkcommit () {
226 db_check_referential_integrity();