Current File : //usr/share/perl5/Debian/DictionariesCommon.pm
#!/usr/bin/perl
package Debian::DictionariesCommon;
use strict;
use base qw(Exporter);
use Text::Iconv;
# List all exported symbols here.
our @EXPORT_OK = qw(parseinfo updatedb loaddb
dico_checkroot
dico_debug
dico_debugprint
dico_get_spellchecker_params
getlibdir
dico_getsysdefault dico_setsysdefault
getuserdefault setuserdefault
dico_find_matching_choice
build_emacsen_support
build_jed_support
build_squirrelmail_support
dico_activate_trigger
dico_clean_orphaned_removefiles
dico_preprocess_default_symlinks
dico_set_default_symlink
);
# Import :all to get everything.
our %EXPORT_TAGS = (all => [@EXPORT_OK]);
my $infodir = "/var/lib/dictionaries-common";
my $cachedir = "/var/cache/dictionaries-common";
my $emacsensupport = "emacsen-ispell-dicts.el";
my $jedsupport = "jed-ispell-dicts.sl";
my $squirrelmailsupport = "sqspell.php";
my $debug = 1 if ( defined $ENV{'DICT_COMMON_DEBUG'} );
# Directories and files to store default values
my $sys_etc_dir = "/etc/dictionaries-common";
my $sys_default_dir = "$cachedir";
my $hunspelldir = "/usr/share/hunspell";
my $ispelldefault = "ispell-default";
my $userdefault = ( defined $ENV{HOME} ) ? "$ENV{HOME}/.$ispelldefault" : undef;
my %sys_default_file = ("ispell" => "$sys_default_dir/ispell-default",
"wordlist" => "$sys_default_dir/wordlist-default");
# ------------------------------------------------------------------
sub dico_checkroot {
# ------------------------------------------------------------------
# Check if we are root
# ------------------------------------------------------------------
return if ($> == 0 or ($^O eq 'interix' and $> == 197108));
die "$0: You must run this as root.\n";
}
# -------------------------------------------------------------
sub dico_debug {
# -------------------------------------------------------------
# Enable debug mode
# -------------------------------------------------------------
$debug++;
$ENV{'DICT_COMMON_DEBUG'}++;
}
# -------------------------------------------------------------
sub dico_debugprint {
# -------------------------------------------------------------
# Show info if in debug mode
# -------------------------------------------------------------
print STDERR "@_\n" if $debug;
}
# ------------------------------------------------------------------
sub getlibdir {
# ------------------------------------------------------------------
# Get location for dict-common info snippets
# ------------------------------------------------------------------
my $class = shift;
return "$infodir/$class";
}
# ------------------------------------------------------------------
sub mydie {
# ------------------------------------------------------------------
# A wrapper to die with some local flavor.
# ------------------------------------------------------------------
my $routine = shift;
my $errmsg = shift;
die __PACKAGE__, "($routine):E: $errmsg";
}
# ------------------------------------------------------------------
sub parseinfo {
# ------------------------------------------------------------------
# Parse given dict-common info file
# ------------------------------------------------------------------
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 my $thedict ( sort keys %{$dictionaries}){
$dictentries = $dictionaries->{$thedict};
@dictarray = ();
foreach my $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 "package Debian::DictionariesCommon::dbfile;\n\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") };
# Add package name to all entries
my $file_basename = $file;
$file_basename =~ s/^$infodir\/$class\///;
$dicts{$_}{'package'} = $file_basename foreach ( keys %dicts );
%dictionaries = (%dictionaries, %dicts);
}
# Merge auto-detected and declared hunspell info.
if ( "$class" eq "hunspell" ){
%dictionaries = %{
dc_merge_installed_hunspell_dicts
($hunspelldir,\%dictionaries) };
}
&dico_dumpdb($class,\%dictionaries);
}
# ------------------------------------------------------------------
sub loaddb {
# ------------------------------------------------------------------
# Load class database
# ------------------------------------------------------------------
my $class = shift;
my $dbfile = "$cachedir/$class.db";
if (-e $dbfile) {
do $dbfile;
}
return \%Debian::DictionariesCommon::dbfile::dictionaries;
}
# ------------------------------------------------------------------
sub getdefault {
# ------------------------------------------------------------------
# Read default value from specified file. Comments and empty lines are ignored.
# ------------------------------------------------------------------
my $file = shift;
my $lang = "";
if (-f $file) {
open( my $FILE,"< $file")
or die "Dictionaries-common::getdefault: Could not open $file for read. Aborting ...\n";
while (<$FILE>){
next if m/^\s*\#/;
next if m/^\s*$/;
$lang = $_;
last;
}
close $FILE;
return $lang;
}
return;
}
# ------------------------------------------------------------------
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 ($sys_default_file{$class});
}
# ------------------------------------------------------------------
sub dico_setsysdefault {
# ------------------------------------------------------------------
# Set system default value for given class
# ------------------------------------------------------------------
my $class = shift;
my $value = shift;
my $default_file = "$sys_default_file{$class}";
my $old_ispell_default = "$sys_etc_dir/$ispelldefault";
if ( "$value" ){
open (DEFAULT, "> $default_file");
print DEFAULT $value;
close DEFAULT;
# Set symlink from old to new location for squirrelmail benefit.
if ( $class eq "ispell" ){
unlink "$old_ispell_default";
symlink "$default_file", "$old_ispell_default";
}
} else {
unlink "$default_file" if ( -e "$default_file" );
# squirrelmail expects an empty file if no ispell dicts are installed.
if ( $class eq "ispell" ){
# Remove $old_ispell_default. Could be a symlink and target be written.
unlink "$old_ispell_default"; #
open (DEFAULT, "> $old_ispell_default");
print DEFAULT "";
close DEFAULT;
}
}
}
# ------------------------------------------------------------------
sub setuserdefault {
# ------------------------------------------------------------------
# Write user's default value to user's default file
# ------------------------------------------------------------------
my $default = getuserdefault ();
my $dictionaries = loaddb ("ispell");
my %languages = ();
my %elanguages = ();
foreach my $language ( sort keys %$dictionaries ){
my $entry = $dictionaries->{$language};
my $elanguage = $language;
if ( defined $entry->{'elanguage'} ){
$elanguage = $entry->{'elanguage'};
}
$languages{$elanguage} = $language;
$elanguages{$language} = $elanguage;
}
unless ( %languages ) {
warn "Sorry, no ispell dictionary is installed in your system.\n";
return;
}
my @choices = sort keys %languages;
my $initial = -1;
if ( defined $default ) {
my $default = $elanguages{$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 ( my $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 $languages{$choices[$sel]};
close DEFAULT;
last;
}
}
close TTY;
}
# ------------------------------------------------------------------
sub generate_comment {
# ------------------------------------------------------------------
# Generate a standard comment string with given prefix
# ------------------------------------------------------------------
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 dico_find_matching_choice {
# ------------------------------------------------------------------
# Try a single regexp match from given class choices
# ------------------------------------------------------------------
my $dictionaries = shift;
my $regexp = shift;
my @found_matches = grep {/$regexp/} keys %$dictionaries;
unless (@found_matches ) {
dico_debugprint "Try harder with case-independent match";
@found_matches = grep {/$regexp/i} keys %$dictionaries;
}
if ( scalar @found_matches eq 1 ){
return $found_matches[0];
} else {
my $dict_list = join("\n",sort keys %$dictionaries);
if ( @found_matches ){
dico_debugprint "Multiple matches for \"$regexp\":\n"
. join("\n",sort @found_matches);
} else {
dico_debugprint "No matches found for \"$regexp\". Available dicts:\n$dict_list";
}
return;
}
}
# ------------------------------------------------------------------
sub dc_merge_installed_hunspell_dicts {
# ------------------------------------------------------------------
# Parse installed hunspell dicts for hunspell-info like stuff and
# merge it with declared list.
# ------------------------------------------------------------------
my $hunspelldir = shift;
my $main_dicts = shift;
# Do nothing if no hunspell dicts are installed
return {} unless ( -d $hunspelldir);
$main_dicts = {} unless $main_dicts;
my @hunspell_aff = <$hunspelldir/*.aff>;
my $parsed_dicts = {};
my $locales_info = {};
my $emacs_equivs = {
"cs_CZ" => "czech",
"da_DK" => "dansk",
"de_DE" => "german8",
"en_GB" => "british",
"en_US" => "american",
"eo" => "esperanto",
"es" => "castellano8",
"es_ES" => "castellano8",
"fi_FI" => "finnish",
"fr_FR" => "francais",
"he_IL" => "hebrew",
"it_IT" => "italiano",
"nl_NL" => "nederlands",
"nn_NO" => "norsk",
"pl_PL" => "polish",
"pt_BR" => "brasileiro",
"pt_PT" => "portugues",
"ru_RU" => "russian",
"sk_SK" => "slovak",
"sl_SI" => "slovenian",
"sv_SE" => "svenska"
};
# Function to get value for key in hunspell aff file
my $parse_value = sub {
my $string = shift;
my $file = shift;
my $value = ( grep(/^\s*$string/,@{$file}) )[0];
if ( defined $value ){
chomp $value;
$value =~ s/\s+$//;
$value =~ s/^\s*$string\s*//;
}
return $value;
};
# Extract aff basename in a way that does not need anything
# outside perl-base (File::Basename is in perl-modules).
my $aff_basename = sub {
my $path = shift;
my $base = (split( /\/|\\/, $path))[-1];
$base =~ s/.aff$//;
return $base;
};
dico_debugprint "--< Debian/DictionariesCommon.pm: Start dc_merge_installed_hunspell_dicts function";
foreach my $aff ( @hunspell_aff ){
my $info = {};
chomp $aff;
if ( -l "$aff" && ! -e "$aff" ){
print STDERR "dmihd: Skipping broken symlink \"$aff\"\n";
next;
}
my $lang = &$aff_basename($aff);
$info->{'hash-name'} = $lang;
$info->{'emacsen-name'} = $lang;
open my $fh, '<:raw', $aff
or die "dmihd: Could not open \"$aff\" for read. Aborting.\n";
my @aff_contents = <$fh>;
close $fh;
my $coding = &$parse_value("SET",\@aff_contents);
if ( defined $coding ){
if ( $coding =~ m/^iso\d.*/i ){
# Emacs uses iso- for iso coding systems.
$coding =~ s/^iso/iso-/i;
}
$info->{'coding-system'} = lc($coding);
}
my $wordchars = &$parse_value("WORDCHARS",\@aff_contents);
if ( defined $wordchars ){
$info->{'otherchars'} = "[$wordchars]";
}
my $allchars = &$parse_value("TRY",\@aff_contents);
if ( defined $allchars ){
my $nonasciichars = $allchars;
$nonasciichars =~ s/[[:ascii:]]//g;
$info->{'additionalchars'} = $nonasciichars;
my @tmp2 = map { "\\" . sprintf("%o", ord($_)) } split('',$nonasciichars);
my $octal_nonascii =
join('',
map { "\\" . sprintf("%o", ord($_)) } split('',$nonasciichars)
);
$info->{'casechars'} = "[a-zA-Z$octal_nonascii]";
$info->{'not-casechars'} = "[^a-zA-Z$octal_nonascii]";
# $info->{'allchars'} = $allchars;
}
$info->{'package'} = "auto-detect";
if ( -l $aff ){
if ( my $target = readlink ($aff) ) {
chomp $target;
$target = &$aff_basename($target);
$locales_info->{$target}->{$lang}++;
};
} else {
$parsed_dicts->{$lang} = $info;
$locales_info->{$lang}->{$lang}++;
}
}
foreach my $lang ( keys %$parsed_dicts ){
if ( defined $locales_info->{$lang} ){
$parsed_dicts->{$lang}->{'hunspell-locales'} =
join(', ', sort keys %{$locales_info->{$lang}});
}
}
# Add aliases for classical emacsen dict names
foreach my $lang ( keys %$parsed_dicts ){
if ( defined $emacs_equivs->{$lang} ){
$parsed_dicts->{$lang}->{'emacsen-name'} = $emacs_equivs->{$lang};
}
}
my %main_dicts_emacsen;
my %main_dicts_hashes;
# Get a list of emacsen and hash names declared in hunspell-info files.
foreach my $lang ( keys %$main_dicts ){
my $lang_entries = $main_dicts->{$lang};
if ( defined $lang_entries->{'emacsen-name'} ) {
$main_dicts_emacsen{$lang_entries->{'emacsen-name'}}++;
$main_dicts_hashes{$lang_entries->{'hash-name'}}++
unless ( $lang_entries->{'emacsen-name'} eq "english_american" );
}
}
# Show some debugging code
dico_debugprint "main-dicts: ". join(', ',sort keys %$main_dicts);
dico_debugprint "emacsen-names:" . join(', ',sort keys %main_dicts_emacsen);
dico_debugprint "hash-names:" . join(', ',sort keys %main_dicts_hashes);
dico_debugprint "parsed-dicts-before: " . join(', ',sort keys %$parsed_dicts);
# Remove parsed entries redundant with a declared dict.
foreach my $lang ( keys %$parsed_dicts ){
if ( defined $main_dicts_emacsen{$parsed_dicts->{$lang}->{'emacsen-name'}}
||
defined $main_dicts_hashes{$parsed_dicts->{$lang}->{'hash-name'}}
){
# Parsed dict matches emacsen or hash name of a declared dict.
delete $parsed_dicts->{$lang};
} else {
my %lang_locales = ();
if ( defined $parsed_dicts->{$lang}->{'hunspell-locales'} ){
map { $lang_locales{$_}++ }
split ('\s*,\s*',$parsed_dicts->{$lang}->{'hunspell-locales'});
}
# A parsed dict locale matches hash name of a declared dict.
foreach my $locale ( keys %lang_locales ){
if ( defined $main_dicts_hashes{$locale} ){
delete $parsed_dicts->{$lang};
last;
}
}
}
}
dico_debugprint "parsed-dicts-cleaned: ", join(', ',sort keys %$parsed_dicts);
# Merge parsed dicts with declared main dicts (preferred)
foreach my $lang ( keys %$main_dicts ){
$parsed_dicts->{$lang} = $main_dicts->{$lang};
}
dico_debugprint "output-hunspell-dicts: ", join(', ',sort keys %$parsed_dicts), "\n>--";
return $parsed_dicts;
}
# ------------------------------------------------------------------
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 my $class ( @classes ){
my $dictionaries = loaddb ($class);
foreach my $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"} ?
lc($lang->{"coding-system"}) : "nil";
my $emacsen_name = defined $lang->{"emacsen-name"} ?
$lang->{"emacsen-name"} : $hashname;
my $emacsen_names = defined $lang->{"emacsen-names"} ?
$lang->{"emacsen-names"} : $emacsen_name;
# 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/ ){
dico_debugprint(" - $class-emacsen: Adding \" -d $hashname\" to \"$ispellargs\"");
$ispellargs .= " -d $hashname";
}
# Escape double quotes in otherchars unless already escaped
$otherchars =~ s/\"/\\"/ unless $otherchars =~ /\\"/;
foreach my $emacsenname ( split(',\s*',$emacsen_names) ){
$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 my $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 my $class ( @classes ){
my %class_slang = ();
my %class_slang_u8 = ();
if ( my $dictionaries = loaddb ($class) ){
foreach my $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;
}
# ------------------------------------------------------------------
sub dico_activate_trigger {
# ------------------------------------------------------------------
# Try activating provided trigger if run under dpkg control.
# Return true in success, nil otherwise.
# ------------------------------------------------------------------
my $trigger = shift;
my $options = shift;
my $await_trigger = defined $options->{'trigger-await'} ? "" : " --no-await ";
die "DictionariesCommon::dico_activate_trigger: No trigger provided. Aborting ...\n" unless $trigger;
if ( defined $ENV{'DPKG_RUNNING_VERSION'} &&
system("type dpkg-trigger >/dev/null 2>&1 && dpkg-trigger $await_trigger $trigger") == 0 ){
dico_debugprint("DictionariesCommon::dico_activate_trigger: Enabled trigger \"$trigger\" [$await_trigger]");
return 1;
}
return;
}
# ------------------------------------------------------------------
sub dico_clean_orphaned_removefiles {
# ------------------------------------------------------------------
# Clean orphaned remove files and their contents.
#
# dico_clean_orphaned_removefiles($class,$dictionaries)
# ------------------------------------------------------------------
my $class = shift;
die "DictionariesCommon::dico_preprocess_default_symlinks: No class passed"
unless $class;
my $dictionaries = shift;
die "DictionariesCommon::dico_preprocess_default_symlinks: No dictionaries passed"
unless $dictionaries;
my $program = "update-default-$class";
my $varlibdir = "/var/lib/$class";
return unless ( $class eq "aspell" or $class eq "ispell" );
foreach my $remove_file (<$varlibdir/*.remove>){
my $dict = $remove_file;
$dict =~ s/\.remove$//;
$dict =~ s/.*\///;
my $compat_file = "$varlibdir/$dict.compat";
# Remove orphaned remove files and its contents if no matching .compat file is found
unless ( -e "$compat_file" ){
open (my $REMOVE,"$remove_file");
while (<$REMOVE>){
chomp;
next if m/^\s*$/;
if ( -e "$_"
&& m:^(/usr/lib|/var/lib): ){
unlink "$_";
print STDERR "$program: Removing \"$_\".\n";
}
}
close $REMOVE;
unlink "$remove_file";
print STDERR "$program: Removing remove file \"$remove_file\".\n";
}
}
# Remove $varlibdir directory if empty and not owned
if ( -d "$varlibdir" ){
unless ( scalar <"$varlibdir/*"> ){
if ( system("dpkg-query -S $varlibdir > /dev/null 2>&1") == 0 ){
dico_debugprint("$program: Empty \"$varlibdir\" is owned by some package.");
} elsif ( scalar %$dictionaries ){
print STDERR "$program: Empty and unowned \"$varlibdir\", but \"$class\" elements installed.\n";
} else {
rmdir "$varlibdir";
print STDERR "$program: Removing unowned and empty \"$varlibdir\" directory.\n";
}
}
}
}
# ------------------------------------------------------------------
sub dico_preprocess_default_symlinks {
# ------------------------------------------------------------------
# Set default symlinks at $libdir if needed. Remove default symlinks
# at $libdir and $etcdir unless they are not dangling
#
# dico_preprocess_default_symlinks ($class,$dictionaries)
# ------------------------------------------------------------------
my $class = shift;
die "DictionariesCommon::dico_preprocess_default_symlinks: No class passed"
unless $class;
my $dictionaries = shift;
die "DictionariesCommon::dico_preprocess_default_symlinks: No dictionaries passed"
unless $dictionaries;
my $program = "installdeb-$class";
my $linkdir = "/etc/dictionaries-common";
my $libdir = { 'ispell' => "/usr/lib/ispell",
'wordlist' => "/usr/share/dict"};
my $links = {'ispell' => ["default.hash", "default.aff"],
'wordlist' => ["words"]};
if ( %{$dictionaries} ){
foreach my $link ( @{$links->{$class}} ){
my $link_from = "$libdir->{$class}/$link";
unless ( -e "$link_from" ){
if ( -w "$libdir->{$class}" ){
print STDERR "Symlinking $link_from to $linkdir/$link\n"
if $debug;
symlink "$linkdir/$link","$link_from";
} else {
print STDERR "$program:Warning: Non writable \"$libdir->{$class}\" dir. Read-only filesystem?\n";
}
}
}
} else {
foreach my $link ( @{$links->{$class}} ){
my $default_etc_link = "$linkdir/$link";
my $default_usr_link = "$libdir->{$class}/$link";
foreach my $default_link ( "$default_etc_link","$default_usr_link"){
if ( -l "$default_link" ){
if ( -e readlink "$default_link" ){ # Non-dangling symlink
print STDERR "$program: Leaving non dangling symlink behind: \"$default_link\"\n";
} else {
if ( -w "$libdir->{$class}" ){
dico_debugprint("No $class elements. Remove $default_link.");
unlink "$default_link"
} else {
print STDERR "$program:Warning: Non writable \"$libdir->{$class}\" dir. Read-only filesystem?\n";
}
}
} elsif ( -e "$default_link" ){
print STDERR "Leaving non symlink \"$default_link\" behind.\n"
}
}
}
}
}
# ------------------------------------------------------------------
sub dico_set_default_symlink {
# ------------------------------------------------------------------
# Try setting default symlinks for ispell dictionaries and wordlists.
# dico_set_default_symlink($class,$value)
# ------------------------------------------------------------------
my $class = shift;
die "DictionariesCommon::dico_set_default_symlink: No class passed" unless $class;
my $value = shift;
die "DictionariesCommon::dico_set_default_symlink: No value passed" unless $value;
my $dictionaries = loaddb ($class);
my $program = "update-default-$class";
my $linkdir = "/etc/dictionaries-common";
my $class_name = { 'ispell' => "ispell dictionary",
'wordlist' => "wordlist"};
my $libdir = { 'ispell' => "/usr/lib/ispell",
'wordlist' => "/usr/share/dict"};
my $link_suffixes = { 'ispell' => [".hash", ".aff"],
'wordlist' => [""]};
my $link_basename = { 'ispell' => "default",
'wordlist' => "words"};
if ( defined $dictionaries->{$value}{"hash-name"} ){
dico_debugprint("update-default-$class: \"$value\" -> \"$dictionaries->{$value}{'hash-name'}\"");
my $hash = "$libdir->{$class}/" . $dictionaries->{$value}{"hash-name"};
foreach my $i ( @{$link_suffixes->{$class}}) {
my $link_to = "$hash$i";
if ( -e "$link_to" ) {
my $link_from = "$linkdir/$link_basename->{$class}$i";
system "ln -fs $link_to $link_from";
dico_debugprint("$program: \"$link_from\" symlink set to \"$link_to\"");
} else {
die "$program:
Could not make the default symlink to \"$link_to\".
This may be a temporary problem due to installation ordering. If that
file is not present after installation, please file a bugreport
against $class_name->{$class} package owning that file.
\n";
}
}
} else {
die "$program: Selected value \"$value\" for $class_name->{$class}\n" .
"does not contain a hash name entry in the database.\n";
}
}
# 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
Mini Shell