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: #e3e3e3; }
 128 tr.datarow1 { background: #ffffff; }
 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|capacity)string |
 157                         lossperleague |
 158                         commodid |
 159                         islandid \d |
 160                         archipelago \d |
 161                         debug |
 162                         [RT]\w+
 163                     )$/x;
 164         my $val= $ARGS{$var};
 165         next if $val eq 'none';
 166         $queryqf{$var}= $val;
 167 }
 168
 169 my $quri= sub {
 170         my $uri= URI->new('lookup');
 171         $uri->query_form(@_);
 172         $uri->path_query();
 173 };
 174
 175 my $prselector_core= sub {
 176         my ($var)= @_;
 177         my $name= $var->{Name};
 178         my $lname= lc $var->{Name};
 179         my $delim= $var->{Before};
 180         my $canon= &{$var->{CmpCanon}}($styles{$name});
 181         my $cvalix= 0;
 182         foreach my $valr (@{ $var->{Values} }) {
 183                 print $delim;  $delim= "\n|\n";
 184                 my ($value,$html) = @$valr;
 185                 my $iscurrent= &{$var->{CmpCanon}}($value) eq $canon;
 186                 my $after;
 187                 if ($iscurrent) {
 188                         print '<b>';
 189                         $after= '</b>';
 190                 } else {
 191                         my %qf= (%baseqf,%queryqf);
 192                         delete $qf{$lname};
 193                         $qf{$lname}= $value if $cvalix;
 194 </%perl>
 195 <a href="<% $quri->(%qf) |h %>">
 196 <%perl>
 197                         $after= '</a>';
 198                 }
 199                 print $html, $after;
 200                 $cvalix++;
 201         }
 202         print "<p>\n\n";
 203 };
 204
 205 my $prselector= sub {
 206         my ($name)= @_;
 207         foreach my $var (@vars) {
 208                 if ($var->{Name} eq $name) {
 209                         $prselector_core->($var);
 210                         return;
 211                 }
 212         }
 213         die $name;
 214 };
 215
 216 foreach my $var (@vars) {
 217         next if $var->{QuerySpecific};
 218         $prselector_core->($var);
 219 }
 220
 221 #---------- initial checks, startup, main entry form ----------
 222
 223 die if $styles{Query} =~ m/[^a-z]/;
 224
 225 my $mydbh;
 226 my $dbh= ($mydbh= dbw_connect($styles{Ocean}));
 227
 228 my $results_head_done=0;
 229 my $someresults= sub {
 230         return if $results_head_done;
 231         $results_head_done=1;
 232         my ($h)= @_;
 233         $h= 'Results' if !$h;
 234         print "\n<h1>$h</h1>\n";
 235 };
 236
 237 </%perl>
 238 <%args>
 239 $debug => 0
 240 </%args>
 241
 242 <hr>
 243
 244 <& "query_$styles{Query}", %baseqf, %queryqf, %styles,
 245     quri => $quri, dbh => $dbh,
 246     prselector => $prselector,
 247     someresults => $someresults,
 248     emsgokorprint => sub {
 249         my ($emsg) = @_;
 250         return 1 unless defined $emsg and length $emsg;
 251         $someresults->();
 252         print $emsg;
 253         return 0;
 254     }
 255  &>
 256
 257 <p>
 258
 259 %#---------- debugging and epilogue ----------
 260
 261 % if ($debug) {
 262 <p>
 263 <pre id="debug_log">
 264 Debug log:
 265 </pre>
 266 % }
 267
 268 <&| script &>
 269 function debug (m) {
 270 % if ($debug) {
 271   var node= document.getElementById('debug_log');
 272   node.innerHTML += "\n" + m + "\n";
 273 % }
 274 }
 275 </&script>
 276
 277 <& footer &>
 278
 279 <%init>
 280 use CommodsWeb;
 281 use HTML::Entities;
 282 use URI::Escape;
 283
 284 </%init>
 285 <%cleanup>
 286
 287 $mydbh->rollback() if $mydbh;
 288
 289 </%cleanup>