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                         [RT]\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         my ($h)= @_;
 213         $h= 'Results' if !$h;
 214         print "\n<h1>$h</h1>\n";
 215 };
 216
 217 </%perl>
 218 <%args>
 219 $debug => 0
 220 </%args>
 221
 222 <hr>
 223
 224 <& "query_$styles{Query}", %baseqf, %queryqf, %styles,
 225     quri => $quri, dbh => $dbh,
 226     prselector => $prselector,
 227     someresults => $someresults,
 228     emsgokorprint => sub {
 229         my ($emsg) = @_;
 230         return 1 unless defined $emsg and length $emsg;
 231         $someresults->();
 232         print $emsg;
 233         return 0;
 234     }
 235  &>
 236
 237 <p>
 238
 239 %#---------- debugging and epilogue ----------
 240
 241 % if ($debug) {
 242 <p>
 243 <pre id="debug_log">
 244 Debug log:
 245 </pre>
 246 % }
 247
 248 <&| script &>
 249 function debug (m) {
 250 % if ($debug) {
 251   var node= document.getElementById('debug_log');
 252   node.innerHTML += "\n" + m + "\n";
 253 % }
 254 }
 255 </&script>
 256
 257 <& footer &>
 258
 259 <%init>
 260 use CommodsWeb;
 261 use HTML::Entities;
 262 use URI::Escape;
 263
 264 </%init>
 265 <%cleanup>
 266
 267 $mydbh->rollback() if $mydbh;
 268
 269 </%cleanup>