chiark / gitweb /
Revamp qtextstring arrangements
authorIan Jackson <ian@liberator.relativity.greenend.org.uk>
Sun, 16 Aug 2009 12:06:12 +0000 (13:06 +0100)
committerIan Jackson <ian@liberator.relativity.greenend.org.uk>
Sun, 16 Aug 2009 12:06:12 +0000 (13:06 +0100)
yarrg/web/check_commodstring [new file with mode: 0644]
yarrg/web/check_routestring
yarrg/web/lookup
yarrg/web/qtextstring
yarrg/web/qtextstringcheck [changed mode: 0644->0755]
yarrg/web/query_commod
yarrg/web/query_route

diff --git a/yarrg/web/check_commodstring b/yarrg/web/check_commodstring
new file mode 100644 (file)
index 0000000..126dc21
--- /dev/null
@@ -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 <ijackson@chiark.greenend.org.uk>
+ 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 <http://www.gnu.org/licenses/>.
+
+ 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.
+
+</%doc>
+
+<%attr>
+multiple => 0
+</%attr>
+
+<%method sqlstmt>
+SELECT commodname,commodid
+       FROM commods WHERE commodname LIKE ?
+</%method>
+
+<%method nomatch>
+  no commodity matches "<% $ARGS{spec} |h %>"
+</%method>
+
+<%method ambiguous>
+  ambiguous commodity "<% $ARGS{spec} |h %>",
+  could be <% $ARGS{couldbe} |h %>
+</%method>
index e66cbfb..55c0783 100755 (executable)
  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.
 
 </%doc>
 
-<%flags>
-inherit => 'qtextstringcheck'
-</%flags>
-
-<%args>
-$ocean
-$format
-$ctype => undef
-$string
-$returnhash => { }
-</%args>
-
-<%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->('&nbsp;');
-               } 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 ];
-
-</%perl>
+<%attr>
+multiple => 1
+</%attr>
+
+<%method sqlstmt>
+               SELECT islandname,islandid,archipelago
+                       FROM islands WHERE islandname LIKE ?
+UNION ALL      SELECT DISTINCT archipelago,NULL,archipelago
+                       FROM islands WHERE archipelago LIKE ?
+</%method>
+
+<%method nomatch>
+  no island or arch matches "<% $ARGS{spec} |h %>"
+</%method>
+
+<%method ambiguous>
+  ambiguous island or arch "<% $ARGS{spec} |h %>",
+  could be <% $ARGS{couldbe} |h %>
+</%method>
index 0106684..a118de0 100755 (executable)
@@ -35,9 +35,9 @@
 
 </%doc>
 <%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});
 
 </%perl>
 <%args>
@@ -153,7 +154,7 @@ $debug => 0
 
 <hr>
 
-<& "query_$a{Query}", %baseqf, %queryqf, quri => $quri, qa => \%a &>
+<& "query_$styleqf{Query}", %baseqf, %queryqf, %styleqf, quri => $quri &>
 
 <p>
 
index 6efe368..82c29dc 100644 (file)
@@ -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.
 
 
 </%doc>
@@ -46,7 +48,8 @@ Enter route (islands, or archipelagoes, separated by |s or commas;
  abbreviations are OK):<br>
 
 <&| 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;
old mode 100644 (file)
new mode 100755 (executable)
index 4018455..337ed31
  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
+
 </%doc>
+
+<%args>
+$ocean
+$format
+$ctype => undef
+$string
+$what
+</%args>
+
 <%flags>
 inherit => undef
 </%flags>
@@ -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->('&nbsp;');
+               } 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) :
                                              '&nbsp;'),
        };
@@ -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 ];
+
 </%perl>
index ab87cac..5a7497b 100644 (file)
 </%doc>
 <%args>
 $quri
-$qa
 $commodstring => '';
 </%args>
 
+% my $qa= \%ARGS;
+
 %#---------- textbox, user enters route as string ----------
 % if (!$qa->{Dropdowns}) {
 
index ea94d61..dd8644f 100644 (file)
@@ -35,7 +35,6 @@
 </%doc>
 <%args>
 $quri
-$qa
 $routestring => '';
 </%args>
 <%perl>
@@ -44,6 +43,7 @@ my @archipelagoes;
 my @islandids;
 my %islandid2;
 
+my $qa= \%ARGS;
 </%perl>
 
 %#---------- 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];
                } 
        }
   }