[ LUGOS ] Recode
Ales Kosir
ales.kosir na hermes.si
Pet Maj 26 16:57:31 CEST 2000
Nekoc sem nekaj takega ze poskusal na precej okoren nacin. Na svojem disku sem
nasel datoteko guess, ki jo lahko preskusis in morda predelas. Pozenes
jo takole
guess [imena datotek]
Program pa izpisuje, kaj je po njegovem razpored v neki datoteki.
Odloca se glede na frekvenco znakov, kjer so sumniki v razlicnih
razporedih.
Lep pozdrav,
Ales
#!/usr/local/bin/perl
#
# Ales Kosir, 7.9.1996
#
# Usage:
#
# guess [files]
#
# guess is part of the language spelling check and conversion
# It guesses the encoding of slovene characters.
#
#--------------
#
# $Author: roman $
# $Header: /home/lugrep/www/arhiv/mailinglist/052000/503.html,v 1.1 2001/07/08 20:51:37 roman Exp $
#
# Revision History:
#
# $Log: 503.html,v $
# Revision 1.1 2001/07/08 20:51:37 roman
# iz ro
#
# Revision 1.4 1996/11/27 07:27:42 kosir
# Manjsi popravki, javna izdaja.
#
# TODO:
# + tezave s TeX123 in YUSCII.
# - v algoritem odlocanja dodaj se YUSCII.
#
#--------------
#
# "C ¬ 172 AC Č 200 C8 Č 200 C8 ^ 94 5E "C \v{C} È
# "c 159 9F č 232 E8 č 232 E8 ~ 126 7E "c \v{c} è
# "S ę 230 E6 138 8A © 169 A9 [ 91 5B "S \v{S} ©
# "s ē 231 E7 154 9A ¹ 185 B9 { 123 7B "s \v{s} ¹
# "Z ¦ 166 A6 142 8E ® 174 AE @ 64 40 "Z \v{Z} ®
# "z § 167 A7 158 9E ¾ 190 BE ` 96 60 "z \v{z} ¾
#
$maxlin = 100; # najvec koliko vrstic pregledam
$verbose = 0; # ali izpisujem sproti, kaj pocnem
$debug = 0; # ali izpisujem sproti, kaj pocnem (zelo podrobno)
$showsort = 0; # ali na koncu izpisem kodiranja urejena po stevilu znakov
$showboth = 0; # ali na koncu izpisem dva najpogostejsa nabora
# ce je Latin1 kodiranje z najvecjim stevilom znakov, potem:
$fraccnt = 0.1; # najmanj koliksen delez Latin1 mora imeti
# naslednji, ce naj bo upostevan kot najbolj verjeten
$mincnt = 2; # najmanj koliko ustreznih znakov mora imeti
# naslednji, ce naj bo upostevan kot najbolj verjeten
%enc_CP852 =
(
'Č', '¬',
'č', '',
'©', 'ę',
'¹', 'ē',
'®', '¦',
'¾', '§'
);
%enc_CP1250 =
(
'Č', '¬',
'č', 'č',
'©', '',
'¹', '',
'®', '',
'¾', ''
);
%enc_LATIN1 =
(
'Č', 'C',
'č', 'c',
'©', 'S',
'¹', 's',
'®', 'Z',
'¾', 'z'
);
%enc_LATIN2 =
(
'Č', 'Č',
'č', 'č',
'©', '©',
'¹', '¹',
'®', '®',
'¾', '¾'
);
%enc_YUSCII =
(
'Č', '^',
'č', '~',
'©', '[',
'¹', '{',
'®', '@',
'¾', '`'
);
%enc_babel =
(
'Č', '"C',
'č', '"c',
'©', '"S',
'¹', '"s',
'®', '"Z',
'¾', '"z'
);
%enc_TeX =
(
'Č', '\v{C}',
'č', '\v{c}',
'©', '\v{S}',
'¹', '\v{s}',
'®', '\v{Z}',
'¾', '\v{z}'
);
%enc_TeX123 =
(
'Č', '\2',
'č', '\1',
'©', '\4',
'¹', '\3',
'®', '\6',
'¾', '\5'
);
%enc_HTML =
(
'Č', 'È',
'č', 'è',
'©', '©',
'¹', '¹',
'®', '®',
'¾', '¾'
);
@encoding_names =
(
'CP852',
'CP1250',
'LATIN1',
'LATIN2',
# 'YUSCII',
'babel',
'TeX',
'TeX123',
'HTML'
); _01
sub encoding {
#
# Podprogram encoding (enc_name, extra_char) vrne znakovno predstavitev
# znaka extra_char v naboru enc_name. Extra_char je kodiran v latin2.
# Primer:
# encoding ("TeX", "č") vrne \v{C}
#
# Na ta nacin naredim dvorazsezno tabelo skalarnih vrednosti,
# ker starejse verzije perla vecrazseznih tabel neposredno ne podpirajo.
#
if ($_[0] eq 'CP852' ) { return $enc_CP852 {$_[1]}; }
elsif ($_[0] eq 'CP1250') { return $enc_CP1250 {$_[1]}; }
elsif ($_[0] eq 'LATIN1') { return $enc_LATIN1 {$_[1]}; }
elsif ($_[0] eq 'LATIN2') { return $enc_LATIN2 {$_[1]}; }
elsif ($_[0] eq 'YUSCII' ){ return $enc_YUSCII {$_[1]}; }
elsif ($_[0] eq 'babel' ) { return $enc_babel {$_[1]}; }
elsif ($_[0] eq 'TeX' ) { return $enc_TeX {$_[1]}; }
elsif ($_[0] eq 'TeX123') { return $enc_TeX123 {$_[1]}; }
elsif ($_[0] eq 'HTML' ) { return $enc_HTML {$_[1]}; }
else { $!=-2; die "Internal error in subroutine encoding ($_[0], $_[1]).\n"; }
}
#
# Enkrat za vselej pripravi seznam dodatnih znakov, kodiranih po LATIN2.
#
@extra_chars = keys (%enc_LATIN2);
#
# Prikazi te dodatne znake
#
if ($debug) {
print "Extra characters: ", @extra_chars, "\n";
print "Encodings: ";
foreach $encoding (@encoding_names) {
print $encoding, " ";
}
print "\n";
}
#
# Kot test izpisi znak "C v razlicnih naborih
#
if ($debug) {
print "Character \"C in all encodings:\n";
foreach $encoding_name (@encoding_names) {
print "In ", $encoding_name, " encoding is represented by ",
&encoding($encoding_name, 'Č'), "\n";
}
}
#
# ce med argumenti programa ni navedena vhodna datoteka,
# kot vhod vzemi stdinput
#
unshift (@ARGV, '-') if $#ARGV < $[;
#
# odpri datoteke, navedene med argumenti programa,
# in jih obdelaj
#
while ($ARGV = shift) {
$filnam = $ARGV;
open (FILE, $filnam) || die "Can't open $filnam.\n"; $!=-2;
#
# Inicializiraj stevce dodatnih znakov za vsak nabor
#
foreach $encoding_name (@encoding_names) {
$carons_cnt{$encoding_name} = 0;
}
$linum = 0;
print "Guessed encoding of $filnam is ";
#
# prestej dodatne znake, kodirane po razlicnih naborih
#
while ( ($_=<FILE>) && ($linum < $maxlin) ) {
study;
$linum +=1;
foreach $encoding_name (@encoding_names) {
foreach $char (@extra_chars) {
$ch = &encoding($encoding_name,$char);
$carons_cnt{$encoding_name}++ while /\Q$ch\E/g;
}
}
}
close (FILE);
#
# Za vsakega izmed naborov prikazi, koliko extra characters je v njem.
#
if ($verbose) {
foreach $encoding_name (@encoding_names) {
print "There are ", $carons_cnt{$encoding_name},
" extra characters encoded in $encoding_name encoding.\n";
}
}
#
# Za vsakega izmed naborov prikazi, koliko extra characters je v njem in
# izpisi urejeno po narascajocem vrstnem redu.
#
@sorted_enc_names = sort { $carons_cnt{$a} <=> $carons_cnt{$b} } @encoding_names;
foreach $encoding_name (@sorted_enc_names) {
print "There are ", $carons_cnt{$encoding_name},
" extra characters encoded in $encoding_name encoding.\n" if ($showsort);
$guessed_next_best = $guessed;
$guessed = $encoding_name;
}
#
# Pri ugibanju najverjetnejsega nabora uporabi preprosto logiko.
#
print "$guessed($carons_cnt{$guessed}), ",
"next probable $guessed_next_best($carons_cnt{$guessed_next_best}), "
if $showboth;
if (($guessed eq 'LATIN1') &&
($carons_cnt{$guessed_next_best} >= $fraccnt * $carons_cnt{$guessed}) &&
($carons_cnt{$guessed_next_best} >= $mincnt)) {
print "$guessed_next_best by educated guess.\n";
}
else {
print "$guessed by educated guess.\n";
}
}
exit;
Dodatne informacije o seznamu Starilist