#!/usr/bin/perl -w -T

# Matthieu Weber <mweber()mit.jyu.fi> 2008, 2010
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
#
# ChangeLog
#
# 2010-06-28 Automatically loads the list of available dictionaries.
# Populates the list of default dictionaries based on regexps found in the
# @default_dict array.
#
# 20??-??-?? Uses the new Netmot interface, add support for prefix/glob search
#
# 2008-11-04 First release

package dictd;

@default_dict = ("Finnish-English", "Finnish-French", "Collins French Dictionary");

@dict_desc = ( "",);
@default = ();

use Net::Server;
@ISA = qw(Net::Server);
use LWP::UserAgent;
use HTML::Entities;
use Text::Format;
#use Text::Iconv;

$ua = LWP::UserAgent->new();
#$netmot = "http://mot.kielikone.fi/mot/jyu/netmot.exe?UI=enle&Opt=8&dic=%d&SearchWord=%s&Search=+Find+";
$netmot = "http://mot.kielikone.fi/mot/jyu/netmot.exe?page=results&UI=fi80&Opt=8&dic=%d&SearchWord=%s&Search.x=12&Search.y=11&SearchMode=1";
$prefix = "http://mot.kielikone.fi/mot/jyu/netmot.exe";
$prefix_param = "xhr=1&page=list&UI=80&Opt=8&SearchMode=1&SearchWord=%s&dic=%d";
$format_title = Text::Format->new(firstIndent => 0, leftMargin => 0);
$format_def = Text::Format->new(firstIndent => 0, leftMargin => 4, bodyIndent=>2);
#$converter = Text::Iconv->new("utf-8", "latin1");

&get_dictionary_list();
#dictd->run(log_level => 2, host => "localhost", port => 2628);
dictd->run(setsid => 0, log_level => 0, host => "localhost", port => 2628);
exit;

sub process_request {
  my $self = shift;
  eval {
    local $SIG{ALRM} = sub { die "Timed Out!\n" };
    my $timeout = 30; # give the user 30 seconds to type a line

    my $previous_alarm = alarm($timeout);
    &reply("220 hello <> msg");
    while( <STDIN> ){
      s/\r?\n$//;
      #last unless
      &dict_protocol_line($_);
      alarm($timeout);
    }
    alarm($previous_alarm);

  };

  if( $@=~/timed out/i ){
    print STDOUT "Timed Out.\r\n";
    return;
  }
}

sub reply {
  my $s = shift @_;
  #print STDERR "> $s\n";
  print "$s\r\n";
}

sub dict_protocol_line {
  shift @_;
  #print STDERR "< $_\n";
  my ($dict, $word);
  if (/^client "(.*)"$/i) {
    &reply("250 Command complete");
  }
  elsif (($dict, $word) = (/^define (.+) "(.*)"$/i)) {
    my @replies = ();
    if ($dict eq "*") {
      for my $d (@default) {
        #print STDERR "query $d\n";
        push @replies, &query_netmot($d, $word);
      }
    }
    elsif ($mot_dicts{$1}) {
      push @replies, &query_netmot($dict, $word);
    }
    else {
      &reply("550 Not found");
      return 0;
    }
    my $nb = @replies;
    &reply("150 $nb");
    for my $rep (@replies) {
      &reply("151 \"$word\" netmot \"$rep->[0]\"");
      &reply($rep->[1]);
      &reply(".");
    }
    &reply("250 Command complete");
  }
  elsif (($dict, $strat, $word) = (/^match (.+) (.+) "(.*)"$/i)) {
    my @replies = ();
    if ($strat ne "prefix" and $strat ne "glob") {
      &reply('551 Invalid strategy, use "SHOW STRAT" for a list of strategies');
      return 0;
    }
    elsif ($dict eq "*") {
      for my $d (@default) {
        push @replies, &query_prefix($d, $word);
      }
    }
    elsif (exists $mot_dicts{$1}) {
      push @replies, &query_prefix($dict, $word);
    }
    else {
      &reply("550 Not found");
      return 0;
    }
    my $nb = @replies;
    &reply("152 $nb matches found");
    for my $rep (@replies) {
      &reply($rep->[0].' "'.$rep->[1].'"');
    }
    &reply(".");
    &reply("250 Command complete");
  }
  elsif (my ($kw) = (/^show (.*)/i)) {
    $kw = uc($kw);
    if ($kw eq "DB" || $kw eq "DATABASE") {
      my $nb = scalar(@dict_desc);
      if ($nb == 0) {
        &reply("554 No databases present");
        return 0;
      }
      else {
        &reply("110 $nb databases present - text follows");
        for $db (sort {$dict_desc[$mot_dicts{$a}] cmp $dict_desc[$mot_dicts{$b}]} keys %mot_dicts) {
          &reply("$db \"$dict_desc[$mot_dicts{$db}]\"");
        }
        #for (my $i = 1; $i<$nb; $i++) {
        #  &reply("$mot_dicts \"$dict_desc[$i]\"");
        #}
        &reply(".");
        &reply("250 Command complete");
      }
    }
    elsif ($kw eq "STRAT" || $kw eq "STRATEGIES") {
      #&reply("555 No strategies available");
      &reply("111 3 strategies available");
      &reply("exact \"Match headwords exactly\"");
      &reply("prefix \"Match a prefix\"");
      &reply("glob \"Match a pattern\"");
      &reply(".");
      &reply("250 Command complete");

    }
    elsif ($kw =~ /^INFO/) {
      &reply("112 database information follows");
      &reply("Copyright (c) 2007 Kielikone Ltd. Kielikone");
      &reply(".");
      &reply("250 Command complete");
    }
    elsif ($kw eq "SERVER") {
      &reply("114 server information follows");
      &reply("NetMOT-DICT proxy");
      &reply(".");
      &reply("250 Command complete");
    }
  }
  elsif (/^status/i) {
    &reply("210 -");
  }
  elsif (/^help/i) {
    &reply("113 help");
    &reply("Commands: define, match, db, database, strat, strategies, info, server, status, help, quit");
    &reply(".");
    &reply("250 Command complete");
  }
  elsif (/^quit/i) {
    &reply("221 bye bye");
    return 0;
  }
  return 1;
}

