3 # helper program for determining pixmap resolution options
5 # This is part of ypp-sc-tools, a set of third-party tools for assisting
6 # players of Yohoho Puzzle Pirates.
8 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
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.
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.
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/>.
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.
27 BEGIN { unshift @INC, qw(.) }
29 use strict (qw(vars));
36 @ARGV>=1 or die "You probably don't want to run this program directly.\n";
37 our ($which) = shift @ARGV;
41 our ($pctb) = $ENV{'YPPSC_YARRG_PCTB'};
42 our ($ua)= http_useragent("database_info_fetch $which");
45 sub jparsetable ($$) {
47 my $jtab= $jobj->{$wh};
48 die "$jsonresp $wh ?" unless defined $jtab;
49 my $cns= $jtab->{'colNames'}; die "$jsonresp $wh ?" unless defined $cns;
50 my $ad= $jtab->{'arrayData'}; die "$jsonresp $wh ?" unless defined $ad;
52 foreach my $ai (@$ad) {
53 @$ai == @$cns or die "$jsonresp $wh ".scalar(@o)."?";
55 for (my $i=0; $i<@$cns; $i++) {
56 $v->{$cns->[$i]} = $ai->[$i];
64 $a->{'name'} cmp $b->{'name'};
68 sub p ($) { print $_[0] or die $!; }
71 die "$_ $& ?" if m/[^-+'"# 0-9a-z]/i;
75 sub json_convert_shim ($) {
77 # In JSON.pm 2.x, jsonToObj prints a warning to stderr which
78 # our callers don't like at all.
79 if ($JSON::VERSION >= 2.0) {
80 return from_json($json);
82 return jsonToObj($json);
86 sub get_arches_islands_pctb ($) {
89 my $url= "$pctb/islands.php?oceanName=".uc $ocean;
90 my $resp= $ua->get($url);
91 die $resp->status_line unless $resp->is_success;
92 $jsonresp= $resp->content;
93 my $jobj= json_convert_shim($resp->content);
94 my $arches= [ jparsetable($jobj, 'arches') ];
95 my $islands= [ jparsetable($jobj, 'islands') ];
98 foreach my $arch (@$arches) {
99 # print Dumper($arnch);
100 my $aname= $arch->{'name'};
101 die "$jsonresp ?" unless defined $aname;
103 foreach my $island (@$islands) {
104 my $iname= $island->{'name'};
105 die "$jsonresp $aname ?" unless defined $iname;
106 next unless $arch->{'id'} == $island->{'arch'};
108 $oceans{$ocean}{$aname}{$iname} .= 'b';
113 die "$jsonresp $islands_done ?" unless $islands_done == @$islands;
117 my $ocean= $ENV{'YPPSC_OCEAN'}; die unless $ocean;
118 return ucfirst lc $ocean;
121 sub for_islands ($$$$) {
122 my ($ocean,$forarch,$forisle,$endarch) = @_;
124 my $arches= $oceans{$ocean};
125 foreach my $aname (sort keys %$arches) {
126 &$forarch($ocean,$aname);
127 my $islands= $arches->{$aname};
128 foreach my $iname (sort keys %$islands) {
129 &$forisle($ocean,$aname,$iname);
135 sub for_commods ($) {
136 my ($forcommod) = @_;
137 foreach my $commod (sort keys %commods) { &$forcommod($commod); }
140 sub compare_sources_one ($$) {
141 my ($srcs,$what) = @_;
142 return if $srcs =~ m,^sl?(?:\%sl?)*b$,;
143 print "srcs=$srcs $what\n";
146 sub main__comparesources () {
147 my $ocean= get_ocean();
149 parse_info_clientside();
150 get_arches_islands_pctb($ocean);
151 parse_pctb_commodmap() or die;
156 my ($ocean,$a,$i)= @_;
157 my $srcs= $oceans{$ocean}{$a}{$i};
158 compare_sources_one($srcs, "island $ocean / $a / $i");
163 my $srcs= $commods{$commod}{Srcs};
164 compare_sources_one($srcs, "commodity $commod");
168 sub main__island () {
169 my $ocean= get_ocean();
171 parse_info_clientside() if $ENV{'YPPSC_YARRG_YARRG'};
172 get_arches_islands_pctb($ocean) if $pctb;
176 my ($ocean,$aname)= @_;
177 ptcl($aname); p(' '); ptcl($aname); p(" {\n");
180 my ($ocean,$aname,$iname)= @_;
181 p(' '); ptcl($iname); p(' '); ptcl($iname); p("\n");
188 sub main__timestamp () {
190 $o{'requesttimestamp'}= '1';
191 my $respcontent= yarrgpostform($ua, \%o);
192 $respcontent =~ m/^OK ([1-9]\d{1,20})\./ or die "$respcontent ?";
197 sub main__yarrgversion () {
198 printf "%s\n", version_core();
201 sub main__useragentstringmap ($$) {
202 printf "%s\n", http_useragent_string_map($_[0], $_[1]);
205 sub main__sunshinewidget () {
214 Vessel {On board a ship} {
225 &{"main__$which"}(@ARGV);