—

              
package Lingua::Jspell::DictManager;
use 5.006;
use strict;
use warnings;
use Data::Dumper;
use File::Copy;
use YAML 'LoadFile';
use File::Spec::Functions;
use Lingua::Jspell;
require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'all' => [ qw() ] );
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
our @EXPORT = qw( &toword &install_dic );
our $VERSION = '0.01';
# Preloaded methods go here.
sub install_dic{
  my %opt =(yaml => undef, name=>undef); ## irr => "name.irr"
  if(ref($_[0]) eq "HASH") {%opt = (%opt , %{shift(@_)}) } ;
  my ($aff,@dic)=@_;
  my $cpaff=1;
  if($aff =~ /^from:(.*)/){
     $aff = catfile($Lingua::Jspell::JSPELLLIB,"$1.aff") ; $cpaff=0;}
  my $ya;
  open(F,">__$$.dic") or die("Error 1: $!\n");
  for (@dic){open(G, $_) or die("Error 2($_): $!\n");
      print F <G>;
      close G;
  }
  close F;
  $ya = LoadFile($opt{yaml}) if $opt{yaml};
  my $name = $opt{name} || $ya->{META}{IDS}[0] || $dic[0];
  if($opt{hash}){ copy($opt{hash}, "__$$.hash"); }
  else { system ("jbuild __$$.dic $aff __$$.hash"); }
  if($opt{irr}){
    copy($opt{irr},catfile($Lingua::Jspell::JSPELLLIB,$opt{irr}))
       or warn ("Error 3: $!");
  }
  copy("__$$.hash",catfile($Lingua::Jspell::JSPELLLIB,"$name.hash"))
    or warn ("Error 4: $!");
  if($cpaff){
    copy($aff,       catfile($Lingua::Jspell::JSPELLLIB,"$name.aff"))
       or warn ("Error 5: $!");
  }
  if ($opt{yaml}){
     copy($opt{yaml},       catfile($Lingua::Jspell::JSPELLLIB,"$name.yaml"))
       or warn ("Error 6: $!");
     for(@{$ya->{META}{IDS}}){
        copy("__$$.hash",catfile($Lingua::Jspell::JSPELLLIB,"$_.hash"))
           or warn ("Error 7: $!");
     }
  }
  unlink("__$$.dic","__$$.hash","__$$.dic.cnt","__$$.dic.stat");
}
sub init{
  my $file = shift;
  my $self = { filename => $file };
  open F, $file or die "Cannot open file '$file': $!\n";
  while(<F>) {
    $self->{   shortcut}{$1} = $2 if (m!^#([^/]+)/([^/]+)/!);
    $self->{revshortcut}{$2} = $1 if (m!^#([^/]+)/([^/]+)/!);
  }
  close F;
  copy($file,"$file.old") or die("$! cant create $file.old\n");
  return bless($self);
}
sub toword{ _data2line(@_) }
sub modeach_word{
  my %opt =(rawfea => 0);
  my $dic = shift;
  if(ref($_[0]) eq "HASH") {%opt = (%opt , %{shift(@_)}) } ;
  my $func = shift;
  open DIC, $dic->{filename} or die("cannot open file");
  open NDIC, ">$dic->{filename}.new" or die("cannot create file $!");
  while(<DIC>) {
    if (m!^#! or m!^\s*$!){ print NDIC $_ ; next }
    chomp;
    my ($word,$class,$flags,@r) = split '/', $_;
    my @flags = ($flags)?split(//, $flags):();
    if(not $opt{rawfea}){
      my @atts;
      if ($class =~ /^\$/){ @atts = (special => $class)}
      else {
       $class =~ s/#([A-Za-z][A-Za-z0-9]*)/$dic->{shortcut}{$1} || ""/ge if $class;
       @atts = ($class)?split(/[,=]/, $class):();
      }
      my %atts;
      if (@atts % 2) {
        %atts = ();
      } else {
        %atts = @atts;
      }
      print NDIC $func->($word,\%atts,\@flags,@r) || $_;
    }
    else {
      print NDIC $func->($word,$class,\@flags,@r) || $_;
    }
    print NDIC "\n";
  }
  close DIC;
  close NDIC;
  copy("$dic->{filename}.new",$dic->{filename});
}
sub foreach_word {
  my %opt =(type => "struct");
  my $dic = shift;
  if(ref($_[0]) eq "HASH") {%opt = (%opt , %{shift(@_)}) } ;
  my $func = shift;
  open DIC, $dic->{filename} or die("cannot open file");
  while(<DIC>) {
    next if m!^#!;
    next if m!^\s*$!;
    chomp;
    my ($word,$class,$flags,@r) = split '/', $_;
    if($opt{type} eq "struct"){
      $class =~ s/#([A-Za-z][A-Za-z0-9]*)/$dic->{shortcut}{$1} || ""/ge if $class;
      my @flags = ($flags)?split(//, $flags):();
      my @atts = ($class)?split(/[,=]/, $class):();
      my %atts;
      if (@atts % 2) {
        %atts = ();
      } else {
        %atts = @atts;
      }
      $func->($word,\%atts,\@flags,@r); }
    elsif( $opt{type} eq "raw"){ $func->($_); }
  }
  close DIC;
}
sub for_this_cat_I_want_only_these_flags {
  my $dic = shift;
  my $cat = shift;
  $cat =~ s/#//g;
  my $flags = shift;
  my %flags;
  @flags{split //,$flags}=1;
  foreach_word($dic, sub {
                 my ($w,$a,$f) = @_;
                 my %fs = %flags;
                 my $ct = $cat;
                 my $this_cat = $a->{CAT} || "unknown";
                 if ($this_cat eq $ct) {
                   my $fl;
                   for $fl(@$f) {
                     unless (exists($fs{$fl})) {
                       print "$w from category '$cat' uses flag '$fl'\n";
                     }
                   }
                 }
               });
}
sub for_this_cat_I_dont_want_these_flags {
  my $dic = shift;
  my $cat = shift;
  $cat =~ s/#//g;
  my $flags = shift;
  my %flags;
  @flags{split //,$flags}=1;
  foreach_word($dic, sub {
                 my ($w,$a,$f) = @_;
                 my %fs = %flags;
                 my $ct = $cat;
                 my $this_cat = $a->{CAT} || "unknown";
                 if ($this_cat eq $ct) {
                   my $fl;
                   for $fl(@$f) {
                     if (exists($fs{$fl})) {
                       print "$w from category '$cat' uses flag '$fl'\n";
                     }
                   }
                 }
               });
}
sub not_categorized {
    my $dic = shift;
    open DIC, $dic->{filename} or die("Cannot open file");
    while(<DIC>) {
        chomp;
        next if /^#/;
        next if /^\s*$/;
        m{^([^/]+)/};
        my $word = $1;
        my $cat = $';
        next unless ($cat =~ m!^/!);
        print "word '$word' doesn't have a categorie\n";
    }
    close DIC;
}
sub extra_words {
  my $dic = shift;
  my %from;
  my ($r,$word,$fea,$fea1,$t);
  my $jdic = Lingua::Jspell->new("port");
  open DIC, $dic->{filename} or die("Cannot open file");
  while(<DIC>) {
    chomp;
    next if /^#/;
    next if /^\s*$/;
    m{^([^/]+)/};
    $word = $1;
    my @rads = $jdic->rad($word);
    if (@rads > 1) {
      print STDERR "." if rand > 0.99;
      for $r (@rads) {
        next if ($r eq $word);
        # for the fea from $word, get the rad==$r
        for $fea ($jdic->fea($word)) {
          if ($fea->{rad} eq $word) {
            for $fea1 (fea($r)) {
              if (_same_cat($fea1->{CAT},$fea->{CAT})) {
                $from{$r} = {word=>$word, orig=>$fea1, dest=>$fea};
              }
            }
          }
        }
        # $from{$r} = {word=>$word};
      }
    }
  }
  close DIC;
  for (keys %from) {
    if ($from{$from{$_}{word}}{word}) {
      print "# warning: multiple dependence\n";
      print "# \t$_ => $from{$_}{word} => $from{$from{$_}{word}}{word}\n";
      delete($from{$_});
    } else {
      print "# from $_ you can get $from{$_}{word}\n";
      print "delete_word('$from{$_}{word}')\n";
    }
  }
}
sub _same_cat {
  my ($a,$b) = @_;
  if (defined($a) && defined($b)) {
    return ($a eq $b);
  } else {
    return 0;
  }
}
# Each element should be a reference to an associative array like this:
#
# { word => 'word', flags => 'zbr', CAT => 'np', G=>'f' }
sub add_word {
        my $dict = shift;
        $dict->_add_full_line(map {
                                my $word = $_->{word};
                                my $flags = $_->{flags};
                                my $comment = $_->{comment} || "";
                                delete($_->{word});
                                delete($_->{flags});
                                delete($_->{comment});
                                my %hash = %$_;
                                my $info = join(",",map {"$_=$hash{$_}"} keys %hash);
                                "$word/$info/$flags/$comment"
                                 } @_);
}
sub _add_full_line {
        my $dict = shift;
    my %saw =();
    @saw{@_} = ();
        my @v;
        open DIC, $dict->{filename} or die("cannot open dictionary file");
        open NDIC, ">$dict->{filename}.new" or die("cannot open new dictionary file");
        while (<DIC>) {
                push @v,$_ and next if (/^#/);
        chomp;
                $saw{$_} = 1;
        }
         
        print NDIC join "", @v;
        print NDIC "\n\n";
        print NDIC map {/./ ? ("$_\n"):()} sort keys %saw;
        close DIC;
        close NDIC;
    copy("$dict->{filename}.new",$dict->{filename});
}
sub delete_word {
        my $dict = shift;
        my $pal=shift;
        my $t;
        open DIC, $dict->{filename} or die("cannot open dictionary file");
        open NDIC, ">$dict->{filename}.new" or die("cannot open new dictionary file");
        while (<DIC>) {
                $t = $1 if /^(.+?)\//;
                print NDIC unless ($t=~/^$pal$/);
        }
        close DIC;
        close NDIC;
    copy("$dict->{filename}.new",$dict->{filename});
}
sub add_flag {
        my $dic = shift;
        my $flag = shift;
        my %words;
        @words{@_} = 1;
         
        $dic -> foreach_word( sub {
                 my ($w,$a,$f) = @_;
                 my %fs;
                 @fs{@$f}=1; 
                 if ($words{$w}) {
                        @fs{split //, $flag}=1;;
                        print _data2line($w,$a,join("",keys %fs));
                 }
                 print _data2line($w,$a,$f);
                 
                                });
}
#$pal=shift;
#($ac,$flag)=(shift=~/([\+\-])(.)/);
#
#while (<>) {
        #print $_ and next if ($_=~/^#/ || $_ eq "\n");
        #$_=~s#\n#/\n# unless ($_=~/.*\/.*\/.*\//);
        #($a,$b,$c,$d)=($_=~/^(.+?)\/(.*?)\/(.*?)\/(.*)/);
        #$c=~s#$flag##g if ($a=~/^$pal$/);
        #$c.=$flag if ($a=~/^$pal$/ && $ac eq "+");
        #print "$a/$b/$c/$d\n";
#}
sub _data2line { my ($word,$atts,$flags,@r) = @_;
  if(ref $atts){
     return "$word/". join(",",map { "$_=$atts->{$_}" } keys %$atts).
                 "/". join("",grep {/./} @$flags).
                 "/". join("/",@r);
  } else {
     return "$word/". $atts .
                 "/". join("",grep {/./} @$flags).
                 "/". join("/",@r);
  }
}
HideShow 122 lines of Pod
=head1 NAME
Lingua::Jspell::DictManager - a perl module for processing jspell dictionaries
=head1 SYNOPSIS
 use Lingua::Jspell::DictManager;
 $dict = init("dictionary file");
 $dict->foreach_word( \&func );
 $dict->for_this_cat_I_want_only_these_flags('nc', 'fp');
 $dict->add_flag("p","linha","carro",...);
 $dict->add_word({word=>'word',flags=>'zbr',CAT=>'np',G=>'f'},...)
 remflag("f.dic","p","linha","carro",...);
=head1 DESCRIPTION
=head2 C<init>
This function returns a new dictionary object to be used in future
methods. It requires a string with the dictionary file name.
=head2 C<install_dic>
 install_dic({name=>"teste"} ,"t.aff", "t.dic")
 install_dic({name=>"t"} ,"from:port", "t1.dic", "t2.dic")
 install_dic({yaml=>"t.yaml"} ,"from:port", "t1.dic", "t2.dic")
 install_dic({yaml=>"t.yaml",irr=>"f.irr"} ,"from:port", "t1.dic")
C<from:lang> is used to reuse the affix table from language C<lang> (the
file lang.aff is imported from the jspell library directory. (see jspell-dic
-dir)
  name  -- name of the dictionary
  yaml  -- yaml file with metadata
  irr   -- file with irregular terms
=head2 C<foreach_word>
This method processes all words from the dictionary using the function
passed as argument. This function is called with three arguments: the
word, a reference to an associative array with the category
information and a reference to a list of rules identifiers.
=head2 C<modeach_word>
This method processes all words from the dictionary using the function
passed as argument. This function is called with three arguments: the
word, a reference to an associative array with the category
information and a reference to a list of rules identifiers.
If the option C<< rawfea =>1 >> is selected, modeach_word receives a string 
instead of a hash reference.
 modeach_word({rawfea=>1}, sub { my($w,$cat,$flags,@com)=@_; ... })
Use the function C<toword($word,$fea,$flag,$coms)> to rebuild a new value;
if "" is return, the previous value is kept.
=head2 C<for_this_cat_I_want_only_these_flags>
This method receives a gramatical category and a string with flags. It
will print warning messages for each entry with that category and with
a flag not described in the flags string.
=head2 C<for_this_cat_I_dont_want_these_flags>
Works like the previous method, but will print warnings if any
category uses one of the specificed flags.
=head2 C<not_categorized>
This method returns a report for the entries without a category
definition.
=head2 C<extra_words>
This method tries to find redundant entries on the dictionary,
producing an ouput file to be executed and delete the redundancy.
=head2 C<add_word>
Add (one or more) word to the dictionary
 $dict->add_word({word=>'word',flags=>'zbr',CAT=>'np',G=>'f'},...)
=head2 C<delete_word>
Deletes the word passed as argument.
=head2 C<add_flag>
Adds the flags in the first argument to all words passed.
=head2 C<toword>
to format Word, features, flags and commants to jspell-dict format.
This functions is tically used em C<modeach_word>.
=head1 AUTHOR
 Alberto Simoes, E<lt>albie@alfarrabio.di.uminho.ptE<gt>
 J.Joao Almeida, E<lt>jj@di.uminho.ptE<gt>
=head1 SEE ALSO
 Lingua::Jspell(3), jspell(1)
=head1 COPYRIGHT & LICENSE
Copyright 2007-2009 Projecto Natura
This program is free software; licensed under GPL.
=cut
1;
__END__