.-.-.-.-.-

#!/usr/bin/perl

package Debian::DictionariesCommon;

use base qw(Exporter);
use Text::Iconv;

# List all exported symbols here.
our @EXPORT_OK = qw(parseinfo updatedb loaddb
		    dico_checkroot
		    dico_get_spellchecker_params
		    getlibdir
                    dico_getsysdefault dico_setsysdefault
		    getuserdefault setuserdefault
		    build_emacsen_support
		    build_jed_support
		    build_squirrelmail_support
		    );
# Import :all to get everything.
our %EXPORT_TAGS = (all => [@EXPORT_OK]);

my $infodir             = "/var/lib/dictionaries-common";
my $cachedir            = "/var/cache/dictionaries-common";
my $etcdir              = "/etc/dictionaries-common";
my $ispelldefault       = "ispell-default";
my $userdefault         = ( defined $ENV{HOME} ) ? "$ENV{HOME}/.$ispelldefault" : undef;
my $emacsensupport      = "emacsen-ispell-dicts.el";
my $jedsupport          = "jed-ispell-dicts.sl";
my $squirrelmailsupport = "sqspell.php";
my %sysetcdefault       = ("ispell"   => "$etcdir/ispell-default",
			   "wordlist" => "$etcdir/wordlist-default");

sub dico_checkroot {
  return if ($> == 0 or ($^O eq 'interix' and $> == 197108));
  die "$0: You must run this as root.\n";
}

sub getlibdir {
  my $class = shift;
  return "$infodir/$class";
}

sub mydie {
  my $routine = shift;
  my $errmsg = shift;
  die __PACKAGE__, "($routine):E: $errmsg";
}

sub parseinfo {
  my $file = shift;
  local $/ = "";    # IRS is global, we need 'local' here, not 'my'
  open (DICT, "< $file");
  my %dictionaries =
    map {
      s/^([^:]+):/lc ($1) . ":"/meg;  # Lower case field names
      my %hash = /^([^:]+):\s*((?<!\n)[^\n]+)\s*$/mg;
      map { delete $hash{$_} if ($hash{$_} =~ /^\s+$/) } keys %hash;
      mydie ('parseinfo',
	     qq{Record in file $file does not have a "Language" entry})
	if not exists $hash{language};
      mydie ('parseinfo',
	     qq{Record in file $file does not have a "Hash-Name" entry})
	if not exists $hash{"hash-name"};
      my $lang = delete $hash{language};
      ($lang, \%hash);
    } <DICT>;
  return \%dictionaries;
}

