yarrg/web/routetextstring

   1 <%args>
   2 $ocean
   3 $format
   4 $ctype => undef
   5 $string
   6 </%args>
   7 <%perl>
   8
   9 use CommodsWeb;
  10 use HTML::Entities;
  11 use JSON;
  12
  13 db_setocean($ocean);
  14 db_connect();
  15
  16 my $sth= $dbh->prepare("SELECT archipelago,islandid,islandname
  17                                 FROM islands WHERE islandname LIKE ?
  18         UNION ALL       SELECT DISTINCT archipelago,NULL,archipelago
  19                                 FROM islands WHERE archipelago LIKE ?");
  20
  21 my (@results, $canontext);
  22 my ($output, $output_wrong);
  23
  24 if ($format =~ 'json') {
  25         $r->content_type($ctype or $format);
  26         $output= sub { print to_json({
  27                 success => 1,
  28                 show => encode_entities($canontext),
  29         })};
  30         $output_wrong= sub { print to_json({
  31                 success => 0,
  32                 show => encode_entities($_[0]),
  33         })};
  34 }
  35
  36 foreach my $each (split m#[/|,]#, $string) {
  37         $each =~ s/^\s*//;  $each =~ s/\s*$//;  $each =~ s/\s+/ /g;
  38         next if !length $each;
  39         my $pat= "\%$each\%";
  40         my $nrows= $sth->execute($pat,$pat);
  41         my $err= sub {
  42                 my $msg= sprintf $_[0], encode_entities($each);
  43                 $output_wrong->($msg);
  44                 $m->abort();
  45         };
  46         my $results= $sth->fetchall_arrayref();
  47         if (!@$results) {
  48                 $err->('no island or arch matches "%s"');
  49         } elsif (@$results > 3) {
  50                 $err->('');
  51         } elsif (@$results > 1) {
  52                 my @m= map { $_->[2] } @$results;
  53                 $err->('ambiguous island or arch "%s", could be '.
  54                         join(', ', @m));
  55         }
  56         push @results, $results->[0];
  57 }
  58
  59 $canontext= join ' | ', map { encode_entities($_->[2]) } @results;
  60
  61 $output->();
  62
  63 </%perl>