chiark / gitweb /
5e0576095a0b23ac7aa837a1d91ff72132f0c3c2
[ypp-sc-tools.main.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 LWP::UserAgent;
29 use JSON;
30 #use Data::Dumper;
31 use IO::File;
32
33 use Commods;
34
35 @ARGV>=1 or die "You probably don't want to run this program directly.\n";
36 our ($which) = shift @ARGV;
37
38 $which =~ s/\W//g;
39
40 our ($pctb) = $ENV{'YPPSC_YARRG_PCTB'};
41 our ($ua)= LWP::UserAgent->new;
42 our $jsonresp;
43
44 sub jparsetable ($$) {
45     my ($jobj,$wh) = @_;
46     my $jtab= $jobj->{$wh};
47     die "$jsonresp $wh ?" unless defined $jtab;
48     my $cns= $jtab->{'colNames'};  die "$jsonresp $wh ?" unless defined $cns;
49     my $ad= $jtab->{'arrayData'};  die "$jsonresp $wh ?" unless defined $ad;
50     my @o=();
51     foreach my $ai (@$ad) {
52         @$ai == @$cns or die "$jsonresp $wh ".scalar(@o)."?";
53         my $v= { };
54         for (my $i=0; $i<@$cns; $i++) {
55             $v->{$cns->[$i]} = $ai->[$i];
56         }
57         push @o, $v;
58     }
59     return @o;
60 }
61 sub sort_by_name {
62     sort {
63         $a->{'name'} cmp $b->{'name'};
64     } @_;
65 }
66
67 sub p ($) { print $_[0] or die $!; }
68 sub ptcl ($) {
69     local ($_) = @_;
70     die "$_ $& ?" if m/[^-+'"# 0-9a-z]/i;
71     p("{$_[0]}");
72 }
73
74 sub json_convert_shim ($) {
75     my ($json) = @_;
76     # In JSON.pm 2.x, jsonToObj prints a warning to stderr which
77     # our callers don't like at all.
78     if ($JSON::VERSION >= 2.0) {
79         return from_json($json);
80     } else {
81         return jsonToObj($json);
82     }
83 }
84
85 sub get_arches_islands_pctb ($) {
86     my ($ocean)= @_;
87     die unless $pctb;
88     my $url= "$pctb/islands.php?oceanName=".uc $ocean;
89     my $resp= $ua->get($url);
90     die $resp->status_line unless $resp->is_success;
91     $jsonresp= $resp->content;
92     my $jobj= json_convert_shim($resp->content);
93     my $arches= [ jparsetable($jobj, 'arches') ];
94     my $islands= [ jparsetable($jobj, 'islands') ];
95
96     my $islands_done=0;
97     foreach my $arch (@$arches) {
98 #       print Dumper($arnch);
99         my $aname= $arch->{'name'};
100         die "$jsonresp ?" unless defined $aname;
101
102         foreach my $island (@$islands) {
103             my $iname= $island->{'name'};
104             die "$jsonresp $aname ?" unless defined $iname;
105             next unless $arch->{'id'} == $island->{'arch'};
106
107             $oceans{$ocean}{$aname}{$iname} .= 'b';
108             
109             $islands_done++;
110         }
111     }
112     die "$jsonresp $islands_done ?" unless $islands_done == @$islands;
113 }
114
115 sub get_ocean () {
116     my $ocean= $ENV{'YPPSC_OCEAN'};  die unless $ocean;
117     return ucfirst lc $ocean;
118 }
119
120 sub for_islands ($$$$) {
121     my ($ocean,$forarch,$forisle,$endarch) = @_;
122
123     my $arches= $oceans{$ocean};
124     foreach my $aname (sort keys %$arches) {
125         &$forarch($ocean,$aname);
126         my $islands= $arches->{$aname};
127         foreach my $iname (sort keys %$islands) {
128             &$forisle($ocean,$aname,$iname);
129         }
130         &$endarch();
131     }
132 }
133
134 sub for_commods ($) {
135     my ($forcommod) = @_;
136     foreach my $commod (sort keys %commods) { &$forcommod($commod); }
137 }
138
139 sub compare_sources_one ($$) {
140     my ($srcs,$what) = @_;
141     return if $srcs =~ m,^sl?(?:\%sl?)*b$,;
142     print "srcs=$srcs $what\n";
143 }
144
145 sub main__comparesources () {
146     my $ocean= get_ocean();
147     
148     parse_info_clientside();
149     get_arches_islands_pctb($ocean);
150     parse_pctb_commodmap() or die;
151
152     for_islands($ocean,
153                 sub { },
154                 sub {
155                     my ($ocean,$a,$i)= @_;
156                     my $srcs= $oceans{$ocean}{$a}{$i};
157                     compare_sources_one($srcs, "island $ocean / $a / $i");
158                 },
159                 sub { });
160     for_commods(sub {
161                     my ($commod)= @_;
162                     my $srcs= $commods{$commod}{Srcs};
163                     compare_sources_one($srcs, "commodity $commod");
164                 });
165 }
166
167 sub main__island () {
168     my $ocean= get_ocean();
169     
170     parse_info_clientside();
171     get_arches_islands_pctb($ocean);
172
173     for_islands($ocean,
174                 sub {
175                     my ($ocean,$aname)= @_;
176                     ptcl($aname); p(' '); ptcl($aname); p(" {\n");
177                 },
178                 sub {
179                     my ($ocean,$aname,$iname)= @_;
180                     p('    '); ptcl($iname); p(' '); ptcl($iname); p("\n");
181                 },
182                 sub {
183                     p("}\n");
184                 });
185 }
186
187 sub main__timestamp () {
188     my %o;
189     $o{'requesttimestamp'}= '1';
190     my $respcontent= yarrgpostform($ua, \%o);
191     $respcontent =~ m/^OK ([1-9]\d{1,20})\./ or die "$respcontent ?";
192     print "$1\n";
193     exit(0);
194 }
195
196 sub main__sunshinewidget () {
197     print <<END
198 Land {On land} {
199     Crew   Crew
200     Shoppe Shoppe
201     Ye     Ye
202     Booty  Booty
203     Ahoy!  Ahoy!
204 }
205 Vessel {On board a ship} {
206     Crew   Crew
207     Vessel Vessel
208     Ye     Ye
209     Booty  Booty
210     Ahoy!  Ahoy!
211 }
212 END
213     or die $!;
214 }
215
216 &{"main__$which"}(@ARGV);