#!/usr/bin/perl


# Déclaration des pragmas
use strict;
use utf8;
use open qw/:std :utf8/;


# Appel des modules externes
use Encode qw(is_utf8);
use Getopt::Long;

# Recherche du nom du programme
my ($programme) = $0 =~ m|^(?:.*/)?(.+)|;
my $usage = "Usage : \n    $programme -t table -r répertoire [ -e extension ]* [ -s fichier_sortie ] [ -l log ] [ -cq ]\n" .
            "    $programme -t table -f fichier_entrée [ -s fichier_sortie ] [ -l log ] [ -cq ]\n" . 
            "    $programme -t table [ -l log ] [ -cq ]\n" . 
            "    $programme -h\n\n";

my $version     = "4.3.1";
my $dateModif   = "09 Janvier 2020";

my @liste = ();
my @table = ();
my %pref  = ();
my %str   = ();

# Initialisation des variables globales
# nécessaires à la lecture des options
my $aide       = 0;
my $casse      = 0;
my $fichier    = "";
my $log        = "";
my $quiet      = 0;
my $repertoire = "";
my $sortie     = "";
my $table      = "";
my @extensions = ();

eval    {
        $SIG{__WARN__} = sub {usage(1);};
        GetOptions(
                "casse"        => \$casse,
                "extension=s"  => \@extensions,
                "fichier=s"    => \$fichier,
                "help"         => \$aide,
                "log=s"        => \$log,
                "quiet"        => \$quiet,
                "repertoire=s" => \$repertoire,
                "sortie=s"     => \$sortie,
                "table=s"      => \$table,
                );
        };
$SIG{__WARN__} = sub {warn $_[0];};

if ( $aide ) {
        print "\nProgramme : \n    \"$programme\", version $version ($dateModif)\n";
        print "    Permet la reconnaissance et l’extraction dans un corpus de textes de termes \n"; 
        print "    figés (composés chimiques, noms scientifiques d’espèces animales ou végétales, \n"; 
        print "    noms propres, etc.) appartenant à une liste finie. \n";
        print "    En l’absence de l’option “-r” ou “-f”, ce programme traite le texte envoyé \n";
        print "    sur l’entrée standard. \n";
        print "    N.B. : la liste et les textes doivent être en UTF-8. \n\n";
        print $usage;
        print "Options :\n";
        print "    -c  tient compte de la casse (majuscule/minuscule) des termes recherchés \n";
        print "    -e  indique l’extension (e.g. “.txt”) du ou des fichiers textes à traiter \n";
        print "        (possibilité d’avoir plusieurs extensions en répétant l'option) \n";
        print "    -f  indique le nom du fichier texte à traiter \n";
        print "    -h  affiche cette aide \n";
        print "    -l  indique le nom du fichier récapitulatif où sera écrit pour chaque fichier \n";
        print "        traité le nombre de termes et d’occurrences trouvés\n";
        print "    -q  supprime l’affichage de la progression du travail \n";
        print "    -r  indique le répertoire contenant les fichiers textes à traiter \n";
        print "    -s  indique le nom du fichier où sera écrit le résultat du traitement \n";
        print "    -t  indique le nom du fichier contenant la ressource, c'est-à-dire la liste \n";
        print "        des termes à rechercher \n\n";
        print "Ressource : \n";
        print "    Le fichier de ressource contient un terme par ligne. On peut indiquer pour \n";
        print "    un terme sa forme préférentielle en ajoutant après le terme une ou plusieurs \n";
        print "    tabulations et le préférentiel. \n";
        print "    Les lignes vides et celles commençant par le caractère “#” ne sont pas prises \n";
        print "    en compte. De plus, la ressource peut être un fichier compressé par “gzip” ou \n";
        print "    “bzip2”. \n\n";
        print "Résultat : \n";
        print "    Le fichier résultat contient une ligne par occurrence trouvée. Chaque ligne \n";
        print "    est formée de 4 champs séparés par une tabulation. On a respectivement le nom \n";
        print "    du fichier traité (“STDIN” dans le cas de l'entrée standard), le terme tel \n";
        print "    qu'il est dans la ressource, le terme tel qu'il apparait dans le texte analysé \n";
        print "    et, dans le cas d'un synonyme, la forme préférentielle du terme. \n\n";
        exit 0;
        }

# Vérification de la présence des options obligatoires
usage(2) if not $table;

if ( $log ) {
        open(LOG, ">:utf8", "$log") or die "$!,";
        }
else    {
        open(LOG, "> /dev/null") or die "$!,";
        }

if ( ! -f $table ) {
        print STDERR "$programme : fichier \"$table\" absent\n";
        usage(5);
        }
elsif ( $table =~ /\.g?[zZ]\Z/ ) {
        open(TAB, "gzip -cd $table |") or die "$!, ";
        binmode TAB, ":utf8";
        }
elsif ( $table =~ /\.bz2\Z/ ) {
        open(TAB, "bzip2 -cd $table |") or die "$!, ";
        binmode TAB, ":utf8";
        }
else    {
        open(TAB, "<:utf8", $table) or die "$!, ";
        }

