yarrg/web/query_route

   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 core of the `trade route' query.
  33
  34
  35 </%doc>
  36 <%args>
  37 $quri
  38 $dbh
  39 $prselector
  40 $routestring => '';
  41 $someresults
  42 $emsgokorprint
  43 </%args>
  44
  45 <%perl>
  46 my $emsg;
  47 my @archipelagoes;
  48 my @islandids;
  49 my %islandid2;
  50
  51 my $qa= \%ARGS;
  52
  53 my $be_post;
  54 my $startform= sub {
  55         ($be_post)= @_;
  56 </%perl>
  57 <form action="<% $quri->() |h %>" method="<% $be_post ? 'post' : 'get' %>">
  58 <%perl>
  59 };
  60 my $goupdate= sub { $be_post ? 'Update' : 'Go' };
  61
  62 </%perl>
  63
  64 <h1>Specify route</h1>
  65
  66 % $prselector->('ShowStalls');
  67
  68 %#---------- textbox, user enters route as string ----------
  69 % if (!$qa->{Dropdowns}) {
  70
  71 Enter route (islands, or archipelagoes, separated by |s or commas;
  72  abbreviations are OK):<br>
  73
  74 % $startform->($routestring =~ m/\S/);
  75
  76 <&| qtextstring, qa => $qa, dbh => $dbh,
  77     thingstring => 'routestring', emsgstore => \$emsg,
  78     perresult => sub {
  79         my ($canonname, $island, $arch) = @_;
  80         push @islandids, $island;
  81         push @archipelagoes, defined $island ? undef : $arch;
  82     }
  83  &>
  84  size=80
  85 </&>
  86
  87 % } else { #---------- dropdowns, user selects from menus ----------
  88
  89 % $startform->(grep {
  90 %               defined $ARGS{"archipelago$_"} ||
  91 %               defined $ARGS{"islandid$_"}
  92 %       } (0..$qa->{Dropdowns}-1));
  93
  94 <%perl>
  95 my ($sth,$row);
  96 my @archlistdata;
  97 my %islandlistdata;
  98 $islandlistdata{'none'}= [ [ "none", "Select island..." ] ];
  99
 100 my $optionlistmap= sub {
 101         my ($optlist, $selected) = @_;
 102         my $out='';
 103         foreach my $entry (@$optlist) {
 104                 $out.= sprintf('<option value="%s" %s>%s</option>',
 105                         encode_entities($entry->[0]),
 106                         defined $selected && $entry->[0] eq $selected
 107                                 ? 'selected' : '',
 108                         encode_entities($entry->[1]));
 109         }
 110         return $out;
 111 };
 112
 113 $sth= $dbh->prepare("SELECT DISTINCT archipelago FROM islands
 114                             ORDER BY archipelago;");
 115 $sth->execute();
 116
 117 while ($row=$sth->fetchrow_arrayref) {
 118         my ($arch)= @$row;
 119         push @archlistdata, [ $arch, $arch ];
 120         $islandlistdata{$arch}= [ [ "none", "Whole arch" ] ];
 121 }
 122
 123 $sth= $dbh->prepare("SELECT islandid,islandname,archipelago
 124                             FROM islands
 125                             ORDER BY islandname;");
 126 $sth->execute();
 127
 128 while ($row=$sth->fetchrow_arrayref) {
 129         my $arch= $row->[2];
 130         push @{ $islandlistdata{'none'} }, [ @$row ];
 131         push @{ $islandlistdata{$arch} }, [ @$row ];
 132         $islandid2{$row->[0]}= { Name => $row->[1], Arch => $arch };
 133 }
 134
 135 my %resetislandlistdata;
 136 foreach my $arch (keys %islandlistdata) {
 137         $resetislandlistdata{$arch}=
 138                 $optionlistmap->($islandlistdata{$arch}, '');
 139 }
 140
 141 </%perl>
 142
 143 <&| script &>
 144 ms_lists= <% to_json_protecttags(\%resetislandlistdata) %>;
 145 function ms_Setarch(dd) {
 146   debug('ms_SetArch '+dd+' arch='+arch);
 147   var arch= document.getElementsByName('archipelago'+dd).item(0).value;
 148   var got= ms_lists[arch];
 149   if (got == undefined) return; // unknown arch ?  hrm
 150   debug('ms_SetArch '+dd+' arch='+arch+' got ok');
 151   var select= document.getElementsByName('islandid'+dd).item(0);
 152   select.innerHTML= got;
 153   debug('ms_SetArch '+dd+' arch='+arch+' innerHTML set');
 154 }
 155 </&script>
 156
 157 <table style="table-layout:fixed; width:90%;">
 158
 159 <tr>
 160 %       for my $dd (0..$qa->{Dropdowns}-1) {
 161 <td>
 162 <select name="archipelago<% $dd %>" onchange="ms_Setarch(<% $dd %>)">
 163 <option value="none">Whole ocean</option>
 164 <% $optionlistmap->(\@archlistdata, $ARGS{"archipelago$dd"}) %></select></td>
 165 %       }
 166 </tr>
 167
 168 <tr>
 169 %       for my $dd (0..$qa->{Dropdowns}-1) {
 170 %               my $arch= $ARGS{"archipelago$dd"};
 171 %               $arch= 'none' if !defined $arch;
 172 <td>
 173 <select name="islandid<% $dd %>">
 174 <% $optionlistmap->($islandlistdata{$arch}, $ARGS{"islandid$dd"}) %>
 175 </select></td>
 176 %       }
 177 </tr>
 178
 179 </table>
 180
 181 % } #---------- end of dropdowns, now common middle of page code ----------
 182
 183 <input type=submit name=submit value="<% $goupdate->() %>">
 184 % my $ours= sub { $_[0] =~ m/^island|^archipelago|^routestring|^[RT]/; };
 185 <& "lookup:formhidden", ours => $ours &>
 186
 187 <%perl>
 188 #========== results ==========
 189
 190 $emsgokorprint->($emsg) or @islandids=();
 191
 192 my $argorundef= sub {
 193         my ($dd,$base) = @_;
 194         my $thing= $ARGS{"${base}${dd}"};
 195         $thing= undef if defined $thing and $thing eq 'none';
 196         return $thing;
 197 };
 198
 199 for my $dd (0..$qa->{Dropdowns}-1) {
 200         my $arch= $argorundef->($dd,'archipelago');
 201         my $island= $argorundef->($dd,'islandid');
 202         next unless defined $arch or defined $island;
 203         if (defined $island and defined $arch) {
 204                 my $ii= $islandid2{$island};
 205                 my $iarch= $ii->{Arch};
 206                 if ($iarch ne $arch) {
 207                         $someresults->();
 208 </%perl>
 209  Specified archipelago <% $arch %> but
 210  island <% $ii->{Name} %>
 211  which is in <% $iarch %>; using the island.<br>
 212 <%perl>
 213                 }
 214                 $arch= undef;
 215         }
 216         push @archipelagoes, $arch;
 217         push @islandids, $island;
 218 }
 219
 220 </%perl>
 221
 222 % if (@islandids) {
 223 %       $someresults->('Relevant trades');
 224 <& routetrade,
 225    dbh => $dbh,
 226    islandids => \@islandids,
 227    archipelagoes => \@archipelagoes,
 228    qa => $qa
 229  &>
 230 </form>
 231 % }