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