chiark / gitweb /
Query-specific "var"s
[ypp-sc-tools.db-live.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                                 [ '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>