yarrg/web/lookup

   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 main `lookup' page, including
  33  all the entry boxes etc. for every query.
  34
  35
  36 </%doc>
  37 <%perl>
  38 my %ahtml;
  39 my @vars;
  40 my %styles;
  41
  42 #---------- "mode" argument parsing and mode menu at top of page ----------
  43
  44 # for debugging, invoke as
  45 #  http://www.chiark.greenend.org.uk/ucgi/~clareb/mason/pirates/pirate-route?debug=1
  46
  47 @vars= ({       Name => 'Ocean',
  48                 Before => 'Ocean: ',
  49                 CmpCanon => sub { ucfirst lc $_[0] },
  50                 Values => [ ocean_list() ]
  51         }, {    Name => 'Dropdowns',
  52                 Before => 'Interface: ',
  53                 CmpCanon => sub { !!$_[0] },
  54                 Values => [     [ 0, 'Type in names' ],
  55                                 [ 4, 'Select from menus' ] ]
  56         }, {    Name => 'Query',
  57                 Before => 'Query: ',
  58                 Values => [     [ 'route', 'Trades for route' ],
  59                                 [ 'commod', 'Prices for commodity' ],
  60                                 [ 'offers', 'Offers at location' ],
  61                                 [ 'routesearch', 'Find profitable route' ],
  62                                 [ 'age', 'Data age' ] ]
  63         }, {    Name => 'BuySell',
  64                 Before => '',
  65                 Values => [     [ 'buy_sell',   'Buy and sell' ],
  66                                 [ 'sell_buy',   'Sell and buy' ],
  67                                 [ 'buy',        'Buy offers only' ],
  68                                 [ 'sell',       'Sell offers only' ],
  69                         ],
  70                 QuerySpecific => 1,
  71         }, {    Name => 'ShowBlank',
  72                 Before => '',
  73                 Values => [     [ 0, 'Omit islands with no offers' ],
  74                                 [ 'show', 'Show all islands' ],
  75                         ],
  76                 QuerySpecific => 1,
  77         }, {    Name => 'ShowStalls',
  78                 Before => '',
  79                 Values => [     [ 0, 'Show total quantity at each price' ],
  80                                 [ 1, 'Show individual stalls' ],
  81                         ],
  82                 QuerySpecific => 1,
  83         }, {    Name => 'RouteSearchType',
  84                 Before => 'Type of routes to search for: ',
  85                 Values => [     [ 0, 'Open-ended' ],
  86                                 [ 1, 'Circular' ],
  87                         ],
  88                 QuerySpecific => 1,
  89         });
  90
  91 foreach my $var (@vars) {
  92         my $name= $var->{Name};
  93         my $lname= lc $name;
  94         $var->{Before}= '' unless exists $var->{Before};
  95         $var->{CmpCanon}= sub { $_[0]; } unless exists $var->{CmpCanon};
  96         foreach my $val (@{ $var->{Values} }) {
  97                 next if ref $val;
  98                 $val= [ $val, encode_entities($val) ];
  99         }
 100         if (exists $ARGS{$lname}) {
 101                 $styles{$name}= $ARGS{$lname};
 102                 my @html= grep { $_->[0] eq $styles{$name} }
 103                                 @{ $var->{Values} };
 104                 $ahtml{$name}= @html==1 ? $html[0][1] : '???';
 105         } else {
 106                 $styles{$name}= $var->{Values}[0][0];
 107                 $ahtml{$name}= $var->{Values}[0][1];
 108         }
 109 }
 110
 111 </%perl>
 112
 113 <%shared>
 114 my %baseqf;
 115 my %queryqf;
 116 </%shared>
 117
 118 <%method formhidden>
 119 <%args>
 120 $ours
 121 </%args>
 122 % foreach my $n (keys %baseqf, keys %queryqf) {
 123 %       next if $ours->($n);
 124 %       my $v= exists $baseqf{$n} ? $baseqf{$n} : $queryqf{$n};
 125 <input type=hidden name=<% $n %> value="<% $v |h %>">
 126 % }
 127 </%method>
 128
 129 <html lang="en"><head><title><% ucfirst $ahtml{Query} %> - YARRG</title>
 130 <style type="text/css">
 131 <& style.css &>
 132   body { margin: 0; color: #000000; background: #c5c7ae; }
 133   div.query { background: #d7d8b3; padding: 1em; }
 134   div.results { padding: 1em; }
 135   table.data { background: #b5b686; }
 136   tr.datarow0 { background: #e3e3e3; }
 137   tr.datarow1 { background: #ffffff; }
 138 </style>
 139 <&| script &>
 140   function register_onload(f) {
 141     var previous_onload= window.onload;
 142     window.onload= function() {
 143       if (previous_onload) previous_onload();
 144       f();
 145     };
 146   }
 147 </&script>
 148 </head><body>
 149
 150 % if (!printable($m)) {
 151 <div class="navoptbar">
 152 <& navbar &>
 153 <p>
 154 % }
 155 <%perl>
 156
 157 foreach my $var (@vars) {
 158         my $lname= lc $var->{Name};
 159         next unless exists $ARGS{$lname};
 160         $baseqf{$lname}= $ARGS{$lname};
 161 }
 162
 163 foreach my $var (keys %ARGS) {
 164         next unless $var =~
 165                 m/^(?: (?:route|commod|capacity|capital|island)string |
 166                         lossperleague | distance |
 167                         commodid |
 168                         islandid \d |
 169                         archipelago \d |
 170                         debug |
 171                         [RT]\w+
 172                     )$/x;
 173         my $val= $ARGS{$var};
 174         next if $val eq 'none';
 175         $queryqf{$var}= $val;
 176 }
 177
 178 my $quri= sub {
 179         my $uri= URI->new('lookup');
 180         $uri->query_form(@_);
 181         $uri->path_query();
 182 };
 183
 184 my $prselector_core= sub {
 185         my ($var)= @_;
 186         return if printable($m);
 187         my $name= $var->{Name};
 188         my $lname= lc $var->{Name};
 189         my $delim= $var->{Before};
 190         my $canon= &{$var->{CmpCanon}}($styles{$name});
 191         my $cvalix= 0;
 192         foreach my $valr (@{ $var->{Values} }) {
 193                 print $delim;  $delim= "\n|\n";
 194                 my ($value,$html) = @$valr;
 195                 my $iscurrent= &{$var->{CmpCanon}}($value) eq $canon;
 196                 my $after;
 197                 if ($iscurrent) {
 198                         print '<b>';
 199                         $after= '</b>';
 200                 } else {
 201                         my %qf= (%baseqf,%queryqf);
 202                         delete $qf{$lname};
 203                         $qf{$lname}= $value if $cvalix;
 204 </%perl>
 205 <a href="<% $quri->(%qf) |h %>">
 206 <%perl>
 207                         $after= '</a>';
 208                 }
 209                 print $html, $after;
 210                 $cvalix++;
 211         }
 212         print "<p>\n\n";
 213 };
 214
 215 my $prselector= sub {
 216         my ($name)= @_;
 217         foreach my $var (@vars) {
 218                 if ($var->{Name} eq $name) {
 219                         $prselector_core->($var);
 220                         return;
 221                 }
 222         }
 223         die $name;
 224 };
 225
 226 foreach my $var (@vars) {
 227         next if $var->{QuerySpecific};
 228         $prselector_core->($var);
 229 }
 230
 231 #---------- initial checks, startup, main entry form ----------
 232
 233 die if $styles{Query} =~ m/[^a-z]/;
 234
 235 my $mydbh;
 236 my $dbh= ($mydbh= dbw_connect($styles{Ocean}));
 237
 238 my $results_head_done=0;
 239 my $someresults= sub {
 240         return if $results_head_done;
 241         $results_head_done=1;
 242         my ($h)= @_;
 243         $h= 'Results' if !$h;
 244         print "\n<h1>$h</h1>\n";
 245 };
 246
 247 </%perl>
 248 <%args>
 249 $debug => 0
 250 </%args>
 251
 252 % if (!printable($m)) {
 253 </div>
 254 <hr>
 255 % }
 256
 257 <& "query_$styles{Query}", %baseqf, %queryqf, %styles,
 258     quri => $quri, dbh => $dbh,
 259     baseqf => \%baseqf, queryqf => \%queryqf, allargs => \%ARGS,
 260     prselector => $prselector,
 261     someresults => $someresults,
 262     emsgokorprint => sub {
 263         my ($emsg) = @_;
 264         return 1 unless defined $emsg and length $emsg;
 265         $someresults->();
 266         print $emsg;
 267         return 0;
 268     }
 269  &>
 270
 271 %#---------- debugging and epilogue ----------
 272
 273 % if ($debug) {
 274 <div class="results">
 275 <pre id="debug_log">
 276 Debug log:
 277 </pre>
 278 </div>
 279 % }
 280
 281 <&| script &>
 282 function debug (m) {
 283 % if ($debug) {
 284   var node= document.getElementById('debug_log');
 285   node.innerHTML += "\n" + m + "\n";
 286 % }
 287 }
 288 </&script>
 289
 290 <& footer &>
 291
 292 <%init>
 293 use CommodsWeb;
 294 use HTML::Entities;
 295 use URI::Escape;
 296
 297 </%init>
 298 <%cleanup>
 299
 300 $mydbh->rollback() if $mydbh;
 301
 302 </%cleanup>