X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?a=blobdiff_plain;f=pctb%2FCommods.pm;h=b348c17812373ab72405c9eebdfd8a0a4c56c977;hb=3b69b2e8a477a5d0544717dc86aad22498347060;hp=dee9fbed5ab45368da33416d9bf2fe20812b381c;hpb=38e3d1bf1be975c8edd6a166106ab2729d15249c;p=ypp-sc-tools.db-live.git diff --git a/pctb/Commods.pm b/pctb/Commods.pm index dee9fbe..b348c17 100644 --- a/pctb/Commods.pm +++ b/pctb/Commods.pm @@ -1,5 +1,28 @@ +# 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. package Commods; +use IO::File; +use HTTP::Request::Common (); use strict; use warnings; @@ -9,17 +32,29 @@ BEGIN { our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); $VERSION = 1.00; @ISA = qw(Exporter); - @EXPORT = qw(%oceans %commods &parse_masters); + @EXPORT = qw(&parse_masters &parse_masters_ocean + %oceans %commods %clients %routes %route_mysteries + &parse_pctb_commodmap %pctb_commodmap @pctb_commodmap + &get_our_version &check_tsv_line + &pipethrough_prep &pipethrough_run + &pipethrough_run_along &pipethrough_run_finish + &pipethrough_run_gzip + &cgipostform); %EXPORT_TAGS = ( ); @EXPORT_OK = qw(); } -our %oceans; # eg $oceans{'Midnight'}{'Ruby'}{'Eta Island'}= $sources +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) ]; +our %routes; # eg $routes{'Midnight'}{'Orca'}{'Tinga'}= $sources NB abbrevs! +our %route_mysteries; # eg $route_mysteries{'Midnight'}{'Norse'}= 3 # $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' @@ -46,6 +81,19 @@ sub parse_master_master1 ($$) { $oceans{$ocean}{$arch}{$_} .= $src; }; }); + } elsif (m/^routes (\w+)$/) { + my $ocean= $1; + @ctx= (sub { + m/^(\S[^\t]*\S),\s*(\S[^\t]*\S),\s*([1-9][0-9]{0,2})$/ or die; + $routes{$ocean}{$1}{$2}= $3; + }); + } 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]; @@ -72,10 +120,179 @@ sub parse_master_master1 ($$) { } }; foreach (@rawcm) { &$ca($_,$src); } + + foreach my $on (keys %routes) { + my $routes= $routes{$on}; + my $ocean= $oceans{$on}; + die unless defined $ocean; + + my @allislands; + foreach my $an (sort keys %$ocean) { + my $arch= $ocean->{$an}; + push @allislands, sort keys %$arch; + } + parse_master_map_route_islands($on, \@allislands, $routes); + foreach my $route (values %$routes) { + parse_master_map_route_islands($on, \@allislands, $route); + } + } +} + +sub parse_master_map_route_islands ($$$) { + my ($on, $allislands, $routemap) = @_;; + foreach my $k (sort keys %$routemap) { + my @ok= grep { index($_,$k) >= 0 } @$allislands; + die "ambiguous $k" if @ok>1; + if (!@ok) { + $route_mysteries{$on}{$k}++; + delete $routemap->{$k}; + } elsif ($ok[0] ne $k) { + $routemap->{$ok[0]}= $routemap->{$k}; + delete $routemap->{$k}; + } + } } sub parse_masters () { parse_master_master1('master-master.txt','s'); } +sub parse_masters_ocean ($) { + my ($oceanname) = @_; + parse_master_master1('master-master.txt','s'); + die "unknown ocean $oceanname ?" unless exists $oceans{$oceanname}; + parse_master_master1("ocean-".(lc $oceanname).".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 ($aref,$prefix) = @_; + $aref->{"${prefix}name"}= 'ypp-sc-tools yarrg'; + $aref->{"${prefix}fixes"}= 'lastpage'; + + my $version= `git-describe --tags HEAD`; $? and die $?; + chomp($version); + $aref->{"${prefix}version"}= $version; + return $aref; +} + +sub pipethrough_prep () { + my $tf= IO::File::new_tmpfile() or die $!; + return $tf; +} + +sub pipethrough_run_along ($$$@) { + my ($tf, $childprep, $cmd, @a) = @_; + $tf->flush or die $!; + $tf->seek(0,0) or die $!; + my $fh= new IO::File; + my $child= $fh->open("-|"); defined $child or die $!; + if (!$child) { + open STDIN, "<&", $tf; + &$childprep() if defined $childprep; + exec $cmd @a; die $!; + } + return $fh; +} +sub pipethrough_run_finish ($) { + my ($fh)= @_; + $fh->error and die $!; + close $fh or die "$! $?"; die $? if $?; +} + +sub pipethrough_run ($$$@) { + my ($tf, $childprep, $cmd, @a) = @_; + my $pt= pipethrough_run_along($tf,$childprep,$cmd,@a); + my $r; + { undef $/; $!=0; $r= <$pt>; } + defined $r or die $!; + pipethrough_run_finish($pt); + return $r; +} +sub pipethrough_run_gzip ($) { + pipethrough_run($_[0],undef,'gzip','gzip'); +} + +sub cgipostform ($$$) { + my ($ua, $url, $form) = @_; + my $req= HTTP::Request::Common::POST($url, + Content => $form, + Content_Type => 'form-data'); + if ($url =~ m,^\.?/,) { + my $tf= pipethrough_prep(); + print $tf $req->content() or die $!; +#print STDERR "[[[",$req->content(),"]]]"; + my $out= pipethrough_run($tf, sub { + $ENV{'REQUEST_METHOD'}= 'POST'; + $ENV{'QUERY_STRING'}= ''; + $ENV{'PATH_TRANSLATED'}= $url; + $ENV{'PATH_INFO'}= ''; + $ENV{'HTTP_HOST'}= 'localhost'; + $ENV{'REMOTE_ADDR'}= '127.0.0.1'; + $ENV{'GATEWAY_INTERFACE'}= 'CGI/1.1'; + $ENV{'DOCUMENT_ROOT'}= '.'; + $ENV{'SCRIPT_FILENAME'}= $url; + $ENV{'SCRIPT_NAME'}= $url; + $ENV{'HTTP_USER_AGENT'}= 'Commods.pm local test'; + + foreach my $f (qw(Content_Length Content_Type)) { + $ENV{uc $f}= $req->header($f); + } +#system 'printenv >&2'; + }, "$url", "$url"); + $out =~ s/\r\n/\n/g; + $out =~ m,^Content-Type: text/plain.*\n\n, or die "$out ?"; + return $'; + } else { + my $resp= $ua->request($url,$req); + die $resp->status_line unless $resp->is_success; + return $resp->content(); + } +} + +our %check_tsv_done; + +sub check_tsv_line ($$) { + my ($l, $bad_data_callback) = @_; + my $bad_data= sub { &$bad_data_callback("bad data: line $.: $_[0]"); }; + + chomp($l) or &$bad_data('missing end-of-line'); + + $l !~ m/\P{IsPrint}/ or &$bad_data('nonprinting char(s)'); + $l !~ m/\\/ or &$bad_data('data contains backslashes'); + my @v= split /\t/, $l, -1; + @v==6 or &$bad_data('wrong number of fields'); + my ($commod,$stall) = @v; + + !keys %commods or + defined $commods{$commod} or + &$bad_data("unknown commodity \`$commod'"); + + $stall =~ m/^\p{IsUpper}|^[0-9]/ or &$bad_data("stall not capitalised"); + !exists $check_tsv_done{$commod,$stall} or &$bad_data("repeated data"); + $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"); + } + return @v; +} 1;