chiark / gitweb /
Merge branch 'stable-5.x'
[ypp-sc-tools.db-test.git] / 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         }, {    Name => 'RouteSearchType',
84                 Before => 'Type of routes to search for: ',
85                 Values => [     [ 0, 'Open-ended' ],
86                                 [ 1, 'Circular' ],
87                         ],
88                 QuerySpecific => 1,
89         });
90
91 foreach my $var (@vars) {
92         my $name= $var->{Name};
93         my $lname= lc $name;
94         $var->{Before}= '' unless exists $var->{Before};
95         $var->{CmpCanon}= sub { $_[0]; } unless exists $var->{CmpCanon};
96         foreach my $val (@{ $var->{Values} }) {
97                 next if ref $val;
98                 $val= [ $val, encode_entities($val) ];
99         }
100         if (exists $ARGS{$lname}) {
101                 $styles{$name}= $ARGS{$lname};
102                 my @html= grep { $_->[0] eq $styles{$name} }
103                                 @{ $var->{Values} };
104                 $ahtml{$name}= @html==1 ? $html[0][1] : '???';
105         } else {
106                 $styles{$name}= $var->{Values}[0][0];
107                 $ahtml{$name}= $var->{Values}[0][1];
108         }
109 }
110
111 </%perl>
112
113 <%shared>
114 my %baseqf;
115 my %queryqf;
116 </%shared>
117
118 <%method formhidden>
119 <%args>
120 $ours
121 </%args>
122 % foreach my $n (keys %baseqf, keys %queryqf) {
123 %       next if $ours->($n);
124 %       my $v= exists $baseqf{$n} ? $baseqf{$n} : $queryqf{$n};
125 <input type=hidden name=<% $n %> value="<% $v |h %>">
126 % }
127 </%method>
128
129 <html lang="en"><head><title><% ucfirst $ahtml{Query} %> - YARRG</title>
130 <style type="text/css">
131 <& style.css &>
132   body { margin: 0; color: #000000; background: #c5c7ae; }
133   div.query { background: #d7d8b3; padding: 1em; }
134   div.results { padding: 1em; }
135   table.data { background: #b5b686; }
136   tr.datarow0 { background: #e3e3e3; }
137   tr.datarow1 { background: #ffffff; }
138 </style>
139 <&| script &>
140   function register_onload(f) {
141     var previous_onload= window.onload;
142     window.onload= function() {
143       if (previous_onload) previous_onload();
144       f();
145     };
146   }
147 </&script>
148 </head><body>
149
150 % if (!printable($m)) {
151 <div class="navoptbar">
152 <& navbar &>
153 <p>
154 % }
155 <%perl>
156
157 foreach my $var (@vars) {
158         my $lname= lc $var->{Name};
159         next unless exists $ARGS{$lname};
160         $baseqf{$lname}= $ARGS{$lname};
161 }
162
163 foreach my $var (keys %ARGS) {
164         next unless $var =~
165                 m/^(?: (?:route|commod|capacity|capital|island)string |
166                         lossperleague | distance |
167                         commodid |
168                         islandid \d |
169                         archipelago \d |
170                         debug |
171                         [RT]\w+
172                     )$/x;
173         my $val= $ARGS{$var};
174         next if $val eq 'none';
175         $queryqf{$var}= $val;
176 }
177
178 my $quri= sub {
179         my $uri= URI->new('lookup');
180         $uri->query_form(@_);
181         $uri->path_query();
182 };
183
184 my $prselector_core= sub {
185         my ($var)= @_;
186         return if printable($m);
187         my $name= $var->{Name};
188         my $lname= lc $var->{Name};
189         my $delim= $var->{Before};
190         my $canon= &{$var->{CmpCanon}}($styles{$name});
191         my $cvalix= 0;
192         foreach my $valr (@{ $var->{Values} }) {
193                 print $delim;  $delim= "\n|\n";
194                 my ($value,$html) = @$valr;
195                 my $iscurrent= &{$var->{CmpCanon}}($value) eq $canon;
196                 my $after;
197                 if ($iscurrent) {
198                         print '<b>';
199                         $after= '</b>';
200                 } else {
201                         my %qf= (%baseqf,%queryqf);
202                         delete $qf{$lname};
203                         $qf{$lname}= $value if $cvalix;
204 </%perl>
205 <a href="<% $quri->(%qf) |h %>">
206 <%perl>
207                         $after= '</a>';
208                 }
209                 print $html, $after;
210                 $cvalix++;
211         }
212         print "<p>\n\n";
213 };
214
215 my $prselector= sub {
216         my ($name)= @_;
217         foreach my $var (@vars) {
218                 if ($var->{Name} eq $name) {
219                         $prselector_core->($var);
220                         return;
221                 }
222         }
223         die $name;
224 };
225
226 foreach my $var (@vars) {
227         next if $var->{QuerySpecific};
228         $prselector_core->($var);
229 }
230
231 #---------- initial checks, startup, main entry form ----------
232
233 die if $styles{Query} =~ m/[^a-z]/;
234
235 my $mydbh;
236 my $dbh= ($mydbh= dbw_connect($styles{Ocean}));
237
238 my $results_head_done=0;
239 my $someresults= sub {
240         return if $results_head_done;
241         $results_head_done=1;
242         my ($h)= @_;
243         $h= 'Results' if !$h;
244         print "\n<h1>$h</h1>\n";
245 };
246
247 </%perl>
248 <%args>
249 $debug => 0
250 </%args>
251
252 % if (!printable($m)) {
253 </div>
254 <hr>
255 % }
256
257 <& "query_$styles{Query}", %baseqf, %queryqf, %styles,
258     quri => $quri, dbh => $dbh,
259     baseqf => \%baseqf, queryqf => \%queryqf, allargs => \%ARGS,
260     prselector => $prselector,
261     someresults => $someresults,
262     emsgokorprint => sub {
263         my ($emsg) = @_;
264         return 1 unless defined $emsg and length $emsg;
265         $someresults->();
266         print $emsg;
267         return 0;
268     }
269  &>
270
271 %#---------- debugging and epilogue ----------
272
273 % if ($debug) {
274 <div class="results">
275 <pre id="debug_log">
276 Debug log:
277 </pre>
278 </div>
279 % }
280
281 <&| script &>
282 function debug (m) {
283 % if ($debug) {
284   var node= document.getElementById('debug_log');
285   node.innerHTML += "\n" + m + "\n";
286 % }
287 }
288 </&script>
289
290 <& footer &>
291
292 <%init>
293 use CommodsWeb;
294 use HTML::Entities;
295 use URI::Escape;
296
297 </%init>
298 <%cleanup>
299
300 $mydbh->rollback() if $mydbh;
301
302 </%cleanup>