From: Ian Jackson Date: Fri, 24 Jul 2009 16:58:49 +0000 (+0100) Subject: Merge branch 'master' into ourdb X-Git-Tag: 3.0~44 X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?a=commitdiff_plain;h=769239e4cc9af0b88578d1b15a1b14a7cb3dc7ba;hp=d6eb446015657288c19d7a9399e3bef7c65ad29e;p=ypp-sc-tools.db-live.git Merge branch 'master' into ourdb Conflicts: pctb/commod-results-processor --- diff --git a/pctb/Commods.pm b/pctb/Commods.pm new file mode 100644 index 0000000..e695f15 --- /dev/null +++ b/pctb/Commods.pm @@ -0,0 +1,123 @@ + +package Commods; +use IO::File; + +use strict; +use warnings; + +BEGIN { + use Exporter (); + our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); + $VERSION = 1.00; + @ISA = qw(Exporter); + @EXPORT = qw(&parse_masters %oceans %commods %clients + &parse_pctb_commodmap %pctb_commodmap @pctb_commodmap + &get_our_version); + %EXPORT_TAGS = ( ); + + @EXPORT_OK = qw(); +} + +our %oceans; # eg $oceans{'Midnight'}{'Ruby'}{'Eta Island'}= $sources; +our %commods; # eg $commods{'Fine black cloth'}= $sources; +our %clients; # eg $clients{'ypp-sc-tools'}= [ qw(last-page) ]; +# $sources = 's[l]b'; +# 's' = Special Circumstances; 'l' = local ; B = with Bleach + +our (%pctb_commodmap,@pctb_commodmap); + +my %colours; # eg $colours{'c'}{'black'}= $sources +my @rawcm; # eg $rawcm[0]='fine rum'; $rawcm[1]='fine %c cloth' + +sub parse_master_master1 ($$) { + my ($mmfn,$src)= @_; + my $mm= new IO::File $mmfn, 'r' or die "$mmfn $!"; + my @ctx= (); + while (<$mm>) { + next if m/^\s*\#/; + next unless m/\S/; + s/\s+$//; + if (m/^\%(\w+)$/) { + my $colourkind= $1; + @ctx= (sub { $colours{$colourkind}{lc $_} .= $src; }); + } elsif (m/^commods$/) { + @ctx= (sub { push @rawcm, lc $_; }); + } elsif (m/^ocean (\w+)$/) { + my $ocean= $1; + @ctx= (sub { + $ocean or die; # ref to $ocean needed to work + # around a perl bug + my $arch= $_; + $ctx[1]= sub { + $oceans{$ocean}{$arch}{$_} .= $src; + }; + }); + } elsif (m/^client (\S+.*\S)$/) { + my $client= $1; + $clients{$client}= [ ]; + @ctx= (sub { + my $bug= $_; + push @{ $clients{$client} }, $bug; + }); + } elsif (s/^ +//) { + my $indent= length $&; + die "wrong indent $indent" unless defined $ctx[$indent-1]; + &{ $ctx[$indent-1] }(); + } else { + die "bad syntax"; + } + } + $mm->error and die $!; + close $mm or die $!; + +#print Dumper(\%oceans); +#print Dumper(\@rawcm); + + %commods= (); + my $ca; + $ca= sub { + my ($s,$ss) = @_; +#print "ca($s)\n"; + if ($s !~ m/\%(\w+)/) { $commods{ucfirst $s} .= $ss; return; } + die "unknown $&" unless defined $colours{$1}; + foreach my $c (keys %{ $colours{$1} }) { + &$ca($`.$c.$', $ss .'%'. $colours{$1}{$c}); + } + }; + foreach (@rawcm) { &$ca($_,$src); } +} + +sub parse_masters () { + parse_master_master1('master-master.txt','s'); +} + +sub parse_pctb_commodmap () { + undef %pctb_commodmap; + foreach my $commod (keys %commods) { $commods{$commod} =~ s/b//; } + + my $c= new IO::File '_commodmap.tsv' or die $!; + if (!$c) { $!==&ENOENT or die $!; return 0; } + + while (<$c>) { + m/^(\S.*\S)\t(\d+)\n$/ or die "$_"; + die if defined $pctb_commodmap{$1}; $pctb_commodmap{$1}= $2; + die if defined $pctb_commodmap[$2]; $pctb_commodmap[$2]= $1; + $commods{$1} .= 'b'; + } + $c->error and die $!; + close $c or die $!; + return 1; +} + +sub get_our_version ($) { + my ($prefix); + { + no strict (qw(refs)); + ${ "${prefix}name" }= 'ypp-sc-tools yarrg'; + ${ "${prefix}fixes" }= 'lastpage'; + ${ "${prefix}version" }= `git-describe --tags HEAD`; + $? and die $?; + } +} + +1; diff --git a/pctb/commod-results-processor b/pctb/commod-results-processor index fe26f88..cba01d9 100755 --- a/pctb/commod-results-processor +++ b/pctb/commod-results-processor @@ -32,6 +32,8 @@ use POSIX; use LWP::UserAgent; use XML::Parser; +use Commods; + # $commod{'Hemp'}{Buy|Sell}{'stall'}{Stall} # $commod{'Hemp'}{Buy|Sell}{'stall'}{Price} # $commod{'Hemp'}{Buy|Sell}{'stall'}{Qty} @@ -217,23 +219,10 @@ sub main__tsv () { } -our (%commodmap); our ($pctb) = $ENV{'YPPSC_PCTB_PCTB'}; our ($ua)= LWP::UserAgent->new; -sub load_commodmap() { - undef %commodmap; - my $c= new IO::File "_commodmap.tsv"; - if (!$c) { $!==&ENOENT or die $!; return; } - while (<$c>) { - m/^(\S.*\S)\t(\d+)\n$/ or die "$_"; - $commodmap{$1}= $2; - } - $c->error and die $!; - close $c; -} - sub refresh_commodmap() { die unless $pctb; $pctb =~ s,/*$,,; @@ -245,7 +234,7 @@ sub refresh_commodmap() { my $intag=''; my %got; my $o= new IO::File "_commodmap.tsv.tmp",'w' or die $!; - undef %commodmap; + undef %pctb_commodmap; my $xp= new XML::Parser (Handlers => @@ -275,8 +264,8 @@ sub refresh_commodmap() { my $index= $1; $_= $got{'name'}; s/^\s+//; s/\s+$//; s/\n/ /g; s/\s+/ /; - die "$_ ?" if exists $commodmap{$_}; - $commodmap{$_}= $index; + die "$_ ?" if exists $pctb_commodmap{$_}; + $pctb_commodmap{$_}= $index; print $o "$_\t$index\n" or die $!; } elsif (lc $_ eq $intag) { $got{$intag}= $cdata; @@ -336,8 +325,8 @@ sub bs_gen_md ($$) { my $o= ''; foreach $commod ( - sort { $commodmap{$a} <=> $commodmap{$b} } - grep { exists $commodmap{$_} } + sort { $pctb_commodmap{$a} <=> $pctb_commodmap{$b} } + grep { exists $pctb_commodmap{$_} } keys %commod ) { #print STDERR "COMMOD $commod\n"; @@ -345,7 +334,7 @@ sub bs_gen_md ($$) { my $l= bs_p($commod,$bs,$sortmul); next unless @$l; #print STDERR "COMMOD $commod has ".scalar(@$l)."\n"; - $o .= writeint($commodmap{$commod}); + $o .= writeint($pctb_commodmap{$commod}); $o .= writeint(scalar @$l); foreach my $cs (@$l) { $stall= $cs->{Stall}; @@ -381,14 +370,14 @@ our (%stalltypetoabbrevmap)= qw( sub genmarketdata () { our $version= '005b'; - load_commodmap(); - my @missing= grep { !exists $commodmap{$_} } keys %commod; + parse_pctb_commodmap(); + my @missing= grep { !exists $pctb_commodmap{$_} } keys %commod; if (@missing) { refresh_commodmap(); refresh_newcommods(); my $missing=0; foreach $commod (sort keys %commod) { - next if exists $commodmap{$commod}; + next if exists $pctb_commodmap{$commod}; if (exists $newcommods{$commod}) { printf STDERR "Ignoring new commodity \`%s'!\n", $commod; } else { @@ -453,7 +442,17 @@ sub gzip ($) { return $r; } -sub main__upload () { +sub main__uploadyaarg () { + my $ocean= $ENV{'YPPSC_OCEAN'}; die unless $ocean; + my $island= $ENV{'YPPSC_ISLAND'}; die unless $island; + my $content= { + 'data' => [ undef, 'deduped.tsv.gz', + Content_Type => 'application/octet-stream', + Content => '' +]}; +} + +sub main__uploadpctb () { my $ocean= $ENV{'YPPSC_OCEAN'}; die unless $ocean; my $island= $ENV{'YPPSC_ISLAND'}; die unless $island; die unless $pctb; diff --git a/pctb/commod-update-receiver b/pctb/commod-update-receiver new file mode 100755 index 0000000..b7bf4cb --- /dev/null +++ b/pctb/commod-update-receiver @@ -0,0 +1,169 @@ +#!/usr/bin/perl -w +# +# This script is invoked when the YPP SC PCTB client uploads to +# the chiark database. + +# This is part of ypp-sc-tools, a set of third-party tools for assisting +# players of Yohoho Puzzle Pirates. +# +# Copyright (C) 2009 Ian Jackson +# +# This program is free software: you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation, either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . +# +# Yohoho and Puzzle Pirates are probably trademarks of Three Rings and +# are used without permission. This program is not endorsed or +# sponsored by Three Rings. + + +# Uploads contain: +# ocean canonical mixed case +# island canonical mixed case +# clientname "ypp-sc-tools" +# clientversion 2.1-g2e06a26 [from git-describe --tags HEAD] +# clientfixes "lastpage" [space separated list] +# data filename=deduped.tsv.gz output of ypp-commodities --tsv + +use strict (qw(vars)); +use POSIX; + +use Commods; + +$CGI::POST_MAX= 3*1024*1024; +$CGI::DISABLE_UPLOADS= 1; + +use CGI qw/:standard -private_tempfiles/; + +setlocale(LC_CTYPE, "en_GB.UTF-8"); + +my $re_any= "^(.*)\$"; + +parse_masters(); + +sub fail ($) { + my ($msg) = @_; + print header(-status=>'400 Bad commodity update', + -type=>'text/plain', + -charset=>'us-ascii'); + print "Error: $msg\n"; + exit 0; +} + +sub must_param ($$) { + my ($n,$re)= @_; + my $v= param($n); + fail("missing form parameter $n") unless defined $v; + fail("invalid form parameter $n ($re)") unless $v =~ m/$re/; + return $1; +} + +my $clientname= must_param('clientname',$re_any); +my $clientinfo= $clients{$clientname}; +fail('unknown client') unless defined $clientinfo; + +my $clientfixes= must_param('clientfixes', "^([-0-9a-z ]*)\$"); +my @clientfixes= sort grep { m/./ } split /\s+/, $clientfixes; +$clientfixes= "@clientfixes"; +foreach my $bug (@$clientinfo) { + fail("client out of date - missing bugfix \`$bug'") + unless grep { $_ eq $bug } @clientfixes; +} + +my $clientversion= must_param('clientversion', "^(\\d[-+._0-9a-zA-Z]+)\$"); + +my $ocean= must_param('ocean', $re_any); +my $island= must_param('island', $re_any); + +my $arches= $oceans{$ocean}; +fail("unknown ocean") unless $arches; + +my $island_found= 0; +foreach my $islands (values %$arches) { + my $sources= $islands->{$island}; + next unless $sources; + die if $island_found; + $island_found= $sources; +} +fail("unknown island") unless $island_found; + +my $timestamp= must_param('timestamp', "^([1-9]\\d{1,20})\$"); +my $now= time; defined $now or die $!; +fail("clock skew") if $timestamp >= $now; + +die if $ocean =~ m/\=/; +die if $island =~ m/\=/; + +my $indatafh= upload('data'); +defined $indatafh or fail("data is not a file"); +my $datafile= must_param('data',"^(deduped\\.tsv\\.gz)\$"); + +our %done; + +my $mcontent= MIME::Entity->build(To => 'yarrg-commod-updates', + Type => 'multipart/mixed', + Boundary => '=', + Charset => 'utf-8'); + +our ($servername,$serverversion,$serverfixes); +get_our_version('::server'); + +my $clientspec= "$clientname $clientversion $clientfixes"; +my $serverspec= "$servername $serverversion $serverfixes"; + +foreach my $vn (qw(ocean island timestamp + clientspec clientname clientversion clientfixes + serverspec servername serverversion serverfixes)) { + my $mpart= MIME::Entity->build(Type => 'text/plain', + Charset => 'utf-8', + Disposition => 'inline', + Data => $$vn); + $mcontent->add_part($mpart); +} + +my $gunzchild= open(GZ, "-|") or die $!; +if (!$gunzchild) { + open STDIN, "<&=", $indatafh or die $!; + execlp 'gunzip'; die $!; +} + +while () { + !m/\P{IsPrint}/ or die bad_data('nonprinting char(s)'); + !m/\\/ or bad_data('data contains backslashes'); + my @v= split /\t/; + @v==6 or bad_data('wrong number of fields'); + my ($commod,$stall) = @v; + defined $commods{$commod} or bad_data("unknown commodity \`$commod'"); + $stall =~ m/^\p{IsUpper}/ or bad_data("stall not capitalised"); + !exists $done{$commod,$stall} or bad_data("repeated data"); + $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 % 1) or ($f !~ m/\>/) or bad_data("> in price"); + } +} +GZ->error and die $!; +$?=0; close GZ; $? and fail("gunzip for check failed code $?"); + +my $mdatafile= MIME::Entity->build(Type => 'application/octet-stream', + Disposition => 'attachment', + Encoding => 'base64', + File => $datafile); +$mcontent->add_part($mdatafile); + +open M, "|/usr/sbin/sendmail -t -oi -oee -odq" + or fail("fork sendmail failed! ($!)"); +$mcontent->print(\*M); + +M->error and fail("write sendmail failed! ($!)"); +$?=0; close M; $? and fail("sendmail failed code $?"); diff --git a/pctb/database-info-fetch b/pctb/database-info-fetch index 3b8db77..2e195c7 100755 --- a/pctb/database-info-fetch +++ b/pctb/database-info-fetch @@ -27,14 +27,17 @@ use strict (qw(vars)); use LWP::UserAgent; use JSON; -use Data::Dumper; +#use Data::Dumper; +use IO::File; -@ARGV==1 or die "You probably don't want to run this program directly.\n"; +use Commods; + +@ARGV>=1 or die "You probably don't want to run this program directly.\n"; our ($which) = shift @ARGV; $which =~ s/\W//g; -our ($pctb) = $ENV{'YPPSC_PCTB_PCTB'}; die unless $pctb; +our ($pctb) = $ENV{'YPPSC_PCTB_PCTB'}; our ($ua)= LWP::UserAgent->new; our $jsonresp; @@ -79,8 +82,9 @@ sub json_convert_shim ($) { } } -sub get_arches_islands () { - my $ocean= $ENV{'YPPSC_OCEAN'}; die unless $ocean; +sub get_arches_islands_pctb ($) { + my ($ocean)= @_; + die unless $pctb; my $url= "$pctb/islands.php?oceanName=".uc $ocean; my $resp= $ua->get($url); die $resp->status_line unless $resp->is_success; @@ -88,30 +92,98 @@ sub get_arches_islands () { my $jobj= json_convert_shim($resp->content); my $arches= [ jparsetable($jobj, 'arches') ]; my $islands= [ jparsetable($jobj, 'islands') ]; - return ($arches,$islands); -} -sub main__island () { - my ($arches, $islands) = get_arches_islands(); -# print Dumper(\@arches, \@islands); my $islands_done=0; - foreach my $arch (sort_by_name(@$arches)) { -# print Dumper($arch); + foreach my $arch (@$arches) { +# print Dumper($arnch); my $aname= $arch->{'name'}; die "$jsonresp ?" unless defined $aname; - ptcl($aname); p(' '); ptcl($aname); p(" {\n"); - foreach my $island (sort_by_name(@$islands)) { + + foreach my $island (@$islands) { my $iname= $island->{'name'}; die "$jsonresp $aname ?" unless defined $iname; next unless $arch->{'id'} == $island->{'arch'}; - p(' '); ptcl($iname); p(' '); ptcl($iname); p("\n"); + + $oceans{$ocean}{$aname}{$iname} .= 'b'; + $islands_done++; } - p("}\n"); } die "$jsonresp $islands_done ?" unless $islands_done == @$islands; } +sub get_ocean () { + my $ocean= $ENV{'YPPSC_OCEAN'}; die unless $ocean; + return ucfirst lc $ocean; +} + +sub for_islands ($$$$) { + my ($ocean,$forarch,$forisle,$endarch) = @_; + + my $arches= $oceans{$ocean}; + foreach my $aname (sort keys %$arches) { + &$forarch($ocean,$aname); + my $islands= $arches->{$aname}; + foreach my $iname (sort keys %$islands) { + &$forisle($ocean,$aname,$iname); + } + &$endarch(); + } +} + +sub for_commods ($) { + my ($forcommod) = @_; + foreach my $commod (sort keys %commods) { &$forcommod($commod); } +} + +sub compare_sources_one ($$) { + my ($srcs,$what) = @_; + return if $srcs =~ m,^sl?(?:\%sl?)*b$,; + print "srcs=$srcs $what\n"; +} + +sub main__comparesources () { + my $ocean= get_ocean(); + + parse_masters(); + get_arches_islands_pctb($ocean); + parse_pctb_commodmap() or die; + + for_islands($ocean, + sub { }, + sub { + my ($ocean,$a,$i)= @_; + my $srcs= $oceans{$ocean}{$a}{$i}; + compare_sources_one($srcs, "island $ocean / $a / $i"); + }, + sub { }); + for_commods(sub { + my ($commod)= @_; + my $srcs= $commods{$commod}; + compare_sources_one($srcs, "commodity $commod"); + }); +} + +sub main__island () { + my $ocean= get_ocean(); + + parse_masters(); + get_arches_islands_pctb($ocean); + + for_islands($ocean, + sub { + my ($ocean,$aname)= @_; + ptcl($aname); p(' '); ptcl($aname); p(" {\n"); + }, + sub { + my ($ocean,$aname,$iname)= @_; + p(' '); ptcl($iname); p(' '); ptcl($iname); p("\n"); + }, + sub { + p("}\n"); + }); +} + sub main__sunshinewidget () { print <) { - m/^(\S.*\S)\t(\d+)$/ or die; - $commodmap[$2]= $1; -} -die $! if CM->error; +parse_pctb_commodmap(); -%stallkinds= qw(A Apothecary - D Distilling - F Furnishing - I Ironworking - S Shipbuilding - T Tailor - W Weaving); +our %stallkinds= qw(A Apothecary + D Distilling + F Furnishing + I Ironworking + S Shipbuilding + T Tailor + W Weaving); sub getline ($) { my ($w)= @_; @@ -54,13 +53,14 @@ sub inmap($\@$) { printf "# Version: \"%s\"\n", getline("version"); -$nstalls= getline("nstalls")+0; +our $nstalls= getline("nstalls")+0; +our @stalls; while (@stalls < $nstalls) { $_= getline("stall name ".(@stalls+1)); if (s/\^([A-Z])$//) { - $kind= $1; - $sk= $stallkinds{$kind}; + my $kind= $1; + my $sk= $stallkinds{$kind}; die "kind $kind in $_ ?" unless defined $sk; $_ .= "'s $sk Stall"; } @@ -70,19 +70,20 @@ unshift @stalls, undef; $|=1; -foreach $bs qw(Buy Sell) { - $alloffers_want= getint("Buy ncommods"); - $alloffers_done=0; +foreach my $bs qw(Buy Sell) { + my $alloffers_want= getint("Buy ncommods"); + my $alloffers_done=0; while ($alloffers_done < $alloffers_want) { - $commodix= getint("Buy $alloffers_done/$alloffers_want commodix"); - $offers= getint("Buy $commodnum offers"); + my $commodix= getint("Buy $alloffers_done/$alloffers_want commodix"); + my $offers= getint("Buy $commodix offers"); + my $offernum; for ($offernum=0; $offernum<$offers; $offernum++) { - $stallix= getint("Buy $commodnum $offernum stallix"); - $price= getint("Buy $commodnum $offernum price"); - $qty= getint("Buy $commodnum $offernum qty"); + my $stallix= getint("Buy $commodix $offernum stallix"); + my $price= getint("Buy $commodix $offernum price"); + my $qty= getint("Buy $commodix $offernum qty"); printf("%s\t%s\t%s", $bs, - inmap('commod',@commodmap,$commodix), + inmap('commod',@pctb_commodmap,$commodix), inmap('stall',@stalls,$stallix)) or die $!; if ($bs eq 'Sell') { print "\t\t" or die $!; } printf("\t%d\t%d", $price, $qty) or die $!; @@ -94,7 +95,7 @@ foreach $bs qw(Buy Sell) { } } -$r= read STDIN,$b,1; +my $r= read STDIN,$b,1; STDIN->error and die $!; STDIN->eof or die; $b and die; diff --git a/pctb/master-master.txt b/pctb/master-master.txt new file mode 100644 index 0000000..3753a43 --- /dev/null +++ b/pctb/master-master.txt @@ -0,0 +1,168 @@ + +commods + %c dye + %c enamel + %c paint + + %c cloth + fine %c cloth + + %g gems + +%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 + +%g + amber + amethyst + beryl + coral + jade + jasper + jet + lapis lazuli + quartz + tigereye + +commods + bananas + broom flower + butterfly weed + carambolas + chalcocite + coconuts + cowslip + cubanite + diamonds + durians + elderberries + emeralds + fine rum + gold nuggets + gold ore + grog + hemp + hemp oil + indigo + iris root + iron + kraken's blood + lacquer + large cannon balls + leushite + lily of the valley + limes + lobelia + lorandite + madder + mangos + masuyite + medium cannon balls + moonstones + nettle + old man's beard + opals + papagoite + passion fruit + pearls + pineapples + pokeweed berries + pomegranates + rambutan + rubies + sail cloth + sapphires + sassafras + serandite + sincosite + small cannon balls + stone + sugar cane + swill + tellurium + thorianite + topazes + varnish + weld + wood + yarrow + +ocean Midnight + Coral + Angelfish Island + Delta Island + Meke Island + Park Island + Diamond + Alpha Island + Byrne Island + Cnossos Island + Oyster Island + Papaya Island + Turtle Island + Winter Solstice + Emerald + Emperor Island + Epsilon Island + Gaea Island + Guava Island + Spring Island + Tinga Island + Wrasse Island + Jet + Chaparral Island + Eclipse Island + Hephaestus' Forge + Lagniappe Island + Namath Island + Xi Island + Opal + Endurance Island + Nu Island + Orca Island + Waterberry + Pearl + Cleopatra's Pearls + Frond Island + Ostreum Island + Zeta Island + Ruby + Eta Island + Cranberry Island + Islay of Luthien + Jorvik Island + Midsummer + Sapphire + Beta Island + Iris Island + Remora Island + Vernal Equinox + +client ypp-sc-tools yarr + lastpage