#!/usr/bin/perl
# vim: et ts=3 sts=3 sw=3
package Lexicon;

use strict;
use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use utf8;
use Encode;

binmode STDOUT, ":utf8";

require Exporter;

@ISA = qw(Exporter AutoLoader);
$VERSION = '0.01';

# items to export into caller's namespace by default
@EXPORT = qw(parse_lexicon update_entry unshoebox);


# SUBROUTINES ####################################

# http://lwp.interglacial.com/ch05_02.htm
sub smart_decode {
    my $value = shift;
    my $x = my $y = $value;
    return $x if utf8::decode($x);
    return $y;
}

# Params: $lexicon_filename, \%lexicon
sub parse_lexicon($$) {
   my $lex_file = shift;
   my $lex_ref = shift;
   my $word;
   my $continue;
   my %cls = (
      'fv:' => 'ashaille',
      'fe:' => 'english',
   );

   open LEX, $lex_file or die "Can't open lexicon file $lex_file: $!\n";
   binmode LEX, ":utf8";

   while (<LEX>) {
      # creates a new entry for every \lx line in the source file
      if (/^\\lx\s+(.+)$/) { # include [\cM\cL] at end of reg if in DOS format
         $word = smart_decode($1);
         update_entry($lex_ref, $word);
      }
      # adds information to the entry of the last \lx word processed
      elsif (defined $word) {
         if (/^\\dc\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'date', unshoebox($1, \%cls));
         }
         elsif (/^\\ge\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'gloss', unshoebox($1, \%cls));
         }
         elsif (/^\\de\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'def', unshoebox($1, \%cls));
         }
         elsif (/^\\ee\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'encyc', unshoebox($1, \%cls));
            $continue = 'encyc';
         }
         elsif (/^\\et\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'etym', unshoebox($1, \%cls));
         }
         elsif (/^\\eg\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'etym_gloss', unshoebox($1, \%cls));
         }
         elsif (/^\\ps\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'pos', unshoebox($1, \%cls));
         }
         elsif (/^\\ph\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'cxs', $1);
            # if this field is unshoebox'd, underscores becomes spaces. Bad.
         }
         elsif (/^\\cf\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'ref', unshoebox($1, \%cls));
         }
         elsif (/^\\sy\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'syn', unshoebox($1, \%cls));
         }
         elsif (/^\\an\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'ant', unshoebox($1, \%cls));
         }
         elsif (/^\\ue\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'usage', unshoebox($1, \%cls));
            $continue = 'usage';
         }
         elsif (/^\\nx\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'disc', unshoebox($1, \%cls));
            $continue = 'disc';
         }
         elsif (/^\\xe\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'examples_trans', unshoebox($1, \%cls));
            $continue = 'examples_trans';
         }
         elsif (/^\\xv\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'examples', unshoebox($1, \%cls));
            $continue = 'examples';
         }
         elsif (/^\\dt\s+(.*)$/) {
            undef $continue;
            update_entry($lex_ref, $word, 'date_added', unshoebox($1, \%cls));
         }
         elsif (defined $continue) {
            chomp;
            $$lex_ref{$word}{$continue} .= unshoebox(" $_", \%cls);
         }
      }
   }

   close LEX;
}

# Params: $lexicon_ref, $word, $key, $val
sub update_entry($$$$) {
   my $lex_ref = shift;
   my $word = shift;
   my $key = shift;
   my $val = shift;

   # create entry for word in lexicon, if it doesn't already exist
   if (!$$lex_ref{$word}) {
      $$lex_ref{$word} = {};
   }

   # if no $key is defined, then return early. This subroutine was called only
   # to create the $$lex_ref{$word} entry.
   if (!$key) {
      return;
   }

   # if it's already defined, ADD the new value
   if ($$lex_ref{$word}{$key}) {
      my $prev = $$lex_ref{$word}{$key};
      $$lex_ref{$word}{$key} = [];
      if (ref $prev eq 'ARRAY') {
         push @{$$lex_ref{$word}{$key}}, $_ foreach @$prev;
      }
      else {
         push @{$$lex_ref{$word}{$key}}, ($prev);
      }
      push @{$$lex_ref{$word}{$key}}, $val;
   }
   # otherwise, define it AS the new value
   else {
      $$lex_ref{$word}{$key} = $val;
   }
}

# Params: $string_to_unshoebox
sub unshoebox($$) {
   my @chars = split //, shift;
   my %classes = %{(shift)};
   my $return = '';   # complete text string, including any HTML
   my $flag = '';     # text prefixed with a colon (fv:, fe:, etc)
   my $word = '';     # text to be surround by a <span> if flagged
   my $char = '';     # current character being processed
   my $verbatim = 0;  # whether to pass $char through as is

   foreach my $raw_char (@chars) {
      $char = $raw_char;

      # look for escaped characters
      if ($verbatim) {
         $word .= $raw_char;
         $verbatim = 0;
         next;
      }
      elsif ($raw_char eq '\\') {
         $verbatim = 1;
         next;
      }
      else {
         $verbatim = 0;
      }

      # convert underscores to spaces before appending char
      if ($raw_char eq '_') {
         $char = ' ';
      }

      # change fe: and fv:
      if ($flag eq 'f') {
         if ($raw_char =~ /[ve]/) {
            $flag = "$flag$raw_char";
         }
         else {
            $return .= $flag . $char;
            $flag = '';
         }
      }
      elsif ($flag eq 'fv' or $flag eq 'fe') {
         if ($raw_char eq ':') {
            $flag = "$flag$raw_char";
         }
         else {
            $return .= "$flag$char";
            $flag = '';
         }
      }
      elsif ($flag eq 'fv:' or $flag eq 'fe:') {
         if ($raw_char =~ /[ .,;"?\/|]/) {
            $raw_char = '' if $raw_char eq '|';
            $return .= make_span($word, $classes{$flag}, $raw_char);
            $word = '';
            $flag = '';
         }
         else {
            $word .= $char;
         }
      }
      elsif ($raw_char eq 'f') {
         $flag = $raw_char;
      }
      else {
         $return .= $char;
      }
   }

   # in case the last word was successfully flagged
   if ($flag eq 'fv:' or $flag eq 'fe:') {
      $return .= make_span($word, $classes{$flag});
   }
   elsif ($flag) {
      $return .= $flag;
   }

   return $return;
}

sub make_span {
   my $word = shift;
   my $class = shift;
   my $char = shift;
   my $dictionary_page = 'http://dictionary.arthaey.com/';
   $char = '' unless $char;

   return $class ? "<lang class=\"$class\">$word</lang>$char" : $word;
}

1;

__END__
