yarrg/web/lookup

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