chiark / gitweb /
Fix up search too long error message - really
[ypp-sc-tools.db-test.git] / yarrg / database-info-fetch
1 #!/usr/bin/perl -w
2
3 # helper program for determining pixmap resolution options
4
5 # This is part of ypp-sc-tools, a set of third-party tools for assisting
6 # players of Yohoho Puzzle Pirates.
7 #
8 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
9 #
10 # This program is free software: you can redistribute it and/or modify
11 # it under the terms of the GNU General Public License as published by
12 # the Free Software Foundation, either version 3 of the License, or
13 # (at your option) any later version.
14 #
15 # This program is distributed in the hope that it will be useful,
16 # but WITHOUT ANY WARRANTY; without even the implied warranty of
17 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 # GNU General Public License for more details.
19 #
20 # You should have received a copy of the GNU General Public License
21 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
22 #
23 # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
24 # are used without permission.  This program is not endorsed or
25 # sponsored by Three Rings.
26
27 use strict (qw(vars));
28 use JSON;
29 #use Data::Dumper;
30 use IO::File;
31
32 use Commods;
33
34 @ARGV>=1 or die "You probably don't want to run this program directly.\n";
35 our ($which) = shift @ARGV;
36
37 $which =~ s/\W//g;
38
39 our ($pctb) = $ENV{'YPPSC_YARRG_PCTB'};
40 our ($ua)= http_useragent("database_info_fetch $which");
41 our $jsonresp;
42
43 sub jparsetable ($$) {
44     my ($jobj,$wh) = @_;
45     my $jtab= $jobj->{$wh};
46     die "$jsonresp $wh ?" unless defined $jtab;
47     my $cns= $jtab->{'colNames'};  die "$jsonresp $wh ?" unless defined $cns;
48     my $ad= $jtab->{'arrayData'};  die "$jsonresp $wh ?" unless defined $ad;
49     my @o=();
50     foreach my $ai (@$ad) {
51         @$ai == @$cns or die "$jsonresp $wh ".scalar(@o)."?";
52         my $v= { };
53         for (my $i=0; $i<@$cns; $i++) {
54             $v->{$cns->[$i]} = $ai->[$i];
55         }
56         push @o, $v;
57     }
58     return @o;
59 }
60 sub sort_by_name {
61     sort {
62         $a->{'name'} cmp $b->{'name'};
63     } @_;
64 }
65
66 sub p ($) { print $_[0] or die $!; }
67 sub ptcl ($) {
68     local ($_) = @_;
69     die "$_ $& ?" if m/[^-+'"# 0-9a-z]/i;
70     p("{$_[0]}");
71 }
72
73 sub json_convert_shim ($) {
74     my ($json) = @_;
75     # In JSON.pm 2.x, jsonToObj prints a warning to stderr which
76     # our callers don't like at all.
77     if ($JSON::VERSION >= 2.0) {
78         return from_json($json);
79     } else {
80         return jsonToObj($json);
81     }
82 }
83
84 sub get_arches_islands_pctb ($) {
85     my ($ocean)= @_;
86     die unless $pctb;
87     my $url= "$pctb/islands.php?oceanName=".uc $ocean;
88     my $resp= $ua->get($url);
89     die $resp->status_line unless $resp->is_success;
90     $jsonresp= $resp->content;
91     my $jobj= json_convert_shim($resp->content);
92     my $arches= [ jparsetable($jobj, 'arches') ];
93     my $islands= [ jparsetable($jobj, 'islands') ];
94
95     my $islands_done=0;
96     foreach my $arch (@$arches) {
97 #       print Dumper($arnch);
98         my $aname= $arch->{'name'};
99         die "$jsonresp ?" unless defined $aname;
100
101         foreach my $island (@$islands) {
102             my $iname= $island->{'name'};
103             die "$jsonresp $aname ?" unless defined $iname;
104             next unless $arch->{'id'} == $island->{'arch'};
105
106             $oceans{$ocean}{$aname}{$iname} .= 'b';
107             
108             $islands_done++;
109         }
110     }
111     die "$jsonresp $islands_done ?" unless $islands_done == @$islands;
112 }
113
114 sub get_ocean () {
115     my $ocean= $ENV{'YPPSC_OCEAN'};  die unless $ocean;
116     return ucfirst lc $ocean;
117 }
118
119 sub for_islands ($$$$) {
120     my ($ocean,$forarch,$forisle,$endarch) = @_;
121
122     my $arches= $oceans{$ocean};
123     foreach my $aname (sort keys %$arches) {
124         &$forarch($ocean,$aname);
125         my $islands= $arches->{$aname};
126         foreach my $iname (sort keys %$islands) {
127             &$forisle($ocean,$aname,$iname);
128         }
129         &$endarch();
130     }
131 }
132
133 sub for_commods ($) {
134     my ($forcommod) = @_;
135     foreach my $commod (sort keys %commods) { &$forcommod($commod); }
136 }
137
138 sub compare_sources_one ($$) {
139     my ($srcs,$what) = @_;
140     return if $srcs =~ m,^sl?(?:\%sl?)*b$,;
141     print "srcs=$srcs $what\n";
142 }
143
144 sub main__comparesources () {
145     my $ocean= get_ocean();
146     
147     parse_info_clientside();
148     get_arches_islands_pctb($ocean);
149     parse_pctb_commodmap() or die;
150
151     for_islands($ocean,
152                 sub { },
153                 sub {
154                     my ($ocean,$a,$i)= @_;
155                     my $srcs= $oceans{$ocean}{$a}{$i};
156                     compare_sources_one($srcs, "island $ocean / $a / $i");
157                 },
158                 sub { });
159     for_commods(sub {
160                     my ($commod)= @_;
161                     my $srcs= $commods{$commod}{Srcs};
162                     compare_sources_one($srcs, "commodity $commod");
163                 });
164 }
165
166 sub main__island () {
167     my $ocean= get_ocean();
168     
169     parse_info_clientside() if $ENV{'YPPSC_YARRG_YARRG'};
170     get_arches_islands_pctb($ocean) if $pctb;
171
172     for_islands($ocean,
173                 sub {
174                     my ($ocean,$aname)= @_;
175                     ptcl($aname); p(' '); ptcl($aname); p(" {\n");
176                 },
177                 sub {
178                     my ($ocean,$aname,$iname)= @_;
179                     p('    '); ptcl($iname); p(' '); ptcl($iname); p("\n");
180                 },
181                 sub {
182                     p("}\n");
183                 });
184 }
185
186 sub main__timestamp () {
187     my %o;
188     $o{'requesttimestamp'}= '1';
189     my $respcontent= yarrgpostform($ua, \%o);
190     $respcontent =~ m/^OK ([1-9]\d{1,20})\./ or die "$respcontent ?";
191     print "$1\n";
192     exit(0);
193 }
194
195 sub main__yarrgversion () {
196     printf "%s\n", version_core();
197 }
198
199 sub main__useragentstringmap ($$) {
200     printf "%s\n", http_useragent_string_map($_[0], $_[1]);
201 }
202
203 sub main__sunshinewidget () {
204     print <<END
205 Land {On land} {
206     Crew   Crew
207     Shoppe Shoppe
208     Ye     Ye
209     Booty  Booty
210     Ahoy!  Ahoy!
211 }
212 Vessel {On board a ship} {
213     Crew   Crew
214     Vessel Vessel
215     Ye     Ye
216     Booty  Booty
217     Ahoy!  Ahoy!
218 }
219 END
220     or die $!;
221 }
222
223 &{"main__$which"}(@ARGV);