Generalise route[text]string

[ypp-sc-tools.web-live.git] / yarrg / web / routetextstring

diff --git a/yarrg/web/routetextstring b/yarrg/web/routetextstring
deleted file mode 100755 (executable)
index be009d4..0000000
--- a/yarrg/web/routetextstring
+++ /dev/null
@@ -1,124 +0,0 @@
-<%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 parses textual strings giving lists of islands
- and archipelagoes, ie textual route strings.
-
-
-</%doc>
-
-<%flags>
-inherit => undef
-</%flags>
-
-<%args>
-$ocean
-$format
-$ctype => undef
-$string
-</%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;
-use HTML::Entities;
-use JSON;
-use Data::Dumper;
-
-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 (@results, $canontext);
-my ($output, $output_wrong);
-
-if ($format =~ /json/) {
-       $r->content_type($ctype or $format);
-       $output= sub { print to_json_shim({
-               success => 1,
-               show => length $canontext ? encode_entities($canontext)
-                       : '&nbsp;',
-               })};
-       $output_wrong= sub { print to_json_shim({
-               success => 0,
-               show => $_[0],
-               })};
-}
-if ($format =~ /return/) {
-       $output= sub { return { Error => '', Results => \@results }; };
-       $output_wrong= sub { return { Error => $_[0] }; };
-}
-if ($format =~ /dump/) {
-       $r->content_type('text/plain');
-       $output_wrong= sub { print Dumper(\@_); };
-       $output= sub { print Dumper(\@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 {
-               my $msg= sprintf $_[0], encode_entities($each);
-               $output_wrong->($msg);
-       };
-       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) {
-                       return $err->('no island or arch matches "%s"');
-               } elsif (keys(%m) > 5) {
-                       return $err->('&nbsp;');
-               } else {
-                       return $err->('ambiguous island or arch "%s",'.
-                               ' could be '.join(', ', sort keys %m));
-               }
-       }
-       push @results, $results->[0];
-}
-
-$canontext= join ' | ', map { $_->[2] } @results;
-return $output->();
-
-</%perl>