#!/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 [ -e extension ] [ -l log ] [ -cq ]\n" . 
            "    $programme -h\n\n";

my $version     = "4.3.0";
my $dateModif   = "03 Novembre 2017";

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 "    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;
}