#!/usr/bin/perl
# Déclaration des pragmas
use strict;
use utf8;
use open qw/:std :utf8/;
# Appel des modules externes de base
use Encode;
use Getopt::Long;
# Appel des modules spécifiques à l'application
# ???
my ($programme) = $0 =~ m|^(?:.*/)?(.+)|;
my $version = "3.1.5";
my $dateModif = "26 Février 2021";
my $usage = "Usage : \n" .
" $programme -h hfd -a alignement -r rejet [ -l log ] [ -m matchStan ] \n" .
" $programme -f fichier -a alignement -r rejet [ -l log ] [ -m matchStan ] \n" .
" $programme -i \n";
my $alignement = undef;
my $fichier = undef;
my $hfd = undef;
my $info = undef;
my $log = undef;
my $rejet = undef;
my $matchStan = "matchStan2Istex_v12c.pl";
eval {
$SIG{__WARN__} = sub {usage(1);};
GetOptions(
"alignement=s" => \$alignement,
"fichier=s" => \$fichier,
"hfd=s" => \$hfd,
"info" => \$info,
"log=s" => \$log,
"rejet=s" => \$rejet,
"match=s" => \$matchStan,
);
};
$SIG{__WARN__} = sub {warn $_[0];};
if ( $info ) {
print "Programme : \n";
print " “$programme”, version $version ($dateModif)\n";
print " Permet de chercher les erreurs dans le fichier de résultats obtenu \n";
print " avec le programme “$matchStan” et de les corriger. \n";
print "\n";
print $usage;
print "\nOptions : \n";
print " -a indique le nom du fichier de résultats de l’alignement dont on doit \n";
print " corriger les erreurs \n";
print " -f indique le nom du fichier d’entrée contenant les notices Pascal ou Francis \n";
print " (qui peut être un fichier compressé avec “gzip” ou “bzip2”) \n";
print " -h indique le nom du fichier HFD servant d’entrée au programme \n";
print " -i affiche cette aide. \n";
print " -l indique le nom du fichier qui recevra, à la fois, le résultat avant et \n";
print " après lorsqu’une notice traitée donnera un résultat différent \n";
print " -m indique le nom du programme d’alignement si ce n'est pas celui par défaut \n";
print " -r indique le nom du fichier contenant les notices Pascal ou Francis ayant \n";
print " été modifiées parce que les notices originales ont provoqué une erreur \n";
print " \n";
print "N.B. : pour ne pas passer par le proxy sur le réseau interne de l’INIST, il faut \n";
print " effacer les variables globales du proxy par la commande “unset http_proxy \n";
print " https_proxy no_proxy” avant de lancer le programme “$programme”. \n";
print " \n";
exit 0;
}
usage(2) if not $alignement or not $rejet;
usage(2) if not $fichier and not $hfd;
usage(2) if $fichier and $hfd;
if ( $hfd and not -d $hfd ) {
print STDERR "Fichier HFD \"$hfd\" absent !\n";
exit(3);
}
# Variables
my $blancs = 0;
my $temp = "rEtmp$$.sgml";
my @lignes = ();
my %correct = ();
my %notice = ();
# Gestion des interruptions
$SIG{'HUP'} = 'nettoie';
$SIG{'INT'} = 'nettoie';
$SIG{'QUIT'} = 'nettoie';
$SIG{'TERM'} = 'nettoie';
if ( $rejet ) {
if ( -f $rejet ) {
open(INP, "<:raw", $rejet) or die "$!,";
while(<INP>) {
next if /^\s*$/o;
next if /^#/o;
my ($inist) = m|<fA47 dir=\d+><s0>(.+?)</s0></fA47>|o;
$correct{$inist} = $_;
}
close INP;
}
}
if ( defined $fichier ) {
if ( $fichier eq '-' ) {
open(REC, "<&STDIN") or die "$!,";
binmode(REC, ":raw");
}
elsif ( $fichier =~ /\.gz\z/o ) {
open(REC, "gzip -cd $fichier |") or die "$!,";
binmode(REC, ":raw");
}
elsif ( $fichier =~ /\.bz2\z/o ) {
open(REC, "bzip2 -cd $fichier |") or die "$!,";
binmode(REC, ":raw");
}
else {
open(REC, "<:raw", $fichier) or die "$!,";
}
}
elsif ( defined $hfd ) {
open(REC, "IhfdCat $hfd |") or die "$!,";
binmode(REC, ":raw");
}
my ($rec, $inist, $refaire) = suivant();
open(LOG, ">:utf8", $log) or die "$!,";
if ( $alignement =~ /\.gz\z/o ) {
open(INP, "gzip -cd $alignement |") or die "$!,";
binmode(INP, ":utf8");
}
elsif ( $alignement =~ /\.bz2\z/o ) {
open(INP, "bzip2 -cd $alignement |") or die "$!,";
binmode(INP, ":utf8");
}
else {
open(INP, "<:utf8", $alignement) or die "$!,";
}
while(<INP>) {
if ( /^\s*$/o ) {
$blancs ++;
if ( @lignes ) {
passe(@lignes);
@lignes = ();
print "\n";
}
else {
print $_ if $blancs == 1;
}
}
else {
push(@lignes, $_);
$blancs = 0;
}
}
close INP;
if ( @lignes ) {
passe(@lignes);
}
exit 0;
sub usage
{
print STDERR $usage;
exit shift;
}
sub suivant
{
my $ligne = <REC>;
if ( defined $ligne ) {
my ($id) = $ligne =~ m|<fA47 dir=\d+><s0>(.+?)</s0></fA47>|o;
if ( $correct{$id} ) {
$ligne = $correct{$id};
}
my $status = erreur($ligne);
return ($ligne, $id, $status);
}
return (undef, undef, undef);
}
sub erreur
{
my $ligne = shift;
if ( m|<fA20 dir=000000>(.+?)</fA20>|o ) {
my $champ = $1;
my $pages = "";
if ( $champ =~ m|<s1>(.+?)</s1>|o ) {
$pages = $1;
}
elsif ( $champ =~ m|<s2>(.+?)</s2>|o ) {
$pages = $1;
}
if ( $pages ) {
$pages =~ s|•|.|go;
$pages =~ s|−|-|go;
$pages =~ s|/|/|go;
$pages =~ s/^ +//o;
if ( $pages =~ /^(&\w+gr; )?vol\. *\S+?, */io or
$pages =~ /^(&\w+gr; )?vol \S+?, */io or
$pages =~ /^(&\w+gr; )?vol\d+, */io or
$pages =~ /^&\w+gr;,? */o ) {
$pages = $';
}
if ( $pages =~ / *[.+?(].*)?.*\z/io or
$pages =~ / +\d+ p\.].*/io ) {
$pages = $`;
}
if ( $pages =~ / *\(.+?\).*\z/io ) {
$pages = $`;
}
if ( $pages =~ /^([0ivx][ivx]*(-[ivx]+)?,? *([ivx]+(-[ivx]+)?,? *)*) (.+)\z/io ) {
$pages = $5;
}
if ( $pages =~ /^s\.p\.\s*\z/io ) {
return 0;
}
elsif ( $pages =~ /^(\d+)-(\d+) +p\./io ) {
return 0;
}
elsif ( $pages =~ /^\S+ +p\./io ) {
return 0;
}
elsif ( $pages =~ /^p\. *(\S+)\z/io ) {
return 0;
}
elsif ( $pages =~ /^(\S+-\S+)-(\S+-\S+)\z/o ) {
return 0;
}
elsif ( $pages =~ /^(\S+?)(-\S+)?,( *(\S+-)?(\S+),)* *(\S+-)?(\S+) *\z/o ) {
return 1;
}
}
}
return 0;
}
sub passe
{
my @liste = @_;
foreach my $ligne (@liste) {
if ( $ligne =~ /^[_0\.\*\+]+[^\t]*\t(\d+\.\d+\W?|-)\t[AMC]\t(\d+(-\d+)+)\t/o ) {
my $valeur = $1;
my $id = $2;
while ( $id ne $inist ) {
($rec, $inist, $refaire) = suivant();
}
if ( $valeur =~ /^\d+\.\d+\z/o ) {
$refaire ++ if $valeur <= 4.000 and $valeur >= 3.490;
}
$refaire ++ if grep(/^\t => ERREUR /o, @liste) > 0;
if ( $refaire ) {
open(TMP, ">:raw", $temp) or die "$!,";
print TMP $rec;
close TMP;
my $nb = 0;
my $ok = 0;
while( not $ok ) {
open(MSI, "$matchStan -f $temp |") or die "$!,";
binmode(MSI, ":utf8");
my @sortie = grep(/\S+/, <MSI>);
close MSI;
if ( grep(/^\t => ERREUR /o, @sortie) == 0 ) {
print @sortie;
compare($id, \@liste, \@sortie);
print STDERR "Notice \"$id\" modifiée \n";
return;
}
elsif ( grep(/^\t => ERREUR 400 /o, @sortie) > 0 ) {
print @liste;
compare($id, \@liste, \@sortie);
print STDERR "Notice \"$id\" erreur 400 !\n";
return;
}
else {
$nb ++;
if ( $nb >= 10 ) {
print STDERR "Problème notice \"$id\" !\n";
print @liste;
return;
}
}
}
die "Impossible de supprimer \"$temp\" : $!," if not unlink $temp;
}
else {
print @liste;
}
return;
}
}
print @liste;
}
sub compare
{
my ($id, $ref1, $ref2) = @_;
my @liste1 = @{$ref1};
my @liste2 = @{$ref2};
my ($score1, $score2) = (undef, undef);
print LOG "===> $id <=== \n";
foreach my $ligne (@liste1) {
if ( $ligne =~ /^[_0\.\*\+]+[^\t]*\t(\d+\.\d+\W?|-)\t[AMC]\t(\d+(-\d+)+)\t/o ) {
$score1 = $1
}
}
foreach my $ligne (@liste2) {
if ( $ligne =~ /^[_0\.\*\+]+[^\t]*\t(\d+\.\d+\W?|-)\t[AMC]\t(\d+(-\d+)+)\t/o ) {
$score2 = $1
}
}
if ($#liste1 != $#liste2 or $score1 ne $score2 ) {
print LOG @liste1;
print LOG "-------------------- \n";
print LOG @liste2;
}
print LOG "\n";
}
sub nettoye
{
my $signal = shift;
if ( fileno(TMP) ) {
close TMP;
}
if ( -f "$temp" ) {
die "Impossible de supprimer \"$temp\" : $!," if not unlink $temp;
}
if ( $signal =~ /^\d+\z/ ) {
exit $signal;
}
if ( $signal ) {
print STDERR "Signal SIG$signal détecté\n";
exit 9;
}
else {
exit 0;
}
}
besagni