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