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         });
  70
  71 foreach my $var (@vars) {
  72         my $name= $var->{Name};
  73         my $lname= lc $name;
  74         $var->{Before}= '' unless exists $var->{Before};
  75         $var->{CmpCanon}= sub { $_[0]; } unless exists $var->{CmpCanon};
  76         foreach my $val (@{ $var->{Values} }) {
  77                 next if ref $val;
  78                 $val= [ $val, encode_entities($val) ];
  79         }
  80         if (exists $ARGS{$lname}) {
  81                 $styles{$name}= $ARGS{$lname};
  82                 my @html= grep { $_->[0] eq $styles{$name} }
  83                                 @{ $var->{Values} };
  84                 $ahtml{$name}= @html==1 ? $html[0][1] : '???';
  85         } else {
  86                 $styles{$name}= $var->{Values}[0][0];
  87                 $ahtml{$name}= $var->{Values}[0][1];
  88         }
  89 }
  90
  91 </%perl>
  92
  93 <%shared>
  94 my %baseqf;
  95 my %queryqf;
  96 </%shared>
  97
  98 <%method formhidden>
  99 <%args>
 100 $ours
 101 </%args>
 102 % foreach my $n (keys %baseqf, keys %queryqf) {
 103 %       next if $ours->($n);
 104 %       my $v= exists $baseqf{$n} ? $baseqf{$n} : $queryqf{$n};
 105 <input type=hidden name=<% $n %> value="<% $v |h %>">
 106 % }
 107 </%method>
 108
 109 <html><head><title><% ucfirst $ahtml{Query} %> - YARRG</title></head><body>
 110
 111 <a href="<% $m->current_comp()->name() |u %>">YARRG</a> -
 112  Yet Another Revenue Research Gatherer
 113 |
 114 <a href="docs">documentation</a>
 115 <p>
 116 <%perl>
 117
 118 foreach my $var (@vars) {
 119         my $lname= lc $var->{Name};
 120         next unless exists $ARGS{$lname};
 121         $baseqf{$lname}= $ARGS{$lname};
 122 }
 123
 124 foreach my $var (keys %ARGS) {
 125         next unless $var =~
 126                 m/^(?:(?:route|commod)string|islandid\d|archipelago\d|debug)$/;
 127         my $val= $ARGS{$var};
 128         next if $val eq 'none';
 129         $queryqf{$var}= $val;
 130 }
 131
 132 my $quri= sub {
 133         my $uri= URI->new('lookup');
 134         $uri->query_form(@_);
 135         $uri->path_query();
 136 };
 137
 138 my $prselector_core= sub {
 139         my ($var)= @_;
 140         my $name= $var->{Name};
 141         my $lname= lc $var->{Name};
 142         my $delim= $var->{Before};
 143         my $canon= &{$var->{CmpCanon}}($styles{$name});
 144         my $cvalix= 0;
 145         foreach my $valr (@{ $var->{Values} }) {
 146                 print $delim;  $delim= "\n|\n";
 147                 my ($value,$html) = @$valr;
 148                 my $iscurrent= &{$var->{CmpCanon}}($value) eq $canon;
 149                 my $after;
 150                 if ($iscurrent) {
 151                         print '<b>';
 152                         $after= '</b>';
 153                 } else {
 154                         my %qf= (%baseqf,%queryqf);
 155                         delete $qf{$lname};
 156                         $qf{$lname}= $value if $cvalix;
 157 </%perl>
 158 <a href="<% $quri->(%qf) |h %>">
 159 <%perl>
 160                         $after= '</a>';
 161                 }
 162                 print $html, $after;
 163                 $cvalix++;
 164         }
 165         print "<p>\n\n";
 166 };
 167
 168 my $prselector= sub {
 169         my ($name)= @_;
 170         foreach my $var (@vars) {
 171                 if ($var->{Name} eq $name) {
 172                         $prselector_core->($var);
 173                         return;
 174                 }
 175         }
 176         die $name;
 177 };
 178
 179 foreach my $var (@vars) {
 180         next if $var->{QuerySpecific};
 181         $prselector_core->($var);
 182 }
 183
 184 #---------- initial checks, startup, main entry form ----------
 185
 186 die if $styles{Query} =~ m/[^a-z]/;
 187
 188 my $mydbh;
 189 my $dbh= ($mydbh= dbw_connect($styles{Ocean}));
 190
 191 my $results_head_done=0;
 192 my $someresults= sub {
 193         return if $results_head_done;
 194         $results_head_done=1;
 195         print "\n<h1>Results</h1>\n";
 196 };
 197
 198 </%perl>
 199 <%args>
 200 $debug => 0
 201 </%args>
 202
 203 <hr>
 204
 205 <& "query_$styles{Query}", %baseqf, %queryqf, %styles,
 206     quri => $quri, dbh => $dbh,
 207     prselector => $prselector,
 208     someresults => $someresults,
 209     emsgokorprint => sub {
 210         my ($emsg) = @_;
 211         return 1 unless defined $emsg and length $emsg;
 212         $someresults->();
 213         print $emsg;
 214         return 0;
 215     }
 216  &>
 217
 218 <p>
 219
 220 %#---------- debugging and epilogue ----------
 221
 222 % if ($debug) {
 223 <p>
 224 <pre id="debug_log">
 225 Debug log:
 226 </pre>
 227 % }
 228
 229 <&| script &>
 230 function debug (m) {
 231 % if ($debug) {
 232   var node= document.getElementById('debug_log');
 233   node.innerHTML += "\n" + m + "\n";
 234 % }
 235 }
 236 </&script>
 237
 238 <& footer &>
 239
 240 <%init>
 241 use CommodsWeb;
 242 use HTML::Entities;
 243 use URI::Escape;
 244
 245 </%init>
 246 <%cleanup>
 247
 248 $mydbh->rollback() if $mydbh;
 249
 250 </%cleanup>