#!/usr/bin/perl
# Déclaration des pragmas
use strict;
use utf8;
use open qw/:std :utf8/;
# Pragmas servant à détecter les variables et fonctions inutilisés,
# ce qui n’a d’intérêt qu’à l’écriture du script.
## use warnings::unused;
## use warnings 'once';
# Appel des modules externes de base
use Encode;
use Getopt::Long;
my ($programme) = $0 =~ m|^(?:.*/)?(.+)|;
my $Version = "1.4.4";
my $dateModif = "25 Octobre 2022";
my $usage = "Usage : \n" .
" $programme -f fichier [ -l log ] [ -c fichier_correct ] [ -b ]\n" .
" $programme -h \n";
my $aide = undef;
my $bom = undef;
my $corrige = undef;
my $fichier = undef;
my $log = undef;
eval {
$SIG{__WARN__} = sub {usage(1);};
GetOptions(
"bom" => \$bom,
"corrige=s" => \$corrige,
"fichier=s" => \$fichier,
"help" => \$aide,
"log=s" => \$log,
);
};
$SIG{__WARN__} = sub {warn $_[0];};
if ( $aide ) {
print " \n";
print "Programme : \n";
print " “$programme”, version $Version ($dateModif)\n";
print " Permet de vérifier que les caractères du texte sont bien codés \n";
print " en UTF-8 et sont considérés comme valides \n";
print "\n";
print $usage;
print "\nOptions : \n";
print " -b ajoute le BOM (Byte Order Mark) au début du fichier de sortie (ce qui \n";
print " n’a de sens qu’en présence de l’option “-c”) \n";
print " -c indique le nom du fichier de sortie avec la version corrigée du texte \n";
print " -f indique le nom du fichier d’entrée \n";
print " -h affiche cette aide \n";
print " -l indique le nom du fichier “log” qui recevra une liste de tous les \n";
print " caractères invalides ou interdits avec leur position dans le texte \n";
print " \nCode de retour : \n";
print " Si tous les caractères du fichier testé sont valides, le programme renvoie \n";
print " le code de retour 0 (zéro). Sinon, le programme renvoie le code 1 en cas \n";
print " d’erreur dans les options, le code 2 si le fichier contient des caractères \n";
print " pouvant poser problème suivant le contexte et le code 3 si le fichier contient \n";
print " des caractères interdits ou mal-formés \n";
print " \nFichier corrigé : \n";
print " Les caractères erronés sont remplacés dans la mesure du possible. Dans le cas \n";
print " des jeux de caractères ISO 8859-1 (ISO latin-1) et ISO 8859-15 (ISO latin-15), \n";
print " comme il n’est pas facile de savoir à quelle norme appartient un caractère, \n";
print " on suppose, par défaut, qu‘il s‘agit de l‘ISO 8859-15. Autrement, chaque \n";
print " caractère inconnu sera remplacé par le caractère “\x{FFFD}”. \n";
print "\n";
exit 0;
}
usage(1) if not $fichier;
# Variables
my $ligne = undef;
my $niveau = undef;
my $octets = undef;
my $position = undef;
my @erreurs = ();
# Expressions régulières pour les caractères multi-octets corrects
my $mo2 = qr/([\xC2-\xDF][\x80-\xBF])/o;
my $mo3 = qr/(\xE0[\xA0-\xBF][\x80-\xBF]|[\xE1-\xEF][\x80-\xBF]{2})/o;
my $mo4 = qr/(\xF0[\x90-\xBF][\x80-\xBF]{2}|[\xF1-\xF3][\x80-\xBF]{3}|\xF4[\x80-\x8F][\x80-\xBF]{2})/o;
# Caractères CP 1252
my %winlat = (
128 => "E2 82 AC",
130 => "E2 80 1A",
131 => "C6 92",
132 => "E2 80 9E",
133 => "E2 80 A6",
134 => "E2 80 A0",
135 => "E2 80 A1",
136 => "CB 86",
137 => "E2 80 B0",
138 => "C5 A0",
139 => "E0 80 B9",
140 => "C5 92",
142 => "C5 BD",
145 => "E2 80 98",
146 => "E2 80 99",
147 => "E2 80 9C",
148 => "E2 80 9D",
149 => "E2 80 A2",
150 => "E2 80 93",
151 => "E2 80 94",
152 => "CB 9C",
153 => "E2 84 A2",
154 => "C5 A1",
155 => "E2 80 BA",
156 => "C5 93",
158 => "C5 BE",
159 => "C5 B8",
);
# Caractères ISO 8859-15
my %lat9 = (
164 => "E2 82 AC",
166 => "C5 A0",
168 => "C5 A1",
180 => "C5 BD",
184 => "C5 BE",
188 => "C5 92",
189 => "C5 93",
190 => "C5 B8",
);
if ( $log ) {
open(LOG, ">>:utf8", $log) or die "$!,";
print LOG "==> $fichier <== \n";
}
else {
open(LOG, ">:utf8", "/dev/null") or die "$!,";
}
if ( $corrige ) {
open(OUT, ">:raw", $corrige) or die "$!,";
if ( $bom ) {
print OUT "\xEF\xBB\xBF";
}
}
else {
open(OUT, ">:raw", "/dev/null") or die "$!,";
}
select OUT;
open(INP, "<:raw", $fichier) or die "$!,";
while($octets = <INP>) {
my $tmp = $octets;
$ligne ++;
$position = 1;
# Vérification des caractères UTF-8 surencodés
## while ( $tmp =~ /(($mo2|$mo3|$mo4){2,})/go ) {
while ( $tmp ) {
if ( $tmp =~ /^(($mo2|$mo3|$mo4){2,})/go ) {
my $chaine = $&;
## $position = pos($tmp) - length($chaine) + 1;
my %occurrences = reduit($chaine, $position);
if ( %occurrences ) {
foreach my $pos (sort {$a <=> $b} keys %occurrences) {
push(@erreurs, $occurrences{$pos}{'erreur'});
print LOG " - $occurrences{$pos}{'erreur'} [ligne $ligne, octet $pos, caractère $occurrences{$pos}{'poscar'}]\n";
print pack("C*", map {hex($_);} split(/ +/, $occurrences{$pos}{'correct'}));
##
## Autre méthode, plus simple.
##
# foreach my $code (split(/ +/, $occurrences{$pos}{'correct'})) {
# print chr(hex($code));
# }
if ( defined $occurrences{$pos}{'taille'} ) {
$tmp = substr($tmp, $occurrences{$pos}{'taille'});
$position += $occurrences{$pos}{'taille'};
last;
}
else {
die "Erreur quelque part,";
}
}
}
}
# then what?
# Vérification de la syntaxe des caractères UTF-8
## $tmp = $octets;
## $position = 1;
## while ( $tmp ) {
if ( $tmp =~ /^[\0-\x7F]+/o ) {
my $chaine = $&;
$tmp = substr($tmp, length($chaine));
while ($chaine =~ /([\0-\x08\x0B\x0C\x0E-\x1F\x7F])/go) {
my $hexa = sprintf("x%02X", ord($1));
my $pos = pos($chaine);
push(@erreurs, "Caractère de contrôle \'$hexa\'");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet ", $position + $pos - 1, ", caractère $poscar]\n";
}
$position += length($chaine);
$chaine =~ s/[\0-\x08\x0B\x0C\x0E-\x1F\x7F]/\xEF\xBF\xBD/go;
print $chaine;
next;
}
# elsif ( $tmp =~ /^(($mo2|$mo3|$mo4){2,})/o ) {
# my $chaine = $1;
# # my $nouveau = undef;
# my $nouveau = reduit($chaine, $position);
# if ( defined $nouveau ) {
#
# # $position += length($chaine);
# }
# }
elsif ( $tmp =~ /^([\xC2-\xDF])([\x80-\xBF])/o ) {
my $oct1 = $1;
my $oct2 = $2;
$tmp = substr($tmp, 2);
my $val = ((ord($oct1) & 31) * 64) + (ord($oct2) & 63);
if ( $val >= 128 and $val <= 159 ) {
if ( $val == 129 or $val == 141 or
$val == 143 or $val == 144 or
$val == 157 ) {
my $hexa = sprintf("0x%04X", $val);
push(@erreurs, "Caractère interdit \'$hexa\'");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
}
else {
my $hexa = sprintf("0x%04X", $val);
if ( $winlat{$val} ) {
my $winlat = pack("C*", map {hex($_);} split(/ +/, $winlat{$val}));
push(@erreurs, "Caractère interdit \'$hexa\' (CP 1252 \'".decode_utf8($winlat)."\' ?)");
print $winlat;
}
else {
push(@erreurs, "Caractère interdit \'$hexa\' (CP 1252 ?)");
print "\xEF\xBF\xBD";
}
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n"
}
}
else {
print "$oct1$oct2";
}
$position += 2;
}
elsif ( $tmp =~ /^(\xED[\xA0-\xAF][\x80-\xBF]\xED[\xB0-\xBF][\x80-\xBF])/o ) {
my @octets = split(//, $1);
my $haut = (((ord($octets[0]) & 15) * 64) + (ord($octets[1]) & 63)) *64 + (ord($octets[2]) & 63);
my $bas = (((ord($octets[3]) & 15) * 64) + (ord($octets[4]) & 63)) *64 + (ord($octets[5]) & 63);
my $val = 65536 + (($haut - 55296) * 1024) + ($bas - 56320);
$tmp = substr($tmp, 6);
$haut = sprintf("0x%04X", $haut);
$bas = sprintf("0x%04X", $bas);
my $hexa = sprintf("0x%04X", $val);
push(@erreurs, "Séquence interdite \'$haut $bas\' (code UTF-16 pour \'$hexa\')");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
$position += 6;
}
elsif ( $tmp =~ /^(\xE0)([\xA0-\xBF])([\x80-\xBF])/o or
$tmp =~ /^([\xE1-\xEF])([\x80-\xBF])([\x80-\xBF])/o ) {
my $oct1 = $1;
my $oct2 = $2;
my $oct3 = $3;
$tmp = substr($tmp, 3);
my $utf8 = $oct1 . $oct2 . $oct3;
my $val = (((ord($oct1) & 15) * 64) + (ord($oct2) & 63)) * 64 + (ord($oct3) & 63);
if ( $val >= 55296 and $val <= 57343 ) {
my $hexa = sprintf("0x%04X", $val);
push(@erreurs, "Caractère interdit \'$hexa\' (demi-codet)");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
}
elsif ( $val >= 57344 and $val <= 63743 ) {
my $hexa = sprintf("0x%04X", $val);
push(@erreurs, "Caractère d’usage privé \'$hexa\'");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
}
elsif ( ( $val >= 64976 and $val <= 65007 ) or
$val == 65534 or $val == 65535 ) {
my $hexa = sprintf("0x%04X", $val);
push(@erreurs, "Non caractère \'$hexa\'");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
}
else {
print $utf8;
}
$position += 3;
}
elsif ( $tmp =~ /^(\xF0)([\x90-\xBF])([\x80-\xBF])([\x80-\xBF])/o or
$tmp =~ /^([\xF1-\xF3])([\x80-\xBF])([\x80-\xBF])([\x80-\xBF])/o or
$tmp =~ /^(\xF4)([\x80-\x8F])([\x80-\xBF])([\x80-\xBF])/o ) {
my $oct1 = $1;
my $oct2 = $2;
my $oct3 = $3;
my $oct4 = $4;
$tmp = substr($tmp, 4);
my $utf8 = $oct1 . $oct2 . $oct3 . $oct4;
my $val = ((((ord($oct1) & 7) * 64) + (ord($oct2) & 63)) * 64 + (ord($oct3) & 63)) * 64 + (ord($oct4) & 63);
if ( $val == 131070 or $val == 131071 or $val == 196606 or $val == 196607 ) {
my $hexa = sprintf("0x%06X", $val);
push(@erreurs, "Non caractère \'$hexa\'");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
}
elsif ( $val >= 196608 and $val <= 917503 ) {
my $hexa = sprintf("0x%06X", $val);
push(@erreurs, "Caractère interdit \'$hexa\' (plans réservés non attribués)");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
}
elsif ( $val >= 917504 and $val <= 983037 ) {
my $hexa = sprintf("0x%06X", $val);
push(@erreurs, "Caractère spécial \'$hexa\'");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
}
elsif ( $val == 983038 and $val == 983039 ) {
my $hexa = sprintf("0x%06X", $val);
push(@erreurs, "Non caractère \'$hexa\'");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
}
elsif ( $val >= 983040 and $val <= 1048573 ) {
my $hexa = sprintf("0x%06X", $val);
push(@erreurs, "Caractère d’usage privé \'$hexa\'");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
}
elsif ( $val == 1048574 and $val == 1048575 ) {
my $hexa = sprintf("0x%06X", $val);
push(@erreurs, "Non caractère \'$hexa\'");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
}
elsif ( $val >= 1048576 and $val <= 1114109 ) {
my $hexa = sprintf("0x%06X", $val);
push(@erreurs, "Caractère d’usage privé \'$hexa\'");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
}
elsif ( $val == 1114110 and $val == 1114111 ) {
my $hexa = sprintf("0x%06X", $val);
push(@erreurs, "Non caractère \'$hexa\'");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
}
else {
print $utf8;
}
$position += 4;
}
elsif ( $tmp =~ /^([\xC0-\xDF][\x80-\xBF])/o or
$tmp =~ /^([\xE0-\xEF][\x80-\xBF][\x80-\xBF])/o or
$tmp =~ /^([\xF0-\xF7][\x80-\xBF][\x80-\xBF][\x80-\xBF])/o ) {
$tmp = $';
my $taille = length($1);
my $sequence = join(" ", map {sprintf("x%02X", ord($_));} split(//, $1));
push(@erreurs, "Séquence interdite \'$sequence\'");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
$position += $taille;
}
elsif ( $tmp =~ /^([\xF8-\xFB][\x80-\xBF]{4})/o or
$tmp =~ /^([\xFC-\xFD][\x80-\xBF]{5})/o or
$tmp =~ /^(\xFE[\x80-\xBF]{6})/o or
$tmp =~ /^(\xFF[\x80-\xBF]{7})/o ) {
$tmp = $';
my $taille = length($1);
my $sequence = join(" ", map {sprintf("x%02X", ord($_));} split(//, $1));
push(@erreurs, "Séquence interdite \'$sequence\'");
my $poscar = position($octets, $position);
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print "\xEF\xBF\xBD";
$position += $taille;
}
else {
my $val = ord(substr($tmp, 0, 1));
my $hexa = sprintf("x%02X", $val);
$tmp = substr($tmp, 1);
my $latin1 = chr(hex($hexa));
my $poscar = position($octets, $position);
if ( $winlat{$val} ) {
my $winlat = pack("C*", map {hex($_);} split(/ +/, $winlat{$val}));
push(@erreurs, "Caractère interdit \'$hexa\' (CP 1252 \'". decode_utf8($winlat)."\' ?)");
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print $winlat;
}
elsif ( $lat9{$val} ) {
my $lat9 = pack("C*", map {hex($_);} split(/ +/, $lat9{$val}));
push(@erreurs, "Caractère interdit \'$hexa\' (ISO 8859-15 \'".decode_utf8($lat9)."\' ou ISO 8859-1 \'$latin1\' ?)");
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
print $lat9;
}
else {
push(@erreurs, "Caractère interdit \'$hexa\' (ISO 8859-1 \'$latin1\' ?)");
print LOG " - $erreurs[$#erreurs] [ligne $ligne, octet $position, caractère $poscar]\n";
my $octet1 = ($val >> 6) + 192;
my $octet2 = ($val & 63) + 128;
$latin1 = pack("C*", ($octet1, $octet2));
print $latin1;
}
$position += 1;
}
}
}
close INP;
close OUT;
if ( @erreurs ) {
print STDERR "\n ==> $fichier <== \n";
print LOG " \n";
my @mortel = ();
my @veniel = ();
my %nb = ();
foreach my $erreur (@erreurs) {
if ( $erreur =~ /\binterdite?\b/o ) {
push(@mortel, $erreur);
$nb{$erreur}++;
}
else {
push(@veniel, $erreur);
$nb{$erreur}++;
}
}
if ( @mortel ) {
print STDERR " Erreur", $#mortel == 0 ? "": "s", " : \n";
}
foreach my $erreur (@mortel) {
if ( $nb{$erreur} ) {
print STDERR "\t$erreur";
print STDERR " ($nb{$erreur} occurrences)" if $nb{$erreur} > 1;
print STDERR "\n";
delete $nb{$erreur};
}
}
if ( @veniel ) {
print STDERR " Avertissement", $#mortel == 0 ? "": "s", " : \n";
}
foreach my $erreur (@veniel) {
if ( $nb{$erreur} ) {
print STDERR "\t$erreur";
print STDERR " ($nb{$erreur} occurrences)" if $nb{$erreur} > 1;
print STDERR "\n";
delete $nb{$erreur};
}
}
if ( @mortel ) {
exit 3;
}
else {
exit 2;
}
}
exit 0;
sub usage
{
print STDERR "\n$usage\n";
exit shift;
}
sub position
{
my ($chaine, $position) = @_;
my $portion = join("", (split(//, $chaine))[0 .. $position - 1]);
my $utf8 = undef;
eval {
$utf8 = decode("UTF-8", $portion, Encode::FB_DEFAULT);
};
return length($utf8);
}
sub reduit
{
my $chaine = shift;
my $position = shift;
my $debut = 0;
my $fin = 0;
my $num = undef;
my $nouveau = undef;
my $offset = 0;
my $original = $position;
my @octets = split(//, $chaine);
my @val = ();
my %retour = ();
$niveau ++;
for ( my $nb = 0 ; $nb <= $#octets ; $nb ++ ) {
my $val = undef;
if ( $octets[$nb] =~ /^[\xC2-\xDF]/o ) {
$val = ((ord($octets[$nb]) & 31) * 64) + (ord($octets[$nb + 1]) & 63);
# $nouveau .= pack("C", $val);
# 1100 0011 1000 0011 1100 0010 1010 1001 = C3 83 C2 A9 = 195 131 194 169
# -> 00011 000011 00010 101001 = C3 A9 = 195 169
# -> 11000011 10101001
#
$nb ++;
}
elsif ( $octets[$nb] =~ /^[\xE0-\xEF]/o ) {
$val = (((ord($octets[$nb]) & 15) * 64) + (ord($octets[$nb + 1]) & 63)) * 64 +
(ord($octets[$nb + 2]) & 63);
$nb += 2;
}
elsif ( $octets[$nb] =~ /^[\xF0-\xF4]/o ) {
$val = ((((ord($octets[$nb]) & 7) * 64) + (ord($octets[$nb + 1]) & 63)) * 64 +
(ord($octets[$nb + 2]) & 63)) * 64 + (ord($octets[$nb + 3]) & 63);
$nb += 3;
}
else {
die "Cas inattendu,";
}
# $fin = $nb;
if ( $num == 0 ) {
if ( $val >= 194 and $val <= 223 ) {
$num = 2;
}
elsif ( $val >= 224 and $val <= 239 ) {
$num = 3;
}
elsif ( $val >= 240 and $val <= 244 ) {
$num = 4;
}
else {
$position = $original + $debut;
if ( $nouveau ) {
my $courant = $niveau;
my $correct = join(" ", map {sprintf("x%02X", ord($_));} split(//, $nouveau));
my $reel = undef;
if ( $nouveau =~ /^(\p{IsPrint})+\z/o ) {
$reel = decode_utf8($nouveau);
}
while ( $nouveau =~ /(($mo2|$mo3|$mo4){2,})/go ) {
my $long = length($&);
my $pos = pos($nouveau);
my %tmp = reduit($nouveau, $position);
if ( %tmp ) {
$correct = $tmp{$position}{'correct'};
$courant = $tmp{$position}{'niveau'};
$reel = $tmp{$position}{'reel'};
}
}
my $sequence = join(" ", map {sprintf("x%02X", ord($_));} @octets[$debut .. $fin]);
my $taille = $fin - $debut + 1;
my $erreur = "Caractère UTF-8 surencodé ";
if ( $courant > 1 ) {
$erreur .= "$courant fois ";
}
$erreur .= "\'$sequence\' (au lieu de \'$correct\'";
if ( defined $reel ) {
$erreur .= " = \'$reel\'";
}
$erreur .= ")";
my $poscar = position($octets, $position);
$retour{$position}{'sequence'} = $sequence;
$retour{$position}{'taille'} = $taille;
$retour{$position}{'correct'} = $correct;
$retour{$position}{'niveau'} = $courant;
$retour{$position}{'poscar'} = $poscar;
$retour{$position}{'erreur'} = $erreur;
$retour{$position}{'reel'} = $reel;
## $nouveau = undef;
}
## $debut = $nb + 1;
## @val = ();
## next;
$niveau --;
return %retour;
}
push(@val, $val);
}
else {
push(@val, $val);
if ( $#val + 1 == $num ) {
my $utf8 = pack("C*", @val);
if ( $utf8 =~ /^($mo2|$mo3|$mo4)\z/o ) {
$nouveau .= $utf8;
$fin = $nb;
}
## elsif ( $utf8 =~ /(($mo2|$mo3|$mo4)+)/o ) {
else {
$position = $original + $debut;
if ( $nouveau ) {
my $courant = $niveau;
my $correct = join(" ", map {sprintf("x%02X", ord($_));} split(//, $nouveau));
my $reel = undef;
if ( $nouveau =~ /^(\p{IsPrint})+\z/o ) {
$reel = decode_utf8($nouveau);
}
while ( $nouveau =~ /(($mo2|$mo3|$mo4){2,})/go ) {
my $long = length($&);
my $pos = pos($nouveau);
my %tmp = reduit($nouveau, $position);
if ( %tmp ) {
$correct = $tmp{$position}{'correct'};
$courant = $tmp{$position}{'niveau'};
$reel = $tmp{$position}{'reel'};
}
}
my $sequence = join(" ", map {sprintf("x%02X", ord($_));} @octets[$debut .. $fin]);
my $taille = $fin - $debut + 1;
my $erreur = "Caractère UTF-8 surencodé ";
if ( $courant > 1 ) {
$erreur .= "$courant fois ";
}
$erreur .= "\'$sequence\' (au lieu de \'$correct\'";
if ( defined $reel ) {
$erreur .= " = \'$reel\'";
}
$erreur .= ")";
my $poscar = position($octets, $position);
$retour{$position}{'sequence'} = $sequence;
$retour{$position}{'taille'} = $taille;
$retour{$position}{'correct'} = $correct;
$retour{$position}{'niveau'} = $courant;
$retour{$position}{'poscar'} = $poscar;
$retour{$position}{'erreur'} = $erreur;
$retour{$position}{'reel'} = $reel;
$nouveau = undef;
}
## $fin ++;
## if ( $octets[$fin] =~ /^[\xC2-\xDF]/o ) {
## $nb = $fin + 1;
## $debut = $fin + 2;
## }
## elsif ( $octets[$fin] =~ /^[\xE0-\xEF]/o ) {
## $nb = $fin + 2;
## $debut = $fin + 3;
## }
## elsif ( $octets[$fin] =~ /^[\xF0-\xF4]/o ) {
## $nb = $fin + 3;
## $debut =$fin + 4;
## }
## $fin = $nb;
$niveau --;
return %retour;
}
## else {
## my $biniou ++;
## }
@val = ();
$num = 0;
}
}
}
if ( $nouveau ) {
$position = $original + $debut;
my $courant = $niveau;
my $correct = join(" ", map {sprintf("x%02X", ord($_));} split(//, $nouveau));
my $reel = undef;
if ( $nouveau =~ /^(\p{IsPrint})+\z/o ) {
$reel = decode_utf8($nouveau);
}
while ( $nouveau =~ /(($mo2|$mo3|$mo4){2,})/go ) {
my $long = length($&);
my $pos = pos($nouveau);
my %tmp = reduit($nouveau, $position);
if ( %tmp ) {
$correct = $tmp{$position}{'correct'};
$courant = $tmp{$position}{'niveau'};
$reel = $tmp{$position}{'reel'};
}
}
my $sequence = join(" ", map {sprintf("x%02X", ord($_));} @octets[$debut .. $fin]);
my $taille = $fin - $debut + 1;
my $erreur = "Caractère UTF-8 surencodé ";
if ( $courant > 1 ) {
$erreur .= "$courant fois ";
}
$erreur .= "\'$sequence\' (au lieu de \'$correct\'";
if ( defined $reel ) {
$erreur .= " = \'$reel\'";
}
$erreur .= ")";
my $poscar = position($octets, $position);
$retour{$position}{'sequence'} = $sequence;
$retour{$position}{'taille'} = $taille;
$retour{$position}{'correct'} = $correct;
$retour{$position}{'niveau'} = $courant;
$retour{$position}{'poscar'} = $poscar;
$retour{$position}{'erreur'} = $erreur;
$retour{$position}{'reel'} = $reel;
}
$niveau --;
return %retour;
}
sub est_valide
{
;
}
besagni