Re: [знатокам perl] русский в регулярных выражениях (bug#486877)

[Yuri Kozlov <yuray@komyakino.ru>]

В Sat, 6 Nov 2010 13:17:17 +0300
Victor Wagner <vitus@wagner.pp.ru> пишет:

> On 2010.11.06 at 10:59:05 +0300, Yuri Kozlov wrote:
> 
> > Здравствуйте.
> > 
> > Ошибка #486877 в adduser наблюдается и для русского языка.
> > Знатоки perl, подскажите как нужно правильно написать тестовую
> > программку (или может сразу исправите багу?),
> > чтобы она правильно отрабатывала (взято из debian-l10-russian@).
> > 
> > use utf8;
> > require POSIX;
> > import POSIX qw(setlocale);
> > require I18N::Langinfo;
> > import I18N::Langinfo qw(langinfo YESEXPR NOEXPR);
> > 
> > setlocale(LC_ALL, "");
> > 
> > my $yesexpr = langinfo(YESEXPR());
> > my $noexpr = langinfo(NOEXPR());
> > 
> > foreach my $c ('y', 'Y', 'n', 'N', 'д', 'Д', 'н', 'Н', 'ж') {
> >         if ($c =~ m/$yesexpr/o) {print "$c match $yesexpr\n";}
> >         if ($c !~ m/$yesexpr/o) {print "$c not match $yesexpr\n";}
> >         if ($c =~ m/$noexpr/o) {print "$c match $noexpr\n";}
> >         if ($c !~ m/$noexpr/o) {print "$c not match $noexpr\n";}
> > }
> > 
> > результат:
> > 
> > y match ^[ДдYy].*
> > y not match ^[НнNn].*
> > Y match ^[ДдYy].*
> > Y not match ^[НнNn].*
> > n not match ^[ДдYy].*
> > n match ^[НнNn].*
> > N not match ^[ДдYy].*
> > N match ^[НнNn].*
> > Wide character in print at t.perl line 14.
> 
> И так, что мы видим - во-первых, perl не может корректно вывести
> русскую букву 'Д' в STDOUT.
> 
> Надо до первого print добавить  binmode STDOUT,":utf8";
> 
> Сказав это, мы видим что yesexpr и noexpr выводятся как какая-то фигня
> из облати  latin-1, а не как русские буквы. 
> 
> То есть perl трактует полученные из langinfo строки как строки байт, а
> не как строки символов. Отсюда и все проблемы. 
> 
> Соответственно, добавляем в начале скрипта
> 
> use Encode qw(decode);
> 
> и оборачиваем вызовы langinfo в decode
> 
> my $yesexpr = decode("utf8",langinfo(YESEXPR()));
> my $noexpr = decode("utf8",langinfo(NOEXPR()));
> 
> Фактически этот вызов decode сводится к "проинтерпетировать данную в
> качестве второго аргумента последовательность байт как строчку в utf-8".
> Результатом будет строка символов, при текущей реализации идентичная
> входной строке байт, но заметно отличающаяся с точки зрения perl по
> смыслу.
> 
> Теперь у нас все радостно работает до тех пор пока локаль использует
> кодировку utf-8. В реальном приложении, где ответы вводятся в stdin,
> придется еще и binmode на STDIN сказать.
> 
> Добиться работы данной тестовой программы во всех русских локалях
> (koi8-r, cp1251, ibm-866) будет несколько сложнее.
> 
> Я сейчас сходу не вспомню, есть ли магическое слово, заставляющее потоки
> ввода-вывода работать в кодировке текущей локали, или придется из
> langinfo запрашивать кодировку  и руками вкручивать ее в binmode (и
> выдачу langinfo декодировать из этой кодировки, естественно).
> 
> Возможно, дешевле будет проверять только на кодировку равную utf-8, и в
> таких локалях работать через честное преобразование и выражений, и
> проверяемых значений к строкам символов (потому что регексп с диапазоном
> в русских букв в квадратных скобках, заданный в utf-8 и
> проинтерпретированный как набор байт, ожидаемого результата не даст), а
> в остальных случаях - наоборот форсированно загонять stdin и stdout в
> режим :bytes - тогда на всех 8-битных кодировках все отработает как
> ожидалось. Но в последнем случае жалко бедных жителей Дальнего Востока,
> у которых есть многобайтовые кодировки, отличные от utf-8.

Угум, теперь правильно. Осталось побороть привязку к utf8.
Но неужели всё так действительно через ...?

use utf8;
use Encode qw(decode);

require POSIX;
import POSIX qw(setlocale);
require I18N::Langinfo;
import I18N::Langinfo qw(langinfo YESEXPR NOEXPR);

setlocale(LC_ALL, "");

binmode(STDOUT,':utf8');
binmode(STDIN,':utf8');

my $yesexpr = langinfo(YESEXPR());
my $noexpr = langinfo(NOEXPR());

my $yesexpr = decode("utf8",langinfo(YESEXPR()));
my $noexpr = decode("utf8",langinfo(NOEXPR()));

foreach my $c ('y', 'Y', 'n', 'N', 'д', 'Д', 'н', 'Н', 'ж') {
        if ($c =~ m/$yesexpr/o) {print "$c match $yesexpr\n";}
        if ($c !~ m/$yesexpr/o) {print "$c not match $yesexpr\n";}
        if ($c =~ m/$noexpr/o) {print "$c match $noexpr\n";}
        if ($c !~ m/$noexpr/o) {print "$c not match $noexpr\n";}
}

yuray@keeper:/tmp$ perl t.perl 
y match ^[ДдYy].*
y not match ^[НнNn].*
Y match ^[ДдYy].*
Y not match ^[НнNn].*
n not match ^[ДдYy].*
n match ^[НнNn].*
N not match ^[ДдYy].*
N match ^[НнNn].*
д match ^[ДдYy].*
д not match ^[НнNn].*
Д match ^[ДдYy].*
Д not match ^[НнNn].*
н not match ^[ДдYy].*
н match ^[НнNn].*
Н not match ^[ДдYy].*
Н match ^[НнNn].*
ж not match ^[ДдYy].*
ж not match ^[НнNn].*

-- 
Best Regards,
Yuri Kozlov