#!/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.2"; 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 d’un nom de fichier ou de répertoire de fichiers textes, ce \n"; print " programme traite le texte envoyé 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; }