Further generalisation of text string entry; add missing copyrights

[ypp-sc-tools.main.git] / yarrg / web / check_routestring

diff --git a/yarrg/web/check_routestring b/yarrg/web/check_routestring
index be009d4e5a4b8fa624a5f809a079a432d0b1da2f..2cbe719cf4eec1afa16860f947da2b5044ee1490 100755 (executable)
--- a/yarrg/web/check_routestring
+++ b/yarrg/web/check_routestring
@@ -32,11 +32,10 @@
  This Mason component parses textual strings giving lists of islands
  and archipelagoes, ie textual route strings.
 
  This Mason component parses textual strings giving lists of islands
  and archipelagoes, ie textual route strings.
 

-

 </%doc>
 
 <%flags>
 </%doc>
 
 <%flags>

-inherit => undef
+inherit => 'qtextstringcheck'

 </%flags>
 
 <%args>
 </%flags>
 
 <%args>


@@ -44,6 +43,7 @@ $ocean
 $format
 $ctype => undef
 $string
 $format
 $ctype => undef
 $string

+$returnhash => { }

 </%args>
 
 <%perl>
 </%args>
 
 <%perl>


@@ -51,11 +51,7 @@ $string
 # typical url for this script:
 #  http://www.chiark.greenend.org.uk/ucgi/~clareb/mason/pirates/routetextstring?format=json&ocean=Midnight&string=d
 
 # 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 CommodsWeb;

-use HTML::Entities;
-use JSON;
-use Data::Dumper;

 
 my $dbh= dbw_connect($ocean);
 
 
 my $dbh= dbw_connect($ocean);
 


@@ -64,38 +60,13 @@ my $sth= $dbh->prepare("SELECT archipelago,islandid,islandname
        UNION ALL       SELECT DISTINCT archipelago,NULL,archipelago
                                FROM islands WHERE archipelago LIKE ?");
 
        UNION ALL       SELECT DISTINCT archipelago,NULL,archipelago
                                FROM islands WHERE archipelago LIKE ?");
 

+my $emsg= '';

 my (@results, $canontext);
 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;
 
 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 $err= sub { $emsg= sprintf $_[0], $each; last; };

        my %m;
        my $results;
        foreach my $pat ("$each\%", "\%$each\%") {
        my %m;
        my $results;
        foreach my $pat ("$each\%", "\%$each\%") {


@@ -107,18 +78,21 @@ foreach my $each (split m#[/|,]#, $string) {
        }
        if (!$results) {
                if (!%m) {
        }
        if (!$results) {
                if (!%m) {

-                       return $err->('no island or arch matches "%s"');
+                       $err->('no island or arch matches "%s"');

                } elsif (keys(%m) > 5) {
                } elsif (keys(%m) > 5) {

-                       return $err->('&nbsp;');
+                       $err->('&nbsp;');

                } else {
                } else {

-                       return $err->('ambiguous island or arch "%s",'.
+                       $err->('ambiguous island or arch "%s",'.

                                ' could be '.join(', ', sort keys %m));
                }
        }
        push @results, $results->[0];
                                ' could be '.join(', ', sort keys %m));
                }
        }
        push @results, $results->[0];

-}
+};
+
+$dbh->disconnect();

 
 

-$canontext= join ' | ', map { $_->[2] } @results;
-return $output->();
+return  $emsg,
+       (join ' | ', map { $_->[2] } @results),
+       [ @results ];

 
 </%perl>
 
 </%perl>