1.15. Анализ данных, разделенных запятыми

Проблема

Имеется файл данных, поля которого разделены запятыми. Однако в полях могут присутствовать свои запятые (находящиеся внутри строк или снабженные служебными префиксами). Многие электронные таблицы и программы для работы с базами данных поддерживают списки полей, разделенных запятыми, в качестве стандартного формата для обмена данными.

Решение

Воспользуйтесь следующей процедурой:

sub parse_csv {
my $text = shift;
# Запись со значениями, разделенными запятыми my @new = ();
push(@new, $+) while $text =~ m{
# Первая часть группирует фразу в кавычках
"([^\"\\]*(?:\\.[^\"\\]*)*)",?
| (^,]+),?
| ,
}QX;
push(@new, under) if substr($text,-1,1) eq ',';
return @new; # Список значений, которые разделялись запятыми
} Также можно воспользоваться стандартным модулем Text:ParseWords:
use Text::ParseWords;
yub parse_csv {
return quoteword(",",0, $_[0],
}

Комментарий

Ввод данных, разделенных запятыми, - коварная и непростая задача. Все выглядит просто, но в действительности приходится использовать довольно сложную систему служебных символов, поскольку сами поля могут содержать внутренние запятые. В результате подстановка получается весьма сложной, а простая функция split /, / вообще исключается. К счастью, модуль Text::ParseWords скрывает от вас все сложности. Передайте функции qoutewords два аргумента и строку разделенных данных. Первый аргумент определяет символ-разделитель (в данном случае - запятая), а второй - логический флаг, который показывает, должна ли возвращаемая строка содержать внутренние кавычки. Если кавычки должны присутствовать внутри поля, также ограниченного кавычками, воспользуйтесь префиксом \: "like \"this\". Кавычки, апострофы и обратная косая черта - единственные символы, для которых этот префикс имеет специальное значение. Все остальные экземпляры \ остаются в итоговой строке. Ниже показан пример использования процедуры parse_csv. q<> - всего лишь хитроумный заменитель кавычек, благодаря которому нам не придется расставлять повсюду символы \.

$line = q"Error, Core Dumped">;
fields = parse_csv($line);
for ($i = 0;$i < fields; $i++) {
print "$i : $fields[$i]\n";
} 0 XYZZY
1
2 O'Reilly, Inc
3 Wall, Larry
4 a \"glug\" bit,
5 5
6 Error, Core Dumped

Смотри также: Описание синтаксиса регулярных выражений в perlre(i); документация по стандартному модулю Text::ParseWords.

1.16. Сравнение слов с похожим звучанием

Проблема

Имеются две английские фамилии. Требуется узнать, звучат ли они похожим образом (независимо от написания). Это позволит выполнять неформальный поиск в телефонной книге, в результатах которого наряду со Smith будут присутствовать и другие похожие имена - например, Smythe, Smite и Smote.

Решение

Воспользуйтесь стандартным модулем Text::Soundex:
use Text::Soundex;
$CODE = soundex($STRING);
OCODES = soundex(@LIST);

Комментарий

Алгоритм soundex хэширует слова (особенно английские фамилии) в небольшом пространстве с использованием простой модели, имитирующей произношение по правилам английского языка. Грубо говоря, каждое слово сокращается до четырехсимвольной строки. Первый символ является буквой верхнего регистра, а прочие - цифры. Сравнивая значения для двух строк, можно определить, звучат ли они похожим образом. Следующая программа предлагает ввести имя и ищет в файле паролей имена с похожим звучанием. Аналогичный подход может использоваться для баз данных имен, поэтому при желании можно индексировать базу данных по ключам soundex. Конечно, такой индекс не будет уникальным.

use Text::Soundex;
use User::pwent;
print "Lookup user: ";
chomp($user = );
exit unless defined $user;
$name_code = soundex($user):
while($uent = getpwent()) {
($firstname, $lastname) = $uent->gecos =~ /(w+)[",]*\b(\w+)/'
if ($name_code eq soundex($uent->name) ||
$name_code eq soundex($$lastname) ||
$name_code eq soundex($firstname) ) {
printf "%s: %s %s\n", $uent->name, $firstname, $lastname;
}
}

Смотри также: Документация по стандартным модулям Text::Soundex и User::pwent; man-страница passwd(S) вашей системы; "Искусство программирования", том 3, глава 6.

1.17. Программа: fixstyle

Представьте себе таблицу с парами устаревших и новых слов. Старые слова Новые слова

bonnet hood
rubber eraser
lorrie truck
trousers pants

Программа из примера 1.4 представляет собой фильтр, который заменяет все встречающиеся в тексте слова из первого столбца соответствующими элементами второго столбца. При вызове без файловых аргументов программа выполняет функции простого фильтра. Если в командной строке передаются имена файлов, то в них помещаются результаты, а прежние версии сохраняются в файлах с расширениями *.orig (см. рецепт 7.9). При наличии параметра командной строки -v сообщения обо всех изменениях записываются в STDERR. Таблица пар "исходное слово/заменитель" хранится в основной программе, начиная с __END__ (см. рецепт 7.6). Каждая пара преобразуется в подстановку и накапливается в переменной $code так же, как это делается в программе popgrep2 из рецепта 6.10. Параметр -t выводит сообщение об ожидании ввода с клавиатуры при отсутствии других аргументов. Если пользователь забыл ввести имя файла, он сразу поймет, чего ожидает программа.
Пример 1.4. fixstyle

#!/usr/bin/peri -w # fixstyle - замена строк секции парными строками # использование: $0 [-v] [файлы...]
use strict;
my $verbose = (@argv && $argv[0] eq '-v' && shift);
if (@ARGV) {
$"I = ".orig"; # Сохранить старые файлы
} else {
warn "$0: Reading from stdin\n" if -t STDIN; }
my $code = "while (<>) {\n"; # Читать данные и строить код для eval
while () {
chomp;
my ($in, $out) = split /\s*=>\s*/;
next unless $in && $out;
$code .= "s{\\0$in\\e}{$out}g";
$code .= "&& printf stderr qq($in => $out at \$ARGV line \$.\\n)' if $verbose;
$code .= ";\n";
} $code ,= "printf;\n}\n";
eval "{ code } 1" 11 die;

_-END__
analysed => analyzed
built-in => builtin
chastized => chastised
commandline => command-line
de-allocate => deallocate
dropin => drop-in
hardcode => hard-code
meta-data => metadata
multicharacter => multi-character
multiway => multi-way
non-empty => nonempty
non-profit => nonprofit
non-trappable => nontrappable
pre-define => predefine
preextend => pre-extend
re-compiling => recompiling
reenter => re-enter
turnkey => turn-key
Небольшое предупреждение: программа работает быстро, но не в тех случаях, когда количество замен измеряется сотнями. Чем больше секция DATA, тем больше времени потребуется. Несколько десятков замен не вызовут существенного замедления. Более того, для малого количества замен эта версия работает быстрее следующей. Но если запустить программу с несколькими сотнями замен, она начнет заметно отставать. В примере 1.5 приведена следующая версия программы. При малом количестве замен она работает медленнее, а при большом - быстрее.

Пример 1.5. fixstyle2
#!/usr/bin/perl -w
# fixstyle2 = аналог fixstyle для большого количества замен

use strict;
my $verbose = (@argv && $argv[0] eq '-v' && shift);
my $change = ();
while () {
chomp;
my ($in, $out) = split /\s*=>\s*/;
next unless Sin && $out;
$change{$in} = $out;
}
if (@ARGV) {
$"I = ".orig";
} else {
warn "$0: Reading from stdin\n" if -t STDIN;
}
while (<>) {
my $i =0;
s/"(\s+)/7 && print $1; # Выдать начальный пропуск
for (split /(\s+)/, $_, -1) {
print( ($i++ & 1) ? $_ : ($change{$_} || $_));
}
}

__END__
analysed => analyzed
built-in => builtin
chastized => chastised
commandline => command-line
de-allocate => deallocate
dropin => drop-in
hardcode => hard-code
meta-data => metadata
multicharacter => multi-character
multiway => multi-way
non-empty => nonempty
non-profit => nonprofit
non-trappable => nontrappable
pre-define => predefine
preextend => pre-extend
re-compiling => recompiling
reenter => re-enter
turnkey => turn-key

В новой версии программы каждая строка разбивается на пропуски и слова (относительно медленная операция). Затем слова используются для поиска замены в хэше, что выполняется существенно быстрее подстановки. Следовательно, первая часть работает медленнее, а вторая - быстрее. Выигрыш в скорости зависит от количества совпадений.
Если бы мы не старались сохранить количество пропусков, разделяющих слова, нетрудно сделать так, чтобы вторая версия не уступала первой по скорости даже при небольшом количестве замен. Если вам хорошо известны особенности входных данных, пропуски можно заменить одиночными пробелами. Для этого применяется следующий цикл: # Работает очень быстро, но со сжатием пропусков

while (<>) {
for (split) {
print $change{$_} | $_, " ";
}
print "\n";
}
В конце каждой строки появляется лишний пробел. Если это нежелательно, воспользуйтесь методикой рецепта 16.14 и создайте входной фильтр. Вставьте следующий фрагмент перед циклом while, сжимающим пропуски:
my $pid = open(stdout, "|=");
die "cannot fork: $!" unless defined $pid;
unless ($pid) {
while () { s/ $//;
print;
} exit;
}

Вперед