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                                 [ 'age', 'Data age' ] ]
  61         }, {    Name => 'BuySell',
  62                 Before => '',
  63                 Values => [     [ 'buy_sell',   'Buy and sell' ],
  64                                 [ 'sell_buy',   'Sell and buy' ],
  65                                 [ 'buy',        'Buy offers only' ],
  66                                 [ 'sell',       'Sell offers only' ],
  67                         ],
  68                 QuerySpecific => 1,
  69         }, {    Name => 'ShowBlank',
  70                 Before => '',
  71                 Values => [     [ 0, 'Omit islands with no offers' ],
  72                                 [ 'show', 'Show all islands' ],
  73                         ],
  74                 QuerySpecific => 1,
  75         }, {    Name => 'ShowStalls',
  76                 Before => '',
  77                 Values => [     [ 0, 'Show total quantity at each price' ],
  78                                 [ 1, 'Show individual stalls' ],
  79                         ],
  80                 QuerySpecific => 1,
  81         });
  82
  83 foreach my $var (@vars) {
  84         my $name= $var->{Name};
  85         my $lname= lc $name;
  86         $var->{Before}= '' unless exists $var->{Before};
  87         $var->{CmpCanon}= sub { $_[0]; } unless exists $var->{CmpCanon};
  88         foreach my $val (@{ $var->{Values} }) {
  89                 next if ref $val;
  90                 $val= [ $val, encode_entities($val) ];
  91         }
  92         if (exists $ARGS{$lname}) {
  93                 $styles{$name}= $ARGS{$lname};
  94                 my @html= grep { $_->[0] eq $styles{$name} }
  95                                 @{ $var->{Values} };
  96                 $ahtml{$name}= @html==1 ? $html[0][1] : '???';
  97         } else {
  98                 $styles{$name}= $var->{Values}[0][0];
  99                 $ahtml{$name}= $var->{Values}[0][1];
 100         }
 101 }
 102
 103 </%perl>
 104
 105 <%shared>
 106 my %baseqf;
 107 my %queryqf;
 108 </%shared>
 109
 110 <%method formhidden>
 111 <%args>
 112 $ours
 113 </%args>
 114 % foreach my $n (keys %baseqf, keys %queryqf) {
 115 %       next if $ours->($n);
 116 %       my $v= exists $baseqf{$n} ? $baseqf{$n} : $queryqf{$n};
 117 <input type=hidden name=<% $n %> value="<% $v |h %>">
 118 % }
 119 </%method>
 120
 121 <html><head><title><% ucfirst $ahtml{Query} %> - YARRG</title>
 122 <style type="text/css">
 123 body {
 124   color: #000000;
 125   background: #ffffff;
 126 }
 127 tr.datarow0 { background: #ffffff; }
 128 tr.datarow1 { background: #e3e3e3; }
 129 </style>
 130 <&| script &>
 131   function register_onload(f) {
 132     var previous_onload= window.onload;
 133     window.onload= function() {
 134       if (previous_onload) previous_onload();
 135       f();
 136     };
 137   }
 138 </&script>
 139 </head><body>
 140
 141 <a href="<% $m->current_comp()->name() |u %>">YARRG</a> -
 142  Yet Another Revenue Research Gatherer
 143 |
 144 <a href="docs">documentation</a>
 145 <p>
 146 <%perl>
 147
 148 foreach my $var (@vars) {
 149         my $lname= lc $var->{Name};
 150         next unless exists $ARGS{$lname};
 151         $baseqf{$lname}= $ARGS{$lname};
 152 }
 153
 154 foreach my $var (keys %ARGS) {
 155         next unless $var =~
 156                 m/^(?: (?:route|commod)string |
 157                         commodid |
 158                         islandid \d |
 159                         archipelago \d |
 160                         debug |
 161                         [RT]\w+
 162                     )$/x;
 163         my $val= $ARGS{$var};
 164         next if $val eq 'none';
 165         $queryqf{$var}= $val;
 166 }
 167
 168 my $quri= sub {
 169         my $uri= URI->new('lookup');
 170         $uri->query_form(@_);
 171         $uri->path_query();
 172 };
 173
 174 my $prselector_core= sub {
 175         my ($var)= @_;
 176         my $name= $var->{Name};
 177         my $lname= lc $var->{Name};
 178         my $delim= $var->{Before};
 179         my $canon= &{$var->{CmpCanon}}($styles{$name});
 180         my $cvalix= 0;
 181         foreach my $valr (@{ $var->{Values} }) {
 182                 print $delim;  $delim= "\n|\n";
 183                 my ($value,$html) = @$valr;
 184                 my $iscurrent= &{$var->{CmpCanon}}($value) eq $canon;
 185                 my $after;
 186                 if ($iscurrent) {
 187                         print '<b>';
 188                         $after= '</b>';
 189                 } else {
 190                         my %qf= (%baseqf,%queryqf);
 191                         delete $qf{$lname};
 192                         $qf{$lname}= $value if $cvalix;
 193 </%perl>
 194 <a href="<% $quri->(%qf) |h %>">
 195 <%perl>
 196                         $after= '</a>';
 197                 }
 198                 print $html, $after;
 199                 $cvalix++;
 200         }
 201         print "<p>\n\n";
 202 };
 203
 204 my $prselector= sub {
 205         my ($name)= @_;
 206         foreach my $var (@vars) {
 207                 if ($var->{Name} eq $name) {
 208                         $prselector_core->($var);
 209                         return;
 210                 }
 211         }
 212         die $name;
 213 };
 214
 215 foreach my $var (@vars) {
 216         next if $var->{QuerySpecific};
 217         $prselector_core->($var);
 218 }
 219
 220 #---------- initial checks, startup, main entry form ----------
 221
 222 die if $styles{Query} =~ m/[^a-z]/;
 223
 224 my $mydbh;
 225 my $dbh= ($mydbh= dbw_connect($styles{Ocean}));
 226
 227 my $results_head_done=0;
 228 my $someresults= sub {
 229         return if $results_head_done;
 230         $results_head_done=1;
 231         my ($h)= @_;
 232         $h= 'Results' if !$h;
 233         print "\n<h1>$h</h1>\n";
 234 };
 235
 236 </%perl>
 237 <%args>
 238 $debug => 0
 239 </%args>
 240
 241 <hr>
 242
 243 <& "query_$styles{Query}", %baseqf, %queryqf, %styles,
 244     quri => $quri, dbh => $dbh,
 245     prselector => $prselector,
 246     someresults => $someresults,
 247     emsgokorprint => sub {
 248         my ($emsg) = @_;
 249         return 1 unless defined $emsg and length $emsg;
 250         $someresults->();
 251         print $emsg;
 252         return 0;
 253     }
 254  &>
 255
 256 <p>
 257
 258 %#---------- debugging and epilogue ----------
 259
 260 % if ($debug) {
 261 <p>
 262 <pre id="debug_log">
 263 Debug log:
 264 </pre>
 265 % }
 266
 267 <&| script &>
 268 function debug (m) {
 269 % if ($debug) {
 270   var node= document.getElementById('debug_log');
 271   node.innerHTML += "\n" + m + "\n";
 272 % }
 273 }
 274 </&script>
 275
 276 <& footer &>
 277
 278 <%init>
 279 use CommodsWeb;
 280 use HTML::Entities;
 281 use URI::Escape;
 282
 283 </%init>
 284 <%cleanup>
 285
 286 $mydbh->rollback() if $mydbh;
 287
 288 </%cleanup>