yarrg/web/routetextstring

   1 %# This is part of the YARRG website.  YARRG is a tool and website
   2 %# for assisting players of Yohoho Puzzle Pirates.
   3 %#
   4 %# Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
   5 %# Copyright (C) 2009 Clare Boothby
   6 %#
   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.
  11 %#
  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.
  16 %#
  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.
  21 %#
  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/>.
  24 %#
  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.
  28 %#
  29 %#
  30 %# This Mason component parses textual strings giving lists of islands
  31 %# and archipelagoes, ie textual route strings.
  32 %#
  33 <%args>
  34 $ocean
  35 $format
  36 $ctype => undef
  37 $string
  38 </%args>
  39 <%perl>
  40
  41 # typical url for this script:
  42 #  http://www.chiark.greenend.org.uk/ucgi/~clareb/mason/pirates/routetextstring?format=json&ocean=Midnight&string=d
  43
  44
  45 use CommodsWeb;
  46 use HTML::Entities;
  47 use JSON;
  48 use Data::Dumper;
  49
  50 my $dbh= dbw_connect($ocean);
  51
  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 ?");
  56
  57 my (@results, $canontext);
  58 my ($output, $output_wrong);
  59
  60 if ($format =~ /json/) {
  61         $r->content_type($ctype or $format);
  62         $output= sub { print to_json({
  63                 success => 1,
  64                 show => length $canontext ? encode_entities($canontext)
  65                         : '&nbsp;',
  66                 })};
  67         $output_wrong= sub { print to_json({
  68                 success => 0,
  69                 show => $_[0],
  70                 })};
  71 }
  72 if ($format =~ /return/) {
  73         $output= sub { return { Error => '', Results => \@results }; };
  74         $output_wrong= sub { return { Error => $_[0] }; };
  75 }
  76 if ($format =~ /dump/) {
  77         $r->content_type('text/plain');
  78         $output_wrong= sub { print Dumper(\@_); };
  79         $output= sub { print Dumper(\@results, $canontext); };
  80 }
  81
  82 foreach my $each (split m#[/|,]#, $string) {
  83         $each =~ s/^\s*//;  $each =~ s/\s*$//;  $each =~ s/\s+/ /g;
  84         next if !length $each;
  85         my $err= sub {
  86                 my $msg= sprintf $_[0], encode_entities($each);
  87                 $output_wrong->($msg);
  88         };
  89         my %m;
  90         my $results;
  91         foreach my $pat ("$each\%", "\%$each\%") {
  92                 $sth->execute($pat,$pat);
  93                 $results= $sth->fetchall_arrayref();
  94                 last if @$results==1;
  95                 map { $m{ $_->[2] }=1 } @$results;
  96                 $results= undef;
  97         }
  98         if (!$results) {
  99                 if (!%m) {
 100                         return $err->('no island or arch matches "%s"');
 101                 } elsif (%m > 5) {
 102                         return $err->('&nbsp;');
 103                 } else {
 104                         return $err->('ambiguous island or arch "%s",'.
 105                                 ' could be '.join(', ', sort keys %m));
 106                 }
 107         }
 108         push @results, $results->[0];
 109 }
 110
 111 $canontext= join ' | ', map { $_->[2] } @results;
 112 return $output->();
 113
 114 </%perl>