%# 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.
%#
<%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({
		success => 1,
		show => length $canontext ? encode_entities($canontext)
			: '&nbsp;',
		})};
	$output_wrong= sub { print to_json({
		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 (%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>