#!/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 qw(:config bundling);
# use Getopt::Long qw(:config no_ignore_case bundling);
use Getopt::Long;
use POSIX qw(mkfifo);
use JSON;
# 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 -j [ -f fichier_entrée ] [ -s fichier_sortie ] [ -l log ] [ -cq ]\n" .
" $programme -t table -p FIFO [ -l log ] [ -cw ]\n" .
" $programme -h\n\n";
my $version = "4.5.1";
my $dateModif = "31 Août 2022";
my @table = ();
my %genre = ();
my %liste = ();
my %pref = ();
my %str = ();
# Initialisation des variables globales
# nécessaires à la lecture des options
my $aide = undef;
my $casse = undef;
my $fichier = undef;
my $json = undef;
my $log = undef;
my $fifo = undef;
my $quiet = undef;
my $repertoire = undef;
my $sortie = undef;
my $table = undef;
my $ws = undef;
my @extensions = ();
my $recherche = 0;
# Getopt::Long::Configure("no_ignore_case");
# Getopt::Long::Configure("bundling");
eval {
$SIG{__WARN__} = sub {usage(1);};
GetOptions(
"casse" => \$casse,
"extension=s" => \@extensions,
"fichier=s" => \$fichier,
"json" => \$json,
"help" => \$aide,
"log=s" => \$log,
"pipe=s" => \$fifo,
"quiet" => \$quiet,
"repertoire=s" => \$repertoire,
"sortie=s" => \$sortie,
"table=s" => \$table,
"webservice" => \$ws,
);
};
$SIG{__WARN__} = sub {warn $_[0];};
if ( $aide ) {
print "\nProgramme : \n \"$programme\", version $version ($dateModif)\n";
print " Adaptation du script Perl “IRC3.pl” permettant la reconnaissance et l’extraction \n";
print " dans un corpus de textes de noms scientifiques d’espèces animales ou végétales \n";
print " appartenant à une liste finie. En plus des noms in-extenso, ce programme recherche \n";
print " aussi les formes abrégées, par exemple : “C. lupus” pour “Canis lupus”. \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 (pour lire les données sur \n";
print " l’entrée standard, utilisez un tiret “-” comme argument) \n";
print " -h affiche cette aide \n";
print " -j indique que les données en entrée, dans un fichier ou sur l’entrée standard, \n";
print " sont en JSON ainsi que le résultat en sortie \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 " -p indique le nom du tube nommé (“named pipe”) ou FIFO utilisé pour transmettre \n";
print " les données \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";
print " -w indique que le programme est utilisé par un “webservice” qui modifie le fichier \n";
print " envoyé en ne gardant que les objets JSON \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 5 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 apparait dans le texte analysé, la forme abrégée du terme tel qu'il est \n";
print " dans la ressource si c’est une forme abrégée qui a été trouvée, le terme tel \n";
print " qu'il est dans la ressource et, dans le cas d'un synonyme, la forme préférentielle \n";
print " du terme. \n\n";
exit 0;
}
# Vérification de la présence des options obligatoires
usage(2) if not $table;
usage(2) if not $fichier and not $repertoire and not $json and not $fifo;
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'} = 'nettoie';
$SIG{'INT'} = 'nettoie';
$SIG{'TERM'} = 'nettoie';
if ( $fifo ) {
$quiet = 2;
mkfifo($fifo, 0666) or die "Impossible de créer FIFO\x{A0}: $!,";
}
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 {
$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} ) {
$str{$terme} = $str;
my ($genre) = $str =~ /^(\P{IsWord}*\p{IsWord}.*?) .+/o ? $1 : $str;
$genre{$genre} ++;
my $tmp = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $genre)));
if ( $casse ) {
$str{$tmp} = $genre if not $str{$tmp};
}
else {
$tmp = lc($tmp);
$str{$tmp} = $genre;
}
push(@{$liste{$tmp}}, $terme);
}
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 $pref =~ m|^\p{IsWord}-?\Z| ) {
print STDERR "Préférentiel refusé : \"$pref\"\n";
next;
}
$pref = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $pref)));
$pref =~ s/ +/ /g;
if ( not $casse ) {
$pref = lc($pref);
}
if ( not $str{$pref} ) {
$str{$pref} = $str;
my ($genre) = $str =~ /^(\P{IsWord}*\p{IsWord}.*?) .+/o ? $1 : $str;
$genre{$genre} ++;
my $tmp = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $genre)));
if ( $casse ) {
$str{$tmp} = $genre if not $str{$tmp};
}
else {
$tmp = lc($tmp);
$str{$tmp} = $genre;
}
push(@{$liste{$tmp}}, $pref);
}
$pref{$terme} = $str;
}
}
close TAB;
my $prefRef = \%pref;
my $strRef = \%str;
my $fleche = "";
my @resultats = ();
foreach my $genre (sort keys %liste) {
if ( $casse ) {
push(@table, sort @{$liste{$genre}}, $genre);
}
else {
push(@table, sort @{$liste{$genre}}, lc($genre));
}
}
my $nb = $#table + 1;
if ( $nb == 0 ) {
print STDERR "\r", " " x 75, "\r Aucun terme présent dans la liste\n";
exit 3;
}
if ( not $quiet ) {
my $tmp = $nb;
1 while $tmp =~ s/(\d)(\d\d\d)\b/$1.$2/o;
print STDERR "\r", " " x 75, "\r $tmp termes présents dans la liste\n" ;
}
if ( $fifo ) {
# $quiet = 0;
$json = undef;
$sortie = undef;
my $retour = undef;
my @json = ();
while( 1 ) {
open(INP, "<:raw", $fifo) or die "$!,";
# binmode(INP, ":raw");
while(<INP>) {
if ( /^%% JOB POUR FIFO (.+)$/o ) {
$sortie = $1;
open(OUT, ">:utf8", $sortie) or die "$!,";
}
elsif ( /^%% FIN JOB/o ) {
$sortie = undef;
if ( $ws ) {
$json = '[' . join(",", @json) . ']';
@json = passe1($json);
foreach $json (@json) {
print OUT "$json\n";
}
@json = ();
}
else {
($json, $retour) = passe1($json);
print OUT $json;
}
close OUT;
$json = undef;
}
elsif ( $sortie ) {
if ( $ws ) {
push(@json, $_);
}
else {
$json .= $_;
}
}
elsif ( /^%% STOP IRC3/o ) {
unlink $fifo;
exit 0;
}
}
close INP;
}
nettoie();
exit 2;
}
select(STDERR);
$| = 1;
select (STDOUT);
if ( $sortie ) {
open(OUT, ">:utf8", $sortie) or die "$!,";
select OUT;
}
if ( $json ) {
if ( $fichier ) {
traite_json($fichier);
}
else {
traite_json('-');
}
}
elsif ( $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 (sort @fichiers) {
traite("$repertoire/$fichier");
}
}
nettoie();
exit 0;
sub usage
{
print STDERR "\n$usage";
exit shift;
}
sub dich
{
my ($key, $tref, $nbi) = @_;
my ($binf) = -1;
my ($bsup) = $nbi;
while ( $bsup > $binf + 1 ) {
my $bmid = int ( ( $bsup + $binf) / 2 );
my $comp = $key cmp $tref->[$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 @para = ();
my %tmp = ();
# On pense à vides la liste
@resultats = ();
# Première passe -> fléche simple
$fleche = '->';
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(@para, $texte);
push(@resultats, recherche($nom, $texte));
$texte = "";
}
next;
}
tr/\n\r/ /s;
$texte .= $_;
}
if ( $texte ) {
push(@resultats, recherche($nom, $texte));
$texte = "";
}
close INP;
# Penser au cas où on ne trouve rien lors de la première passe
if ( not @resultats ) {
print LOG "0\t0\t$nom\n";
return;
}
@resultats = passe2($nom, \@resultats, \@para);
}
sub traite_json
{
my $nom = shift;
if ( $nom eq '-' ) {
open(INP, "<&STDIN") or die "Impossible de dupliquer STDIN: $!,";
binmode(INP, ":raw");
$nom = 'STDIN';
}
else {
open(INP, "<:raw", $nom) or die "$!,";
}
my $texte = undef;
my @id = ();
my @para = ();
my %para = ();
my %resultats = ();
my %tmp = ();
# On pense à vides la liste
@resultats = ();
# Première passe -> fléche simple
$fleche = '->';
print STDERR "\r", " " x 75, "\r Traite le fichier $nom " if not $quiet;
my $input = "";
my @input = ();
my %input = ();
while(<INP>) {
$input .= $_;
}
close INP;
my ($json, $retour) = passe1($input);
print $json;
if ( $retour ) {
nettoie();
exit $retour;
}
}
sub passe1
{
my $input = shift;
# Variables
my $nom = undef;
my $texte = undef;
my @id = ();
my @input = ();
my @para = ();
my %input = ();
my %para = ();
my %resultats = ();
my %tmp = ();
my $perl = undef;
eval {
$perl = decode_json $input;
};
if ( $@ ) {
$@ =~ s/"/\\"/go;
$@ =~ s/[\r\n]//go;
$@ =~ s/at $0 .+//go;
if ( $ws ) {
return("{\"message\": \"erreur de conversion des données JSON vers Perl.\", \"explication\": \"$@\"}\n");
}
else {
return("[{\"message\": \"erreur de conversion des données JSON vers Perl.\", \"explication\": \"$@\"}]\n", 4);
}
}
if ( ref($perl) eq 'ARRAY' ) {
@input = @{$perl};
foreach my $doc (@input) {
my %doc = %{$doc};
$nom = $doc{'id'};
push(@id, $nom);
my $value = $doc{'value'};
if ( ref($value) eq 'ARRAY' ) {
my @values = @{$value};
foreach my $item (@values) {
push(@para, $item);
push(@resultats, recherche($nom, $item));
}
}
else {
push(@para, $value);
push(@resultats, recherche($nom, $value));
}
if ( @resultats ) {
@{$para{$nom}} = @para;
@para = ();
@{$resultats{$nom}} = @resultats;
@resultats = ();
}
}
}
elsif ( ref($perl) eq 'HASH' ) {
%input = %{$perl};
$nom = $input{'id'};
push(@id, $nom);
my $value = $input{'value'};
if ( ref($value) eq 'ARRAY' ) {
my @values = @{$value};
foreach my $item (@values) {
push(@para, $item);
push(@resultats, recherche($nom, $item));
}
}
else {
push(@para, $value);
push(@resultats, recherche($nom, $value));
}
if ( @resultats ) {
@{$para{$nom}} = @para;
@para = ();
@{$resultats{$nom}} = @resultats;
@resultats = ();
}
}
my @tmp = ();
foreach $nom (@id) {
my @ambigus = ();
my %especes = ();
my $tmp = " {\n \"id\": \"$nom\",\n";
if ( defined $resultats{$nom} ) {
@resultats = passe2($nom, \@{$resultats{$nom}}, \@{$para{$nom}});
# foreach my $item (@resultats) {
while ( my $item = shift @resultats ) {
my @champs = split(/\t/, $item);
if ( $champs[2] =~ /^\?.+\?\z/o ) {
push(@ambigus, $item);
}
else {
$especes{$champs[2]} ++;
}
}
}
my @especes = sort keys %especes;
if ( @especes ) {
$tmp .= $ws ? " \"value\": [\n" : " \"species\": [\n";
while (my $item = shift @especes) {
$tmp .= " \"$item\"";
$tmp .= ", " if @especes;
$tmp .= "\n";
}
$tmp .= " ]\n";
}
else {
$tmp .= " \"species\": []\n";
}
$tmp .= " }";
push(@tmp, $tmp);
}
if ( $ws ) {
foreach my $item (@tmp) {
$item =~ s/^ *//o;
$item =~ s/,\n */, /go;
$item =~ s/\n *//go;
}
return @tmp;
}
else {
return ("[\n" . join(",\n", @tmp) . "\n]\n", 0);
}
}
sub passe2
{
my ($id, $ref_liste, $ref_para) = @_;
my @liste = @{$ref_liste};
my @para = @{$ref_para};
# Deuxième passe => fléche double
$fleche = '=>';
# Préparation de la table
my %tmp = ();
my @tmp1 = sort grep {not $tmp{$_} ++;} @liste;
my @tmp2 = ();
%tmp = ();
foreach my $item (@tmp1) {
my ($terme) = split(/\t/o, $item);
my ($genre) = $terme =~ /^(\P{IsWord}*\p{IsWord}.*?) .+/o ? $1 : $terme;
$genre = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $genre)));
$genre = lc($genre) if not $casse;
push(@tmp2, $genre);
if ( $liste{$genre} ) {
push(@tmp2, @{$liste{$genre}});
}
else {
push(@tmp2, grep(/^$genre\p{IsSpace}/, @table));
}
}
@tmp1 = sort grep {not $tmp{$_} ++;} @tmp2;
my %tmpPref = ();
my %tmpStr = ();
@tmp2 = ();
foreach my $terme (@tmp1) {
if ( $casse ) {
# my $str = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $terme)));
push(@tmp2, $terme);
if ( $str{$terme} ) {
$tmpStr{$terme} = $str{$terme};
}
else {
print STDERR "Pas de forme canonique pour \"$terme\"\n";
next;
}
if ( $terme =~ /^(\p{IsUpper})\P{IsSpace}+\p{IsSpace}+(.+)/o ) {
my $abrev = "$1. $2";
my $str = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $abrev)));
push(@tmp2, $str);
$tmpStr{$str} = $abrev;
if ( $tmpPref{$str} ) {
$tmpPref{$str} .= " ; $str{$terme}";
}
else {
$tmpPref{$str} = $str{$terme};
}
}
}
else {
# my $str = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, lc($terme))));
push(@tmp2, $terme);
if ( $str{$terme} ) {
$tmpStr{$terme} = $str{$terme};
# $tmpStr{$str} = $str{$terme} if $str ne $terme;
}
else {
print STDERR "Pas de forme canonique pour \"$terme\"\n";
next;
}
if ( $terme =~ /^(\p{IsLower})\P{IsSpace}+\p{IsSpace}+(.+)/o ) {
my $abrev = "$1. $2";
my $str = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, lc($abrev))));
push(@tmp2, $str);
$tmpStr{$str} = "\u$abrev";
if ( $tmpPref{$str} ) {
# $tmpPref{$str} .= " ; " . $str{$terme};
$tmpPref{$str} .= " ; " . $terme;
}
else {
# $tmpPref{$str} = $str{$terme};
$tmpPref{$str} = $terme;
}
}
}
}
%tmp = ();
@tmp1 = sort grep{not $tmp{$_} ++;} @tmp2;
@liste = ();
%tmp = ();
# On point sur les nouveaux hachages ...
$prefRef = \%tmpPref;
$strRef = \%tmpStr;
foreach my $para (@para) {
push(@liste, recherche($id, $para, \@tmp1));
}
# Traitement des ambigüités toujours présentes
@tmp1 = grep{not $tmp{$_} ++;} grep(/\t\?.+\?\z/, @liste);
if ( @tmp1 ) {
@tmp2 = grep(!/\t\?.+\?\z/, @liste);
foreach my $item (@tmp1) {
my ($t1, $t2, $t3) = split(/\t/, $item);
%tmp = ();
my @tmp3 = grep{not $tmp{$_} ++;} grep(/./, split(/\?/, $t3));
my %score = ();
foreach my $pref (@tmp3) {
$score{$pref} = grep(/$t1\t[^\t]+\t$pref\z/, @tmp2);
}
my @tmp = sort {$score{$b} <=> $score{$a}} grep {$score{$_} > 0;} keys %score;
if ( $#tmp == 0 ) {
foreach my $resultat (@liste) {
if ( $resultat eq $item ) {
$resultat = "$t1\t$t2\t$tmp[0]";
}
}
}
next if @tmp;
%score = ();
foreach my $pref (@tmp3) {
$score{$pref} = grep(/\t$pref\z/, @tmp2);
}
@tmp = sort {$score{$b} <=> $score{$a}} grep {$score{$_} > 0;} keys %score;
if ( $#tmp == 0 ) {
foreach my $resultat (@liste) {
if ( $resultat eq $item ) {
$resultat = "$t1\t$t2\t$tmp[0]";
}
}
next;
}
%tmp = ();
foreach my $pref (@tmp3) {
my ($genre) = $pref =~ /^(.+?) /o;
$tmp{$genre} ++;
}
for ( my $n = 1 ; $n <= $#liste ; $n ++ ) {
if ( $liste[$n] eq $item ) {
for ( my $m = $n ; $m >= 0 ; $m -- ) {
my ($terme) = $liste[$m] =~ /^(.+?)\s/o;
next if not $genre{$terme};
if ( $tmp{$terme} ) {
@tmp = grep(/^$terme /, @tmp3);
if ( $#tmp == 0 ) {
foreach my $resultat (@liste) {
if ( $resultat eq $item ) {
$resultat = "$t1\t$t2\t$tmp[0]";
}
}
}
}
}
}
}
}
}
# ... et retour aux hachages par défaut.
$prefRef = \%pref;
$strRef = \%str;
@tmp1 = ();
while( my $resultat = shift @liste ) {
my @champs = split(/\t/, $resultat);
next if $genre{$champs[0]};
if ( $champs[2] ) {
$resultat = "$champs[1]\t$champs[0]\t$champs[2]\t$pref{$champs[2]}";
}
else {
$resultat = "$champs[1]\t\t$champs[0]\t$pref{$champs[0]}";
}
print STDERR "\r", " " x 75, "\r" if not $quiet;
if ( $json ) {
push(@tmp1, $resultat);
}
else {
print "$id\t$resultat\n";
}
if ( $champs[2] ) {
if ( $champs[2] =~ /^\?.+\?\z/o and not $json ) {
print STDERR "ATTENTION ! $id : ambiguïté sur la forme non abrégée de “$champs[0]” !\n" if not $quiet;
print LOG "ATTENTION ! $id : ambiguïté sur la forme non abrégée de “$champs[0]” !\n";
}
else {
$tmp{$champs[2]} ++;
}
}
else {
$tmp{$champs[0]} ++;
}
}
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, $id;
return @tmp1 if $json;
}
sub recherche
{
my $cle = undef;
my $orig = undef;
my $tref = undef;
my $nbi = $nb;
($cle, $orig, $tref) = @_;
if ( not defined $tref ) {
$tref = \@table;
}
else {
$nbi = $#{$tref} + 1;
}
$orig =~ s/^\p{IsSpace}+//o;
$orig =~ s/\p{IsSpace}+\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, $tref, $nbi);
my $bout = join(" ", (grep(/\P{IsSpace}/, split(/( )/, $rec)))[0 .. 1] );
my $biniou = 1;
if ( $retour > -1 ) {
print STDERR "\r", " " x 75, "\r" if not $quiet;
$terme = $tref->[$retour];
my $tmp = $tref->[$retour];
$terme =~ s/(\P{IsWord})/\\$1/go;
$terme =~ s/\\ /\\s*/og;
$terme =~ s/([^\x20-\x7F])/./og;
if ( $orig =~ /^$terme\b/ or ( ! $casse and $orig =~ /^$terme\b/i ) ) {
my $chaine = $&;
if ( $chaine =~ /\p{IsUpper}/o ) {
push(@matchs, "$strRef->{$tmp}\t$chaine");
if ( defined $prefRef->{$tmp} ) {
if ( $prefRef->{$tmp} =~ / ; /o ) {
my @possibles = split(/ ; /, $prefRef->{$tmp});
my $probable = desambiguise(\@possibles, \@matchs);
if ( $probable ) {
$matchs[$#matchs] .= "\t$strRef->{$probable}";
}
else {
$probable = join('?', map {$strRef->{$_}} @possibles);
$matchs[$#matchs] .= "\t?$probable?";
}
}
else {
$matchs[$#matchs] .= "\t$strRef->{$prefRef->{$tmp}}";
}
}
}
}
else {
push(@matchs, "$strRef->{$tmp}\t*** ERREUR ***");
print STDERR "ERREUR (1) sur la recherche de l'original $cle\n";
}
if ( not $quiet and not $genre{$strRef->{$tmp}} ) {
# if ( not $quiet ) {
print STDERR "$cle $fleche $strRef->{$tmp}\n";
print STDERR " Traite le fichier $cle ";
}
}
else {
$retour = - 2 - $retour;
$terme = $tref->[$retour];
my ($debut) = $terme =~ m|^(.*?\p{IsWord}+)|;
$debut =~ s/(\P{IsWord})/\\$1/g;
if ( $debut and $rec =~ /^$debut\b/ ) {
do {
# print "$retour\t$debut\t$terme\t$bout\n";
$terme =~ s/(\P{IsWord})/\\$1/g;
if ( $rec =~ /^$terme\b/ ) { # Mot exact seulement
print STDERR "\r", " " x 75, "\r" if not $quiet;
$terme =~ s/\\ /\\p{IsSpace}*/og;
my $alt = $terme;
$alt =~ s/(\\?[^\x20-\x7F])/./og;
my $tmp = $tref->[$retour];
if ( $orig =~ /^$terme/ or ( not $casse and $orig =~ /^$terme/i ) ) {
my $chaine = $&;
if ( $chaine =~ /\p{IsUpper}/o ) {
push(@matchs, "$strRef->{$tmp}\t$chaine");
if ( defined $prefRef->{$tmp} ) {
if ( $prefRef->{$tmp} =~ / ; /o ) {
my @possibles = split(/ ; /, $prefRef->{$tmp});
my $probable = desambiguise(\@possibles, \@matchs);
if ( $probable ) {
$matchs[$#matchs] .= "\t$strRef->{$probable}";
}
else {
$probable = join('?', map {$strRef->{$_}} @possibles);
$matchs[$#matchs] .= "\t?$probable?";
}
}
else {
$matchs[$#matchs] .= "\t$strRef->{$prefRef->{$tmp}}";
}
}
}
}
elsif ( $orig =~ /^$alt/ or ( not $casse and $orig =~ /^$alt/i ) ) {
my $chaine = $&;
if ( $chaine =~ /\p{IsUpper}/o ) {
push(@matchs, "$strRef->{$tmp}\t$chaine");
if ( defined $prefRef->{$tmp} ) {
if ( $prefRef->{$tmp} =~ / ; /o ) {
my @possibles = split(/ ; /, $prefRef->{$tmp});
my $probable = desambiguise(\@possibles, \@matchs);
if ( $probable ) {
$matchs[$#matchs] .= "\t$strRef->{$probable}";
}
else {
$probable = join('?', map {$strRef->{$_}} @possibles);
$matchs[$#matchs] .= "\t?$probable?";
}
}
else {
$matchs[$#matchs] .= "\t$strRef->{$prefRef->{$tmp}}";
}
}
}
}
else {
push(@matchs, "$strRef->{$tmp}\t*** ERREUR ***");
print STDERR "ERREUR (2) sur la recherche de l'original $cle\n";
}
if ( not $quiet and not $genre{$strRef->{$tmp}} ) {
print STDERR "$cle $fleche $strRef->{$tmp}\n";
print STDERR " Traite le fichier $cle ";
}
$retour = 0;
}
if ( $retour > 0 ) {
$terme = $tref->[--$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{IsSpace}+\P{IsWord}\p{IsSpace}*/ ) {
$orig =~ s/^\p{IsSpace}+\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 desambiguise
{
my $ptrPossibles = shift;
my $ptrMatchs = shift;
return undef;
my @references = ();
foreach my $resultat (@resultats) {
my @tmp = split(/\t/, $resultat);
if ( $tmp[2] ) {
next if $tmp[2] =~ /^\?.+\?\z/o;
push(@references, $tmp[2]);
}
elsif ( $tmp[0] !~ /^\w\. /o ) {
push(@references, $tmp[0]);
}
}
foreach my $resultat (@{$ptrMatchs}) {
my @tmp = split(/\t/, $resultat);
if ( $tmp[2] ) {
next if $tmp[2] =~ /^\?.+\?\z/o;
push(@references, $tmp[2]);
}
elsif ( $tmp[0] !~ /^\w\. /o ) {
push(@references, $tmp[0]);
}
}
my %score = ();
my %tmp = ();
my @liste = grep {not $tmp{$_} ++;} reverse @references;
foreach my $possible (@{$ptrPossibles}) {
foreach my $item (@liste) {
if ( $item eq $str{$possible} ) {
$score{$possible} = 1 ;
}
}
}
my @tmp = sort keys %score;
if ( $#tmp == 0 ) {
return $tmp[0];
}
foreach my $item (@liste) {
my ($genre) = $item =~ /^(\S+) /o;
next if not $genre;
if ( not $casse ) {
$genre = lc($genre);
}
my ($possible) = grep(/^$genre /, @{$ptrPossibles});
return $possible if $possible;
}
}
sub nettoie
{
if ( $fifo and -p $fifo ) {
unlink $fifo;
}
if ( not $quiet ) {
print STDERR "\r", " " x 75, "\r";
print STDERR "\n";
}
exit 0;
}
besagni