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