# ------------------------------------------------------------------
sub dico_dumpdb {
# ------------------------------------------------------------------
# Save %dictionaries in Data::Dumper like format. This function
# should be enough for the limited needs of dictionaries-common
# ------------------------------------------------------------------
  my $class        = shift;
  my $dictionaries = shift;
  my @fullarray    = ();
  my @dictarray    = ();
  my $output       = "$cachedir/$class.db";
  my $dictentries  = '';
  my $thevalue     = '';

foreach $thedict ( sort keys %{$dictionaries}){
    $dictentries = $dictionaries->{$thedict};
    @dictarray   = ();
    foreach $thekey ( sort keys %{$dictentries}){
      $thevalue = $dictentries->{$thekey};
      # Make sure \ and ' are escaped in keyvals
      $thevalue =~ s/(\\|\')/\\$1/g;
      push (@dictarray,"     \'$thekey\' => \'$thevalue\'");
    }
    # Make sure \ and ' are escaped in dict names
    $thedict =~ s/(\\|\')/\\$1/g;
    push (@fullarray,
	  "  \'$thedict\' => \{\n" . join(",\n",@dictarray) . "\n  \}");
  }

mkdir $cachedir unless (-d $cachedir);

open (DB,"> $output");
  print DB generate_comment("### ") . "\n";
  print DB "%dictionaries = (\n";
  print DB join (",\n",@fullarray);
  print DB "\n);\n\n1;\n";
  close DB;
}

# ------------------------------------------------------------------
sub dico_get_spellchecker_params {
# ------------------------------------------------------------------
# dico_get_spellchecker_params($class,\%language)
#  Get right params for $class (currently unused) and $language
# ------------------------------------------------------------------
  my $class       = shift;
  my $language    = shift;
  my $d_option    = "";
  my $w_option    = "";
  my $T_option    = "";
  my $ispell_args = "";

$d_option = "-d $language->{'hash-name'}"
      if exists $language->{'hash-name'};
  $w_option = "-w $language->{'additionalchars'}"
      if exists $language->{'additionalchars'};

if ( exists $language->{'extended-character-mode'} ){
    $T_option =  $language->{'extended-character-mode'};
    $T_option =~ s/^~//; # Strip leading ~ from Extended-Character-Mode.
    $T_option =  '-T ' . $T_option;
  }

if ( exists $language->{'ispell-args'} ){
    $ispell_args = $language->{'ispell-args'};
    foreach ( split('\s+',$ispell_args) ) {
      # No d_option if already in $ispell_args
      $d_option = "" if /^\-d/;
    }
  }
  return "$d_option $w_option $T_option $ispell_args";
}

# ------------------------------------------------------------------
sub updatedb {
# ------------------------------------------------------------------
# Parse info files for the given class and update class database
# ------------------------------------------------------------------
  my $class        = shift;
  my %dictionaries = ();

foreach my $file (<$infodir/$class/*>) {
    next if $file =~ m/.*~$/;                 # Ignore ~ backup files
    my $dicts = &parseinfo ("$file");
    %dictionaries = (%dictionaries, %$dicts);
  }
  &dico_dumpdb($class,\%dictionaries);
}

# ------------------------------------------------------------------
sub loaddb {
# ------------------------------------------------------------------
# Load class database
# ------------------------------------------------------------------
  my $class  = shift;
  my $dbfile = "$cachedir/$class.db";
  if (-e $dbfile) {
    do $dbfile;
  }
  return \%dictionaries;
}

# ------------------------------------------------------------------
sub getdefault {
# ------------------------------------------------------------------
# If available, read current user's default from given file.
# ------------------------------------------------------------------
  $file = shift;
  if (-f $file) {
    my $lang = `cat $file`;
    chomp $lang;
    return $lang;
  }
  else {
    return undef;
  }
}

# ------------------------------------------------------------------
sub getuserdefault {
# ------------------------------------------------------------------
# Get user default from user's default file
# ------------------------------------------------------------------
  die "Dictionaries-common::getuserdefault: Could not set \$userdefault. Aborting ...\n"
    unless $userdefault;
  getdefault ($userdefault);
}

# ------------------------------------------------------------------
sub dico_getsysdefault {
# ------------------------------------------------------------------
# Get system default value for given class
# ------------------------------------------------------------------
  my $class = shift;
  getdefault ($sysetcdefault{$class});
}

# ------------------------------------------------------------------
sub dico_setsysdefault {
# ------------------------------------------------------------------
# Set system default value for given class
# ------------------------------------------------------------------
  my $class = shift;
  my $value = shift;

open (DEFAULT, "> $sysetcdefault{$class}");
  print DEFAULT $value;
  close DEFAULT;
}

# ------------------------------------------------------------------
sub setuserdefault {
# ------------------------------------------------------------------
# Write user's default value to user's default file
# ------------------------------------------------------------------
  my $default      = getuserdefault ();
  my $dictionaries = loaddb ("ispell");
  my @choices      = sort keys %$dictionaries;

if (scalar @choices == 0) {
    warn "Sorry, no ispell dictionary is installed in your system.\n";
    return;
  }

my $initial = -1;
  if (defined $default) {
    for (my $i = 0; $i < scalar @choices; $i++) {
      if ($default eq $choices[$i]) {
	$initial = $i;
	last;
      }
    }
  }

open (TTY, "/dev/tty");
  while (1) {
    $| = 1;
    print
      "\nSelect your personal ispell dictionary for use with ispell-wrapper\n\n";
    for ($i = 0; $i < scalar @choices; $i++) {
      print "  " . ($i == $initial ? "*" : " ")
	     . " [" . ($i+1) . "] $choices[$i]\n";
    }
    print qq(\nSelect number or "q" for quit)
      . ($initial != -1 ? " (* is the current default): " : ": ");
    my $sel = <TTY>;
    chomp $sel;
    last if $sel eq "q";
    if ($sel < 1 or $sel > scalar @choices) {
      print qq{\nInvalid choice "$sel".\n\n};
      next;
    }
    else {
      $sel--;
      open (DEFAULT, "> $userdefault");
      print DEFAULT $choices[$sel];
      close DEFAULT;
      last;
    }
  }
  close TTY;
}

sub generate_comment {
  my $commstr = shift;
  my $comment = "This file is part of the dictionaries-common package.
It has been automatically generated.
DO NOT EDIT!";
  $comment =~ s{^}{$commstr}mg;
  return "$comment\n";
}

# ------------------------------------------------------------------
sub build_emacsen_support {
# ------------------------------------------------------------------
# Put info from dicts info files into emacsen-ispell-dicts.el
# ------------------------------------------------------------------
  my $elisp          = '';
  my @classes        = ("aspell","hunspell","ispell");
  my %entries        = ();
  my %class_locales  = ();

foreach $class ( @classes ){
    my $dictionaries = loaddb ($class);

foreach $k (keys %$dictionaries) {
      my $lang = $dictionaries->{$k};

next if (exists $lang->{'emacs-display'}
	       && $lang->{'emacs-display'} eq "no");

my $hashname = $lang->{"hash-name"};
      my $casechars = exists $lang->{casechars} ?
	  $lang->{casechars} : "[a-zA-Z]";
      my $notcasechars = exists $lang->{"not-casechars"} ?
	  $lang->{"not-casechars"} : "[^a-zA-Z]";
      my $otherchars = exists $lang->{otherchars} ?
	  $lang->{otherchars} : "[']";
      my $manyothercharsp = exists $lang->{"many-otherchars"} ?
	  ($lang->{"many-otherchars"} eq "yes" ? "t" : "nil") : "nil";
      my $ispellargs = exists $lang->{"ispell-args"} ?
	  $lang->{"ispell-args"} : "-d $hashname";
      my $extendedcharactermode = exists $lang->{"extended-character-mode"} ?
	  ('"' . $lang->{"extended-character-mode"} . '"') : "nil";
      my $codingsystem = exists $lang->{"coding-system"} ?
	  $lang->{"coding-system"} : "nil";
      my $emacsenname = exists $lang->{"emacsen-name"} ?
	  $lang->{"emacsen-name"} : $hashname;

# Explicitly add " -d $hashname" to $ispellargs if not already there.
      # Note that this must check for "-dxx", "-d xx", "-C -d xx", "-C -dxx" like matches
      if ( $ispellargs !~ m/( |^)-d/ ){
	print STDERR " - $class-emacsen: Adding \" -d $hashname\" to \"$ispellargs\"\n"
	  if defined $ENV{'DICT_COMMON_DEBUG'};
	$ispellargs .= " -d $hashname";
      }

$entries{$class}{$emacsenname} = $entries{'all'}{$emacsenname} =
	  ['"' . $emacsenname  . '"',
	   '"' . $casechars    . '"',
	   '"' . $notcasechars . '"',
	   '"' . $otherchars   . '"',
	   $manyothercharsp,
	   '("' . join ('" "', split (/\s+/,$ispellargs)) . '")',
	   $extendedcharactermode,
	   $codingsystem];

if ( $class eq "aspell" && exists $lang->{"aspell-locales"} ){
	foreach ( split(/\s*,\s*/,$lang->{"aspell-locales"}) ){
	  $class_locales{"aspell"}{$_} = $emacsenname;
	}
      } elsif ( $class eq "hunspell" && exists $lang->{"hunspell-locales"} ){
	foreach ( split(/\s*,\s*/,$lang->{"hunspell-locales"}) ){
	  $class_locales{"hunspell"}{$_} = $emacsenname;
	}
      }
    }
  }

