chiark / gitweb /
9c7200c39480df0343ab70b7615e4e994316b3d2
[ypp-sc-tools.db-test.git] / yarrg / web / route
1 <html><head><title>Specify route</title></head><body>
2
3 <%perl>
4 my %a;
5 my @vars;
6
7 # for output:
8 my @archipelagoes;
9 my @islandids;
10 my %islandid2;
11
12 #---------- "mode" argument parsing and mode menu at top of page ----------
13
14 # for debugging, invoke as
15 #  http://www.chiark.greenend.org.uk/ucgi/~clareb/mason/pirates/pirate-route?debug=1
16
17 @vars= ({       Name => 'Ocean',
18                 Before => 'Ocean: ',
19                 CmpCanon => sub { ucfirst lc $_[0] },
20                 Values => [ ocean_list() ]
21         }, {    Name => 'Dropdowns',
22                 Before => 'Interface: ',
23                 CmpCanon => sub { !!$_[0] },
24                 Values => [     [ 0, 'Type in names' ],
25                                 [ 4, 'Select from menus' ] ]
26         });
27
28 foreach my $var (@vars) {
29         my $name= $var->{Name};
30         my $lname= lc $name;
31         $var->{Before}= '' unless exists $var->{Before};
32         $var->{CmpCanon}= sub { $_[0]; } unless exists $var->{CmpCanon};
33         foreach my $val (@{ $var->{Values} }) {
34                 next if ref $val;
35                 $val= [ $val, encode_entities($val) ];
36         }
37         if (exists $ARGS{$lname}) {
38                 $a{$name}= $ARGS{$lname};
39         } else {
40                 $a{$name}= $var->{Values}[0][0];
41         }
42 }
43
44 my %baseqf;
45 foreach my $var (@vars) {
46         my $lname= lc $var->{Name};
47         next unless exists $ARGS{$lname};
48         $baseqf{$lname}= $ARGS{$lname};
49 }
50
51 my %queryqf;
52 foreach my $var (keys %ARGS) {
53         next unless $var =~
54                 m/^(?:routestring|islandid\d|archipelago\d|debug)$/;
55         $queryqf{$var}= $ARGS{$var};
56 }
57
58 my $uri= URI->new($m->current_comp()->name());
59 my $quri= sub { $uri->query_form(@_); $uri->path_query(); };
60
61 foreach my $var (@vars) {
62         my $name= $var->{Name};
63         my $lname= lc $var->{Name};
64         my $delim= $var->{Before};
65         my $canon= &{$var->{CmpCanon}}($a{$name});
66         my $cvalix= 0;
67         foreach my $valr (@{ $var->{Values} }) {
68                 print $delim;  $delim= "\n|\n";
69                 my ($value,$html) = @$valr;
70                 my $iscurrent= &{$var->{CmpCanon}}($value) eq $canon;
71                 my $after;
72                 if ($iscurrent) {
73                         print '<b>';
74                         $after= '</b>';
75                 } else {
76                         my %qf= (%baseqf,%queryqf);
77                         delete $qf{$lname};
78                         $qf{$lname}= $value if $cvalix;
79                         print '<a href="',$quri->(%qf),'">';
80                         $after= '</a>';
81                 }
82                 print $html, $after;
83                 $cvalix++;
84         }
85         print "<p>\n\n";
86 }
87
88 #---------- initial checks, startup, main entry form ----------
89
90 dbw_connect($a{Ocean});
91
92 </%perl>
93 <%args>
94 $debug => 0
95 $routestring => ''
96 </%args>
97
98 <h1>Specify route</h1>
99 <form action="<% $quri->() %>" method="get">
100
101 %#---------- textbox, user enters route as string ----------
102 % if (!$a{Dropdowns}) {
103
104 Enter route (islands, or archipelagoes, separated by |s or commas;
105  abbreviations are OK):<br/>
106
107 <script type="text/javascript">
108 tr_uri= "routetextstring?format=json&type=text/xml"
109                 + "&ocean=<% uri_escape($a{Ocean}) %>";
110
111 tr_timeout=false;
112 tr_request=false;
113 tr_done='';
114 tr_needed='';
115 function tr_Later(){
116   window.clearTimeout(tr_timeout);
117   tr_timeout = window.setTimeout(tr_Needed, 500);
118 }
119 function tr_Needed(){
120   window.clearTimeout(tr_timeout);
121   tr_element= document.getElementById('routestring');
122   tr_needed= tr_element.value;
123   tr_Request();
124 }
125 function tr_Request(){
126   if (tr_request || tr_needed==tr_done) return;
127   tr_done= tr_needed;
128   tr_request= new XMLHttpRequest();
129   uri= tr_uri+'&string='+encodeURIComponent(tr_needed);
130   tr_request.open('GET', uri);
131   tr_request.onreadystatechange= tr_Ready;
132   tr_request.send(null);
133 }
134 function tr_Ready() {
135   if (tr_request.readyState != 4) return;
136   if (tr_request.status == 200) {
137     response= tr_request.responseText;
138     eval('results='+response);
139     toedit= document.getElementById('routeresults');
140     toedit.innerHTML= results.show;
141   }
142   tr_request= false;
143   tr_Request();
144 }
145 window.onload= tr_Needed;
146 </script>
147
148 <input type="text" id="routestring" name="routestring" size=80
149  value="<% $routestring |h %>"
150  onchange="tr_Needed();"
151  onkeyup="tr_Later();"><br>
152 <div id="routeresults">&nbsp;</div><br/>
153
154 % } else { #---------- dropdowns, user selects from menus ----------
155
156 <%perl>
157 my ($sth,$row);;
158 my @archlistdata;
159 my %islandlistdata;
160 $islandlistdata{'none'}= [ [ "none", "Select island..." ] ];
161
162 my $optionlistmap= sub {
163         my ($optlist, $selected) = @_;
164         my $out='';
165         foreach my $entry (@$optlist) {
166                 $out.= sprintf('<option value="%s" %s>%s</option>',
167                         encode_entities($entry->[0]),
168                         defined $selected && $entry->[0] eq $selected
169                                 ? 'selected' : '',
170                         encode_entities($entry->[1]));
171         }
172         return $out;
173 };
174
175 my $dbh= dbw_connect($a{Ocean});
176
177 $sth= $dbh->prepare("SELECT DISTINCT archipelago FROM islands
178                             ORDER BY archipelago;");
179 $sth->execute();
180
181 while ($row=$sth->fetchrow_arrayref) {
182         my ($arch)= @$row;
183         push @archlistdata, [ $arch, $arch ];
184         $islandlistdata{$arch}= [ [ "none", "Whole arch" ] ];
185 }
186
187 $sth= $dbh->prepare("SELECT islandid,islandname,archipelago
188                             FROM islands
189                             ORDER BY islandname;");
190 $sth->execute();
191
192 while ($row=$sth->fetchrow_arrayref) {
193         my $arch= $row->[2];
194         push @{ $islandlistdata{'none'} }, [ @$row ];
195         push @{ $islandlistdata{$arch} }, [ @$row ];
196         $islandid2{$row->[0]}= { Name => $row->[1], Arch => $arch };
197 }
198
199 my %resetislandlistdata;
200 foreach my $arch (keys %islandlistdata) {
201         $resetislandlistdata{$arch}=
202                 $optionlistmap->($islandlistdata{$arch}, '');
203 }
204
205 </%perl>
206
207 <input type=hidden name=dropdowns value="<% $a{Dropdowns} %>">
208
209 <script type="text/javascript">
210 ms_lists= <% to_json(\%resetislandlistdata) %>;
211 function ms_Setarch(dd) {
212   debug('ms_SetArch '+dd+' arch='+arch);
213   var arch= document.getElementsByName('archipelago'+dd).item(0).value;
214   var got= ms_lists[arch];
215   if (got == undefined) return; // unknown arch ?  hrm
216   debug('ms_SetArch '+dd+' arch='+arch+' got ok');
217   var select= document.getElementsByName('islandid'+dd).item(0);
218   select.innerHTML= got;
219   debug('ms_SetArch '+dd+' arch='+arch+' innerHTML set');
220 }
221 </script>
222
223 <table style="table-layout:fixed; width:90%;">
224
225 <tr>
226 %       for my $dd (0..$a{Dropdowns}-1) {
227 <td>
228 <select name="archipelago<% $dd %>" onchange="ms_Setarch(<% $dd %>)">
229 <option value="none">Whole ocean</option>
230 <% $optionlistmap->(\@archlistdata, $ARGS{"archipelago$dd"}) %></select></td>
231 %       }
232 </tr>
233
234 <tr>
235 %       for my $dd (0..$a{Dropdowns}-1) {
236 %               my $arch= $ARGS{"archipelago$dd"};
237 %               $arch= 'none' if !defined $arch;
238 <td>
239 <select name="islandid<% $dd %>">
240 <% $optionlistmap->($islandlistdata{$arch}, $ARGS{"islandid$dd"}) %>
241 </select></td>
242 %       }
243 </tr>
244
245 </table>
246
247 % } #---------- end of dropdowns, now common middle of page code ----------
248
249 <input type=submit name=submit value="Go">
250 </form>
251
252 <%perl>
253 #========== result computations ==========
254
255 my $results_head;
256 $results_head= sub {
257         print "<h1>Results</h1>\n";
258         $results_head= sub { };
259 };
260
261 #---------- result computation - textstring ----------
262 if (!$a{Dropdowns}) {
263   if (length $routestring) {
264         $results_head->();
265         my $rsr= $m->comp('routetextstring',
266                 ocean => $a{Ocean},
267                 string => $routestring,
268                 format => 'return'
269         );
270         if (length $rsr->{Error}) {
271                 print encode_entities($rsr->{Error});
272         } else {
273                 foreach my $entry (@{ $rsr->{Results} }) {
274                         push @archipelagoes,
275                                 defined $entry->[1] ? undef : $entry->[0];
276                         push @islandids, $entry->[1];
277                 } 
278         }
279   }
280
281 } else { #---------- results - dropdowns ----------
282
283 my $argorundef= sub {
284         my ($dd,$base) = @_;
285         my $thing= $ARGS{"${base}${dd}"};
286         $thing= undef if defined $thing and $thing eq 'none';
287         return $thing;
288 };
289
290 for my $dd (0..$a{Dropdowns}-1) {
291         my $arch= $argorundef->($dd,'archipelago');
292         my $island= $argorundef->($dd,'islandid');
293         next unless defined $arch or defined $island;
294         if (defined $island and defined $arch) {
295                 my $ii= $islandid2{$island};
296                 my $iarch= $ii->{Arch};
297                 if ($iarch ne $arch) {
298                         $results_head->();
299 </%perl>
300  Specified archipelago <% $arch %> but
301  island <% $ii->{Name} %>
302  which is in <% $iarch %>; using the island.<br>
303 <%perl>
304                 }
305                 $arch= undef;
306         }
307         push @archipelagoes, $arch;
308         push @islandids, $island;
309 }
310
311 }#---------- result processing, common stuff
312 </%perl>
313
314 % if (@islandids) {
315 %       $results_head->();
316
317 <& routetrade, islandids => \@islandids, archipelagoes => \@archipelagoes &>
318
319 % }
320
321 %#---------- debugging and epilogue ----------
322
323 % if ($debug) {
324 <p>
325 <pre id="debug_log">
326 Debug log:
327 </pre>
328 % }
329
330 <script type="text/javascript">
331 function debug (m) {
332 % if ($debug) {
333   var node= document.getElementById('debug_log');
334   node.innerHTML += "\n" + m + "\n";
335 % }
336 }
337 </script>
338
339 <%init>
340 use CommodsWeb;
341 use HTML::Entities;
342 use URI::Escape;
343 use JSON;
344
345 </%init>