yarrg/web/lookup

   1 <%doc>
   2
   3  This is part of the YARRG website.  YARRG is a tool and website
   4  for assisting players of Yohoho Puzzle Pirates.
   5
   6  Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
   7  Copyright (C) 2009 Clare Boothby
   8
   9   YARRG's client code etc. is covered by the ordinary GNU GPL (v3 or later).
  10   The YARRG website is covered by the GNU Affero GPL v3 or later, which
  11    basically means that every installation of the website will let you
  12    download the source.
  13
  14  This program is free software: you can redistribute it and/or modify
  15  it under the terms of the GNU Affero General Public License as
  16  published by the Free Software Foundation, either version 3 of the
  17  License, or (at your option) any later version.
  18
  19  This program is distributed in the hope that it will be useful,
  20  but WITHOUT ANY WARRANTY; without even the implied warranty of
  21  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22  GNU Affero General Public License for more details.
  23
  24  You should have received a copy of the GNU Affero General Public License
  25  along with this program.  If not, see <http://www.gnu.org/licenses/>.
  26
  27  Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
  28  are used without permission.  This program is not endorsed or
  29  sponsored by Three Rings.
  30
  31
  32  This Mason component generates the main `lookup' page, including
  33  all the entry boxes etc. for every query.
  34
  35
  36 </%doc>
  37 <%perl>
  38 my %a;
  39 my %ahtml;
  40 my @vars;
  41
  42 # for output:
  43 my @archipelagoes;
  44 my @islandids;
  45 my %islandid2;
  46
  47 #---------- "mode" argument parsing and mode menu at top of page ----------
  48
  49 # for debugging, invoke as
  50 #  http://www.chiark.greenend.org.uk/ucgi/~clareb/mason/pirates/pirate-route?debug=1
  51
  52 @vars= ({       Name => 'Ocean',
  53                 Before => 'Ocean: ',
  54                 CmpCanon => sub { ucfirst lc $_[0] },
  55                 Values => [ ocean_list() ]
  56         }, {    Name => 'Dropdowns',
  57                 Before => 'Interface: ',
  58                 CmpCanon => sub { !!$_[0] },
  59                 Values => [     [ 0, 'Type in names' ],
  60                                 [ 4, 'Select from menus' ] ]
  61         }, {    Name => 'Query',
  62                 Before => 'Query: ',
  63                 Values => [     [ 'route', 'Trades for route' ],
  64                                 [ 'age', 'Data age' ] ]
  65         });
  66
  67 foreach my $var (@vars) {
  68         my $name= $var->{Name};
  69         my $lname= lc $name;
  70         $var->{Before}= '' unless exists $var->{Before};
  71         $var->{CmpCanon}= sub { $_[0]; } unless exists $var->{CmpCanon};
  72         foreach my $val (@{ $var->{Values} }) {
  73                 next if ref $val;
  74                 $val= [ $val, encode_entities($val) ];
  75         }
  76         if (exists $ARGS{$lname}) {
  77                 $a{$name}= $ARGS{$lname};
  78                 my @html= grep { $_->[0] eq $a{$name} } @{ $var->{Values} };
  79                 $ahtml{$name}= @html==1 ? $html[0][1] : '???';
  80         } else {
  81                 $a{$name}= $var->{Values}[0][0];
  82                 $ahtml{$name}= $var->{Values}[0][1];
  83         }
  84 }
  85
  86 </%perl>
  87 <html><head><title><% ucfirst $ahtml{Query} %> - YARRG</title></head><body>
  88 <& webcopyright &>
  89
  90 <a href="<% $m->current_comp()->name() |u %>">YARRG</a> -
  91  Yet Another Revenue Research Gatherer
  92 |
  93 <a href="docs">documentation</a>
  94 <p>
  95 <%perl>
  96
  97 my %baseqf;
  98 foreach my $var (@vars) {
  99         my $lname= lc $var->{Name};
 100         next unless exists $ARGS{$lname};
 101         $baseqf{$lname}= $ARGS{$lname};
 102 }
 103
 104 my %queryqf;
 105 foreach my $var (keys %ARGS) {
 106         next unless $var =~
 107                 m/^(?:routestring|islandid\d|archipelago\d|debug)$/;
 108         my $val= $ARGS{$var};
 109         next if $val eq 'none';
 110         $queryqf{$var}= $val;
 111 }
 112
 113 my $quri= sub {
 114         my $uri= URI->new('lookup');
 115         $uri->query_form(@_);
 116         $uri->path_query();
 117 };
 118
 119 foreach my $var (@vars) {
 120         my $name= $var->{Name};
 121         my $lname= lc $var->{Name};
 122         my $delim= $var->{Before};
 123         my $canon= &{$var->{CmpCanon}}($a{$name});
 124         my $cvalix= 0;
 125         foreach my $valr (@{ $var->{Values} }) {
 126                 print $delim;  $delim= "\n|\n";
 127                 my ($value,$html) = @$valr;
 128                 my $iscurrent= &{$var->{CmpCanon}}($value) eq $canon;
 129                 my $after;
 130                 if ($iscurrent) {
 131                         print '<b>';
 132                         $after= '</b>';
 133                 } else {
 134                         my %qf= (%baseqf,%queryqf);
 135                         delete $qf{$lname};
 136                         $qf{$lname}= $value if $cvalix;
 137                         print '<a href="',$quri->(%qf),'">';
 138                         $after= '</a>';
 139                 }
 140                 print $html, $after;
 141                 $cvalix++;
 142         }
 143         print "<p>\n\n";
 144 }
 145
 146 #---------- initial checks, startup, main entry form ----------
 147
 148 dbw_connect($a{Ocean});
 149
 150 </%perl>
 151 <%args>
 152 $debug => 0
 153 $routestring => ''
 154 </%args>
 155
 156 <hr>
 157
 158 %########### query `route' ##########
 159 % if ($a{Query} eq 'route') {
 160
 161 <h1>Specify route</h1>
 162 <form action="<% $quri->() %>" method="get">
 163
 164 %#---------- textbox, user enters route as string ----------
 165 % if (!$a{Dropdowns}) {
 166
 167 Enter route (islands, or archipelagoes, separated by |s or commas;
 168  abbreviations are OK):<br/>
 169
 170 <script type="text/javascript">
 171 tr_uri= "routetextstring?format=json&type=text/xml"
 172                 + "&ocean=<% uri_escape($a{Ocean}) %>";
 173
 174 tr_timeout=false;
 175 tr_request=false;
 176 tr_done='';
 177 tr_needed='';
 178 function tr_Later(){
 179   window.clearTimeout(tr_timeout);
 180   tr_timeout = window.setTimeout(tr_Needed, 500);
 181 }
 182 function tr_Needed(){
 183   window.clearTimeout(tr_timeout);
 184   tr_element= document.getElementById('routestring');
 185   tr_needed= tr_element.value;
 186   tr_Request();
 187 }
 188 function tr_Request(){
 189   if (tr_request || tr_needed==tr_done) return;
 190   tr_done= tr_needed;
 191   tr_request= new XMLHttpRequest();
 192   uri= tr_uri+'&string='+encodeURIComponent(tr_needed);
 193   tr_request.open('GET', uri);
 194   tr_request.onreadystatechange= tr_Ready;
 195   tr_request.send(null);
 196 }
 197 function tr_Ready() {
 198   if (tr_request.readyState != 4) return;
 199   if (tr_request.status == 200) {
 200     response= tr_request.responseText;
 201     eval('results='+response);
 202     toedit= document.getElementById('routeresults');
 203     toedit.innerHTML= results.show;
 204   }
 205   tr_request= false;
 206   tr_Request();
 207 }
 208 window.onload= tr_Needed;
 209 </script>
 210
 211 <input type="text" id="routestring" name="routestring" size=80
 212  value="<% $routestring |h %>"
 213  onchange="tr_Needed();"
 214  onkeyup="tr_Later();"><br>
 215 <div id="routeresults">&nbsp;</div><br/>
 216
 217 % } else { #---------- dropdowns, user selects from menus ----------
 218
 219 <%perl>
 220 my ($sth,$row);;
 221 my @archlistdata;
 222 my %islandlistdata;
 223 $islandlistdata{'none'}= [ [ "none", "Select island..." ] ];
 224
 225 my $optionlistmap= sub {
 226         my ($optlist, $selected) = @_;
 227         my $out='';
 228         foreach my $entry (@$optlist) {
 229                 $out.= sprintf('<option value="%s" %s>%s</option>',
 230                         encode_entities($entry->[0]),
 231                         defined $selected && $entry->[0] eq $selected
 232                                 ? 'selected' : '',
 233                         encode_entities($entry->[1]));
 234         }
 235         return $out;
 236 };
 237
 238 my $dbh= dbw_connect($a{Ocean});
 239
 240 $sth= $dbh->prepare("SELECT DISTINCT archipelago FROM islands
 241                             ORDER BY archipelago;");
 242 $sth->execute();
 243
 244 while ($row=$sth->fetchrow_arrayref) {
 245         my ($arch)= @$row;
 246         push @archlistdata, [ $arch, $arch ];
 247         $islandlistdata{$arch}= [ [ "none", "Whole arch" ] ];
 248 }
 249
 250 $sth= $dbh->prepare("SELECT islandid,islandname,archipelago
 251                             FROM islands
 252                             ORDER BY islandname;");
 253 $sth->execute();
 254
 255 while ($row=$sth->fetchrow_arrayref) {
 256         my $arch= $row->[2];
 257         push @{ $islandlistdata{'none'} }, [ @$row ];
 258         push @{ $islandlistdata{$arch} }, [ @$row ];
 259         $islandid2{$row->[0]}= { Name => $row->[1], Arch => $arch };
 260 }
 261
 262 my %resetislandlistdata;
 263 foreach my $arch (keys %islandlistdata) {
 264         $resetislandlistdata{$arch}=
 265                 $optionlistmap->($islandlistdata{$arch}, '');
 266 }
 267
 268 </%perl>
 269
 270 <input type=hidden name=dropdowns value="<% $a{Dropdowns} |h %>">
 271
 272 <script type="text/javascript">
 273 ms_lists= <% to_json(\%resetislandlistdata) %>;
 274 function ms_Setarch(dd) {
 275   debug('ms_SetArch '+dd+' arch='+arch);
 276   var arch= document.getElementsByName('archipelago'+dd).item(0).value;
 277   var got= ms_lists[arch];
 278   if (got == undefined) return; // unknown arch ?  hrm
 279   debug('ms_SetArch '+dd+' arch='+arch+' got ok');
 280   var select= document.getElementsByName('islandid'+dd).item(0);
 281   select.innerHTML= got;
 282   debug('ms_SetArch '+dd+' arch='+arch+' innerHTML set');
 283 }
 284 </script>
 285
 286 <table style="table-layout:fixed; width:90%;">
 287
 288 <tr>
 289 %       for my $dd (0..$a{Dropdowns}-1) {
 290 <td>
 291 <select name="archipelago<% $dd %>" onchange="ms_Setarch(<% $dd %>)">
 292 <option value="none">Whole ocean</option>
 293 <% $optionlistmap->(\@archlistdata, $ARGS{"archipelago$dd"}) %></select></td>
 294 %       }
 295 </tr>
 296
 297 <tr>
 298 %       for my $dd (0..$a{Dropdowns}-1) {
 299 %               my $arch= $ARGS{"archipelago$dd"};
 300 %               $arch= 'none' if !defined $arch;
 301 <td>
 302 <select name="islandid<% $dd %>">
 303 <% $optionlistmap->($islandlistdata{$arch}, $ARGS{"islandid$dd"}) %>
 304 </select></td>
 305 %       }
 306 </tr>
 307
 308 </table>
 309
 310 % } #---------- end of dropdowns, now common middle of page code ----------
 311
 312 <input type=submit name=submit value="Go">
 313 </form>
 314
 315 <%perl>
 316 #========== result computations ==========
 317
 318 my $results_head;
 319 $results_head= sub {
 320         print "<h1>Results</h1>\n";
 321         $results_head= sub { };
 322 };
 323
 324 #---------- result computation - textstring ----------
 325 if (!$a{Dropdowns}) {
 326   if (length $routestring) {
 327         $results_head->();
 328         my $rsr= $m->comp('routetextstring',
 329                 ocean => $a{Ocean},
 330                 string => $routestring,
 331                 format => 'return'
 332         );
 333         if (length $rsr->{Error}) {
 334                 print encode_entities($rsr->{Error});
 335         } else {
 336                 foreach my $entry (@{ $rsr->{Results} }) {
 337                         push @archipelagoes,
 338                                 defined $entry->[1] ? undef : $entry->[0];
 339                         push @islandids, $entry->[1];
 340                 }
 341         }
 342   }
 343
 344 } else { #---------- results - dropdowns ----------
 345
 346 my $argorundef= sub {
 347         my ($dd,$base) = @_;
 348         my $thing= $ARGS{"${base}${dd}"};
 349         $thing= undef if defined $thing and $thing eq 'none';
 350         return $thing;
 351 };
 352
 353 for my $dd (0..$a{Dropdowns}-1) {
 354         my $arch= $argorundef->($dd,'archipelago');
 355         my $island= $argorundef->($dd,'islandid');
 356         next unless defined $arch or defined $island;
 357         if (defined $island and defined $arch) {
 358                 my $ii= $islandid2{$island};
 359                 my $iarch= $ii->{Arch};
 360                 if ($iarch ne $arch) {
 361                         $results_head->();
 362 </%perl>
 363  Specified archipelago <% $arch %> but
 364  island <% $ii->{Name} %>
 365  which is in <% $iarch %>; using the island.<br>
 366 <%perl>
 367                 }
 368                 $arch= undef;
 369         }
 370         push @archipelagoes, $arch;
 371         push @islandids, $island;
 372 }
 373
 374 }#---------- result processing, common stuff
 375 </%perl>
 376
 377 % if (@islandids) {
 378 %       $results_head->();
 379
 380 <& routetrade, islandids => \@islandids, archipelagoes => \@archipelagoes &>
 381
 382 % }
 383
 384 % } elsif ($a{Query} eq 'age') {
 385 % ########### query `age' ##########
 386
 387 <h1>Market data age</h1>
 388 <& dataage, %baseqf, %queryqf &>
 389
 390 % } ########## end of `age' query ##########
 391
 392 %#---------- debugging and epilogue ----------
 393
 394 % if ($debug) {
 395 <p>
 396 <pre id="debug_log">
 397 Debug log:
 398 </pre>
 399 % }
 400
 401 <script type="text/javascript">
 402 function debug (m) {
 403 % if ($debug) {
 404   var node= document.getElementById('debug_log');
 405   node.innerHTML += "\n" + m + "\n";
 406 % }
 407 }
 408 </script>
 409
 410 <& footer &>
 411
 412 <%init>
 413 use CommodsWeb;
 414 use HTML::Entities;
 415 use URI::Escape;
 416 use JSON;
 417
 418 </%init>