X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-live.git;a=blobdiff_plain;f=yarrg%2Fweb%2Flookup;h=751a99aa1a6916382c3843c610eda6691a02868b;hp=e062e60c6c4b072ca6daf1f96709f0d111e87cad;hb=013f7a0ab3bf8d2b1100022e8fc868407c751720;hpb=63f1acf6e7821a94d3a906ba831203ff916e7893 diff --git a/yarrg/web/lookup b/yarrg/web/lookup old mode 100644 new mode 100755 index e062e60..751a99a --- a/yarrg/web/lookup +++ b/yarrg/web/lookup @@ -1,18 +1,44 @@ -Route - YARRG +<%doc> -YARRG - - Yet Another Revenue Research Gatherer -

+ This is part of the YARRG website. YARRG is a tool and website + for assisting players of Yohoho Puzzle Pirates. + + Copyright (C) 2009 Ian Jackson + Copyright (C) 2009 Clare Boothby + + YARRG's client code etc. is covered by the ordinary GNU GPL (v3 or later). + The YARRG website is covered by the GNU Affero GPL v3 or later, which + basically means that every installation of the website will let you + download the source. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Affero General Public License as + published by the Free Software Foundation, either version 3 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Affero General Public License for more details. + + You should have received a copy of the GNU Affero General Public License + along with this program. If not, see . + + Yohoho and Puzzle Pirates are probably trademarks of Three Rings and + are used without permission. This program is not endorsed or + sponsored by Three Rings. + + + This Mason component generates the main `lookup' page, including + all the entry boxes etc. for every query. + + <%perl> my %a; +my %ahtml; my @vars; -# for output: -my @archipelagoes; -my @islandids; -my %islandid2; - #---------- "mode" argument parsing and mode menu at top of page ---------- # for debugging, invoke as @@ -27,6 +53,10 @@ my %islandid2; CmpCanon => sub { !!$_[0] }, Values => [ [ 0, 'Type in names' ], [ 4, 'Select from menus' ] ] + }, { Name => 'Query', + Before => 'Query: ', + Values => [ [ 'route', 'Trades for route' ], + [ 'age', 'Data age' ] ] }); foreach my $var (@vars) { @@ -40,11 +70,24 @@ foreach my $var (@vars) { } if (exists $ARGS{$lname}) { $a{$name}= $ARGS{$lname}; + my @html= grep { $_->[0] eq $a{$name} } @{ $var->{Values} }; + $ahtml{$name}= @html==1 ? $html[0][1] : '???'; } else { $a{$name}= $var->{Values}[0][0]; + $ahtml{$name}= $var->{Values}[0][1]; } } + +<% ucfirst $ahtml{Query} %> - YARRG + +YARRG - + Yet Another Revenue Research Gatherer +| +documentation +