# Write alists of ispell, hunspell and aspell only installed dicts and their properties

foreach $class ( @classes ) {
    my @class_dicts = reverse sort keys %{ $entries{$class} };
    if ( scalar @class_dicts ){
      $elisp .= "\n;; Adding $class dicts\n\n";
      foreach ( @class_dicts ){
	my $mystring = join ("\n     ",@{ $entries{$class}{$_} });
	$elisp .= "(add-to-list \'debian-$class-only-dictionary-alist\n  \'($mystring))\n";
      }
      $elisp .= "\n";
    }
  }

# Write a list of locales associated to each emacsen name

foreach my $class ("aspell", "hunspell"){
    my $tmp_locales = $class_locales{$class};
    if ( defined $tmp_locales && scalar %$tmp_locales ){
      $elisp .= "\n\n;; An alist that will try to map $class locales to emacsen names";
      $elisp .= "\n\n(setq debian-$class-equivs-alist \'(\n";
      foreach ( sort keys %$tmp_locales ){
	$elisp .= "     (\"$_\" \"$tmp_locales->{$_}\")\n";
      }
      $elisp .= "))\n";

# Obtain here debian-aspell-dictionary, after debian-aspell-equivs-alist
      # is loaded

$elisp .="
;; Get default value for debian-$class-dictionary. Will be used if
;; spellchecker is $class and ispell-local-dictionary is not set.
;; We need to get it here, after debian-$class-equivs-alist is loaded

(setq debian-$class-dictionary (debian-ispell-get-$class-default))\n\n";
   } else {
      $elisp .= "\n\n;; No emacsen-$class-equivs entries were found\n";
   }}

