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 $pat= "\%$each\%";
  45         my $nrows= $sth->execute($pat,$pat);
  46         my $err= sub {
  47                 my $msg= sprintf $_[0], encode_entities($each);
  48                 $output_wrong->($msg);
  49                 $m->abort();
  50         };
  51         my $results= $sth->fetchall_arrayref();
  52         if (!@$results) {
  53                 $err->('no island or arch matches "%s"');
  54         } elsif (@$results > 3) {
  55                 $err->('&nbsp;');
  56         } elsif (@$results > 1) {
  57                 my @m= map { $_->[2] } @$results;
  58                 $err->('ambiguous island or arch "%s", could be '.
  59                         join(', ', @m));
  60         }
  61         push @results, $results->[0];
  62 }
  63
  64 $canontext= join ' | ', map { $_->[2] } @results;
  65
  66 $output->();
  67
  68 </%perl>