chiark / gitweb /
mention ijackson's repo for jpctb-linkfarmer
[ypp-sc-tools.db-live.git] / yarrg / CommodsDatabase.pm
index 4866c855d3baacccc7c29ae754a60415169672d6..3cb543dc43b3866971cff2cb28e39de7f6061631 100644 (file)
 
 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;
 
@@ -34,30 +43,76 @@ BEGIN {
     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
     $VERSION     = 1.00;
     @ISA         = qw(Exporter);
-    @EXPORT      = qw(&db_setocean &db_connect $dbh
-                     &db_filename &db_doall);
+    @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= "OCEAN-$oceanname.db";
+    $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= DBI->connect("dbi:SQLite:$dbfn",'','',
-                      { AutoCommit=>0,
-                        RaiseError=>1, ShowErrorStatement=>1,
-                        unicode=>1 })
-       or die "$dbfn $DBI::errstr ?";
+    $dbh= db_connect_core($dbfn);
 }
 
 sub db_doall ($) {
@@ -66,4 +121,150 @@ sub db_doall ($) {
     }
 }
 
+#---------- 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(<<END);
+
+ # Every buy/sell must refer to an entry in commods, islands, and stalls:
+ SELECT * FROM $bs NATURAL LEFT JOIN commods WHERE commodname IS NULL;
+ SELECT * FROM $bs NATURAL LEFT JOIN islands WHERE islandname IS NULL;
+ SELECT * FROM $bs LEFT JOIN STALLS USING (stallid) WHERE stallname IS NULL;
+
+ # Every buy/sell must be part of an upload:
+ SELECT * FROM $bs NATURAL LEFT JOIN uploads WHERE timestamp IS NULL;
+
+ # The islandid in stalls must be the same as the islandid in buy/sell:
+ SELECT * FROM $bs JOIN stalls USING (stallid)
+       WHERE $bs.islandid != stalls.islandid;
+
+END
+    }
+
+    nooutput(<<END);
+
+ # Every stall and upload must refer to an island:
+ SELECT * FROM stalls NATURAL LEFT JOIN islands WHERE islandname IS NULL;
+ SELECT * FROM uploads NATURAL LEFT JOIN islands WHERE islandname IS NULL;
+
+END
+    if ($full) {
+       foreach my $end (qw(aiid biid)) {
+           foreach my $tab (qw(dists routes)) {
+               nooutput(<<END);
+
+ # Every row in dists and routes must refer to two existing rows in islands:
+ SELECT * FROM $tab d LEFT JOIN islands ON d.$end=islandid
+       WHERE islandname IS NULL;
+
+END
+           }
+       }
+       nooutput(<<END);
+
+ # Every pair of islands must have an entry in dists:
+ SELECT * FROM islands ia JOIN islands ib LEFT JOIN dists
+       ON ia.islandid=aiid and ib.islandid=biid
+       WHERE dist IS NULL;
+
+ # Every commod must refers to a commodclass and vice versa:
+ SELECT * FROM commods NATURAL LEFT JOIN commodclasses
+       WHERE commodclass IS NULL;
+ SELECT * FROM commodclasses NATURAL LEFT JOIN commods
+       WHERE commodname IS NULL;
+
+ # Ordvals which are not commodclass ordvals are unique:
+ SELECT ordval,count(*),commodname,commodid,posinclass
+       FROM commods
+       WHERE posinclass > 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 NATURAL JOIN commodclasses
+       WHERE posinclass > 0
+       GROUP BY commodclassid,posinclass
+       HAVING count(*) > 1;
+ SELECT commodclass,commodclassid,count(*)
+       FROM commods NATURAL JOIN commodclasses
+       WHERE posinclass > 0
+       GROUP BY commodclassid
+       HAVING count(*) != maxposinclass;
+ SELECT *
+       FROM commods NATURAL JOIN commodclasses
+       WHERE posinclass < 0 OR posinclass > maxposinclass;
+
+END
+    }
+}
+
+sub db_chkcommit ($) {
+    my ($full) = @_;
+    db_check_referential_integrity($full);
+    $dbh->commit();
+}
+
 1;