open (ELISP, "> $cachedir/$emacsensupport")
      or die "Cannot open emacsen cache file";
  print ELISP generate_comment (";;; ");
  print ELISP $elisp;
  close ELISP;
}

# ------------------------------------------------------------------
sub build_jed_support {
# ------------------------------------------------------------------
# Put info from dicts info files into jed-ispell-dicts.sl
# ------------------------------------------------------------------

my @classes = ("aspell","ispell");
  my $slang   = generate_comment ("%%% ");

## The S-Lang code generated below will be wrapped in preprocessor
  ## ifexists constructs, insuring that the $jedsupport file will
  ## always evaluate correctly.

foreach $class ( @classes ){
    my %class_slang    = ();
    my %class_slang_u8 = ();
    if ( my $dictionaries = loaddb ($class) ){
      foreach $k (sort keys %$dictionaries) {
	my $lang = $dictionaries->{$k};
	next if (exists $lang->{'jed-display'}
		 && $lang->{'jed-display'} eq "no");

my $hashname = $lang->{"hash-name"};
	my $additionalchars = exists $lang->{additionalchars} ?
	    $lang->{additionalchars} : "";
	my $otherchars = exists $lang->{otherchars} ?
	    $lang->{otherchars} : "'";
	my $emacsenname = exists $lang->{"emacsen-name"} ?
	    $lang->{"emacsen-name"} : $hashname;
	my $extendedcharmode = exists $lang->{"extended-character-mode"} ?
	    $lang->{"extended-character-mode"} : "";
	my $ispellargs = exists $lang->{"ispell-args"} ?
	    $lang->{"ispell-args"} : "";
	my $codingsystem = exists $lang->{"coding-system"} ?
	    $lang->{"coding-system"} : "l1";

# Strip enclosing [] from $otherchars
	$otherchars =~ s/^\[//;
	$otherchars =~ s/\]$//;
	# Convert chars in octal \xxx representation to the character
	$otherchars =~ s/\\([0-3][0-7][0-7])/chr(oct($1))/ge;
	$additionalchars =~ s/\\([0-3][0-7][0-7])/chr(oct($1))/ge;

$class_slang{$emacsenname} =
	    "  $class" . "_add_dictionary (\n"
	    . "    \"$emacsenname\",\n"
	    . "    \"$hashname\",\n"
	    . "    \"$additionalchars\",\n"
	    . "    \"$otherchars\",\n"
	    . ($class eq "ispell" ? "    \"$extendedcharmode\",\n" : "")
	    . "    \"$ispellargs\");";
	if ( $class eq "aspell" ){
	  my $converter = Text::Iconv->new ($codingsystem, "utf8");
	  my $additionalchars_utf = $converter->convert ($additionalchars);
	  my $otherchars_utf = $converter->convert ($otherchars);
	  $class_slang_u8{$emacsenname} =
	      qq{    aspell_add_dictionary (
      "$emacsenname",
      "$hashname",
      "$additionalchars_utf",
      "$otherchars_utf",
      "$ispellargs");};
	} # if $class ..
      } # foreach $k ..
    } # if loaddb ..
    if ( scalar keys %class_slang ){
      $slang .= "\n\#ifexists $class" . "_add_dictionary\n";
      if ( $class eq "aspell" ){
	$slang .= "  if (_slang_utf8_ok) {\n"
	    . join("\n",sort values %class_slang_u8)
	    . "\n  } else {\n"
	    . join("\n",sort values %class_slang)
	    . "\n  }";
      } else {
	$slang .= join("\n",sort values %class_slang);
      }
      $slang .= "\n\#endif\n";
    }
  } # foreach $class
  open (SLANG, "> $cachedir/$jedsupport")
      or die "Cannot open jed cache file";
  print SLANG $slang;
  close SLANG;
}

