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 &dumptab_head &dumptab_row_hashref
50 &db_chkcommit &db_check_referential_integrity);
56 sub dbr_filename ($$) {
57 my ($datadir,$oceanname) = @_;
58 return "$datadir/OCEAN-$oceanname.db";
60 sub dbr_connect ($$) {
61 my ($datadir,$ocean) = @_;
62 return db_connect_core(dbr_filename($datadir,$ocean));
65 sub db_connect_core ($) {
67 my $h= DBI->connect("dbi:SQLite:$fn",'','',
69 RaiseError=>1, ShowErrorStatement=>1,
71 or die "$fn $DBI::errstr ?";
73 # default timeout is 30s which is plenty
81 $dbfn= dbr_filename('.',$oceanname);
87 sub db_onconflict (&) {
88 my ($conflictproc) = @_;
89 $dbh->{HandleError}= sub {
90 my ($emsg,$dbh,$val1) = @_;
91 my $native_ecode= $dbh->err();
92 &$conflictproc($emsg) if grep { $_ == $native_ecode } qw(5 6);
93 # 5==SQLITE_BUSY, 6==SQLITE_LOCKED according to the SQLite3
94 # API documentation, .../capi3ref.html#extended-result-codes.
95 return 0; # RaiseError happens next.
102 my $lockfn= "Writer.lock";
103 $writerlockh= new IO::File "$lockfn", "w" or die "$lockfn $!";
105 my $flockall= pack 's!s!LLLLLL', F_WRLCK, SEEK_SET, 0,0,0,0,0,0;
106 # should work everywhere to lock the whole file, provided that
107 # l_type and l_whence are `short int' and come first in that order,
108 # and that start, len and pid are no more than 64 bits each.
110 my $r= fcntl($writerlockh, F_SETLKW, $flockall);
111 $r or die "$lockfn fcntl $!";
115 $dbh= db_connect_core($dbfn);
119 foreach my $cmd (split /\;/, $_[0]) {
120 $dbh->do("$cmd;") if $cmd =~ m/\S/;
124 #---------- table dump helper ----------
126 sub dumptab_head ($$$) {
127 my ($fh,$w,$cols) = @_;
128 printf $fh "|%-${w}s", $_ foreach @$cols; print $fh "|\n";
129 print $fh "+",('-'x$w) foreach @$cols; print $fh "+\n";
132 sub dumptab_row_hashref ($$$$) {
133 my ($fh,$w,$cols,$row) = @_;
134 printf $fh "|%-$w.${w}s",
135 (defined $row->{$_} ? $row->{$_} : 'NULL')
140 #---------- referential integrity constraints ----------
142 # SQLite doesn't support foreign key constraints so we do it by steam:
148 foreach my $stmt (split /\;/, $stmts) {
149 next unless $stmt =~ /\S/;
152 $stmt =~ s/^([ \t]*\#.*)$/ $etxt .= $1."\n"; ''; /mge;
153 $etxt= $letxt unless length $etxt;
156 $stmt =~ s/^\s+//; $stmt =~ s/\s+$//;
157 my $sth= $dbh->prepare($stmt);
161 my @cols= @{ $sth->{NAME_lc} };
163 while ($row= $sth->fetchrow_hashref) {
165 print STDERR "REFERENTIAL INTEGRITY ERROR\n";
166 print STDERR "\n$etxt\n $stmt\n\n";
167 dumptab_head(\*STDERR,$w,\@cols);
169 if ($ecount>5) { print STDERR "...\n"; last; }
170 dumptab_row_hashref(\*STDERR,$w,\@cols,$row);
177 die "REFERENTIAL INTEGRITY ERRORS $ekindcount\n"
181 sub db_check_referential_integrity ($) {
183 # non-full is done only for market data updates; it avoids
184 # detecting errors which are essentially missing metadata and
187 foreach my $bs (qw(buy sell)) {
190 # Every buy/sell must refer to an entry in commods, islands, and stalls:
191 SELECT * FROM $bs NATURAL LEFT JOIN commods WHERE commodname IS NULL;
192 SELECT * FROM $bs NATURAL LEFT JOIN islands WHERE islandname IS NULL;
193 SELECT * FROM $bs LEFT JOIN STALLS USING (stallid) WHERE stallname IS NULL;
195 # Every buy/sell must be part of an upload:
196 SELECT * FROM $bs NATURAL LEFT JOIN uploads WHERE timestamp IS NULL;
198 # The islandid in stalls must be the same as the islandid in buy/sell:
199 SELECT * FROM $bs JOIN stalls USING (stallid)
200 WHERE $bs.islandid != stalls.islandid;
207 # Every stall and upload must refer to an island:
208 SELECT * FROM stalls NATURAL LEFT JOIN islands WHERE islandname IS NULL;
209 SELECT * FROM uploads NATURAL LEFT JOIN islands WHERE islandname IS NULL;
213 foreach my $end (qw(aiid biid)) {
214 foreach my $tab (qw(dists routes)) {
217 # Every row in dists and routes must refer to two existing rows in islands:
218 SELECT * FROM $tab d LEFT JOIN islands ON d.$end=islandid
219 WHERE islandname IS NULL;
226 # Every pair of islands must have an entry in dists:
227 SELECT * FROM islands ia JOIN islands ib LEFT JOIN dists
228 ON ia.islandid=aiid and ib.islandid=biid
231 # Every commod must refers to a commodclass and vice versa:
232 SELECT * FROM commods NATURAL LEFT JOIN commodclasses
233 WHERE commodclass IS NULL;
234 SELECT * FROM commodclasses NATURAL LEFT JOIN commods
235 WHERE commodname IS NULL;
237 # Ordvals which are not commodclass ordvals are unique:
238 SELECT ordval,count(*),commodname,commodid,posinclass
244 # For every class, posinclass is dense from 1 to maxposinclass,
245 # apart from the commods for which it is zero.
246 SELECT commodclass,commodclassid,posinclass,count(*)
247 FROM commods NATURAL JOIN commodclasses
249 GROUP BY commodclassid,posinclass
251 SELECT commodclass,commodclassid,count(*)
252 FROM commods NATURAL JOIN commodclasses
254 GROUP BY commodclassid
255 HAVING count(*) != maxposinclass;
257 FROM commods NATURAL JOIN commodclasses
258 WHERE posinclass < 0 OR posinclass > maxposinclass;
264 sub db_chkcommit ($) {
266 db_check_referential_integrity($full);