Revamp qtextstring arrangements

diff --git a/yarrg/web/check_commodstring b/yarrg/web/check_commodstring
new file mode 100644 (file)
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 <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>

diff --git a/yarrg/web/check_routestring b/yarrg/web/check_routestring
index e66cbfbfd35e855ef3a514806cf693426ceae24b..55c0783e8f64e15871d353bee006b068d37551e2 100755 (executable)
--- a/yarrg/web/check_routestring
+++ b/yarrg/web/check_routestring
@@ -29,70 +29,27 @@
  sponsored by Three Rings.
 
 
  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>
 
 
 </%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>

diff --git a/yarrg/web/lookup b/yarrg/web/lookup
index 0106684af46e5ba515d69b9b3aa4a92be2fc9d19..a118de0905a4d1e58cd500fcc732b20811f847ef 100755 (executable)
--- a/yarrg/web/lookup
+++ b/yarrg/web/lookup
@@ -35,9 +35,9 @@
 
 </%doc>
 <%perl>
 
 </%doc>
 <%perl>

-my %a;

 my %ahtml;
 my @vars;
 my %ahtml;
 my @vars;

+my %styleqf;

 
 #---------- "mode" argument parsing and mode menu at top of page ----------
 
 
 #---------- "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}) {
                $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 {
                $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];
        }
 }
                $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 $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";
        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 ----------
 
 
 #---------- 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>
 
 </%perl>
 <%args>


@@ -153,7 +154,7 @@ $debug => 0
 
 <hr>
 
 
 <hr>
 

-<& "query_$a{Query}", %baseqf, %queryqf, quri => $quri, qa => \%a &>
+<& "query_$styleqf{Query}", %baseqf, %queryqf, %styleqf, quri => $quri &>

 
 <p>
 
 
 <p>
 

diff --git a/yarrg/web/qtextstring b/yarrg/web/qtextstring
index 6efe368e650dfc396b020f5fa58f5679d3c86426..82c29dcda728e030ef4587fca3dc0a086b9bce87 100644 (file)
--- a/yarrg/web/qtextstring
+++ b/yarrg/web/qtextstring
@@ -29,7 +29,9 @@
  sponsored by Three Rings.
 
 
  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>
 
 
 </%doc>


@@ -46,7 +48,8 @@ Enter route (islands, or archipelagoes, separated by |s or commas;
  abbreviations are OK):<br>
 
 <&| script &>
  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;
                + "&ocean=<% uri_escape($qa->{Ocean}) %>";
 
 ts_timeout=false;

diff --git a/yarrg/web/qtextstringcheck b/yarrg/web/qtextstringcheck
old mode 100644 (file)
new mode 100755 (executable)
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.
 
  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>
 </%doc>

+
+<%args>
+$ocean
+$format
+$ctype => undef
+$string
+$what
+</%args>
+

 <%flags>
 inherit => undef
 </%flags>
 <%flags>
 inherit => undef
 </%flags>


@@ -41,19 +53,60 @@ inherit => undef
 use JSON;
 use Data::Dumper;
 use HTML::Entities;
 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;
 
 $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,
 
 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;'),
        };
                         length $canontext ? encode_entities($canontext) :
                                              '&nbsp;'),
        };


@@ -61,7 +114,13 @@ if ($format =~ /json/) {
 }
 if ($format =~ /dump/) {
        $r->content_type('text/plain');
 }
 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>
 </%perl>

diff --git a/yarrg/web/query_commod b/yarrg/web/query_commod
index ab87cac30e5bb6e7d01ef638f3906dd8a11ae16e..5a7497bac9d3d8d042bf40c031d565bf952607d2 100644 (file)
--- a/yarrg/web/query_commod
+++ b/yarrg/web/query_commod
@@ -35,10 +35,11 @@
 </%doc>
 <%args>
 $quri
 </%doc>
 <%args>
 $quri

-$qa

 $commodstring => '';
 </%args>
 
 $commodstring => '';
 </%args>
 

+% my $qa= \%ARGS;
+

 %#---------- textbox, user enters route as string ----------
 % if (!$qa->{Dropdowns}) {
 
 %#---------- textbox, user enters route as string ----------
 % if (!$qa->{Dropdowns}) {
 

diff --git a/yarrg/web/query_route b/yarrg/web/query_route
index ea94d61c8f20ddf3428f2d873232c4e2f1d27557..dd8644f1675694d200e28341d0b32bc5d6396422 100644 (file)
--- a/yarrg/web/query_route
+++ b/yarrg/web/query_route
@@ -35,7 +35,6 @@
 </%doc>
 <%args>
 $quri
 </%doc>
 <%args>
 $quri

-$qa

 $routestring => '';
 </%args>
 <%perl>
 $routestring => '';
 </%args>
 <%perl>


@@ -44,6 +43,7 @@ my @archipelagoes;
 my @islandids;
 my %islandid2;
 
 my @islandids;
 my %islandid2;
 

+my $qa= \%ARGS;

 </%perl>
 
 %#---------- textbox, user enters route as string ----------
 </%perl>
 
 %#---------- textbox, user enters route as string ----------


@@ -170,7 +170,8 @@ $results_head= sub {
 if (!$qa->{Dropdowns}) {
   if (length $routestring) {
        $results_head->();
 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'
                ocean => $qa->{Ocean},
                string => $routestring,
                format => 'return'


@@ -179,9 +180,9 @@ if (!$qa->{Dropdowns}) {
                print encode_entities($emsg);
        } else {
                foreach my $entry (@$results) {
                print encode_entities($emsg);
        } else {
                foreach my $entry (@$results) {

-                       push @archipelagoes,
-                               defined $entry->[1] ? undef : $entry->[0];

                        push @islandids, $entry->[1];
                        push @islandids, $entry->[1];

+                       push @archipelagoes,
+                               defined $entry->[1] ? undef : $entry->[2];

                } 
        }
   }
                } 
        }
   }