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 db_setocean($ocean);
  19 db_connect();
  20
  21 my $sth= $dbh->prepare("SELECT archipelago,islandid,islandname
  22                                 FROM islands WHERE islandname LIKE ?
  23         UNION ALL       SELECT DISTINCT archipelago,NULL,archipelago
  24                                 FROM islands WHERE archipelago LIKE ?");
  25
  26 my (@results, $canontext);
  27 my ($output, $output_wrong);
  28
  29 if ($format =~ /json/) {
  30         $r->content_type($ctype or $format);
  31         $output= sub { print to_json({
  32                 success => 1,
  33                 show => length $canontext ? encode_entities($canontext)
  34                         : '&nbsp;',
  35                 })};
  36         $output_wrong= sub { print to_json({
  37                 success => 0,
  38                 show => $_[0],
  39                 })};
  40 }
  41 if ($format =~ /return/) {
  42         $output= sub { return { Error => '', Results => \@results }; };
  43         $output_wrong= sub { return { Error => $_[0] }; };
  44 }
  45 if ($format =~ /dump/) {
  46         $r->content_type('text/plain');
  47         $output_wrong= sub { print Dumper(\@_); };
  48         $output= sub { print Dumper(\@results, $canontext); };
  49 }
  50
  51 foreach my $each (split m#[/|,]#, $string) {
  52         $each =~ s/^\s*//;  $each =~ s/\s*$//;  $each =~ s/\s+/ /g;
  53         next if !length $each;
  54         my $err= sub {
  55                 my $msg= sprintf $_[0], encode_entities($each);
  56                 $output_wrong->($msg);
  57         };
  58         my %m;
  59         my $results;
  60         foreach my $pat ("$each\%", "\%$each\%") {
  61                 $sth->execute($pat,$pat);
  62                 $results= $sth->fetchall_arrayref();
  63                 last if @$results==1;
  64                 map { $m{ $_->[2] }=1 } @$results;
  65                 $results= undef;
  66         }
  67         if (!$results) {
  68                 if (!%m) {
  69                         return $err->('no island or arch matches "%s"');
  70                 } elsif (%m > 5) {
  71                         return $err->('&nbsp;');
  72                 } else {
  73                         return $err->('ambiguous island or arch "%s",'.
  74                                 ' could be '.join(', ', sort keys %m));
  75                 }
  76         }
  77         push @results, $results->[0];
  78 }
  79
  80 $canontext= join ' | ', map { $_->[2] } @results;
  81
  82 return $output->();
  83
  84 </%perl>