# ------------------------------------------------------------------
sub build_squirrelmail_support {
# ------------------------------------------------------------------
# Build support file for squirrelmail with a list of available
# dictionaries and associated spellchecker calls, in php format.
# ------------------------------------------------------------------
  my @classes      = ("aspell","ispell","hunspell");
  my $php          = "<?php\n";
  my @dictlist     = ();

$php .= generate_comment ("### ");
  $php .= "\$SQSPELL_APP = array (\n";

foreach my $class (@classes) {
    my $dictionaries = loaddb ($class);
    foreach ( keys %$dictionaries ){
      next if m/.*[^a-z]tex[^a-z]/i;            # Discard tex variants
      my $lang = $dictionaries->{$_};
      my $squirrelname;
      if ( defined $lang->{"squirrelmail"} ){
	next if ( lc($lang->{"squirrelmail"}) eq "no" );
	$squirrelname = $lang->{"squirrelmail"};
      } else {
	next unless m/^(.*)$(.+)$$/;
	$squirrelname = $2;
      }
      my $spellchecker_params =
	&dico_get_spellchecker_params($class,$lang);
      push @dictlist, qq {  '$squirrelname ($class)' => '$class -a $spellchecker_params'};
    }
  }

$php .= join(",\n", sort @dictlist);
  $php .= "\n);\n";

open (PHP, "> $cachedir/$squirrelmailsupport")
      or die "Cannot open SquirrelMail cache file";
  print PHP $php;
  close PHP;
}

# Ensure we evaluate to true.
1;

__END__

#Local Variables:
#perl-indent-level: 2
#End:

=head1 NAME

Debian::DictionariesCommon.pm - dictionaries-common library

=head1 SYNOPSIS

use Debian::DictionariesCommon q(:all)
    $dictionaries = parseinfo ('/var/lib/dictionaries-common/ispell/iwolof');
    loaddb ('ispell')
    updatedb ('wordlist')

=head1 DESCRIPTION

Common functions for use from the dictionaries-common system.

=head1 CALLING FUNCTIONS

=over

=item C<dico_checkroot>

Check for rootness and fail if not.

=item C<build_emacsen_support>

Put info from dicts info files into emacsen-ispell-dicts.el

=item C<build_jed_support>

Put info from dicts info files into jed-ispell-dicts.sl

=item C<build_squirrelmail_support>

Build support file for squirrelmail with a list of available
dictionaries and associated spellchecker calls, in php format.

=item C<$libdir = getlibdir($class)>

Return info dir for given class.

=item C<$default = dico_getsysdefault($class)>

Return system default value for given class.

=item C<$libdir = getuserdefault>

Return value for user default ispell dictionary.

=item C<dico_get_spellchecker_params($class,\%language)>

Get right params for $class (currently unused) and $language

=item C<\%dictionaries = loaddb($class)>

Read class .db file and return a reference to a hash
with its contents.

=item C<\%result = parseinfo($file)>

Parse given info file and return a reference to a hash with
the relevant data.

=item C<setsysdefault($value)>

Set value for system default ispell dictionary.

=item C<setuserdefault>

Set value for user default ispell dictionary, after asking
to select it from the available values.

=item C<updatedb($class)>

Parse info files for given class and update class .db
file under dictionaries-common cache dir.

=back

=head1 SEE ALSO

Debian dictionaries-common policy.

=head1 AUTHORS

Rafael Laboissiere
 Agustin Martin

=cut

/var/../usr/share/doc-base/../perl5/Debian/DictionariesCommon.pm