X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-test.git;a=blobdiff_plain;f=pctb%2FCommods.pm;h=75d48c4ee9d2ed707d4da20268274cdbfe474546;hp=d59529b0a6b1eb0121d3761e45a5a34c42686993;hb=e3bd945bfba693d7467f28a2c59e77219387caa9;hpb=3ff1e35cbf0515fbc42a43476e7c8ec1834e8db6 diff --git a/pctb/Commods.pm b/pctb/Commods.pm index d59529b..75d48c4 100644 --- a/pctb/Commods.pm +++ b/pctb/Commods.pm @@ -1,6 +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; @@ -10,8 +32,14 @@ BEGIN { 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); + @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(); @@ -20,6 +48,8 @@ BEGIN { 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 @@ -51,7 +81,13 @@ sub parse_master_master1 ($$) { $oceans{$ocean}{$arch}{$_} .= $src; }; }); - } elsif (m/^client (\S+)$/) { + } elsif (m/^routes (\w+)$/) { + my $ocean= $1; + @ctx= (sub { + m/^(\S[^\t]*\S)\t+(\S[^\t]*\S)\t+([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 { @@ -84,11 +120,48 @@ 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; @@ -108,4 +181,118 @@ sub parse_pctb_commodmap () { 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;