chiark / gitweb /
Merge branch 'stable-5.x' into web
authorIan Jackson <ijackson@chiark.greenend.org.uk>
Thu, 5 Nov 2009 16:33:19 +0000 (16:33 +0000)
committerIan Jackson <Ian.Jackson@eu.citrix.com>
Thu, 5 Nov 2009 16:33:19 +0000 (16:33 +0000)
yarrg/Commods.pm
yarrg/CommodsDatabase.pm
yarrg/TODO
yarrg/commod-email-processor
yarrg/commod-results-processor
yarrg/commod-update-receiver
yarrg/db-idempotent-populate
yarrg/devel-notes
yarrg/source-info.txt
yarrg/update-master-info
yarrg/yppedia-chart-parser

index e63126a..9178112 100644 (file)
@@ -37,10 +37,10 @@ BEGIN {
     @ISA         = qw(Exporter);
     @EXPORT      = qw(&parse_info_clientside &fetch_with_rsync
                      &parse_info_serverside &parse_info_serverside_ocean
-                     %oceans %commods %clients
+                     %oceans %commods %clients %commodclasses
                      %vessels %shotname2damage
                      &parse_pctb_commodmap %pctb_commodmap @pctb_commodmap
-                     &get_our_version &check_tsv_line
+                     &get_our_version &check_tsv_line &errsan
                      &pipethrough_prep &pipethrough_run
                      &pipethrough_run_along &pipethrough_run_finish
                      &pipethrough_run_gzip &http_useragent &version_core
@@ -94,12 +94,16 @@ our %commods;
 # eg $commods{'Fine black cloth'}{Srcs}= $sources;
 # eg $commods{'Fine black cloth'}{Mass}= 700 [g]
 # eg $commods{'Fine black cloth'}{Volume}= 1000 [ml]
+# eg $commods{'Fine black cloth'}{Ordval}= 203921
 
 our (%pctb_commodmap,@pctb_commodmap);
 
 my %colours; # eg $colours{'c'}{'black'}= $sources
 my (@rawcm, @nocm); # eg $rawcm[0]='fine rum'; $rawcm[1]='fine %c cloth'
 
+my %colour_ordvals; # $colour_ordvals{'c'}{'green'}= '30';
+our %commodclasses; # $commodclasses{'dye'}= '3';
+
 # IMPORTANT
 #  when extending the format of source-info in a non-backward
 #  compatible way, be sure to update update-master-info too.
@@ -118,11 +122,24 @@ sub parse_info1 ($$$) {
        s/\s+$//;
        if (m/^\%(\w+)$/) {
            my $colourkind= $1;
-           @ctx= (sub { $colours{$colourkind}{lc $_} .= $src; });
+           @ctx= (sub {
+               m/^(\S[^\t@]*\S)(?:\t+\@(\d+\+?))?$/ or die "$_ ?";
+               my ($colour,$order)=($1,$2);
+               $colours{$colourkind}{$colour} .= $src;
+               if (defined $order) {
+                   $order =~ s/^(\d+)\+$/ $1  + $. * 10 /e;
+                   $colour_ordvals{$colourkind}{$colour}= $order;
+               }
+           });
        } elsif (m/^commods$/) {
            @ctx= (sub { push @rawcm, lc $_; });
        } elsif (m/^nocommods$/) {
            @ctx= (sub { push @nocm, lc $_; });
+       } elsif (m/^commodclasses$/) {
+           @ctx= (sub {
+               die unless m/^\*([_a-z]+)$/;
+               $commodclasses{$1}= scalar keys %commodclasses;
+           });
        } elsif (m/^ocean (\w+)$/) {
            my $ocean= $1;
            keys %{ $oceans{$ocean} };
@@ -177,36 +194,57 @@ sub parse_info1 ($$$) {
        
     %commods= ();
     my $ca;
+    my $lnoix=0;
     $ca= sub {
-       my ($s,$ss) = @_;
-#print "ca($s)\n";
+       my ($s,$ss,$ordbase) = @_;
+#print STDERR "ca($s,,".(defined $ordbase ? $ordbase : '?').")\n";
        if ($s !~ m/\%(\w+)/) {
            my ($name, $props) = $s =~
-               /^(\S[^\t]*\S)(?:\t+(\S[^\t]*\S))?$/
+               /^(\S[^\t]*\S)(?:\t+(\S.*\S))?$/
                or die "bad commodspec $s";
            return if grep { $name eq $_ } @nocm;
            my $ucname= ucfirst $name;
            $commods{$ucname}{Srcs} .= $ss;
            my $c= $commods{$ucname};
            $c->{Volume}= 1000;
+           my ($ordval, $ordclassval);
            foreach my $prop (defined $props ? split /\s+/, $props : ()) {
                if ($prop =~ m/^([1-9]\d*)(k?)g$/) {
                    $c->{Mass}= $1 * ($2 ? 1000 : 1);
-               } elsif ($prop =~m/^([1-9]\d*)l$/) {
+               } elsif ($prop =~ m/^([1-9]\d*)l$/) {
                    $c->{Volume}= $1 * 1000;
+               } elsif ($prop =~ m/^\*([_a-z]+)$/) {
+                   $c->{Class}= $1;
+                   die "$1" unless exists $commodclasses{$1};
+                   $ordclassval= 1e7 + $commodclasses{$1} * 1e7;
+               } elsif ($prop =~ m/^\@(\d+\+?)$/) {
+                   $ordval= $1;
+                   $ordval =~ s/^(\d+)\+$/ $1 + $lnoix * 10 /e;
                } else {
                    die "unknown property $prop for $ucname";
                }
            }
+           $c->{ClassOrdval}= $ordclassval;
+           if (defined $ordbase && defined $ordval && defined $ordclassval) {
+               my $ordvalout= $ordbase + $ordval + $ordclassval;
+               $c->{Ordval}= $ordvalout;
+#print STDERR "ordval $ordvalout $name OV=$ordval OB=$ordbase OCV=$ordclassval\n";
+           } else {
+#print STDERR "ordval NONE $name\n";
+            }
            return;
        }
        die "unknown $&" unless defined $colours{$1};
        my ($lhs,$pctlet,$rhs)= ($`,$1,$');
        foreach my $c (keys %{ $colours{$pctlet} }) {
-           &$ca($lhs.$c.$rhs, $ss .'%'. $colours{$pctlet}{$c});
+           my $ordcolour= $colour_ordvals{$pctlet}{$c};
+           &$ca($lhs.$c.$rhs,
+                $ss .'%'. $colours{$pctlet}{$c},
+                defined($ordbase) && defined($ordcolour)
+                    ? $ordbase+$ordcolour : undef);
        }
     };
-    foreach (@rawcm) { &$ca($_,$src); }
+    foreach (@rawcm) { $lnoix++; &$ca($_,$src,0); }
 }
 
 sub parse_info_clientside () {
@@ -369,6 +407,12 @@ sub cgipostform ($$$) {
 
 our %check_tsv_done;
 
+sub errsan ($) {
+    my ($value) = @_;
+    $value =~ s/[^-+\'. A-Za-z0-9]/ sprintf "\\x%02x",ord $& /ge;
+    return "\"$value\"";
+}
+
 sub check_tsv_line ($$) {
     my ($l, $bad_data_callback) = @_;
     my $bad_data= sub { &$bad_data_callback("bad data: line $.: $_[0]"); };
@@ -382,15 +426,19 @@ sub check_tsv_line ($$) {
 
     !keys %commods or
        defined $commods{$commod} or
-       &$bad_data("unknown commodity \`$commod'");
+       &$bad_data("unknown commodity ".errsan($commod));
     
-    $stall =~ m/^\p{IsUpper}|^[0-9]/ or &$bad_data("stall not capitalised");
-    !exists $check_tsv_done{$commod,$stall} or &$bad_data("repeated data");
+    $stall =~ m/^\p{IsUpper}|^[0-9]/ or
+       &$bad_data("stall not capitalised ".errsan($stall));
+    !exists $check_tsv_done{$commod,$stall} or
+       &$bad_data("repeated data ".errsan($commod).",".errsan($stall));
     $check_tsv_done{$commod,$stall}= 1;
     foreach my $i (2..5) {
        my $f= $v[$i];
-       $f =~ m/^(|0|[1-9][0-9]{0,5}|\>1000)$/ or &$bad_data("bad field $i");
-       ($i % 2) or ($f !~ m/\>/) or &$bad_data("> in field $i price");
+       $f =~ m/^(|0|[1-9][0-9]{0,5}|\>1000)$/ or
+           &$bad_data("bad field $i ".errsan($f));
+       ($i % 2) or ($f !~ m/\>/) or
+           &$bad_data("> in field $i price ".errsan($f));
     }
 
     foreach my $i (2,4) {
index c510080..3cb543d 100644 (file)
@@ -45,7 +45,9 @@ BEGIN {
     @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
+                     &dumptab_head &dumptab_row_hashref
+                     &db_chkcommit &db_check_referential_integrity);
     %EXPORT_TAGS = ( );
 
     @EXPORT_OK   = qw();
@@ -119,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;
index 8e85c93..e8edb94 100644 (file)
@@ -1,8 +1,6 @@
 UPLOADER
 --------
 
-detect all unexpected mouse movements
-
 more flexible installation arrangements
 
 windows uploader
@@ -10,13 +8,6 @@ windows uploader
 DATABASE/DICTIONARY MANAGER
 ---------------------------
 
-eliminate black dye from live database
-
-when update rejected print better error message including
- broken commodity name
-
-notice commodities deleted from source-info and warn about them
-
 support Opal and Jade (currently there are some unicode problems)
 
 WEBSITE
@@ -28,3 +19,13 @@ initial/final stocks feature
 
 query_routesearch should show capital for each voyage
 query_routesearch should support ending in specific place(s)
+
+
+USEFUL WEBSITE UI SUGGESTIONS
+-----------------------------
+
+Change loss per league to always be percentage and not to require % to
+be typed.  Put % sign in HTML after the entry box ?
+
+15:59 <fivemack> font size=-3 for the license info at the bottom
+would also be good
index 1cff462..a75864a 100755 (executable)
@@ -195,7 +195,7 @@ sub main () {
     pipethrough_run_finish($pt, 'gunzip <$deduped_tsv.gz');
 
 #    print "\n";
-    $dbh->commit();
+    db_chkcommit(0);
 
     # select * from ((buy natural join commods) natural join stalls) natural join islands;
     # select * from ((sell natural join commods) natural join stalls) natural join islands;
index 37484d6..8ede371 100755 (executable)
@@ -39,7 +39,7 @@ use Commods;
 # $commod{'Hemp'}{Hold}
 
 our @v;
-our ($commod,$stall,%commod);
+our ($commod,$stall,%commod,@commods_inorder);
 
 @ARGV==1 or die "You probably don't want to run this program directly.\n";
 our ($mode) = shift @ARGV;
@@ -69,6 +69,7 @@ while (<>) {
        die "$_ ?" if m/.\D/;
     }
     ($commod,$stall) = @v;
+    push @commods_inorder, $commod unless exists $commod{$commod};
     bs_read(Buy,  2);
     bs_read(Sell, 4);
     $commod{$commod}{Hold}= $v[6]+0 if @v>6;
@@ -234,6 +235,41 @@ sub main__tsv () {
     write_tsv(\*STDOUT,1);
 }
 
+sub undef_printable { my ($ov)= @_; defined $ov ? $ov : '?'; };
+
+sub commodsinorder_print1 ($$) {
+    my ($keyword,$commod) = @_;
+    printf("%s\t%-40s %10s %s",
+          $keyword,
+          $commod,
+          undef_printable($commods{$commod}{Ordval}),
+          undef_printable($commods{$commod}{Class}))
+       or die $!;
+}
+
+sub main__commodsinorder () {
+    parse_info_serverside();
+    my $last_ov;
+    foreach my $commod (@commods_inorder) {
+       my $ov= $commods{$commod}{Ordval};
+       commodsinorder_print1('found',$commod);
+       if (defined $ov) {
+           if (defined $last_ov && $ov <= $last_ov) {
+               print " out-of-order" or die $!;
+           }
+           $last_ov= $ov;
+       }
+       print "\n" or die $!;
+    }
+    foreach my $commod (sort {
+           undef_printable($commods{$a}{Ordval}) cmp
+           undef_printable($commods{$b}{Ordval})
+       } keys %commods) {
+       next if exists $commod{$commod};
+       commodsinorder_print1('none',$commod);
+       print "\n" or die $!;
+    }
+}
 
 our ($pctb) = $ENV{'YPPSC_YARRG_PCTB'};
 
index 0ae5ba8..2059ad7 100755 (executable)
@@ -93,7 +93,7 @@ addlog("receiving");
 
 $o{'clientname'}= must_param('clientname',$re_any);
 my $clientinfo= $clients{$o{'clientname'}};
-fail('unknown client') unless defined $clientinfo;
+fail('unknown client '.errsan($o{'clientname'})) unless defined $clientinfo;
 
 my $clientfixes= must_param('clientfixes', "^([-0-9a-z ]*)\$");
 my @clientfixes= sort grep { m/./ } split /\s+/, $clientfixes;
@@ -115,7 +115,7 @@ $o{'ocean'}= must_param('ocean', $re_any);
 $o{'island'}= must_param('island', $re_any);
 
 my $arches= $oceans{$o{'ocean'}};
-fail("unknown ocean") unless $arches;
+fail("unknown ocean ".errsan($o{'ocean'})) unless $arches;
 
 parse_info_serverside_ocean($o{'ocean'});
 
@@ -126,7 +126,7 @@ foreach my $islands (values %$arches) {
     die if $island_found;
     $island_found= $sources;
 }
-fail("unknown island") unless $island_found;
+fail("unknown island ".errsan($o{'island'})) unless $island_found;
 
 $o{'timestamp'}= must_param('timestamp', "^([1-9]\\d{1,20})\$");
 fail("clock skew") if $o{'timestamp'} > $now;
index 0ecde9e..bb0448c 100755 (executable)
@@ -36,9 +36,17 @@ use DBI;
 use Commods;
 use CommodsDatabase;
 
+my $trace=0;
+while (@ARGV and $ARGV[0] eq '-D') {
+       $trace++;
+       shift @ARGV;
+}
+
 @ARGV==1 or die;
 my ($oceanname) = @ARGV;
 
+$|=1;
+
 #---------- setup ----------
 
 parse_info_serverside();
@@ -47,107 +55,379 @@ db_setocean($oceanname);
 db_writer();
 db_connect();
 
-#---------- schema ----------
+$dbh->trace(1) if $trace;
+
+
+#---------- schema update code ----------
+
+our @need_compact;
+our @need_transfer_back;
+
+our %table;
+
+sub table ($$) {
+    my ($table, $fields) = @_;
+    table_maycompact($table,undef,undef,$fields);
+}
+
+sub table_maycompact ($$$$) {
+    my ($table, $cpact_idfield, $cpact_needupdates, $fields) = @_;
+
+    #----- parse $fields -----
+
+    my @want_fields;
+    my @want_field_specs;
+    my %want_field_specs;
+
+    foreach my $fspec (split /\n/, $fields) {
+       next unless $fspec =~ m/\S/;
+       if ($fspec =~ m/^\s*\+/) {
+           push @want_field_specs, "\t".$';
+           next;
+       } elsif ($fspec =~ m/^\s*(\w+)(\s+)(\w.*\S)\s*$/) {
+           my ($f,$spaces,$rhs) = ($1,$2,$3);
+           my $spec= "\t".$f.$spaces.$rhs;
+           push @want_fields, $f;
+           push @want_field_specs, $spec;
+           $want_field_specs{$f}= $spec;
+       } else {
+           die "$table $fspec ?";
+       }
+    }
+
+    my $want_field_specs= join ",\n", @want_field_specs;
+
+    #----- ensure table exists -----
+
+    db_doall(<<END);
+ CREATE TABLE IF NOT EXISTS $table (
+$want_field_specs
+       );
+END
+    my @need_recreate;
+
+    #----- check whether we need to remove autoinc -----
+
+    if ($fields !~ /\bautoinc/i) {
+       my $autoinc= $dbh->prepare(<<END);
+ SELECT sql FROM sqlite_master
+       WHERE type='table' and name=? and tbl_name=?
+END
+        $autoinc->execute($table,$table);
+       my ($sql)= $autoinc->fetchrow_array();
+       die unless defined $sql;
+       push @need_recreate, 'remove autoinc'
+           if $sql =~ m/\bautoinc/i;
+    }
+
+    #----- check whether we need to add fields -----
+
+    my $check= $dbh->prepare("SELECT * FROM $table LIMIT 1");
+    $check->execute();
+    my %have_fields;
+    $have_fields{$_}=1 foreach @{ $check->{NAME_lc} };
+    $check->finish();
+
+    my @have_fields;
+    my @aside_fields;
+    my @have_field_specs;
+    my @aside_field_specs;
+
+    foreach my $f (@want_fields) {
+       if ($have_fields{$f}) {
+           push @have_fields, $f;
+           push @have_field_specs, $want_field_specs{$f};
+       } else {
+           my $aside= $want_field_specs{$f};
+           $aside =~ s/\bUNIQUE\b//i;
+           $aside =~ s/\bNOT\s*NULL\b//i;
+           $aside =~ s/\bPRIMARY\s*KEY\b//i;
+           $aside =~ s/\s+$//;
+           push @aside_fields, $f;
+           push @aside_field_specs, $aside;
+           push @need_recreate, "field $f";
+       }
+    }
+
+    #----- Do we need to recreate ? -----
+    if (!@need_recreate) {
+       $table{$table}= $table;
+       return;
+    }
+    #----- Yes, recreate: -----
+
+    print "    Recreating $table: ", join('; ',@need_recreate);
+    $table{$table}= "aside_$table";
+
+    my $have_fields= join ',', @have_fields;
+    my $aside_fields= join ',', @have_fields, @aside_fields;
+    my $have_field_specs= join ",\n", @have_field_specs;
+    my $aside_field_specs= join ",\n", @have_field_specs, @aside_field_specs;
+
+    db_doall(<<END);
+ CREATE TEMPORARY TABLE aside_$table (
+$aside_field_specs
+       );
+ INSERT INTO aside_$table ($have_fields) 
+       SELECT $have_fields FROM $table;
+
+ DROP TABLE $table;
+END
+
+    push @need_transfer_back, {
+       Table => $table,
+       Sql => <<END
+ CREATE TABLE $table (
+$want_field_specs
+       );
+
+ INSERT INTO $table ($aside_fields) SELECT $aside_fields FROM aside_$table;
+
+ DROP TABLE aside_$table;
+END
+    };
+    
+    #----- Do we need to compact ids ? -----
+    (print(".\n"), return) unless
+        defined $cpact_idfield
+       and grep { m/^remove autoinc/ } @need_recreate;
+    # yes:
+
+    print "; will compact.\n";
+    unshift @$cpact_needupdates, [ $table ], [ $cpact_idfield ];
+
+    push @need_compact, {
+       Table => $table,
+       Id => $cpact_idfield,
+       Updates => $cpact_needupdates,
+       Fields => [ @want_fields ],
+       FieldSpecs => $want_field_specs
+       };
+}
+
+
+#---------- actual schema ----------
 
 foreach my $bs (qw(buy sell)) {
-    db_doall(<<END)
- CREATE TABLE IF NOT EXISTS $bs (
-       commodid        INTEGER                 NOT NULL,
-       islandid        INTEGER                 NOT NULL,
-       stallid         INTEGER                 NOT NULL,
-       price           INTEGER                 NOT NULL,
-       qty             INTEGER                 NOT NULL,
-       PRIMARY KEY (commodid, islandid, stallid)
- );
- CREATE INDEX IF NOT EXISTS ${bs}_by_island ON $bs (commodid, islandid, price);
- CREATE INDEX IF NOT EXISTS ${bs}_by_price  ON $bs (commodid, price, islandid);
+    table($bs,<<END);
+       commodid        INTEGER                 NOT NULL
+       islandid        INTEGER                 NOT NULL
+       stallid         INTEGER                 NOT NULL
+       price           INTEGER                 NOT NULL
+       qty             INTEGER                 NOT NULL
+       + PRIMARY KEY (commodid, islandid, stallid)
 END
-    ;
 }
 
-db_doall(<<END)
- CREATE TABLE IF NOT EXISTS commods (
-       commodid        INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       commodname      TEXT    UNIQUE          NOT NULL,
-       unitmass        INTEGER,
+table_maycompact('commods', 'commodid',
+                [ [ qw(buy sell) ], [ qw(commodid) ],
+ ], <<END);
+       commodid        INTEGER PRIMARY KEY     NOT NULL
+       commodname      TEXT    UNIQUE          NOT NULL
+       unitmass        INTEGER
        unitvolume      INTEGER
- );
- CREATE TABLE IF NOT EXISTS islands (
-       islandid        INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       islandname      TEXT    UNIQUE          NOT NULL,
+       commodclassid   INTEGER                 NOT NULL
+       ordval          INTEGER                 NOT NULL
+       posinclass      INTEGER                 NOT NULL
+END
+
+table_maycompact('islands', 'islandid',
+                [ [ qw(buy sell stalls uploads) ], [ qw(islandid) ], 
+                  [ qw(dists routes) ], [ qw(aiid biid) ], 
+ ], <<END);
+       islandid        INTEGER PRIMARY KEY     NOT NULL
+       islandname      TEXT    UNIQUE          NOT NULL
        archipelago     TEXT                    NOT NULL
- );
- CREATE TABLE IF NOT EXISTS stalls (
-       stallid         INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL,
-       islandid        INTEGER                 NOT NULL,
-       stallname       TEXT                    NOT NULL,
-       UNIQUE (islandid, stallname)
- );
- CREATE TABLE IF NOT EXISTS uploads (
-       islandid        INTEGER PRIMARY KEY     NOT NULL,
-       timestamp       INTEGER                 NOT NULL,
-       message         TEXT                    NOT NULL,
-       clientspec      TEXT                    NOT NULL,
+END
+
+table('stalls', <<END);
+       stallid         INTEGER PRIMARY KEY     NOT NULL
+       islandid        INTEGER                 NOT NULL
+       stallname       TEXT                    NOT NULL
+       + UNIQUE (islandid, stallname)
+END
+
+table('commodclasses', <<END);
+       commodclassid   INTEGER PRIMARY KEY     NOT NULL
+       commodclass     TEXT    UNIQUE          NOT NULL
+       maxposinclass   INTEGER                 NOT NULL
+END
+
+table('uploads', <<END);
+       islandid        INTEGER PRIMARY KEY     NOT NULL
+       timestamp       INTEGER                 NOT NULL
+       message         TEXT                    NOT NULL
+       clientspec      TEXT                    NOT NULL
        serverspec      TEXT                    NOT NULL
- );
- CREATE TABLE IF NOT EXISTS dists (
-       aiid            INTEGER                 NOT NULL,
-       biid            INTEGER                 NOT NULL,
-       dist            INTEGER                 NOT NULL,
-       PRIMARY KEY (aiid, biid)
- );
- CREATE TABLE IF NOT EXISTS routes (
-       aiid            INTEGER                 NOT NULL,
-       biid            INTEGER                 NOT NULL,
-       dist            INTEGER                 NOT NULL,
-       PRIMARY KEY (aiid, biid)
- );
- CREATE TABLE IF NOT EXISTS vessels (
-       name            TEXT                    NOT NULL,
-       mass            INTEGER                 NOT NULL,
-       volume          INTEGER                 NOT NULL,
-       shot            INTEGER                 NOT NULL,
-       PRIMARY KEY (name)
- );
 END
-    ;
 
-$dbh->commit;
+table('dists', <<END);
+       aiid            INTEGER                 NOT NULL
+       biid            INTEGER                 NOT NULL
+       dist            INTEGER                 NOT NULL
+       + PRIMARY KEY (aiid, biid)
+END
+
+table('routes', <<END);
+       aiid            INTEGER                 NOT NULL
+       biid            INTEGER                 NOT NULL
+       dist            INTEGER                 NOT NULL
+       + PRIMARY KEY (aiid, biid)
+END
+
+table('vessels', <<END);
+       name            TEXT                    NOT NULL
+       mass            INTEGER                 NOT NULL
+       volume          INTEGER                 NOT NULL
+       shot            INTEGER                 NOT NULL
+       + PRIMARY KEY (name)
+END
+
 
 #---------- commodity list ----------
 
+sub commodsortkey ($) {
+    my ($commod) = @_;
+    return $commods{$commod}{Ordval} ||
+          $commods{$commod}{ClassOrdval};
+}
+sub commods_ordered () {
+    sort {
+       commodsortkey($a) <=> commodsortkey($b);
+    } keys %commods;
+}
+
+our %posincl;
+
 {
-    my $insert= $dbh->prepare(<<'END')
- INSERT OR IGNORE INTO commods
-     (unitmass,
-      unitvolume,
-      commodname)
-     VALUES (?,?,?);
+    my %classorderedcount;
+
+    foreach my $cl (keys %commodclasses) {
+       $classorderedcount{$cl}= 0;
+    }
+    foreach my $commod (commods_ordered()) {
+       my $cl= $commods{$commod}{Class};
+       die "no class for commodity $commod" unless defined $cl;
+
+       my $clid= $commodclasses{$cl};
+       die "unknown class $cl for $commod ".(join '|', sort keys %commodclasses) unless defined $clid;
+
+       if (defined $commods{$commod}{Ordval}) {
+           $posincl{$commod}= ++$classorderedcount{$cl};
+       } else {
+           $posincl{$commod}= 0;
+       }
+    }
+
+    db_doall(<<END);
+ DELETE FROM $table{commodclasses};
 END
-    ;
-    my $update= $dbh->prepare(<<'END')
- UPDATE commods
-     SET unitmass = ?,
-         unitvolume = ?
-     WHERE commodname = ?
+    my $addclass= $dbh->prepare(<<END);
+ INSERT INTO $table{commodclasses}
+     (commodclassid, commodclass, maxposinclass)
+     VALUES (?,?,?)
 END
-    ;
-    foreach my $commod (sort keys %commods) {
+    foreach my $cl (sort keys %commodclasses) {
+       my $clname= $cl;
+       $clname =~ s/_/ /g;
+       $addclass->execute($commodclasses{$cl}+1,
+                          ucfirst $clname,
+                          $classorderedcount{$cl});
+    }
+}
+
+{
+    my @valuefields= qw(
+                       unitmass
+                       unitvolume
+                       commodclassid
+                       ordval
+                       posinclass
+                       );
+    my $insert= $dbh->prepare("
+ INSERT OR IGNORE INTO $table{commods}
+      ( commodname,
+       ".join(",
+       ", @valuefields)." )
+     VALUES (?,".join(',', map {'?'} @valuefields).")
+");
+    my $update= $dbh->prepare("
+ UPDATE $table{commods}
+     SET ".join(",
+       ", map { "$_ = ?" } @valuefields)."
+     WHERE commodname = ?
+");
+    foreach my $commod (commods_ordered()) {
        my $c= $commods{$commod};
         die "no mass for $commod" unless defined $c->{Mass};
-        die "no colume for $commod" unless defined $c->{Volume};
-       my @qa= ($c->{Mass}, $c->{Volume}, $commod);
-       $insert->execute(@qa);
-       $update->execute(@qa);
+        die "no volume for $commod" unless defined $c->{Volume};
+       
+       my $cl= $c->{Class};
+       my $clid= $commodclasses{$cl}+1;
+
+       my @valuevalues= (
+                         $c->{Mass},
+                         $c->{Volume},
+                         $clid,
+                         commodsortkey($commod),
+                         $posincl{$commod}
+                         );
+       $insert->execute($commod, @valuevalues);
+       $update->execute(@valuevalues, $commod);
+    }
+
+    my $search= $dbh->prepare(<<END);
+ SELECT commodname,commodid FROM $table{commods};
+END
+    my %check;
+    foreach my $bs (qw(buy sell)) {
+       $check{$bs}= $dbh->prepare(<<END);
+ SELECT islandname,stallname,price,qty
+   FROM $table{$bs}
+   JOIN $table{stalls} USING (stallid)
+   JOIN $table{islands} ON ($bs.islandid = $table{islands}.islandid)
+   WHERE commodid = ? LIMIT 1
+END
     }
-    $dbh->commit;
+    my $delete= $dbh->prepare(<<END);
+ DELETE FROM $table{commods} WHERE commodid = ?
+END
+    $search->execute();
+    my $any=0;
+    while (my $row= $search->fetchrow_hashref()) {
+       next if defined $commods{$row->{'commodname'}};
+       print $any++ ? '; ' : "    Dropping old commodities: ",
+             $row->{'commodname'};
+       foreach my $bs (qw(buy sell)) {
+           $check{$bs}->execute($row->{'commodid'});
+           my $problem= $check{$bs}->fetchrow_hashref();
+           if ($problem) {
+               print "\n";
+               die <<END
+
+FATAL ERROR
+    Removed commodity
+       $row->{'commodid'}
+       $row->{'commodname'}
+    but
+       $bs
+       $problem->{'islandname'}
+       $problem->{'stallname'}
+       $problem->{'qty'} at $problem->{'price'}
+END
+            }
+       }
+       $delete->execute($row->{'commodid'});
+    }
+    print ".\n" if $any;
 }
 
 #---------- vessel types ----------
 {
-    my $idempotent= $dbh->prepare(<<'END')
- INSERT OR REPLACE INTO vessels (name, shot, mass, volume)
-                         VALUES (?,?,?,?)
+    my $idempotent= $dbh->prepare(<<END)
+ INSERT OR REPLACE INTO $table{vessels}
+       (name, shot, mass, volume)
+       VALUES (?,?,?,?)
 END
     ;
     foreach my $name (sort keys %vessels) {
@@ -158,5 +438,110 @@ END
        my @qa= ($name, $shotdamage, map { $v->{$_} } qw(Mass Volume));
        $idempotent->execute(@qa);
     }
-    $dbh->commit;
+}
+
+#---------- transfer data back from any recreated tables ----------
+
+foreach my $tb (@need_transfer_back) {
+    my $tab= $tb->{Table};
+    print "    Retransferring $tab...";
+
+    if (!eval {
+       db_doall($tb->{Sql});
+       1;
+    }) {
+       my $emsg= $@;
+       my $w=20;
+       print STDERR "\n=== $tab retransfer failed, dumping:\n";
+       my $dumph= $dbh->prepare("SELECT * FROM aside_$tab");
+       $dumph->execute();
+       my @cols= @{ $dumph->{NAME_lc} };
+       dumptab_head(\*STDERR,$w,\@cols);
+       my $row;
+       while ($row= $dumph->fetchrow_hashref()) {
+           dumptab_row_hashref(\*STDERR,$w,\@cols,$row);
+       }
+       die "\n$emsg";
+    }
+    print "\n";
+    $table{$tab}= $tab;
+}
+
+#---------- create indices ----------
+
+foreach my $bs (qw(buy sell)) {
+    db_doall(<<END)
+ CREATE INDEX IF NOT EXISTS ${bs}_by_island ON $bs (commodid, islandid, price);
+ CREATE INDEX IF NOT EXISTS ${bs}_by_price  ON $bs (commodid, price, islandid);
+END
+    ;
+}
+
+db_check_referential_integrity(1);
+
+#---------- compact IDs ----------
+
+sub getminmax ($$$) {
+    my ($tab,$minmax,$f) = @_;
+    my $sth= $dbh->prepare("SELECT $minmax($f) FROM $tab");
+    $sth->execute();
+    my ($val)= $sth->fetchrow_array();
+    return defined($val) ? $val : '?';
+}
+
+foreach my $cp (@need_compact) {
+    print "    Compacting $cp->{Table}";
+    my $tab= $cp->{Table};
+    my $id= $cp->{Id};
+    my $tmp_field_specs= $cp->{FieldSpecs};
+    my $fields= join ',', @{$cp->{Fields}};
+    $tmp_field_specs =~ s/\bprimary key\b/UNIQUE/i or
+       die "$tab $tmp_field_specs ?";
+    db_doall(<<END);
+ CREATE TEMPORARY TABLE idlookup_$tab (
+       new_$id         INTEGER PRIMARY KEY NOT NULL,
+$tmp_field_specs
+ );
+ INSERT INTO idlookup_$tab ($fields)
+       SELECT $fields
+       FROM $tab;
+END
+    my $oldmax= getminmax($tab,'max',$id);
+    my $offset= $oldmax+1;
+    
+    printf(" %s %s..%d=>1..%d:",
+          $cp->{Id},
+          getminmax($tab,'min',$id),
+          $oldmax,
+          getminmax("idlookup_$tab",'max',"new_$id"));
+    my @updates= @{ $cp->{Updates} };
+    while (@updates) {
+       my $utabs= shift @updates;
+       my $ufields= shift @updates;
+       foreach my $utab (@$utabs) {
+           printf(" %s",$utab);
+           my $fh= '.';
+           foreach my $ufield (@$ufields) {
+               printf("%s%s",$fh,$ufield); $fh=',';
+               db_doall(<<END);
+ UPDATE $utab
+    SET $ufield = $offset +
+        (SELECT new_$id FROM idlookup_$tab
+          WHERE idlookup_$tab.$id = $utab.$ufield);
+ UPDATE $utab
+    SET $ufield = $ufield - $offset;
+END
+            }
+       }
+    }
+    print "\n";
+}
+
+#---------- put it all into effect ----------
+
+db_chkcommit(1);
+
+{
+    local $dbh->{AutoCommit} = 1;
+    $dbh->do('VACUUM');
 }
index f4f6066..430523a 100644 (file)
@@ -1,21 +1,4 @@
 
-removing an obsolete commodity:
-
-  select * from (select * from sell union select * from buy) left outer join commods using (commodid) where commods.commodname = 'Black dye' limit 10;
-
-if that produces no output then:
-
-  begin;
-  delete from commods where commodname like 'Black dye';
-  select * from (select * from sell union select * from buy) left outer join commods using (commodid) where commods.commodname is null limit 10;
-
-and if that produces no output then:
-  commit;
-otherwise
-  rollback;
-
-=======================================
-
 ceb's example route:
   alpha,byrne,papaya,turtle,jorvik,luthien
 
index 88b9311..acfca81 100644 (file)
@@ -1,3 +1,4 @@
+# -*- fundamental -*-
 
 vessels
 #|   Ship Name    |Gun Size|Volume | Mass  |
@@ -31,128 +32,150 @@ shot
  medium        3
  large 4
 
-commods
- kraken's blood                1kg
- %c dye                        1kg
- %c enamel             5kg
- %c paint              1200g 1l
+commodclasses
+ *basic_commodities
+ *ship_supplies
+ *herbs
+ *minerals
+ *cloth
+ *dye
+ *paint
+ *enamel
+ *forageables
 
- %c cloth              700g
- fine %c cloth         700g
- sail cloth            700g
+commods
+ kraken's blood                1kg             *dye                    @105
+ %d dye                        1kg             *dye                    @0
+ %enamel enamel                5kg             *enamel                 @0
+ %c paint              1200g 1l        *paint                  @0
+
+ %c cloth              700g            *cloth                  @2
+ fine %c cloth         700g            *cloth                  @5
+ sail cloth            700g            *cloth                  @150000
+
+%d
+ red                                                           @100
+ yellow                                                                @110
+ blue                                                          @120
+ green                                                         @130
+ lime
+ navy
 
-nocommods
- black dye
+%enamel
+ %c                                                            @0
 
 %c
- aqua
- black
- blue
- brown
- gold
- green
- grey
- lavender
- lemon
- light blue
- light green
- lime
- magenta
- maroon
- mint
- navy
- orange
- peach
- persimmon
- pink
- purple
- red
- rose
- tan
- violet
- white
- yellow
+ red                                                           @100000+
+ tan                                                           @100000+
+ white                                                         @100000+
+ black                                                         @100000+
+ grey                                                          @100000+
+ yellow                                                                @100000+
+ pink                                                          @100000+
+ violet                                                                @100000+
+ purple                                                                @100000+
+ navy                                                          @100000+
+ blue                                                          @100000+
+ aqua                                                          @100000+
+ lime                                                          @100000+
+ green                                                         @100000+
+ orange                                                                @100000+
+ aqua                                                          @100000+
+ lime                                                          @100000+
+ green                                                         @100000+
+ orange                                                                @100000+
+ maroon                                                                @100000+
+ brown                                                         @100000+
+ gold                                                          @100000+
+ rose                                                          @100000+
+ lavender                                                      @100000+
+ mint                                                          @100000+
+ light green                                                   @100000+
+ magenta                                                       @200000+
+ lemon                                                         @200000+
+ peach                                                         @200000+
+ light blue                                                    @200000+
+ persimmon                                                     @200000+
 
 commods
- %g gems               10kg
- diamonds              10kg
- emeralds              10kg
- moonstones            10kg
- opals                 10kg
- pearls                        10kg
- rubies                        10kg
- sapphires             10kg
- topazes               10kg
+ %g gems               10kg            *forageables            @0
+ diamonds              10kg            *forageables            @200000+
+ emeralds              10kg            *forageables            @200000+
+ moonstones            10kg            *forageables            @200000+
+ opals                 10kg            *forageables            @200000+
+ pearls                        10kg            *forageables            @200000+
+ rubies                        10kg            *forageables            @200000+
+ sapphires             10kg            *forageables            @200000+
+ topazes               10kg            *forageables            @200000+
 
 %g
- amber
- amethyst
- beryl
- coral
- jade
- jasper
- jet
- lapis lazuli
- quartz
- tigereye
+ amber                                                         @200000+
+ amethyst                                                      @200000+
+ beryl                                                         @200000+
+ coral                                                         @200000+
+ jade                                                          @200000+
+ jasper                                                                @200000+
+ jet                                                           @200000+
+ lapis lazuli                                                  @200000+
+ quartz                                                                @200000+
+ tigereye                                                      @200000+
 
 commods
- swill                 1kg
- grog                  1kg
- fine rum              1kg
-
- broom flower          200g
- butterfly weed                100g
- cowslip               700g
- elderberries          700g
- indigo                        700g
- iris root             300g
- lily of the valley    300g
- lobelia               200g
- madder                        400g
- nettle                        300g
- old man's beard       800g
- pokeweed berries      300g
- sassafras             500g
- weld                  300g
- yarrow                        200g
-
- bananas               125kg 100l
- coconuts              125kg 100l
- limes                 125kg 100l
- mangos                        125kg 100l
- pineapples            125kg 100l
-
- carambolas            125kg 100l
- durians               125kg 100l
- passion fruit         125kg 100l
- pomegranates          125kg 100l
- rambutan              125kg 100l
-
- chalcocite            5700g
- cubanite              4700g
- gold nuggets          400g
- leushite              4400g
- lorandite             5500g
- masuyite              5100g
- papagoite             3300g
- serandite             3400g
- sincosite             3000g
- tellurium             6200g
- thorianite            100g
-
- small cannon balls    7100g
- medium cannon balls   14200g 2l
- large cannon balls    21300g 3l
-
- hemp                  125kg 250l
- hemp oil              1kg
- iron                  7800g
- lacquer               1kg
- stone                 2600g
- sugar cane            50kg 100l
- varnish               1kg
- wood                  175kg 250l
+ swill                 1kg             *ship_supplies          @0+
+ grog                  1kg             *ship_supplies          @0+
+ fine rum              1kg             *ship_supplies          @0+
+ small cannon balls    7100g           *ship_supplies          @0+
+ medium cannon balls   14200g 2l       *ship_supplies          @0+
+ large cannon balls    21300g 3l       *ship_supplies          @0+
+
+ broom flower          200g            *herbs
+ butterfly weed                100g            *herbs
+ cowslip               700g            *herbs
+ elderberries          700g            *herbs
+ indigo                        700g            *herbs
+ iris root             300g            *herbs
+ lily of the valley    300g            *herbs
+ lobelia               200g            *herbs
+ madder                        400g            *herbs
+ nettle                        300g            *herbs
+ old man's beard       800g            *herbs
+ pokeweed berries      300g            *herbs
+ sassafras             500g            *herbs
+ weld                  300g            *herbs
+ yarrow                        200g            *herbs
+
+ bananas               125kg 100l      *forageables
+ coconuts              125kg 100l      *forageables
+ limes                 125kg 100l      *forageables
+ mangos                        125kg 100l      *forageables
+ pineapples            125kg 100l      *forageables
+
+ carambolas            125kg 100l      *forageables
+ durians               125kg 100l      *forageables
+ passion fruit         125kg 100l      *forageables
+ pomegranates          125kg 100l      *forageables
+ rambutan              125kg 100l      *forageables
+
+ chalcocite            5700g           *minerals
+ cubanite              4700g           *minerals
+ gold nuggets          400g            *minerals
+ leushite              4400g           *minerals
+ lorandite             5500g           *minerals
+ masuyite              5100g           *minerals
+ papagoite             3300g           *minerals
+ serandite             3400g           *minerals
+ sincosite             3000g           *minerals
+ tellurium             6200g           *minerals
+ thorianite            100g            *minerals
+
+ iron                  7800g           *basic_commodities      @110
+ sugar cane            50kg 100l       *basic_commodities      @120
+ hemp                  125kg 250l      *basic_commodities      @130
+ wood                  175kg 250l      *basic_commodities      @140
+ stone                 2600g           *basic_commodities      @150
+ hemp oil              1kg             *basic_commodities      @160
+ varnish               1kg             *basic_commodities      @180
+ lacquer               1kg             *basic_commodities      @190
 
 
 client ypp-sc-tools yarrg
index f757455..adad34c 100755 (executable)
@@ -95,7 +95,7 @@ sub process_some_info ($$$) {
            next if $h =~ m/^nocommods/;
        }
        next if $sfn =~ m/source-info/ && $h =~ m/^ocean\b/;
-       next if $h =~ m/^client|^vessels|^shot\b/;
+       next if $h =~ m/^client|^vessels|^shot\b|^commodclasses/;
 
        print $df $_, "\n" or die $!;
     }
index 41ef985..e6e22b5 100755 (executable)
@@ -772,6 +772,7 @@ for (;;) {
            print STDERR "*** --stdin-chart, aborting!\n";
            exit 1;
        }
+       progress("checking database");        db_check_referential_integrity();
        progress("committing database");       $dbh->commit();
        progress("committing _ocean-*.txt");   localtopo_commit();
        exit 0;