#!/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 = "1.3.1"; my $dateModif = "12 Mars 2019"; my @table = (); my %genre = (); my %liste = (); 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 " 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 \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 { $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 =~ /^(.+?) /o; $genre{$genre} ++; if ( $casse ) { $str{$genre} = $genre if not $str{$genre}; } else { my $tmp = lc($genre); $str{$tmp} = $genre; $genre = $tmp; } push(@{$liste{$genre}}, $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 $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} ) { $str{$pref} = $str; my ($genre) = $str =~ /^(.+?) /o; $genre = lc($genre) if not $casse; push(@{$liste{$genre}}, $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" ; } 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 (sort @fichiers) { traite("$repertoire/$fichier"); } } else { traite('-'); } nettoye(); exit 0; sub usage { my $retour = shift; print STDERR $usage; exit $retour; } 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; } # Deuxième passe => fléche double $fleche = '=>'; # Préparation de la table my @tmp1 = sort grep {not $tmp{$_} ++;} @resultats; my @tmp2 = (); %tmp = (); foreach my $terme (@tmp1) { my ($mot) = split(/\p{IsSpace}+/o, $terme); $mot = lc($mot) if not $casse; push(@tmp2, $mot); if ( $liste{$mot} ) { push(@tmp2, @{$liste{$mot}}); } else { push(@tmp2, grep(/^$mot\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); $tmpStr{$str} = $terme; if ( $terme =~ /^(\p{IsUpper})\P{IsSpace}+\p{IsSpace}+(.+)/o ) { my $abrev = "$1. $2"; $str = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, $abrev))); push(@tmp2, $str); $tmpStr{$str} = $abrev; if ( $tmpPref{$str} ) { $tmpPref{$str} .= " ; $terme"; } else { $tmpPref{$str} = $terme; } } } else { my $str = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, lc($terme)))); push(@tmp2, $str); if ( $str{$terme} ) { $tmpStr{$terme} = $str{$terme}; $tmpStr{$str} = $str{$terme} if $str ne $terme; } if ( $terme =~ /^(\p{IsLower})\P{IsSpace}+\p{IsSpace}+(.+)/o ) { my $abrev = "$1. $2"; $str = join(" ", grep(/\P{IsSpace}/, split(/(\P{IsWord})/, lc($abrev)))); push(@tmp2, $str); $tmpStr{$str} = "\u$abrev"; if ( $tmpPref{$str} ) { $tmpPref{$str} .= " ; " . $terme; } else { $tmpPref{$str} = $terme; } } } } %tmp = (); @tmp1 = sort grep{not $tmp{$_} ++;} @tmp2; @resultats = (); %tmp = (); # On point sur les nouveaux hachages ... $prefRef = \%tmpPref; $strRef = \%tmpStr; foreach my $para (@para) { push(@resultats, recherche($nom, $para, \@tmp1)); } # Traitement des ambigüités toujours présentes @tmp1 = grep{not $tmp{$_} ++;} grep(/\t\?.+\?\z/, @resultats); if ( @tmp1 ) { @tmp2 = grep(!/\t\?.+\?\z/, @resultats); 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 (@resultats) { 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 (@resultats) { 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 <= $#resultats ; $n ++ ) { if ( $resultats[$n] eq $item ) { for ( my $m = $n ; $m >= 0 ; $m -- ) { my ($terme) = $resultats[$m] =~ /^(.+?)\s/o; next if not $genre{$terme}; if ( $tmp{$terme} ) { @tmp = grep(/^$terme /, @tmp3); if ( $#tmp == 0 ) { foreach my $resultat (@resultats) { if ( $resultat eq $item ) { $resultat = "$t1\t$t2\t$tmp[0]"; } } } } } } } } } # ... et retour aux hachages par défaut. $prefRef = \%pref; $strRef = \%str; while( my $resultat = shift @resultats ) { my @champs = split(/\t/, $resultat); next if $genre{$champs[0]}; print STDERR "\r", " " x 75, "\r"; print "$nom\t$resultat\n"; if ( $champs[2] ) { if ( $champs[2] =~ /^\?.+\?\z/o ) { print STDERR "ATTENTION ! $nom : ambiguïté sur la forme non abrégée de “$champs[0]” !\n"; print LOG "ATTENTION ! $nom : 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, $nom; } 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); if ( $retour > -1 ) { print STDERR "\r", " " x 75, "\r" if not $quiet; $terme = $tref->[$retour]; my $tmp = $tref->[$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 ) ) { 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; do { $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; $terme =~ s/([^\x20-\x7F])/./og; my $tmp = $tref->[$retour]; if ( $orig =~ /^$terme/ or ( ! $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}}"; } } } } 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}} ) { # if ( not $quiet ) { 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 nettoye { if ( not $quiet ) { print STDERR "\r", " " x 75, "\r"; print STDERR "\n"; } exit 0; }