X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.main.git;a=blobdiff_plain;f=yarrg%2Fweb%2Flookup;h=a2ccc8de0a80df6b3659fafc95bdc41976888deb;hp=41eda49db3359e0462a330245c3ce1468fe9b86d;hb=3ce667a2d3fd7c36f60da86bb59071264790e375;hpb=974db6fb76db530406e21d71b785cc3b6f5c3079 diff --git a/yarrg/web/lookup b/yarrg/web/lookup old mode 100644 new mode 100755 index 41eda49..a2ccc8d --- a/yarrg/web/lookup +++ b/yarrg/web/lookup @@ -1,44 +1,43 @@ -%# 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. -%# +<%doc> + + 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; +my %styles; #---------- "mode" argument parsing and mode menu at top of page ---------- @@ -57,7 +56,36 @@ my %islandid2; }, { Name => 'Query', Before => 'Query: ', Values => [ [ 'route', 'Trades for route' ], + [ 'commod', 'Prices for commodity' ], + [ 'offers', 'Offers at location' ], + [ 'routesearch', 'Find profitable route' ], [ 'age', 'Data age' ] ] + }, { Name => 'BuySell', + Before => '', + Values => [ [ 'buy_sell', 'Buy and sell' ], + [ 'sell_buy', 'Sell and buy' ], + [ 'buy', 'Buy offers only' ], + [ 'sell', 'Sell offers only' ], + ], + QuerySpecific => 1, + }, { Name => 'ShowBlank', + Before => '', + Values => [ [ 0, 'Omit islands with no offers' ], + [ 'show', 'Show all islands' ], + ], + QuerySpecific => 1, + }, { Name => 'ShowStalls', + Before => '', + Values => [ [ 0, 'Show total quantity at each price' ], + [ 1, 'Show individual stalls' ], + ], + QuerySpecific => 1, + }, { Name => 'RouteSearchType', + Before => 'Type of routes to search for: ', + Values => [ [ 0, 'Open-ended' ], + [ 1, 'Circular' ], + ], + QuerySpecific => 1, }); foreach my $var (@vars) { @@ -70,37 +98,83 @@ foreach my $var (@vars) { $val= [ $val, encode_entities($val) ]; } if (exists $ARGS{$lname}) { - $a{$name}= $ARGS{$lname}; - my @html= grep { $_->[0] eq $a{$name} } @{ $var->{Values} }; + $styles{$name}= $ARGS{$lname}; + my @html= grep { $_->[0] eq $styles{$name} } + @{ $var->{Values} }; $ahtml{$name}= @html==1 ? $html[0][1] : '???'; } else { - $a{$name}= $var->{Values}[0][0]; + $styles{$name}= $var->{Values}[0][0]; $ahtml{$name}= $var->{Values}[0][1]; } } -<% ucfirst $ahtml{Query} %> - YARRG -<& webcopyright &> +<%shared> +my %baseqf; +my %queryqf; + + +<%method formhidden> +<%args> +$ours + +% foreach my $n (keys %baseqf, keys %queryqf) { +% next if $ours->($n); +% my $v= exists $baseqf{$n} ? $baseqf{$n} : $queryqf{$n}; + value="<% $v |h %>"> +% } + + +<% ucfirst $ahtml{Query} %> - YARRG + +<&| script &> + function register_onload(f) { + var previous_onload= window.onload; + window.onload= function() { + if (previous_onload) previous_onload(); + f(); + }; + } + + + +% if (!printable($m)) { YARRG - Yet Another Revenue Research Gatherer | +introduction +| documentation +| +development

+% } <%perl> -my %baseqf; foreach my $var (@vars) { my $lname= lc $var->{Name}; next unless exists $ARGS{$lname}; $baseqf{$lname}= $ARGS{$lname}; } -my %queryqf; foreach my $var (keys %ARGS) { next unless $var =~ - m/^(?:routestring|islandid\d|archipelago\d|debug)$/; + m/^(?: (?:route|commod|capacity|capital|island)string | + lossperleague | distance | + commodid | + islandid \d | + archipelago \d | + debug | + [RT]\w+ + )$/x; my $val= $ARGS{$var}; next if $val eq 'none'; $queryqf{$var}= $val; @@ -112,11 +186,13 @@ my $quri= sub { $uri->path_query(); }; -foreach my $var (@vars) { +my $prselector_core= sub { + my ($var)= @_; + return if printable($m); my $name= $var->{Name}; my $lname= lc $var->{Name}; my $delim= $var->{Before}; - my $canon= &{$var->{CmpCanon}}($a{$name}); + my $canon= &{$var->{CmpCanon}}($styles{$name}); my $cvalix= 0; foreach my $valr (@{ $var->{Values} }) { print $delim; $delim= "\n|\n"; @@ -130,260 +206,72 @@ foreach my $var (@vars) { my %qf= (%baseqf,%queryqf); delete $qf{$lname}; $qf{$lname}= $value if $cvalix; - print ''; + + +<%perl> $after= ''; } print $html, $after; $cvalix++; } print "

\n\n"; -} - -#---------- initial checks, startup, main entry form ---------- - -dbw_connect($a{Ocean}); - - -<%args> -$debug => 0 -$routestring => '' - - -

- -%########### query `route' ########## -% if ($a{Query} eq 'route') { - -

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])); +my $prselector= sub { + my ($name)= @_; + foreach my $var (@vars) { + if ($var->{Name} eq $name) { + $prselector_core->($var); + return; + } } - return $out; + die $name; }; -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" ] ]; -} - -$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 { }; -}; +#---------- initial checks, startup, main entry form ---------- -#---------- 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]; - } - } - } +die if $styles{Query} =~ m/[^a-z]/; -} else { #---------- results - dropdowns ---------- +my $mydbh; +my $dbh= ($mydbh= dbw_connect($styles{Ocean})); -my $argorundef= sub { - my ($dd,$base) = @_; - my $thing= $ARGS{"${base}${dd}"}; - $thing= undef if defined $thing and $thing eq 'none'; - return $thing; +my $results_head_done=0; +my $someresults= sub { + return if $results_head_done; + $results_head_done=1; + my ($h)= @_; + $h= 'Results' if !$h; + print "\n

$h

\n"; }; -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 +<%args> +$debug => 0 + -% if (@islandids) { -% $results_head->(); - -<& routetrade, islandids => \@islandids, archipelagoes => \@archipelagoes &> - +% if (!printable($m)) { +
% } -% } elsif ($a{Query} eq 'age') { -% ########### query `age' ########## - -

Market data age

-<& dataage, %baseqf, %queryqf &> +<& "query_$styles{Query}", %baseqf, %queryqf, %styles, + quri => $quri, dbh => $dbh, queryqf => \%queryqf, allargs => \%ARGS, + prselector => $prselector, + someresults => $someresults, + emsgokorprint => sub { + my ($emsg) = @_; + return 1 unless defined $emsg and length $emsg; + $someresults->(); + print $emsg; + return 0; + } + &> -% } ########## end of `age' query ########## +

%#---------- debugging and epilogue ---------- @@ -394,14 +282,14 @@ Debug log: % } - + <& footer &> @@ -409,6 +297,10 @@ function debug (m) { use CommodsWeb; use HTML::Entities; use URI::Escape; -use JSON; +<%cleanup> + +$mydbh->rollback() if $mydbh; + +