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 if ($format =~ 'return') {
  41         $output= sub { return { Error => '', Results => \@results }; };
  42         $output_wrong= sub { return { Error => $_[0] }; };
  43 }
  44
  45 foreach my $each (split m#[/|,]#, $string) {
  46         $each =~ s/^\s*//;  $each =~ s/\s*$//;  $each =~ s/\s+/ /g;
  47         next if !length $each;
  48         my $err= sub {
  49                 my $msg= sprintf $_[0], encode_entities($each);
  50                 $output_wrong->($msg);
  51         };
  52         my %m;
  53         my $results;
  54         foreach my $pat ("$each\%", "\%$each\%") {
  55                 $sth->execute($pat,$pat);
  56                 $results= $sth->fetchall_arrayref();
  57                 last if @$results==1;
  58                 map { $m{ $_->[2] }=1 } @$results;
  59                 $results= undef;
  60         }
  61         if (!$results) {
  62                 if (!%m) {
  63                         return $err->('no island or arch matches "%s"');
  64                 } elsif (%m > 5) {
  65                         return $err->('&nbsp;');
  66                 } else {
  67                         return $err->('ambiguous island or arch "%s",'.
  68                                 ' could be '.join(', ', sort keys %m));
  69                 }
  70         }
  71         push @results, $results->[0];
  72 }
  73
  74 $canontext= join ' | ', map { $_->[2] } @results;
  75
  76 return $output->();
  77
  78 </%perl>