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