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