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