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 </%perl>
 138 <a href="<% $quri->(%qf) |h %>">
 139 <%perl>
 140                         $after= '</a>';
 141                 }
 142                 print $html, $after;
 143                 $cvalix++;
 144         }
 145         print "<p>\n\n";
 146 }
 147
 148 #---------- initial checks, startup, main entry form ----------
 149
 150 dbw_connect($a{Ocean});
 151
 152 </%perl>
 153 <%args>
 154 $debug => 0
 155 $routestring => ''
 156 </%args>
 157
 158 <hr>
 159
 160 %########### query `route' ##########
 161 % if ($a{Query} eq 'route') {
 162
 163 <h1>Specify route</h1>
 164 <form action="<% $quri->() |h %>" method="get">
 165
 166 %#---------- textbox, user enters route as string ----------
 167 % if (!$a{Dropdowns}) {
 168
 169 Enter route (islands, or archipelagoes, separated by |s or commas;
 170  abbreviations are OK):<br>
 171
 172 <&| script &>
 173 tr_uri= "routetextstring?format=json&type=text/xml"
 174                 + "&ocean=<% uri_escape($a{Ocean}) %>";
 175
 176 tr_timeout=false;
 177 tr_request=false;
 178 tr_done='';
 179 tr_needed='';
 180 function tr_Later(){
 181   window.clearTimeout(tr_timeout);
 182   tr_timeout = window.setTimeout(tr_Needed, 500);
 183 }
 184 function tr_Needed(){
 185   window.clearTimeout(tr_timeout);
 186   tr_element= document.getElementById('routestring');
 187   tr_needed= tr_element.value;
 188   tr_Request();
 189 }
 190 function tr_Request(){
 191   if (tr_request || tr_needed==tr_done) return;
 192   tr_done= tr_needed;
 193   tr_request= new XMLHttpRequest();
 194   uri= tr_uri+'&string='+encodeURIComponent(tr_needed);
 195   tr_request.open('GET', uri);
 196   tr_request.onreadystatechange= tr_Ready;
 197   tr_request.send(null);
 198 }
 199 function tr_Ready() {
 200   if (tr_request.readyState != 4) return;
 201   if (tr_request.status == 200) {
 202     response= tr_request.responseText;
 203     eval('results='+response);
 204     toedit= document.getElementById('routeresults');
 205     toedit.innerHTML= results.show;
 206   }
 207   tr_request= false;
 208   tr_Request();
 209 }
 210 window.onload= tr_Needed;
 211 </&script>
 212
 213 <input type="text" id="routestring" name="routestring" size=80
 214  value="<% $routestring |h %>"
 215  onchange="tr_Needed();"
 216  onkeyup="tr_Later();"><br>
 217 <div id="routeresults">&nbsp;</div><br>
 218
 219 % } else { #---------- dropdowns, user selects from menus ----------
 220
 221 <%perl>
 222 my ($sth,$row);;
 223 my @archlistdata;
 224 my %islandlistdata;
 225 $islandlistdata{'none'}= [ [ "none", "Select island..." ] ];
 226
 227 my $optionlistmap= sub {
 228         my ($optlist, $selected) = @_;
 229         my $out='';
 230         foreach my $entry (@$optlist) {
 231                 $out.= sprintf('<option value="%s" %s>%s</option>',
 232                         encode_entities($entry->[0]),
 233                         defined $selected && $entry->[0] eq $selected
 234                                 ? 'selected' : '',
 235                         encode_entities($entry->[1]));
 236         }
 237         return $out;
 238 };
 239
 240 my $dbh= dbw_connect($a{Ocean});
 241
 242 $sth= $dbh->prepare("SELECT DISTINCT archipelago FROM islands
 243                             ORDER BY archipelago;");
 244 $sth->execute();
 245
 246 while ($row=$sth->fetchrow_arrayref) {
 247         my ($arch)= @$row;
 248         push @archlistdata, [ $arch, $arch ];
 249         $islandlistdata{$arch}= [ [ "none", "Whole arch" ] ];
 250 }
 251
 252 $sth= $dbh->prepare("SELECT islandid,islandname,archipelago
 253                             FROM islands
 254                             ORDER BY islandname;");
 255 $sth->execute();
 256
 257 while ($row=$sth->fetchrow_arrayref) {
 258         my $arch= $row->[2];
 259         push @{ $islandlistdata{'none'} }, [ @$row ];
 260         push @{ $islandlistdata{$arch} }, [ @$row ];
 261         $islandid2{$row->[0]}= { Name => $row->[1], Arch => $arch };
 262 }
 263
 264 my %resetislandlistdata;
 265 foreach my $arch (keys %islandlistdata) {
 266         $resetislandlistdata{$arch}=
 267                 $optionlistmap->($islandlistdata{$arch}, '');
 268 }
 269
 270 </%perl>
 271
 272 <input type=hidden name=dropdowns value="<% $a{Dropdowns} |h %>">
 273
 274 <&| script &>
 275 ms_lists= <% to_json_protecttags(\%resetislandlistdata) %>;
 276 function ms_Setarch(dd) {
 277   debug('ms_SetArch '+dd+' arch='+arch);
 278   var arch= document.getElementsByName('archipelago'+dd).item(0).value;
 279   var got= ms_lists[arch];
 280   if (got == undefined) return; // unknown arch ?  hrm
 281   debug('ms_SetArch '+dd+' arch='+arch+' got ok');
 282   var select= document.getElementsByName('islandid'+dd).item(0);
 283   select.innerHTML= got;
 284   debug('ms_SetArch '+dd+' arch='+arch+' innerHTML set');
 285 }
 286 </&script>
 287
 288 <table style="table-layout:fixed; width:90%;">
 289
 290 <tr>
 291 %       for my $dd (0..$a{Dropdowns}-1) {
 292 <td>
 293 <select name="archipelago<% $dd %>" onchange="ms_Setarch(<% $dd %>)">
 294 <option value="none">Whole ocean</option>
 295 <% $optionlistmap->(\@archlistdata, $ARGS{"archipelago$dd"}) %></select></td>
 296 %       }
 297 </tr>
 298
 299 <tr>
 300 %       for my $dd (0..$a{Dropdowns}-1) {
 301 %               my $arch= $ARGS{"archipelago$dd"};
 302 %               $arch= 'none' if !defined $arch;
 303 <td>
 304 <select name="islandid<% $dd %>">
 305 <% $optionlistmap->($islandlistdata{$arch}, $ARGS{"islandid$dd"}) %>
 306 </select></td>
 307 %       }
 308 </tr>
 309
 310 </table>
 311
 312 % } #---------- end of dropdowns, now common middle of page code ----------
 313
 314 <input type=submit name=submit value="Go">
 315 </form>
 316
 317 <%perl>
 318 #========== result computations ==========
 319
 320 my $results_head;
 321 $results_head= sub {
 322         print "<h1>Results</h1>\n";
 323         $results_head= sub { };
 324 };
 325
 326 #---------- result computation - textstring ----------
 327 if (!$a{Dropdowns}) {
 328   if (length $routestring) {
 329         $results_head->();
 330         my $rsr= $m->comp('routetextstring',
 331                 ocean => $a{Ocean},
 332                 string => $routestring,
 333                 format => 'return'
 334         );
 335         if (length $rsr->{Error}) {
 336                 print encode_entities($rsr->{Error});
 337         } else {
 338                 foreach my $entry (@{ $rsr->{Results} }) {
 339                         push @archipelagoes,
 340                                 defined $entry->[1] ? undef : $entry->[0];
 341                         push @islandids, $entry->[1];
 342                 }
 343         }
 344   }
 345
 346 } else { #---------- results - dropdowns ----------
 347
 348 my $argorundef= sub {
 349         my ($dd,$base) = @_;
 350         my $thing= $ARGS{"${base}${dd}"};
 351         $thing= undef if defined $thing and $thing eq 'none';
 352         return $thing;
 353 };
 354
 355 for my $dd (0..$a{Dropdowns}-1) {
 356         my $arch= $argorundef->($dd,'archipelago');
 357         my $island= $argorundef->($dd,'islandid');
 358         next unless defined $arch or defined $island;
 359         if (defined $island and defined $arch) {
 360                 my $ii= $islandid2{$island};
 361                 my $iarch= $ii->{Arch};
 362                 if ($iarch ne $arch) {
 363                         $results_head->();
 364 </%perl>
 365  Specified archipelago <% $arch %> but
 366  island <% $ii->{Name} %>
 367  which is in <% $iarch %>; using the island.<br>
 368 <%perl>
 369                 }
 370                 $arch= undef;
 371         }
 372         push @archipelagoes, $arch;
 373         push @islandids, $island;
 374 }
 375
 376 }#---------- result processing, common stuff
 377 </%perl>
 378
 379 % if (@islandids) {
 380 %       $results_head->();
 381
 382 <& routetrade, islandids => \@islandids, archipelagoes => \@archipelagoes &>
 383
 384 % }
 385
 386 % } elsif ($a{Query} eq 'age') {
 387 % ########### query `age' ##########
 388
 389 <h1>Market data age</h1>
 390 <& dataage, %baseqf, %queryqf &>
 391
 392 % } ########## end of `age' query ##########
 393
 394 %#---------- debugging and epilogue ----------
 395
 396 % if ($debug) {
 397 <p>
 398 <pre id="debug_log">
 399 Debug log:
 400 </pre>
 401 % }
 402
 403 <&| script &>
 404 function debug (m) {
 405 % if ($debug) {
 406   var node= document.getElementById('debug_log');
 407   node.innerHTML += "\n" + m + "\n";
 408 % }
 409 }
 410 </&script>
 411
 412 <& footer &>
 413
 414 <%init>
 415 use CommodsWeb;
 416 use HTML::Entities;
 417 use URI::Escape;
 418
 419 </%init>