From b6d8c4a781c0bedf79a4b13af5afe9ad47de97ed Mon Sep 17 00:00:00 2001 From: Ian Jackson Date: Sun, 16 Aug 2009 13:06:12 +0100 Subject: [PATCH] Revamp qtextstring arrangements --- yarrg/web/check_commodstring | 53 ++++++++++++++++++++++ yarrg/web/check_routestring | 85 +++++++++--------------------------- yarrg/web/lookup | 17 ++++---- yarrg/web/qtextstring | 7 ++- yarrg/web/qtextstringcheck | 73 ++++++++++++++++++++++++++++--- yarrg/web/query_commod | 3 +- yarrg/web/query_route | 9 ++-- 7 files changed, 161 insertions(+), 86 deletions(-) create mode 100644 yarrg/web/check_commodstring mode change 100644 => 100755 yarrg/web/qtextstringcheck diff --git a/yarrg/web/check_commodstring b/yarrg/web/check_commodstring new file mode 100644 index 0000000..126dc21 --- /dev/null +++ b/yarrg/web/check_commodstring @@ -0,0 +1,53 @@ +<%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 simply defines how to look up commodities. + It is called by qtextstring. + + + +<%attr> +multiple => 0 + + +<%method sqlstmt> +SELECT commodname,commodid + FROM commods WHERE commodname LIKE ? + + +<%method nomatch> + no commodity matches "<% $ARGS{spec} |h %>" + + +<%method ambiguous> + ambiguous commodity "<% $ARGS{spec} |h %>", + could be <% $ARGS{couldbe} |h %> + diff --git a/yarrg/web/check_routestring b/yarrg/web/check_routestring index e66cbfb..55c0783 100755 --- a/yarrg/web/check_routestring +++ b/yarrg/web/check_routestring @@ -29,70 +29,27 @@ sponsored by Three Rings. - This Mason component parses textual strings giving lists of islands - and archipelagoes, ie textual route strings. + This Mason component simply defines how to look up route entries. + It is called by qtextstring. -<%flags> -inherit => 'qtextstringcheck' - - -<%args> -$ocean -$format -$ctype => undef -$string -$returnhash => { } - - -<%perl> - -# typical url for this script: -# http://www.chiark.greenend.org.uk/ucgi/~clareb/mason/pirates/routetextstring?format=json&ocean=Midnight&string=d - -use CommodsWeb; - -my $dbh= dbw_connect($ocean); - -my $sth= $dbh->prepare("SELECT archipelago,islandid,islandname - FROM islands WHERE islandname LIKE ? - UNION ALL SELECT DISTINCT archipelago,NULL,archipelago - FROM islands WHERE archipelago LIKE ?"); - -my $emsg= ''; -my (@results, $canontext); - -foreach my $each (split m#[/|,]#, $string) { - $each =~ s/^\s*//; $each =~ s/\s*$//; $each =~ s/\s+/ /g; - next if !length $each; - my $err= sub { $emsg= sprintf $_[0], $each; last; }; - my %m; - my $results; - foreach my $pat ("$each\%", "\%$each\%") { - $sth->execute($pat,$pat); - $results= $sth->fetchall_arrayref(); - last if @$results==1; - map { $m{ $_->[2] }=1 } @$results; - $results= undef; - } - if (!$results) { - if (!%m) { - $err->('no island or arch matches "%s"'); - } elsif (keys(%m) > 5) { - $err->(' '); - } else { - $err->('ambiguous island or arch "%s",'. - ' could be '.join(', ', sort keys %m)); - } - } - push @results, $results->[0]; -}; - -$dbh->rollback(); - -return $emsg, - (join ' | ', map { $_->[2] } @results), - [ @results ]; - - +<%attr> +multiple => 1 + + +<%method sqlstmt> + SELECT islandname,islandid,archipelago + FROM islands WHERE islandname LIKE ? +UNION ALL SELECT DISTINCT archipelago,NULL,archipelago + FROM islands WHERE archipelago LIKE ? + + +<%method nomatch> + no island or arch matches "<% $ARGS{spec} |h %>" + + +<%method ambiguous> + ambiguous island or arch "<% $ARGS{spec} |h %>", + could be <% $ARGS{couldbe} |h %> + diff --git a/yarrg/web/lookup b/yarrg/web/lookup index 0106684..a118de0 100755 --- a/yarrg/web/lookup +++ b/yarrg/web/lookup @@ -35,9 +35,9 @@ <%perl> -my %a; my %ahtml; my @vars; +my %styleqf; #---------- "mode" argument parsing and mode menu at top of page ---------- @@ -70,11 +70,12 @@ 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} }; + $styleqf{$name}= $ARGS{$lname}; + my @html= grep { $_->[0] eq $styleqf{$name} } + @{ $var->{Values} }; $ahtml{$name}= @html==1 ? $html[0][1] : '???'; } else { - $a{$name}= $var->{Values}[0][0]; + $styleqf{$name}= $var->{Values}[0][0]; $ahtml{$name}= $var->{Values}[0][1]; } } @@ -115,7 +116,7 @@ foreach my $var (@vars) { my $name= $var->{Name}; my $lname= lc $var->{Name}; my $delim= $var->{Before}; - my $canon= &{$var->{CmpCanon}}($a{$name}); + my $canon= &{$var->{CmpCanon}}($styleqf{$name}); my $cvalix= 0; foreach my $valr (@{ $var->{Values} }) { print $delim; $delim= "\n|\n"; @@ -142,9 +143,9 @@ foreach my $var (@vars) { #---------- initial checks, startup, main entry form ---------- -die if $a{Query} =~ m/[^a-z]/; +die if $styleqf{Query} =~ m/[^a-z]/; -dbw_connect($a{Ocean}); +dbw_connect($styleqf{Ocean}); <%args> @@ -153,7 +154,7 @@ $debug => 0
-<& "query_$a{Query}", %baseqf, %queryqf, quri => $quri, qa => \%a &> +<& "query_$styleqf{Query}", %baseqf, %queryqf, %styleqf, quri => $quri &>

