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