Глава 1 Строки

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],
}

Комментарий

$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. Сравнение слов с похожим звучанием

Проблема

Решение

Комментарий

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;
}

© copyright 2000 Soft group