diff --git a/yarrg/web/qtextstring b/yarrg/web/qtextstring index 6efe368..82c29dc 100644 --- a/yarrg/web/qtextstring +++ b/yarrg/web/qtextstring @@ -29,7 +29,9 @@ sponsored by Three Rings. - This Mason component handles `live' analysis of text string entries. + This Mason component handles analysis of text string entries, including + both the AJAX calls from web page javascript and the entry validation + and processing calls from other components. @@ -46,7 +48,8 @@ Enter route (islands, or archipelagoes, separated by |s or commas; abbreviations are OK):
<&| script &> -ts_uri= "check_<% $thingstring %>?format=json&type=text/xml" +ts_uri= "qtextstringcheck?format=application/json&ctype=text/xml" + + "&what=<% $thingstring %>" + "&ocean=<% uri_escape($qa->{Ocean}) %>"; ts_timeout=false; diff --git a/yarrg/web/qtextstringcheck b/yarrg/web/qtextstringcheck old mode 100644 new mode 100755 index 4018455..337ed31 --- a/yarrg/web/qtextstringcheck +++ b/yarrg/web/qtextstringcheck @@ -32,7 +32,19 @@ This Mason component handles the generic output format options for text string parsers/checkers like check_routestring. +# typical url for this script: +# http://www.chiark.greenend.org.uk/ucgi/~clareb/mason/pirates/qtextstring?what=routestring?format=json&ocean=Midnight&string=d + + +<%args> +$ocean +$format +$ctype => undef +$string +$what + + <%flags> inherit => undef @@ -41,19 +53,60 @@ inherit => undef use JSON; use Data::Dumper; use HTML::Entities; - -my ($emsg, $canontext, $results)= $m->call_next(); +use CommodsWeb; + +die if $what =~ m/[^a-z]/; +my $specifics= "check_${what}"; +my $specific= $m->fetch_comp($specifics); + +my $dbh= dbw_connect($ocean); +my $sqlstmt= $specific->scall_method("sqlstmt"); +my $sth= $dbh->prepare($sqlstmt); +my @sqlstmt_qs= $sqlstmt =~ m/\?/g; + +#die "$sqlstmt @sqlstmt_qs"; + +my $emsg= ''; +my @results; + +my @specs= $specific->attr('multiple') ? (split m#[/|,]#, $string) : ($string); + +foreach my $each (@specs) { + $each =~ s/^\s*//; $each =~ s/\s*$//; $each =~ s/\s+/ /g; + next if !length $each; + my $err= sub { $emsg= $_[0]; last; }; + my %m; + my $results; + foreach my $pat ("$each", "$each\%", "\%$each\%") { + $sth->execute(($pat) x @sqlstmt_qs); + $results= $sth->fetchall_arrayref(); + last if @$results==1; + map { $m{ $_->[0] }=1 } @$results; + $results= undef; + } + if (!$results) { + if (!%m) { + $err->($specific->scall_method("nomatch", + spec => $each)); + } elsif (keys(%m) > 5) { + $err->(' '); + } else { + $err->($specific->scall_method("ambiguous", + spec => $each, + couldbe => join(', ', sort keys %m))); + } + } + push @results, $results->[0]; +}; $emsg='' if !defined $emsg; - -my $format= $ARGS{'format'}; -my $ctype= $ARGS{'ctype'}; +my $canontext= join ' | ', map { $_->[0] } @results; if ($format =~ /json/) { $r->content_type($ctype or $format); my $jobj= { success => 1*!length $emsg, - show => (length $emsg ? encode_entities($emsg) : + show => (length $emsg ? $emsg : length $canontext ? encode_entities($canontext) : ' '), }; @@ -61,7 +114,13 @@ if ($format =~ /json/) { } if ($format =~ /dump/) { $r->content_type('text/plain'); - print Dumper($emsg, $canontext, $results); + print Dumper($emsg, $canontext, \@results); } +$dbh->rollback(); + +return $emsg, + $canontext, + [ @results ]; + diff --git a/yarrg/web/query_commod b/yarrg/web/query_commod index ab87cac..5a7497b 100644 --- a/yarrg/web/query_commod +++ b/yarrg/web/query_commod @@ -35,10 +35,11 @@ <%args> $quri -$qa $commodstring => ''; +% my $qa= \%ARGS; + %#---------- textbox, user enters route as string ---------- % if (!$qa->{Dropdowns}) { diff --git a/yarrg/web/query_route b/yarrg/web/query_route index ea94d61..dd8644f 100644 --- a/yarrg/web/query_route +++ b/yarrg/web/query_route @@ -35,7 +35,6 @@ <%args> $quri -$qa $routestring => ''; <%perl> @@ -44,6 +43,7 @@ my @archipelagoes; my @islandids; my %islandid2; +my $qa= \%ARGS; %#---------- textbox, user enters route as string ---------- @@ -170,7 +170,8 @@ $results_head= sub { if (!$qa->{Dropdowns}) { if (length $routestring) { $results_head->(); - my ($emsg,$canonstring,$results)= $m->comp('check_routestring', + my ($emsg,$canonstring,$results)= $m->comp('qtextstringcheck', + what => 'routestring', ocean => $qa->{Ocean}, string => $routestring, format => 'return' @@ -179,9 +180,9 @@ if (!$qa->{Dropdowns}) { print encode_entities($emsg); } else { foreach my $entry (@$results) { - push @archipelagoes, - defined $entry->[1] ? undef : $entry->[0]; push @islandids, $entry->[1]; + push @archipelagoes, + defined $entry->[1] ? undef : $entry->[2]; } } } -- 2.30.2