--- /dev/null
+<%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>
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->(' ');
- } 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>
</%doc>
<%perl>
-my %a;
my %ahtml;
my @vars;
+my %styleqf;
#---------- "mode" argument parsing and mode menu at top of page ----------
$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];
}
}
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";
#---------- 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>
<hr>
-<& "query_$a{Query}", %baseqf, %queryqf, quri => $quri, qa => \%a &>
+<& "query_$styleqf{Query}", %baseqf, %queryqf, %styleqf, quri => $quri &>
<p>
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>
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;
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>
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) :
' '),
};
}
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>
</%doc>
<%args>
$quri
-$qa
$commodstring => '';
</%args>
+% my $qa= \%ARGS;
+
%#---------- textbox, user enters route as string ----------
% if (!$qa->{Dropdowns}) {
</%doc>
<%args>
$quri
-$qa
$routestring => '';
</%args>
<%perl>
my @islandids;
my %islandid2;
+my $qa= \%ARGS;
</%perl>
%#---------- textbox, user enters route as string ----------
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'
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];
}
}
}