+<%perl> + my %baseqf; foreach my $var (@vars) { my $lname= lc $var->{Name}; @@ -56,11 +99,16 @@ my %queryqf; foreach my $var (keys %ARGS) { next unless $var =~ m/^(?:routestring|islandid\d|archipelago\d|debug)$/; - $queryqf{$var}= $ARGS{$var}; + my $val= $ARGS{$var}; + next if $val eq 'none'; + $queryqf{$var}= $val; } -my $uri= URI->new($m->current_comp()->name()); -my $quri= sub { $uri->query_form(@_); $uri->path_query(); }; +my $quri= sub { + my $uri= URI->new('lookup'); + $uri->query_form(@_); + $uri->path_query(); +}; foreach my $var (@vars) { my $name= $var->{Name}; @@ -80,7 +128,9 @@ foreach my $var (@vars) { my %qf= (%baseqf,%queryqf); delete $qf{$lname}; $qf{$lname}= $value if $cvalix; - print ''; + + +<%perl> $after= ''; } print $html, $after; @@ -91,236 +141,20 @@ foreach my $var (@vars) { #---------- initial checks, startup, main entry form ---------- +die if $a{Query} =~ m/[^a-z]/; + dbw_connect($a{Ocean}); <%args> $debug => 0 -$routestring => '' -

Specify route

-
- -%#---------- textbox, user enters route as string ---------- -% if (!$a{Dropdowns}) { - -Enter route (islands, or archipelagoes, separated by |s or commas; - abbreviations are OK):
- - +
-
-
 

- -% } else { #---------- dropdowns, user selects from menus ---------- - -<%perl> -my ($sth,$row);; -my @archlistdata; -my %islandlistdata; -$islandlistdata{'none'}= [ [ "none", "Select island..." ] ]; - -my $optionlistmap= sub { - my ($optlist, $selected) = @_; - my $out=''; - foreach my $entry (@$optlist) { - $out.= sprintf('', - encode_entities($entry->[0]), - defined $selected && $entry->[0] eq $selected - ? 'selected' : '', - encode_entities($entry->[1])); - } - return $out; -}; - -my $dbh= dbw_connect($a{Ocean}); - -$sth= $dbh->prepare("SELECT DISTINCT archipelago FROM islands - ORDER BY archipelago;"); -$sth->execute(); - -while ($row=$sth->fetchrow_arrayref) { - my ($arch)= @$row; - push @archlistdata, [ $arch, $arch ]; - $islandlistdata{$arch}= [ [ "none", "Whole arch" ] ]; -} +<& "query_$a{Query}", %baseqf, %queryqf, quri => $quri, a => \%a &> -$sth= $dbh->prepare("SELECT islandid,islandname,archipelago - FROM islands - ORDER BY islandname;"); -$sth->execute(); - -while ($row=$sth->fetchrow_arrayref) { - my $arch= $row->[2]; - push @{ $islandlistdata{'none'} }, [ @$row ]; - push @{ $islandlistdata{$arch} }, [ @$row ]; - $islandid2{$row->[0]}= { Name => $row->[1], Arch => $arch }; -} - -my %resetislandlistdata; -foreach my $arch (keys %islandlistdata) { - $resetislandlistdata{$arch}= - $optionlistmap->($islandlistdata{$arch}, ''); -} - - - - - - - - - - -% for my $dd (0..$a{Dropdowns}-1) { - -% } - - - -% for my $dd (0..$a{Dropdowns}-1) { -% my $arch= $ARGS{"archipelago$dd"}; -% $arch= 'none' if !defined $arch; - -% } - - -
-
-
- -% } #---------- end of dropdowns, now common middle of page code ---------- - - -
- -<%perl> -#========== result computations ========== - -my $results_head; -$results_head= sub { - print "

Results

\n"; - $results_head= sub { }; -}; - -#---------- result computation - textstring ---------- -if (!$a{Dropdowns}) { - if (length $routestring) { - $results_head->(); - my $rsr= $m->comp('routetextstring', - ocean => $a{Ocean}, - string => $routestring, - format => 'return' - ); - if (length $rsr->{Error}) { - print encode_entities($rsr->{Error}); - } else { - foreach my $entry (@{ $rsr->{Results} }) { - push @archipelagoes, - defined $entry->[1] ? undef : $entry->[0]; - push @islandids, $entry->[1]; - } - } - } - -} else { #---------- results - dropdowns ---------- - -my $argorundef= sub { - my ($dd,$base) = @_; - my $thing= $ARGS{"${base}${dd}"}; - $thing= undef if defined $thing and $thing eq 'none'; - return $thing; -}; - -for my $dd (0..$a{Dropdowns}-1) { - my $arch= $argorundef->($dd,'archipelago'); - my $island= $argorundef->($dd,'islandid'); - next unless defined $arch or defined $island; - if (defined $island and defined $arch) { - my $ii= $islandid2{$island}; - my $iarch= $ii->{Arch}; - if ($iarch ne $arch) { - $results_head->(); - - Specified archipelago <% $arch %> but - island <% $ii->{Name} %> - which is in <% $iarch %>; using the island.
-<%perl> - } - $arch= undef; - } - push @archipelagoes, $arch; - push @islandids, $island; -} - -}#---------- result processing, common stuff - - -% if (@islandids) { -% $results_head->(); - -<& routetrade, islandids => \@islandids, archipelagoes => \@archipelagoes &> - -% } +

%#---------- debugging and epilogue ---------- @@ -331,19 +165,20 @@ Debug log: % } - + + +<& footer &> <%init> use CommodsWeb; use HTML::Entities; use URI::Escape; -use JSON;