$SIG{'HUP'} = 'nettoye';
$SIG{'INT'} = 'nettoye';
$SIG{'TERM'} = 'nettoye';

print STDERR "\r", " " x 75, "\r Chargement de la ressource ...  " if not $quiet;

while (<TAB>) {
        next if /^#/o or /^\s*$/o;
        chomp;
        s/\r//go;

        # Vérification de jeu de caractères (doit être UTF-8)
        if ( not is_utf8($_, Encode::FB_QUIET) ) {
                print STDERR "Erreur : la table de référence doit être en UTF-8\n";
                exit 6;
                }

        my $pref =  "";
        my $terme = "";
        if ( /\t+/o ) {
                ($terme, $pref) = split(/\t+/o);
                }
        else    {
#                 $pref = $_;
                $terme = $_;
                }
        $terme =~ s/^\p{IsSpace}+//o;
        $terme =~ s/\p{IsSpace}+\z//o;
#         $terme =~ s/\p{IsSpace}\p{IsSpace}+/ /o;
        my $str = $terme;
        if ( $terme =~ m|^\p{IsSpace}*\Z| or $terme =~ m|^\p{IsWord}-?\Z| ) {
                print STDERR "Terme refusé : \"$terme\"\n";
                next;
                }
        $terme = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $terme)));
        $terme =~ s/  +/ /g;
        if ( not $casse ) {
                $terme = lc($terme);
                }
        if ( not $str{$terme} ) {
                push(@liste, $terme);
                $str{$terme} = $str;
                }
        else    {
#                 print STDERR "Erreur : doublon \"$str{$terme}\" et \"$str\"\n";
                print LOG "doublon \"$str{$terme}\" et \"$str\"\n";
                next;
                }
        if ( $pref ) {
                $pref =~ s/^\p{IsSpace}+//o;
                $pref =~ s/\p{IsSpace}+\z//o;
#                 $pref =~ s/\p{IsSpace}\p{IsSpace}+/ /o;
                $str = $pref;
                if ( $pref =~ m|^\p{IsSpace}*\Z| or $terme =~ m|^\p{IsWord}-?\Z| ) {
                        print STDERR "Préférentiel refusé : \"$pref\"\n";
                        next;
                        }
                $pref = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $terme)));
                $pref =~ s/  +/ /g;
                if ( not $casse ) {
                        $pref = lc($pref);
                        }
                if ( not $str{$pref} ) {
                        push(@liste, $pref);
                        $str{$pref} = $str;
                        }
                $pref{$terme} = $str;
                }
        }
close TAB;

@table = sort @liste;
my $nb = $#table + 1;
@liste = ();

if ( $nb == 0 ) {
        print STDERR "\r", " " x 75, "\r Aucun terme présent dans la liste\n";
        exit 3;
        }

print STDERR "\r", " " x 75, "\r $nb termes présents dans la liste\n" if not $quiet;

select(STDERR);
$| = 1;
select (STDOUT);

if ( $sortie ) {
        open(OUT, ">:utf8", $sortie) or die "$!,";
        select OUT;
        }

if ( $fichier ) {
        traite($fichier);
        }
elsif ( $repertoire ) {
        opendir(DIR, $repertoire) or die "$!,";
        my @fichiers = ();
        if ( @extensions ) {
                my $extensions = "(" . join("|", map {s/^\.//o; $_;} @extensions) . ")";
                @fichiers = grep(/\.$extensions\z/, grep(!/^\./o, readdir(DIR)));
                }
        else    {
                @fichiers = grep(!/^\./o, readdir(DIR));
                }
        closedir(DIR);
        foreach $fichier (@fichiers) {
                traite("$repertoire/$fichier");
                }
        }
else    {
        traite('-');
        }

nettoye();


exit 0;


sub usage
{
my $retour = shift;

print STDERR $usage;

exit $retour;
}

sub dich
{
my ($binf) = -1;
my ($bsup) = $nb;
my ($key) = $_[0];

while ( $bsup > $binf + 1 ) {
        my $bmid = int ( ( $bsup + $binf) / 2 );
        my $comp = $key cmp $table[$bmid];
        return $bmid if $comp == 0;
        if ( $comp > 0 ) {
                $binf = $bmid;
                }
        else    {
                $bsup = $bmid;
                }
        }
return (- $bsup - 1);
}

sub traite
{
my $input = shift;

my $nom   = "";
if ( $input eq '-' ) {
        open(INP, "<&STDIN") or die "Impossible de dupliquer STDIN: $!,";
        binmode(INP, ":utf8");
        $nom = "STDIN";
        }
else    {
        open(INP, "<:utf8", $input) or die "$!,";
        ($nom) = $input =~ m|^(?:.*/)?(.+)|o;
        }
        
my $texte = "";
my @resultats = ();
my %tmp = ();

print STDERR "\r", " " x 75, "\r Traite le fichier $nom  " if not $quiet;

while(<INP>) {
        # Vérification de jeu de caractères (doit être UTF-8)
        if ( not is_utf8($_, Encode::FB_QUIET) ) {
                if ( $nom eq 'STDIN' ) {
                        print STDERR "Erreur : le texte en entrée standard doit être en UTF-8\n";
                        }
                else    {
                        print STDERR "Erreur : le fichier \"$nom\" doit être en UTF-8\n";
                        }
                exit 7;
                }

        if ( /^\s*$/o ) {
                if ( $texte ) {
                        push(@resultats, recherche($nom, $texte));
                        while( my $resultat = shift @resultats ) {
                                print "$nom\t$resultat\n";
                                my ($ref, $chaine) = split(/\t/, $resultat);
                                $tmp{$ref} ++;
                                }
                        $texte = "";
                        }
                next;
                }
        tr/\n\r/  /s;
        $texte .= $_;
        }

if ( $texte ) {
        push(@resultats, recherche($nom, $texte));
        while( my $resultat = shift @resultats ) {
                print "$nom\t$resultat\n";
                my ($ref, $chaine) = split(/\t/, $resultat);
                $tmp{$ref} ++;
                }
        }

close INP;

my $nb_refs = 0;
my $nb_occs = 0;

foreach my $ref (keys %tmp) {
        $nb_refs ++;
        $nb_occs += $tmp{$ref};
        }

printf LOG "%d\t%d\t%s\n", $nb_refs, $nb_occs, $nom;
}

sub recherche
{
my ($cle, $orig) = @_;

$orig =~ s/^\s+//o;
$orig =~ s/\s+\z//o;

my $rec = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $orig)));

