Lingua::RU::Detect - Heuristics for guessing encoding sequence

	use Lingua::RU::Detect "detect_enc";
	say Dumper(detect_enc("бНОПНЯ")); 
	say Dumper(detect_enc("бОДТЕК"));

	$VAR1 = [
		[
			'UTF-8',
			'ISO-8859-5'
		],
		[
			'KOI8-R',
			'UTF-8'
		]
	];

package Lingua::RU::Detect;

use vars qw ($VERSION);
$VERSION = '1.1';

use strict;
use utf8;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(detect_enc);

my %patterns = (
	'-|'.
		'UTF-8.KOI8-R,CP1251.KOI8-R,CP1251.UTF-8',	'\b(?:[А-Я][а-х]+|[а-я]{3,})\b',

	'UTF-8.CP1251,KOI8-R.UTF-8|'.
		'UTF-8.KOI8-R,CP1251.UTF-8',		'\b(?:[а-я][А-Я]+|[А-Я]{3,})\b',

	'UTF-8.ISO-8859-5,KOI8-R.UTF-8|'.
		'UTF-8.KOI8-R,ISO-8859-5.UTF-8|'.
		'UTF-8.CP1251,ISO-8859-5.UTF-8',	'[а-я]+[А-Я]+[а-я]+|[А-Я]+[а-я]+[А-Я]+',

	'UTF-8.ISO-8859-5,CP1251.UTF-8|'.
		'UTF-8.CP866,CP1251.UTF-8',			'[а-яёїџђѓќў]+[√ЄЁЎЇ№]{1,2}[а-яџђѓќўёї]+\b',

	'UTF-7.UTF-8',							'(?:^|\s)\+B[B-F][0-9a-zA-Z]+',
	'UTF-7.CP866',							'(?:^|\s)\+JWg[a-zA-Z]+',
	'UTF-8.ISO-8859-1,UTF-7.ISO-8859-1',	'(?:^|\s)\+AN[a-zA-Z]+',

	'UTF-8.CP1251,KOI8-R.CP866',			'є.¶|¶.¶',
	'UTF-8.CP1252,KOI8-R.CP866',			'º.º|¶.º',
	'UTF-8.CP1251,UTF-8.CP866',				'в•Ё|•›в•',
	'UTF-8.KOI8-R,UTF-8.CP866',				'Б∙╗|Б∙.Б∙.',
	'UTF-8.ISO-8859-1',						'к|пÐ',
	'UTF-8.CP1251,UTF-8.ISO-8859-1',		'ГђВ|°Г‘',
	'UTF-8.KOI8-R,UTF-8.ISO-8859-1',		'ц░б',
	'UTF-8.CP1251,UTF-8.UTF-16',			'н‚.н‚|н†.н†',
	'UTF-8.KOI8-R,UTF-8.UTF-16',			'╬М|╪М|╣М|╫М',
	'UTF-8.CP1251,CP866.UTF-8',				'®.+Ґ|«Ё|®¤­®|«Ґ',
	'UTF-8.CP1251,UTF-8.KOI8-R',			'Рїв|СЏ',

	'UTF-8.ISO-8859-1,ISO-8859-5.UTF-8',	'[ýëåêòðèôèêàöèÿãóáåðíèé]+[ÝËÅÊÒÐÈÔÈÊÀÖÈŸÃÓÁÅÐÍÈÉ]+[ýëåêòðèôèêàöèÿãóáåðíèé]+|[ÝËÅÊÒÐÈÔÈÊÀÖÈŸÃÓÁÅÐÍÈÉ]+[ýëåêòðèôèêàöèÿãóáåðíèé]+[ÝËÅÊÒÐÈÔÈÊÀÖÈŸÃÓÁÅÐÍÈÉ]+',
	'UTF-8.CP1252,CP1251.UTF-8',			'[ýëåêòðèôèêàöèÿãóáåðíèé]{3,}',
	'UTF-8.CP1252,KOI8-R.UTF-8',			'[ÀÏÎËÜÇÎÂÀÍÈÅÑ]{2,}',

	'UTF-8.CP866,KOI8-R.UTF-8',				'[╟╧╫╣║╔╙═╔╥╧╦┴╤╠┼╦╘╥╔╞╔╦┴├╔╤└╓╬┘╚ ╟╒┬┼╥╬╔╩]{4,}',
	'UTF-8.KOI8-R,CP866.UTF-8',				'[╟╧╫╣║╔╙═╔╥╧╦┴╤╠┼╦╘╥╔╞╔╦┴├╔╤└╓╬┘╚ ╟╒┬┼╥╬╔╩]+[А-Я]+[╟╧╫╣║╔╙═╔╥╧╦┴╤╠┼╦╘╥╔╞╔╦┴├╔╤└╓╬┘╚ ╟╒┬┼╥╬╔╩]+[А-Я]+[╟╧╫╣║╔╙═╔╥╧╦┴╤╠┼╦╘╥╔╞╔╦┴├╔╤└╓╬┘╚ ╟╒┬┼╥╬╔╩]+',
	'UTF-8.CP866,ISO-8859-5.UTF-8',			'[а-ор-я]+[╟╧╫╣║╔╙═╔╥╧╦┴╤╠┼╦╘╥╔╞╔╦┴├╔╤└╓╬┘╚ ╟╒┬┼╥╬╔╩]+[а-ор-я]+[╟╧╫╣║╔╙═╔╥╧╦┴╤╠┼╦╘╥╔╞╔╦┴├╔╤└╓╬┘╚ ╟╒┬┼╥╬╔╩]+',
	'UTF-8.KOI8-R',							'[пя][╟╧╫╣║╔╙═╔╥╧╦┴╤╠┼╦╘╥╔╞╔╦┴├╔╤└╓╬┘╚ ╟╒┬┼╥╬╔╩][пя]|п.я',
	'UTF-8.CP866',							'[▒▓╟╧╫╣║╔╙═╔╥╧╦┴╤╠┼╦╘╥╔╞╔╦┴├╔╤└╓╬┘╚ ╟╒┬┼╥╬╔╩]+[А-Я][▒▓╟╧╫╣║╔╙═╔╥╧╦┴╤╠┼╦╘╥╔╞╔╦┴├╔╤└╓╬┘╚ ╟╒┬┼╥╬╔╩]+[А-Я][▒▓╟╧╫╣║╔╙═╔╥╧╦┴╤╠┼╦╘╥╔╞╔╦┴├╔╤└╓╬┘╚ ╟╒┬┼╥╬╔╩]+',
);