sub clean_reply {
  shift @_;
  s/\&nbsp;/ /g;
  s/<\/?(?:tr|td|span|div|font|sup|b|table|a)[^>]*>//g;
  #s/<\/?b>/*/g;
  s/<\/?i>/\//g;
  s/&lt;/</g;
  s/&gt;/>/g;
  s/^\s+//g;
  s/\&#(\d+);/$1 < 300 ? chr($1) : "?"/eg;
  s/ (\d+\.?) / \n$1 /g;
  s/\/(\d+\.?)\// \n$1/g;
  my @lines = split /\n/,$_;
  my $s = $format_title->format(shift @lines);
  for my $l (@lines) {
    $s .= $format_def->format($l);
  }
  $s = "" if $s =~ /^\s*$/;
  return $s;
}

sub get_dictionary_list {
  my $response = $ua->request(HTTP::Request->new(GET => $prefix."?UI=en"));
  #print STDERR $response->content;
  my @lines = split /\r?\n/, $response->content;
  my $flag = 0;
  for (@lines) {
    if (/<select name="dic"/) {
      $flag = 1;
    }
    elsif ($flag && /<option value="(\d+)"[^>]*>([^<]+)<\/option>/) {
      my $idx = $1;
      my $name = $2;
      $dict_desc[$idx] = $name; 
      #print STDERR &make_shortname($name)."\n";
      my $shortname = &make_shortname($name);
      $mot_dicts{$shortname} = $idx;
      foreach my $re (@default_dict) {
        if ($name =~ /MOT $re \d+\.\d+/) {
          push @default, $shortname;
          last;
        }
      }
    }
    elsif ($flag && /<\/select>/) {
      $flag = 0;
    }
  }
  #print join("\n", @dict_desc)."\n";
  #print join("\n", @default)."\n";
}

sub make_shortname {
  my $s = shift @_;
  $s =~ s/^MOT //;
  $s =~ s/WSOY //;
  $s =~ s/Gummerus //;
  $s =~ s/Norstedts //;
  $s =~ s/FinnLectura //;
  $s =~ s/Finnish/fi/g;
  $s =~ s/French/fr/g;
  $s =~ s/English/en/g;
  $s =~ s/Swedish/sv/g;
  $s =~ s/German/de/g;
  $s =~ s/Russian/ru/g;
  $s =~ s/Estonian/et/g;
  $s =~ s/Italian/it/g;
  $s =~ s/Spanish/es/g;
  $s =~ s/Dutch/nl/g;
  $s =~ s/Danish/da/g;
  $s =~ s/Contemporary/cont./g;
  $s =~ s/(?:Comprehensive )?Dictionary(?: of )?//g;
  $s =~ s/\d+\.\d+(?:\w)?//g;
  $s = substr $s, 0, 12;
  $s =~ s/ +$//;
  $s =~ s/ +/_/g;
  return lc($s);
}

sub query_netmot {
  my ($dict, $word) = @_;
  my $response = $ua->request(HTTP::Request->new(GET => sprintf $netmot, $mot_dicts{$dict}, $word));
  #print STDERR $response->content;
  #print STDERR sprintf $netmot, $mot_dicts{$dict}, $word; print "\n";
  my @lines = split /\r?\n/, $response->content;
  my $src = "";
  my $acc = "";
  my @resp = ();
  for (@lines) {
    if (/<hr size="1"/ && $src && $acc) {
      push @resp, [$src, $acc];
      $acc = "";
    }
    if (/<div class="dichead"><b>([^<]+)<\/b>/) {
      $src = $1;
    }
    elsif (/<div style=/) {
      my $data = &clean_reply($_);
      $acc .= "$data\n" if $data;
      #push @resp, [$src, $data] if $data;
    }
  }
  if ($src && $acc) {
    push @resp, [$src, $acc];
    $acc = "";
  }
  return @resp;
}

sub query_prefix {
  my ($dict, $word) = @_;
  my $req = HTTP::Request->new("POST" => $prefix);
  $req->content_type('application/x-www-form-urlencoded');
  #print STDERR sprintf $prefix_param, $word, $mot_dicts{$dict};
  $req->content(sprintf $prefix_param, $word, $mot_dicts{$dict});
  my $response = $ua->request($req) || die "request failed";
  #print STDERR $response->content;
  my @lines = split /\r?\n/, $response->content;
  my @resp = ();
  for (@lines) {
    next if /^$/;
    if (/<div class="qlink"[^>]*>(.*)<\/div>/) {
      my $w = decode_entities($1);
      push @resp, [$dict, $w];
    }
  }
  return @resp;
}
1;