if ( ! $casse ) {
        $rec = lc($rec);
        }

my $terme = "";
my @matchs = ();

while ( length($rec) ) {
        my $retour = dich($rec);
        if ( $retour > -1 ) {
                print STDERR "\r", " " x 75, "\r" if not $quiet;
                $terme = $table[$retour];
                $terme =~ s/(\P{IsWord})/\\$1/g;
                $terme =~ s/\\ / */og;
                $terme =~ s/([^\x20-\x7F])/./og;
                if ( $orig =~ /^$terme\b/ or ( ! $casse and $orig =~ /^$terme\b/i ) ) {
                        push(@matchs, "$str{$table[$retour]}\t$&");
                        if ( $pref{$table[$retour]} ) {
                                $matchs[$#matchs] .= "\t$str{$pref{$table[$retour]}}";
                                }
                        }
                else    {
                        push(@matchs, "$str{$table[$retour]}\t*** ERREUR ***");
                        print STDERR "ERREUR (1) sur la recherche de l'original $cle\n";
                        }
                if ( not $quiet ) {
                        print STDERR "$cle => $str{$table[$retour]}\n";
                        print STDERR " Traite le fichier $cle  ";
                        }
                }
        else    {
                $retour = - 2 - $retour;
                $terme = $table[$retour];
                my ($debut) = $terme =~ m|^(.*?\p{IsWord}+)|;
                $debut =~ s/(\P{IsWord})/\\$1/g;
                do {
                        $terme =~ s/(\P{IsWord})/\\$1/g;
# Recherche le début du mot et autorise les préfixes
#                if ( $rec =~ /^$terme.*?\b/ ) {
                        if ( $rec =~ /^$terme\b/ ) { # Mot exact seulement
                                print STDERR "\r", " " x 75, "\r" if not $quiet;
                                $terme =~ s/\\ / */og;
                                $terme =~ s/([^\x20-\x7F])/./og;
                                if ( $orig =~ /^$terme/ or ( ! $casse and $orig =~ /^$terme/i ) ) {
                                        push(@matchs, "$str{$table[$retour]}\t$&");
                                        if ( $pref{$table[$retour]} ) {
                                                $matchs[$#matchs] .= "\t$str{$pref{$table[$retour]}}";
                                                }
                                        }
                                else    {
                                        push(@matchs, "$str{$table[$retour]}\t*** ERREUR ***");
                                        print STDERR "ERREUR (2) sur la recherche de l'original $cle\n";
                                        }
                                if ( not $quiet ) {
                                        print STDERR "$cle => $str{$table[$retour]}\n";
                                        print STDERR " Traite le fichier $cle  ";
                                        }
                                $retour = 0;
                                }
                        if ( $retour > 0 ) {
                                $terme = $table[--$retour];
                                }
                        else {
                                $terme = "";
                                }
                        } until $terme !~ /^$debut/;
                }
        $rec =~ s/^\P{IsSpace}+\p{IsSpace}?//;
        if ( $orig =~ /^\p{IsWord}+\p{IsSpace}*/ ) {
                $orig =~ s/^\p{IsWord}+\p{IsSpace}*//;
                }
        elsif ( $orig =~ /^\P{IsWord}\p{IsSpace}*/ ) {
                $orig =~ s/^\P{IsWord}\p{IsSpace}*//;
                }
        else    {
                print STDERR "ERREUR sur le texte intégral : $orig\n";
                }
        }

return @matchs;
}

sub nettoye
{
if ( not $quiet ) {
        print STDERR "\r", " " x 75, "\r";
        print STDERR "\n";
        }

exit 0;
}