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