X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?a=blobdiff_plain;ds=sidebyside;f=pctb%2FCommods.pm;fp=pctb%2FCommods.pm;h=0000000000000000000000000000000000000000;hb=c68fb80a6bbf7acbcac4b2cb2143f5fea745cd2b;hp=955446f402f48719943af31844cc17e9742649a1;hpb=b9cce976550d000f15e5a8f2b690740bdae1e468;p=ypp-sc-tools.web-live.git diff --git a/pctb/Commods.pm b/pctb/Commods.pm deleted file mode 100644 index 955446f..0000000 --- a/pctb/Commods.pm +++ /dev/null @@ -1,305 +0,0 @@ -# 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; - -BEGIN { - use Exporter (); - our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); - $VERSION = 1.00; - @ISA = qw(Exporter); - @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 %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' - -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/^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]; - &{ $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); } - - 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 "@a $!"; - } - return $fh; -} -sub pipethrough_run_finish ($$) { - my ($fh, $what)= @_; - $fh->error and die $!; - close $fh or die "$what $! $?"; 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, "@a"); - 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)'); - 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"); - } - - foreach my $i (2,4) { - &$bad_data("price with no qty or vice versa (field $i)") - if length($v[$i]) xor length($v[$i+1]); - } - length($v[2]) or length($v[4]) or - &$bad_data("commodity entry with no buy or sell offer"); - - return @v; -} - -1;