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