--- /dev/null
+
+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;
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}
}
-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,/*$,,;
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 =>
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;
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";
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};
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 {
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;
--- /dev/null
+#!/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 <ijackson@chiark.greenend.org.uk>
+#
+# 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 <http://www.gnu.org/licenses/>.
+#
+# 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 (<GZ>) {
+ !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 $?");
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;
}
}
-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;
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 <<END
Land {On land} {
or die $!;
}
-&{"main__$which"}();
+&{"main__$which"}(@ARGV);
-#!/usr/bin/perl
+#!/usr/bin/perl -w
# This specific file is hereby placed in the public domain, or nearest
# equivalent in law, by me, Ian Jackson. 5th July 2009.
-use IO::Handle;
+use IO::File;
+use strict (qw(vars));
-open CM, "_commodmap.tsv" or die $!;
+use Commods;
+
+our ($debug)= 0;
$debug=1 if @ARGV;
-while (<CM>) {
- 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)= @_;
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";
}
$|=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 $!;
}
}
-$r= read STDIN,$b,1;
+my $r= read STDIN,$b,1;
STDIN->error and die $!;
STDIN->eof or die;
$b and die;
--- /dev/null
+
+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
~yarrgweb / ypp-sc-tools.db-test.git / commitdiff