localnames-server.pl

   1 #! /usr/bin/perl
   2 # Copyright (C) 2005  Alex Schroeder <alex@emacswiki.org>
   3 #
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program; if not, write to the
  16 #    Free Software Foundation, Inc.
  17 #    59 Temple Place, Suite 330
  18 #    Boston, MA 02111-1307 USA
  19
  20 use CGI;
  21 use CGI::Carp qw(fatalsToBrowser);
  22 use LWP::UserAgent;
  23
  24 my $db = 'localnames.db';
  25 my $pwd = '5ga55b6b4aq00x192w23efrvhtg';
  26 my $q = new CGI;
  27 my $url = $q->param('url');
  28 my $name = $q->param('name');
  29
  30 if ($q->param('list')) {
  31   list();
  32 } elsif ($url and $q->param('pwd') eq $pwd) {
  33   redefine();
  34 } elsif ($name) {
  35   resolve();
  36 } else {
  37   html();
  38 }
  39
  40 sub html {
  41   print $q->header(),
  42     $q->start_html('LocalNames Server'),
  43     $q->h1('LocalNames Server'),
  44     $q->p('Reads a definition of', $q->a({-href=>'http://ln.taoriver.net/about.html'}, 'local names'),
  45           'from an URL and saves it.  At the same time it also offers to redirect you to the matching URL,',
  46           'if you query it for a name.'),
  47     $q->p(q{$Id: localnames-server.pl,v 1.5 2005/01/09 23:38:09 as Exp $}),
  48     $q->p($q->a({-href=>$q->url . '?list=1'}, 'List of all names')),
  49     $q->start_form(-method=>'GET'),
  50     $q->p('Redefine from URL:', $q->textfield('url', '', 50)),
  51     $q->p('Password:', $q->textfield('pwd', '', 50)),
  52     $q->p('Query name: ', $q->textfield('name', '', 50)),
  53     $q->p($q->submit()),
  54     $q->end_form(),
  55     $q->end_html();
  56   exit;
  57 }
  58 use warnings ;
  59 use strict ;
  60 use DB_File ;
  61
  62 my %LocalNamesSeen = ();
  63 my %LocalNames = ();
  64
  65 sub redefine {
  66   print $q->header(-type=>'text/plain; charset=UTF-8');
  67   unlink $db;
  68   tie %LocalNames, "DB_File", $db, O_RDWR|O_CREAT, 0666, $DB_HASH
  69     or die "Cannot open file '$db': $!\n";
  70   LocalNamesParseDefinition($url);
  71   print "Done.\n";
  72 }
  73
  74 sub LocalNamesParseDefinition {
  75   my $url = shift;
  76   if (not $LocalNamesSeen{$url}) {
  77     $LocalNamesSeen{$url} = 1;
  78     print "Reading $url\n";
  79     my $ua = new LWP::UserAgent;
  80     my $response = $ua->get($url);
  81     die $response->status_line unless $response->is_success;
  82     my $data = $response->content;
  83     my($type, $name, $target);
  84     foreach my $line (split(/\n/, $data)) {
  85       next unless $line;                   # skip empty lines
  86       next if substr($line, 0, 1) eq '#';  # skip comment
  87       # split on whitespace, unquote if possible
  88       $line =~ /^(.|LN|NS|X|PATTERN)\s+(?:"(.*?)"|(\S+))\s+(?:"(.*?)"|(\S+))$/ or next;
  89       my ($ntype, $nname, $ntarget) = ($1, $2 || $3, $4 || $5);
  90       # Wherever a period is found, the value of the record's column
  91       # is the same as the value found in the same column in the
  92       # previous record.
  93       $type = $ntype unless $ntype eq '.';
  94       $name = $nname unless $nname eq '.';
  95       $target = $ntarget unless $ntarget eq '.';
  96       if ($type eq 'LN') {
  97         my $page = FreeToNormal($name);
  98         $LocalNames{$page} = $target unless $LocalNames{$page}; # use the first
  99       } elsif ($type eq 'NS') {
 100         LocalNamesParseDefinition($target, $name);
 101       }
 102       # else do nothing -- X FINAL is not supported, because
 103       # undefined pages link to edit pages on the local wiki!
 104     }
 105   }
 106   # else do nothing -- been there before
 107 }
 108
 109 sub FreeToNormal { # trim all spaces and convert them to underlines
 110   my $id = shift;
 111   return '' unless $id;
 112   $id =~ s/ /_/g;
 113   if (index($id, '_') > -1) {  # Quick check for any space/underscores
 114     $id =~ s/__+/_/g;
 115     $id =~ s/^_//;
 116     $id =~ s/_$//;
 117   }
 118   return $id;
 119 }
 120
 121 sub resolve {
 122   tie %LocalNames, "DB_File", $db, O_RDWR|O_CREAT, 0666, $DB_HASH
 123     or die "Cannot open file '$db': $!\n";
 124   $name = FreeToNormal($name);
 125   my $target = $LocalNames{$name};
 126   if ($target) {
 127     print $q->redirect($target);
 128   } else {
 129     print $q->header(-status=>404),
 130       $q->start_html('Not Found'),
 131       $q->h2('Not Found'),
 132       $q->p("The name '$name' was not found on this server."),
 133       $q->end_html();
 134   }
 135 }
 136
 137 sub list {
 138   print $q->header(-type=>'text/plain; charset=UTF-8');
 139   tie %LocalNames, "DB_File", $db, O_RDWR|O_CREAT, 0666, $DB_HASH
 140     or die "Cannot open file '$db': $!\n";
 141   foreach (keys %LocalNames) {
 142     print $_, "\n";
 143   }
 144 }