@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);
+ &dbr_filename &dbr_connect &db_connect_core
+ &db_chkcommit &db_check_referential_integrity);
%EXPORT_TAGS = ( );
@EXPORT_OK = qw();
}
}
+#---------- 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";
+ printf STDERR "|%-${w}s", $_ foreach @cols; print STDERR "|\n";
+ print STDERR "+",('-'x$w) foreach @cols; print STDERR "+\n";
+ }
+ if ($ecount>5) { print STDERR "...\n"; last; }
+ printf STDERR "|%-$w.${w}s",
+ (defined $row->{$_} ? $row->{$_} : 'NULL')
+ foreach @cols;
+ print STDERR "\n";
+ }
+ next unless $ecount;
+
+ $ekindcount++;
+ print STDERR "\n\n";
+ }
+ die "REFERENTIAL INTEGRITY ERRORS $ekindcount\n"
+ if $ekindcount;
+}
+
+sub db_check_referential_integrity () {
+ 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
+ }
+ 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 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;
+
+ # Every commod which refers to a commodclass refers to an existing one:
+ SELECT * FROM commods WHERE commodclass NOT IN
+ (SELECT commodclass FROM commodclasses);
+
+ # There are no empty commodclasses:
+ SELECT * FROM commodclasses NATURAL LEFT JOIN commods
+ WHERE commodname IS NULL;
+
+ # Ordvals which are not zero are unique:
+ SELECT ordval,count(*) FROM COMMODS
+ WHERE ordval IS NOT NULL AND ordval != 0
+ GROUP BY ordval
+ HAVING count(*) > 1;
+
+END
+}
+
+sub db_chkcommit () {
+ db_check_referential_integrity();
+ $dbh->commit();
+}
+
1;
$dbh->trace(1) if $trace;
-#---------- 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";
- printf STDERR "|%-${w}s", $_ foreach @cols; print STDERR "|\n";
- print STDERR "+",('-'x$w) foreach @cols; print STDERR "+\n";
- }
- if ($ecount>5) { print STDERR "...\n"; last; }
- printf STDERR "|%-$w.${w}s",
- (defined $row->{$_} ? $row->{$_} : 'NULL')
- foreach @cols;
- print STDERR "\n";
- }
- next unless $ecount;
-
- $ekindcount++;
- print STDERR "\n\n";
- }
- die "REFERENTIAL INTEGRITY ERRORS $ekindcount\n"
- if $ekindcount;
-}
-
-sub check_referential_integrity () {
- 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
- }
- 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 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;
-
- # Every commod which refers to a commodclass refers to an existing one:
- SELECT * FROM commods WHERE commodclass NOT IN
- (SELECT commodclass FROM commodclasses);
-
- # There are no empty commodclasses:
- SELECT * FROM commodclasses NATURAL LEFT JOIN commods
- WHERE commodname IS NULL;
-
- # Ordvals which are not zero are unique:
- SELECT ordval,count(*) FROM COMMODS
- WHERE ordval IS NOT NULL AND ordval != 0
- GROUP BY ordval
- HAVING count(*) > 1;
-
-END
-}
-
-sub chkcommit () {
- check_referential_integrity();
- $dbh->commit();
-}
-
#---------- schema ----------
foreach my $bs (qw(buy sell)) {
END
;
-chkcommit();
+db_chkcommit();
#---------- commodity list ----------
foreach my $cl (sort keys %incl) {
$addclass->execute($cl, $incl{$cl});
}
- chkcommit();
+ db_chkcommit();
}
#---------- vessel types ----------
my @qa= ($name, $shotdamage, map { $v->{$_} } qw(Mass Volume));
$idempotent->execute(@qa);
}
- chkcommit();
+ db_chkcommit();
}