yarrg/web/routetextstring

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