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