my %ambiguities = (
	'-'		=> 'на|ст|ни|но|ан|ов|ко|то|ен|ле|ел|ра|ре|ис|по|ом|ро|ет|ва|та|ос|те|де|ль|ер|он|ть|за|ск|от|ли|ат|ол|об|ар|од|ие|го|пр|ри|мо|ам|сл|тр|не|ор|ла|ал|ит',
	'UTF-8.KOI8-R,CP1251.KOI8-R,CP1251.UTF-8'		=> 'лч|ъп|лу|лм|чл|ма|им|пм|ел|йе|ей|оч|ое|уъ|нм|мк|ом|еп|ач|пч|мъ|пе|де|йщ|ео|мл|пщ|цч|ъи|мп|йу|чп|мй|мю|чо|мд|уе|жм|но|оу|км|чк|ъй|по|ле|мо|йч|чй|уп',
	
	'UTF-8.CP1251,KOI8-R.UTF-8'		=> 'ОБ|УФ|ОЙ|ОП|БО|ПЧ|ЛП|ФП|ЕО|МЕ|ЕМ|ТБ|ТЕ|ЙУ|РП|ПН|ТП|ЕФ|ЧБ|ФБ|ПУ|ФЕ|ДЕ|МШ|ЕТ|ПО|ФШ|ЪБ|УЛ|ПФ|МЙ|БФ|ПМ|ПВ|БТ|ПД|ЙЕ|ЗП|РТ|ТЙ|НП|БН|УМ|ФТ|ОЕ|ПТ|МБ|БМ|ЙФ',
	'UTF-8.KOI8-R,CP1251.UTF-8'		=> 'МЮ|ЯР|МХ|МН|ЮМ|НБ|ЙН|РН|ЕМ|КЕ|ЕК|ПЮ|ПЕ|ХЯ|ОН|НЛ|ПН|ЕР|БЮ|РЮ|НЯ|РЕ|ДЕ|КЭ|ЕП|НМ|РЭ|ГЮ|ЯЙ|НР|КХ|ЮР|НК|НА|ЮП|НД|ХЕ|ЦН|ОП|ПХ|ЛН|ЮЛ|ЯК|РП|МЕ|НП|КЮ|ЮК|ХР',
	
	'UTF-8.ISO-8859-5,KOI8-R.UTF-8' => 'ЮС|гд|ЮЩ|ЮЯ|СЮ|Яз|ЫЯ|дЯ|ХЮ|ЬХ|ХЬ|вС|вХ|Щг|аЯ|ЯЭ|вЯ|Хд|зС|дС|Яг|дХ|ФХ|Ьи|Хв|ЯЮ|ди|кС|гЫ|Яд|ЬЩ|Сд|ЯЬ|ЯТ|Св|ЯФ|ЩХ|ЧЯ|ав|вЩ|ЭЯ|СЭ|гЬ|дв|ЮХ|Яв|ЬС|СЬ|Щд',
	'UTF-8.KOI8-R,ISO-8859-5.UTF-8' => 'щп|АБ|щь|щч|пщ|чр|зч|Бч|ущ|шу|уш|Юп|Юу|ьА|ъч|чэ|Юч|уБ|рп|Бп|чА|Бу|ту|шЛ|уЮ|чщ|БЛ|вп|Аз|чБ|шь|пБ|чш|чя|пЮ|чт|ьу|сч|ъЮ|Юь|эч|пэ|Аш|БЮ|щу|чЮ|шп|пш|ьБ',
	'UTF-8.CP1251,ISO-8859-5.UTF-8' => 'ЭР|бв|ЭШ|ЭЮ|РЭ|ЮТ|ЪЮ|вЮ|ХЭ|ЫХ|ХЫ|аР|аХ|Шб|ЯЮ|ЮЬ|аЮ|Хв|ТР|вР|Юб|вХ|ФХ|Ым|Ха|ЮЭ|вм|ЧР|бЪ|Юв|ЫШ|Рв|ЮЫ|ЮС|Ра|ЮФ|ШХ|УЮ|Яа|аШ|ЬЮ|РЬ|бЫ|ва|ЭХ|Юа|ЫР|РЫ|Шв',

	'UTF-8.ISO-8859-5,CP1251.UTF-8' => 'эр|ёђ|эш|эю|рэ|ют|ъю|ђю|хэ|ых|хы|№р|№х|шё|яю|юь|№ю|хђ|тр|ђр|юё|ђх|фх|ыќ|х№|юэ|ђќ|чр|ёъ|юђ|ыш|рђ|юы|юс|р№|юф|шх|ую|я№|№ш|ью|рь|ёы|ђ№|эх|ю№|ыр|ры|шђ',
	'UTF-8.CP866,CP1251.UTF-8'		=> 'эр|ёЄ|эш|эю|рэ|ют|ъю|Єю|хэ|ых|хы|Ёр|Ёх|шё|яю|юь|Ёю|хЄ|тр|Єр|юё|Єх|фх|ы№|хЁ|юэ|Є№|чр|ёъ|юЄ|ыш|рЄ|юы|юс|рЁ|юф|шх|ую|яЁ|Ёш|ью|рь|ёы|ЄЁ|эх|юЁ|ыр|ры|шЄ',
);

sub detect_enc {
	my $string = shift;

	my %variants = ();
	for my $path (sort keys %patterns) {
		$variants{$path} = () = $string =~ /$patterns{$path}/g;
	}

	my $path = scalar keys %variants ? (sort {$variants{$a} <=> $variants{$b}} keys %variants)[-1] : '';

	$path = remove_ambiguity($path, $string) if $path =~ m{\|};
	
	return make_list($path);
}

sub remove_ambiguity {
	my $paths = shift;
	my $text = shift;

	my @paths = split m{\|}, $paths;
	my %stats = ();
	for my $path (@paths) {
		$stats{$path} = () = $text =~ /$ambiguities{$path}/g;
	}

	return scalar keys %stats ? (sort {$stats{$a} <=> $stats{$b}} keys %stats)[-1] : $paths[0];
}

sub make_list {
	my $path = shift;

	my @ret;

	for my $pair (split /,/, $path) {
		my ($from, $to) = split /\./, $pair;
		push @ret, [$from, $to] unless $from eq '-';
	}

	return @ret;
}

1;

__END__