@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
# 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.
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} };
%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 () {
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]"); };
!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) {
@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();
}
}
+#---------- 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;
UPLOADER
--------
-detect all unexpected mouse movements
-
more flexible installation arrangements
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
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
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;
# $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;
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;
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'};
$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;
$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'});
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;
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();
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) {
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');
}
-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
+# -*- fundamental -*-
vessels
#| Ship Name |Gun Size|Volume | Mass |
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
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 $!;
}
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;
~yarrgweb / ypp-sc-tools.main.git / commitdiff