1 %# This is part of the YARRG website. YARRG is a tool and website
2 %# for assisting players of Yohoho Puzzle Pirates.
4 %# Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
5 %# Copyright (C) 2009 Clare Boothby
7 %# YARRG's client code etc. is covered by the ordinary GNU GPL (v3 or later).
8 %# The YARRG website is covered by the GNU Affero GPL v3 or later, which
9 %# basically means that every installation of the website will let you
10 %# download the source.
12 %# This program is free software: you can redistribute it and/or modify
13 %# it under the terms of the GNU Affero General Public License as
14 %# published by the Free Software Foundation, either version 3 of the
15 %# License, or (at your option) any later version.
17 %# This program is distributed in the hope that it will be useful,
18 %# but WITHOUT ANY WARRANTY; without even the implied warranty of
19 %# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 %# GNU Affero General Public License for more details.
22 %# You should have received a copy of the GNU Affero General Public License
23 %# along with this program. If not, see <http://www.gnu.org/licenses/>.
25 %# Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
26 %# are used without permission. This program is not endorsed or
27 %# sponsored by Three Rings.
30 %# This Mason component parses textual strings giving lists of islands
31 %# and archipelagoes, ie textual route strings.
41 # typical url for this script:
42 # http://www.chiark.greenend.org.uk/ucgi/~clareb/mason/pirates/routetextstring?format=json&ocean=Midnight&string=d
50 my $dbh= dbw_connect($ocean);
52 my $sth= $dbh->prepare("SELECT archipelago,islandid,islandname
53 FROM islands WHERE islandname LIKE ?
54 UNION ALL SELECT DISTINCT archipelago,NULL,archipelago
55 FROM islands WHERE archipelago LIKE ?");
57 my (@results, $canontext);
58 my ($output, $output_wrong);
60 if ($format =~ /json/) {
61 $r->content_type($ctype or $format);
62 $output= sub { print to_json({
64 show => length $canontext ? encode_entities($canontext)
67 $output_wrong= sub { print to_json({
72 if ($format =~ /return/) {
73 $output= sub { return { Error => '', Results => \@results }; };
74 $output_wrong= sub { return { Error => $_[0] }; };
76 if ($format =~ /dump/) {
77 $r->content_type('text/plain');
78 $output_wrong= sub { print Dumper(\@_); };
79 $output= sub { print Dumper(\@results, $canontext); };
82 foreach my $each (split m#[/|,]#, $string) {
83 $each =~ s/^\s*//; $each =~ s/\s*$//; $each =~ s/\s+/ /g;
84 next if !length $each;
86 my $msg= sprintf $_[0], encode_entities($each);
87 $output_wrong->($msg);
91 foreach my $pat ("$each\%", "\%$each\%") {
92 $sth->execute($pat,$pat);
93 $results= $sth->fetchall_arrayref();
95 map { $m{ $_->[2] }=1 } @$results;
100 return $err->('no island or arch matches "%s"');
102 return $err->(' ');
104 return $err->('ambiguous island or arch "%s",'.
105 ' could be '.join(', ', sort keys %m));
108 push @results, $results->[0];
111 $canontext= join ' | ', map { $_->[2] } @results;