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