yarrg/web/enter_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 form contents for selecting a list
  33  of locations (eg, a route).
  34
  35
  36 </%doc>
  37 <%args>
  38 $qa
  39 $dbh
  40 $emsg_r
  41 $warningfs_r
  42
  43 $enterwhat
  44 $islandids_r
  45 $archipelagoes_r
  46 </%args>
  47
  48 %#---------- textbox, user enters route as string ----------
  49 % if (!$qa->{Dropdowns}) {
  50
  51 <% $enterwhat %>
  52 % if (defined($archipelagoes_r)) {
  53 (islands, or archipelagoes,
  54 % } else {
  55 (islands
  56 % }
  57 separated by |s or commas; abbreviations are OK):<br>
  58
  59 <& qtextstring, qa => $qa, dbh => $dbh, emsgstore => $emsg_r,
  60     thingstring => defined($archipelagoes_r) ? 'routestring' : 'islandstring',
  61     prefix => 'rl', boxopts => 'size=80',
  62     onresults => sub {
  63         foreach (@_) {
  64         my ($canonname, $island, $arch) = @$_;
  65                 push @$islandids_r, $island;
  66                 push @$archipelagoes_r, defined $island ? undef : $arch
  67                         if defined $archipelagoes_r;
  68         }
  69     }
  70  &>
  71
  72 % } else { #---------- dropdowns, user selects from menus ----------
  73
  74 <%perl>
  75 my %islandid2;
  76 my ($sth,$row);
  77 my @archlistdata;
  78 my %islandlistdata;
  79 $islandlistdata{'none'}= [ [ "none", "Select island..." ] ];
  80
  81 my $optionlistmap= sub {
  82         my ($optlist, $selected) = @_;
  83         my $out='';
  84         foreach my $entry (@$optlist) {
  85                 $out.= sprintf('<option value="%s" %s>%s</option>',
  86                         encode_entities($entry->[0]),
  87                         defined $selected && $entry->[0] eq $selected
  88                                 ? 'selected' : '',
  89                         encode_entities($entry->[1]));
  90         }
  91         return $out;
  92 };
  93
  94 $sth= $dbh->prepare("SELECT DISTINCT archipelago FROM islands
  95                             ORDER BY archipelago;");
  96 $sth->execute();
  97
  98 while ($row=$sth->fetchrow_arrayref) {
  99         my ($arch)= @$row;
 100         push @archlistdata, [ $arch, $arch ];
 101         $islandlistdata{$arch}= [ [ "none", "Whole arch" ] ];
 102 }
 103
 104 $sth= $dbh->prepare("SELECT islandid,islandname,archipelago
 105                             FROM islands
 106                             ORDER BY islandname;");
 107 $sth->execute();
 108
 109 while ($row=$sth->fetchrow_arrayref) {
 110         my $arch= $row->[2];
 111         push @{ $islandlistdata{'none'} }, [ @$row ];
 112         push @{ $islandlistdata{$arch} }, [ @$row ];
 113         $islandid2{$row->[0]}= { Name => $row->[1], Arch => $arch };
 114 }
 115
 116 my %resetislandlistdata;
 117 foreach my $arch (keys %islandlistdata) {
 118         $resetislandlistdata{$arch}=
 119                 $optionlistmap->($islandlistdata{$arch}, '');
 120 }
 121
 122 </%perl>
 123
 124 <&| script &>
 125 ms_lists= <% to_json_protecttags(\%resetislandlistdata) %>;
 126 function ms_Setarch(dd) {
 127   debug('ms_SetArch '+dd+' arch='+arch);
 128   var arch= document.getElementsByName('archipelago'+dd).item(0).value;
 129   var got= ms_lists[arch];
 130   if (got == undefined) return; // unknown arch ?  hrm
 131   debug('ms_SetArch '+dd+' arch='+arch+' got ok');
 132   var select= document.getElementsByName('islandid'+dd).item(0);
 133   select.innerHTML= got;
 134   debug('ms_SetArch '+dd+' arch='+arch+' innerHTML set');
 135 }
 136 </&script>
 137
 138 <table style="table-layout:fixed; width:90%;">
 139
 140 <tr>
 141 %       for my $dd (0..$qa->{Dropdowns}-1) {
 142 <td>
 143 <select name="archipelago<% $dd %>" onchange="ms_Setarch(<% $dd %>)">
 144 <option value="none">Whole ocean</option>
 145 <% $optionlistmap->(\@archlistdata, $qa->{"archipelago$dd"}) %></select></td>
 146 %       }
 147 </tr>
 148
 149 <tr>
 150 %       for my $dd (0..$qa->{Dropdowns}-1) {
 151 %               my $arch= $qa->{"archipelago$dd"};
 152 %               $arch= 'none' if !defined $arch;
 153 <td>
 154 <select name="islandid<% $dd %>">
 155 <% $optionlistmap->($islandlistdata{$arch}, $qa->{"islandid$dd"}) %>
 156 </select></td>
 157 %       }
 158 </tr>
 159
 160 </table>
 161
 162 <%perl>
 163
 164 my $argorundef= sub {
 165         my ($dd,$base) = @_;
 166         my $thing= $qa->{"${base}${dd}"};
 167         $thing= undef if defined $thing and $thing eq 'none';
 168         return $thing;
 169 };
 170
 171 for my $dd (0..$qa->{Dropdowns}-1) {
 172         my $arch= $argorundef->($dd,'archipelago');
 173         my $island= $argorundef->($dd,'islandid');
 174         next unless defined $arch or defined $island;
 175         if (defined $island and defined $arch) {
 176                 my $ii= $islandid2{$island};
 177                 my $iarch= $ii->{Arch};
 178                 if ($iarch ne $arch) {
 179                         push @$warningfs_r, sub {
 180 </%perl>
 181  Specified archipelago <% $arch %> but
 182  island <% $ii->{Name} %>
 183  which is in <% $iarch %>; using the island.<p>
 184 <%perl>
 185                         };
 186                 }
 187                 $arch= undef;
 188         }
 189         push @$archipelagoes_r, $arch;
 190         push @$islandids_r, $island;
 191 }
 192
 193 </%perl>
 194 <p>
 195
 196 % }