Строки
..И открыл легкомысленно уста свои, и безрассудно расточает слова.
Книга Иова, 35:16
Введение
Многие языки программирования заставляют нас мыслить на неудобном низком уровне. Вам понадобилась строка, а язык хочет, чтобы вы работали с указателем или байтовым массивом. Впрочем, не отчаивайтесь — Perl не относится к языкам низкого уровня, и в нем удобно работать со строками.
Perl проектировался для обработки текста. В сущности, в Perl существует такое количество текстовых операций, что их невозможно описать в одной главе. Рецепты обработки текста встречаются и в других главах. В частности, обратитесь к главе 6 «Поиск по шаблону» и главе 8 «Содержимое файлов» — в них описаны интересные приемы, не рассмотренные в этой главе.
Фундаментальной единицей для работы с данными в Perl является скаляр (scalar), то есть отдельное значение, хранящееся в отдельной (скалярной) переменной. В скалярных переменных хранятся строки, числа и ссылки. Массивы и хэши представляют собой соответственно списки или ассоциативные массивы скаляров. Ссылки используются для косвенных обращений к другим величинам; они отчасти похожи на указатели в языках низкого уровня. Числа обычно хранятся в формате вещественных чисел с двойной точностью. Строки в Perl могут иметь произвольную длину (ограниченную только объемом виртуальной памяти вашего компьютера) и содержат произвольные данные — даже двоичные последовательности с нулевыми байтами.
Строка не является массивом байт; к отдельному символу нельзя обратиться по индексу, как к элементу массива — для этого следует воспользоваться функцией substr. Строки, как и все типы данных Perl, увеличиваются и уменьшаются в размерах по мере необходимости. Неиспользуемые строки уничтожаются системой сборки мусора Perl (обычно при выходе переменной, содержащей строку, за пределы области действия или после вычисления выражения, в которое входит стро-
ка). Иначе говоря, об управлении памятью можно не беспокоиться — об этом уже позаботились до вас.
Скалярная величина может быть определенной или неопределенной. Определенная величина может содержать строку, число или ссылку. Единственным неопределенным значением является undef, все остальные значения считаются определенными — даже 0 и пустая строка. Однако определенность не следует путать с логической истиной; чтобы проверить, определена ли некоторая величина, следует воспользоваться функций defined. Логическая истина имеет особое значение, которое проверяется логическими операторами && и | |, а также в условии блока while.
Две определенные строки считаются ложными: пустая строка ("") и строка единичной длины, содержащая цифру «ноль» (' 0"). Возможно, второе вас несколько удивит, но это связано с тем, что Perl выполняет преобразования между числами и строками по мере необходимости. Числа 0. 0.00 и 0.00000000 без кавычек считаются ложными значениями, но в строках они становятся истинными (так, строка 0 00 считается истинной, а не ложной). Все остальные определенные значения (например, ' false", 15 и \$х) истинны.
В строковом контексте значение undef интерпретируется как пустая строка ( '"). В числовом контексте undef интерпретируется как 0, а в ссылочном — как нуль-ссылка. При этом во всех случаях оно считается ложным. Использование неопределенной величины там, где Perl ожидает получить определенную, приводит к записи в STDERR предупреждения времени выполнения (если был использован флаг -w). Для простого вопроса о том, является ли нечто истинным или ложным, предупреждение не выдается. Некоторые операции не выдают предупреждений при использовании переменных, содержащих неопределенные значения. К их числу относятся операции автоматического увеличения и уменьшения, ++ и --, а также сложение и конкатенация с присваиванием, += и =.
В программах строки записываются в апострофах или кавычках, в форме q// или qq// или «встроенных документов» (here-documents). Апострофы используются в простейшей форме определения строк с минимальным количеством специальных символов: ' — завершает строку, \' — вставляет в нее апостроф, а \\ — обратную косую черту:
$string = '\п', й Два символа, \ и п
$string = 'Jon \'Maddog\ Orwant' # Внутренние апострофы
В строках, заключенных в кавычки, возможна интерполяция имен переменных (но не вызовов функций — о том, как это делается, см. рецепт 1.10). В них используется множество служебных символов: ' \п" — символ перевода строки, "\033" — символ с восьмеричным кодом 33, "\cJ" — Ctrl+J и т. д. Полный список приведен в странице руководства perlop(l).
$stnng = '\n', # Символ перевода строки
Sstring = 'Jon YMaddogV Orwant , 8 Внутренние кавычки
Операторы q// и qq// позволяют чередовать разделители строк с апострофами и кавычками. Например, строку с внутренними апострофами проще записать в следующем виде, вместо того чтобы использовать служебные символы \':
28 Глава 1 • Строки
Sstring = q/Jon 'Maddog' Orwant/; # Внутренние апострофыВ качестве разделителей могут использоваться одинаковые символы, как в этом примере, или парные (для различных типов скобок):
$stnng = q[Jon 'Maddog' Orwant]; it Внутренние апострофы
Sstring = q{Jon 'Maddog' Orwant}; # Внутренние апострофы
Sstring = q(Jon 'Maddog' Orwant); # Внутренние апострофы
Sstring = q<Jon 'Maddog' Orwant>; # Внутренние апострофы
Концепция «встроенных документов» позаимствована из командных интерпретаторов (shell) и позволяет определять строки, содержащие большое количество текста. Текст может интерпретироваться по правилам для строк, заключенных в апострофы или кавычки, и даже как перечень исполняемых команд — в зависимости от того, как задается завершающий идентификатор. Например, следующий встроенный документ будет интерпретироваться по правилам для строк, заключенных в кавычки:
$а = «"EOF";
This is a multiline here document
terminated by EOF on a line by itself
EOF
Обратите внимание: после завершающего EOF точка с запятой не ставится. Встроенные документы более подробно рассматриваются в рецепте 1.11.
Предупреждение для программистов из других стран: в настоящее время Perl не обладает прямой поддержкой многобайтовых кодировок (в версии 5.006 ожидается поддержка Unicode), поэтому в тексте книги понятия байт и символ считаются идентичными.
1.1. Работа с подстроками
Проблема
Требуется получить или модифицировать не целую строку, а лишь ее часть. Например, вы прочитали запись с фиксированной структурой и теперь хотите извлечь из нее отдельные поля.
Решение
Функция substr предназначена для чтения и записи отдельных байтов строки:
lvalue = substr($string, Soffset, 4count); Svalue = substr($stnng, Soffset);
substr($string, Soffset, Scount) = Snewstring;
substr($string, Soffset) = Snewtail;
Функция unpack ограничивается доступом только для чтения, но при извлечении нескольких подстрок работает быстрее:
# Получить 5-байтовую строку, пропустить 3,
# затем две 8-байтовые строки, затем все остальное
(Sleading, $s1, $s2, $trailing) =
unpack("A5 хЗ A8 A8 A*", $data);
# Деление на группы из пяти байт
@fivers = unpack("A5" x (length($stnng)/5), $string);
# Деление строки на отдельные символы
@chars = unpack("A1" x (length($string), $string);
Комментарий
В отличие от многих языков, в которых строки представлены в виде массива байтов (или символов), в Perl они относятся к базовым типам данных. Это означает, что для работы с отдельными символами или подстроками применяется функция unpack или substr.
Второй аргумент функции substr (смещение) определяет начало интересующей вас подстроки; положительные значения отсчитываются от начала строки, а отрицательные — с конца. Если смещение равно 0, подстрока начинается с начала. Третий аргумент определяет длину подстроки.
$stnng = "This is what you have";
U +012345678901234567890 Прямое индексирование (слева направо)
# 109876543210987654321- Обратное индексирование (слева направо)
0 соответствует 10, 20 и т. д
$first = substr($stnng, 0, 1); п "Т"
$start = substr($string, 5, 2); # "is"
$rest = substr($string. 13); n "you have"
$last = substr($string, -1); # "e"
$end = substr($string, -4); # "have"
$piece = substr($stnng, -8, 3), # "you"
Однако функция substr позволяет не только просматривать части строки, но и изменять их. Дело в том, что substr относится к экзотической категории левосторонних функций, то есть таких, которым при вызове можно присвоить значение. К тому же семейству относятся функции vec, pos и keys (начиная с версии 5.004). При некоторой фантазии функции local и ту также можно рассматривать как левосторонние.
Sstring = "This is what you have";
print Sstring;
This is what you have
substr($stnng, 5, 2) = "wasn't"; # заменить "is" на "wasn't"
This wasn't what you have
substr($string, -12) = "ondrous"; # "This wasn't wondrous"
This wasn't wondrous
substr($string, 0, 1) = ""; # Удалить первый символ
his wasn't wondrous
30 Глава 1 • Строки
substr($string, -10) = ' , # Удалить последние 10 символовhis wasn'
Применяя оператор =" в сочетании с операторами s///, m// или tr///, можно заставить их работать только с определенной частью строки:
# =~ применяется для поиска по шаблону if (substr($stnng, -10) =" /pattern/) {
print Pattern matches in last 10 characters'^ ',
# подставить "at" вместо 'is', ограничиваясь первыми пятью символами
substr($string, 0, 5) =" s/is/at/g,
Более того, подстроки даже можно поменять местами, используя с каждой стороны присваивания несколько вызовов substr:
# Поменять местами первый и последний символ строки
$а = make a hat ,
(substr($a,0,1), substr($a,-1)) = (substr($a.-1), substr($a,0,1)); print $a, take a ham
Хотя функция unpack не является левосторонней, она работает значительно быстрее substr, особенно при одновременном извлечении нескольких величин. В отличие от substr она не поддерживает непосредственные смещения. Вместо этого символ х нижнего регистра с числом пропускает заданное количество байт в прямом направлении, а символ ' X ' верхнего регистра — в обратном направлении.
# Извлечение подстроки функцией unpack
$а = ' То be or not to be ,
$b = unpack( хб А6 , $a), tt Пропустить 6 символов, прочитать 6 символов print $b; or not
($b, $c) = unpack( хб A2 X5 A2', $a), # Вперед 6, прочитать 2,
# назад 5, прочитать 2 print '$b\n$c\n"; or be
Иногда строка «режется» на части в определенных позициях. Предположим, вам захотелось установить позиции разреза перед символами 8, 14, 20, 26 и 30 — в каждом из перечисленных столбцов начинается новое поле. В принципе можно вычислить форматную строку unpack - 'А7 А6 А6 А4 А*", но программист на Perl по природе ленив и не желает попусту напрягаться. Пусть за него работает Per]. Воспользуйтесь приведенной ниже функцией cut2fmt.
sub cut2fmt {
my((s>positions) = @>_, my $template = my $lastpos = 1, foreach $place(positions) {
Stemplate = A ($place - $lastpos) ";
Slastpos = $place;
}
Stemplate = "A*';
return $template; }
$fmt = cut2fmt(8, 14, 20, 26, 30); print "$fmt\n", A7 A6 A6 A6 A4 A*
Возможности функции unpack выходят далеко за пределы обычной обработки текста. Она также обеспечивает преобразование между текстовыми и двоичными данными.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций unpack и substг в perlfunc(l); подпрограмма cut2fmt из рецепта 1.18. Применение unpack для двоичных данных демонстрируется в рецепте 8.18.
1.2. Выбор значения по умолчанию
Проблема
Требуется закрепить за скалярной переменной значение по умолчанию, но лишь в том случае, если оно не было задано ранее. Довольно часто требуется, чтобы стандартное значение переменной жестко кодировалось в программе, по его можно было переопределить из командной строки или переменной окружения.
Решение
Воспользуйтесь оператором | | или | | =, работающим как со строками, так и с числами:
U Использовать $Ь, если значение $Ь истинно, и $с в противном случае $а = $Ь || $с,
и Присвоить $х значение $у, но лишь в том случае, U если $х не является истинной $х ||= $у,
Если ваша переменная может принимать значения 0 или "0", воспользуйтесь функцией defined:
# Использовать $Ь, если значение $Ь определено, и $с в противном случае $а = defmed($b) ? $b $c,
Комментарий
Главное отличие между этими двумя приемами (defined и | |) состоит, прежде всего, в том, что именно проверяется — определенность или истинность. В мире Perl три определенных значения являются ложными: 0, "0" и "". Если ваша переменная содержит одну из этих величин, но вы не хотите изменять ее, 11 не подой-
дет — приходится выполнять неуклюжие проверки с defined. Часто бывает удоб но организовать программу так, чтобы принималась в расчет истинность или ложность переменных, а не их определенность.
В отличие от других языков, где возвращаемые значения ограничиваются О и 1, оператор | | Perl обладает более интересным свойством: он возвращает первый (левый) операнд, если тот имеет истинное значение; в противном случае возвращается второй операнд. Оператор && ведет себя аналогично (для второго выражения), но этот факт используется реже. Для операторов несущественно, что представляют собой их операнды — строки, числа или ссылки; подойдет любое скалярное значение. Они просто возвращают первый операнд, из-за которого все выражение становится истинным или ложным. Возможно, это расходится с возвращаемым значением в смысле булевой алгебры, но такими операторами удобнее пользоваться.
Это позволяет установить значение по умолчанию для переменной, функции или более длинного выражения в том случае, если первый операнд не подходит. Ниже приведен пример использования 11, в котором $foo присваивается либо $bar, либо, если значение $Ьаг ложно, — строка "DEFAULT VALUE":
$foo = $bar || DEFAULT VALUE'
В другом примере переменной $di г присваивается либо первый аргумент командной строки программы, либо ' /tmp", если аргумент не указан:
$dir = shift(@ARGV) ||
To же самое можно сделать и без изменения @ARGV:
$dir = $ARGV[O] || Vtmp"
Если 0 является допустимым значением $ARGV[O], использовать 11 нельзя, потому что вполне нормальное значение будет интерпретировано как ложное. Приходится обращаться к тернарному оператору выбора:
$dir = defmed($ARGV[O]) ? shift(@ARGV) Vtmp ,
To же можно записать и иначе, со слегка измененной семантикой:
$dir = (3ARGV ? $ARGV[O] /tmp"
Мы проверяем количество элементов в @ARGV. В условии оператора выбора (9 ¦) @ARGV интерпретируется в скалярном контексте. Значение будет ложным лишь при нулевом количестве элементов, в этом случае будет использоваться "/tmp". Во всех остальных ситуациях переменной (когда пользователь вводит аргумент) будет присвоен первый аргумент командной строки.
Следующая строка увеличивает значение %count, при этом в качестве ключа используется значение $shell, а если оно ложно — строка "/bin/sh".
$count{ $shell || "/bin/sh' }++,
В одном условии можно объединить несколько альтернативных вариантов, как показывает следующий пример. Результат совпадает с первым операндом, имеющим истинное значение.
й Определить имя пользователя в системе UNIX $user = $ENV{USER}
11 getloginO
|| (getwuid($<))[0]
|| "Unknown uid number $<";
Оператор && работает аналогично; он возвращает первый операнд, если этот операнд ложен. В противном случае возвращается второй операнд. Поскольку ложные значения представляют интерес существенно реже, чем истинные, это свойство используется не так часто. Одно из возможных применений продемонстрировано в рецепте 8.13.
Оператор присваивания 11 = выглядит странно, но работает точно так же, как и остальные операторы присваивания. Практически для всех бинарных операторов Perl $VAR 0P= VALUE означает $VAR = $VAR OP VALUE; например, $а += $b —тоже, что и $а = $a + $b. Следовательно, оператор | |= может использоваться для присваивания альтернативного значения переменной. Поскольку 11 выполняет простую логическую проверку (истина или ложь), у него не бывает проблем с неопределенными значениями, даже при использовании ключа -w.
В следующем примере | |= присваивает переменной $starting_pomt значение "Greenwich", если оно не было задано ранее. Предполагается, что $starting_point не принимает значений 0 или "О", а если принимает — то такие значения должны быть заменены:
$startmg_point ||= 'Greenwich'
В операторах присваивания 11 нельзя заменять оператором о г, поскольку о г имеет слишком низкий приоритет. Выражение $а = $b or $с эквивалентно ($а = $b) or $c. В этом случае переменной $Ь всегда присваивается $а, а это совсем не то, чего вы добивались.
Не пытайтесь распространить это любопытное применение 11 и 11 = со скалярных величин на массивы и хэши. У вас ничего не выйдет, потому что левый операнд интерпретируется в скалярном контексте. Приходится делать что-нибудь подобное:
@а = @b unless @а; # Копировать, если массив пуст
@а = @Ь ? @Ь : @с; # Присвоить @Ь, если он не пуст, иначе @с
> Смотри также---------------------------------------------------------------------------------------------
Описание оператора | | врег1ор(1); описание функций defined и exists вреИ-func{\).
1.3. Перестановка значений
без использования временных переменных
Проблема
Требуется поменять значения двух скалярных переменных, но вы не хотите использовать временную переменную.
34 Глава 1 • Строки
РешениеВоспользуйтесь присваиванием по списку:
($VAR1, $VAR2) = ($VAR2, $VAR1),
Комментарий
В большинстве языков программирования перестановка значений двух переменных требует промежуточного присваивания:
$terap = $a, $а = $Ь, $b = Sterap
В Perl дело обстоит иначе Язык следит за обеими сторонами присваивания и за тем, чтобы ни одно значение не было случайно стерто. Это позволяет избавиться от временных переменных:
$а = alpha
$b = omega ,
($а $b) = ($Ь $а), # Первый становится последним - и наоборот
Подобным способом можно поменять местами сразу несколько переменных:
($alpha $beta, $production) = qw(January March August)
# beta перемещается в alpha,
# production - в beta
# alpha - в production
($alpha, $beta, $production) = ($beta, Sproduction, $alpha),
После завершения этого фрагмента значения переменных $alpha, $beta и
$production будут равны соответственно March , August и January .
> Смотри также---------------------------------------------------------------------------------------------
Раздел «List value constructors» perlop(i).
1.4. Преобразование между символами и ASCII-кодами
Проблема
Требуется вывести код, соответствующий некоторому символу в кодировке ASCII, или наоборот — символ по ASCII-коду.
Решение
Воспользуйтесь функцией о rd для преобразования символа в число или функцией ch r — для преобразования числа в символ:
$num = ord($char), $char = chr($num),
Формат %с в функциях printf и spnntf также преобразует число в символ-
$char = sprintf( %c , $num), # Медленнее чем chr($num)
printf( Number %d is character %c\n , $num, $num) Number 101 is character e
Шаблон С*, используемый в функциях pack и unpack, позволяет быстро преобразовать несколько символов:
@ASCII = unpack( С* $stnng) ©STRING = pack( C* $ascn),
Комментарий
В отличие от низкоуровневых, нетипизованных языков вроде ассемблера, Perl не считает эквивалентными символы и числа; эквивалентными считаются строки и числа. Это означает, что вы не можете произвольно присвоить вместо символа его числовое представление, или наоборот. Для преобразования между символами и их числовыми значениями в Perl существуют функции chr и ord, взятые из Pascal:
$ascu_value = ord( e ) ft Теперь 101 Icharacter = chг(101), ft Теперь е
Символ в действительности представляется строкой единичной длины, поэтому его можно просто вывести функцией print или с помощью формата %s функций printf и spnntf Формат %с заставляет printf или spnntf преобразовать число в символ, однако он не позволяет вывести символ, который уже хранится в символьном формате (то есть в виде строки).
printf( Number %d is character %c\n 101 101),
Функции pack, unpack, chr и ord работают быстрее, чем spnntf. Приведем пример практического применения pack и unpack.
@ascn_character_numbers = unpack( С* , sample ), print (eiascii_character_numbers\n , 115 97 109 112 108 101
$word = pack( C» ascn_character_nurabers),
Sword = pack( C* 115, 97, 109, 112, 108 101), # To же самое
print $word\n
sample
А вот как превратить HAL в IBM:
$hal = HAL ,
@ascn = unpack( C* , $hal),
foreach $val (@ascii) {
$val++, # Увеличивает каждый ASCII-код на 1
}
$ibm = pack( С*). @ascii), print $ibm\n # Выводит IBM
О Смотри также--------------------------------------------------------------------------------------------
Описание функций chr, ord, printf, sprintf, pack и unpack ърег1/ипс(\).
1.5. Посимвольная обработка строк
Проблема
Требуется последовательно обрабатывать строку по одному символу.
Решение
Воспользуйтесь функцией split с пустым шаблоном, чтобы разбить строку на отдельные символы, или функцией unpack, если вам нужны лишь их ASCII-коды:
@>array = split(//, $string);
@array = unpack("O", Sstring);
Или последовательно выделяйте очередной символ в цикле:
while (/(.)/g) { # . здесь не интерпретируется как новая строка
# Сделать что-то полезное с $1 }
Комментарий
Как говорилось выше, фундаментальной единицей текста в Perl является строка, а не символ. Необходимость посимвольной обработки строк возникает достаточно редко. Обычно такие задачи легче решаются с помощью высокоуровневых операций Perl (например, поиска по шаблону). Пример приведен в рецепте 7.7, где для поиска аргументов командной строки используются подстановки.
Если вызвать split с шаблоном, который совпадает с пустой строкой, функция возвращает список отдельных символов строки. При намеренном использовании эта особенность оказывается удобной, однако с ней можно столкнуться и случайно. Например, /X*/ совпадает с пустой строкой. Не исключено, что вам встретятся и другие ненамеренные совпадения.
Ниже приведен пример, который выводит символы строки "an apple a day", отсортированные в восходящем порядке ASCII-кодов:
%seen =();
$string = "an apple a day";
foreach $byte (split //, Sstring) {
$seen($1)++; }
print "unique chars are: ", sort(keys %seen), "\n"; unique chars are: adelnpy
Решения с функциями split и unpack предоставляют массив символов, с которым можно работать. Если массив не нужен, воспользуйтесь поиском по шаблону в цикле while с флагом /д, который будет извлекать по одному символу:
%seen =();
$string = "an apple a day";
while ($string =~ /(.)/g) {
$seen($1)++; }
print "unique chars are: ", sort(keys %seen), "\n"; unique chars are: adelnpy
Как правило, посимвольная обработка строк не является оптимальным решением. Вместо использования index/substr или split/unpack проще воспользоваться шаблоном. В следующем примере 32-разрядная контрольная сумма вычисляется вручную, но лучше поручить работу функции unpack — она сделает то же самое намного эффективнее.
Следующий пример вычисляет контрольную сумму символов $st ring в цикле f о reach. Приведенный алгоритм не оптимален; просто мы используем традиционную и относительно легко вычисляемую сумму. За более достойной реализацией контрольной суммы обращайтесь к модулю MD5 на CPAN.
$sum = 0;
foreach $ascval (unpack("O", $string)) {
$sum += $ascval; > print "sum is $sum\n";
# Для строки "an apple a day" выводится сумма 1248
Следующий вариант делает то же самое, но намного быстрее:
$sum = unpack("%32C", $string);
Это позволяет эмулировать программу вычисления контрольной суммы SysV:
#!/usr/bin/perl
# sum - Вычисление 16-разрядной контрольной суммы всех входных файлов
«checksum = 0;
while (о) { $checksum += unpack("%16O", $_) } Schecksum %= (2 •• 16) - 1; print "$checksum\n";
На практике пример использования выглядит так:
% perl sum /etc/termcap 1510
Если у вас установлена GNU-версия sum, для получения идентичного ответа для того же файла ее следует вызвать с параметром -sysv:
% sum -sysv /etc/termcap 1510 851 /etc/termcap
В примере 1.1 приведена еще одна крошечная программа, в которой также реализована посимвольная обработка входных данных. Идея заключается в том, что-
38 Глава 1 • Строки
бы вывод каждого символа сопровождался небольшой паузой — текст будет появляться перед аудиторией в замедленном темпе, и его будет удобнее читать.Пример 1.1. slowcat
#!/usr/bin/perl
# slowcat -замедленный вывод
# использование: slowcat [-DELAY] [files...],
« где DELAY - задержка
SDELAY = ($ARGV[O] =~ /"-([.\d]+)/) ? (shift, $1) : 1;
$| = 1; while (<>) {
for (split(//)) { print; select(undef,undef,undef, 0.005 ¦ $DELAY);
> Смотри также---------------------------------------------------------------------------------------------
Описание функций split и unpack в perlfunc(l); применение select для организации задержки объясняется в рецепте 3.10.
1.6. Обратная перестановка слов или символов
Проблема
Требуется изменить порядок символов или слов в строке на противоположный.
Решение
Для перестановки байтов воспользуйтесь функцией reverse в скалярном контексте:
Srevbytes = reverse($string);
Для перестановки слов воспользуйтесь reverse в списковом контексте с функциями split и join:
$revwords = join(" ", reverse split(" ", Sstring);
Комментарий
У функции reverse существуют два варианта применения. В скалярном контексте функция объединяет аргументы и возвращает полученную строку в обратном порядке. В списковом контексте функция возвращает аргументы в обратном порядке. При использовании reve rse для перестановки символов в неочевидной ситуации используйте функцию scalar для форсированного применения скалярного контекста.
1.6. Обратная перестановка слов или символов 39
Sgnirts = reverse($string); tt Перестановка символов $string Ssdrow = reverse(@words); tt Перестановка элементов @sdrow
Sconfused = reverse(@words); tt Перестановка букв в join("", ©words)
Приведем пример обратной перестановки слов в строке. Пробел (" ") в качестве шаблона split является особым случаем. Он заставляет split использовать в качестве разделителя смежные пропуски (whitespace) и отбрасывать начальные пустые поля (по аналогии с awk). Обычно split отбрасывает только конечные пустые поля.
П Обратная перестановка слов
$string = 'Yoda said, "can you see this?"';
@>allwords = split(" ", Sstring);
@revwords = join(" ", reverse @allwords);
print $revwords, "\n";
this?" see you "can said, Yoda
Временный массив @allwords можно убрать и сделать все в одной строке:
$revwords = ]oin(" ", reverse split(" ", $string);
Смежные пропуски в $string превращаются в один пробел в Srevwords. Что бы сохранить существующие пропуски, поступите так:
Srevwords = join("", reverse split (/(S+)/, $string));
С помощью функции reverse можно проверить, является ли слово палиндромом (то есть читается ли одинаково в обоих направлениях):
Sword = "reviver";
$is_palmdrome = (Sword eq reverse(Sword));
Программа для поиска длинных палиндромов в файле /usr/dict/words записывается в одну строку:
% perl -nle 'print if $_ eq reverse && length >5' /usr/dict/words deedeed
deified
denned
hallah
kakkak
murdrum
redder
repaper
retter
reviver
rotator
sooloos
tebbet
terret
tut-tut
Описание функций split, reverse и scalar в perlfunc(l); раздел «Switches» perlrun(l).
1.7. Расширение и сжатие символов табуляции
Проблема
Требуется преобразовать символы табуляции в строке в соответствующее количество пробелов, или наоборот. Преобразование пробелов в табуляцию сокращает объем файлов, имеющих много смежных пробелов. Преобразование символов табуляции в пробелы может понадобиться при выводе на устройства, которые не понимают символов табуляции или считают, что они находятся в других позициях.
Решение
Примените подстановку весьма странного вида:
while (Sstnng =" s/\t+/ x length($&) * 8 - length($ ) % 8)/e) { it Выполнять пустой цикл до тех пор, # пока выполняется условие подстановки
Также можно воспользоваться стандартным модулем Text::Tabs:
use Text Tabs,
@expanded_lmes = expand(@lines_with_tabs),
@>tabulated_lines = unexpand(<s>lines_without_tabs),
Комментарий
Если позиции табуляции следуют через каждые N символов (где N обычно равно 8), их несложно преобразовать в пробелы. В стандартном, «книжном» методе не используется модуль Text::Tabs, однако разобраться в нем непросто. Кроме того, в нем используется переменная $ , одно упоминание которой замедляет поиск по шаблону в программе. Причина объясняется в разделе «Специальные переменные» введения к главе 6.
while (о) {
1 while s/\t+/' ' х length($&) • 8 - length($ ) % 8)/e, print,
Вы смотрите на второй цикл while и не можете понять, почему его нельзя было включить в конструкцию s///g? Потому что вам приходится каждый раз заново пересчитывать длину от начала строки (хранящуюся в $'), а не от последнего совпадения.
Загадочная конструкция 1 while CONDITION эквивалентна while (CONDITION) {}, но более компактна. Она появилась в те дни, когда первая конструкция работала в Perl несравнимо быстрее второй. Хотя сейчас второй вариант почти не уступает по скорости, первый стал удобным и привычным.
Стандартный модуль Text::Tabs содержит функции преобразований в обоих направлениях, экспортирует переменную $tabstop, которая определяет число пробелов на символ табуляции. Кроме того, это не приводит к снижению быстродействия, потому что вместо $& и $ используются $1 и $2:
use Text Tabs,
Stabstop = 4,
while (<>) { print expand($_) }
Модуль Text::Tabs также может применяться для «сжатия» табуляции. В следующем примере используется стандартное значение $tabstop, равное 8:
use Text Tabs,
while (о) { print unexpand($_) }
> Смотри также---------------------------------------------------------------------------------------------
Страница руководства модуля Text::Tabs; описание оператора s/// Bperlre(l) и perlop(l).
1.8. Расширение переменных во входных данных
Проблема
Имеется строка, внутри которой присутствует ссылка на переменную: You owe $debt to me Требуется заменить имя переменной $debt в строке ее текущим значением.
Решение
Если все переменные являются глобальными, воспользуйтесь подстановкой с символическими ссылками:
$text =~s/\$(\w+)/${$1}/g,
Но если среди переменных могут встречаться лексические (ту) переменные, следует использовать /ее:
Stext =~ s/(\$\w+)/$1/gee,
Комментарий
Первый способ фактически сводится к следующему: мы ищем нечто похожее на имя переменной, а затем интерполируем ее значение посредством символического разыменования (dereferencing). Если $1 содержит строку somevar, то ${$1} будет равно содержимому Ssomevar. Такой вариант не будет работать при действую-
Приведем пример:
use vars qw($rows $cols);
no strict 'refs', # для приведенного ниже ${$1}
my $text;
($rows, $cols) = (24, 80);
$text = q(I am $ rows high and $cols long); # апострофы'
$text =- s/\$(\w+)/${$1}/g;
print $text,
1 am 24 high and 80 long
Возможно, вам уже приходилось видеть, как модификатор подстановки /е используется для вычисления заменяющего выражения, а не строки. Допустим, вам потребовалось удвоить каждое целое число в строке:
$text = ' I am 17 years old'; $text =- s/(\d+)/2 * $1/eg;
Перед запуском программы, встречая /е при подстановке, Perl компилирует код заменяющего выражения вместе с остальной программой, задолго до фактической подстановки. При выполнении подстановки $1 заменяется найденной строкой. В нашем примере будет вычислено следующее выражение:
2 * 17
Но если попытаться выполнить следующий фрагмент:
$text = 'I am $AGE years old'; # Обратите внимание на апострофы1
$text =~ s/(\$\w+)/$1/eg; # НЕВЕРНО
при условии, что $text содержит имя переменной $AGE, Per] послушно заменит $1 на $AGE и вычислит следующее выражение:
'$AGE
В результате мы возвращаемся к исходной строке. Чтобы получить значение переменной, необходимо снова вычислить результат. Для этого в строку добавляется еще один модификатор /е:
$text =~ s/(\$\w+)/$1/eeg; # Находит переменные глу()
Да, количество модификаторов /е может быть любым. Только первый модификатор компилируется вместе с программой и проверяется на правильность синтаксиса. В результате он работает аналогично конструкции eval {BLOCK}, хотя и не перехватывает исключений. Возможно, лучше провести аналогию с do {BLOCK}.
Остальные модификаторы /е ведут себя иначе и больше напоминают конструкцию eval "STRING". Они не компилируются до выполнения программы. Маленькое преимущество этой схемы заключается в том, что вам не придется вставлять в блок директиву no strict ' refs1. Есть и другое огромное преимущество: этот
механизм позволяет находить лексические переменные, созданные с помощью ту, — символическое разыменование на это не способно.
В следующем примере модификатор /х разрешает пропуски и комментарии в шаблоне подстановки, а модификатор /е вычисляет правостороннее выражение на программном уровне. Модификатор /е позволяет лучше управлять обработкой ошибок или других экстренных ситуаций:
# Расширить переменные в $text Если переменная не определена, й вставить сообщение об ошибке. $text =~ s{
\$ й Найти знак доллара
(\w+) и Найти "слово1 и сохранить его в $1
Н
no strict 'refs'; if (defined $$1) {
$$1; # Расширять только глобальные переменные
} else {
"[NO VARIABLE' \$$1]; й Сообщение об ошибке } }едх;
Обратите внимание на изменение синтаксиса $$1 в Perl 5.004; когда-то это выражение означало ${$}1, а теперь оно означает ${$1}. Для обеспечения обратной совместимости в строках оно сохраняет старый смысл (но выдает предупреждение с -w). Запись ${$1} используется в строках для того, чтобы предотвратить разыменование PID. Если значение $$ равно 23448, то $$1 в строке превращается в 234481, а не в значение переменной, имя которой хранится в $1.
> Смотри также---------------------------------------------------------------------------------------------
Описание оператора s/// в perlre(l) и perlop(l); описание функции eval в perlfunc(l). Аналогичное использование подстановок встречается в рецепте 20.9.
1.9. Преобразование регистра
Проблема
Строку с символами верхнего регистра необходимо преобразовать в нижний регистр, или наоборот.
Решение
Воспользуйтесь функциями 1с и ис со служебными командами \1_ и \U:
use locale; й Необходимо в 5.004 и выше
= uc($little); й "bo peep" -> "ВО PEEP" Slittle = lc($big); й "JOHN' -> "john"
Slittle = "\L$big"; # "JOHN" -> "john"
Для замены отдельного символа используйте функции lcfirst и ucfirst со служебными командами \1 и \и:
|
$big = ' |
¦\u$little"; |
# |
"bo" |
-> "Bo" |
|
$little |
= "\l$big"; |
# |
"BoPeep» |
-> "boPeep" |
Функции и служебные команды выглядят по-разному, но делают одно и то же. Допускается указание регистра как первого символа, так и целой строки. Вы даже можете форсировать применение верхнего регистра для первого символа и нижнего — для всех остальных.
Встречая директиву use locale, функции преобразования регистра Perl и механизм поиска по шаблону начинают «уважать» правила вашего национального языка. Благодаря ей становится возможным поиск символов с диакритическими элементами и т. д. Одна из распространенных ошибок — преобразование регистра с помощью t г///. Да, мы хорошо помним, что в одном из старых изданий этой книги рекомендовали использовать tr/A-Z/a-z/. В свое оправдание можем лишь сказать, что в то время другого способа не существовало. Такое решение работает не всегда, поскольку из него выпадают все символы с умляутами, седилями и прочими диакритическими элементами, встречающимися во многих языках. Команды преобразования регистра ис и \U понимают эти символы и обеспечивают их правильное преобразование (по крайней мере, если в программе присутствует директива use locale). Исключение составляет немецкий язык; символ Я в верхнем регистре выглядит как SS, но в Perl такое преобразование не поддерживается.
use locale;
$beast = "dromedary";
# Изменить регистр разных символов $beast-
Scapit = ucfirst($beast), # Dromedary
Scapit = "\u\L$beast"; # (то же)
Scapall = "uc($beast); # DROMEDARY
$capall = "\U$beast"; » (то же)
$caprest = lcfirst(uc($beast)); # dROMEOARY
$caprest = "\l\U$beast"; # (то же)
Как правило, служебные команды обеспечивают согласованное применение регистра в строке:
# Преобразовать первый символ каждого слова в верхний регистр,
# а остальные символы - в нижний
$text = "tHIS is a loNG UNE";
$text =~ s/(w+)/\u\L$1/g;
print $text;
This Is A Long Line
Ими также можно пользоваться для выполнения сравнений без учета регистра:
if (uc($a) eq uc($b)) {
print "a and b are the same\n', >
Программа randcap из примера 1.2 случайным образом преобразует в верхний регистр примерно 20 процентов вводимых символов. Пользуясь ей, можно свободно общаться с 14-летними WaREz dOODz.
Пример 1.2. randcap
ff1/usr/bin/perl -p
# randcap фильтр, который случайным образом
# преобразует к верхнему регистру 20% символов
# В версии 5.004 вызов srandQ необязателен
BEGIN {srand(time() " ($$ + ($$ « 15))) }
sub randcase { rand(100) < 20 ¦> '\u$_[0]" • M\l$_[0]" } s/(\w)/randcase($1)/ge;
% randcap < genesis | head -9 boOk 01 genesis
001:001 in the BEginning goD created the heaven and tHe earTH.
001:002 and the earth wAS without ForM, aNO void; AnO darkneSS was upon The Face of the dEEp. an the spirit of GOd movEd upOn tHe face of the Waters.
001:003 and god Said, let there be ligHt: and therE wAs LigHt.
Более изящное решение — воспользоваться предусмотренной в Perl возможностью применения поразрядных операторов для строк:
sub randcase {
rand(100) < 20 ? С\040' " $1) . $1 }
Этот фрагмент изменяет регистр примерно у 20 процентов символов. Однако для 8-разрядных кодировок он работает неверно. Аналогичная проблема существовала и в исходной программе randcase, однако она легко решалась применением директивы use locale.
Следующий пример поразрядных строковых операций быстро отсекает у всех символов строки старшие биты:
Sstring &= "\177" х length($string),
Впрочем, о человеке, ограничивающем строки 7-разрядными символами, будут говорить все окружающие — и не в самых лестных выражениях.
D> Смотри также------------------------------------------------------------------------------------------
Описание функций uc, lc, ucfirst и lcfirst в perlfunc(l); описание метасимволов \L, \U, \1 и \и в разделе «Quote and Quote-like Operators» perlop( 1).
Проблема
Требуется интерполировать вызов функции или выражение, содержащиеся в строке. По сравнению с интерполяцией простых скалярных переменных это позволит конструировать более сложные шаблоны.
Решение
Выражение можно разбить на отдельные фрагменты и произвести конкатенацию:
Sanswer = $var1 . func(). $var2; # Только для скалярных величин
Также можно воспользоваться неочевидными расширениями @{ [LIST EXPR]} mm${\(SCALAR EXPR)}:
Sanswer = "STRING @{[LIST EXPR]} MORE STRING" Sanswer = "STRING ${\(SCALAR EXPR)} MORE STRING",
Комментарий
В следующем фрагменте продемонстрированы оба варианта. В первой строке выполняется конкатенация, а во второй — фокус с расширением:
$phrase = "I have " . ($n + 1) "guanacos.", Sphrase = "I have ${\($n +1)} guanacos ",
В первом варианте строка-результат образуется посредством конкатенации более мелких строк; таким образом, мы добиваемся нужного результата без интерполяции. Функция print фактически выполняет конкатенацию для всего списка аргументов, и, если вы собираетесь вызвать print $phrase, можно было бы просто написать:
print "I have ", $n + 1 . "guanacos.\n",
Если интерполяция абсолютно неизбежна, придется воспользоваться вторым вариантом, изобилующим знаками препинания. Только символы @, $ и \ имеют особое значение в кавычках и обратных апострофах. Как и в случаях с т// и s///, синоним qx() не подчиняется правилам расширения для кавычек, если в качестве ограничителя использованы апострофы! $home = qx'echo home is $HOME'; возьмет переменную $НОМЕ из командного интерпретатора, а не из Perl! Итак, единственный способ добиться расширения произвольных выражений — расширить ${} или @{}, в чьих блоках присутствуют ссылки.
Однако вы можете сделать нечто большее, чем просто присвоить переменной значение, полученное в результате интерполяции. Так, в следующем примере мы конструируем строку с интерполированным выражением и передаем результат функции:
some_func("What you want is @{[ split /./, $rec ]} items");
Интерполяция может выполняться и во встроенных документах:
die "Couldn't send mail" unless send_mail(«"EOTEXT", Starget);
To: $naughty
From: Your bank
Cc: @{ get_manager_list($naughty) }
Date: @{[ do { my $now = 'date'; chomp $now; $now} ]} (today)
Dear Jnaughty,
Today, you bounced check number @{[ 500 + int rand(100) ]> to us. Your account is now closed.
Sincerely, the management EOTEXT
Расширение строк в обратных апострофах (' ') оказывается особенно творческой задачей, поскольку оно часто сопровождается появлением ложных символов перевода строки. Создавая блок в скобках за @ в разыменовании анонимного массива @{[]}, как это было сделано в последнем примере, вы можете создавать закрытые (private) переменные.
Все эти приемы работают, однако простое разделение задачи на несколько этапов или хранение всех данных во временных переменных почти всегда оказывается более понятным для читателя.
В версии 5.004 Perl в выражении ${\EXPR } значение EXPR ошибочно вычислялось в списковом, а не скалярном контексте. Ошибка была исправлена в версии 5.005.
> Смотри также---------------------------------------------------------------------------------------------
perlref(l).
1.11. Отступы во встроенных документах
Проблема
При использовании механизма создания длинных строк (встроенных документов) текст должен выравниваться вдоль левого поля; в программе это неудобно. Требуется снабдить отступами текст документа в программе, но исключить отступы из окончательного содержимого документа.
Решение
Воспользуйтесь оператором s/// для отсечения начальных пропусков:
# Все сразу
($var = <<HERE_TARGET) =" s/~\s+//gm; далее следует
48 Глава 1 • Строки
ваш текст HERE_TARGET# Или за два этапа $var = «HERE_TARGET;
далее следует
ваш текст HERE_TARGET $var =~ s/"\s+//gm;
Комментарий
Подстановка получается весьма прямолинейной. Она удаляет начальные пропуски из текста встроенного документа. Модификатор /гп позволяет символу " совпадать с началом каждой строки документа, а модификатор /д заставляет механизм поиска повторять подстановку с максимальной частотой (то есть для каждой строки встроенного документа).
(Sdefimtion = «'FINIS') ="s/~\s+//gm,
The five variations of caraelids
are the familiar camel, his frieds
the llama and the alpaca, and the
rather less well-known guanaco
and vicuca. FINIS
Учтите: во всех шаблонах этого рецепта используется модификатор \s, разрешающий совпадение с символами перевода строки. В результате из встроенного документа будут удалены все пустые строки. Если вы не хотите этого, замените в шаблонах \s на [~\S\n].
В подстановке используется то обстоятельство, что результат присваивания может использоваться в левой стороне =~. Появляется возможность сделать все в одной строке, но она работает лишь при присвоении переменной. При непосредственном использовании встроенный документ интерпретируется как неизменяемый объект, и вы не сможете модифицировать его. Более того, содержимое встроенного документа нельзя изменить без предварительного сохранения его в переменной.
Впрочем, для беспокойства нет причин. Существует простой обходной путь, особенно полезный при частом выполнении этой операции. Достаточно написать подпрограмму:
sub fix {
my Sstring = shift; $strmg =~ s/~\s+//gm; return Sstring;
print fix(«"END");
Наш документ END
1.11. Отступы во встроенных документах 49
# Если функция была объявлена заранее, скобки можно опустить: print fix « 'END";
Наш документ END
Как и во всех встроенных документах, маркер конца документа (END в нашем примере) должен быть выровнен по левому полю. Если вы хотите снабдить отступом и его, в документ придется добавить соответствующее количество пропусков:
(Squote = «' FINIS') ="s/"\s+//gm;
. we will have peace, when you and all you works have perished--and the works of your dark master to whom you would deliver us You are a liar, Saruman, and a corrupter of men's hearts. --Theoden in /usr/src/perl/taint.c
FINIS Squote =~ s/\s+--/\n--; # Перенести на отдельную строку
Если эта операция выполняется с документами, содержащими программный код для eval или просто выводимый текст, массовое удаление всех начальных пропусков нежелательно, поскольку оно уничтожит отступы в тексте. Конечно, это безразлично для eval, но не для читателей.
Мы подходим к следующему усовершенствованию — префиксам для строк, которые должны снабжаться отступами. Например, в следующем примере каждая строка начинается с @@@ и нужного отступа:
if ($REMEMBER_THE_MAIN) <
$perl_main_C = dequote«' MAIN_INTERPRETER_LOOP';
@@@ mt
@@@ runops() {
@@@ SAVEI32(runlevel);
@@@ runlevel++,
@@@ while ( op = (*op->op_ppaddr)() ) ;
@@@ TAINT.N0T;
@@@ return 0;
@@@ >
MAIN_INTERPRETER_LOOP # При желании добавьте дополнительный код }
При уничтожении отступов также возникают проблемы со стихами.
sub dequote;
$poem = dequote«EVER_ON_AND_ON;
Now far ahead the Road has gone, And I must follow, if I can, Pursuing it with eager feet,
Until it joins some larger way Where may paths and errands meet. And whither then9 I cannot say.
--Bilbo in /usr/src/perl/pp_ctl. с
print "Here's your poem:\n\n$poem\n ';
Результат будет выглядеть так:
Here's your poem:
Now far ahead the Road has gone,
And I must follow, if I can, Pursuing it with eager feet,
Until it joins some larger way Where may paths and errands meet.
And whither then? I cannot say.
--Bilbo in /usr/src/perl/pp_ctl.c
Приведенная ниже функция dequote справляется со всеми описанными проблемами. При вызове ей в качестве аргумента передается встроенный документ. Функция проверяет, начинается ли каждая строка с общей подстроки (префикса), и если это так — удаляет эту подстроку. В противном случае она берет начальный пропуск из первой строки и удаляет его из всех последующих строк.
sub dequote {
local $_ = shift;
my ($white, $leader); # пропуск и префикс, общие для всех строк
if (/"\s*C:(["\w\s]+)(\s*).An)('?-\s«\1\2''.An)+$/) < (Swhite, $leader) = ($2, quotemeta($1));
} else {
($white, $leader_ = (/"(\s+)/, '');
}
s/"\s*'?$leader(?:$white)V/gm,
return $_; }
Если при виде этого шаблона у вас стекленеют глаза, его всегда можно разбить на несколько строк и добавить комментарии с помощью модификатора /х:
if (m{
# начало Строки
\s * # 0 и более символов-пропусков
(?: # начало первой несохраненной группировки
( й начать сохранение $1
[~\w\s] # один байт - не пробел и не буквенный символ
+ # 1 или более
) # закончить сохранение $1
( \s* ) # занести 0 и более пропусков в буфер $2
. * \п # искать до конца первой строки
) # конец первой группировки
(?: # начало второй несохраненной группировки
\s • # 0 и более символов-пропусков
\1 # строка, предназначенная для $1
\2 ? # то, что будет в $2, но дополнительно
.* \п # искать до конца строки
) + # повторить идею с группами 1 и более раз
$ й до конца строки
}х
(Swhite, Sleader) = ($2, quotemeta($1));
} else {
($white, Sleader) = (/~(\s+)/, ");
}
s{
# начало каждой строки (из-за /m)
\s * # любое количество начальных пропусков
9 # с минимальным совпадением
$leader # сохраненный префикс
(7 # начать несохраненную группировку
$white # то же количество
) ? # если после префикса следует конец строки
}{}xgm;
Разве не стало понятнее? Пожалуй, нет. Нет смысла уснащать программу банальными комментариями, которые просто дублируют код. Возможно, перед вами один из таких случаев.
> Смотри также---------------------------------------------------------------------------------------------
Раздел «Scalar Value Constructors» perldata(l); описание оператора s/// в perlre( 1) и perlop( 1).
1.12. Переформатирование абзацев
Проблема
Длина текста не позволяет разместить его в одной строке. Требуется разделить его на несколько строк без переноса слов. Например, сценарий проверки стиля читает текстовый файл по одному абзацу и заменяет неудачные обороты хорошими. Замена оборота «применяет функциональные возможности» словом «использует» приводит к изменению количества символов, поэтому перед выводом абзаца его придется переформатировать.
Решение
Воспользуйтесь стандартным модулем Text::Wrap для расстановки разрывов строк в нужных местах:
use Text:.Wrap;
©OUTPUT = wrap($LEADTAB, $NEXTTAB, @PARA);
Комментарий
В модуле Text::Wrap присутствует функция wrap (см. пример 1.3), которая получает список строк и переформатирует их в абзац с длиной строки не более $Text. :Wrap: : columns символов. Мы присваиваем переменной $columns значение 20; это гарантирует, что ни одна строка не будет длиннее 20 символов. Перед
Пример 1.3. wrapdemo
#'/usr/bin/perl -w
# wrapdemo - демонстрация работы Text Wrap
@input = ( Folding and splicing is the work of an editor , not a mere collection of silicon , and , mobile electrons1 )
use Text Wrap qw($columns Swrap),
$columns = 20,
print 0123456789 x 2 \n ,
print wrap( , , @input) \n ,
Результат выглядит так:
01234567890123456789
Folding and splicing is the work of an editor, not a mere collection of silicon and mobile electrons'
В результате мы получаем один абзац, в которой каждая строка, кроме последней, завершается символом перевода строки:
й Объединение нескольких строк с переносом текста
use Text Wrap,
undef $/,
print wrap( , split(/\s*\n\s*/, <>),
Если на вашем компьютере установлен модуль Term::ReadKey с CPAN, вы можете воспользоваться им для определения размеров окна, чтобы длина строк соответствовала текущему размеру экрана. Если этого модуля нет, размер экрана иногда можно взять из $ENV{COLUMNS} или определить по выходным данным команды stty.
Следующая программа переформатирует и слишком короткие, и слишком длинные строки абзаца по аналогии с программой fmt. Для этого разделителем входных записей $/ назначается пустая строка (благодаря чему о читает целые абзацы), а разделителем выходных записей $\ — два перевода строки. Затем абзац преобразуется в одну длинную строку посредством замены всех символов перевода строки (вместе с окружающими пропусками) одиночными пробелами. Наконец, мы вызываем функцию wrap с пустыми отступами первой и всех последующих строк.
use Text Wrap qw(&wrap $columns),
use Term ReadKey qw(GetTerminalSize),
($columns) = GetTerminalSize(),
($/, $\) = ( , \n\n ), ft Читать по абзацам, выводить два перевода строки
while (о) { # Читать весь абзац
s/\s*\n\s*/ /g, # Заменить промежуточные переводы строк пробелами
print wrap( ', '', $_), # и отформатировать
> Смотри также---------------------------------------------------------------------------------------------
Описание функций split и join вperlfunc(l), страница руководства стандартного модуля Text::Wrap. Применение модуля Term::ReadKey с CPAN продемонстрировано в рецепте 15.6.
1.13. Служебные преобразования символов
Проблема
Некоторые символы выводимой строки (апострофы, запятые и т. д.) требуется преобразовать к специальному виду. Предположим, вы конструируете форматную строку для sprintf и хотите преобразовать символы % в %%.
Решение
Воспользуйтесь подстановкой, которая снабжает префиксом \ или удваивает каждый преобразуемый символ:
# Обратная косая черта
$var =" s/([CHARLIST])/\\$1/g,
# Удвоение
$var =" s/([CHARLIST])/$1$1/g,
Комментарий
В приведенных выше решениях $var — модифицируемая переменная, a CHARLIST — список преобразуемых символов, который может включать служебные комбинации типа \t или \п. Если преобразуется всего один символ, можно обойтись без скобок:
$stnng ="
Преобразования, выполняемые в следующем примере, позволяют подготовить строку для передачи командному интерпретатору. На практике преобразование символов и " еще не сделает произвольную строку полностью безопасной для командного интерпретатора. Правильно собрать весь список символов так сложно, а риск так велик, что для запуска программ лучше воспользоваться списковыми формами system и exec (см. рецепт 16.11) — в этом случае вы вообще избегаете взаимодействия с интерпретатором.
Две обратные косые черты в секции заменителя были использованы потому, что эта секция интерпретируется по правилам для строк в кавычках. Следовательно, чтобы получить одну обратную косую черту, приходится писать две. Приведем аналогичный пример для VMS DCL, где дублируются все апострофы и кавычки:
$stnng = q(Mom said, "Don't do that."), Istring =" s/(["'])/$1$1/g;
С командными интерпретаторами Microsoft дело обстоит еще сложнее. В DOS и Windows COMMAND. COM работает с кавычками, но не с апострофами; не имеет представления о том, как поступать с обратными апострофами, а для превращения кавычек в литерал используется обратная косая черта. Почти все бесплатные или коммерческие Unix-подобные интерпретаторы для Windows пытаются исправить эту удручающую ситуацию.
Кроме того, можно определить интервал с помощью символа -, а затем инвертировать его с помощью символа ". Следующая команда преобразует все символы, не входящие в интервал от А до Z:
Sstring =" s/([-A-Z])/\\$1/g,
Для преобразования всех неалфавитных символов следует воспользоваться метасимволами \Q и \Е или функцией quotemeta. Например, следующие команды эквивалентны:
$stnng = "this \Qis a test1 \E"; $string = "this is\\ a\\ test1"; $string = "this " . quotemeta("is a test!'),
> Смотри также---------------------------------------------------------------------------------------------
Описание оператора s/// в perlre(l) и perlop(l); описание функции quotemeta рассматривается вperlfunc(l). В рецепте 19.1 рассматривается преобразование служебных символов в HTML, а в рецепте 19.6 — о том, как обойтись без передачи интерпретатору строк со служебными символами.
1.14. Удаление пропусков в обоих концах строки
Проблема
В полученную строку могут входить начальные или конечные пропуски. Требуется удалить их.
Решение
Воспользуйтесь парой подстановок:
$stnng =~ s/"\s+//; Sstring =" s/\s+$//;
Также можно написать специальную функцию, которая возвращает нужное значение:
$stnng = trim( $stnng); @many = trim(@many);
sub trim {
my @out = @_, for (@out) {
s/-\s+//;
s/\s+$//; } return wantarray ' @out $out[0];
Комментарий
У этой проблемы имеются различные решения, однако в большинстве случаев приведенный вариант является наиболее эффективным.
Для удаления последнего символа из строки воспользуйтесь функцией chop. В версии 5 была добавлена функция chomp, которая удаляет последний символ в том и только в том случае, если он содержится в переменной $/ (по умолчанию — "\п"). Чаще всего она применяется для удаления завершающего символа перевода строки из введенного текста:
# Вывести полученный текст заключенным в >< while(<STDIN>) {
chomp;
print ">$_<\n",
> Смотри также---------------------------------------------------------------------------------------------
Описание оператора s/// врег1ге(1) иperlop(l); описание функций chop и chomp вperlfunc(i). Начальные пропуски удаляются в функции getnum из рецепта 2.1 и при разделении элементов списка в рецепте 4.1.
1.15. Анализ данных, разделенных запятыми
Проблема
Имеется файл данных, поля которого разделены запятыми. Однако в полях могут присутствовать свои запятые (находящиеся внутри строк или снабженные служебными префиксами). Многие электронные таблицы и программы для работы с
Решение
Воспользуйтесь следующей процедурой:
sub parse_csv {
my $text = shift; # Запись со значениями, разделенными запятыми
my @new = ();
push(@new, $+) while $text =~ m{
# Первая часть группирует фразу в кавычках
I , }gx;
push(@new, undef) if substr($text, -1,1) eq ','; return @new, # Список значений, которые разделялись запятыми }
Также можно воспользоваться стандартным модулем Text: Parse Words:
use Text:.ParseWords,
sub parse_csv {
return quoteword( ',' ,0, $_[0], }
Комментарий
Ввод данных, разделенных запятыми, — коварная и непростая задача. Все выглядит просто, но в действительности приходится использовать довольно сложную систему служебных символов, поскольку сами поля могут содержать внутренние запятые. В результате подстановка получается весьма сложной, а простая функция split /, / вообще исключается.
К счастью, модуль Text::ParseWords скрывает от вас все сложности. Передайте функции qoutewords два аргумента и строку разделенных данных. Первый аргумент определяет символ-разделитель (в данном случае — запятая), а второй — логический флаг, который показывает, должна ли возвращаемая строка содержать внутренние кавычки.
Если кавычки должны присутствовать внутри поля, также ограниченного кавычками, воспользуйтесь префиксом \: "like \"this\". Кавычки, апострофы и обратная косая черта — единственные символы, для которых этот префикс имеет специальное значение. Все остальные экземпляры \ остаются в итоговой строке.
Ниже показан пример использования процедуры parse_csv. q<> — всего лишь хитроумный заменитель кавычек, благодаря которому нам не придется расставлять повсюду символы \.
$line = q<XYZZY, ""/O'Reilly, Inc'/'Wall, LarryVa \"glug\" bit,", 5,
"Error, Core Dumped">, ©fields = parse_csv($line), for ($1 = 0,$i < ©fields; $i++)
print "$i . $fields[$i]\n";
XYZZY
O'Reilly, Inc
Wall, Larry
a \"glug\" bit,
5
Error, Core Dumped
> Смотри также---------------------------------------------------------------------------------------------
Описание синтаксиса регулярных выражений в perlre{\); документация по стандартному модулю Text::ParseWords.
1.16. Сравнение слов с похожим звучанием
Проблема
Имеются две английские фамилии. Требуется узнать, звучат ли они похожим образом (независимо от написания). Это позволит выполнять неформальный поиск в телефонной книге, в результатах которого наряду со Smith будут присутствовать и другие похожие имена — например, Smythe, Smite и Smote.
Решение
Воспользуйтесь стандартным модулем Text::Soundex:
use Text .Soundex;
$CODE = soundex($STRING); ©CODES = soundex(iaLIST);
Комментарий
Алгоритм soundex хэширует слова (особенно английские фамилии) в небольшом пространстве с использованием простой модели, имитирующей произношение по правилам английского языка. Грубо говоря, каждое слово сокращается до че-тырехсимвольной строки. Первый символ является буквой верхнего регистра, а прочие — цифры. Сравнивая значения для двух строк, можно определить, звучат ли они похожим образом.
Следующая программа предлагает ввести имя и ищет в файле паролей имена с похожим звучанием. Аналогичный подход может использоваться для баз данных имен, поэтому при желании можно индексировать базу данных по ключам soundex. Конечно, такой индекс не будет уникальным.
print "Lookup user: "; chomp($user = <ST0IN>); exit unless defined $user; $name_code = soundex($user);
while($uent = getpwentO) {
(Sfirstname, $lastname) = $uent->gecos =" /(w+)[~,]*\b(\w+)/;
if ($name_code eq soundex($uent->name) ||
$name_code eq soundex($$lastname) 11
$name_code eq soundex($firstname) )
{
printf "%s: %s %s\n", $uent->name, Sfirstname, $lastname;
t> Смотри также--------------------------------------------------------------------------------------------
Документация по стандартным модулям Text::Soundex и User::pwent; man-страница passwd(5) вашей системы; «Искусство программирования», том 3, глава 6.
1.17. Программа: fixstyle
Представьте себе таблицу с парами устаревших и новых слов. Старые слова Новые слова
|
bonnet |
hood |
|
rubber |
eraser |
|
lorrie |
truck |
|
trousers |
pants |
При вызове без файловых аргументов программа выполняет функции простого фильтра. Если в командной строке передаются имена файлов, то в них помещаются результаты, а прежние версии сохраняются в файлах с расширениями *.orig (см. рецепт 7.9). При наличии параметра командной строки -v сообщения обо всех изменениях записываются в STDERR.
Таблица пар «исходное слово/заменитель» хранится в основной программе, на
чиная с_ END (см. рецепт 7.6). Каждая пара преобразуется в подстановку и на
капливается в переменной $code так же, как это делается в программе popgrep2 из
рецепта 6.10.
Параметр -t выводит сообщение об ожидании ввода с клавиатуры при отсутствии других аргументов. Если пользователь забыл ввести имя файла, он сразу поймет, чего ожидает программа.
Пример 1.4. fixstyle
#!/usr/bin/perl -w
# fixstyle - замена строк секции <DATA> парными строками
# использование: $0 [-v] [файлы...]
use strict;
my Sverbose = (@ARGV && $ARGV[O] eq '-v' && shift);
if (@ARGV) {
$"I = ".orig"; # Сохранить старые файлы } else {
warn "$0: Reading from stdin\n" if -t STDIN;
my $code = "while (<>) {\n";
# Читать данные и строить код для eval
while (<OATA>) {
chomp;
my ($in, $out) = split /\s*=>\s*/;
next unless $in && $out;
$code .= "s{\\Q$in\\E}{$out}g";
$code .= "&& printf STDERR qq($in => $out at \$ARGV line \$.\\n)M
if $verbose;
$code .= ";\n";
|
$code .= "printf; |
\n}\n"; |
|
|
eval "{ code } |
1" |
II 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-charac |
|
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 |
В примере 1.5 приведена следующая версия программы. При малом количестве замен она работает медленнее, а при большом — быстрее.
Пример 1.5. fixstyle2
#'/usr/bin/perl -w
0 fixstyle2 = аналог fixstyle для большого количества замен
use strict
my Sverbose = (@ARGV && $ARGV[O] eq -v && shift),
my $change = (),
while (<DATA>) {
chomp,
my ($m, $out) = split /\s*=>\s«/,
next unless $in && $out,
$change{$in} = $out, } if (@ARGV) {
$"I = orig , } else {
warn $0- Reading from stdm\n if -t STDIN,
while (<>) { my $i =0,
s/~(\s+)// && print $1, 0 Выдать начальный пропуск for (split /(\s+)/, $_, -1) {
pnnt( ($i++ & 1) ? $_ ($change{$J || $_)),
|
_ END__ |
||
|
analysed |
=> |
analyzed |
|
built-in |
=> |
builtm |
|
chastized |
=> |
chastised |
|
commandlme |
=> |
command-line |
|
de-allocate |
=> |
deallocate |
|
dropin |
=> |
drop-in |
|
hardcode |
=> |
hard-code |
|
meta-data |
=> |
metadata |
|
multicharacter |
=> |
multi-character |
|
multiway |
=> |
multi-way |
|
non-empty |
=> |
nonempty |
1.18. Программа: psgrep 61
non-profit => nonprofit
non-trappable => nontrappable
pre-define => predefine
preextend => pre-extend
re-compilmg => recompiling
reenter => re-enter
turnkey => turn-key
В новой версии программы каждая строка разбивается на пропуски и слова (относительно медленная операция). Затем слова используются для поиска замены в хэше, что выполняется существенно быстрее подстановки. Следовательно, первая часть работает медленнее, а вторая — быстрее. Выигрыш в скорости зависит от количества совпадений.
Если бы мы не старались сохранить количество пропусков, разделяющих слова, нетрудно сделать так, чтобы вторая версия не уступала первой по скорости даже при небольшом количестве замен. Если вам хорошо известны особенности входных данных, пропуски можно заменить одиночными пробелами. Для этого применяется следующий цикл:
U Работает очень быстро, но со сжатием пропусков while (о) {
for (split) {
print $change{$_} || $_,
}
print \n ,
>
В конце каждой строки появляется лишний пробел. Если это нежелательно, воспользуйтесь методикой рецепта 16.14 и создайте входной фильтр. Вставьте следующий фрагмент перед циклом while, сжимающим пропуски:
my $pid = open(STDOUT, |= ),
die cannot fork $' unless defined $pid,
unless ($pid) {
while (<STDIN>) {
s/ $//,
print,
>
exit,
1.18. Программа: psgrep
Многие программы (в том числе ps, netstat, Is —I, find -Is и tcpdump) часто выдают большие объемы данных. Файлы журналов тоже быстро увеличиваются в размерах, что затрудняет их просмотр. Такие данные можно обработать программой-фильтром типа дгер и отобрать из них лишь часть строк, однако регулярные выражения плохо согласуются со сложной логикой — достаточно взгляну 1Ь па ухищрения, на которые приходится пускаться в рецепте 6.17.
Программа psg rep умеет делать все это и бесконечно большее, потому что в ней критерии отбора не являются регулярными выражениями; они состоят из полноценного кода Perl. Каждый критерий последовательно применяется к каждой строке вывода. В результате выводятся лишь те данные, которые удовлетворяют всем аргументам. Ниже приведены примеры критериев поиска и соответствующие лм командные строки.
• Строки со словами, заканчивающимися на sh:
% psgrep '/sh\b/'
• Процессы с именами команд, заканчивающимися на sh:
% psgrep 'command =" /sh$/'
• Процессы с идентификатором пользователя, меньшим 10:
% psgrep 'uid < 10'
• Интерпретаторы с активными консолями:
% psgrep 'command =~ '/"-/' 'tty ne ">"'
• Процессы, запущенные на псевдоконсолях:
% psgrep 'tty =' /-[p-t]'
• Отсоединенные непривилегированные процессы:
% psgrep 'uid && tty eq "?"'
• Большие непривилегированные процессы:
% psgrep 'size > 10 * 2**10' 'uid ' = 0'
Ниже показаны данные, полученные при последнем вызове psgrep на нашем компьютере. Как и следовало ожидать, в них попал только netscape и его вспомогательный процесс:
|
FLAGS |
UID |
PID |
|
0 |
101 |
9751 |
|
100000 |
101 |
9752 |
1 0 0 14932 9652 do_select S p1 0:25 netscape 9751 0 0 10636 812 do_select S p1 0:00 (dns
helper)
В примере 1.6 приведен исходный текст программы psgrep. Пример 1.6. psgrep
#' /usr/bin/perl -w
• psgrep - фильтрация выходных данных ps
8 с компиляцией пользовательских запросов в программный код #
1.18. Программа: psgrep 63
use strict;
# Все поля из заголовка PS
my ©fieldnames = qw( FLAGS UID PID PPID PRI NICE SIZE RSS WCHAN STAT TTY TIME COMMAND),
# Определение формата распаковки (в примере
# жестко закодирован формат ps для Linux)
my $fmt = cut2fmt(8, 14, 20, 26, 30, 34, 41, 47, 59, 63, 67, 72);
my %fields; # Для хранения данных
die «Thanatos unless §ARGV; usage: $0 criterion ...
Each criterion is a Perl expression involving:
©fieldnames
All criteria must be met for a line to be printed Thanatos
# Создать синонимы для uid, size, UID, SIZE и т д.
# Пустые скобки необходимы для создания прототипа без аргументов
for my $name (©fieldname) {
no strict 'refs';
•name = *{lc $name} = sub () { $fields{$name} };
my $code = "sub is_desirable { " jom(" and ", @ARGV) ' } '; unless (eval $code.1) {
die "Error in code: $@\n\t$code\n";
open (PS, "ps wwaxl |") || die "cannot fork. $! ';
print scalar <PS>, # Строка-заголовок
while (<PS> {
(5>fields{@fieldnames} = tnm(unpack($fmt, $_));
print if is_desirable(); # Строки, удовлетворяющие критериям
}
close(PS) 11 die "ps failed!";
# Преобразовать позиции разреза в формат распаковки sub cut2fmt {
my(@positions) = @_; my Stemplate = ' '; my Slastpos = 1; foreach $place(positions) {
$template .= "A" . ($place - $lastpos) . " "; Slastpos = $place; } Stemplate .= "A*";
продолжение ¦&
return $template;
sub trim {
my §out = @_; for (@out) <
s/\s+$//; } return wantarray ? @out :
Dut[0];
# Следующий шаблон использовался для определения позиций разреза.
# Далее следует пример входных данных#123456789012345678901234567890123456789012345678901234567890123456789012345
1
|
26 30 34 I I I |
Позиции:
| 14 |
| 20 |
| 41 |
| 59 63 67 72 |
| I |
| I |
|
_ END
FLAGS
100 140 100100 100140 |
STA TTY TIME COMMAND
| UID О О 101 |
| PID 1 187 428 |
| PPID PRI |
| 0 1 1 |
|
99 30217 101 593 101 30639 101 25145 0 10116 |
|
402 426 9562 9563 9564 |
| 100000 |
О 0 1552 1008 posix.lock S ? 0:00 httpd
О 0 1780 1260 copy.thread S 1 0:00 -tcsh
17 0 924 496 R p1 0:00 ps axl
| 0 |
| 100100 100100 100000 |
| О 26560 26554 101 19058 9562 |
ся в главе 16 «Управление процессами и межпроцессные взаимодействия», особенно в рецептах 16.10 и 16.13.
Настоящая сила и выразительность psgrep обусловлены тем, что в Perl строковые аргументы могут представлять собой не просто строки, а программный код Perl. Похожий прием использован в рецепте 9.9, за исключением того, что в psgrep аргументы пользователя «упакованы» в процедуру is_desirable. При этом компиляция строк в код Perl выполняется всего один раз — еще перед запуском той программы, чей вывод мы обрабатываем. Например, при запросе UID ниже 10 будет сгенерирована следующая строка:
eval "sub is_desirable { uid < 10 } " . 1;
Загадочное . 1 в конце присутствует для того, чтобы при компиляции пользовательского кода команда eval возвращала истинное значение. В этом случае нам даже не придется проверять $@ на предмет ошибок компиляции, как это делается в рецепте 10.12.
Использование произвольного кода Perl в фильтрах для отбора записей — невероятно мощная возможность, но она не является абсолютно оригинальной. Perl многим обязан языку программирования awk, который часто применялся для подобной фильтрации. Один из недостатков awk заключался в том, что он не мог легко интерпретировать входные данные в виде полей фиксированной длины (вместо полей, разделенных особыми символами). Другой недостаток — отсутствие мнемонических имен полей; в awk использовались имена $1, $2 и т. д. К тому же Perl может делать многое такое, на что не способен awk.
Пользовательские критерии даже не обязаны быть простыми выражениями. Например, следующий вызов инициализирует переменную $id номером пользователя nobody и затем использует ее в выражении:
% psgrep 'no strict "vars";
BEGIN { $id = getpwnam("nobody") } uid == $id '
Но как использовать эти слова, uid, command и size, даже не снабжая их символом $ для представления соответствующих полей входных записей? Мы напрямую манипулируем с таблицей символов, присваивая замыкания (closures) неявным тип-глобам (typeglobs), которые создают функции с соответствующими именами. Замыкания описаны в рецепте 11.4, а их присвоение тип-глобам для создания синонимов функций — в рецепте 10.14.
Однако в psgrep встречается нюанс, отсутствующий в этих рецептах, — речь идет о пустых скобках в замыкании. Благодаря скобкам функция может использоваться в выражениях везде, где допускается отдельная величина (например, строка или числовая константа). В результате создается пустой прототип, а функция обращения к полю (например, uid) вызывается без аргументов, по аналогии со встроенной функцией time. Если не создать для функций пустые прототипы, выражения "uid < 10" или "size / 2 > rss" приведут в замешательство синтаксический анализатор — он увидит в них незаконченный глоб (wildcard glob) или шаблон поиска. Прототипы рассматриваются в рецепте 10.11.
Показанная версия psgrep получает входные данные от команды ps в формате Red Hat Linux. Чтобы перенести ее в другую систему, посмотрите, в каких столб-
После небольшого изменения в функциях отбора программа даже подойдет для работы с пользовательской базой данных. Если у вас имеется массив записей (см. рецепт 11.9), пользователь может указать произвольный критерий отбора:
sub _
sub titleO { $_->{TITLE} }
sub executive { title ="/(' vice-)?president/i }
# Критерии отбора указываются при вызове grep @slowburners = grep { id < 10 && 'executive } ©employees,
По причинам, связанным с безопасностью и быстродействием, такой подход редко встречается в реальных механизмах, описанных в главе 14 «Базы данных». В частности, он не поддерживается в SQL, но имея в своем распоряжении Perl и некоторую долю изобретательности, нетрудно создать свой собственный вариант. Подобная методика использована в поисковой системе http://mox. perl.com/ cgi-bin/MxScreen, но вместо получения данных от ps записи представляют собой хэши Perl, загружаемые из базы данных
Числа
Каждый, кто занимается математическими
методами получения случайных чисел,
несомненно, впадает в грех
Джон фон Нейман (1951)
Введение
Числа составляют основные типы данных практически в любом языке программирования, однако даже с ними могут возникнуть неожиданные сложности. Случайные числа, числа с дробной частью, числовые последовательности и преобразования строк в числа — все это вызывает немалые затруднения.
Perl старается по возможности облегчить вам жизнь, и его средства для работы с числами не являются исключением из этого правила. Если скалярное значение интерпретируется в программе как число, то Perl преобразует его в числовую форму. Читаете ли вы числовые данные из файла, извлекаете отдельные цифры из строки или иным образом получаете числа из бесчисленных текстовых источников Внешнего Мира, — вам не приходится преодолевать препятствия в виде неудобных ограничений других языков на пути преобразования ASCII-строк в числа.
Если строка используется в числовом контексте (например, в математическом выражении), Perl старается интерпретировать ее как число, однако у него нет возможности сообщить о том, что строка в действительности не соответствует числу. Встречая не-числовой символ, Perl прекращает интерпретацию строки, при этом не-числовые строки считаются равными нулю, поэтому "А7" преобразуется в О, а 7 А — в 7 (хотя флаг -w предупредит вас о некорректных преобразованиях). Иногда (например, при проверке вводимых данных) требуется узнать, соответствует ли строка числу. Мы покажем как это делается в рецепте 2.1.
В рецепте 2.16 объясняется, как получить число из строк с шестнадцатерич-ными или восьмеричными представлениями чисел — например, Oxff . Perl автоматически преобразует литералы в программном коде (поэтому $а = 3 + Oxff присвоит $а значение 258), но это не относится к данным, прочитанным программой. Вы не можете прочитать Oxff в $b и затем написать $а = 3 + $Ь, чтобы присвоить $а 258.
Числа, прочитанные из файла или встретившиеся в программе в виде литералов, преобразуются из десятичного представления (например, 0.1) во внутреннее. Невозможно точно представить 0.1 в виде двоичного числа с плавающей запятой — подобно тому, как 1/3 невозможно точно представить в виде конечного десятичного числа. Следовательно, двоичное представление 0.1 в действительности отличается от 0.1. Для 20 десятичных разрядов оно равно 0.10000000000000000555.
При выполнении арифметических операций с двоичными представлениями чисел с плавающей запятой накапливаются ошибки. Значение выражения 3*0.1 не совпадает с двоичной кодировкой числа 0.3. Это означает, что числа с плавающей запятой в Perl нельзя просто сравнивать с помощью ==. Работе с ними посвящены рецепты 2.2 и 2.3.
В рецепте 2.4 показано, как преобразовать ASCII-строку с двоичным представлением числа (например, "1001") в целое (9 для приведенного примера) и обратно. Рецепт 2.5 описывает три способа выполнения некоторой операции с каждым элементом последовательного множества целых чисел. Преобразование чисел в римскую запись и обратно продемонстрировано в рецепте 2.6.
Случайным числам посвящено сразу несколько рецептов. Функция Perl rand возвращает число с плавающей запятой от 0 до 1 или от 0 до своего аргумента. Мы покажем, как получить случайное число в конкретном интервале, как сделать их «еще более случайными» и как заставить rand генерировать новый набор случайных чисел при каждом запуске программы.
Глава завершается рецептами, относящимися к тригонометрии, логарифмам, умножению матриц, комплексным числам. Заодно вы найдете ответ на часто встречающийся вопрос: «Как включить в выводимое число запятую?»
2.1. Проверка строк на соответствие числам
Проблема
Требуется проверить, соответствует ли строка допустимому числу. Эта проблема часто возникает при проверке входных данных (например, в сценариях CGI).
Решение
Сравните строку с регулярным выражением, которое совпадает со всеми интересующими вас разновидностями чисел:
2.1. Проверка строк на соответствие числам 69
if ($strmg =- /PATTERN/) { # является числом
> else {
tt не является числом
Комментарий
Все зависит от того, что именно понимать под числом. Даже простые на первый взгляд понятия — например, целое — заставят вас поломать голову над тем, какие строки следует отнести к этой категории. Например, что делать с начальным + для положительных чисел? Разрешить, сделать обязательным или запретить? А числа с плавающей запятой представляются таким огромным количеством способов, что у вас в голове перегреется процессор.
Сначала решите, какие символы допустимы, а какие — нет. Затем сконструируйте для отобранных символов регулярное выражение. Ниже приведены некоторые стандартные конструкции для самых распространенных ситуаций (что-то вроде полуфабрикатов для нашей поваренной книги).
# Содержит нецифровые символы
warn "has nondigits" if /\0/;
# He является натуральным числом
warn "not a natural number" unless /"\d+$/; # Отвергает -3
# He является целым числом
warn "not an integer" unless /"-?\d+$/; # Отвергает +3 warn "not an integer" unless /"[+-]9\d+$/;
# He является десятичным числом
warn "not a decimal number" unless /"-Ad+X^VM/; * Отвергает .2 warn "not a decimal number" unless /"-?(?:d+(?:\.\d)?|\.\d+)$/; tt He является вещественным числом С warn "not a C float"
unless /¦([+-]?)(?=\d|\.\d)\d*(V\d*)?([Ee]([+-p\d+))?$/;
В этих шаблонах не обрабатываются особые случаи Infinity и NaN в записи IEEE. Если вы не боитесь, что члены комитета IEEE придут к вашему компьютеру и начнут бить вас по голове копиями соответствующих стандартов, вероятно, об этих странных «числах» можно забыть.
Для строк с начальными или конечными пробелами эти шаблоны не подходят. Либо вставьте в них соответствующую логику, либо вызовите функцию trim из рецепта 1.14.
В POSIX-системах Perl поддерживает функцию POSIX: :strtod. Ее семантика чрезвычайно громоздка, поэтому мы приведем функцию getnum для упрощения доступа. Эта функция получает строку и возвращает либо преобразованное число, либо undef для строк, не соответствующих вещественным числам С. Интерфейсная функция is_numeric упрощает вызов getnum в ситуациях, когда вы просто хотите спросить: «Это вещественное число»?
sub getnum {
use POSIX qw(strtod);
$str =~ s/\s+$//,
$i=0
my($num, Sunparsed) = strtod($str),
if (($str eq ") || (Sunparsed '=0) || $') {
return, } else {
return $num,
}
sub is_numeric { defined scalar &getnum }
> Смотри также------------------------------------------------------------------------
Описание синтаксиса регулярных выражений в perlre(i); страница руководства strtod(3); документация по стандартному модулю POSIX.
2.2. Сравнение чисел с плавающей запятой
Проблема
Арифметика с плавающей запятой не является абсолютно точной. Сравнивая два числа, вы хотите узнать, совпадают ли они до определенного десятичного разряда. Как правило, именно так следует сравнивать числа с плавающей запятой.
Решение
Воспользуйтесь функцией sprintf и отформатируйте числа до определенного десятичного разряда, после чего сравните полученные строки:
# equal(NUM1, NUM2, ACCURACY), возвращает true если NUM1 и NUM2
# совпадают на ACCURACY десятичных разрядов
sub equal {
my ($A $B, $dp) = @_,
return sprintf( % ${dp}g , $A) eq sprintf( % ${dp}g , $A), }
Альтернативное решение — преобразовать числа в целые, умножая их на соответствующий коэффициент.
Комментарий
Процедура equal понадобилась из-за того, что в компьютерах многие числа с плавающей запятой представляются с ограниченной точностью. Дополнительная информация приведена в разделе «Введение».
При фиксированном количестве цифр в дробной части (например, в денежных суммах) проблему можно решить преобразованием в целое число. Если
сумма 3.50 будет храниться в виде 350, а не 3.5, необходимость в числах с плавающей запятой отпадает. Десятичная точка снова появляется в выводимых данных:
Swage = 536, # $5 36/час
$week = 40 • Swage, в $214 40
printf( One week's wage is \$% 2f\n Sweek/100),
One week's wage is: $214.40
Редко требуется сравнивать числа более чем до 15 разряда.
> Смотри также---------------------------------------------------------------------------------------------
Описание функции sprintf вperifunc(\); описание переменной $# в странице руководства perlvariX); документация по стандартному модулю Math::BigFloat. Функция sprintf используется в рецепте 2.3. Также обращайтесь к разделу 4.2.2 тома 2 «Искусство программирования».
2.3. Округление чисел с плавающей запятой
Проблема
Число с плавающей запятой требуется округлить до определенного разряда. Проблема связана с теми же погрешностями представления, которые затрудняют сравнение чисел (см. рецепт 2.2), а также возникает в ситуациях, когда точность ответа намеренно снижается для получения более наглядного результата.
Решение
Для получения непосредственного вывода воспользуйтесь функциями Perl sprintf
или printf:
Srounded = sprintf( %FORMATf , Sun rounded),
Комментарий
Округление серьезно отражается на работе некоторых алгоритмов, потому используемый метод должен быть точно указан. В особо важных приложениях (например, в финансовых вычислениях или системах наведения ракет) грамотный программист реализует свою собственную функцию округления, не полагаясь на встроенную логику языка (или ее отсутствие).
Однако во многих ситуациях можно просто воспользоваться функцией sprintf. Формат f позволяет указать количество разрядов, до которого округляется аргумент. Perl округляет последний разряд вверх, если следующая цифра равна 5 и более, и вниз в противном случае.
$b = spnntf("%.2f", $a);
print "Unrounded: $a\nRounded: %.2f\n", $a,
Unrounded: 0.255 Rounded: 0.26 Unrounded: 0.255 Rounded: 0.26
Существуют три функции, предназначенные для округления чисел с плавающей запятой до целых: int, ceil и floor. Встроенная функция Perl int возвращает целую часть числа с плавающей запятой (при вызове без аргумента она использует $_). Функции модуля POSIX floor и ceil округляют аргументы вверх и вниз, соответственно, до ближайшего целого.
use POSIX;
print "number\tint\floor\tceil\n",
@a = { 3.3 , 3.5 , 3.7 , -3.3}; foreach (@a) {
printf( "% ,1f\t% ,1f\t% ,1f\t% .1f\n", $_, int($_), floor($_), ceil($_) );
|
number |
int |
floor |
ceil |
|
3.3 |
3.0 |
3.0 |
4.0 |
|
3.5 |
3.0 |
3.0 |
4.0 |
|
3.7 |
3.0 |
3.0 |
4.0 |
|
-3.3 |
-3.0 |
-4.0 |
-3.0 |
|
> Смотри также---- |
2.4. Преобразования между двоичной и десятичной системами счисления
Проблема
Имеется десятичное число, которое необходимо вывести в двоичном представлении, или наоборот, двоичная последовательность, которую требуется преобразовать в десятичное число. Такие задачи часто возникают при отображении не-текстовых данных — например, полученных в процессе взаимодействия с некоторыми системными функциями и программами.
Чтобы преобразовать целое число Perl в строку, состоящую из единиц и нулей, сначала упакуйте его в сетевой формат "N" (с начальным старшим байтом), а затем снова распакуйте по одному биту (формат "В32 ").
sub dec2bm {
my $str = unpack("B32", pack("N", shift));
$str =" s/"0+('=\d)//; » В противном случае появятся начальные нули
return $str;
Чтобы преобразовать строку из единиц и нулей в целое число Perl, дополните ее необходимым количеством нулей, а затем выполните описанную выше процедуру в обратном порядке:
sub bin2dec {
return unpack("N', pack("B32\ substr('O" x 32 shift, -32)));
Комментарий
Речь идет о преобразовании чисел между строками вида "00100011" и десятичной системой счисления (35). Строка содержит двоичное представление числа. На этот раз функция spnntf не поможет: в ней не предусмотрен формат для вывода чисел в двоичной системе счисления. Следовательно, нам придется прибегнуть к функциям Perl pack и unpack для непосредственных манипуляций со строковыми данными.
Функции pack и unpack предназначены для работы со строками. Строки можно интерпретировать как последовательности битов, байты, целые, длинные целые, числа с плавающей запятой в представлении IEEE, контрольные суммы — не говоря уже о многом другом. Обе функции, pack и unpack, по аналогии со spnntf получают форматную строку, которая определяет выполняемые с аргументом операции.
Мы используем pack и unpack для интерпретации строк как последовательностей битов и двоичного представления целого числа. Чтобы понять, каким образом строка интерпретируется как последовательность битов, необходимо хорошо разобраться в поведении функции pack. Строка интерпретируется как последовательность байтов, состоящих из восьми бит. Байты всегда нумеруются слева направо (первые восемь бит образуют первый байт, следующие восемь бит — второй и т. д.), однако внутри каждого байта биты могут нумероваться как слева направо, так и справа налево.
Функция pack с шаблоном "В" работает с битами каждого байта, пронумерованными слева направо. Именно в этом порядке они должны находиться для применения формата "N", которым мы воспользуемся для интерпретации последовательности битов как 32-разрядного целого.
' $num = bin2dec('0110110') # $num = 54
$binstr = dec2bin(54); # $binstr = 110110
Проблема
Требуется выполнить некоторую операцию со всеми целыми между X и Y. Подобная задача возникает при работе с непрерывной частью массива или в любой ситуации, когда необходимо обработать все числа1 из заданного интервала.
Решение
Воспользуйтесь циклом for или .. в сочетании с циклом f о reach:
foreach ($X . $Y) {
# $_ принимает все целые значения от X до Y включительно
foreach $i ($X .. $Y) {
# $i принимает все целые значения от X до Y включительно
foreach ($1 = $Х; $i <= $Y; $i++) {
# $i принимает все целые значения от X до Y включительно
foreach ($i = $X; $1 <= $Y; $i+=7) {
# $i принимает целые значения от X до Y включительно с шагом 7
Комментарий
В первых двух методах используется конструкция $Х. . $Y, которая создает список всех целых чисел между $Х и $Y. Если $Х и $Y расположены далеко друг от друга, это приводит к большим расходам памяти (исправлено в версии 5.005). При организации перебора последовательных целых чисел цикл for из третьего способа расходует память более эффективно.
В следующем фрагменте продемонстрированы все три способа. В данном случае мы ограничиваемся выводом сгенерированных чисел:
print "Infancy is:"; foreach (0 .. 2) { print "$_ ";
}
print "\n";
print "Toddling is: "; foreach $i (3 .. 4) {
print "$i "; } print "\n";
print "Childhood is: ";
for ($1 = 5; $i <= 12; $i++) <
print "$i "; > print "\n";
Infancy is: 0 1 2
Toddling is: 3 4
Childhood is: 5 6 7 8 9 10 11 12
Смотри также
Описание операторов for и foreach в perlsyn(l).
2.6. Работа с числами в римской записи
Проблема
Требуется осуществить преобразование между обычными числами и числами в римской записи. Такая необходимость часто возникает при оформлении сносок и нумерации страниц в предисловиях.
Решение
Воспользуйтесь модулем Roman с CPAN:
use Roman;
$roman = roman($arabic); # Преобразование
# в римскую запись
$arabic = arabic($roman) if isroman($roman); # Преобразование
# из римской записи
Комментарий
Для преобразования арабских («обычных») чисел в римские эквиваленты в модуле Roman предусмотрены две функции, Roman и roman. Первая выводит символы в верхнем регистре, а вторая — в нижнем.
Модуль работает только с римскими числами от 1 до 3999 включительно. В римской записи нет отрицательных чисел или нуля, а для числа 5000 (с помощью которого представляется 4000) используется символ, не входящий в кодировку ASCII.
use Roman;
$roman_fifteen = roman(15); # "xv"
print "Roman for fifteen is $roman_fifteen\n";
$arabic_fifteen = arabic($roman_fifteen);
print "Converted back, $roman_fifteen is $arabic_fifteen\n";
Roman for fifteen is xv
Converted back, xv is 15
Документация по модулю Roman; рецепт 6.23.
2.7. Генератор случайных чисел
Проблема
Требуется генерировать случайные числа в заданном интервале — например, чтобы выбрать произвольный элемент массива, имитировать бросок кубика в игре или сгенерировать случайный пароль.
Решение
Воспользуйтесь функцией Perl rand. $random = int( rand( $Y-$X+1 ) ) + $X;
Комментарий
Следующий фрагмент генерирует и выводит случайное число в интервале от 25 до 75 включительно:
$random = int( rand(51)) + 25; print "$random\n";
Функция rand возвращает дробное число от 0 (включительно) до заданного аргумента (не включается). Мы вызываем ее с аргументом 51, чтобы случайное число было больше либо равно 0, но никогда не было бы равно 51 и выше. Затем от сгенерированного числа берется целая часть, что дает число от 0 до 50 включительно (функция int превращает 50,9999... в 50). К полученному числу прибавляется 25, что дает в результате число от 25 до 75 включительно.
Одно из распространенных применений этой методики — выбор случайного элемента массива:
$elt = $array[ rand ©array ];
Также она часто используется для генерации случайного пароля из заданной последовательности символов:
@chars = ( "А" .. 7", "а" .. "г", 0 .. 9, qw(% ! @ $%"&*)); Spassword = jom("", @chars[ map { rand @chars } ( 1 .. 8 ) ]);
Мы генерируем восемь случайных индексов @chars с помощью функции тар, извлекаем соответствующие символы в виде среза и объединяем их в случайный пароль. Впрочем, в действительности пароль получается не совсем случайным — безопасность вашей системы зависит от стартового значения (seed) генератора случайных чисел на момент запуска программы. В рецепте 2.8 показано, как «раскрутить» генератор случайных чисел и сделать генерируемые числа более случайными.
О Смотри также
Описание функций int, rand и join Bperlfunc(l). Случайные числа исследуются в рецептах 2.8—2.10, а используются — в рецепте 1.9.
2.8. Раскрутка генератора случайных чисел
Проблема
При каждом запуске программы вы получаете один и тот же набор «случайных» чисел. Требуется «раскрутить» генератор, чтобы Perl каждый раз генерировал разные числа. Это важно практически для любых применений случайных чисел, особенно для игр.
Решение
Воспользуйтесь функцией Perl srand: srand EXPR;
Комментарий
Генерация случайных чисел — непростое дело. Лучшее, на что способен компьютер без специального оборудования, — генерация псевдослучайных чисел, равномерно распределенных в области своих значений. Псевдослучайные числа генерируются по математическим формулам, а это означает, что при одинаковом стартовом значении генератора две программы сгенерируют одни и те же псевдослучайные числа.
Функция srand задает новое стартовое значение для генератора псевдослучайных чисел. Если она вызывается с аргументом, то указанное число будет использовано в качестве стартового. При отсутствии аргумента srand использует величину, значение которой трудно предсказать заранее (относится к Perl 5.004 и более поздним версиям; до этого использовалась функция time, значения которой совсем не были случайными). Не вызывайте srand в программе более одного раза.
Если вы не вызвали srand сами, Perl версий 5.004 и выше вызывает srand с «хорошим» стартовым значением при первом запуске rand. Предыдущие версии этого не делали, поэтому программы всегда генерировали одну и ту же последовательность чисел. Если вы предпочитаете именно такое поведение, вызывайте srand с конкретным аргументом:
srand( <STOIN> );
То, что Perl старается выбрать хорошее стартовое значение, еще не гарантирует криптографической безопасности сгенерированных чисел от усердных попыток взлома. Информацию о построении надежных генераторов случайных чисел можно найти в учебниках по криптографии.
t> Смотри также--------------------------------------------------------------------------------------------
Описание функции srand Bperlfunc(l). Примеры ее применения приведены в рецептах 2.7 и 2.9.
Проблема
Требуется генерировать случайные числа, которые были бы «более случайными», чем выдаваемые генератором Perl. Иногда возникают проблемы, связанные с ограниченным выбором стартовых значений в библиотеках С. В некоторых приложениях последовательность псевдослучайных чисел начинает повторяться слишком рано.
Решение
Воспользуйтесь другими генераторами случайных чисел — например, теми, которые присутствуют в модулях Math::Random и Math::TrulyRandom с CPAN:
use Math::TrulyRandom;
Srandom = truly_random_value();
use Math_Random;
$random = random_unifonn();
Комментарий
Для генерации случайных чисел в Perl используется стандартная библиотечная функция С rand(3) (впрочем, на стадии компоновки это можно изменить). Некоторые реализации функции rand возвращают только 16-разрядные случайные числа или используют слабые алгоритмы, не обеспечивающие достаточной степени случайности.
Модуль Math::TrulyRandom генерирует случайные числа, используя погрешности системного таймера. Процесс занимает некоторое время, поэтому им не стоит пользоваться для генерации большого количества случайных чисел.
Модуль Math::Random генерирует случайные числа с помощью библиотеки randlib. Кроме того, он содержит многочисленные вспомогательные функции.
О Смотри также--------------------------------------------------------------------------------------------
Описание функций srand и rand в perlfunc(l); рецепты 2.7—2.8; документация по модулям Math::Random и Math::TrulyRandom с CPAN.
2.10. Генерация случайных чисел
с неравномерным распределением
Проблема
Требуется генерировать случайные числа в ситуации, когда одни значения появляются с большей вероятностью, чем другие (неравномерное распределение). Допустим, вы отображаете на своей Web-странице случайный баннер и у вас имеется набор весовых коэффициентов, определяющих частоту появления того или
Решение
Если вам потребовались случайные величины, распределенные по конкретному закону (допустим, по закону Гаусса), загляните в учебник по статистике и найдите в нем нужную функцию или алгоритм. Следующая функция генерирует случайные числа с нормальным распределением, со стандартным отклонением 1 и нулевым математическим ожиданием.
sub gaussian_rand {
my ($u1, $u2); # Случайные числа с однородным распределением
my $w; # Отклонение, затем весовой коэффициент
my ($g1, $g2); # Числа с гауссовским распределением
do {
$u1 = 2 * rand() - 1;
$u2 = 2 * rand() - 1;
$w = $u1*$u1 + $u2»u2 } while ($w >= 1);
$w = sqrt( (-2 * log($w)) / $w); $g2 = $u1 * $w; $g1 = $u2 * $w;
# Возвратить оба числа или только одно return wantarray ? ($g1, $g2) : $g1; }
Если у вас есть список весовых коэффициентов и значений и вы хотите выбирать элементы списка случайным образом, выполните два последовательных шага. Сначала превратите весовые коэффициенты в вероятностное распределение с помощью приведенной ниже функции weight_to_dist, а затем воспользуйтесь функцией weighted_rand для случайного выбора чисел.
# weight_to_dist: получает хэш весовых коэффициентов
# и возвращает хэш вероятностей
sub weight_to_dist {
my %weights = @>_; my %dist =(); my $total = 0; my ($key, Sweight); local $_;
foreach (values %weights) { $total += $_;
while ( ($key, Sweight) = each %weights ) { $dist{$key} = $weight/$total;
# weighted_ran: получает хэш вероятностей 8 и возвращает случайный элемент хэша sub weighted_rand {
my %dist = @_;
my ($key, $weight);
while (1) { # Чтобы избежать погрешностей вычислений
# с плавающей запятой (см. ниже), ray $rand = rand,
while ( ($кеу, $weight) = each %dist ) { return $key if ($rand -= $weight) <0;
Комментарий
Функция gaussian_rand реализует полярный метод Бокса—Мюллера для преобразования двух независимых случайных чисел с однородным распределением, лежащих в интервале от 0 до 1 в два числа с математическим ожиданием 0 и стандартным отклонением 1 (то есть распределенных по закону Гаусса). Чтобы сгенерировать числа с другим математическим ожиданием и стандартным отклонением, умножьте выходные данные gaussian_rand на нужное стандартное отклонение и прибавьте математическое ожидание:
# gaussian_rand - см. выше
$mean = 25;
$sdev = 2;
Ssalary - gaussian_rand() * $sdev + $mean;
printf("You have been hired at \$%.2f\n", Ssalary);
Функция weighted_rand получает случайное число из интервала от 0 до 1. Затем она использует вероятности, сгенерированные weight_to_dist, и определяет, какому элементу соответствует это случайное число. Из-за погрешностей представления с плавающей запятой накопленные ошибки могут привести к тому, что возвращаемый элемент не будет найден. Поэтому код размещается в цикле while, который в случае неудачи выбирает новое случайное число и делает очередную попытку.
Кроме того, модуль Math::Random с CPAN содержит функции, генерирующие случайные числа для многих распределений.
t> Смотри также--------------------------------------------------------------------------------------------
Описание функции rand в perlfunc(l); рецепт 2.7; документация по модулю Math::Random с CPAN.
2.11. Выполнение тригонометрических вычислений в градусах
Проблема
Требуется, чтобы в тригонометрических функциях использовались градусы вместо стандартных для Perl радианов.
Решение
Создайте функции для преобразований между градусами и радианами (2я радиан соответствуют 360 градусам).
BEGIN {
use constant PI => 3.14159265358979;
sub deg2rad {
my $degrees = shift;
return (Sdegrees / 180) • PI;
sub rad2deg {
my $radians = shift;
return (Sradians / PI) - 180;
Также можно воспользоваться модулем Math::Trig:
use Math::Trig;
$radians = deg2rad($degrees); Sdegrees = rad2deg($radians);
Комментарий
Если вам приходится выполнять большое количество тригонометрических вычислений, подумайте об использовании стандартных модулей Math::Trig или POSIX. В них присутствуют дополнительные тригонометрические функции, которых нет в стандартном Perl. Другой выход заключается в определении приведенных выше функций rad2deg и deg2rad. В Perl нет встроенной константы я, однако при необходимости ее можно вычислить настолько точно, насколько позволит ваше оборудование для вычислений с плавающей запятой. В приведенном выше решении п является константой, определяемой командой use constant. Синус угла, заданного в градусах, вычисляется следующим образом:
# Функции deg2rad и rad2def приведены выше или взяты из Math::Trig sub degree_sine {
my Sdegrees = shift;
return $result,
> Смотри также------------------------------------------------------------------------
Описание функций sin, cos и atan2 в perlfunc(l); стандартная документация по модулям POSIX и Math::Tng.
2.12. Тригонометрические функции
Проблема
Требуется вычислить значения различных тригонометрических функций — таких как синус, тангенс или арккосинус.
Решение
В Perl существуют лишь стандартные тригонометрические функции sin, cos и atan2. С их помощью можно вычислить тангенс (tan) и другие тригонометрические функции:
sub tan {
my $theta = shift,
return sin($theta)/cos($theta), }
В модуле POSIX представлен расширенный набор тригонометрических функций:
use POSIX,
$у = acos(3 7),
Модуль Math::Trig содержит полный набор тригонометрических функций, а также позволяет выполнять операции с комплексными аргументами (или дающие комплексный результат):
use Math Trig, $у = acos(3 7),
Комментарий
Если значение $theta равно л/2, Зп/2 и т. д., в функции tan возникает исключительная ситуация деления на ноль, поскольку для этих углов косинус равен нулю. Аналогичные ошибки возникают и во многих функциях модуля Math::Trig. Чтобы перехватить их, воспользуйтесь конструкцией eval:
eval {
$у = tan($pi/2), } or return undef,
t> Смотри также--------------------------------------------------------------------------------------------
Описание функций sin, cos и atan2 вperlfunc(l). Тригонометрия в контексте комплексных чисел рассматривается в рецепте 2.15, а использование eval для перехвата исключений — в рецепте 10.12.
2.13. Вычисление логарифмов
Проблема
Требуется вычислить логарифм по различным основаниям.
Решение
Для натуральных логарифмов (по основанию е) существует встроенная функция log:
$log_e = log(VALUE),
Чтобы вычислить логарифм по основанию 10, воспользуйтесь функцией log 10 модуля POSIX:
use POSIX qw(log10), $log_10 = Iog10(VALUE),
Для других оснований следует использовать соотношение:
1одл(х) = 1одв(х)/1оде(п)
где х — число, логарифм которого вычисляется, п — нужное основание, а е — основание натуральных логарифмов.
sub log_base {
my ($base, $value) = @_, return log($value)/log($base),
Комментарий
Функция log_base позволяет вычислять логарифмы по любому основанию. Если основание заранее известно, намного эффективнее вычислить его натуральный логарифм заранее и сохранить для последующего использования, вместо того чтобы каждый раз пересчитывать его заново.
# Определение log_base см выше
$answer = log_base(10, 10, 10_000),
print Iog10(10,100) = $answer\n ,
Iog10(10,000) = 4
use Math::Complex;
printf "Iog2(1024) = %lf\n", logn(1024, 2); S Обратите внимание
# на порядок аргументов' Iog2(1024) = 10.000000
хотя комплексные числа в вычислениях не используются. Функция не очень эффективна, однако в будущем планируется переписать Math::Complex на С для повышения быстроты.
> Смотри также------------------------------------------------------------------------
Описание функции log вperlfunc(i); документация по стандартному модулю POSIX.
2.14. Умножение матриц
Проблема
Требуется перемножить два двумерных массива. Умножение матриц часто используется в математических и инженерных вычислениях.
Решение
Воспользуйтесь модулями PDL с CPAN. Модули PDL (Perl Data Language, то есть «язык данных Perl») содержат быстрые и компактные матричные и математические функции:
use PDL;
# $а и $b - объекты pdl
$с = $а * $Ь;
Альтернативный вариант — самостоятельно реализовать алгоритм умножения матриц для двумерных массивов:
sub mmult {
my ($m1,$m2) = @_;
my ($m1rows,$m1cols) = matdim($m1);
my ($m2rows,$m2cols) = matdim($m2);
unless ($m1cols == $m2rows) { # Инициировать исключение
die "IndexError: matrices don't match; $m1cols != $m2rows";
my $result = []; my ($i, $], $k),
for $i (range($m1rows)) { for $] (range($m2cols)) { for $k (range($m1cols)) {
2.14. Умножение матриц 85
$result->[$i][$]] += $m1->[$i][$k] ¦ $m2->[$k][$j];
return $result;
sub range {0 .. ($_[0] - 1 }
sub veclen {
my $ary_ref = $_[O];
my type = ref $ary_ref;
if ($type ne "ARRAY") {die "$type is bad array ref for $ary_ref" }
return scalar(@$ary_ref);
sub raatdim {
my $matnx = $_[0];
my $rows = veclen($matnx);
my $cols = veclen($matrix->[0]);
return ($rows, $cols),
Комментарий
Если у вас установлена библиотека PDL, вы можете воспользоваться ее молниеносными числовыми операциями. Они требуют значительно меньше памяти и ресурсов процессора, чем стандартные операции с массивами Perl. При использовании объектов PDL многие числовые операторы (например, + и *) перегружаются и работают с конкретными типами операндов (например, оператор * выполняет так называемое скалярное умножение). Для умножения матриц используется перегруженный оператор х.
use PDL;
$а = pdl [
[ 3, 2, 3 ], [ 5, 9, 8 ],
$b = pdl [
[ 4, 7 ],
[ 9, 3 ],
[ 8, 1 ],
$c = $a x $b; # Перегруженный оператор x
Если библиотека PDL недоступна или вы не хотите привлекать ее для столь тривиальной задачи, матрицы всегда можно перемножить вручную:
$х = [
[ 3, 2, 3 ], [ 5, 9, 8 ],
$У = [
[ 4, 7 ],
[ 9, 3 ],
[ 8, 1 ],
$z = mult($x, $y);
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулю PDL с CPAN.
2.15. Операции с комплексными числами
Проблема
Ваша программа должна работать с комплексными числами, часто используемыми в инженерных, научных и математических расчетах.
Решение
Либо самостоятельно организуйте хранение вещественной и мнимой составляющих комплексного числа, либо воспользуйтесь классом Math::Complex (из стандартной поставки Perl).
Ручное умножение комплексных чисел
# $с = $а • $Ь - моделирование операции
$c_real = ( $a_real * $b_real ) - ($a_imaginary ¦ $b_imaginary ); $c_imagmary = ( $a_real * $b_itnaginary ) - ($b_real • $a_imaginary );
Math::Complex
# Умножение комплексных чисел с помощью Math::Complex
use Math::Complex;
$c = $a * $b;
Комментарий
Ручное умножение комплексных числа 3+5i и 2-2i выполняется следующим образом:
$a_real = 3; $a_imaginary =5; # 3 + 5i;
$b_real = 2; $b_imaginary = -2; # 2 - 2i;
$c_real = ($a_real * $b_real ) - ( $a_imaginary ¦ $b_imaginary );
$c_imaginary = ($a_real • $b_imagmary ) - ( $b_real • $a_imaginary );
2.16 Преобразования восьмеричных и шестнадцатеричных чисел 87
print "с = ${c_real}+${c_imaginary}i\n";
с = 16+4i
То же с применением модуля Math::Complex:
use Math:iComplex;
$a = Math:;Complex->new(3, 5);
$b = Math::Complex->new(2,-2);
$c = $a * $t>;
print "c = $c\n";
с = 16+41
Версия 5. 004 позволяет создавать комплексные числа с помощью конструкции cplx или экспортированной константы i:
use Math::Complex;
$c = cplx(3,5) * cplx(2,-2); # Лучше воспринимается
$d = 3 + 4*i; #3+4i
printf "sqrt($d) = %s\n", sqrt($d);
sqrt(3+4i) = 2+i
В исходном варианте модуля Math::Complex, распространяемом с версией 5.003, не перегружаются многие функции и операторы версии 5.004. Кроме того, Math::Complex используется модулем Math::Trig (появившимся в версии 5.004), поскольку некоторые функции могут выходить за пределы вещественной оси в комплексную плоскость — например, арксинус 2.
Смотри также
Документация по стандартному модулю Math::Complex.
2.16. Преобразования восьмеричных и шестнадцатеричных чисел
Проблема
Требуется преобразовать строку с восьмеричным или шестнадцатеричным представлением (например, "0x55" или "0755") в правильное число.
Perl воспринимает лишь те восьмеричные и шестнадцатеричные числа, которые встречаются в программе в виде литералов. Если числа были получены при чтении из файла или переданы в качестве аргументов командной строки, автоматическое преобразование не выполняется.
Решение
Воспользуйтесь функциями Perl oct и hex:
$number = hex($hexadecimal); # Шестнадцатеричное число
$number = oct($octal); # Восьмеричное число
Функция oct преобразует восьмеричные числа как с начальными нулями, так и без них ( 0350" и "350"). Более того, она даже преобразует шестнадцатеричные числа, если у них имеется префикс "Ох". Функция hex преобразует только шестнадцатеричные числа с префиксом "Ох" или без него — например, "0x255", "ЗА", "ff" или "deadbeef" (допускаются символы верхнего и нижнего регистров).
Следующий пример получает число в десятичной, восьмеричной или шестна-дцатеричной системе счисления и выводит его во всех трех системах счисления. Для преобразования из восьмеричной системы используется функция oct. Если введенное число начинается с 0, применяется функция hex. Затем функция printf при выводе преобразует число в десятичную, восьмеричную и шестнадцатерич-ную систему:
print Gimme a number in decimal, octal, or hex , $num = <STOIN>, chomp $num,
exit unless defined $num,
$num = oct($num) is $num =~ /"0/, # Обрабатывает как восьмеричные,
# так и шестнадцатеричные числа printf %d %x %o\n , $num, $num, $num,
Следующий фрагмент преобразует режимы доступа к файлам UNIX. Режим всегда задается в восьмеричном виде, поэтому вместо hex используется функция oct:
print Enter file permission in octal ',
Spermissions = <STDIN>,
die Exiting \n unless defined $permissions,
chomp Spermissions,
Spermissions = oct($permissions), # Режим доступа всегда задается
# в восьмеричной системе print The decimal value is $permissions\n',
О Смотри также------------------------------- .------------------------------------------------------------
Раздел «Scalar Value Constructors» вperldata(l); описание функций oct и hex в perlfunc(l).
2.17. Вывод запятых в числах
Проблема
При выводе числа требуется вывести запятые после соответствующих разрядов. Длинные числа так воспринимаются намного лучше, особенно в отчетах.
Решение
Обратите строку, чтобы перебирать символы в обратном порядке, — это позволит избежать подстановок в дробной части числа. Затем воспользуйтесь регулярным
выражением, найдите позиции для запятых и вставьте их с помощью подстановки. Наконец, верните строку к исходному порядку символов.
sub commify {
my $text = reverse $_[0],
$text =" s/(\d\d\d)(?=\d)("\d.\ )/$1 /g,
return scalar reverse $text;
Комментарий
Регулярные выражения намного удобнее использовать в прямом, а не в обратном направлении. Учитывая этот факт, мы меняем порядок символов в строке на противоположный и вносим небольшие изменения в алгоритм, который многократно вставляет запятые через каждые три символа от конца. Когда все вставки будут выполнены, порядок символов снова меняется, а строка возвращается из функции. Поскольку функция reverse учитывает косвенный контекст возврата, мы принудительно переводим ее в скалярный контекст.
Функцию нетрудно модифицировать так, чтобы вместо запятых разряды разделялись точками, как принято в некоторых странах.
Пример использования функции commify выглядит так:
# Достоверный счетчик обращений -)
use Math TrulyRandom,
$hits = truly_random_value(), # Отрицательное значение1
$output = 'Your web page received $hits accesses last month \n",
print commify($output),
Your web page received -1,740,525,205 accesses last month.
> Смотри также---------------------------------------------------------------------------------------------
perllocale(l); описание функции reverse в perlfunc(l).
2.18. Правильный вывод во множественном числе
Проблема
Требуется вывести фразу типа: "It took $time hours" («Это заняло $time часов»). Однако фраза «It took I hours» («Это заняло 1 часов») не соответствует правилам грамматики. Необходимо исправить ситуацию1.
Решение
Воспользуйтесь printf и тернарным оператором X?Y: Z, чтобы изменить глагол или существительное.
printf "%d hour%s %s enough.\n", $time, $time == 1 ? "" : "s"; $time == 1 ? "is" : "are";
Кроме того, можно воспользоваться модулем Lingua::EN::Inflect с CPAN, упоминаемым в комментарии.
Комментарий
Невразумительные сообщения вроде "1 f ile(s) updated" встречаются только из-за того, что автору программы лень проверить, равен ли счетчик 1.
Если образование множественного числа не сводится к простому добавлению суффикса s, измените функцию printf соответствующим образом:
printf "It took %d centur%s", $time, $time == 1 ? "y" : "ies";
В простых ситуациях такой вариант подходит, однако вам быстро надоест писать его снова и снова. Возникает желание написать для него специальную функцию:
sub noun_plural { local $_ = shift; # Порядок проверок крайне важен!
s/ss$/sses/ 11
s/([psc]h)$/${1}es/ ||
s/z$/zes/ 11
s/ff/$/ffs/ 11
s/f$/ves/ ||
s/ey$/eys/ 11
s/y$/ies/ ч 11
s/ix$/ices/ ||
s/([sx])$/$1es/ ||
s/$/s/ I|
die "can't get here"; • return $_;
¦verb_singular = \&noun_plural; # Синоним функции
Однако со временем будут находиться новые исключения и функция будет становиться все сложнее и сложнее. Если у вас возникнет потребность в подобных морфологических изменениях, воспользуйтесь универсальным решением, которое предлагает модуль Lingua:EN::Inflect от CPAN.
use Lingua::EN::Inflect qw(PL classical);
classical(1); # Почему не сделать по умолчанию?
while (<DATA>) { # Каждая строка данных for (split) { # Каждое слово в строке print "One $_, two", PL($_), ",\n";
# И еще один вариант
$_ = 'secretary general';
print "One $_, two ", PL($_), ".\n";
__END__ fish fly ox species genus jockey index matrix mythos phenomenon formula
Результат выглядит так:
One fish, two fish.
One fly, two flies.
One ox, two oxen.
One species, two species.
One genus, two genera.
One phylum, two phyla.
One cherub, two cherubim.
One radius, two radii.
One jockey, two jockeys.
One index, two indices.
One matrix, two matrices.
One mythos, two mythoi.
One phenomenon, two phenomena.
One formula, two formulae.
One secretary general, two secretaries general.
Мы рассмотрели лишь одну из многих возможностей модуля. Кроме того, он обрабатывает склонения и спряжения для других частей речи, содержит функции сравнения без учета регистра, выбирает между использованием а и an и делает многое другое.
> Смотри также---------------------------------------------------------------------------------------------
Описание тернарного оператора выбора в perlop(l); документация по модулю Lingua::EN::Inflect с CPAN.
2.19. Программа: разложение на простые множители
Следующая программа получает один или несколько целых аргументов и раскладывает их на простые множители. В ней используется традиционное числовое представление Perl, кроме тех ситуаций, когда представление с плавающей запятой может привести к потере точности. В противном случае (или при запуске с параметром -Ь) используется стандартная библиотека Math::Blight, что позволяет работать с большими числами. Однако библиотека загружается лишь при необходимости, поэтому вместо use используются ключевые слова require и import — это позволяет выполнить динамическую загрузку библиотеки во время выполнения вместо статической загрузки на стадии компиляции.
Запустите программу со списком чисел, и она выведет простые множители для каждого числа:
$ factors 8 9 96 2178
8 2**3
9 3**2
96 2**5 3
2178 2 3**2 11**2
Программа нормально работает и с очень большими числами:
% factors 239322000000000000000000 +239322000000000000000000 2**19 3 5**18 +39887 % factors 23932200000000000000000000 +25000000000000000000000000 2**24 5**26
Исходный текст программы приведен в примере 2.1.
Пример 2.1. bigfact
#!/usr/bm/perl
# bigfact - разложение на простые множители
use strict;
use integer;
use vars qw{ $opt_b $opt_d >; use Getopt::Std;
@ARGV && getopts('bd') or die "usage: $0 [-b] number ..,"; load_biglib() if $opt_b;
ARG: foreach my $orig ( @ARGV ) { my ($n, $root, %factors, Sfactor); $n = $opt_b ? Math::BigInt->new($orig) : $orig; if ($n + 0 ne $n) { # don't use -w for this
printf STDERR "bignum: %s would become %s\n", $n, $n+0 if $opt_d;
load_biglib();
$n = Math::BigInt->new($orig); } printf "%-10s ", $n;
Я $sqi равно квадрату $i. Используется тот факт, # что ($i + 1) •* 2 == $i •* 2 + 2 * $i + 1. for (my ($i, $sqi) = (2, 4); $sqi <= $n; $sqi += 2 * $i ++ + 1) { while ($n % $i == 0) {
$n /= $i;
print STDERR "" if $opt_d;
$factors
if ($n != 1 44 $n != long) { $factors{$n}++ } if (! «factors) {
print "PRIME\n";
next ARG; >
for $factor ( sort { $a <=> $b } keys %factors ) { print "$factor";
if ($factors{$factor} > 1) {
print "*«$factors{$factor}";
>
print " "; } print "\n";
# Имитирует use, но во время выполнений sub loadjaglib {
require Math::BigInt;
Math.:8iglnt->import();
Дата и время
Не следует требовать, чтобы время в секундах с начала
эпохи точно соответствовало количеству секунд между
указанным временем и началом эпохи.
Стандарт IEEE 1003 1b-1993 (POSIX) раздел В.2.2.2
Введение
Время и дата — очень важные величины, и с ними необходимо уметь работать. «Сколько пользователей регистрировалось за последний месяц?», «Сколько секунд я должен проспать, чтобы проснуться к полудню?» и «Не истек ли срок действия пароля данного пользователя?» — вопросы кажутся тривиальными, однако ответ на них потребует на удивление нетривиальных операций.
В Perl моменты времени представлены в виде интервалов, измеряемых в секундах с некоторого момента, называемого началом эпохи. В UNIX и многих других системах начало эпохи соответствует 00 часов 00 минут 1 января 1970 года по Гринвичу (GMT1). На Macintosh дата и время измеряется в местном часовом поясе. Функция gmtime возвращает правильное время по Гринвичу, основанное на смещении местного часового пояса. Помните об этом, рассматривая рецепты этой главы. На Macintosh количество секунд с начала эпохи позволяет отсчитывать время в интервале от 00:00 1 января 1904 года до 06:28:15 6 февраля 2040 года.
Говоря о времени и датах, мы часто путаем две разные концепции: момент времени (дата, время) и интервал между двумя моментами (недели, дни, месяцы и т. д.). При отсчете секунд с начала эпохи интервалы и моменты представляются в одинаковых единицах, поэтому с ними можно выполнять простейшие математические операции.
Однако люди не привыкли измерять время в секундах с начала эпохи. Мы предпочитаем работать с конкретным годом, месяцем, днем, часом, минутой и секундой. Более того, название месяца может быть как полным, так и сокращенным. Число может указываться как перед месяцем, так и после него. Использование разных форматов затрудняет вычисления, поэтому введенная пользователем или
прочитанная из списка строка даты/времени обычно преобразуется в количество секунд с начала эпохи, с ней производятся необходимые операции, после чего секунды снова преобразуются для вывода.
Для удобства вычислений количество секунд с начала эпохи всегда измеряется по Гринвичу. В любых преобразованиях всегда необходимо учитывать, представлено ли время по Гринвичу или в местном часовом поясе. Различные функции преобразования позволяют перейти от гринвичского времени в местное, и наоборот.
Функция Perl time возвращает количество секунд, прошедших с начала эпохи... более или менее' точно. Для преобразования секунд с начала эпохи в конкретные дни, месяцы, годы, часы, минуты и секунды используются функции localtime и gmtime. В списковом контексте эти функции возвращают список, состоящий из девяти элементов.
Переменная Значение Интервал
|
$sec |
Секунды |
0-60 |
|
$Ш1П |
Минуты |
0-59 |
|
$hours |
Часы |
0-23 |
|
$mday |
День месяца |
1-31 |
|
$month |
Месяц |
0-11, 0== январь |
|
$year |
Год, начиная с 1900 |
1-138 (и более) |
|
$wday |
День недели |
0-6,0 == воскресенье |
|
$yday |
День года |
1-366 |
|
$isdst |
Оили 1 |
true, если действует летнее время |
Секунды изменяются в интервале 0-60 с учетом возможных корректировок; под влиянием стандартов в любой момент может возникнуть лишняя секунда.
В дальнейшем совокупность «день/месяц/год/час/минута/секунда» будет обозначаться выражением «полное время» — хотя бы потому, что писать каждый раз «отдельные значения дня, месяца, года, часа, минут и секунд» довольно утомительно. Сокращение не связано с конкретным порядком возвращаемых значений.
Perl не возвращает данные о годе в виде числа из двух цифр. Он возвращает разность между текущим годом и 1900, которая до 1999 года представляет собой число из двух цифр. У Perl нет своей «проблемы 2000 года», если только вы не изобретете ее сами (впрочем, у вашего компьютера и Perl может возникнуть проблема 2038 года, если к тому времени еще будет использоваться 32-разрядная адресация). Для получения полного значения года прибавьте к его представлению 1900. Не пользуйтесь конструкцией 19$уеаг", или вскоре ваши программы начнут выдавать «год 19102». Мы не можем точно зафиксировать интервал года, потому что все зависит от размера целого числа, используемого вашей системой для представления секунд с начала эпохи. Малые числа дают небольшой интервал; большие (64-разрядные) числа означают огромные интервалы.
Fri Apr 11 09:27:08 1997
Объекты стандартного модуля Time::tm позволяют обращаться к компонентам даты/времени по именам. Стандартные модули Time::localtime и Time::gmtime переопределяют функции localtime и gmtime, возвращающие списки, и заменяют их версиями, возвращающими объекты Time::tm. Сравните два следующих фрагмента:
# Массив
print 'Today is day ', (localtime()[7], of the current year \n , Today is day 117 of the current year.
# Объекты Time tm
$tm = localtime,
print Today is day ', $tm->yday, of the current year \n , Today is day 117 of the current year.\
Чтобы преобразовать список в количество секунд с начала эпохи, воспользуйтесь стандартным модулем Time::Local. В нем имеются функции timelocal и timegm, которые получают список из девяти элементов и возвращают целое число. Элементы списка и интервалы допустимых значений совпадают с теми, которые возвращаются функциями localtime и gettime.
Количество секунд с начала эпохи ограничивается размером целого числа. Беззнаковое 32-разрядное целое позволяет представить время по Гринвичу от 20:45:52 13 декабря 1901 года до 03:14:07 19 января 2038 года включительно. Предполагается, что к 2038 году в компьютерах должны использоваться целые числа большей разрядности. Во всяком случае, будем надеяться на это. Чтобы работать с временем за пределами этого интервала, вам придется воспользоваться другим представлением или выполнять операции со отдельными значениями года, месяца и числа.
Модули Date::Calc и Date::Manip с CPAN работают с этими отдельными значениями, но учтите — они не всегда вычитают из года 1900, как это делает localtime, а нумерация месяцев и недель в них не всегда начинается с 0. Как всегда, в страницах руководства можно найти достоверные сведения о том, какая информация передается модулю, а какая — возвращается им. Только представьте, как будет неприятно, если рассчитанные вами финансовые показатели уйдут на 1900 лет в прошлое!
3.1. Определение текущей даты
Проблема
Требуется определить год, месяц и число для текущей даты.
Решение
Воспользуйтесь функцией localtime. Без аргументов она возвращает текущую дату и время. Вы можете вызвать localtime и извлечь необходимую информацию из полученного списка:
($DAY, $MONTH, $YEAR) = (localtime)[3,4,5],
Модуль Timc:: localtime переопределяет localtime так, чтобы функция возвращала объект Time::tm:
use Time localtime
$tm = localtime,
($DAY, SMONTH, $YEAR) = ($tm->mday, $tm->mon, $tm->year),
Комментарий
Вывод текущей даты в формате ГГГГ-ММ-ДД с использованием стандартной функции localtime выполняется следующим образом:
($day, Smonth, $year) = (localtime)[3,4 5],
printf( The current date is %04d %02d %02\n $year+1900, $month+1, $day),
The current date is 1999 04 28
Нужные ноля из списка, возвращаемою localtime, извлекаются с помощью среза. Запись могла выглядеть иначе:
($day, Smonth, $year) = (localtime)[3 5],
А вот как текущая дата выводится в формате ГГГГ-ММ-ДД (рекомендованном стандартом ISO 8601) с использованием Time::localtime:
use Time localtime
$tm = localtime,
printf( The current date is %04d-%02d-%02\n , $tm->year+1900,
($tm->mon)+1, $tm->mday) The current date is 1999-04-28
В короткой программе обьектный интерфейс выглядит ]1еуместпо. Однако при большом объеме вычислений с отдельными компонентами даты обращения по имени заметно упрощают чтение программы.
То же самое можно сделать и хитроумным способом, не требующим создания временных переменных:
printf( The current date is %04d-%02d-%02\n ,
sub {($_[5]+1900, $_[4]+1 $_[3])}->(localtime)),
Кроме того, в модуле POSIX имеется функция strftime, упоминаемая в рецепте 3.8:
use POSIX qw(strftime),
print strftime %Y-%m-%d\n , localtime,
Функция gmtime работает аналогично localtime, но возвращает время по Гринвичу, а не для местного часового пояса.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций localtime и gmtime вperlfunc(l); документация по стандартному модулю Time::locallime.
Проблема
Требуется преобразовать дату/время, выраженные отдельными значениями дня, месяца, юда и т. д. в количество секунд с начала эпохи.
Решение
Воспользуйтесь функцией timelocal пли timegm стандартного модуля Time::Local. Выбор зависит от того, относится ли дата/время к текущему часовому поясу пли Гринвичскому меридиану:
use Time Local,
$TIME = timelocal($sec, $mm, $hours Smday, Smon, $year)
$TIME = timegm($sec, $min, $hours $mday, $mon $year),
Комментарий
Встроенная функция localtime преобразует количество секунд с начала эпохи в компоненты полного времени; процедура timelocal из стандартного модуля Time::Local преобразует компоненты полного времени в секунды. Следующий пример показывает, как определяется количество секунд с начала эпохи для текущей даты. Значения дня, месяца и года получаются от localtime:
# $hours, Sminutes и Sseconds задают время для текущей даты
# и текущего часового пояса
use Time Local
$time = timelocal($seconds, Sminutes, $hours, (localtime)[3 4,5])
Если функции timelocal передаются месяц и год, они должны принадлежать тем же интервалам, что и значения, возвращаемые localtime. А именно, нумерация месяцев начинав!ся с 0, а из года вычитается 1900.
Функция timelocal предполагает, что компоненты полного времени соответствуют текущему часовому поясу. Модуль Time::Local также экспортирует процедуру timegm, для которой компоненты полного времени задаются для Гринвичского меридиана. К сожалению, удобных средств для работы с другими часовыми поясами, кроме текущего или Гринвичского, не существует. Лучшее, что можно сделать, — преобразовать время к Гринвичскому и вычесть или прибавить смещение часового пояса в секундах.
В следующем фрагменте демонстрируется как применение timegm, так и настройка интервалов года и месяца:
# $day - день месяца (1-31)
# $month - месяц (1-12)
8 $уеаг - год, состоящий из четырех цифр (например, 1999)
# $hours, Sminutes и Sseconds - компоненты времени по Гринвичу
use Time Local,
$time = timegm($seconds, Sminutes $hours, Sday, $month-1, Syear-1900)
Как было показано во введении, количество секунд с начала эпохи не может выходить за пределы интервала от 20:45:52 13 декабря 1901 года до 03:14:07 19 января 2038 года включительно. Не преобразуйте такие даты — либо воспользуйтесь модулем Date:: с CPAN, либо выполните вычисления вручную.
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю Time::Local. Обратное преобразование рассматривается в рецепте 3.3.
3.3. Преобразование секунд с начала эпохи в полное время
Проблема
Требуется преобразоват ь количество секунд с начала эпохи в отдельные значения дня, месяца, года и т. д
Решение
Воспользуйтесь функцией localtime или gmtime в зависимости от того, хотите ли вы получить дату/время для текущего часового пояса или для Гринвичского меридиана.
(Sseconds $minutes, $hours $day_of_month $year $wday, $yday $isdst) = localtime($TIME)
Стандартные модули Time-.timelocal n Time: gmtime переопределяют функции localtime и gmtime так, чтобы к компонентам можно было обращаться по именам:
use Time localtime, # или Time gmtime $tm = localtime($TIME), # или gmtime($TIME) Sseconds = $tm->sec, #
Комментарий
Функции localtime и gettime возвращают несколько странную информацию о годе и месяце; из года вычитается 1900, а нумерация месяцев начинается с 0 (январь). Не забудьте исправить полученные величины, как это делается в следующем примере:
(Sseconds, Smmutes $hours, $day_of_month, $month, Syear,
$wday, $yday, $isdst) = localtime($time), pnntf( Dateline %02d %02d %02d-%04d/%02d/%02d\n ,
Shours, $mmutes, Sseconds, $year+1900, $month+1,
$day_of_nionth),
Модуль Time::localtime позволяет избавиться от временных переменных:
use Time localtime, $tm = localtime($time)
100 Глава 3 • Дата и время
printf( Dateline %02d %02d %02d-%04d/%02d/%02d\n , $tm->hour, $tm->min, $tm->sec, $tm->year+1900, $tm->mon+1, $tm->mday),D> Смотри также------------------------------------------------------------------------------------------
Описание функции localtime в perlfunc(i); документация по стандартным модулям Timc::localtime и Time::gmtirae. Обратное преобразование рассматривается в рецепте 3.2.
3.4. Операции сложения и вычитания для дат
Проблема
Имеется значение даты/времени. Требуется определить дату/время, отделенную от них некоторым промежутком в прошлом или будущем.
Решение
Проблема решается простым сложением или вычитанием секунд с начала эпохи:
$when = $now + Sdifference, $then = Snow - Sdifference,
Если у вас имеются отдельные компоненты полного времени, воспользуйтесь модулем Date::Calc с CPAN. Если вычисления выполняются только с целыми днями, примените функцию Add_Delta_Days (смещение $offset может представлять собой как положительное, так и отрицательное целое количество дней):
use Date Calc qw(Add_Delta_Days),
($y2, $iTi2, $d2) = Add_Dclta_Days($y, $m, $d, Soffset)
Если в вычислениях используются часы, минуты и секунды (то есть не только дата, но и время), воспользуйтесь функцией Add_Delta_DHMS:
use Date DateCalc qw(Add_Delta_DHMS), ($year2, Smonth2, Sday2, $h2, $m2, $s2) =
Add_Delta_DHMS( $year, Smonth, $day, Shour Smmute, Sseconds, $days_offset, $hour_offset, $minute_offset, $seconds_offset ),
Комментарий
Вычисления с секундами от начала эпохи выполняются проще всего (если не считать усилий па преобразования даты/времени в секунды и обратно). В следующем фрагменте показано, как прибавить смещение (в данном примере — 55 диен, 2 часа, 17 минут и 5 секунд) к заданной базовой дате и времени:
Sbirthtime = 96176750, # 18 января 1973 года, 03 45 50
Sinterval = 5 + #5 секунд
17 • 60 + #17 минут
2 - 60 * 60 + #2 часа
55 ¦ 60 * 60 • 24, й и 55 дней $then = Sbirthtime + Smterval, print 'Then is ", scalar(localtime($then)), \n , Then is Wed Mar 14 06:02:55 1973
Мы также могли воспользоваться функцией Add_Delta_DHMS и обойтись без преобразований к секундам с начала эпохи и обратно:
use Date Calc qw(Add_Delta_DHMS),
($year, Smonth $day, $hh, $mm, $ss) = Add_Delta_DHMS(
1973, 1, 18, 3, 45, 50, # 18 января 1973 года, 03 45 50
55, 2, 17, 5), # 55 дней, 2 часа, 17 минут, 5 секунд print To be prcise $hh $mm $ss, $month/$day/$year\n', To be precise: 6:2:55, 3/14/1973
Как обычно, необходимо проследить, чтобы аргументы функции находились в правильных интервалах. Add_Delta_DHMS получает полное значение года (без вычитания 1900). Нумерация месяцев начинается с 1, а не с 0. Аналогичные параметры передаются и функции Add_Delta_Days модуля Date::DateCalc:
use Date DateCalc qw(Add_Delta_Days), ($year, Smonth, $day) = Add_Delta_Days( 1973, 1, 18, 55), print Nat was 55 days old on $month/$day/$year\n Nat was 55 days old on: 3/14/1973
Смотри также
Документация по модулю Date::Calc от CPAN.
3.5. Вычисление разности между датами
Проблема
Требуется определить количество дней между двумя датами или моментами времени.
Решение
Если даты представлены в виде секунд с начала эпохи и принадлежат интервалу от 20:45:52 13 декабря 1901 года до 03:14:07 19 января 2038 года включительно, достаточно вычесть одну дату из другой и преобразовать полученные секунды в дни:
Sseconds = $recent = $earlier
Если вы работаете с отдельными компонентами полного времени или беспокоитесь об ограничениях интервалов для секунд с начала эпохи, воспользуйтесь модулем Date::Calc с CPAN. Он позволяет вычислять разность дат:
use Date Calc qw(Delta_DHMS), ($days, Shours, $minutes, Sseconds) =
Delta_DHMS( Syeari, $month1, $day1, $hour1, $minute1, $seconds1, # Ранний
ft момент
$year2, $month2, $day2, $hour2, $mmute2, $seconds2, й Поздний
й момент
Одна из проблем, связанных с секундами с начала эпохи, — преобразование больших целых чисел в форму, понятную для человека. Следующий пример демонстрирует один из способов преобразования секунд с начала эпохи в привычные недели, дни, часы, минуты и секунды:
$bree = 361535725, # 04 35 25 16 июня 1981 года $nat = 96201950, # 03 45 50 18 января 1973 года
$difference = $bree - $nat,
print There were Sdifference seconds between Nat and Bree\n ,
There were 266802575 seconds between Nat and Bree
Sseconds = Sdifference % 60,
Sdifference = (Sdifference - Sseconds) / 60
Sminutes = Sdifference % 60,
Sdifference = (Sdifference - Sminutes) / 60,
Shours = Sdifference $ 24,
Sdifference = (Sdifference - Shours) / 24,
Sdays = Sdifference % 7,
$weeks = (Sdifference - Sdays) / 7,
print (Sweeks weeks, Sdays days, Shours Sminutes $seconds)\n , (441 weeks, 0 days, 23: 49: 35)
Функции модуля Date::Calc упрощают подобные вычисления. Delta_Days возвращает количество дней между двумя датами. Даты передаются ей в виде списка «год/месяц/деиь» в хронологическом порядке, то есть начиная с более ранней.
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю Date::Calc с CPAN.
3.6. Определение номера недели или дня недели/месяца/года
Проблема
Имеется дата в секундах с начала эпохи или в виде отдельных компонентов — года, месяца и т. д. Требуется узнать, на какой номер недели или день недели/месяца/года она приходится.
Решение
Если дата выражена в секундах с начала эпохи, день года, день месяца или недели возвращается функцией localtime. Номер недели легко рассчитывается по дню года.
3.6. Определение номера недели или дня недели/месяца/года 103
(SMONTHDAY, $WEEKDAY, $YEARDAY) = (localtime $DATE) [3,6,7], $WEEKNUM = mt($YEARDAY / 7) + 1,Отдельные компоненты полного времени можно преобразовать в число секунд с начала эпохи (см. рецепт 3.3) и воспользоваться приведенным выше решением. Возможен и другой вариант — применение функций Day_of_Week, Week_Number и Day_of_Year модуля Date::Calc с CPAN:
use Date Calc qw(Day_of_Week Week_Number Day_of_Year),
# Исходные величины - $year, Smonth и $day
# По определению $day является днем месяца
$wday = Oay_of_Week($year $month, $day),
$wnum = Week_Number($year, $month, $day),
$dnum = Day_of_Year($year, $month $day),
Комментарий
Функции Day_of_Week, Week_Number и Day_of_Year получают год без вычитания 1900 и месяц в нумерации, начинающейся с 1 (январь), а не с 0. Возвращаемое значение функции Day_of_Week находится в интервале 1-7 (с понедельника до воскресенья) или равняется 0 в случае ошибки (например, при неверно заданной дате).
use Date Calc qw(Day_of_Week Week_Number),
$year = 1981,
Smonth =6, # (Июнь)
$day = 16,
№ys = qw Error Monday Tuesday Wednesday Thursday Friday Saturday Sunday ,
$wday = Day_of_Week($year, $month $day), print $month/$day/$year was a $days[$wday]\n ,
$wnum = Week_Number($year, $month, $day), print in the $wnum week \n , 6/16/1981 was a Tuesday in the 25 week
В некоторых странах сущестнуют специальные стандарты, касающиеся первой недели года. Например, в Норвегии первая педеля должна содержать не менее 4 дней (и начинаться с понедельника). Если 1 января выпадает па неделю из 3 и менее дней, она считается 52 или 53 неделей предыдущего года. В Америке первая рабочая неделя обычно начинается с первого понедельника года. Возможно, при таких правилах вам придется написать собственный алгоритм или по крайней мере изучить форматы %G, %L, %W и %U функции UmxDate модуля Date::Manip.
t> Смотри также--------------------------------------------------------------------------------------------
Описание функции localtime в perlfunc(l); документация по стандартному модулю Date::Calc от CPAN.
Проблема
Спецификация даты или времени читается в произвольном формате, однако ее требуется преобразовать в отдельные компоненты (год, месяц и т. д.).
Решение
Если дата уже представлена в виде числа пли имеет жесткий, легко анализируемый формат, воспользуйтесь регулярным выражением (и, возможно, хэшем, связывающим названия месяцев с номерами) для извлечения отдельных значений дня, месяца и года. Затем преобразуйте их в секунды с начала эпохи с помощью функций timelocal и timegm стандартного модуля Timc::Local.
use Time Local,
# $date хранится в формате 1999-06-03 (ГГГГ-ММ-ДД)
($уууу, $mm $dd) = ($date =" /(\d+)-(\d+)-(\d+)/
й Вычислить секунды с начала эпохи для полночи указанного дня
# в текущем часовом поясе
$epoch_seconds = timelocal(0 0, 0 $dd, $mm $уууу)
Более гибкое решение — применение функции ParseDate из модуля Date::Manip с CPAN и последующее извлечение отдельных компонентов с помощью UnixOate.
use Date Manip qw(ParseDate UnixDate), $date = ParseDate($STRING) if O$date) {
# Неверная дата } else {
LVALUES = UmxDate($date ©FORMATS) }
Комментарий
Универсальная функция ParseDate поддерживает различные форматы дат. Она даже преобразует такие строки, как «today» («сегодня»), «2 weeks ago Friday» («в пятницу две недели назад») и «2nd Sunday in 1996» («2-е воскресенье 199G года»), а также понимает форматы даты/времени в заголовках почты и новостей. Расшифрованная дата возвращается в собственном формате — строке вида «ГГГГММДДЧЧ:ММ:СС». Сравнение двух строк позволяет узнать, совпадают ли представленные ими даты, однако арифметические операции выполняются иначе. Поэтому мы воспользовались функцией UnixDate для извлечения года, месяца и дня в нужном формате.
Функция UnixDate получает дату в виде строки, возвращаемой ParseDate, и список форматов. Она последовательно применяет каждый формат к строке и возвращает результат. Формат представляет собой строку с описанием одного или нескольких элементов даты/времени и способов оформления этих элементов. Например, формат %Y соответствует году, состоящему из четырех цифр. Приведем пример:
3.8. Вывод даты 105
use Date Mamp qw(ParseDate UnixDate)
while (<>) <
$date = ParseDate($_) if (i$date) {
warn Bad date string $_\n ,
next, } else {
($year, $month, $day) = UmxDate($date, %Y , %n , %d ),
print Date was $month/$day/$year\n
t> Смотри также--------------------------------------------------------------------------------------------
Документация для модуля Date::Manip с CPAN; пример использования приведен в рецепте 3.11.
3.8. Вывод даты
Проблема
Требуется преобразовать дату и время, выраженные в секундах с начала эпохи, в более понятную для человека форму
Решение
Вызовите localtime пли gmtime в скалярном контексте — в эюм случае функция получает количество секунд с начала эпохи и возвращает строку вида Tue May 26 05:15-20 1998:
SSTRING = localtime($EPOCH_SECONDS),
Кроме того, функция strftime из стандартного модуля POSIX позволяет лучше настроить формат вывода и работает с отдельными компонентами полного времени:
use POSIX qw(strftime),
SSTRING = strftime($FORMAT SSECONDS, SMINUTES, SHOUR,
$DAY_OF_MONTH SMONTH, $YEAR, $WEEKDAY,
SYEARDAY, $DST),
В модуле Date::Manip с CPAN есть функция UnixDate — нечто вроде специализированного варианта spnntf, предназначенного для работы с датами. Ей передается дата в формате Date::Manip. Применение Date::Manip вместо POSIX::strftime имеет дополнительное преимущество, так как для этого от системы не требуегся совместимость с POSIX.
use Date Manip qw(UmxDate) SSTRING = UmxDate($DATE, SFORMAT),
Простейшее решение — функция localtime — относится к встроенным средствам Perl. В скалярном контексте эта функция возвращает строку, отформатированную особым образом:
Sun Sep 21 15:33:36 1999
Программа получается простой, хотя формат строки сильно ограничен:
use Time Local,
$time = timelocal(50, 45, 3, 18, 0, 73)
print Scalar localtime gives scalar(localtime($time)), \n ,
Scalar localtime gives1. Thu Jan 18 03:45:50 1973
Разумеется, дата и время для localtime должны исчисляться в секундах с начала эпохи. Функция POSIX strftime получаст набор компонентов полного времени и форматную строку, аналогичную pnntf, и возвращает также строку. Поля в выходной строке задаются директивами %. Полный список директив приведен в документации по strftime для вашей системы. Функция strftime ожидает, что отдельные компоненты дагы/временп принадлежат тем же интервалам, что и значения, возвращаемые localtime:
use POSIX qw(strftime),
use Time Local
$time = timelocal(50, 45 3, 18 0, 73),
print Scalar localtime gives , scalar(localtime($time)) \n ,
Scalar localtime gives: Thu Jan 18 03:45:50 1973
Разумеется, дата и время для localtime должны исчисляться в секундах с начала эпохи. Функция POSIX strftime получает набор компонентов полного времени и форматную строку, аналогичную pnntf, и возвращает также строку. Поля в выходной строке задаются директивами %. Полный список директив приведен в документации по strftime для вашей системы. Функция strftime ожидает, что отдельные компоненты даты/времени принадлежат тем же интервалам, что и значения, возвращаемые localtime:
use POSIX qw(strftime),
use Time Local,
$time = timelocal(50, 45 3, 18, 0, 73),
print strftime gives , strftime( %A %D , localtime($time)) \n ,
strftime gives: Thursday 01/18/73
При использовании POSIX • strftime все значения выводятся в соответствии с национальными стандартами. Так, во Франции ваша программа вместо "Sunday" выведет "Dimanche". Однако учтите: интерфейс Perl к функции strftime модуля POSIX всегда преобразует дату в предположении, что она относится к текущему часовому поясу.
Если функция strftime модуля POSIX недоступна, у вас всегда остается верный модуль Date::Manip, описанный в рецепте 3.6.
use Date Manip qw(ParseDate UnixDate), $date = ParseDate( 18 Jan 1973, 3 45 50 ),
3.9. Таймеры высокого разрешения 107
$datestr = UmxOate($date, %а %Ь %е %Н %М %S %г %У ), # скалярный контекст print Date Manip gives $datestr\n , Date::Mamp gives: Thu Jan 18 03:45:50 GMT 1973
!> Смотри также--------------------------------------------------------------------------------------------
Описание функции gmtime и localtime в perlfunc(l); perllocale(l); man-страшще strftime(3) вашей системы; документация по модулям POSIX и Date::Manip cCPAN.
3.9. Таймеры высокого разрешения
Проблема
Функция time возвращает время с точностью до секунды. Требуется измерить время с более высокой точностью.
Решение
Иногда эта проблема неразрешима. Если на вашем компьютере Perl поддерживает функцию syscall, а в системе имеется функция типа gettimeofday(2), вероятно, ими можно воспользоваться для измерения времени. Особенности вызова syscall зависят от конкретного компьютера. В комментарии приведен примерный вид фрагмента, однако его переносимость не гарантирована.
На некоторых компьютерах эти функциональные возможности инкапсулируются в модуле Time::HiRes (распространяется с CPAN):
use Time HiRes qw(gettimeofday), $tO = gettimeofday, ## Ваши операции $t1 = gettimeofday, $elapsed = $t1 - $tO,
# $elapsed - значение с плавающей точкой, равное числу секунд
# между $t1 и $t2
Комментарий
В следующем фрагменте модуль Time::HiRcs используется для измерения промежутка между выдачей сообщения и нажатием клавиши RETURN:
use Time HiRes qw(gettimeofday), print "Press return when ready ", Sbefore = gettimeofday; $lme = <>;
$elapsed = gettimeofday-Sbefore, print You took $elapsed seconds \n , Press return when ready: You took 0.228149 seconds.
Сравните с эквивалентным фрагментом, использующим syscall:
Глава 3 • Дата и время
require 'sys/syscall ph ,# Инициализировать структуры, возвращаемые gettirneofday
$TIMEVAL_T = LL
$done = $start = pack($TIMEVAL_T, ()),
# Вывод приглашения
print Press return when ready
# Прочитать время в $start
syscall(&SYS_gettimeofday, Sstart 0)) '= -1
|[ die gettimeofday $' ,
# Прочитать перевод строки
$lme = <>,
# Прочитать время в $done
syscall(&SYS_gettimeofday, $done 0) '= -1
I| die gettimeofday $'
it Распаковать структуру
@start = unpack($TIMEVAL_T, Sstart),
@done = unpack($TIMEVAL_T, $done),
ft Исправить микросекунды
for ($done[1], $start[1]) { $_ /= 1_000_000 }
# Вычислить разность
$delta_time = sprintf % 4f , ($done[0] + $done[1] )
($start[0] + $start[1] )
print That took $delta_time seconds\n , Press return when ready. That took 0.3037 seconds
Программа получилась более длинной, поскольку системные функции вызываются непосредственно из Perl, а в Time::HiRes они реализованы одной функцией С. К тому же она стала сложнее — для вызова специфических функций операционной системы необходимо хорошо разбираться в структурах С, которые передаются системе и возвращаются eii. Некоторые программы, входящие в поставку Perl, пытаются автоматически определить форматы pack и unpack по заголовочному файлу С. В нашем примере sys/syscall.ph — библиотечный файл Perl, сгенерированный утилитой Ii2ph, которая преобразует заголовочный файл sys/ syscallh в sys/syscall.ph. В частности, в нем определена функция &SYS_gettimeof day, возвращающая номер системного вызова для gettimeofday.
Следующий пример показывает, как использовать Time::HiRes для измерения временных характеристик:
use Time HiRes qw(gettimeofday),
# Вычислить среднее время сортировки
$size = 500, $number_of_times = 100 $total_time = О
for ($i =0, $i < number_of_times $i++) { my (is>array, $j, $begm, $time),
# Заполнить массив
@array = (),
for ($]=0, $j<$size $]++) { push(@array, rand) }
# Выполнить сортировку
$begm = gettimeofday,
@array = sort { $a <=> $b } ©array $time = gettimeofday=$t1, $total_time += $time,
printf On average, sorting %d random numbers takes %5 f seconds\n
$size ($total_time/$number_of_times), On average, sorting 500 random numbers takes 0.02821 seconds
t> Смотри также--------------------------------------------------------------------------------------------
Документация по модулям Timc::HiRes и BenchMark с CPAN; описание функции syscall в perlfunc(l); man-страница syscall(2).
3.10. Короткие задержки
Проблема
Требуется сделать в программе паузу продолжительностью менее секунды.
Решение
Воспользуйтесь функцией select, если она поддерживается вашей системой:
select(undef undef undef, $time_to_sleep) где $time_to_sleep — длительность паузы.
Некоторые системы не поддерживают select с четырьмя аргументами. В модуле Time::HiRcs присутствует функция sleep, которая допускает длину паузы с плавающей точкой:
use Time HiRes qw(sleep), sleep($time_to_sleep),
Комментарий
Следующий фрагмент демонстрирует применение функции select. Он представляет собой упрощенную версию программы из рецепта 1.5. Можете рассматривать его как эмулятор 300-бодного терминала:
select(undef, undef undef, 0 25)
print, }
С помощью Timc::HiRes это делается так:
use Time HiRes qw(sleep) while (о) {
sleep(0 25)
print, >
> Смотри также--------------------------------------
Документация по модулям Time.:HiRcs и BenchMark с CPAN; описание функций sleep и select в perlfunc(i). Функция select использована для организации короткой задержки в программе slowcat из рецепта 1.5.
3.11. Программа: hopdelta
Вы никогда не задавались вопросом, почему какое-нибудь важное письмо так долго добиралось до вас? Обычная почта не позволит узнать, как долго ваше письмо пылилось па полках всех промежуточных почтовых отделений. Однако в электронной почте такая возможность имеется. В заголовке сообщения присутствует строка Received: с информацией о том, когда сообщение было получено каждым промежуточным транспортным агентом.
Время в заголовках воспринимается плохо. Его приходится читать в обратном направлении, снизу вверх. Оно записывается в разных форматах по прихоги каждого транспортного агента. Но хуже всего то, что каждое время регистрируется в своем часовом поясе. Взглянув на строки "Tue, 26 May 1998 23 57.38 -0400" и "Wed, 27 May 1998 05.04.03 +0100", вы вряд ли сразу поймете, что эти два момента разделяют всего 6 минут 25 секунд.
На помощь приходят функции ParseDate и DateCalc модуля Date::Manip от CPAN:
use Date Mamp qw(ParseDate DateCalc)
$d1 = ParseDate( Tue, 26 May 1998 23 57 38 -0400 ),
$d2 = ParseDate( Wed, 27 May 1998 05 04 03 +0100 ),
print DateCalc($d1, $d2),
+0:0.0:0:0:6:25
Возможно, с такими данными удобно работать программе, но пользователь все же предпочтет что-нибудь более привычное. Программа hopdelta из примера 3.1 получает заголовок сообщения и пытается проанализировать дельты (разности) между промежуточными остановками. Результаты выводятся для местного часового пояса.
Пример 1.3. hopdelta
tt'/usr/bin/perl
# hopdelta - по заголовку почтового сообщения выдает сведения
U о задержке почты на каждом промежуточном участке
use strict
use Date Manip qw (ParseDate UnixDate),
# Заголовок печати, из-за сложностей printf следовало
# бы использовать format/write
printf %-20 20s %-20 20s 96-20 20s %s\n ,
Sender , Recipient , Time , Delta ,
$/ = # Режим абзаца
$_ = о # Читать заголовок
s/\n\s+/ /g, й Объединить строки продолжения
# Вычислить, когда и где начался маршрут сообщения
my($start_from) = /"From *\@(["\s>]«)/m,
my($start_date) = /"Date \s+( *)/m,
my $then = getdate($start_date),
printf %-20 20s %-20 20s %s\n , Start , $start_from, fmtdate($then)
my $prevfrom = $start_from
# Обрабатывать строки заголовка снизу вверх
for (reverse split(/\n/)) {
my ($delta, $now, $from, $by, $when),
next unless /"Received /
s/\bon ( *?) (id *)/, $1/s, n Кажется, заголовок qmail
unless (($when) = / \s+( *)$/) { # where the date falls
warn bad received line $_ ,
next
($from) = /from\s+(\S+)/,
($from) = /\(( *9)\)/ unless $from # Иногда встречается
$from =~ s/\)$//, й Кто-то пожадничал
($by) = /by\s+(\S+\ \S+)/ # Отправитель для данного участка
# Операции, приводящие строку к анализируемому формату for ($when) {
s/ (for|via) *$//,
s/([+-]\d\d\d\d) \(\S+\)/$V,
s/id \S+,VW/.
next unless $now = getdate($when), tt Перевести в секунды
# с начала эпохи $delta = $now - $then,
printf %-20 20s %-20 20s %s , $from, $by, fmtdate($now), Sprevfrom = $by puttime($delta), $then = $now, }
exit,
продолжение rf>
11? Глава 3 • Дата и время Пример 1.3 (продолжение)
# Преобразовать произвольные строки времени в секунды с начала эпохи sub getdate {my Sstring = shift,
$stnng =" s/\s+\( *\)\s*$//, # Убрать нестандартные
# терминаторы
my $date = ParseDate($stnng)
my $epoch_secs = UmxDate($date %s ),
return $epoch_secs,
# Преобразовать секунды с начала эпохи в строку определенного формата sub fmtdate {
my Sepoch = shift,
my($sec, $mm, $hour, $mday, $mon, $year) = localtime($epoch), return sprintf %02d %02d %02d %04d/%02d/%02d Shour, $mm, $sec, $year + 1900, $mon + 1, $mday,
# Преобразовать секунды в удобочитаемый формат sub puttime {
fny($seconds) = shift,
my($days, Shours, Sminutes),
$days = pull_count($seconds 24 * 60 * 60),
Shours = puli_count($seconds 60 - 60),
Smmutes = pull_count($seconds 60)
put_field('s' $seconds),
put_field('n', $mmutes)
put_field('h , Shours),
put_field('d', $days)
print \n ,
# Применение $count = pull_count(seconds, amount)
# Удалить из seconds величину amount изменить версию вызывающей
# стороны и вернуть число удалений
sub pull_count {
my(Sanswer) = mt($_[0] / $_[1]), $_[0] -= Sanswer . $_[1], return Sanswer,
# Применение put_field(char, number)
# Вывести числовое поле в десятичном формате с 3 разрядами и суффиксом char
й Выводить лишь для секунд (char == s )
sub put_field {
my ($char, Snumber) = @_,
printf %3d%s , Snumber, $char if $numbet |[ $char eq 's',
|
Sender |
Recipient |
Time |
Delta |
|
|
Start |
wall.org |
09:17:12 |
1998/05/23 |
44s 3m |
|
wall.org |
mail.brainstorm.net |
09:20:56 |
1998/05/23 |
|
|
mail.brainstorm.net |
ihereg.perl.com |
09:20:58 |
1998/05/23 |
2s |
Массивы
Я считаю, что произведения искусства — единственные объекты
материальной Вселенной, обладающие внутренним порядком.
И потому, не веря в высшую ценность искусства,
я все же верю в Искусство ради Искусства.
Э. М. Фостер
Введение
Если попросить вас перечислить содержимое своих карманов, назвать имена трех последних президентов или объяснить, как пройти к нужному месту, в любом случае получится список: вы называете объекты один за другим в определенном порядке. Списки являются частью нашего мировоззрения. Мощные примитивы Perl для работы со списками и массивами помогают преобразовать мировоззрение в программный код.
Термины список (list) n массив (array) трактуются в этой главе в соответствии с канонами Perl. Например, ("Reagan' , "Bush", "Clinton") — это список трех последних американских президентов. Чтобы сохранить его в переменной, воспользуйтесь массивом: @рresidents = ("Reagan", "Bush", "Clinton"). Каждый из этих терминов относится к упорядоченной совокупности скалярных величин; отличие состоит в том, что массив представляет собой именованную переменную, размер которой можно непосредственно изменить, а список является скорее отвлеченным понятием. Можно рассматривать массив как переменную, а список — как содержащиеся в пей значения.
Отличие может показаться надуманным, но операции, изменяющие размер этой совокупности (например, push или pop), работают с массивом, а не списком. Нечто похожее происходит с $а и 4: в программе можно написать $а++, но не 4++. Аналогично, рор(@а) — допустимо, а рор(1, 2,3)— нет.
Главное — помнить, что списки и массивы в Perl представляют собой упорядоченные совокупности скалярных величин. Операторы и функции, работающие со списками и массивами, обеспечивают более быстрый или удобный доступ к элементам по сравнению с ручным извлечением. Поскольку размер массива изменяется не так уж часто, термины «массив» и «список» обычно можно считать синонимами.
Вложенные списки не создаются простым вложением скобок. В Perl следующие строки эквивалентны:
fanested = ('this , 'that , "the", order'), ©nested = ("this', "that", ('the', 'order')),
Почему Perl не поддерживает вложенные списки напрямую? Отчасти по историческим причинам, но также и потому, что это позволяет многим операциям (типа print или sort) работать со списками произвольной длины и произвольного содержания.
Что делать, если требуется более сложная структура данных — например, массив массивов или массив хэшей? Вспомните, что скалярные переменные могут хранить не только числа или строки, но и ссылки. Сложные (многоуровневые) структуры данных в Perl всегда образуются с помощью ссылок. Следовательно, «двумерные массивы» или «массивы массивов» в действительности реализуются как массив ссылок на массивы — по аналогии с двумерными массивами С, которые могут представлять собой массивы указателей на массивы.
Для большинства рецептов этой главы содержимое массивов несущественно. Например, проблема слияния двух массивов решается одинаково для массивов строк, чисел или ссылок. Решения некоторых проблем, связанных с содержимым массивов, приведены в главе 11 «Ссылки и записи». Рецепты этой главы ограничиваются обычными массивами.
Давайте введем еще несколько терминов. Скалярные величины, входящие в массив или список, называются элементами. Для обращения к элементу используется его позиция, или индекс. Индексация в Perl начинается с 0, поэтому в следующем списке:
<9>tune = ('The', 'Star-Spangled', 'Banner' );
элемент "The ' находится в первой позиции, но для обращения к нему используется индекс 0: $tune[O]. Это объясняется как извращенностью компьютерной логики, где нумерация обычно начинается с 0, так и извращенностью разработчиков языка, которые выбрали 0 как смещение внутри массива, а не порядковый номер элемента.
4.1. Определение списка в программе
Проблема
Требуется включить в программу список — например, при инициализации массива.
Решение
Перечислите элементы, разделяя их запятыми:
@а = ("quick", "brown", 'fox"),
При большом количестве однословных элементов воспользуйтесь оператором qw():
@а = qw(Why are you teasing me7);
Mines = (« END_OF_HERE_DOC =' m/~\s*( +)/gm),
The boy stood on the burning deck,
It was as hot as glass END_OF_HERE_DOC
Комментарий
Наиболее распространен первый способ — в основном из-за того, что в виде литералов в программе инициализируются лишь небольшие массивы. Инициализация большого массива загромождает программу и усложняет ее чтение, поэтому такие массивы либо инициализируются в отдельном библиотечном файле (см. главу 12 «Пакеты, библиотеки и модули»), либо просто читаются из файла данных:
@bigarray = (),
open(DATA, < mydatafile ) or die Couldn t read from datafile $'\n ,
while (<DATA>) {
chomp,
push(@bigarray, $_), }
Во втором способе используется оператор qw. Наряду с q(), qq() и qx() он предназначен для определения строковых величин в программе. Оператор q() интерпретируется по правилам для апострофов, поэтому следующие две строки эквивалентны:
$banner = 'The mines of Moria , Sbanner = q(The mines of Moria),
Оператор qq() интерпретируется по правилам для кавычек:
$name = Gandalf ,
Sbanner = Speak, $name, and enter1 ,
Sbanner = qq(Speak, Sname, and welcome1),
А оператор qx() интерпретируется почти так же, как и обратные апострофы, — то есть выполняет команду с интерполяцией неременных и служебными символами \ через командный интерпретатор. В обратных апострофах интерполяцию отменить нельзя, а в qx — можно. Чтобы отказаться от расширения переменных Perl, используйте в qx ограничитель ':
$his_host = 'www perl com ,
$host_info = nslookup $his_host , # Переменная Perl расширяется
$perl_info = qx(ps $$), # Значение $$ от Perl
$shell_mfo = qx ps $$', # Значение $$ от интерпретатора
Если операторы q(), qq() и qx() определяют одиночные строки, то qw() определяет список однословных строк. Строка- аргумент делится по пробелам без интерполяции переменных. Следующие строки эквивалентны:
@banner = ('Costs', 'only , $4 95 ),
@banner = qw(Costs only $4 95),
@banner = split( ', 'Costs only $4 95');
Во всех операторах определения строк, как и при поиске регулярных выражений, разрешается выбор символа-ограничителя, включая парные скобки. Допустимы все четыре типа скобок (угловые, квадратные, фигурные и круглые). Следовательно, вы можете без опасении использовать любые скобки при условии, что для открывающей скобки найдется закрывающая:
§brax = qw1 ()<>{}[]'.
brings = qw(Nenya Narya Vilya),
Stags = qw<LI TABLE TR TD A IMG H1 P>,
$sample = qw(The vertical bar (|) looks and behaves like a pipe ),
Если ограничитель встречается в строке, а вы не хотите заменить его другим, используйте префикс \:
©banner = qw)The vertical bar (\|) looks and behaves like a pipe |,
Оператор qw() подходит лишь для списков, в которых каждый элемент является отдельным словом, ограниченным пробелами. Будьте осторожны, а то у Колумба вместо трех кораблей появится четыре:
$ships = qw(Nica Pmta Santa Магна), и НЕВЕРНО1 " $ships = ('Nica1, 'Pinta', 'Santa Магна'), # Правильно
> Смотри также---------------------------------------------------------------------------------------------
Раздел «List Value Constructors» perldata(l); раздел «Quote and Quote-Like Operators» perlop(l); оператор s/// описай в perlop(l).
4.2. Вывод списков с запятыми
Проблема
Требуется вывести список с неизвестным количеством элементов. Элементы разделяются запятыми, а перед последним элементом выводится слово and.
Решение
Следующая функция возвращает строку, отформатированную требуемым образом:
sub commify_series { (@_ == 0) •> ' '
(@_ ==1)9 $_[0]
(@_ == 2) ? ]oin(" and ', @_)
(", ', @_[0 ($#_-1], 'and $_[-1]"),
Комментарий
При выводе содержимое массива порой выглядит довольно странно:
@array = ('red", "yellow", 'green'),
На самом деле вам нужна строка "I have red, yellow, and green marbles". Приведенная выше функция генерирует строку именно в таком формате. Между двумя последними элементами списка вставляется "and". Если в списке больше двух элементов, все они разделяются запятыми.
Пример 4.1 демонстрирует применение этой функции с одним дополнением: если хотя бы один элемент списка содержит запятую, в качестве разделителя используется точка с запятой.
Пример 4.1. commify_series
#'/usr/bin/perl -w
# commify_senes - демонстрирует вставку запятых при выводе описка
©lists = (
[ 'just one thing' ], [ qw(Mutt Jeff) ], [ qw(Peter Paul Mary) ],
[ 'To our parents', 'Mother Theresa', 'God' ],
[ 'pastrami', 'ham and cheese', 'peanut butter and jelly', 'tuna' ], [ 'recycle tired, old phrases', 'ponder big, happy thoughts' ], [ 'recycle tired, old phrases', 'ponder big, happy thoughts', 'sleep and dream peacefully ],
foreach $aref (@lists) {
print "The list is ' . commify_series((g>$aref) . \n",
sub commify_series {
my $sepchar = grep(/,/ => @_) 9 "; ' • ",",
(@_ == 0) ? '• :
(@_ == 1) ? $_[0] :
(@_ == 2) ? join(" and ', @_)
join("$sepchar ', @_[0 ($#_-1)], "and $_[-1]"); }
Результаты выглядят так:
The list is: just one thing.
The list is: Mutt and Jeff.
The list is: Peter, Paul, and Mary.
The list is: To our parents, Mother Theresa, and God.
The list is: pastrami, ham and cheese, peanut butter and jelly, and tuna.
The list is: recycle tired, old phrases and ponder big, happy thoughts.
4.3. Изменение размера массива 119'
The list is: recycle tired, old phrases; ponder
big, happy thoughts; and sleep and dream peacefully.
Как видите, мы отвергаем порочную практику исключения последней запятой из списка, что нередко приводит к появлению двусмысленностей.
> Смотри также---------------------------------------------------------------------------------------------
Описание функции grep в perlfunc(l); описание тернарного оператора выбора в perlop(l). Синтаксис вложенных списков рассматривается в рецепте 11.1.
4.3. Изменение размера массива
Проблема
Требуется увеличить или уменьшить размер массива. Допустим, у вас имеется массив работников, отсортированный по размерам оклада, и вы хотите ограничить его пятью самыми высокооплачиваемыми работниками. Другой пример — если окончательный размер массива точно известен, намного эффективнее выделить всю память сразу вместо того, чтобы увеличивать массив постепенно, добавляя элементы в конец.
Решение
Присвойте значение $#ARRAY:
U Увеличить или уменьшить ©ARRAY $#ARRAY = $NEW_LAST_ELEMENT_INDEX_NUMBER
Присваивание элементу, находящемуся за концом массива, автоматически увеличивает массив:
$ARRAY[$NEW_LAST_ELEMENT_INDEX_NUMBER] = $VALUE;
Комментарий
$#ARRAY — последний допустимый индекс массива @ARRAY. Если ему присваивается значение меньше текущего, массив уменьшается. Отсеченные элементы безвозвратно теряются. Если присвоенное значение больше текущего, массив увеличивается. Новые элементы получают неопределенное значение.
Однако $#ARRAY не следует путать с ©ARRAY. $#ARRAY представляет собой последний допустимый индекс массива, a @ARRAY (в скалярном контексте, то есть в числовой интерпретации) — количество элементов. $#ARRAY на единицу меньше @ARRAY, поскольку нумерация индексов начинается с 0.
В следующем фрагменте использованы оба варианта:
sub what_about_that_array {
print 'The array now has ", scalar(@people), ' elements.\n", print "The index of the last element is $#people \n"; print "Element #3 is '$people[3]',\n',
Результат:
The array now has 4 elements.
The index of the last element is 3.
Element «3 is 'Young'.
А другой фрагмент:
$#people--, what_about_that_array();
выводит следующий результат:
The array now has 3 elements.
The index of the last element is 2.
Element #3 is
Элемент с индексом 3 пропал при уменьшении массива. Если бы программа запускалась с ключом -w, Perl также выдал бы предупреждение об использовании неинициализированной величины, поскольку значение $people[3] не определено.
В следующем примере:
$#people = 10_000, what_about^that_array(),
результат выглядит так:
The array now has 10001 elements.
The index of the last element is 10000.
Element #3 is
Элемент ' Young" безвозвратно утерян. Вместо присваивания $ffpeople можно было сказать:
$people[10_000]=undef,
Массивы Perl не являются разреженными. Другими словами, если у вас имеется 10000-й элемент, то должны присутствовать и остальные 9999 элементов. Они могут быть неопределенными, но все равно будут занимать память. Из-за этого $array[time] или любая другая конструкция, где в качестве индекса используется очень большое целое число, является неудачным решением. Лучше воспользуйтесь хэшем.
При вызове print нам пришлось написать scalar @array, поскольку Perl интерпретирует большинство аргументов в списковом контексте, а требовалось значение @аггау в скалярном контексте.
> Смотри также------------------------------------------------------------------------------- ;-----------------
Описание $#ARRAY вperldata(l).
4.4. Выполнение операции с каждым элементом списка
Проблема
Требуется повторить некоторую операцию для каждого элемента списка.
Массивы часто используются для сбора интересующей информации - например, имен пользователей, превысивших свои дисковые квоты. Данные обрабатываются, при этом с каждым элементом массива выполняется некоторая операция. Скажем, в примере с дисковыми квотами каждому пользователю отправляется предупреждающее сообщение.
Решение
Воспользуйтесь циклом f о reach:
foreach $item (LIST) {
# Выполнить некоторые действия с $item }
Комментарий
Предположим, в массиве @bad_users собран список пользователей, превысивших свои дисковые квоты. В следующем фрагменте для каждого нарушителя вызывается процедура complain():
foreach $user (@bad_users) {
cornplain($user), >
Столь тривиальные случаи встречаются редко. Как правило, для генерации списка часто используются функции
foreach $var (sort keys %ENV) {
print '$var=$ENV{$var}\n , }
Функции sort и keys строят отсортированный список имен переменных окружения. Конечно, многократно используемые списки следует сохранять в массивах. Но для одноразовых задач удобнее работать со списком напрямую.
Возможности этой конструкции расширяются не только за счет построения списка в foreach, по и за счет дополнительных операций в блоке кода. Одно из распространенных применений foreach — сбор информации о каждом элементе списка и принятие некоторого решения на основании полученных данных. Вернемся к примеру с квотами:
foreach $user (@all_users) {
$disk_space = get_usage($user); ff Определить объем используемого
# дискового пространства
if ($disk_space > $MAX_QU0TA) { # Если он больше допустимого .
complain($user), й . предупредить о нарушении
Переменная, которой последовательно присваиваются все элементы списка, называется переменной цикла или итератором. Если итератор не указан, используется глобальная переменная $_. Она используется по умолчанию во многих строковых, списковых и файловых функциях Perl. В коротких программных блоках пропуск $_ упрощает чтение программы (хотя в длинных блоках излишек неявных допущений делает программу менее понятной). Например:
fо reach ( who ) { if (/tchrist/) { print,
Или в сочетании с циклом while:
while (<FH>) { и Присвоить $_ очередную прочитанную строку
chomp; # Удалить из $_ конечный символ \п,
# если он присутствует
foreach (split) { Я Разделить $_ по пропускам и получить @_
# Последовательно присвоить $_
# каждый из полученных фрагментов
$_ = reverse, и Переставить символы $_
# в противоположном порядке
print 8 Вывести значение $_
Многочисленные применения $_ заставляют понервничать. Особенно беспокоит то, что значение $_ изменяется как в foreach, так и в while. Возникает вопрос — не будет ли полная строка, прочитанная в $_ через <FH>, навсегда потеряна после выполнения foreach?
К счастью, эти опасения необоснованны — но крайней мере, в данном случае. Perl не уничтожает старое значение $_, поскольку переменная-итератор ($_) существует в течение всего выполнения цикла. При входе во внутренний цикл старое значение автоматически сохраняется, а при выходе — восстанавливается.
Однако причины для беспокойства все же есть. Если цикл while будет внутренним, a foreach — внешним, ваши страхи в полной мере оправдаются. В отличие от foreach конструкция while <FH> разрушает глобальное значение $_ без предварительного сохранения! Следовательно, в начале любой процедуры (или блока), где $_ используется в подобной конструкции, всегда должно присутствовать объявление local $ .
Если в области действия (scope) присутствует лексическая переменная (объявленная с ту), то временная переменная будет иметь лексическую область действия, ограниченную данным циклом. В противном случае она будет считаться глобальной переменной с динамической областью действия. Во избежание странных побочных эффектов версия 5.004 допускает более наглядную и понятную запись:
foreach my $item (@array) {
print 'l = $item\n , }
Цикл foreach обладает еще одним свойством: в цикле переменная-итератор является не копией, а скорее синонимом (alias) текущего элемента. Иными словами, изменение итератора приводит к изменению каждого элемента списка.
@аггау = (1,2,3), foreach $item (@array) {
$item--, }
print @array , 0 1 2
й Умножить каждый элемент @>a и @b на семь @а = ( 5, 3) @b = (0, 1) foreach $item (@a, @b) {
•$item *= 7,
print Sitem , > 3.5 21 0 7
Модификация списков в цикле foreach оказывается более понятной и быстрой, чем в эквивалентном коде с циклом for и указанием конкретных индексов. Это не ошибка; такая возможность была намеренно предусмотрена разработчиками языка. Не зная о ней, можно случайно изменить содержимое списка. Теперь вы знаете.
Например, применение s/// к элементам списка, возвращаемого функцией values, приведет к модификации только копий, но не самого хэша. Однако срез хэша (s>hash{ keys %hash} (см. главу 5 «Хэши») дает нам нечто, что все же можно изменить с пользой для дела:
# Убрать пропуски из скалярной величины, массива и всех элементов хэша foreach (Sscalar, @array, @hash{keys %hash}) {
s/\s+$//, }
По причинам, связанным с эквивалентными конструкциями командного интерпретатора Борна для UNIX, ключевые слова for и foreach взаимозаменяемы:
for $item (@array) { # То же, что и foreach $item (@array) # Сделать что-то
for (@array) { # То же, что и foreach $_ (@array)
Подобный стиль часто показывает, что автор занимается написанием или сопровождением сценариев интерпретатора и связан с системным администрированием UNIX. Жизнь таких людей н без того сложна, поэтому не стоит судить их слишком строго.
О Смотри также
Разделы «For Loops», «Foreach Loops» и «Loop Control» perlsyn(l); раздел «Temporary Values via local()» peiisub(l). Оператор local() рассматривается в рецепте 10.13, a my() — в рецепте 10.2.
4.5. Перебор массива по ссылке
Проблема
Имеется ссылка на массив. Вы хотите использовать foreach для обращения к каждому элементу массива.
Решение
Для перебора разыменованного (dereferenced) массива используется цикл foreach или for:
й Перебор элементов массива SARRAYREF foreach $item(@$ARRAYREF) { П Сделать что-то с $item
for ($i = 0, $1 <= $#$ARRAYREF, $i++) { й Сделать что-то с $ARARAYREF->[$i]
Комментарий
Приведенное решение предполагает, что у вас имеется скалярная переменная, содержащая ссылку па массив. Это позволяет делать следующее:
@fruits = ( Apple , Blackberry ), $fruit_ref = \@>fruits, foreach $fruit (@$fruit_ref) {
print $fruit tastes good in a pie \n , }
Apple tastes good in a pie. Blackberry tastes good in a pie.
Цикл foreach можно переписать в цикле for следующего вида:
for ($1=0, $i <= $#$fruit_ref, $i++) {
print $fruit_ref->[$i] tastes good in a pie \n",
Однако ссылка па массив нередко является результатом более сложного выражения. Для превращения такого результата в массив применяется конструкция @{ EXPR }:
$namelist{felines} = \@rogue_cats, foreach Scat ( @{ $namelist{felines} } ) {
print Scat purrs hypnotically \n , } print --More--\nYou are controlled \n
Как и прежде, цикл foreach можно заменшь эквивалентным циклом for:
for ($i=0, $i <= $#{ $namelist{felines} }, $i++) {
print $namelist{felines}[$i] purrs hypnotically \n ,
> Смотри также---------------------------------------------------------------------------------------------
perlref(i) и peillol(l); рецепты 4 4; 11.1.
4.6. Выборка уникальных элементов из списка
Проблема
Требуется удалить из списка повюряющиеся элементы — например, при построении списка из файла или на базе выходных данных некоей команды. Рецепт в равно]! мере относится как к удалению дубликатов при вводе, так и в уже заполненных массивах.
Решение
Хэш используется для сохранения встречавшихся ранее элементов, а функция keys — для их извлечения. Принятая в Perl концепция истинности позволит уменьшить объем программы и ускорить ее работу.
Прямолинейно
%seen = (), @uniq = ()
foreach Sitpm (@list) { unless ($seen{$item})
# Если мы попали сюда, значит, элемент не встречался ранее
$seen{$item} = 1
push(@umq $item),
Быстро
%seen = (),
foreach $item (ia>list) {
push((g>uniq Sitem) unless $seen{$item}++,
%seen =(),
foreach $item (@list) {
some_func($item) unless $seen{$item}++ }
Быстро, но по-другому
%seen = (),
foreach $item (@list) { $seen{$item}++,
V /
@uniq = keys %seen,
Быстро и совсем по-другому
%seen = (),
©unique = grep { ' $seen{$_} ++ } @list,
Комментарий
Суть сводится к простому вопросу — встречался ли данный элемент раньше? %эпш идеально подходят для подобного поиска. В первом варианте («Прямолинейно») массив уникальных значений строится но мере обработки исходного списка, а для регистрации встречавшихся значений используется хэш.
Второй вариант («Быстро») представляет собой самый естественный способ решения подобных задач в Perl. Каждый раз, когда встречается новое значение, в хэш с помощью оператора ++ добавляется новый элемент. Побочный эффект состоит в том, что в хэш попадают ж e повторяющиеся экземпляры. В данном случае хэш работает как множество.
Третий вариант («Аналогично, но с пользовательской функцией») похож на второй, однако вместо сохранения значения мы вызываем некоторую пользовательскую функцию и передаем ей это значение в качестве аргумента. Если ничего больше не требуется, хранить отдельный массив уникальных значений будет излишне.
В следующем варианте («Быстро, по по-другому») уникальные ключи извлекаются из хэша %seen лишь после того, как он будет полностью построен. Иногда это удобно, но исходный порядок элементов утрачивается.
В последнем варианте («Быстро и совсем по-другому») построение хэша %seen объединяется с извлечением уникальных элементов. При этом сохраняется исходный порядок элементов.
Использование хэша для записи значений имеет два побочных эффекта: при обработке длинных списков расходуется много памяти, а список, возвращаемый keys, не отсортирован в алфавитном или числовом порядке и не сохраняет порядок вставки.
# Построить список зарегистрированных пользователей с удалением дубликатов
%ucnt = (),
for ( who ) {
s/\s *\n//, # Стереть от первого пробела до конца строки -й остается имя пользователя
$ucnt{$_}++, # Зафиксировать присутствие данного пользователя >
# Извлечь и вывести уникальные ключи
@users = sort keys %ucnt,
print users logged in @users\n ,
> Смотри также---------------------------------------------------------------------------------------------
Раздел «Foreach Loops» perlsyn(l); описание функции keys вреИ/ипс(\). Аналогичное применение хэшей продемонстрировано в рецептах 4.7 и 4.8.
4.7. Поиск элементов одного массива, отсутствующих в другом массиве
Проблема
Требуется найти элементы, которые присутствуют в одном массиве, но отсутствуют в другом.
Решение
Мы ищем элементы @А, которых пет в @>В. Постройте хэш из ключей @В — он будет использоваться в качестве таблицы просмотра. Затем проверьте каждый элемент @А и посмотрите, присутствует ли он в @>В.
Простейшая реализация
# Предполагается, что @А и @В уже загружены
%seen = (), # Хэш для проверки принадлежности элемента В (Эаоп1у =(), й Ответ
# Построить таблицу просмотра
foreach $item (@B) { $seen{$item} = 1 }
# Найти элементы @А, отсутствующие в @В
foreach $item (@A) {
unless $item (@A) {
й Отсутствует в %seen, поэтому добавить в @aonly push(@aonly, $item),
128 Глава 4 • Массивы Идиоматическая версия
1my %seen, # Таблица просмотра ray @aonly, 8 Ответй Построить таблицу просмотра @seen{@B} = ().
foreach $item (@А) {
push(@aonly, $item) unless exists $seen{$item},
Комментарий
Практически любая проблема, при которой требуется определить принадлежность скалярной величины к списку или массиву, решается в Perl с помощью хэ-шей. Сначала мы обрабатываем @В и регистрируем в хэше %seen псе элементы @>В, присваивая соответствующему элементу хэша значение 1. Затем мы последовательно перебираем все элементы @А и проверяем, присутствует ли данный элемент в хэше %seen (то есть в @В).
В приведенном фрагменте ответ будет содержать дубликаты из массива @А. Ситуацию нетрудно исправить, для этого достаточно включать элементы @А в %seen но мере обработки:
foreach $item (@A) {
push (@aonly, $item) unless $seen{$item},
$seen{$item} =1 8 Пометить как уже встречавшийся
}
Эти решения в основном отличаются по способу построения хэша. В первом варианте перебирается содержимое @>В. Во втором для инициализации хэша используется срез. Следующий пример наглядно демонстрирует срезы хэша. Фрагмент:
$hash{ key1 } = 1, $hash{ key2 > = 2,
эквивалентен следующему:
gnash{ key1 , key2 } = (1,2),
Список в фигурных скобках содержит ключи, а список справа — значения. В первом решении %seen инициализируется перебором всех элементов @В и присваиванием соответствующим элементам %seen значения 1. Во втором мы просто говорим:
@seen{@iB> = ()
В этом случае элементы @>В используются в качестве ключей для %seen, а с ними ассоциируется undef, поскольку количество значений в правой части меньше количества позиций для их размещения. Показанный вариант работает,
@seen{§B} = (1) х @В,
Е> Смотри также-------------------------------------------------------------------------------------------
Описание срезов хэшей в perldata(i). Аналогичное применение хэшей продемонстрировано в рецептах 4.7 и 4.8.
4.8. Вычисление объединения, пересечения и разности уникальных списков
Проблема
Имеются два списка, каждый из которых содержит неповторяющиеся элементы. Требуется узнать, какие элементы присутствуют в обоих списках (пересечение), присутствуют в одном и отсутствуют в другом списке (разность) или хотя бы в одном нз списков (объединение).
Решение
В приведенных ниже решениях списки инициализируются следующим образом:
@а = (1, 3, 5, 6, 7, 8), (s>b = (2, 3, 5 7, 9),
@umon = (Sisect = @diff = (), %umon = %isect = (), %count =(),
Простое решение для объединения и пересечения
foreach $е(@а) { $union{$e} = 1 }
foreach $e (@b) {
if ( $umon{$e} ) { $isect{$e} = 1 }
$umon {$e} = 1, >
@umon = keys %umon, @>isect = keys %isect,
Идиоматическое решение
foreach $e (@a, @b) { $umon{$e}++ && $isect{$e}++ }
@union = keys %umons, @isect = keys %isect,
foreach $e (@a, §b) { $count{$e}++ }
foreach $e (keys %count) { push(@umon, $e), if ($count{$e} == 2) {
push @isect, $e, } else {
push @diff, $e,
Косвенное решение
@isect = @diff = @umon = (),
foreach $e (@a, @b) { $count{$e}++ }
foreach $e (keys %count) { push(@umon, $e), push @{ $count{$e} == 2 ? \@isect \@diff },
Комментарий
В первом решении происходит непосредственное вычисление объединения и пересечения двух списков, ни один из которых не содержит дубликатов. Для записи элементов, принадлежащих к объединению и пересечению, используются два разных хэша. Сначала мы заносим каждый элемент первого массива в хэш объединения и ассоциируем с ним истинное значение. Затем при последовательной обработке элементов второго массива мы проверяем, присутствует ли элемент в объединении. Если присутствует, он также включается и в хэш пересечения. В любом случае элемент заносится в хэш объединения. После завершения перебора мы извлекаем ключи обоих хэшей. Ассоциированные с ними значения не нужны.
Второе решение («Идиоматическое») в сущности делает то же самое, однако для него потребуется хорошее знание операторов Perl (а также awk, С, C++ и Java) ++ и &&. Если ++ находится после переменной, то ее старое значение используется до приращения. Когда элемент встречается впервые, он еще отсутствует в объединении, поэтому первая часть && будет ложной, а вторая часть попросту игнорируется. Когда тот же элемент встретится во второй раз, он уже присутствует в объединении, поэтому мы заносим его и в пересечение.
В третьем решении использован всего один хэш для хранения информации о том, сколько раз встретился тот или иной элемент. Записав элементы обоих массивов в хэш, мы последовательно перебираем его ключи. Каждый ключ автоматически попадает в объединение. Ключи, с которыми ассоциировано значение 2, присутствуют в обоих массивах и потому заносятся в массив пересече-
ния. Ключи с ассоциированным значением 1 встречаются лишь в одном из двух массивов и заносятся в массив разности. В отличие от исходного решения, порядок элементов в выходных массивах не совпадает с порядком элементов входных массивов.
В последнем решении, как и в предыдущем, используется всего один хэш с количеством экземпляров каждого элемента Однако на этот раз реализация построена на массиве в блоке @{ }.
Мы вычисляем не простую, а симметричную разность. Эти термины происходят из теории множеств. Симметричная разность представляет собой набор всех элементов, являющихся членами либо @А, либо @В, но не обоих сразу. Простая разность — набор всех элементов @А, отсутствующих в §В (см. рецепт 4,7).
> Смотри также---------------------------------------------------------------------------------------------
Аналогичное применение хэшей продемонстрировано в рецептах 4.7 и 4.8.
4.9. Присоединение массива
Проблема
Требуется объединить два массива, дописав все элементы одного из них в конец другого.
Решение
Воспользуйтесь функцией push:
# push
push(@ARRAY1, @ARRAY2),
Комментарий
Функция push оптимизирована для записи списка в конец массива. Два массива также можно объединить посредством сглаживания (flattening) списков Perl, однако в этом случае выполняется намного больше операций копирования, чем при использовании push:
@ARRAY1 = (©ARRAY1, @ARRAY2)
Ниже показан пример практического использования push-
©members = ( Time Flies ), ©initiates = ( An , Arrow ), push(@>members, ©initiates),
# ©members содержит элементы ( Time , Flies , An , Arrow )
Если содержимое одного массива требуется вставить в середину другого, воспользуйтесь функцией splice:
splice(@members, 2, 0, Like , ©initiates), print @members\n , splice(@members, 0, 1, Fruit ),
Результат выглядит так:
Time Flies Like An Arrow Fruit Flies Like A Banana
> Смотри также-------------------------------
Описание функций splice и push вperlfunc(l); раздел «List Value Constructors» perldata(l).
4.10. Обращение массива
Проблема
Требуется обратить массив (то есть переставить элементы в противоположном порядке).
Решение
Воспользуйтесь функцией reverse:
# Обращение ©ARRAY дает ©REVERSED ©REVERSED = reverse ©ARRAY,
Также можно воспользоваться циклом for:
for ($l = $#ARRAY, $i >= 0 $l--) { # Сделать что-то с $ARRAY[$i]
Комментарий
Настоящее обращение списка выполняется функцней reverse; цикл for просто перебирает элементы в обратном порядке. Если обращенная копия списка не нужна, цикл for экономит память и время.
Если функция reverse используется для обращения только что отсортированного списка, логичнее будет сразу отсортировать список в нужном порядке. Например:
№ Два шага сортировка, затем обращение ©ascending = sort { $a cmp $b } ©users, ©descending = reverse ©ascending,
# Один шаг сортировка с обратным сравнением ©descending = sort { $b cmp $a } ©users,
> Смотри также---------------------------------------------------------------------------------------------
Описание функции reverse в perlfunc{\). Она используется в рецепте 1.6.
4.11. Обработка нескольких элементов массива
Проблема
Требуется удалить сразу несколько элементов в начале или конце массива.
Решение
Воспользуйтесь функцией splice:
# Удалить $N элементов с начала ©ARRAY (shift $N)
CFRONT = splice(@ARRAY, 0, $N),
# Удалить $N элементов с конца массива (pop $N)
©END = spllce(@ARRAY, -$N),
Комментарий
Часто бывает удобно оформить эти операции в виде функций:
sub shift2
return splice(@{$_[0]}, 0, 2),
sub pop2 (\@) {
return splice(@{$_[0]}, 0, -2), >
Использование функций делает код более наглядным:
©friends = qw(Peter Paul Mary Jim Tim), ($this $that) = shift2(pfriends),
# $this содержит Peter, $that - Paul,
# a ©friends - Mary, Jim и Tim
©beverages = qw(Dew Jolt Cola Sprite Fresca),
@pair = pop2(©beverages),
U $pair[0] содержит $sprite, $pair[1] - Fresca,
# a ©beverages - (Dew, Jolt, Cola)
Функция splice возвращает элементы, удаленные из массива, поэтому shif t2 заменяет первые два элемента @ARRAY ничем (то есть удаляет их) и возвращает два удаленных элемента. Функция рор2 удаляет и возвращает два последних элемента.
В качестве аргументов этим функциям передается ссылка на массив — это сделано для того, чтобы они лучше имитировали встроенные функции shift и pop. При вызове ссылка не передается явно, с использованием символа \. Вместо этого компилятор, встречая прототип со ссылкой на массив, организует передачу массива по ссылке. Преимущества такого подхода — эффективность, наглядность и проверка параметров на стадии компиляции. Недостаток — передаваемый
$line[5] = \@list,
©got = рор2( @{ $lme[5] } ),
Перед вами еще один пример, когда вместо простого списка должен использоваться массив. Прототип \@ требует, чтобы объект, занимающий данную позицию в списке аргументов, был массивом. $line[5] представляет собой не массив, а ссылку на него. Вот почему нам понадобился «лишний» знак @.
> Смотри также ---------------------------------------------------------------------------------------------
Описание функции splice вperlfunc(l); раздел «Prototypes» perlsub(i). Функция splice используется в рецепте 4.9.
4.12. Поиск первого элемента списка, удовлетворяющего некоторому критерию
Проблема
Требуется найти первый элемент списка, удовлетворяющего некоторому критерию (или индекс этого элемента). Возможна и другая формулировка — определить, проходит ли проверку хотя бы один элемент. Критерий может быть как простым («Присутствует ли элемент в списке?»)1, так и сложным («Имеется список работников, отсортированный в порядке убывания оклада. У кого из менеджеров самый высокий оклад?»). В простых случаях дело обычно ограничивается значением элемента, но если сам массив может изменяться, вероятно, следует определять индекс первого подходящего элемента.
Решение
Перебирайте элементы в цикле f о reach и вызовите last, как только критерий будет выполнен:
ray($match, $found $itera), foreach $item(@array) { if (Scnterion) {
$match = $item, # Необходимо сохранить
$found = 1
last,
if($found) {
## Сделать что-то с $match } else {
Чтобы определить индекс, перебирайте все индексы массива и вызывайте last, как только критерий выполнится:
my($i, $match_idx), for ($1 =0, $i < @аггау $i++) { if ($cnterion) {
$match_idx = $i, # Сохранить индекс
last,
if(defmed $match_idx) {
## Найден элемент $array[$match_idx] } else {
## Неудачный поиск
Комментарий
Стандартных механизмов для решения этой задачи не существует, поэтому мы напишем собственный код для перебора и проверки каждого элемента. В нем используются циклы f о reach и for, а вызов last прекращает проверку при выполнении условия. Но перед тем, как прерывать поиск с помощью last, следует сохранить найденный индекс.
Одна из распространенных ошибок — использование функции g rep. Дело в том, что grep проверяет все элементы и находит все совпадения; если вас интересует только первое совпадение, этот вариант неэффективен.
Если нас интересует значение первого найденного элемента, присвойте его переменной $match. Мы не можем просто проверять $item в конце цикла, потому что f о reach автоматически локализует1 переменную-итератор и потому не позволяет узнать ее последнее значение после завершения цикла (см. рецепт АЛ)
Рассмотрим пример. Предположим, в массиве @employees находится список объектов с информацией о работниках, отсортированный в порядке убывания оклада. Мы хотим найти инженера с максимальным окладом; это будет первый инженер в массиве. Требуется только вывести имя инженера, поэтому нас интересует не индекс, а значение элемента.
foreach $employee (©employees) {
if ( $employee->category() eq engineer ) { $highest_engmeer = Semployee last,
print Highest paid engineer is , $highest_engineer->name(), \n ,
for ($1 =0, $1 < ©ARRAY, $l++) {
last if $cnterion, } If ($1 < @ARRAY) {
## Критерий выполняется по индексу $1 } else {
## Неудачный поиск
t> Смотри также
Разделы «For Loops», «Foreach Loops» и «Loop Control»perlsyn(l); описание функции grep вperlfunc(l).
4.13. Поиск всех элементов массива, удовлетворяющих определенному критерию
Проблема
Требуется найти все элементы списка, удовлетворяющие определенному критерию.
Проблема извлечения подмножества из списка остается прежней. Вопрос заключается в том, как найти всех инженеров в списке работников, всех пользователей в административной группе, все интересующие вас имена файлов и т. д.
Решение
Воспользуйтесь функцией grep. Функция применяет критерий ко всем элементам списка и возвращает лишь те, для которых он выполняется:
©РЕЗУЛЬТАТ = grep { КРИТЕРИЙ ($_) } ©СПИСОК,
Комментарий
То же самое можно было сделать в цикле foreach:
©РЕЗУЛЬТАТ = (), foreach (©СПИСОК) {
ризп(@РЕЗУЛЬТАТ, $_) If КРИТЕРИЙ ($_), }
Функция Perl g rep позволяет записать всю эту возню с циклами более компактно. В действительности функция дгер сильно отличается от одноименной команды UNIX — она не имеет параметров для нумерации строк или инвертирования критерия и не ограничивается проверками регулярных выражений. Например, чтобы отфильтровать из массива очень большие числа или определить, с какими ключами хэша ассоциированы очень большие значения, применяется следующая запись:
©bigs = grep { $_ > 1_000_000 } ©nums,
©pigs = grep { $users{$_} > 1e7 } keys %users,
В следующем примере в @matching заносятся строки, полученные от команды who и начинающиеся с gnat :
©matching = grep { /"gnat / } who , Или другой пример:
©engineers = grep { $_->position() eq Engineer' } ©employees,
Из массива @employees извлекаются только те объекты, для которых метод position() возвращает строку Engineer.
Grep позволяет выполнять и более сложные проверки:
@secondary_assistance = grep { $_->income >= 26_000 &&
$_->income < 30_000 } ©applicants,
Однако в таких ситуациях бывает разумнее написать цикл.
> Смотри также---------------------------------------------------------------------------------------------
Разделы «For Loops», «Foreach Loops» и «Loop Control» perlsyn(l); описание функции grep в perlfunc(l); страница руководства who(i) вашей системы (если есть); рецепт 4.12.
4.14. Числовая сортировка массива
Проблема
Требуется отсортировать список чисел, однако функция Perl sort (по умолчанию) выполняет алфавитную сортировку в ASCII-порядке.
Решение
Воспользуйтесь функцией Perl sort с оператором числового сравнения, оператор <=>:
©Sorted = sort { $a <=> $b } ©Unsorted,
При вызове функции sort можно передавать необязательный программный блок, с помощью которого принятый по умолчанию алфавитный порядок сравнения заменяется вашим собственным. Функция сравнения вызывается каждый раз, когда sort сравнивает две величины. Сравниваемые значения загружаются в специальные пакетные переменные $а и $Ь, которые автоматически локализуются.
Функция сравнения должна возвращать отрицательное число, если значение $а должно находиться в выходных данных перед $Ь; 0, если они совпадают или порядок несущественен; и положительное число, если значение $а должно находиться после $Ь. В Perl существуют два оператора с таким поведением: оператор <=> сортирует числа по возрастанию в числовом порядке, а стр сортирует строки по возрастанию в алфавитном порядке. По умолчанию sort использует сравнения в стиле стр.
Следующий фрагмент сортирует список идентификаторов процессов (PID) в массиве @pids, предлагает пользователю выбрать один PID и посылает сигнал TERM, за которым следует сигнал KILL. В необязательном программном блоке $а сравнивается с $Ь оператором <=>, что обеспечивает числовую сортировку.
# @>pids - несортированный массив идентификаторов процессов foreach my $pid (sort { $a <=> $b } @pids) {
print $pid\n , }
print Select a process ID to kill \n , chomp ($pid = <>),
die Exiting \n unless $pid && $pid =~ /~\d=$/, kill ( TERM ,$pid) sleep 2, kill ( KILL ,$pid),
При использовании условия $a<=>$b или $а cmp $b список сортируется в порядке возрастания. Чтобы сортировка выполнялась в порядке убывания, достаточно поменять местами $а и $Ь в функции сравнения:
©descending = sort { $b <=> $а } @unsorted,
Функции сравнения должны быть последовательными; иначе говоря, функция всегда должна возвращать один и тот же ответ для одинаковых величин. Непоследовательные функции сравнения приводят к зацикливанию программы или ее аварийному завершению, особенно в старых версиях Perl.
Также возможна конструкция вида sort ИМЯ СПИСОК, где ИМЯ — имя функции сравнения, возвращающей -1, 0 или +1. В интересах быстродействия нормальные правила вызова не соблюдаются, а сравниваемые значения, как по волшебству, появляются в глобальных пакетных переменных $а и $Ь. Из-за особенностей вызова этой функции в Perl рекурсия в ней может не работать.
Предупреждение: значения $а и $Ь задаются в пакете, активном в момент вызова sort, — а он может не совпадать с пакетом, в котором была откомпилирована передаваемая sort функция сравнения (ИМЯ)! Например:
package Sort_Subs,
sub revnum { $b <=> $a }
package Other_Pack,
@all = sort Sort_Subs revnum 4, 19, 8, 3,
Такая попытка тихо заканчивается неудачей — впрочем, при наличии ключа -хю о неудаче будет заявлено вслух. Дело в том, что вызов sort создает пакетные переменные $а и $Ь в своем собственном пакете, Other_Pack, а функция revnum будет использовать версии из своего пакета. Это еще один аргумент в пользу встроенных функций сортировки:
@all = sort { $b <=> $а } 4, 19 8, 3
За дополнительной информацией о пакетах обращайтесь к главе 10 «Подпрограммы».
> Смотри также---------------------------------------------------------------------------------------------
Описание операторов стр и <=> Bperlop(l); описание функций kill, sort и sleep в perlfunc(l); рецепт 4.15.
4.15. Сортировка списка по вычисляемому полю
Проблема
Требуется отсортировать список, руководствуясь более сложным критерием, нежели простыми строковыми или числовыми сравнениям.
Такая проблема часто встречается при работе с объектами или сложными структурами данных («отсортировать по третьему элементу массива, на который указывает данная ссылка»). Кроме того, она относится к сортировке по нескольким ключам — например, когда список сортируется по дню рождения, а затем по имени (когда у нескольких людей совпадают дни рождения).
Решение
Воспользуйтесь нестандартной функцией сравнения в sort: ©ordered = sort { compareQ } ©unordered, Для ускорения работы значение поля можно вычислить заранее:
@рrecomputed = map { [computeO, $_] } ©unordered,
@ordered_precomputed = sort { $a->[0] <=> $b->[0] } ©precomputed,
©ordered = map { $_->[1] } @ordered_precomputed,
Наконец, эти три шага можно объединить:
©ordered = map { $_->[1] }
sort { $a->[0] <=> $b->[0] } map { [computeO, $_] } ©unordered,
О том, как пользоваться функциями сравнения, рассказано в рецепте 4.14. Помимо использования встроенных операторов вроде <=>, можно конструировать более сложные условия:
©ordered = sort { $a->name cmp $b->name } ©employees,
Функция sort часто используется подобным образом в циклах foreach:
foreach $employee (sort {$a->name cmp $b->name } (^employees) {
print $employee->name, earns \$ , $employee->salary, \n , }
Если вы собираетесь много работать с элементами, расположенными в определенном порядке, эффективнее будет сразу отсортировать их и работать с отсортированным списком:
@sorted_employees = sort { $a->name cmp $b->name } ©employees, foreach $employee (©sorted_employees) {
print $employee->name, earns \$ , $employee->salary, \n , }
Я Загрузить %bonus foreach $employee (@sorted_employees) {
if ($bonus{ $employee->ssn } ) {
print $employee->name, got a bonus1\n ,
В функцию можно включить несколько условий и разделить их операторами ||. Оператор || возвращает первое истинное (ненулевое) значение Следовательно, сортировку можно выполнять по одному критерию, а при равенстве элементов (когда возвращаемое значение равно 0) сортировать по другому критерию. Получается «сортировка внутри сортировки»:
©sorted = sort {$a->name cmp $b->name
II $b->age <=> $a->age) ©employees,
Первый критерий сравнивает имена двух работников. Если они не совпадают, 11 прекращает вычисления и возвращает результат cmp (сортировка в порядке возрастания имен). Но если имена совпадают, 11 продолжает проверку и возвращает результат <=> (сортировка в порядке убывания возраста). Полученный список будет отсортирован по именам и по возрасту в группах с одинаковыми именами.
Давайте рассмотрим реальный пример сортировки. Мы собираем информацию обо всех пользователям в виде объектов User pwent, после чего сортируем их по именам и выводим отсортированный список:
use User pwent qw(getpwent), ©users = (),
# Выбрать всех пользователей while (aefined($user = getpwent)) { push(@users, $user),
gusers = sort { $a->name cmp $b-<name } ©users, foreach $user (©users) {
print $user->name, \n , }
Возможности не ограничиваются простыми сравнениями или комбинациями простых сравнений. В следующем примере список имен сортируется по второй букве имени. Вторая буква извлекается функцией substr:
©sorted = sort { substr($a 1,1) cmp substr($b,1 1) } @names, А ниже список сортируется по длине строки:
©sorted = sort { length $a <=> length $b } ©strings,
Функция сравнения вызывается sort каждый раз, когда требуется сравнить два элемента. Число сравнений заметно увеличивается с количеством сортируемых элементов. Сортировка 10 элементов требует (в среднем) 46 сравнений, однако при сортировке 1000 элементов выполняется 14 000 сравнений. Медленные операции (например, split или вызов подпрограммы) при каждом сравнении тормозят работу программы.
К счастью, проблема решается однократным выполнением операции для каждого элемента перед сортировкой. Воспользуйтесь тар для сохранения результатов операции в массиве, элементы которого являются анонимными массивами с исходным и вычисленным полем. Этот «массив массивов» сортируется по предварительно вычисленному полю, после чего тар используется для получения отсортированных исходных данных. Концепция map/sort/map применяется часто и с пользой, поэтому ее стоит рассмотреть более подробно.
Применим ее к примеру с сортировкой по длине строки:
©temp = map { [ length $_, $_ ] } ©strings, ©temp = sort { $a->[0] <=> $b->[0] } @temp, ©sorted = map { $_->[1] } ©temp,
В первой строке map создает временный массив строк с их длинами. Вторая строка сортирует временный массив, сравнивая их предварительно вычисленные длины. Третья строка превращает временный массив строк/длин в отсортированный массив строк. Таким образом, длина каждой строки вычисляется всего один раз.
Поскольку входные данные каждой строки представляют собой выходные данные предыдущей строки (массив @temp, созданный в строке 1, передается sort в строке 2, а результат сортировки передается тар в строке 3), их можно объединить в одну команду и отказаться от временного массива:
©sorted = map { $_->[1] >
sort {$a->[0] <=> $b->[0] } map { [ length $_, $_] } ©strings,
Теперь операции перечисляются в обратном порядке. Встречая конструкцию map/sort/map, читайте ее снизу вверх:
тар: нижний вызов тар строит временный список анонимных массивов. Список содержит пары из предварительно вычисленного поля (length $_) и исходного элемента ($_). В этой строке показано, как происходит вычисление поля.
sort: список анонимных массивов сортируется посредством сравнения предварительно вычисленных полей. По этой строке трудно о чем-то судить — разве что о том, будет ли список отсортирован в порядке возрастания или убывания.
тар: вызов тар в начале команды превращает отсортированный список анонимных массивов в список исходных отсортированных элементов. Как правило, во всех конструкциях map/sort/map он выглядит одинаково.
Ниже показан более сложный пример, в котором сортировка выполняется по первому числу, найденному в каждой строке §f ields:
@temp = map { [ /(\d+)/, $_ ] } ©fields, @sorted_temp = sort {$a->[0] <=> $b->[0] } @temp, <5>sorted_fields = map { $_->["!] } @sorted_temp,
Регулярное выражение в первой строке извлекает из строки, обрабатываемой тар, первое число. Мы используем регулярное выражение /(\d+)/ в списковом контексте.
Из этого фрагмента можно убрать временный массив. Код принимает следующий вид:
@sorted_fields = map { $_->[1] }
sort { $a->[0] <=> $b->[0] } пар { [ /(\d+)/, $_ ] } ©fields,
В последнем примере выполняется компактная сортировка данных, разделенных запятыми (они взяты из файла UNIX passwd). Сначала выполняется числовая сортировка файла по четвертому полю (идентификатору группы), затем — числовая сортировка по третьему полю (идентификатору пользователя) и алфавитная сортировка по первому полю (имени пользователя).
print map { $_->[0] } # Целая строка
sort {
$а->[1] <=> $Ь->[1] # Идентификатор группы
II $а->[2] <=> $Ь->[2] # Идентификатор пользователя
II
$а->[3] <=> $Ь->[3] # Имя пользователя }
тар { [ $_, (split / /)[3,2,0] ] } cat /etc/passwd',
Компактная конструкция map/sort/map больше напоминает программирование на Lisp и Scheme, нежели обычное наследие Perl — С и awk. Впервые она была предложена Рэндалом Шварцем (Randal Schwartz) и потому часто называется «преобразованием Шварца».
> Смотри также---------------------------------------------------------------------------------------------
Описание функции sort вperlfunc(l); описание операторов стр и <=> вperlop(l); рецепт 4.14.
4.16. Реализация циклических списков
Проблема
Требуется создать циклический список и организовать работу с ним.
Решение
Воспользуйтесь функциями unshift и pop (или push и shift) для обычного массива.
unshift(@circular, pop(@circular)), # Последний становится первым push (^circular, shift(@circular)), # И наоборот
Комментарий
Циклические списки обычно применяются для многократного выполнения одной и той же последовательности действий — например, обработки подключений к серверу. Приведенный выше фрагмент не является полноценной компьютерной реализацией циклических списков с указателями и настоящей цикличностью. Вместо этого мы просто перемещаем последний элемент на первую позицию, и наоборот.
sub grab_and_rotate (\@ ) { пу Slistref = shift, my $element = $listref->[0], push(@listref, shift @$listref), return $element;
§processes = ( 1, 2, 3, 4, 5 ),
while (1) {
Sprocess = grab_and_rotate(@>processes), print Handling process $process\n", sleep 1,
> Смотри также---------------------------------------------------------------------------------------------
Описание функций unshift и push в perlfunc(l); рецепт 13.13.
Проблема
Требуется случайным образом переставить элементы массива. Наиболее очевидное применение — тасование колоды в карточной игре, однако аналогичная задача возникает в любой ситуации, где элементы массива обрабатываются в произвольном порядке.
Решение
Каждый элемент массива меняется местом с другим, случайно выбранным элементом:
U fisher_yates_shuffle ( \@array ) генерация случайной перестановки # массива @аггау на месте sub fisher_yates_shuffle < my $array = shift, my $i,
for ($i = @$array, --$i, ) { my $] = int rand ($i+1), next if $i == $], @$array[$i,$j] = @$array[$j,$i],
fisher_yates_shuffle( \@array ), ft Перестановка массива @array на месте
Или выберите случайную перестановку, воспользовавшись кодом из примера 4.4:
Spermutations = factorial^ scalar @array ),
@shuffle = @>array [ n2perm( 1+int(rand Spermutations), $#array) ],
Комментарий
Случайные перестановки на удивление коварны. Написать плохую программу перестановки очень просто:
sub naive_sriuffle { # Не делайте так1
for (my $i = 0, $i < §_, $i++) {
my $j = int rand @_, # Выбрать случайный элемент
($_[$i], $_[$j]) = ($_[$j], $_[$i]), # Поменять местами
Такой алгоритм является смещенным — одни перестановки имеют большую вероятность, чем другие. Это нетрудно доказать: предположим, мы получили список из 3 элементов. Мы генерируем 3 случайных числа, каждое из которых может принимать 3 возможных значения — итого 27 возможных комбинаций. Однако для списка из трех элементов существует всего 6 перестановок. Поскольку 27 не делится на 6, некоторые перестановки появляются с большей вероятностью, чем другие.
В приведенном выше алгоритме Фишера— Йетса это смещение устраняется за счет изменения интервала выбираемых случайных чисел.
Смотри также
Описание функции rand B.peilfunc(\). Дополнительная информация о случайных числах приведена в Рецептах 2.7-2.9. В рецепте 4.19 показан другой способ построения случайных перестановок.
4.18. Программа: words
Описание
Вас когда-нибудь интересовало, каким образом программы типа Is строят столбцы отсортированных выходных данных, расположенных по столбцам, а не по строкам? Например:
|
aw k |
cp |
ed |
login |
mount |
rmdir |
sum |
|
basename |
csh |
egrep |
Is |
mt |
sed |
sync |
|
cat |
date |
fgrep |
mail |
mv |
sh |
tar |
|
chgrp |
dd |
grep |
mkdir |
ps |
sort |
touch |
|
chfflod |
df |
kill |
mknod |
pwd |
stty |
VI |
|
chown |
echo |
In |
more |
rm |
su |
|
|
В примере 4.2 |
показано, |
как это |
делается. |
|||
|
Пример |
4.2. words |
|||||
|
#' /usr/bm/perl |
-w |
|||||
|
# words • |
- вывод |
данных по |
столбцам |
my ($item, $cols, $rows, $maxlen), my (Sxpixel, Sypixel, $mask, @data),
getwinsize(),
# Получить все строки входных данных
# и запомнить максимальную длину строки
Smaxlen = 1,
while (о) { my $mylen, s/\s+$//,
Smaxlen = $mylen if (($mylen = length) > Smaxlen) push(@data, $_),
Smaxlen += 1, # Дополнительный пробел
# Определить границы экрана $cols = int($cols / Smaxlen) || 1,
продолжение
Глава 4 • Массивы
Пример 4.2. (продолжение)$rows = mt(($#data+$cols) / $cols),
# Задать маску для ускорения вычислений
$mask = sprintf( %%-%ds , $maxlen-1),
# Подпрограмма для обнаружения последнего элемента строки
sub EOL { ($item+1) % $cols == 0 }
й Обработать каждый элемент, выбирая нужный фрагмент
ft на основании позиции
for (Sitem = 0, $item < $rows * $cols, $item++) {
my Starget = ($itera % $cols) ¦ $rows + int($item/$cols)
my $piece = spnntf($mask $target < ©data ? $data[$target] ),
Ipiece =~ s/\s+$// if EOL(), # Последний элемент не выравнивать
print $piece,
print \n if EOL(),
# Завершить при необходимости
print \n if EOL(),
# He переносится -- только для Linux
sub getwmsize <
my Swinsize = \0 x 8,
my STIOCGWINSZ = 0x40087468,
if (ioctl(STDOUT, STIOCGWINSZ, Swinsize)) {
($rows, $cols, Sxpixel, Sypixel) = unpack( S4 , Swinsize), } else {
$cols = 80,
Наиболее очевидный способ вывести отсортированный список по столбцам — последовательно выводите каждый элемент списка, выравнивая его пробелами до определенной ширины. Когда вывод достигает конца строки, происходит переход на следующую строку. Но такой вариант хорош лишь тогда, когда строки читаются слева направо. Если данные должны читаться по столбцам, сверху вниз, приходится искать другое решение.
Программа words представляет собой фильтр, который генерирует выходные данные по столбцам. Она читает все входные данные и запоминает максимальную длину строки. После того как все данные будут прочитаны, ширина экрана делится на длину самой большой входной записи — результат равен ожидаемому количеству столбцов.
Затем программа входит в цикл, который выполняется для каждой входной записи. Однако порядок вывода неочевиден. Предположим, имеется список из девяти элементов:
Неправильно Правильно
Программа words производит все необходимые вычисления, чтобы элементы (1,4,7) выводились в одной строке, (2,5,8) — в другой и (3,6,9) — в последней строке.
Текущие размеры окна определяются вызовом loctl. Этот вариант прекрасно работает — в той системе, для которой он был написан. В любой другой он не подойдет. Если вас это устраивает, хорошо В рецепте 12.14 показано, как определить размер окна в вашей системе с помощью файла ioctl.pch или программы на С. Решение из рецепта 15.4 отличается большей переносимостью, однако вам придется установить модуль с CPAN.
> Смотри также---------------------------------------------------------------------------------------------
Рецепт 15.4.
4.19. Программа: permute
Проблема
Вам никогда не требовалось сгенерировать все возможные перестановки массива или выполнить некоторый фрагмент для всех возможных перестановок? Например:
% echo man bites dog | permute
dog bites man
bites dog man
dog man bites
man dog bites
bites man dog
man bites dog
Количество возможных перестановок для множества равно факториалу числа элементов в этом множестве. Оно растет чрезвычайно быстро, поэтому не стоит генерировать перестановки для большого числа элементов:
|
Размер множества |
Количество перестановок |
|
1 |
1 |
|
2 |
2 |
|
3 |
6 |
|
4 |
24 |
|
5 |
120 |
|
6 |
720 |
|
7 |
5040 |
|
8 |
40320 |
|
9 |
362880 |
|
10 |
3628800 |
|
11 |
39916800 |
|
12 |
479001600 |
|
13 |
6227020800 |
|
14 |
87178291200 |
|
15 |
1307674368000 |
use Math Biglnt,
sub factorial {
my $n = shift,
my $s = 1,
$s ¦= $n-while $n > 0,
return $s, }
print factorial(Math Biglnt->new( 500 )), +1220136...(1035 digits total)
Два решения, приведенных ниже, отличаются порядком возвращаемых перестановок.
Решение из примера 4.3 использует классический алгоритм списковых перестановок, используемый знатоками Lisp. Алгоритм относительно прямолинеен, однако в нем создаются ненужные копии. Кроме того, в решении жестко закодирован простой вывод перестановок без каких-либо дополнительных действий.
Пример 4.3. tdc-permute
й1/usr/bin/perl -п
# tsc_permute вывод всех перестановок введенных слов
permute([split], []),
sub permute {
my @items = (°>{ $_[0] }, my @perms = @{ $_[1] }, unless (@items) {
print @perms\n , } else {
my(@newitems,@newperms, $i),
foreach $i (0 Stfitems) {
@newitems = ©items,
@newperms = @perms,
unshift(@newperms, splice(@newitems, $i, 1)), permute([@newitems], Onewperms]),
Решение из примера 4.4, предложенное Марком-Джейсоном Доминусом (Mark-Jason Dominus), более элегантно и работает примерно на 25 % быстрее. Вместо того чтобы рассчитывать все перестановки, программа генерирует n-ю конкретную перестановку. Элегантность проявляется в двух аспектах. Во-первых, в программе удается избежать рекурсии, кроме как при вычислении факториала (который алгоритмом перестановок обычно не используется). Во-вторых, вместо перестановки реальных данных генерируется перестановка целых чисел.
149
В программе для экономии времени использована методика запоминания. Ее суть заключается в том, что функция, Которая всегда возвращает конкретный ответ для конкретного набора аргументов, запоминает этот ответ. При следующем вызове с теми же аргументами дальнейшие вычисления уже не потребуются. Функция factorial сохраняет ранее вычисленные значения факториала в закрытом массиве @f act ( 10.3).
Функция n2perm вызывается с двумя аргументами: номером генерируемой перестановки (от 0 до N!, где N — размер массива) и индексом последнего элемента массива. Функция n2perm для расчета шаблона перестановки вызывает подпрограмму n2pat. Затем шаблон преобразуется в перестановку целых чисел подпрограммой pat2perm. Шаблон представляет собой список вида (0 2 0 1 0), что означает: «Вырезать пулевой элемент, затем второй элемент оставшегося списка, затем нулевой, первый и снова пулевой».
Пример 4.4. mjd-permute
#' /usr/bm/perl -w
8 mjd_permute перестановка всех введенных слов
use strict,
while (о) {
my @data = split,
my $num_permutations = factorial(scalar @>data)
for (my $1=0, $i < $num_permutations $i++) {
my ©permutation = @data[n2perm($i, $#data)],
print @permutation\n ,
# Вспомогательная функция факториал с запоминанием BEGIN {
my ffact = (1), sub factonal($) { my $r> = shift,
return $fact[$n] if defined $fact[$n], $fact[$n] = $n * factorial($n - 1)
|
# n2pat($N, $len) построить |
||
|
sub n2pat { |
||
|
my $1 = |
1, |
|
|
my $N |
shift, |
|
|
my $len = |
shift, |
|
|
my @pat, |
||
|
while ($1 |
<= $len + |
1) { |
|
push |
@pat, $N % |
$i, |
|
$N = |
mt($N/$i), |
N—й шаблон перестановки длины $1еп
# На самом деле просто while ($N) {
продолжение
}
return @pat;
# pat2perm(@pat) : превратить шаблон, возвращаемый n2pat(),
# в перестановку целых чисел,
sub pat2perm {
my @pat = @_,
my @source = (0 .. $#pat);
my @perm;
push @perm, splice(@source, (pop @pat), 1) while @pat,
return @perm;
# n2perm($N, $len) • сгенерировать N-ю перестановку S объектов sub n2perm {
pat2perm(n2pat(@_));
> Смотри также
Описание функций unshift и splice вperlfunc(l); рецепты 2.7; 10.3.
Хэш и
Выполнять линейный просмотр в ассоциативном массиве — все равно что пытаться забить кого-нибудь до смерти заряженным «Узи».Ларри Уолл
Введение
Как люди, так и части компьютерных программ взаимодействуют между собой самым причудливым образом. Отдельные скалярные переменные похожи на отшельников, ведущих замкнутое существование в рамках собственной личности. Массив напоминает партию, где множество индивидуумов объединяется под именем харизматического предводителя. Где-то между ними расположилась удобная ниша, в которой живут совокупности связей «один-к-одному» — хэши. В старой документации по Perl хэши часто назывались ассоциативными массивами, но термин получается слишком длинным. Аналогичные структуры данных существуют и в других языках, где они обозначаются другими терминами — хэш-таблицы, таблицы, словари, отображения и даже а-списки, в зависимости от языка.
К сожалению, отношения хэшей являются не равными, а подчиненными — например, «Энди — начальник Ната»; «Кровяное давление пациента — 112/62» или «Название журнала с индексом ISSN 1087-903X — The Perl Journal». Хэш всего лишь предоставляет удобные средства для получения ответов на вопросы типа: «Кто является начальником Ната?» или «Как называется журнал 1087-903Х»? Вы не сможете спросить «Чьим начальником является Энди?» Впрочем, поиску ответов на подобные вопросы посвящен один из рецептов этой главы.
Однако у хэшей есть свои преимущества. В Perl хэш является встроенным типом данных. Благодаря применению хэшей многие сложные алгоритмы сводятся к простой выборке значений. Кроме того, хэши предоставляют быстрые и удобные средства для построения индексов и таблиц просмотра. Если для простой скалярной переменной применяется идентификатор типа $, а для массива — @, то для хэшей используется идентификатор %.
Префикс % относится лишь к ссылкам на хэш в целом. Значение ключа представляет собой скалярную величину, поэтому для него используется символ $ (по
В обычных массивах используются числовые индексы, но индексы хэшей всегда являются строковыми. Ассоциированные значения могут быть произвольными скалярными величинами, в том числе ссылками. Используя ссылки в качестве ассоциированных значений, можно создавать хэши для хранения не только строк и чисел, но и массивов, других хэшей или объектов (вернее, ссылок на массивы, хэшп или объекты).
Хэши могут инициализироваться с помощью списков, содержащих пары «ключ/ значение»:
%аде = ( "Nat", 24, "Jules", 25, "Josh", 17 );
Такая запись эквивалентна следующей:
$age{'Nat"} = 24, $age{"Jules"} = 25; $age<"Josh"} = 17;
Для упрощения инициализации хэшей был создан оператор, оператор =>. В основном он представляет собой более наглядную замену для запятой. Например, возможна следующая инициализация хэша:
%food_color = (
"Apple" => "red",
"Banana" => "yellow",
"Lemon" => "yellow",
"Carrot" => "orange"
);
(хэш %food_color используется во многих примерах этой главы). Такая инициализация также является примером списковой эквивалентности — в некоторых отношениях хэш ведет себя так, словно онявляется списком пар «ключ/значение». Мы воспользуемся этим в нескольких рецептах, в частности — для объединения и инвертирования.
В отличие от обычной запятой, оператор => обладает особым свойством: любое предшествующее ему слово интерпретируется как строковое значение. Это позволяет убрать кавычки и сделать программу более понятной. Однословные ключи хэшей также автоматически интерпретируются как строки, поэтому вместо $hash{"somekey"} можно написать просто $hash{somekey}. Приведенная выше инициализация %food_color записывается в следующем виде:
%food_color = (
Apple => "red",
Banana => "yellow",
Lemon => "yellow",
Carrot => "orange"
Одно из важных свойств хэшей заключается в том, что их элементы хранятся в особой последовательности, обесценивающей выборку. Следовательно, независимо от порядка занесения данных в хэш, порядок их хранения будет непредсказуемым.
> Смотри также--------------------------------------------------------------------------------------------
Описание функций unshift и splice вperlfunc(l).
5.1. Занесение элемента в хэш
Проблема
Требуется добавить в хэш новый элемент.
Решение
Присвойте нужное значение в записи вида:
$ХЭШ{$КЛЮЧ} = $ЗНАЧЕНИЕ;
Комментарий
Процесс занесения данных в хэш весьма тривиален. В языках, где хэш не относится к встроенным типам данных, приходится беспокоиться о переполнении, изменении размеров и коллизиях в хэш-таблицах. В Perl обычное присваивание решает сразу все проблемы. Если ключ уже занят, то есть содержит предыдущее значение, память автоматически освобождается (по аналогии с присваиванием скалярной переменной).
# Хэш %food_color определяется во введении
$food_color{Raspberry} = "pink";
print "Known foods:\п";
foreach $food (keys %food_color) {
print "$food\n"; >
Known foods: Banana Apple Raspberry Carrot Lemon
Если в качестве ключа хэша используется неопределенная величина undef, она преобразуется в пустую строку "" (что сопровождается предупреждением при запуске с параметром -w). Вероятно, неопределенный ключ undef — это не то, что вы хотели. С другой стороны, undef является вполне допустимым значением в хэ-шах. Однако при выборке значения для ключа, отсутствующего в хэше, вы также получите undef. Это означает, что для проверки существования ключа $кеу в хэше %hash простая логическая проверка if ($hash{$key}) не подходит. Присутствие ключа в хэше проверяется записью вида exists($hash{$key}); определенность ассоциированного значения — defined($hash{$key}), а его истинность — if ($hash{$key}).
> Смотри также---------------------------------------------------------------------------------------------
Раздел «List Value Constructors»peildata(\), рецепт 5 2
5.2. Проверка наличия ключа в хэше
Проблема
Требуется узнать, содержит ли хэш конкретный ключ независимо от ассоциированного с ним значения
Решение
Воспользуйтесь функцией exists
# Содержит ли %ХЭШ ключ $КЛЮЧ"?
if (exists($X3UJ{$MK)4})) {
# Ключ существует } else {
Я Ключ не существует }
Комментарий
В следующем фрагменте функция exists проверяет, присутствует ли ключ в хэше %food_color
# Хэш %food_color определяется во введении
foreach $name ( Banana Martini ) {
if (exists $food_color{$name}) {
print $name is a food \n } else {
print Sname is a drink \n
Banana is a food Martini is a drink
Функция exists проверяет только наличие ключа в хэше Она не сообщает об ассоциированном значении, определено ли оно, истинно или ложно На первый взгляд кажется, что отличия несущественны Однако в действительности проблемы такого рода плодятся быстро, как кролики Возьмем следующий фрагмент
= О Toddler } = 3
$age{ Unborn } = О $аде{ Phantasm } = undef
foreach $thmg ( Toddler Unborn Phantasm Relic } { print Sthing
print Exists if exists $age{$thmg} print Defined if defined $age{thmg} print True if $age{$thing} print \n
Toddler Exists Defined True Unborn Exists Defined Phantasm Exists Relic
Элемент $age{ Toddler } проходит все три проверки — существования, определенности и истинности Он существует, потому что мы присвоили ключу Toddle r значение в хэше Он определен, потому что значение не равно undef Наконец, он истинен, потому что присвоенная величина не является одним из ложных значений Perl
Элемент $age{ Unborn } проходит только проверки существования и опреде ленности Он существует, потому что ключу Unborn было присвоено значение в хэше, и определен, потому что это значение не равно undef Однако он не является истинным, потому что 0 интерпретируется в Perl как одна из ложных величин
Элемент $age{ Phantasm } проходит только проверку существования Он существует, потому что ключу Phantasm было присвоено значение в хэше Поскольку это значение представляет собой undef, проверка определенности не работает Так как undef также считается в Perl одним из ложных значений, проверка истинности тоже не работает
Наконец, $age{ Relic } не проходит ни одну из проверок Значение для Relic не заносилось в хэш, поэтому проверка на существование завершается неудачей Из-за отсутствия ассоциированного значения попытка обратиться к $age{ Relic } дает undef Как мы знаем из примера с Phantasm , undef не проходит проверки определенности и истинности
Иногда undef полезно сохранить в хэше Это означает «такой ключ встречается, но с ним не связано никакого полезного значения» Например, рассмотрим программу, которая определяет размер файлов из переданного списка Следующий фрагмент пытается пропускать файлы, которые уже встречались в списке, однако это не касается файлов нулевой длины и встречавшихся ранее несуществующих файлов
%name = () while (<>) {
chomp
next if $name{$_} # НЕВЕРНО i
$name{$_} = -s $_
next if exists $name{$_},
В самом первом примере предполагается, что все, что не является едой (food), относится к напиткам {dunk). В реальном мире подобные допущения весьма опасны
> Смотри также---------------------------------------------------------------------------------------------
Описание функций exists и defined в perlfunc(i). Концепция истинности рассматривается в разделе «Scalar Values»perldala(l).
5.3. Удаление из хэша
Проблема
Требуется удалить элемент из хэша, чтобы он не опознавался функцией keys, values или each. Например, если в хэше имена работников ассоциируются с окладами, после увольнения работника необходимо удалить его строку из хэша.
Решение
Воспользуйтесь функцией delete:
# Удалить $КЛЮЧ и ассоциированное значение из хэша %ХЭШ
delete($X3UI{$KniO4}),
Комментарий
Многие ошибочно пытаются удалять элементы из хэша с помощью undef — undef ${ХЭШ{$КЛЮЧ} или $ХЭШ{$КЛЮЧ} = undef. В обоих случаях в хэше будет присутствовать элемент с ключом $КЛЮЧ и значением undef.
Функция delete — единственное средство для удаления конкретных элементов из хэша. Удаленный элемент не появится ни в списке keys, пи в итерациях each; функция exists возвращает для цего ложное значение.
Следующий фрагмент демонстрирует отличия undef от delete:
# Хэш %food_color определяется во введении
sub print_foods {
my @foods = keys %food_color, my $food,
print Keys @foods\n , print Values
foreach $food (@foods) {
my $color = $food_color{$food},
if (defined $color) { print $color ,
} else {
print (undef)
print \n ,
print Initially \n , prmt_foods()
print \nWith Banana undef\n undef $food_color{ Banana }, print_foods(),
print \nWith Banana deleted\n , delete $food_color{ Banana }, print_foods(),
Initially
Keys: Banana Apple Carrot Lemon
Values: yellow red orange yellow
With Banana undef
Keys: Banana Apple Carrot Lemon
Values: (undef) red orange yellow
With Banana deleted Keys Apple Carrot Lemon Values: red orange yellow
Как видите, после присвоения $food_color{ Banana } = undef ключ Banana остается в хэше. Элемент не удаляется; просто мы присвоили ему undef. С другой стороны, функция delete действительно удалила данные из хэша — ключ Banana исчезает из списка, возвращаемого функцией keys.
Функция delete также может вызываться для среза хэша, это приводит к удалению всех указанных ключей.
delete @food_color{ Banana Apple Cabbage },
\> Смотри также--------------------------------------------------------------------------------------------
Описание функций delete и keys в perlfunc(l). Применение keys продемонстрировано в рецепте 5.4.
5.4. Перебор хэша
Проблема
Требуется выполнить некоторые действия с каждым элементом (то есть парой «ключ/значение») хэша.
Воспользуйтесь функцией each в цикле while:
и/1и1е(($КЛЮЧ, $ЗНАЧЕНИЕ) = each(%X3UJ)) {
# Сделать что-то с $КЛЮЧ и $ЗНАЧЕНИЕ
}
Если хэш не очень велик, можно вызвать keys в цикле f о reach:
fо reach $КЛЮЧ (keys %ХЭШ) {
$ЗНАЧЕНИЕ = $ХЭШ{$ШЧ}
# Сделать что-то с $КЛЮЧ и $ЗНАЧЕНИЕ
}
Комментарий
Следующий простой пример перебирает элементы хэша %food_color из введения:
# Хэш %food_color определяется во введении while(($food, $color) = each(%food_color)) {
print $food is Scolor \n , }
Banana is yellow. Apple is red. Carrot is orange. Lemon is yellow.
В примере с f о reach можно обойтись без переменной $color, поскольку она используется всего один раз. Достаточно написать:
print $food is $food_color{$food} \n .
При каждом вызове each для одного и того же хэша функция возвращает «следующую» пару ключ/значение. Слово «следующую» взято в кавычки, потому что пары возвращаются в порядке, соответствующем внутренней структуре хэша, и этот порядок почти никогда не совпадает с числовым или алфавитным. За последним элементом each возвращает пустой список (); результат интерпретируется как ложный, и цикл while завершается.
В примере с foreach использована функция keys, которая строит список всех ключей из хэша еще перед началом выполнения цикла. Преимущество each заключается в том, что пары «ключ/значение» извлекаются по одной. Если хэш содержит много ключей, отказ от предварительного построения полного списка существенно экономит память и время. Однако функция each не позволяет управлять порядком обработки пар.
Применение foreach и keys для перебора списка позволяет установить свой порядок обработки Предположим, нам понадобилось вывести содержимое хэша в алфавитном порядке ключей:
foreach $food (sort keys %food_color) { print $food is $food_color{$food} \n
Apple is red. Banana is yellow. Carrot is orange. Lemon is yellow.
Подобное применение f о reach встречается довольно часто. Функция keys строит список ключей в хэше, после чего foreach перебирает их. Если хэш состоит из большого числа элементов, возникает опасность, что возвращаемый keys список займет много памяти. Приходится выбирать между затратами памяти и возможностью обработки элементов в определенном порядке. Сортировка подробнее рассматривается в рецепте 5.9.
Поскольку функции keys, values и each используют одни и те же внутренние структуры данных, следует внимательно следить за чередованием вызовов этих функций или преждевременным выходом из цикла each. При каждом вызове keys или values текущая позиция each сбрасывается. Следующий фрагмент зацикливается и бесконечно выводит первый ключ, возвращаемый each:
while ( ($k,$v) = each %food_color) {
print Processing $k\n ,
keys %food_color, # Возврат к началу %food_color
}
Модификация хэша во время его перебора в each или foreach, как правило, сопряжена с опасностью. При добавлении или удалении ключей из хэша функция each ведет себя по-разному для связанных и несвязанных хэшей. Цикл foreach перебирает заранее построенный список ключей, поэтому после начала цикла он ничего не знает о добавленных или удаленных ключах. Ключи, добавленные внутри цикла, не включаются автоматически в список перебираемых ключей, а удаленные внутри цикла ключи не удаляются из этого списка.
Программа countfrom из примера 5.1 читает файл почтового ящика и выводит количество сообщений от каждого отправителя. Отправитель определяется по строке From: (в этом отношении сценарий не очень интеллектуален, однако нас сейчас интересуют операции с хэшами, а не обработка почтовых файлов). Передайте имя почтового ящика в командной строке или используйте - для перенаправления.
Пример 5.1. countfrom
й1 /usr/bin/perl
# countfrom - подсчет сообщений от каждого отправителя
$filename = $ARGV[O] || - ,
open(FILE, <$filename ) or die Can t open $filename $' ,
while(<FILE>) {
if (/"From ( *)/) { $from<$1}++ }
foreach $person (sort keys %from) { print $person $from{$person}\n
Описание функций each и keys в perlfunc(i); описание циклов for и foreach в рецепте 4.5.
5.5. Вывод содержимого хэша
Проблема
Требуется вывести содержимое хэша, однако конструкции print %ХЭШ и print %ХЭШ не работают.
Решение
Одно из возможных решений — перебрать все пары «ключ/значение» в хэше (см. рецепт 5.4) и вывести их:
while ( ($k $v) = each %hash) {
print $k => $v\n }
Также можно построить список строк с помощью тар:
print тар { $_ => $hash{$_}\n } keys %hash
Или воспользуйтесь фокусом из рецепта 1.10 и интерполируйте хэш как список:
print @{[ %hash ]}\n
Или сохраните хэш во временном массиве и выведите его:
{
my @temp = %hash, print istemp ,
Комментарий
Все перечисленные приемы обладают различными возможностями по управлению порядком и форматированием вывода, а гакже различно]"! эффективностью.
Первый способ (перебор хэша) чрезвычайно гибок и эффективен по затратам памяти Вы можете как угодно форматировать выходные данные, при этом понадобятся всего две скалярные переменные — текущий ключ и значение. Использование цикла foreach позволяет вывести хэш с упорядочением ключей (ценой построения отсортированного списка):
foreach $k (sort keys %hash) { print $k => $hash{$k}\n , >
Функция map не уступает перебору по богатству возможностей Сортировка ключей по-прежнему позволяет работать с элементами в произвольном порядке. Выходные данные можно как угодно форматировать. На этот раз создается
список строк (например, КЛЮЧ=>ЗНАЧЕНИЕ , как в приведенном выше примере), передаваемый print
Два последних приема представляют собой фокусы, связанные с интерполяцией. Интерпретация хэша как списка не позволяет предсказать или управлять порядком вывода пар «ключ/значение». Более того, данные в этом случае выводятся в виде списка ключей и значений, элементы которого разделяются текущим содержимым переменной $ В отличие от других приемов, вам не удастся вывести каждую пару на новой строке или отделить ключи от значений символом =>.
Смотри также
Описание переменной $ в perlvar(l); описание функций foreach, map, keys, sort и each в perlfunc(l). Строковая интерполяция рассматривается в рецепте 1.10, а перебор хэша — в рецепте 5.4
5.6. Перебор элементов хэша в порядке вставки
Проблема
Функции keys и each извлекают элементы хэша в довольно странном порядке. Вы хотите получить элементы в порядке вставки.
Решение
Воспользуйтесь модулем Tie::IxHash
use Tie IxHash,
tie %ХЭШ Tie IxHash ,
# Операции с хэшем %ХЭШ
gkeys = keys %ХЭШ # Массив @keys отсортирован в порядке вставки
Комментарий
Модуль Tie::IxHash заставляет функции keys, each и values возвращать элементы в порядке занесения в хэш. Это часто избавляет от необходимости заранее обрабатывать ключи хэша какой-нибудь сложной сортировкой или поддерживать отдельный массив, содержащий ключи в порядке их вставки.
Tie- IxHash также представляет объектно-ориен тированный интерфейс к функциям splice, push, pop, shift, unshift, keys, values и delete, а также многим другим.
Следующий пример демонстрирует использование keys и each:
# Инициализировать
use Tie IxHash,
tie %food_color, Tie IxHas , $food_color{Banana} = Yellow ,
$food_color{Apple} = Green
$food_color{Lemon} = Yellow
print "Still in insertion order, the foods' colors are:\n" while (( $food, $color ) = each %food_color ) { print '$food is colored $color.\n",
In insertion order, the foods are:
Banana
Apple
Lemon
Still in insertion order, the foods' colors are: Banana is colored Yellow. Apple is colored Green. Lemon is colored Yellow.
t> Смотри также
Документация по модулю Tie::IxHash от CPAN; рецепт 13.15.
5.7. Хэши с несколькими ассоциированными значениями
Проблема
Требуется хранить в хэше несколько значений, ассоциированных с одним ключом.
Решение
Сохраните в хэше ссылку на массив для хранения ассоциированных значений.
Комментарий
В хэше могут храниться только скалярные величины. Однако ссылки являются скалярными величинами. Таким образом, проблема решается сохранением в $ХЭШ {$КЛЮЧ} ссылки на массив со значениями, ассоциированными с ключом $КЛЮЧ. Обычные операции с хэшами — вставка, удаление, перебор и проверка существования — переписываются для операций с массивами (push, splice и foreach).
Следующий фрагмент реализует простую вставку в хэш. Он обрабатывает выходные данные команды who(l) на компьютере с UNIX и выводит краткий список пользователей с терминалами, на которых они зарегистрированы:
%ttys =();
open(WHO, "who|") or die "can't open who: $!' ; while (<WHO>) {
($user, $tty) = split,
push( @{$ttys{$user}}, $tty ),
foreach $user (sort keys %ttys) {
print "$user @t$ttys{$user}}\n", >
Вся суть этого фрагмента заключена в строке push, где содержится версия $tty{$user} = $tty для многозначного хэша. Все имена терминалов интерполируются в строке print конструкцией @{$ttys{user}}. Если бы, например, нам потребовалось вывести владельца каждого терминала, мы бы организовали перебор анонимного массива:
foreach $user (sort keys %ttys) {
print "$user. ", scalar( @{$ttys{$user}} ), 'ttys \n"; foreach $tty (sort @{$ttys{$user}}) {
@stat = state/dev/$tty' );
$user = @stat "> ( getpwuid($stat[4]) )[0] . (not available)',
print "\t$tty (owned by $user)\n ;
Функция exists может иметь два значения: «Существует ли в хэше хотя бы одно значение для данного ключа?» и «Существует ли данное значение для данного ключа?» Чтобы реализовать вторую интерпретацию, придется просмотреть массив в поисках нужной величины. Первая трактовка exists косвенно связана с функцией delete: если мы можем гарантировать, что ни один анонимный массив никогда не остается пустым, можно воспользоваться встроенной функцией exists. Чтобы убедиться, что анонимные массивы не остаются пустыми, их следует проверять после удаления элемента:
sub multihash_delete {
my {$hash, $key, Svalue) = @_, my $1;
return unless ref( $hash->{$key} ); for ($1 = 0, $i < <®{ $hash->{$key} }; $i++) { if ($hash->{$key}->[$i] eq $value) { splice( @{$hash->{$key}}, $i, 1), last,
delete $hash->{$key} unless @{$hash-><$key}}, }
Альтернативная реализация многозначных хэшей приведена в главе 13 «Классы, объекты и связи», где они реализуются как связанные обычные хэши.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций splice, delete, push, foreach и exists вperlfunc(l); рецепт 11.1. Связи рассматриваются в рецепте 13.15.
Проблема
Хэш связывает ключ с ассоциированным значением. У вас имеется хэш и значение, для которого требуется определить ключ.
Решение
Воспользуйтесь функцией reverse для создания инвертированного хэша, где ассоциированные значения исходного хэша являются ключами, и наоборот.
# %ХЭШ связывает ключи со значениями
%ОБРАТНЫЙ = reverse %ХЭШ;
Комментарий
В этом решении используется списковая эквивалентность хэшей, о которой упоминалось во введении. В списковом контексте reve rse интерпретирует %ХЭШ как список и меняет местами составляющие его элементов. Одно из важнейших свойств списковой интерпретации хэша заключается в том, что элементы списка представляют собой пары «ключ/значение». После инвертирования такого списка первым элементом становится значение, а вторым — ключ. Если интерпретировать такой список как хэш, его значения будут являться ключами исходного хэша, и наоборот. Приведем пример:
%surname = ( Mickey' => Mantle , "Babe => 'Ruth ), %first_name = reverse %surname, print $first_narae{"Mantle' , '\n", Mickey
Если интерпретировать % surname как список, мы получим следующее:
('Mickey", "Mantle', "Babe', 'Ruth")
(а может быть, ("Babe", "Ruth", "Mickey", "Mantle' ), поскольку порядок элементов непредсказуем). После инвертирования список выглядит так:
('Ruth', "Babe", 'Mantle", 'Mickey')
Интерпретация его в качестве хэша дает следующее:
('Ruth' => "Babe', 'Mantle" => 'Mickey')
В примере 5.2 приведена программа foodfind. Если передать ей название продукта, она сообщает цвет, а если передать цвет — она сообщает название.
Пример 5.2. foodfind
#' /usr/bm/perl -w
# foodfind - поиск продуктов по названию или цвету
$given = shift @ARGV or die 'usage foodfind food_or_color\n ;
%color = (
'Apple ' => "red' ,
"Banana" => "yellow', "Lemon' => 'yellow", "Carrot" => 'orange'
%food = reverse %color,
if (exists $color{$given}) {
print "$given is a food with color $color{$given} \n',
>
if (exists $food{$given>) {
print '$food{$given} is a food with color $given \n' ; }
Если два ключа исходного хэша имеют одинаковые значения ("Lemon' и "Banana" в предыдущем примере), то инвертированный хэш будет содержать лишь один из них (какой именно — зависит от порядка хэширования, так что непредсказуемо). Дело в том, что хэши в Perl по определению имеют уникальные ключи.
Чтобы инвертировать хэш с повторяющимися значениями, следует воспользоваться методикой рецепта 5.7 — то есть построить хэш, ассоциированные значения которого представляют собой списки ключей исходного хэша:
# Хэш %food_color определяется во введении while (($food,$color) = each(%food_color)) { push(@{foods_with_color{$color}}, $food),
print @{$foods_with_color{yellow}} were yellowfoods.n', Banana Lemon were yellow foods.
Кроме того, это позволит модифицировать программу foodfind так, чтобы она работала с цветами, соответствующими сразу нескольким продуктам. Например, при вызове foodfmd yellow будут выводиться и Banana, и Lemon.
Если какие-либо значения исходного хэша были не простыми строками и числами, а ссылками, при инвертировании возникает проблема — ссылки не могут использоваться в качестве ключей, если только вы не воспользуетесь модулем Tie::RefHash (см. рецепт 5.12).
> Смотри также---------------------------------------------------------------------------------------------
Описание функций reverse в perlfunc{\); рецепт 13.15.
5.9. Сортировка хэша
Проблема
Требуется работать с элементами хэша в определенном порядке.
Решение
Воспользуйтесь функцией keys для построения списка ключей, а затем отсортируйте их в нужном порядке:
@keys = sort { criterionO } (keys %hash),
foreach $key (@keys) { lvalue = $hash{$key}, # Сделать что-то с $key, Svalue
Комментарий
Хотя хранить элементы хэша в заданном порядке невозможно (без использования модуля Tie:IxHash, упомянутого в рецепте 5.6), перебирать их можно в любом порядке.
Существует множество разновидностей одного базового механизма: вы извлекаете ключи, упорядочиваете их функцией sort и обрабатываете элементы в новом порядке. Допускается применение любых хитростей сортировки, упоминавшихся в главе 4 «Массивы». Рассмотрим пару практических примеров.
В первом фрагменте sort просто используется для упорядочения ключей по алфавиту:
foreach $food (sort keys %food_color) {
print $food is $food_color($food) \n , }
Другой фрагмент сортирует ключи по ассоциированным значениям:
foreach $food (sort { $food_color{$a} cmp $food_color{$b} } ) keys %food__color) {
print $food is $food_color{$food} \n , }
Наконец, сортировка выполняется по длине ассоциированных значений:
@foods = sort { length($food_color{$a}) <=> length($food_color{$b}) }
keys %food_color, foreach $food (@foods) {
print $food is $food_color{$food} \n , }
> Смотри также---------------------------------------------------------------------------------------------
Описание функций sort и keys вperlfunc(l); рецепт 5.6. Сортировка списков рассматривается в рецепте 4.15.
5.10. Объединение хэшей
Проблема
Требуется создать новый хэш, содержащий элементы двух существующих хэшей.
Решение
Интерпретируйте хэши как списки и объедините их так, как это делается со списками:
%merged =
Для экономии памяти можно организовать перебор элементов и построить новый хэш следующим образом:
%merged = (),
while ( ($k,$v) = each(%A) ) { $merged{$k} = $v,
}
while ( ($k,$v) = each(%B) ) { $merged{$k} = $v,
Комментарий
В первом варианте, как и в предыдущем рецепте инвертирования хэшей, используется списковая эквивалентность, о которой говорилось во введении. (%А, %В) интерпретируется как список пар «ключ/значение». Когда он присваивается объединенному хэшу %merged, Perl преобразует список пар снова в хэш. Рассмотрим, как эта методика реализуется на практике:
# Хэш %food_color определяется во Введении
%drink_color = ( Galliano => yellow ,
Mai Tai => blue ),
%mgested_colors = (%drink_color %food_color),
Ключи обоих входных хэшей присутствуют в выходном не более одного раза. Если в хэшах найдутся совпадающие ключи, в итоговый хэш включается тот ключ, который встретился последним.
Прямое присваивание компактно и наглядно, но при больших размерах хэшей оно приводит к большим расходам памяти. Это связано с тем, что перед выполнением присваивания итоговому хэшу Perl разворачивает оба хэша во временный список. Пошаговое объединение с помощью each, показанное ниже, избавит вас от этих затрат. Заодно вы сможете решить, как поступать с совпадающими ключами.
С применением each первый фрагмент записывается следующим образом:
# Хэш %food_color определяется во Введении
%drink_color = ( Galliano => yellow ,
Mai Tai => blue ),
%substance_color = (),
while (($k, $v) = each %food_color) {
$substance_color{$k} = $v } while (($k, $v) = each %drmk_color) {
$substance_color{$k) = $v, }
Обратите внимание на повторяющийся код присваивания в циклах while. Проблема решается так:
Если в объединяемых хэшах присутствуют одинаковые ключи, можно вставить код для обработки дубликатов:
foreach Ssubstanceref (\%food_color, \%drink_color ) { while (($k, $v) = each %substanceref) { if (exists $substance_color{$k}) {
print Warning $k seen twice Using the first definition \n , next, } $substance_color{$k} = $v,
В частном случае присоединения одного хэша к другому можно воспользоваться срезом для получения более элегантной записи:
@>all_colors{keys %new_colors} = values %new_colors,
Потребуется память в объеме, достаточном для хранения списков всех ключей и значений %new_colors. Как и в первом варианте, расходы памяти при большом размере списков могут сделать эту методику неприемлемой.
> Смотри также---------------------------------------------------------------------------------------------
Описание функции each вperlfunc(l); рецепт 4.9.
5.11. Поиск общих или различающихся ключей в двух хэшах
Проблема
Требуется найти в хэше ключи, присутствующие в другом хэше, — или наоборот, не входящие в другой хэш.
Решение
Организуйте перебор ключей хэша с помощью функции keys и проверяйте, присутствует ли текущий ключ в другом хэше.
Поиск общих ключей
ту @соттоп = (), foreach (keys %hash1) {
push(@common, $_) if exists $hash2{$_}, } # ^common содержит общие ключи
5.12. Хэширование ссылок 169 Поиск ключей, отсутствующих в другом хэше
my @this_not_that = (), foreach (keys %hash1) {push(@this_not_that, $_) unless exists $hash2{$_}, }
Комментарий
При поиске общих или различающихся ключей хэшей можно воспользоваться рецептами для поиска общих или различающихся элементов в массивах ключей хэшей. За подробностями обращайтесь к рецепту 4.8.
В следующем фрагменте поиск различающихся ключей применяется для нахождения продуктов, не входящих в хэш с описаниями цитрусовых:
# Хэш %food_color определяется во введении
# %citrus_color - хэш, связывающий названия цитрусовых плодов с их цветами
%citrus_color = (Lemon => yellow ,
Orange => orange , Lime => green ),
# Построить список продуктов не входящих в хэш цитрусовых
@non-citrus = (),
foreach (keys %food_color) {
push (@non_citrus, $_) unless exists $citrus_color{$_}, }
t> Смотри также--------------------------------------------------------------------------------------------
Описание функции each вperlfunc(l). Срезы хэшей рассматриваются вperldata(l).
5.12. Хэширование ссылок
Проблема
Если функция keys вызывается для хэша, ключи которого представляют собой ссылки, то возвращаемые ей ссылки не работают. Подобная ситуация часто возникает при создании перекрестных ссылок в двух хэшах.
Решение
Воспользуйтесь модулем Tie::Refflash:
use Tie RefHash,
tie %hash, Tie RefHas ,
it Теперь в качестве ключей хэша %hash можно использовать ссылки
Комментарий
Ключи хэшей автоматически преобразуются в строки — то есть интерпретируются так, словно они заключены в кавычки. Для чисел и строк при этом ничего не теряется. Однако со ссылками дело обстоит иначе.
Class::Somewhere=HASH(0x72048) ARRAY(0x72048)
Преобразованную ссылку невозможно вернуть к прежнему виду, поскольку она перестала быть ссылкой и превратилась в обычную строку. Следовательно, при использовании ссылок в качестве ключей хэша они теряют свои «волшебные свойства».
Для решения этой проблемы обычно создается специальный хэш, ключами которого являются ссылки, преобразованные в строки, а значениями — настоящие ссылки. Именно это и происходит в модуле Tie::RefHash. Мы воспользуемся объектами ввода/вывода для работы с файловыми манипуляторами и покажем, что даже такие странные ссылки могут использоваться для индексации хэша, связанного с Tie::RefHash.
Приведем пример:
use Tie RefHash, use 10 File,
tie %nane, Tie RefHash ,
foreach $filename ( /etc/termcap , /vnumx , /bin/cat ) {
$fh = 10 File->( < Sfilename ) or next,
$name{$fh} = Sfilename, }
print open files , ]oin( , values %name \n , foreach $file (keys %name) {
seek($file, 0, 2), # Позиционирование в конец файла
pnntf ( %s is %d bytes long \n $name{$file}, tell($file)) }
Однако вместо применения объекта в качестве ключа хэша обычно достаточно сохранить уникальный атрибут объекта (например, имя или идентификатор).
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю Tie::RefHash; раздел «Warning» perl-ref(l).
5.13. Предварительное выделение памяти для хэша
Проблема
Требуется заранее выделить память под хэш, чтобы ускорить работу программы — в этом случае Perl не придется выделять новые блоки при каждом добавлении элемента. Окончательный размер хэша часто бывает известен в начале построения, и эта информация пригодится для повышения быстродействия.
Решение
Присвойте количество пар «ключ/значение» конструкции keys(%X3lll):
# Выделить в хэше %hash память для $num элементов
keys(%hash) = $num,
Комментарий
Новая возможность, впервые появившаяся в Perl версии 5.004, может положительно повлиять на быстродействие вашей программы (хотя и не обязательно). В хэшах Perl и так применяются общие ключи, поэтому при наличии хэша с ключом 'Apple Perl уже не выделяет память под другую копию Apple при включении этого ключа в другой хэш.
# В %users резервируется место для 512 элементов
keys(%users) = 512,
Внутренние структуры данных Perl требуют, чтобы количество ключей было равно степени 2. Если написать:
keys(%users) = 1000,
Perl выделит для хэша 1024 «гнезда». Количество ключей не всегда равно количеству гнезд. Совпадение обеспечивает оптимальное быстродействие, однако конкретное соответствие между ключами и гнездами зависит от ключей и внутреннего алгоритма хэширования Perl.
> Смотри также---------------------------------------------------------------------------------------------
Функция keys описана вperlfunc(l). Также обращайтесь к рецепту 4.3.
5.14. Поиск самых распространенных значений
Проблема
Имеется сложная структура данных (например, массив или хэш). Требуется узнать, как часто в ней встречается каждый элемент массива (или ключ хэша). Допустим, в массиве содержатся сведения о транзакциях Web-сервера и вы хотите узнать, какой файл запрашивается чаще остальных. Или для хэша, в котором имя пользователя ассоциируется с количеством регистрации в системе, требуется определить наиболее распространенное количество регистрации.
Решение
Воспользуйтесь хэшем и подсчитайте, сколько раз встречается тот или иной элемент, ключ или значение:
%count = (),
foreach $element (©array) {
Глава 5 • Хэши
$count{$element}++ }Комментарий
Каждый раз, когда возникает задача подсчета различных объектов, вероятно, стоит воспользоваться хэшем. В приведенном выше цикле foreach для каждого экземпляра $element значение $count{$element} увеличивается на 1.
> Смотри также---------------------------------------------------------------------------------------------
Рецепты 4.6 и 4.7.
5.15. Представление отношений между данными
Проблема
Требуется представить отношения между данными — например, отношения «предок/потомок» в генеалогическом дереве или «родительский/порожденный процесс» в таблице процессов. Задача тесно связана с представлением таблиц в реляционных базах данных (отношения между записями) и графов в компьютерных технологиях (отношения между узлами графа).
|
Решение |
||
|
Воспользуйтесь хэшем. |
||
|
Комментарий |
||
|
Следующий хэш представляет часть г |
||
|
%father = ( Cam |
=> |
Adam , |
|
Abel |
=> |
Adam , |
|
Seth |
=> |
Adam |
|
Enoch |
=> |
Cain , |
|
Irad |
=> |
Enoch , |
|
Mehujael |
=> |
Irad , |
|
Methusael |
=> |
Mehujael |
|
Lamech |
=> |
Methusael |
|
Jabal |
=> |
Lamech , |
|
Jubal |
=> |
Lamech |
Tubalcain => Lamech , Enos => Seth )
Например, мы можем легко построить генеалогическое дерево любого персонажа:
while (о) { chomp, do {
print $_ , # Вывести текущее имя $_ = $father{$_}, # Присвоить $_ отца $_ } while defined, # Пока отцы находятся print \п , }
Просматривая хэш %father, можно отвечать на вопросы типа: «Кто родил Сета?» При инвертировании хэша отношение заменяется противоположным Это позволяет использовать рецепт 5.8 для ответов на вопросы типа: «Кого родил Ламех?»
while ( ($k, $v) = each %father ) { push( @{ $children{$v} }, $k )
$ = , й Выходные данные разделяются запятыми while (о) {
chomp
if ($children{$J) {
(^children = @{$children{$_}}
} else {
©children = nobody
}
print $_ begat (^children \n , }
Хэши также могут представлять такие отношения, как директива «include языка С — А включает В, если А содержит ttinclude В Следующий фрагмент строит хэш (он не проверяет наличие файлов в /usr/include, как следовало бы, но этого можно добиться ценой минимальных изменений):
foreach $file (@files) {
local *F, # На случай если понадобится
tt локальный файловый манипулятор unless (open (F, <$file )) {
warn Couldn t read file $' skipping \n , next,
while (<F>) {
next unless /"\s*#\s+include\s+<([~>\+)>/, push(@{$includes{$1}} $file), }
close F, }
Другой фрагмент проверяет, какие файлы не включают других:
<3>mclude_fгее = () # Список файлов, не включающих других файлов @umq{map { @$_ } values %includes} = undef foreach $file (sort keys %umq) {
push( @include_free , $file ) unless $mcludes{$file}
> Смотри также---------------------------------------------------------------------------------------------
Рецепт 4.6; описание более сложных структур данных в рецептах 11.9—11.14.
5.16. Программа: dutree
Программа dutree (см. пример 5.3) преобразует выходные данные du:
|
% di |
cookbook |
||
|
19 |
pcb/fix |
||
|
20 |
pcb/rev/maybe/yes |
||
|
10 |
pcb/rev/maybe/not |
||
|
705 |
pcb/rev/maybe |
||
|
54 |
pob/rev/web |
||
|
1371 |
pcb/rev |
||
|
3 |
pcb/pending/mine |
||
|
1016 |
pcb/pending |
||
|
2412 |
pcb |
||
|
в отсортированную иера] |
эхичеа |
||
|
2412 |
pcb |
||
|
1371 rev |
|||
|
| 705 maybe |
|||
|
I |
675 . |
||
|
I |
20 yes |
||
|
I |
10 not |
||
|
612 . |
|||
|
54 web |
|||
|
101 |
6 pending |
||
|
1013 |
|||
|
3 |
mine |
||
|
19 fix |
|||
|
e |
% dutree
% dutree /usr
% dutree -a
% dutree -a /bin
Хэш %Dirsize сопоставляет имена с размерами файлов. Например, значение $Dirsize{"pcb"} в нашем примере равно 2412. Этот хэш используется как для вывода, так и для сортировки подкаталогов каждого каталога по размерам.
Хэш %Kids представляет больший интерес. Для любого пути $path значение $Kids{path} содержит (ссылку на) массив с именами подкаталогов данного каталога. Так, элемент с ключом "pcb" содержит ссылку на анонимный массив со строками "fix", "rev" и "pending". Элемент "rev" содержит "maybe" и "web". В свою очередь, элемент "maybe" содержит "yes" и "по", которые не имеют собственных элементов, поскольку являются «листами» (конечными узлами) дерева.
Функции output передается начало дерева — последняя строка, прочитанная из выходных данных du. Сначала функция выводит этот каталог и его размер, затем сортирует его подкаталоги (если они имеются) так, чтобы подкаталоги наибольшего размера оказались наверху. Наконец, output вызывает саму себя, рекурсивно перебирая все подкаталоги. Дополнительные аргументы используются при форматировании.
Программа получается рекурсивной, поскольку рекурсивна сама файловая система. Однако ее структуры данных не рекурсивны — по крайней мере, не в том смысле, в котором рекурсивны циклические связанные списки. Каждое ассоциированное значение представляет собой массив ключей для дальнейшей обработки. Рекурсия заключается в обработке, а не в способе хранения.
Пример 5.3. dutree
#'/usr/bin/perl -w
# dutree - печать сортированного иерархического представления
# выходных данных du
use strict,
my %Dirsize, my %Kids,
getdots(my $topdir = mput()), output($topdir),
# Запустить du, прочитать входные данные, сохранить размеры и подкаталоги
# Вернуть последний прочитанный каталог (файл9)
sub input {
™y($size, $name, Sparent),
@ARGV = ( du @ARGV | ), fl Подготовить аргументы
while (о)
(Ssize, $name) = split,
$Dirsize{$name} = $size,
(Sparent = $name) =' s#/["/]+$#», fl Имя каталога
push @{ $Kids{$parent} }, $name unless eof, > return $name;
fl Рассчитать, сколько места занимают файлы каждого каталога,
# не находящиеся в подкаталогах Добавить новый фиктивный
# подкаталог с именем ' ', содержащий полученную величину
sub getdots {
продолжение
my $root = $_[0],
my($size, $cursize),
$size = Scursize = $Dirsize{$root},
if \$Kids<$root}) {
for my $kid (@{ $ Kids {$ root} }) {
$cursize -= $Dirsize{$kid},
getdots($kid),
if ($size •= $cursize) { my $dot = $root/ , $Dirsize{$dot} = $cursize, push @{ $Kids{$root} }, $dot,
ft Рекурсивно вывести все данные,
# передавая при рекурсивных вызовах
# выравнивающие пробелы и ширину числа
sub output {
my($root, Sprefix, $width) = (shift, shift || ", shift || 0),
my $path,
($path = $root) =" s# */##, # Базовое имя
my $size = $Dirsize{$root},
my $line = spnntf( %${width}d %s', Ssize, $path),
print Sprefix, $lme, \n',
for ($prefix = $line) { # Дополнительный вывод
s/\d /| /,
s/["|]/ /g, } if ($Kids{$root}) { в Узел имеет подузлы
my isKids = §{ $Kids{$root} },
@Kids = sort { $Dirsize{$b} <=> $Dirsize{$a} } @Kids,
$Dirsize{$Kids[0]} =- /(\d+)/,
my $width = length $1,
for my $kid (@Kids) { output($kid, $prefix, $width) }
До того как в Perl появилась прямая поддержка хэшей массивов, эмуляция подобных конструкций высшего порядка требовала титанических усилий. Некоторые программисты использовали многократные вызовы split и join, но это работало чрезвычайно медленно.
В примере 5.4 приведена версия программы dutree из тех далеких дней. Поскольку у нас не было прямых ссылок на массивы, приходилось самостоятельно залезать в символьную таблицу Perl. Программа на ходу создавала переменные с жутковатыми именами. Удастся ли вам определить, какой хэш используется этой программой?
Массив @{"pcb"> содержит ссылку на анонимный массив, содержащий "pcb/ fix", "pcb/rev' и "pcb/pendmg". Массив @{"pcb/rev"} содержит "pcb/rev/maybe" и "pcb/rev/web". Массив @{"pcb/rev/maybe"} содержит "pcb/rev/maybe/yes" и ¦•pcb/rev/maybe/not'.
Когда вы присваиваете *kid что-нибудь типа 'pcb/f ix", строка в правой части преобразуется в тип-глоб. @kid становится синонимом для @{ 'pcb/f ix"}, но это отнюдь не все. &kid становится синонимом для &{" pcb/f ix"} и т. д.
Если эта тема покажется неинтересной, подумайте, как local использует динамическую область действия глобальных переменных, чтобы избежать передачи дополнительных аргументов. Заодно посмотрите, что происходит с переменной width в процедуре output.
Пример 5.4. dutree-orig
tt> /usr/bm/perl
# dutree_orig старая версия, которая появилась
й до выхода perl$ (начало 90-х)
(alines = du @ARGV ,
chop(@lines),
&input($top = pop @lines),
&output($top),
exit,
sub input {
local($root, *kid, $him) = @_[0,0],
while (©lines && Schildof($root, $lines[$#lmes])) {
&input($him = pop(@lmes)),
push(@kid, $him), i} if (@kid) {
local($mysize) = ($root =" /"(\d+)/),
for (@kid) { $mysize -= (/"(\d+)/)[0], }
push(@kid, $mysize ) if $size ' = $mysize, } @kid = &sizesort(*kid),
sub output {
local($root, *kid, $prefix) = @_[0,0,1],
local($size, $path) = split( , $root),
$path =~ s1 */'',
$line = sprintf('%${width}d %s , $size, $path),
print $prefix, $lme, '\n',
$prefix = $line,
Sprefix =~ s/\d /I /,
$prefix =- s/["|]/ /g,
local(Swidth) = $kid[O] =" /(\d+)/ && length( $1 ),
for (iakid) { &output($_, Sprefix), },
} продолжение
sub sizesort {
local(*list, ©index) = shift; sub bynum { $mdex[$b] <=> $index[$a]; for (©list) { push(@mdex, /(\d+)/), } @list[sort bynum O..$#list];
sub childof {
local(@pair) = $_;
for (@pair) { s/~\d+\s+//g, s/$/\//, }
index($pair[1], $pair[0]) >= 0, }
Итак, какой же хэш используется старой программой dutree? Правильный ответ — %mam ¦ :, то есть символьная таблица Perl. He стоит и говорить, что эта программа не будет работать с use strict. Мы рады сообщить, что новая версия работает втрое быстрее старой. Дело в том, что старая версия постоянно ищет переменные в символьной таблице, а новая обходится без этого. Кроме того, нам удалось избежать медленных вызовов split для занимаемого места и имени каталога. Однако мы приводим и старую версию, поскольку она весьма поучительна.
 |
Поиск по шаблону
[Искусство — это] шаблон, наполняемый разумом. Сэр Герберт Рид, «Значение Искусства»
Введение
В большинстве современных языков программирования существуют примитивные средства поиска по шаблону (обычно вынесенные в дополнительные библиотеки), но шаблоны Perl интегрируются на уровне самого языка. Они обладают возможностями, которыми не могут похвастаться другие языки; возможностями, которые позволяют взглянуть на данные с принципиально новой точки зрения. Подобно тому, как шахматист воспринимает расположение фигур на доске как некий образ, адепты Perl рассматривают данные с позиций шаблонов. Шаблоны записываются на языке регулярных выражений1, богатом знаками препинания, и позволяют работать с замечательными алгоритмами, обычно доступными лишь экспертам в области компьютерных технологий.
«Если поиск по шаблону — такая потрясающая и мощная штука, — спросите вы, — то почему же эта глава не содержит сотни рецептов по применению регулярных выражений?» Да, регулярные выражения обеспечивают естественное решение многих проблем, связанных с числами, строками, датами, Web-документами, почтовыми адресами и буквально всем, что встречается в этой книге. В других главах поиск по шаблону применяется свыше 100 раз. А в этой главе в основном представлены те рецепты, в которых шаблоны являются частью вопроса, а не ответа.
Обширная и тщательно проработанная поддержка регулярных выражений в Perl означает, что в вашем распоряжении оказываются не только те средства, которые не встречаются ни в одном другом языке, но и принципиально новые возможности их использования. Программисты, недавно познакомившиеся с Perl, часто ищут в нем функции поиска и подстановки:
180 Глава 6 • Поиск по шаблону
match( $строка $шаблон)subst( $строка $шаблон, $замена)
Однако поиск и подстановка — настолько распространенные задачи, что они заслуживают собственного синтаксиса'
$meadow =~ m/sheep/, # Истинно если $meadow содержит sheep Smeadow '" m/sheep/ # Истинно если $meadow не содержит sheep $meadow =~ s/old/new # Заменить в $meadow old на new
Поиск по шаблону даже в упрощенном виде не похож на обычные строковые сравнения. Он больше похож на поиск строк с применением универсальных символов-мутантов, к тому же накачанных допингом. Без специального «якоря» позиция, в которой ищется совпадение, свободно перемещается по всей строке. Допустим, если вы захотите найти слово ovine или ovmes и воспользуетесь выражением $meadow =~ /ovine/, то в каждой из следующих строк произойдет ложное совпадение-Fine bovmes demand fine toreadors Muskoxen are a polar ovibovine species Groovmess went out of fashion decades ago
Иногда нужная строка находится прямо у вас перед глазами, а совпадение все равно не происходит
Ovmes are found typically in ovianes
Проблема в том, что вы мыслите категориями человеческого языка, а механизм поиска по шаблону — нет. Когда этот механизм получает шаблон /ovine/ и другую строку, в которой происходит поиск, он ищет в строке символ о , за которым сразу же следует v , затем 1 , п и е Все, что находится до этой последовательности символов или после нее, не имеет значения.
Итак, выясняется, что шаблон находит совпадения там, где они не нужны, и не узнает то, что действительно нужно. Придется усовершенствовать его. Например, для поиска последовательности ovine или ovmes шаблон должен выглядеть примерно так:
if (Smeadow =~ /\bovinesAb/i) { print Here be sheep1 }
Шаблон начинается со метасимвола \Ь, который совпадает только с границей слова. s? обозначает необязательный символ s — он позволяет находить как ovine, так и ovmes. Модификатор /i в конце шаблона означает, что поиск осуществляется без учета регистра.
Как видите, некоторые символы и последовательности символов имеют особый смысл для механизма поиска по шаблону. Метасимволы фиксируют шаблон в начале или конце строки, описывают альтернативные значения для частей шаблона, организуют повторы и позволяют запомнить часть найденной подстроки, чтобы в дальнейшем использовать ее в шаблоне или программном коде.
Освоить синтаксис поиска по шаблону не так уж сложно. Конечно, служебных символов много, но существование каждого из них объясняется вескими причинами. Регулярное выражение — это не просто беспорядочная груда знаков... это тщательно продуманная груда знаков! Если вы что-нибудь забыли, всегда можно
заглянуть в документацию. Сводка по синтаксису регулярных выражений имеется в страницах руководстваperlre(i) nperlop(i), входящих в любую поставку Perl.
Три затруднения
Но синтаксис регулярных выражений — это еще цветочки по сравнению с их хитроумной семантикой. Похоже, большинство трудностей вызывают три особенности поиска по шаблону: жадность, торопливость (а так же то, как эти три аспекта взаимодействуют между собой) и возврат.
Принцип жадности: если квантификатор (например, *) может совпасть в не скольких вариантах, он всегда совпадает со строкой наибольшей длины. Объяснения приведены в рецепте 6.15.
Принцип торопливости: механизм поиска старается обнаружить совпадение как можно скорее, иногда даже раньше, чем вы ожидаете. Рассмотрим конструкцию Fred =" /x*/. Если попросить вас объяснить ее смысл, вы, вероятно, скажете. «Содержит ли строка Fred символы х?» Вероятно, результат поиска окажется неожиданным — компьютер убежден, что символы присутствуют. Дело в том, что /х*/ означает не просто «символы х», а «любое количество символов х». Или более формально — ноль и более символов. В данном случае нетерпеливый механизм поиска удовлетворяется нулем.
Приведем более содержательный пример:
$string = good food Sstring =~ s/o*/e/
Как вы думаете, какое из следующих значений примет $string после подстановки?
goof food geod food geed food geed feed ged food ged fed egood food
Правильный ответ — последний, поскольку первая точка, в которой встречается ноль и более экземпляров о , находится прямо в начале строки. Удивлены? С регулярными выражениями это бывает довольно часто.
А теперь попробуйте угадать, как будет выглядеть результат при добавлении модификатора /д, который делает подстановку глобальной? Строка содержит много мест, в которых встречается ноль и более экземпляров о , — точнее, восемь. Итак, правильный ответ — egeede efeede .
Приведем другой пример, в котором жадность уступает место торопливости:
% echo ababacaca | perl -ne print $&\n if /(a|ba|b)+(a|ac)+/ ababa
Это объясняется тем, что при поиске в Perl используются так называемые традиционные неопределенные конечные автоматы (в отличие от неопределенных конечных автоматов POSIX). Подобные механизмы поиска гарантируют возврат не самого длинного общего совпадения, а лишь самого длинного левого совпаде-
Но дело не обязательно обстоит именно так. В следующем примере используется awk — язык, от которого Perl позаимствовал немало:
% echo ababacaca |
awk match($O,/(a|ba|b)+(a|ac)+/) { print substr($0, RSTART, RLENGTH) } ababacaca
Выбор реализации поиска по шаблону в основном зависит от двух факторов: нерегулярности выражений (то есть наличия в них обратных ссылок) и типа возвращаемой величины (логическое «да/нет», все совпадение, подвыражения). Такие инструменты, как awk, egrep и lex, используют регулярные выражения и возвращают либо логическое «да/нет», либо все совпадение. Подобные возможности поддерживаются определенными конечными автоматами; поскольку определенные конечные автоматы работают быстрее и проще, реализация в перечисленных инструментах основана именно на них. Поиск по шаблону в таких программах и библиотеках, как ed, regex или perl, — совсем другое дело. Обычно приходится поддерживать нерегулярные выражения и знать, какие части строки совпали с различными частями шаблона. Эта задача намного сложнее и отличается экспоненциальным ростом времени выполнения. Естественный алгоритм ее реализации основан на неопределенных конечных автоматах; в этом заключается и проблема, и возможности. Проблема — в том, что неопределенные конечные автоматы работают медленно. Возможности — в том, что формулировка шаблона с учетом особенностей конкретной реализации позволяет существенно повысить быстродействие.
Последняя и самая интересная из трех особенностей — возврат. Чтобы шаблон совпал, должно совпасть все регулярное выражение, а не лишь его отдельная часть. Следовательно, если начало шаблона с квантификатором совпадает, а одна из последующих частей шаблона — нет, механизм поиска возвращается к началу и пытается найти для него другое совпадение — отсюда и термин «возврат». Фактически это означает, что механизм поиска должен систематически перебирать разные возможности до тех пор, пока не найдет полное совпадение. В некоторых реализациях поиска возврат используется для поиска других совпадающих компонентов, которые могли бы увеличить длину найденного совпадения. Механизм поиска Perl этого не делает; найденное частичное совпадение используется немедленно, — если позднее другая часть шаблона сделает полное совпадение невозможным, происходит возврат и поиск другого частичного совпадения (см. рецепт 6.16).
Модификаторы
Модификаторы, используемые при поиске по шаблону, намного проще перечислить и понять, чем другие метасимволы. Ниже приведена краткая сводка:
/i Игнорировать регистр (с учетом национальных алфавитов).
/х Игнорировать большинство пропусков в шаблонах и разрешить комментарии.
/д Глобальный модификатор — поиск/замена выполняются всюду, где это возможно.
/gc He сбрасывать позицию при неудачном поиске.
/s Разрешить совпадение . с переводом строки; кроме того, игнорировать устаревшее значение $*.
/т Разрешить совпадение " и $ соответственно для начала и конца строки во внутренних переводах строк.
/о Однократная компиляция шаблонов.
/е Правая часть s/// представляет собой выполняемый код.
/ее Правая часть s/// выполняется, после чего возвращаемое значение ин-терпретируеся снова.
Наиболее распространены модификаторы /i и /д. Шаблон /ram/i совпадает со строками ram , RAM , Ram и т. д. При наличии этого модификатора обратные ссылки проверяются без учета регистра (пример приведен в рецепте 6.16) При вызове директивы use locale в сравнениях будет учитываться состояние текущих локальных настроек. В текущей реализации модификатор /i замедляет поиск по шаблону, поскольку подавляет некоторые оптимизации скорости.
Модификатор /д используется с s/// для замены всех найденных совпадений, а не только первого Кроме того, /д используется с т// в циклах поиска (но не замены!) всех совпадений:
while (m/(\d+)/g) {
print Found number $1\n }
В списковом контексте /g извлекает все совпадения в массив-
©numbers = m/(\d+)/g
В этом случае будут найдены только неперекрывающиеся совпадения. Для поиска перекрывающихся совпадений придется идти на хитрость — организовать опережающую проверку нулевой ширины с помощью конструкции С?= ). Раз ширина равна нулю, механизм поиска вообще не смещается вперед. При этом найденные данные сохраняются внутри скобок. Однако Perl обнаруживает, что при наличии модификатора /д мы остались на прежнем месте, и перемещается на один символ вперед.
Продемонстрируем отличия на примере:
$digits = 123456789 ,
@nonlap = Sdigits =~/(\d\d\d)/g
@yeslap = $digits =V('?=(\d\d\d))/g
print Non-overlapping @nonlap\n
print Overlapping @yeslap\n
Non-overlapping- 123 456 789
Overlapping: 123 234 345 456 567 678 789
Модификаторы /s и / m используются для поиска последовательностей, содержащих внутренний перевод строки. При указании /s точка совпадает с \п — в обычных условиях этого не происходит. Кроме того, при поиске игнорируется значение устаревшей переменной $*. Модификатор /т приводит к тому, что " и $ совпадают в позициях до и после \п соответственно Он полезен в режиме
При наличии модификатора /е правая часть выполняется как программный код, и затем полученное значение используется в качестве заменяющей строки. Например, подстановка s/(\d+)/spnntf("%#x ', $1)/ge преобразует все числа в шестнадцатеричную систему счисления — скажем, 2581 превращается в 0хЬ23.
В разных странах существуют разные понятия об алфавите, поэтому стандарт POSIX предоставляет в распоряжение систем (а следовательно, и программ) стандартные средства для представления алфавитов, упорядочения наборов символов и т. д. Директива Perl use locale предоставляет доступ к некоторым из них; дополнительную информацию можно найти в странице руководства perllocale. При действующей директиве use locale в символьный класс \w попадают символы с диакритическими знаками и прочая экзотика. Служебные символы изменения регистра \u, \U, \1 и \1_ (а также соответствующие функции uc, ucfirst и т. д.) также учитывают use locale, поэтому \u превратит а в £, если этого потребует локальный контекст.
Специальные переменные
В результате некоторых операций поиска по шаблону Perl устанавливает значения специальных переменных. Так, переменные $1, $2, $3 и т. д. до бесконечности (Perl не останавливается на $9) устанавливаются в том случае, если шаблон содержит обратные ссылки (то есть часть шаблона заключена в скобки). Каждая открывающая скобка, встречающаяся в шаблоне слева направо, начинает заполнение новой переменной. Переменная $+ содержит значение последней обратной ссылки для последнего успешного поиска. Это помогает узнать, какой из альтернативных вариантов поиска был обнаружен (например, при обнаруженном совпадении для /(х,*у)|(у *z)/b переменной $+ будет находиться содержимое $1 или $2 — в зависимости от того, какая из этих переменных была заполнена). Переменная $& содержит полный текст совпадения при последнем успешном поиске. В переменных $ и $' хранятся строки соответственно до и после совпадения при успешном поиске:
$stnng = And little lambs eat ivy»,
$stnng =~ /l["s]*s/,
print ($ ) ($&) ($ )\n ,
(And ) (little lambs) ( eat ivy)
Переменные $', $& и $' соблазнительны, но опасны. Само их присутствие в любом месте программы замедляет поиск по шаблону, поскольку механизм должен присваивать им значения при каждом поиске. Сказанное справедливо даже в том случае, если вы всего один раз используете лишь одну из этих переменных, — или даже если они совсем не используются, а лишь встречаются в программе. В версии 5.005 переменная $& перестала обходиться так дорого.
После всего сказанного возникает впечатление, что шаблоны могут все. Как ни странно, это не так (во всяком случае, не совсем так). Регулярные выражения в принципе не способны решить некоторые задачи. В этом случае на помощь при-
ходят специальные модули. Скажем, регулярные выражения не обладают средствами для работы со сбалансированным вводом, то есть любыми данными произвольной вложенности — например, парными скобками, тегами HTML и т. д. Для таких целей приходится строить настоящий анализатор наподобие HTML::Parser из рецептов главы 20 «Автоматизация в Web». Еще одна задача, не решаемая шаблонами Perl, — неформальный поиск. В рецепте 6.13 показано, как она решается с помощью специального модуля.
6.1. Копирование с подстановкой
Проблема
Вам надоело многократно использовать две разные команды для копирования и подстановки.
Решение
Замените фрагменты вида:
$dst = $src,
$dst =" s/this/that/,
следующей командой:
($dst = $src) =~ s/this/that/,
Комментарий
Иногда подстановка должна выполняться не в исходной строке, а в ее копии, однако вам не хочется делить ее на два этапа. Например:
# Выделить базовое имя
(Sprogname = $0) =~ s'~ ¦/''.
# Начинать Все Слова С Прописной Буквы
($capword = Sword) =" s/(\w+)/\u\L$1/g,
# /usr/man/man3/foo .1 заменяется на /usr/man/man/cat3/foo 1
(Scatpage = $manpage) =~ s/man(9=\d)/cat/,
Подобная методика работает даже с массивами:
@bindirs = qw( /usr/bin /bin /usr/local/bin ), for (@libdirs = @bindirs) { s/bin/lib/ } print @>libdirs\n , /usr/lib /lib /usr/local/lib
Если подстановка должна выполняться для правой переменной, а в левую заносится результат, следует изменить расположение скобок. Обычно результат подстановки равен либо "" в случае неудачи, либо количеству выполненных замен. Сравните с предыдущими примерами, где в скобки заключалась сама операция присваивания. Например:
Глава 6 • Поиск по шаблону
($а = $b) =~ s/x/y/g # Скопировать $Ь и затем изменить $а $а = ($b =~ s/x/y/g) # Изменить $Ь и занести в $ количество подстановокD> Смотри также-------------------------------------------------------------------------------
Раздел «Assignment Operators» perlop(l)
6.2. Идентификация алфавитных символов
Проблема
Требуется узнать, состоит ли строка только из алфавитных символов
Решение
Наиболее очевидное решение не подходит для общего случая
if ($var - /~[A-Za-z]+$/) {
# Только алфавитные символы }
Дело в том, что такой вариант не учитывает локальный контекст пользователя Если наряду с обычными должны идентифицироваться символы с диакритическими знаками, воспользуйтесь директивой use locale и инвертированным символьным классом
use locale
if ($var -" /~[-\W\d_]+$/) {
print var is purely alphabetic\n
Комментарий
В Perl понятие «алфавитный символ» тесно связано с локальным контекстом, поэтому нам придется немного схитрить Регулярное выражение \w совпадает с одним алфавитным или цифровым символом, а также символом подчеркивания Следовательно, \W не является одним из этих символов Инвертируемый символьный класс ["\W\d_] определяет байт, который не является алфавитным символом, цифрой или подчеркиванием После инвертирования остаются одни алфавитные символы которые нас и интересуют В программе это выглядит так
use locale
use POSIX locale_h
Я На вашем компьютере строка локального контекста может выглядеть иначе unless (setlocale(LC_ALL fr_CA IS08859-1 )) { die couldn t set locale to French Canadian\n
while (<DATA>) {
chomp
if (/T\W\dJ+$/) }
print $_ alphabetic\n } else [
print $_ line noise\n
__END__ silly fa3ade couperate nico Renne Molmre hxanoglobin nanve tschbfl random1stuff#here
> Смотри также---------------------------------------------------------------------------------------------
Описание работы с локальным контекстом в perllocale(l), страница руководства /оса/е(3) вашей системы, рецепт 6 12
6.3. Поиск слов
Проблема
Требуется выделить из строки отдельные слова
Решение
Хорошенько подумайте, что должно считаться словом и как одно слово отделяется от остальных Затем напишите регулярное выражение, в котором будут воплощены ваши решения Например
/\S+/ # Максимальная серия байтов не являющихся пропусками /[A-Za z -]+/ # Максимальная серия букв апострофов и дефисов
Комментарий
Концепция «слова» зависит от приложения, языка и входного потока, поэтому в Perl не существует встроенного определения слов Слова приходится собирать вручную из символьных классов и квантификаторов, как это сделано выше Во втором примере мы пытаемся сделать так, чтобы shepherd s и sheep-sheering воспринимались как отдельные слова
У большинства реализаций имеются ограничения, связанные с вольностями
письменного языка Например, хотя второй шаблон успешно опознает слова
spank d и counter-clockwise , он выдернет rd из строки 23rd Psalom Чтобы
/\b([A-Za-z]+\b/ # Обычно наилучший вариант
/\s([A-Za-z]+)\s/ # Не работает в конце строки или без знаков препинания
В Perl существует метасимвол \w, который совпадает с одним символом, разрешенным в идентификаторах Perl. Однако идентификаторы Perl редко отвечают нашим представлениям о словах — обычно имеется в виду последовательность алфавитно-цифровых символов и подчеркиваний, но не двоеточий с апострофами. Поскольку метасимвол \Ь определяется через \w, он может преподнести сюрпризы при определении границ английских слов (и тем более — слов языка суахили).
И все же метасимволы \Ь и \ В могут пригодиться. Например, шаблон /\Bis\B/ совпадает со строкой "is" только внутри слова, но не на его границах. Скажем, в thistle совпадение будет найдено, а в vis-a-vis —нет.
> Смотри также---------------------------------------------------------------------------------------------
Интерпретация \b, \w и \s в perlre(l); шаблоны для работы со словами из рецепта 6.23.
6.4. Комментирование регулярных выражений
Проблема
Требуется сделать ваше сложное регулярное выражение более понятным и упростить его изменение в будущем.
Решение
В вашем распоряжении четыре способа: внешние комментарии, внутренние комментарии с модификатором /х, внутренние комментарии в заменяющей части s/// и альтернативные ограничители.
Комментарий
Во фрагменте из примера 6.1 использованы все четыре способа. Начальный комментарий описывает, для чего предназначено регулярное выражение. Для относительно простых шаблонов ничего больше не потребуется В сложных шаблонах (вроде приведенного) желательно привести дополнительные комментарии.
Пример 6.1. resname
ft'/usr/bin/perl -p
# resname - заменить все имена в стиле foo bar com во входном потоке
6.4. Комментирование регулярных выражений 189
8 на foo bar com [204 148 40 9] (или аналогичными)
use Socket, 8 Загрузить met_addr
s{ #
( # Сохранить имя хоста в $1
(? # Скобки только для группировки
(91 [-_] ) # Ни подчеркивание ни дефис
[\w-] + # Компонент имени хоста
\ # и точка домена
) + # Повторяется несколько раз
[A-Za-z] # Следующий символ должен быть буквой
[\w-] + # Завершающая часть домена
) # Конец записи $1
}{ # Заменить следующим
$1 8 Исходная часть плюс пробел
( ($addr = gethostbyname($1)) # Если имеется адрес
? [ inet_ntoa($addr) ] # отформатировать
# иначе пометить как сомнительный
}дех # /д - глобальная замена
# /е - выполнение
# /х - улучшенное форматирование
Для эстетов в этом примере использованы альтернативные ограничители. Когда шаблон поиска или замены растягивается на несколько строк, наличие парных скобок делает его более понятным. Другая частая причина для использования альтернативных ограничителей — присутствие в шаблоне символов / (например, s/\/\//\/ \//g) Альтернативные ограничители упрощают чтение такого шаблона (например, s'//'/ /' g или s{//}{/ /}g).
При наличии модификатора /х Perl игнорирует большинство пропусков в шаблоне (в символьных классах они учитываются) и интерпретирует символы # и следующий за ними текст как комментарий Такая возможность весьма полезна, однако у вас могут возникнуть проблемы, если пропуски или символы # являются частью шаблона В таких случаях снабдите символы префиксом \, как это сделано в следующем примере:
s/ 8 Заменить
\# # знак фунта
(\w+) # имя переменной
\8 # еще один знак фунта
/${$1}/хд 8 значением глобальной переменной
Помните, комментарий должен пояснять программу, а не пересказывать ее. Комментарии типа $i++ # Увеличить $i на 1 станут причиной плохих оценок на курсах программирования или подорвут вашу репутацию среди коллег
Остается модификатор /е, при котором заменяющая строка вычисляется как полноценное выражение Perl, а не как (заключенная в кавычки и интерполированная) строка. Результат выполнения этого кода используется в качестве заменяю-
Удвоение /е напоминает конструкцию eval STRING . Это позволит применить лексические переменные вместо глобальных в предыдущем примере с заменой.
s/ # Заменить
\# # знак фунта
(\w+) # имя переменной
\# Я еще один знак фунта
/ $ $1/хеед # значением «любой* переменной
После подстановки /ее проверьте переменную $@ Она содержит сообщения об ошибках, полученные в результате работы вашего кода, — в отличие от /е, в данном случае код действительно генерируется во время работы программы.
> Смотри также---------------------------------------------------------------------------------------------
Описание модификатора /х в perlre(l).
6.5. Поиск N-ro совпадения
Проблема
Требуется найти не первое, a N-e совпадение шаблона в строке. Допустим, вы хотите узнать, какое слово предшествует третьему экземпляру слова fish:
One fish two fish red fish blue fish
Решение
Воспользуйтесь модификатором /g и считайте совпадения в цикле while:
$WANT = 3, Scount = О
while (/(\w+)\s+fish\b/gi) { if (++$count == $WANT) {
print The third fish is a $1 one \n ,
# Предупреждение не выходите из этого цикла с помощью last
The third fish is a red one.
Или воспользуйтесь счетчиком и шаблоном следующего вида:
/С \w+\s+fish\s+){2}(\w+)\s+fish/i,
Комментарий
Как объяснялось во введении к этой главе, при наличии модификатора /д в скалярном контексте происходит многократный поиск. Его удобно использовать в циклах while — например, для подсчета совпадений в строке:
# Простой вариант с циклом while
$count = 0,
while($strmg =" /PAT/g) {
$count++, # Или что-нибудь другое
}
# То же с завершающим циклом while
$count = 0
$count++ while Sstnng =~ /PAT/g
# С циклом for
for (Scount = 0, Sstring =" /PAT/g, $count++) { }
# Аналогично, но с подсчетом перекрывающихся совпадений
$count++ while $stnng =" /(7=PAT)/g
Чтобы найти N-й экземпляр, проще всего завести отдельный счетчик Когда он достигнет N, сделайте то, что считаете нужным. Аналогичная методика может применяться и для поиска каждого N-ro совпадения — в этом случае проверяется кратность счетчика N посредством вычисления остатка при делении. Например, проверка (++$count % 3) == 0 находит каждое третье совпадение.
Если вам не хочется брать на себя дополнительные хлопоты, всегда можно извлечь все совпадения и затем выбрать из них то, что вас интересует.
$pond = One fish two fish red fish blue fish ,
# С применением временного массива
©colors = ($pond =" /(w+)\s+fish\b\gi), # Найти все совпадения
$color = $colors[2], # Выбрать одно,
# интересующее нас
# Без временного массива
Scolor = ( $pond =~ /(\w+)\s+fish\b/gi )[2], # Выбрать третий элемент
print The third fish is the pond is Scolor \n The third fish in the pond is red.
В другом примере находятся все нечетные совпадения:
Scount = 0,
$_ = One fish two fish red fish blue fish ,
@evens = grep {$count++ % 2 == 1} /(\w+)\s+fish\b/gi,
print Even numbered fish are @evens \n ,
Even numbered fish are two blue.
При подстановке заменяющая строка должна представлять собой программное выражение, которое возвращает соответствующую строку. Не забывайте возвращать оригинал как заменяющую строку в том случае, если замена не нужна. В следующем примере мы ищем четвертый экземпляр fish и заменяем предшествующее слово другим:
|
$count = 0 |
|||
|
s{ |
|||
|
\b |
|||
|
( |
\w+) |
||
|
\s+ fish |
\b |
||
|
Я |
|||
|
if |
(++$count |
== |
4) { |
|
sushi |
$2, |
||
|
} |
else { |
||
|
$1 |
$2 |
||
|
}gex |
|||
|
One |
fish two |
fish |
red fish sushi fish |
Другой способ — глобальный поиск в списковом контексте для получения всех совпадений и последующее извлечение нужного элемента этого списка
$pond = One fish two fish red fish blue fish swim here $color = ( $pond =~ /\b(\w+)\s+fish\b/gi )[-1], print Last fish is $color \n , Last fish is blue.
Если потребуется найти последнее совпадение без применения /д, то же самое можно сделать с отрицательной опережающей проверкой (?l НЕЧТО) Если вас интересует последний экземпляр произвольного шаблона А, вы ищете А, сопровождаемый любым количеством «не-А», до конца строки Обобщенная конструкция имеет вид А(9! *А) *$, однако для удобства чтения ее можно разделить
т{
А # Найти некоторый шаблон А
С1 # При этом не должно находиться
¦ # что-то другое А # и А )
$ # До конца строки }х
В результате поиск последнего экземпляра fish принимает следующий вид:
$pond = One fish two fish red fish blue fish if ($pond =" m{
\b ( \w+) \s+ fish \b C' * \b fish \b ) }six ) {
print Last fish is $1/\n } else <
print Failed'\n ,
}
Last fish is blue.
Такой подход имеет свои преимущества — он ограничивается одним шаблоном и потому подходит для ситуаций, аналогичных описанной в рецепте 6.17. Впрочем, имеются и недостатки. Он однозначно труднее записывается и воспринимается — впрочем, если общий принцип понятен, все выглядит не так плохо. К тому же это решение медленнее работает — для протестированного набора данных быстродействие снижается примерно в два раза.
> Смотри также---------------------------------------------------------------------------------------------
Поведение конструкции m//g в скалярном контексте описано в разделе «Regexp Quote-like Operators» perlop(l). Отрицательные опережающие проверки нулевой ширины продемонстрированы в разделе «Regular Expressions» perlre(i).
6.6. Межстрочный поиск
Проблема
Требуется использовать регулярные выражения для последовательности, состоящей из нескольких строк Специальные символы (любой символ, кроме перевода строки), " (начало строки) и $ (конец строки), кажется, не работают Это может произойти при одновременном чтении нескольких записей или всего содержимого файла.
Решение
Воспользуйтесь модификатором /m, /s или обоими сразу. Модификатор /s разрешает совпадение с переводом строки (обычно этого не происходит). Если последовательность состоит из нескольких строк, шаблон /foo «bar/s совпадет с f оо и ba r , находящимися в двух соседних строках. Это не относится к точкам в символьных классах (например, [#% ]), которые всегда представляют собой обычные точки.
Модификатор /т разрешает совпадение " и $ в переводах строк. Например, совпадение для шаблона /~=head[ 1 -7]$/m возможно не только в начале записи, но и в любом из внутренних переводов строк.
Комментарий
При синтаксическом анализе документов, в которых переводы строк не имеют значения, часто используется «силовое» решение — файл читается по абзацам (а иногда даже целиком), после чего происходит последовательное извлечение лексем. Для успешного межстрочного поиска необходимо, чтобы символ совпадал с переводом строки — обычно этого не происходит. Если в буфер читается сразу несколько строк, вероятно, вы предпочтете, чтобы символы " и $ совпадали с началом и концом внутренних строк, а не всего буфера.
Необходимо хорошо понимать, чем /т отличается от /s: первый заставляет " и $ совпадать на внутренних переводах строк, а второй заставляет совпадать с пере-
Фильтр из примера 6.2 удаляет теги HTML из всех файлов, переданных в @ARGV, и отправляет результат в STDOUT. Сначала мы отменяем разделение записей, чтобы при каждой операции чтения читалось содержимое всего файла. Если @ARGV содержит несколько аргументов, файлов также будет несколько. В этом случае при каждом чтении передается содержимое всего файла. Затем мы удаляем все открывающие и закрывающие угловые скобки и все, что находится между ними. Мы не можем просто воспользоваться * по двум причинам: во-первых, этот шаблон не учитывает закрывающих угловых скобок, а во-вторых, он не поддерживает межстрочных совпадений Проблема решается применением *'в сочетании с модификатором /s — по крайней мере, в данном случае.
Пример 6.2. killtags
#'/usr/bin/perl
# killtags - очень плохое удаление тегов HTML
under" $/ # При каждом чтении передается весь файл
while (<>) { # Читать по одному файлу
s/< *?>//gs # Удаление тегов (очень скверное)
print # Вывод файла в STDOUT
>
Шаблон s/<[">]*>//g работает намного быстрее, но такой подход наивен: он приведет к неправильной обработке тегов в комментариях HTML или угловых скобок в кавычках (<IMG SRC= here gif ALT= <<0oh la la1» >). В рецепте 20 6 показано, как решаются подобные проблемы.
Программа из примера 6.3 получает простой текстовый документ и ищет в начале абзацев строки вида Chapter 20 Better Living Through Chemisery . Такие строки оформляются заголовками HTML первого уровня. Поскольку шаблон получился довольно сложным, мы воспользовались модификатором /х, который разрешает внутренние пропуски и комментарии.
Пример 6.3. headerfy
#Vusr/bm/perl
# headerfy оформление заголовков глав в HTML
|
$/ = |
|||
|
while ( <> |
) { |
# |
Получить абзац |
|
s{ |
|||
|
\A |
# |
Начало записи |
|
|
( |
# |
Сохранить в $1 |
|
|
Chapter |
# |
Текстовая строка |
|
|
\s+ |
Обязательный пропуск |
||
|
\d+ |
# |
Десятичное число |
|
|
\s* |
# |
Необязательный пропуск |
|
|
# |
Двоеточие |
||
|
* |
Все, кроме перевода строки, |
||
|
}{<H1>$K/H1>}gx, |
|||
|
print |
до конца строки
Если комментарии лишь затрудняют понимание, ниже тот же пример переписан в виде короткой командной строки:
% perl -OOpe s{\A(Chapter\s+\d+\s* *)}{<H1>$1</H1>}gx datafile
Возникает интересная проблема: в одном шаблоне требуется указывать как начало записи, так и конец строки. Начало записи можно было бы определить с помощью ", но символ $ должен определять не только конец записи, но и конец строки. Мы добавляем модификатор /ш, отчего изменяется смысл как ", так и $. Начало записи вместо " определяется с помощью \А. Кстати говоря, метасимвол \Z (хотя в нашем примере он не используется) совпадает с концом записи даже при наличии модификатора /т.
Следующий пример демонстрирует совместное применение /s и /т. На этот раз мы хотим, чтобы символ " совпадал с началом любой строки абзаца, а точка — с переводом строки. Эти модификаторы никак не связаны, и их совместное применение ничем не ограничено. Стандартная переменная $ содержит число записей последнего прочитанного файла. Стандартная переменная $ARGV содержит файл, автоматически открываемый при обработке <ARGV>.
$/ = # Режим чтения абзацев while (<ARGV>) {
while (m#"START( *?)~END&sm) { # /s - совпадение с переводом строки
# /m - совпадение " с началом
внутренних строк print chunk $ in $ARGV has «$1»\n ,
Если вы уже привыкли работать с модификатором /т, то " и $ можно заменить на \А и \Z. Но что делать, если вы предпочитаете /s и хотите сохранить исходный смысл ? Воспользуйтесь конструкцией [~\п] Если вы не намерены использовать /s, но хотите иметь конструкцию, совпадающую с любым байтом, сконструируйте символьный класс вида [\000-\377] или даже [\d\D]. Использовать [ \п] нельзя, поскольку в символьных классах не обладает особой интерпретацией.
> Смотри также---------------------------------------------------------------------------------------------
Описание переменной $/ вperlvar{\)\ описание модификаторов /s и /тврег1ге(\). Мы вернемся к специальной переменной $/ в главе 8.
6.7. Чтение записей с разделением по шаблону
Проблема
Требуется прочитать записи, разделение которых описывается некоторым шаблоном. Perl не позволяет присвоить регулярное выражение переменной-разделителю входных записей.
196 Глава 6 • Поиск по шаблону
Многие проблемы — в первую очередь связанные с синтаксическим анализом сложных файловых форматов, — заметно упрощаются, если у вас имеются удобные средства для чтения записей, разделенных в соответствии с определенным шаблоном.Решение
Прочитайте весь файл и воспользуйтесь функцией split:
undef $/,
©chunks = зр11г(/шаблон/,<ФАЙЛОВЫЙ_МАНИПУЛЯТОР>),
Комментарий
Разделитель записей Perl должен быть фиксированной строкой, а не шаблоном (ведь должен awk быть хоть в чем-то лучше!). Чтобы обойти это ограничение, отмените разделитель входных записей, чтобы следующая операция чтения прочитала весь файл. Иногда это называется режимом поглощающего ввода (slurp mode), потому что весь файл поглощается как одна большая строка. Затем разделите эту большую строку функцией split, используя шаблон разделения записей в качестве первого аргумента.
Рассмотрим пример. Допустим, входной поток представляет собой текстовый файл, содержащий строки " Se", " Ch" и " Ss" — служебные коды для макросов troff. Эти строки представляют собой разделители. Мы хотим найти текст, расположенный между ними.
# Ch, Se и Ss отделяют фрагменты данных STDIN {
local $/ = undef,
©chunks = split(/"\.(Ch|Se|Ss)$/m, о), } print "I read ", scalar(@chunks), chunks \n",
Мы создаем локальную версию переменной $/, чтобы после завершения блока было восстановлено ее прежнее значение. Если шаблон содержит круглые скобки, функция split также возвращает разделители. Это означает, что данные в возвращаемом списке будут чередоваться с элементами "Se", "Ch" и "Ss".
Если разделители вам не нужны, но вы все равно хотите использовать круглые скобки, воспользуйтесь «несохраняющими» скобками в шаблоне вида /-\.(':Ch|Se|Ss)$/m.
Чтобы записи разделялись перед шаблоном, но шаблон включался в возвращаемые записи, воспользуйтесь опережающей проверкой: /? (?=\. (9: Ch | Se | Ss)) /т. В этом случае каждый фрагмент будет начинаться со строки-разделителя.
Учтите, что для больших файлов такое решение потребует значительных расходов памяти. Однако для современных компьютеров и типичных текстовых файлов эта проблема уже не так серьезна. Конечно, не стоит применять это решение для 200-мегабайтного файла журнала, не располагая достаточным местом на диске для подкачки. Впрочем, даже при избытке виртуальной памяти ничего хорошего не выйдет.
6.8. Извлечение строк из определенного интервала
> Смотри такжеОписание переменной $/ Bperlvar(l) и в главе 8; описание функции perlfunc(l).
6.8. Извлечение строк из определенного интервала
Требуется извлечь все строки, расположенные в определенном интервале. 0нтеР" вал может быть задан двумя шаблонами (начальным и конечным) или ноМеР0М первой и последней строки.
Часто встречающиеся примеры — чтение первых 10 строк файла (строки с 1 ^° ™> или основного текста почтового сообщения (все, что следует после пустой сТр0КИ)-
Решение
Используйте оператор .. или ... для шаблонов или номеров строк. В of-личие от .. оператор ... не возвращает истинное значение, если оба условия выг*олня" ются в одной строке.
while (<>) {
if (/НАЧАЛЬНЫЙ ШАБЛОН/ .. /КОНЕЧНЫЙ ШАБЛОН/) { # Строка находится между начальным 9 и конечным шаблонами включительно.
while (о) {
if ($НОМЕР_НАЧАЛЬНОЙ_СТРОКИ . $НОМЕР_КОНЕЧНОЙ_СТРОКИ)
# Строка находится между начальной
# и конечной включительно.
Если первое условие оказывается истинным, оператор ... не проверяет второе условие.
while (<>) {
if (/НАЧАЛЬНЫЙ ШАБЛОН/ ... /КОНЕЧНЫЙ ШАБЛОН/) {
# Строка находится между начальным
# и конечным шаблонами, расположенными в разных строках.
while (<>) {
if ($НОМЕР_НАЧАЛЬНОЙ_СТРОКИ .. $НОМЕР_КОНЕЧНОЙ_СТРОКИ) # Строка находится между начальной и и конечной, расположенными в разных строках.
Глава 6 • Поиск по шаблону
КомментарийИз бесчисленных операторов Perl интервальные операторы . . и ..., вероятно, вызывают больше всего недоразумений. Они создавались для упрощения выборки интервалов строк, чтобы программисту не приходилось сохранять информацию о состоянии. В скалярном контексте (например, в условиях операторов if и while) эти операторы возвращают true или false, отчасти зависящее от предыдущего состояния. Выражение левый_операнд . . правый_операнд возвращает false до тех пор, пока левый_операнд не станет истинным. Когда это условие выполняется, левый_операнд перестает вычисляться, а оператор возвращает true до тех пор, пока не станет истинным правый операнд. После этого цикл начинается заново. Другими словами, истинность первого операнда «включает» конструкцию, а истинность второго операнда «выключает» ее.
Условия могут быть абсолютно произвольными. В сущности, границы интервала могут быть заданы проверочными функциями mytestfunc(1) ., mytestfunc(2), хотя на практике это происходит редко. Как правило, операндами интервальных операторов являются либо номера строк (первый пример), шаблоны (второй пример) или их комбинация.
# Командная строка для вывода строк с 15 по 17 включительно (см. ниже)
perl -ne 'print if 15 .. 17' datafile
# Вывод всех фрагментов <ХМР> .. </ХМР> из документа HTML
while (о) {
print if m#<XMP>#i ., m#</XMP>#i;
# To же, но в виде команды интерпретатора
% perl -ne 'print if m#<XMP>#i .. m#</XMP>#i' document.html
Если хотя бы один из операндов задан в виде числовой константы, интервальные операторы осуществляют неявное сравнение с переменной $. ($NR или $INPUT_LINE_NUMBER при действующей директиве use English). Поосторожнее с неявными числовыми сравнениями! В программе необходимо указывать числовые константы, а не переменные. Это означает, что в условии можно написать 3 .. 5, но не $п .. $т, даже если значения $п и $т равны 3 и 5 соответственно. Вам придется непосредственно проверить переменную $..
# Команда не работает
perl -ne 'BEGIN { $top=3; $bottom=5 } print if Stop .. $bottom' /etc/passwd
# Работает
perl -ne 'BEGIN {$top=3; $bottom=5 } \
print if $. == Stop .. $. == Sbottom' /etc/passwd
# Тоже работает
perl -ne 'print if 3 .. 5' /etc/passwd
Операторы .. и ... отличаются своим поведением в том случае, если оба операнда могут оказаться истинными в одной строке. Рассмотрим два случая:
print if /begin/ .. /end/; print if /begin/ ... /end/;
Для строки "You may not end here you begin" оба интервальных оператора возвращают true. Однако оператор .. не будет выводить дальнейшие строки. Дело в том, что после выполнения первого условия он проверяет второе условие в той же строке; вторая проверка сообщает о найденном конце интервала. С другой стороны, оператор . . . продолжит поиск до следующей строки, в которой найдется /end/, — он никогда не проверяет оба операнда одновременно.
Разнотипные условия можно смешивать:
|
while (<>) { |
|||
|
$in_header |
= |
1 . |
. /"$/; |
|
$in_body |
$/ • |
. eof(); |
Рассмотрим пример. Следующий фрагмент читает файлы с почтовыми сообщениями и выводит адреса, найденные в заголовках. Каждый адрес выводится один раз. Заголовок начинается строкой "From:" и завершается первой пустой строкой. Хотя это определение и не соответствует RFC-822, оно легко формулируется.
%seen = (); while (о) {
next unless /"From:?\s/i .. /"$/;
while (/(["<>(),;\s]+\@["<>().;\s]+)/g) { print "$1\n" unless $seen{$1}++;
Если интервальные операторы Perl покажутся вам странными, записывайтесь в команды поддержки s2p и а2р — трансляторов для переноса кода sed и awk в Perl. В обоих языках есть свои интервальные операторы, которые должны работать в Perl.
> Смотри также---------------------------------------------------------------------------------------------
Описание операторов .. и ... в разделе «Range Operator» perlop(i); описание переменной $NR в perlvariX).
Проблема
Вы хотите, чтобы вместо регулярных выражений Perl пользователи могли выполнять поиск с помощью традиционных универсальных символов командного интерпретатора. В тривиальных случаях шаблоны с универсальными символами выглядят проще, нежели полноценные регулярные выражения.
Решение
Следующая подпрограмма преобразует четыре универсальных символа командного интерпретатора в эквивалентные регулярные выражения; все остальные символы интерпретируются как строки.
sub glob2pat {
my $globstr = shift, my %patmap = (
'• =>'.*,
">¦ => ' ',
¦[ => •['. ¦]• => ¦]•
);
Sglobstr =" s{(.)} < $patmap{$1> || '\0$1- }ge; return " Sglobstr . '$'; }
Комментарий
Шаблоны Perl отличаются от применяемых в командных интерпретаторах конструкций с универсальными символами. Конструкция * * интерпретатора не является допустимым регулярным выражением. Она соответствует шаблону /". *\.. *$/, который совершенно не хочется вводить с клавиатуры.
Функция, приведенная в решении, выполняет все преобразования за вас. При этом используются стандартные правила встроенной функции glob.
Интерпретатор Perl
|
list 1 |
"list\. $ |
|
|
project * |
"project\ |
4 |
|
•old |
" *old$ |
|
|
type* [ch] |
"type *\ |
[ch]$ |
|
* * * |
- Л 4 |
В интерпретаторе действуют другие правила. Шаблон неявно закрепляется на концах строки. Вопросительный знак соответствует любому символу, звездочка —
произвольному количеству любых символов, а квадратные скобки определяют интервалы. Все остальное, как обычно.
Большинство интерпретаторов не ограничивается простыми обобщениями в одном каталоге. Например, конструкция */* означает: «все файлы во всех подкаталогах текущего каталога». Более того, большинство интерпретаторов не выводит имена файлов, начинающиеся с точки, если точка не была явно включена в шаблон поиска. Функция glob2pat такими возможностями не обладает, если они нужны — воспользуйтесь модулем File::KGlob с CPAN.
> Смотри также---------------------------------------------------------------------------------------------
Страницы руководства csh(l) и ksh(l) вашей системы; описание функции glob в perlfunc(l); документация по модулю Glob::DosGlob от CPAN; раздел «I/O Operators» perlop(l); рецепт 9.6.
6.10. Ускорение интерполированного поиска
Проблема
Требуется, чтобы одно или несколько регулярных выражений передавались в качестве аргументов функции или программы. Однако такой вариант работает медленнее, чем при использовании литералов.
Решение
Если имеется всего один шаблон, который не изменяется в течение всей работы программы, сохраните его в строке и воспользуйтесь шаблоном /$pattern/o:
while ($line = о) {
if ($lme =~ /$pattern/o) { # Сделать что-то
Однако для нескольких шаблонов это решение не работает. Три приема, описанные в комментарии, позволяют ускорить поиск на порядок или около того.
Комментарий
Во время компиляции программы Perl преобразует шаблоны во внутреннее представление. На стадии компиляции преобразуются шаблоны, не содержащие переменных, однако преобразование шаблонов с переменными происходит во время выполнения. В результате интерполяция переменных в шаблонах (например, /$pattern/) замедляет работу программы. Это особенно заметно при частых изменениях $pattern.
Применяя модификатор /о, автор сценария гарантирует, что значения интерполируемых в шаблоне переменных остаются неизменными, а если они все же
Модификатор /о в шаблонах без интерполированных переменных не дает никакого выигрыша в скорости. Кроме того, он бесполезен в ситуации, когда у вас имеется неизвестное количество регулярных выражений и строка должна поочередно сравниваться со всеми шаблонами Не поможет он и тогда, когда интерполируемая переменная является аргументом функции, поскольку при каждом вызове функции ей присваивается новое значение.
В примере 6 4 показана медленная, но очень простая методика многострочного поиска для нескольких шаблонов. Массив @>popstates содержит стандартные сокращенные названия тех штатов, в которых безалкогольные газированные напитки обозначаются словом pop. Задача — вывести все строки входного потока, в которых хотя бы одно из этих сокращений присутствует в виде отдельного слова. Модификатор /о не подходит, поскольку переменная, содержащая шаблон, постоянно изменяется
Пример 6.4. popgrepl
# popgrepl - поиск строк с названиями штатов
# версия 1 медленная, но понятная
@popstates = qw(CO ON MI WI MN),
LINE while (defined($line = <>)) {
for $state (@popstates) {
if ($line =' /\b$state\b/) { print, next LINE,
Столь примитивное, убогое, «силовое» решение оказывается ужасно медленным — для каждой входной строки все шаблоны приходится перекомпилировать заново. Мы рассмотрим три варианта решения этой проблемы. Первый вариант генерирует строку кода Perl и вычисляет ее с помощью eval; второй кэширует внутренние представления регулярных выражений в замыканиях, третий использует модуль Regexp с CPAN для хранения откомпилированных регулярных выражений.
Традиционный подход к ускорению многократного поиска в Perl — построе ние строки, содержащей нужный код, и последующий вызов eval $code . Подобная методика использована в примере 6.5.
Пример 6.5. рордгер2
#'/usr/bin/perl
# рордгер2 - поиск строк с названиями штатов
# версия 2 eval, быстрая, но сложная в написании
@popstates = qw(CO ON MI WI MN)
$code = while (defmed($line = <>)) { ,
6.10. Ускорение интерполированного поиска 203
for $state (@popstates) {
$code = \tif (\$lme =' /\\b$state\\b/) { print \$line, next, }\n ,
|
$code |
= } , |
|||||||
|
print |
CODE IS\n------- \n$code\n----- \n if |
0, # |
Отладочный вывод |
|||||
|
eval $code, |
||||||||
|
die if |
$e>, |
|||||||
|
Программа popgrep2 генерирует |
1 строки следующего вида: |
|||||||
|
while ( |
;defined($lme = <>) |
{ |
||||||
|
if |
($line = |
" /bCO\b/) |
{ |
print |
$line, |
next, |
} |
|
|
if |
($lme = |
- /bON\b/) |
{ |
print |
$line, |
next |
} |
|
|
if |
($line = |
" /bMI\b/) |
{ |
print |
$lme |
next, |
} |
|
|
if |
($lme = |
" /bWIW) |
{ |
print |
$line, |
next, |
> |
|
|
if |
(Sline = |
" /bMN\b/) |
{ |
print |
$line, |
next, |
} |
Самое неприятное в таком решении — то, что правильно записать все строки и служебные символы довольно трудно. Функция dequote из рецепта 1.11 может упростить чтение программы, но проблема с конструированием переменных, используемых позже, остается насущной. Кроме того, в строках нельзя использовать символ /, поскольку он служит ограничителем в операторе ш//.
Существует изящный выход, впервые предложенный Джеффри Фридлом (Jeffrey Fnedl). Он сводится к построению анонимной функции, которая кэширу-ет откомпилированные шаблоны в созданном ей замыкании. Для этого функция eval вызывается для строки, содержащей определение анонимной функции, которая проверяет совпадения с передаваемыми ей шаблонами. Perl компилирует шаблон всего только при определении анонимной функции. После вызова eval появляется возможность относительно быстрого поиска.
В примере 6. 6 приведена очередная версия программы popgrep, в которой используется данный прием.
Пример 6.6. рордгерЗ
й1/usr/bin/perl
# рордгерЗ - поиск строк с названиями штатов
# версия 3 алгоритм с построением вспомогательной функции
@popstates = qw(CO ON MI WI MN),
$expr = ]om( || , map { m/\\b\$popstates[$_]\\b/o } 0 $#popstates), $match_any = eval sub < $expr } , die if $@, while (<>) {
print if &$match_any, >
В результате функции eval передается следующая строка (за вычетом форматирования):
204 Глава 6 • Поиск по шаблонуsub {
m/\b$popstates[0]\b/o || m/\b$popstates[1]\b/o ||
m/\b$popstates[2]\b/o || m/\b$popstates[3]\b/o ||
m/\b$popstates[4]\b/o >
Ссылка на массив @popstates находится внутри замыкания. Применение модификатора /о в данном случае безопасно.
Пример 6.7 представляет собой обобщенный вариант этой методики. Создаваемые в нем функции возвращают true, если происходит совпадение хотя бы с одним (и более) шаблоном.
Пример 6.7. grepauth
O'/usr/bin/perl
ff grepauth - вывод строк, в которых присутствуют Тот и Nat
Smultimatch = build_match_all(q/Tom/, q/Nat/), while (<>) {
print if &$multimatch, } exit,
sub build_match_any { build_match_func( 11 , @_) }
sub build_match_all { build_match_func( && , §_) }
sub build_match_func { my Scondition = shift, my ©pattern = @_, 9 Переменная должна быть лексической,
# а не динамической
my $expr = join Scondition => map { m/\$pattern[$_]/o } (0 $#pattern), ту $match_func = eval sub { local \$_ = shift if \@_, $expr } , die if $@, # Проверить $@, переменная должна быть пустой1 return $match_func,
}
Конечно, вызов eval для интерполированных строк (см. popgrep2) представляет собой фокус, кое-как но работающий. Зато применение лексических переменных в замыканиях, как в рордгерЗ и функциях build_match_*, — это уже высший пилотаж. Даже матерый программист Perl не сразу поверит, что такое решение действительно работает. Впрочем, программа будет работать независимо от того, поверили в нее или нет.
На самом деле нам хотелось бы, чтобы Perl один раз компилировал каждый шаблон и позволял позднее ссылаться на него в откомпилированном виде. Такая возможность появилась в версии 5.005 в виде оператора определения регулярных выражений qr//. В предыдущих версиях для этого был разработан экспериментальный модуль Regexp с CPAN. Объекты, создаваемые этим модулем, представляют откомпилированные регулярные выражения. При вызове метода match объекты выполняют поиск по шаблону в строковом аргументе. Существуют специальные методы для извлечения обратных ссылок, определения позиции совпадения и передачи флагов, соответствующих определенным модификаторам — например, /i.
В примере 6.8 приведена версия программы popgrep, демонстрирующая простейшее применение этого модуля.
Пример 6.8. рордгер4
Л'/usr/bin/perl
tt рордгер4 - поиск строк с названиями штатов # версия 4 применение модуля Regexp use Regexp,
@popstates = qw(CO ON MI WI MN),
@poppats = map { Regexp->new( \b $_ \b ) } @popstates, while (defined($lme = <>)) { for $patob] (@poppats) {
print $line if $patobj->match($line),
Возможно, вам захочется сравнить эти решения по скорости. Текстовый файл, состоящий из 22 000 строк («файл Жаргона»), был обработан версией 1 за 7,92 секунды, версией 2 — всего за 0,53 секунды, версией 3 — за 0,79 секунды и версией 4 — за 1,74 секунды. Последний вариант намного понятнее других, хотя и работает несколько медленнее. Кроме того, он более универсален.
> Смотри также--------------------------------------------------------------------------------------------
Описание интерполяции в разделе «Scalar Value Constructors» perldata(i); описание модификатора /о в perlre(l); документация по модулю Regexp с CPAN.
6.11. Проверка правильности шаблона
Проблема
Требуется, чтобы пользователь мог ввести свой собственный шаблон. Однако первая же попытка применить неправильный шаблон приведет к аварийному завершению программы.
Решение
Сначала проверьте шаблон с помощью конструкции eval {} для какой- нибудь фиктивной строки. Если переменная $@ не устанавливается, следовательно, исключение не произошло и шаблон был успешно откомпилирован. Следующий цикл работает до тех пор, пока пользователь не введет правильный шаблон.
do {
print Pattern? ,
chomp($pat = о),
eval { =~ /$pat/ },
warn INVALID PATTERN $@ if $@ } while $@>,
Отдельная функция для проверки шаблона выглядит так*
206 Глава б • Поиск по шаблону
sub is_valid_pattern { my Spat = shift; return eval { "" =" /Spat/; 1 } I| 0,Работа функции основана на том, что при успешном завершении блока возвращается 1. При возникновении исключения этого никогда не произойдет.
Комментарий
Некомпилируемые шаблоны встречаются сплошь и рядом. Пользователь может по ошибке ввести "<Is*["> ","*** GET RICH ***" или "+5-1". Если слепо воспользоваться введенным шаблоном в программе, возникнет исключение — как правило, это приводит к аварийному завершению программы.
Крошечная программа из примера 6.9 показывает, как проверяются шаблоны.
Пример 6.9. paragrep
#'/usr/bin/perl
# paragrep - простейший поиск
die "usage: $0 pat [files]\n" unless @ARGV,
$/ =
Spat = shift;
eval { "" =" /Spat/, 1 } or die '$0: Bad pattern Spat $@\n',
while (<>) {
print "$ARGV $ : $_" if /$pat/o;
Модификатор /о обещает Perl, что значение интерполируемой переменной останется постоянным во время всей работы программы — это фокус для повышения быстродействия. Даже если значение $pat изменится, Perl этого не заметит.
Проверку можно инкапсулировать в функции, которая возвращает 1 при успешном завершении блока и 0 в противном случае {см. выше функцию is_valid_ pattern). Хотя исключение можно также перехватить с помощью eval "/Spat/", у такого решения есть два недостатка. Во-первых, во введенной пользователем строке не должно быть символов / (или других выбранных ограничителей). Во-вторых, в системе безопасности открывается зияющая брешь, которую было бы крайне желательно избежать. Некоторые строки могут сильно испортить настроение:
Spat = "You lose @{[ system('rm -rf *')]} big here",
Если вы не желаете предоставлять пользователю настоящие шаблоны, сначала всегда можно выполнить метапреобразование строки:
$safe_pat = quotemeta(Spat), somethingO if /$safe_pat/;
Или еще проще:
somethingO if /\Q$pat/,
Но если вы делаете нечто подобное, зачем вообще связываться с поиском по шаблону? В таких случаях достаточно простого применения index.
Разрешая пользователю вводить настоящие шаблоны, вы открываете перед ним много интересных и полезных возможностей. Это, конечно, хорошо. Просто придется проявить некоторую осторожность, вот и все. Допустим, пользователь желает выполнять поиск без учета регистра, а вы не предусмотрели в своей программе параметр вроде -1 в дгер. Работая с полными шаблонами, пользователь сможет ввести внутренний модификатор /\ в виде (9i) — например,/('i)stuff/.
Что произойдет, если в результате интерполяции получается пустая строка? Если $pat — пустая строка, с чем совпадет /$pat/ — иначе говоря, что произойдет при пустом поиске //? С началом любой возможной строки? Неправильно. Как ни странно, при поиске по пустому шаблону повторно используется шаблон предыдущего успешного поиска. Подобная семантика выглядит сомнительно, и ее практическое использование в Perl затруднительно.
Даже если шаблон проверяется с помощью eval, учтите: время поиска по неко
торым шаблонам связано с длиной строки экспоненциальной зависимостью. На
дежно идентифицировать такие шаблоны не удается. Если пользователь введет
один из них, программа надолго задумается и покажется «зависшей». Возможно,
из тупика можно выйти с помощью установленного таймера, однако в версии 5.004
прерывание работы Perl в неподходящий момент может привести к аварийному
завершению. '
> Смотри также---------------------------------------------------------------------------------------------
Описание функции eval вperlfunc(l).
6.12. Локальный контекст в регулярных выражениях
Проблема
Требуется преобразовать регистр в другом локальном контексте или заставить метасимвол \w совпадать с символами национальных алфавитов — например, Jose или dejd vu.
Предположим, у вас имеется полгигабайта текста на немецком языке, для которого необходимо составить предметный указатель. Вы хотите извлекать слова (с помощью \w+) и преобразовывать их в нижний регистр (с помощью 1с или \L). Однако обычные версии \w и 1с не находят слова немецкого языка и не изменяют регистр символов с диакритическими знаками.
Решение
Регулярные выражения и функции обработки текста Perl имеют доступ к локальному контексту POSIX. Если включить в программу директиву use locale, Perl
use locale,
Комментарий
По умолчанию \w+ и функции преобразования регистра работают с буквами верхнего и нижнего регистров, цифрами и подчеркиваниями. Преобразуются лишь простейшие английские слова, и даже в очень распространенных заимствованных словах происходят сбои. Директива use locale помогает справиться с затруднениями.
Пример 6.10 показывает, чем отличаются выходные данные для английского (en) и немецкого (de) локальных контекстов.
Пример 6.10. localeg
й'/usr/bin/perl -w
tt localeg - выбор локального контекста
use locale,
use POSIX locale_h ,
$name = andreas k\xF6mg ,
@locale{qw(German English)} = qw(de_DE IS0_8859-1 us-ascn),
setlocale(LC_CTYPE, $locale{English})
or die Invalid locale $locale{English} , @english_names = (), while ($name =" /\b(\w+)\b/g) {
push(@english_names, ucfirst($1)), } setlocale(LC_CTYPE, $locale{German})
or die Invalid locale $locale{German> , @german_names = (), while ($name =' /\b(\w+)\b/g) {
push(@german_names, ucfirst($1)), >
print English names @english_names\n , print German names @gerraan_names\n , English names: Andreas К Nig German names: Andreas Konig
Решение основано на поддержке локальных контекстов в POSIX. Ваша система может обладать, а может и не обладать такой поддержкой. Но даже если система заявляет о поддержке локальных контекстов POSIX, в стандарте не определены имена локальных контекстов. Разумеется, переносимость такого решения не гарантирована.
t> Смотри также--------------------------------------------------------------------------------------------
Описание метасимволов \b, \w и \s врег/ге(1), описание локальных контекстов Perl вperllocale(l) и странице руководства locale(3) вашей системы; рецепт 6.2.
6.13. Неформальный поиск
Проблема
Требуется выполнить неформальный поиск по шаблону.
Задача часто возникает в ситуации, когда пользовательский ввод может быть неточным или содержащим ошибки.
Решение
Воспользуйтесь модулем String :Арргох от CPAN:
use Strin Approx qw(amatch),
if (amatch( ШАБЛОН , ©list)) {
# Совпадение }
©matches = amatch( ШАБЛОН , ©list),
Комментарий
Модуль String::Approx вычисляет, насколько шаблон отличается от каждой строки списка. Если количество односимвольных вставок, удалений или замен для получения строки из шаблона не превышает определенного числа (по умолчанию 10 процентов длины шаблона), строка «совпадает» с шаблоном. В скалярном контексте amatch возвращает количество успешных совпадений. В списковом контексте возвращаются совпавшие строки.
use String Approx qw(amatch),
open(DICT /usr/dict/words or die Can t open diet $' ,
while(<DICT>) {
print if amatch( balast ),
ballast
ballustrade
blast
blastula
sandblast
Функции amatch также можно передать параметры, управляющие учетом регистра и количеством допустимых вставок, удалений и подстановок. Параметры передаются в виде ссылки на список. Они полностью описаны в документации по String::Approx.
Следует заметить, что поисковые функции модуля работают в 10-40 раз медленнее встроенных функций Perl. Используйте String::Approx лишь в том случае, если регулярные выражения Perl не справляются с неформальным поиском.
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулю String:'Approx от CPAN; рецепт 1.16.
Проблема
Требуется возобновить поиск с того места, где было найдено последнее совпадение.
Такая возможность пригодится при многократном извлечении фрагментов данных из стрЪки.
Решение
Воспользуйтесь комбинацией модификатора /д, метасимвола \G и функции pos.
Комментарий
При наличии модификатора /д механизм поиска запоминает текущую позицию в строке. При следующем поиске с /д совпадения ищутся, начиная с сохраненной позиции. Это позволяет создать цикл while для извлечения необходимой информации из строки:
while (/(\d+)/g) {
print "Found $1\n"; i
Присутствие \G в шаблоне привязывает поиск к концу предыдущего совпадения. Например, если число хранится в строке с начальными пробелами, замена каждого пробела нулем может выполняться так:
$п = " 49 here"; $п =¦ s/\G /0/g; print $n; 00049 here
\G часто применяется в циклах while. Например, в следующем примере анализируется список чисел, разделенных запятыми:
while (/\G,?(\d+)/g) {
print "Found number $1\n";
} ' ;
Если поиск закончился неудачей (например, если в последнем примере кончились числа), сохраненная позиция по умолчанию перемещается в начало строки. Если это нежелательно (например, требуется продолжить поиски с текущей позиции, но с другим шаблоном), воспользуйтесь модификатором /с в сочетании с /д:
$_ = "The year 1752 lost 10 days on the 3rd of September";
while (/(\d+)/gc) {
print "Found number $1\n";
if (/\G(\S+)/g) {
print "Found $1 after the last number.\n";
Found numeral 1752
Found numeral 10
Found numeral 3
Found rd after the last number.
Как видите, при последовательном применении шаблонов можно изменять позицию начала поиска с помощью модификатора /д. Позиция последнего совпадения связывается со скалярной величиной, в которой происходит поиск, а не с шаблоном. Позиция не копируется вместе со строкой и не сохраняется оператором local.
Позиция последнего совпадения читается и задается функцией pos. Аргумен том функции является строка, для которой читается или задается позиция последнего совпадения. Если аргумент не указан, pos работает с переменной $_:
print "The position in \$a is ", pos($a); pos($a) = 30;
print 'The position in \$_ is ", pos; pos = 30;
> Смотри также---------------------------------------------------------------------------------------------
Описание модификатора /g в perlre( 1).
6.15. Максимальный и минимальный поиск
Проблема
Имеется шаблон с максимальным квантификатором — *,+,? или {}. Требуется перейти от максимального поиска к минимальному.
Классический пример — наивная подстановка для удаления тегов из HTML-документа. Хотя s#<TT>. *</TT>##gsi выглядит соблазнительно, в действительности будет удален весь текст от первого открывающего до последнего закрывающего тега ТТ. От строки "Even <TT>vi</TT> can edit <TT>troff</TT> effectively." остается лишь "Even effectively" — смысл полностью изменился!
Решение
Замените максимальный квантификатор соответствующим минимальным. Другими словами, *, +, ? или {} соответственно заменяются *?,+?, ??и{}?.
Комментарий
В Perl существуют два набора квантификаторов: максимальные (*, +, ? и {}) и
минимальные1
(*?, +?, ?? и {}?). Например, для строки "Perl is a Swiss Army Chainsaw!" шаблон/(г. *s)/совпадет с "rl is a Swiss Army Chains", а шаблон /(r.*?s)/ —с "rl is".
# Максимальный поиск •*
s/< *>//gs, # Неудачная попытка удаления тегов
# Минимальный поиск
s/< *?>//gs, tt Неудачная попытка удаления тегов
Показанное решение не обеспечивает правильного удаления тегов из HTML-документа, поскольку отдельное регулярное выражение не заменит полноценного анализатора. Правильное решение этой проблемы продемонстрировано в рецепте 20.6.
Впрочем, с минимальными совпадениями дело обстоит не так просто. Не стоит ошибочно полагать, что BEGIN *?END в шаблоне всегда соответствует самому короткому текстовому фрагменту между соседними экземплярами BEGIN и END. Возьмем шаблон /BEGIN(. *?)END/. После поиска в строке "BEGIN and BEGIN and END" переменная $1 будет содержать "and BEGIN and". Вероятно, вы рассчитывали на другой результат.
Представьте, что мы хотим извлечь из HTML-документа весь текст, оформленный полужирным и курсивным шрифтом одновременно:
<b><i>this</i> and <i>that</i> are iraportant</b> Oh, <bxi>me too'</ix/t»
Может показаться, что шаблон для поиска текста, находящегося между парами тегов HTML (то есть не включающий теги), должен выглядеть так:
ш{ <Ь><1>( «?)</i></b> }sx,
Как ни странно, шаблон этого не делает. Многие ошибочно полагают, что он сначала находит последовательность ЧЬ><1>', затем нечто отличное от "<Ь><1>', а затем — ' </i></b> ', оставляя промежуточный текст в $1. Хотя по отношению к входным данным он часто работает именно так, в действительности делается совершенно иное. Шаблон просто находит левую строку минимальной длины, которая соответствует всему шаблону. В данном примере это вся строка. Если вы хотели ограничиться текстом между "<Ь><1> ' и ' </ix/b> ', не включающим другие теги полужирного или курсивного начертания, результат окажется неверным.
Если искомая строка состоит всего из одного символа, инвертированный класс (например, /Х["Х]*)Х/) заметно превосходит минимальный поиск по эффективности. Однако обобщенный шаблон, который находит «сначала BEGIN, затем не-BEGIN, затем END» для произвольных BEGIN и END и сохраняет промежуточный текст в $1, выглядит следующим образом:
/BEGIN»? ("BEGIN) )*)END/
Наш пример с тегами HTML выглядит примерно так:
)* ) </1></Ь> }sx, или так:
m{ <bxi>( С C?l</[ib]>) )* ) </ix/b> }sx,
Как замечает Джеффри Фридл, это скороспелое решение не очень эффектив
но. В ситуациях, где скорость действительно важна, он предлагает воспользовать
ся более сложным шаблоном: .*
т{
["<]• # Заведомо допустимо
С
Символ <' возможен, если он не входит в недопустимую конструкцию
С1 </'[ib]> ) # Недопустимо
< tt Все нормально, найти <
["<]* й и продолжить
) *
}sx
> Смотри также---------------------------------------------------------------------------------------------
Описание минимальных квантификаторов в разделе «Regular Expressions» perlre(\).
6.16. Поиск повторяющихся слов
Проблема
Требуется найти в документе повторяющиеся слова.
Решение
Воспользуйтесь обратными ссылками в регулярных выражениях.
Комментарий
Механизм поиска запоминает часть строки, которая совпала с частью шаблона, заключенной в круглые скобки. Позднее в шаблоне обозначение \1 ссылается на первый совпавший фрагмент, \2 — на второй и т. д. Не используйте обозначение $1 — оно интерпретируется как переменная и интерполируется до начала поиска. Шаблон /([A-Z])\1/ совпадает с символом верхнего регистра, за которым следует не просто другой символ верхнего регистра, а именно тот, что был сохранен в первой паре скобок.
Следующий фрагмент читает входной файл по абзацам. При этом используется принятое в Perl определение абзаца как фрагмента, заканчивающегося двумя и более смежными переводами строк. Внутри каждого абзаца находятся все по-
Модификатор /х разрешает внутренние пропуски и комментарии, упрощающие чтение регулярных выражений. Модификатор /i позволяет найти оба экземпляра "is " в предложении "Is is this ok?". Модификатор /g в цикле while продолжает поиск повторяющихся слов до конца текста. Внутри шаблона метасимволы \Ь (граница слова) и \s (пропуск) обеспечивают выборку целых слов.
$/ = ¦, while (о) { while ( m{
\b
(\S+) \Ь (
\s+ \1 \b ) + }xig ) {
print "dup word -$1' at paragraph $.\n";
Приведенный фрагмент найдет удвоенное test в следующем примере:
This is a test
test of the duplicate word funder.
Проверка \S+ между двумя границами слов обычно нежелательна, поскольку граница слова определяется как переход между \w (алфавитно-цифровым символом или подчеркиванием) и либо концом строки, либо He-\w. Между двумя \Ь обычный смысл \S+ (один и более символов, не являющихся пропусками) распространяется до последовательности символов, не являющихся пропусками, первый и последний символ которой должны быть алфавитно-цифровыми символами или подчеркиваниями.
Рассмотрим другой интересный пример использования обратных ссылок. Представьте себе два слова, причем конец первого совпадает с началом второго — например, "nobody" и "bodysnatcher". Требуется найти подобные «перекрытия» и сформировать строку вида "nobodysnatcher". Это вариация на тему нашей основной проблемы — повторяющихся слов.
Чтобы решить эту задачу, программисту на С, привыкшему к традиционной последовательной обработке байтов, придется написать длинную и запутанную программу. Но благодаря обратным ссылкам задача сводится к одному простому поиску:
$а = 'nobody';
$b = 'bodysnatcher';
if ("$a $b' =- /-(\w+)(\w+) \2(\w+)$/) {
print "$2 overlaps in $1-$2-$3\n";
}
body overlaps in no-body-snatcher
Казалось бы, из-за наличия максимального квантификатора переменная $1 должна захватывать все содержимое "nobody". В действительности так и происходит — на некоторое время. Но после этого не остается ни одного символа, который можно было бы занести в $2. Механизм поиска дает задний ход, и $1 неохотно уступает один символ переменной $2. Пробел успешно совпадает, но далее в шаблоне следует переменная \2, которая в настоящий момент содержит просто "у". Следующий символ в строке — не "у", а "Ь". Механизм поиска делает следующий шаг назад; через некоторое время $1 уступит $2 достаточно символов, чтобы шаблон нашел фрагмент, пробел и затем тот же самый фрагмент.
Этот прием не работает, если само перекрытие содержит повторяющиеся фрагменты — как, например, для строк "rococo " и "cocoon". Приведенный выше алгоритм решит, что перекрываются символы "со", а не "coco". Однако мы хотим получить не "rocococoon", a "гососооп". Задача решается включением минимального квантификатора в $1:
/"(\w+')(\w+) \2(\w+)$/
Трудно представить, насколько мощными возможностями обладают обратные ссылки. Пример 6.11 демонстрирует принципиально новый подход к проблеме разложения числа на простые множители (см. главу 2 «Числа).
Пример 6.11. prime-pattern
#'/usr/bin/perl
# pnme_pattern - разложение аргумента на простые множители по шаблону
for ($N = ('о1 х shift); $N =" /~(оо+?)\1+$/, $N =" s/$1/o/g) {
print length($1), " "; i print length ($N), "\n";
Несмотря на свою непрактичность, этот подход отлично демонстрирует возможности обратных ссылок и потому весьма поучителен.
Приведем другой пример. Гениальная идея, предложенная Дугом Макилро-ем (Doug Mcllroy) — во всяком случае, так утверждает Эндрю Хьюм (Andrew Hume), — позволяет решать диофантовы уравнения первого порядка с помощью регулярных выражений. Рассмотрим уравнение 12х + 15у + 16z = 281. Сможете ли вы найти возможные значения х, у и z? А вот Perl может!
# Решение 12х + 15у + 16z = 281 для максимального х
if (($X, $Y, $Z) =
(( о' х 281) =- /-(о.)\1<11>(о.)\2{14}(о.)\3{15>$/)) {
($х, $у, $2) = (length(JX), length($Y), length($Z));
print "One solution is- x=$x, y=$y; z=$z.\n", } else {
print "No solution.\n"; } One solution is: x=17; y=3; z=2.
(( о х 281) =- /"(о+)\1{11}(о+)\2{14}(о+)\3{15}$/))
One solution is: x=17; y=3; z=2.
(( о х 281) =- /-(о«?)\1{11}(о.)\2{14}(о.)\3{15}$/))
One solution is: x=0; y=17; 2=11.
(( о х 281) =" /"(о+-?)\1{11}(о.)\2{14}(о*)\3{15}$/))
One solution is' x=1; y=3; z=14.
Подобные демонстрации математических возможностей выглядят потрясающе, но из них следует вынести один важный урок: механизм поиска по шаблону (особенно с применением обратных ссылок) всей душой желает предоставить вам ответ и будет трудиться с феноменальным усердием. Однако обратные ссылки в регулярных выражениях могут привести к экспоненциальному росту времени выполнения. Для любых нетривиальных данных программа будет работать так медленно, что даже дрейф континентов по сравнению с ней покажется быстрым
> Смотри также------------------------------------------------------------------------
Описание обратных ссылок в разделе «Regular Expressions» perlre(l).
6.17. Логические AND, OR и NOT в одном шаблоне
Проблема
Имеется готовая программа, которой в качестве аргумента или входных данных передается шаблон. В нее невозможно включить дополнительную логику — например, параметры для управления учетом регистра при поиске, AND и NOT. Следовательно, вы должны написать один шаблон, который будет совпадать с любым из двух разных шаблонов (OR), двумя шаблонами сразу (AND) или менять смысл поиска на противоположный (NOT).
Подобная задача часто возникает при получении данных из конфигурационных файлов, Web-форм или аргументов командной строки. Пусть у вас имеется программа, в которой присутствует следующий фрагмент:
chomp($pattern = <CONFIG_FH>), if ( $data =" /Spattern/ ) { }
Если вы отвечаете за содержимое CONFIG_FH, вам понадобятся средства для передачи программе поиска логических условий через один-единственный шаблон.
Решение
Выражение истинно при совпадении /ALPHA/ или /BETA/ (аналогично /ALPHA/ 11 / BETA/):
/ALPHA|BETA/
Выражение истинно, если и /ALPHA/, и /BETA/ совпадают при разрешенных перекрытиях (то есть когда подходит строка BETALPHA ). Аналогично /ALPHA/ && / BETA/:
/-(?=•ALPHA)(?= *BETA)/s
Выражение истинно, если и /ALPHA/, и /BETA/ совпадают при запрещенных перекрытиях (то есть когда BETALPHA не подходит):
/ALPHA -BETA|BETA *ALPHA/s
Выражение истинно, если шаблон /PAT/ не совпадает (аналогично $var i" /PAT/):
/-(? (?iPAT) )*$/s
Выражение истинно, если шаблон BAD не совпадает, а шаблон GOOD — совпадает:
/(9=-(? (?|BAD) )*$)GOOD/s
Комментарий
Предположим, вы пишете программу и хотите проверить некоторый шаблон на несовпадение. Воспользуйтесь одним из вариантов:
if (i ($string =" /pattern/)) {somethmgO } # Некрасиво if ( Sstring •" /pattern/) {somethingO } № Рекомендуется
Если потребовалось убедиться в совпадении обоих шаблонов, примените следующую запись:
if ($string =" /pati/ && $stnng =" /pat2/ ) { somethingO >
Проверка совпадения хотя бы одного из двух шаблонов выполняется так:
if ($stnng =" /pati/ || $stnng =" /pat2/ ) { somethingO }
Короче говоря, нормальные логические связки Perl позволяют комбинировать логические выражения вместо того, чтобы объединять их в одном шаблоне. Но давайте рассмотрим программу minigrep из примера 6.12, которая в качестве аргумента получает всего один шаблон.
Пример 6.12. minigrep
#'/usr/bin/perl
# minigrep - тривиальный поиск
$pat = shift,
while (о) {
print if /$pat/o, >
Если потребуется сообщить minigrep, что некоторый шаблон не должен совпадать или что должны совпасть оба мини-шаблона в произвольном порядке, вы оказываетесь в тупике. Программа просто не предусматривает подобных конструкций. Как сделать все в одном шаблоне? Другими словами, вы хотите выполнить программу minigrep с параметром PAT, который не совпадает или содержит несколько логически связанных шаблонов. Такая задача нередко возникает в программах, читающих шаблоны из конфигурационных файлов.
В случае с AND придется различать перекрывающиеся и неперекрывающиеся совпадения. Допустим, вы хотите узнать, совпадают ли в некоторой строке шаблоны bell и lab . Если разрешить перекрытия, слово labelled пройдет проверку, а если отказаться от перекрытий — нет. Случай с перекрытиями потребует двух опережающих проверок:
labelled =" /"('= •bell)(?= *lab)/s
Помните- в нормальной программе подобные извращения не нужны. Достаточно сказать:
Sstnng =" /bell/ && $stnng =" /lab/
Мы воспользуемся модификатором /х с комментариями. Развернутая версия шаблона выглядит так:
if ($murray_hill =~ m{
tt Начало строки (?= # Опережающая проверка нулевой ширины
• # Любое количество промежуточных символов
bell # Искомая строка bell
) # Вернуться, мы лишь проверяем
С= * Повторить
* # Любое количество промежуточных символов
lab о Искомая строка labs
)
>sx ) # /s разрешает совпадение с переводом строки {
print Looks like Bell Labs might be in Murray Hill1\n , >
Мы не воспользовались *9 для раннего завершения поиска, поскольку минимальный поиск обходится дороже максимального. Поэтому для произвольных входных данных, где совпадение с равной вероятностью может произойти как в начале, так и в конце строки, * будет эффективнее нашего решения. Разумеется, выбор между * и *? иногда определяется правильностью программы, а не эффективностью, но не в данном случае.
Для обработки перекрывающихся совпадений шаблон будет состоять из двух частей, разделенных OR. В первой части lab' следует после bell , а во второй — наоборот:
labelled =* /(? " «bell -lab)|С? " *lab «bell)/ или в развернутой форме:
$brand = labelled ,
if ($brand =* m{
(? # Группировка без сохранения
*? # Любое количество начальных символов bell в Искомая строка bell •9 # Любое количество промежуточных символов
6.17. Логические AND, OR и NOT в одном шаблоне 219
lab # Искомая строка lab
) # Конец группировки
| # Или попробовать другой порядок
С # Группировка без сохранения
~ *? # Любое количество начальных символов
lab # Искомая строка lab
¦' # Любое количество промежуточных символов
bell # Искомая строка bell
) # Конец группировки
}sx ) # /s разрешает совпадение с переводом строки
{
print Our brand has bell and lab separate \n , }
Такие шаблоны не всегда работают быстрее. $murray_hill =" /bell/ && $murray_ hille ="7lab/ сканирует строку не более двух раз, однако для ('=" *9Ье11)('?=" *?lab) механизм поиска ищет lab для каждого экземпляра bell , что в наихудшем случае приводит к квадратичному времени выполнения.
Тем, кто внимательно рассмотрел эти два случае, шаблон NOT покажется тривиальным. Обобщенная форма выглядит так:
$тар =" /"С C'walclo) )*$/s То же в развернутой форме:
if ($map =* m{
# Начало строки
(' # Группировка без сохранения
С1 # Опережающая отрицательная проверка
waldo и Нашли впереди' ) # Если да, отрицание не выполняется
# Любой символ (благодаря /s)
) * # Повторить группировку 0 и более раз
$ # До конца строки
}sx ) # /s разрешает совпадение с переводом строки {
print There s no waldo here'\n ,
>
Как объединить в одном шаблоне AND, OR и NOT? Результат выглядит отвратительно, и в обычных программах делать нечто подобное практически никогда не следует. Однако при обработке конфигурационных файлов или командных строк, где вводится всего один шаблон, у вас нет выбора. Объедините все изложенное выше. Будьте осторожны.
Предположим, вы хотите запустить программу UNIX w и узнать, зарегистрировался ли пользователь tchrist с любого терминала, имя которого начинается не с ttyp; иначе говоря, шаблон ' tchrist должен совпадать, a "ttyp* — нет.
Примерный вывод w в моей системе Linux выглядит так:
7:15am up 206 days, 13:30, 4 users, load average: 1.04, 1.07, 1.04
USER TTY FROM LOGIN» IDLE JCPU PCPU WHAT
tchrist ttyl 5:16pm 36days 24:43 0.03s xinit
|
tchrist |
tty2 |
|
|
tchrist |
ttypO |
chthon |
|
gnat |
ttys4 |
coprolith |
Посмотрим, как поставленная задача решается с помощью приведенной выше программы minigrep или программы tcgrep, приведенной в конце главы:
% w | minigrep "(?i *ttyp) «tchrist Расшифруем структуру шаблона:
m {
# Привязка к началу строки
С1 # Опережающая проверка нулевой ширины
* # Любое количество любых символов (быстрее *7)
ttyp # Строка, которая не должна находиться
) # Опережающая отрицательная проверка, возврат к началу
¦ # # Любое количество любых символов (быстрее *?)
tchrist # Пытаемся найти пользователя tchrist
}х
Неважно, что любой нормальный человек в такой ситуации дважды вызывает дгер (из них один - с параметром -v, чтобы отобрать несовпадения):
% w | grep tchrist | grep -v ttyp
Главное — что логические конъюнкции и отрицания можно закодировать в одном шаблоне. Однако подобные вещи следует снабжать комментариями — пожалейте тех, кто займется ими после вас.
Как внедрить модификатор /s в шаблон, передаваемый программе из командной строки? По аналогии с /i, который в шаблоне превращается в (?i). Модификаторы /s и /т также безболезненно внедряются в шаблоны в виде /Cs) или /Cm). Их даже можно группировать — например, /Csmi). Следующие две строки фактически эквивалентны:
% grep -1 ШАБЛОН ФАЙЛЫ
% minigrep ('1)ШАБЛ0Н ФАЙЛЫ
> Смотри также------------------------------------------------------------------------
Описание опережающих проверок в разделе «Regular Expressions» perlre(l); man-страницы grep(i) и w(l) вашей системы. Работа с конфигурационными файлами рассматривается в рецепте 8.16.
6.18. Поиск многобайтовых символов
Проблема
Требуется выполнить поиск регулярных выражений для строк с многобайтовой кодировкой символов.
Кодировка определяет соответствие между символами и их числовыми представлениями. В кодировке ASCII каждый символ соответствует ровно одному
байту, однако языки с иероглифической письменностью (китайский, японский и корейский) содержат так много символов, что в их кодировках символы приходится представлять несколькими байтами.
Perl исходит из предположения, что один байт соответствует одному символу. В ASCII все работает нормально, но поиск по шаблону в строках, содержащих многобайтовые символы, — задача по меньшей мере нетривиальная. Механизм поиска не понимает, где в последовательности байтов расположены границы символов, и может вернуть «совпадения» от середины одного символа до середины другого.
Решение
Воспользуйтесь кодировкой и преобразуйте шаблон в последовательность байтов, образующих многобайтовые символы. Основная мысль заключается в построении шаблона, который совпадает с одним (многобайтовым) символом кодировки, а затем применить этот шаблон «любого символа» в более сложных шаблонах.
Комментарий
В качестве примера мы рассмотрим одну из кодировок японского языка, EUC-JP, и разберемся, как воспользоваться ей для решения многих проблем, связанных с многобайтовыми символами. В EUC-JP можно представить тысячи символов, но в сущности эта кодировка является надмножеством ASCII. Байты с 0 по 127 (0x00 - 0x7F) почти точно совпадают с ASCII-аналогами и соответствуют однобайтовым символам. Некоторые символы представляются двумя байтами; первый байт равен 0х8Е, а второй принимает значения из интервала OxAO-OxOF. Другие символы представляются тремя байтами; первый байт равен 0x8F, а остальные принадлежат интервалу 0хА1—OxFE. Наконец, часть символов представляется двумя байтами, каждый из которых принадлежит интервалу 0хА1—OxFE.
Исходя из этих данных, можно построить регулярное выражение. Для удобства последующего применения мы определим строку $eucjp с регулярным выражением, которое совпадает с одним символом кодировки EUC-JP:
my $euc]p = q{ ft Компоненты кодировки EUC-JP
[\xOO-\x7F] # ASCII/JIS-Roman (один байт/символ)
| \x8E[\xA0-\xDF] # катакана половинной ширины (два байта/символ)
| \x8F[\xA1-xFE][\xA1-\xFE] # JIS X 0212-1990 (три байта/символ)
| [\xA1-\xFE][\xA1-\xFE] ft JIS X 0208 1997 (два байта/символ)
},
(строка содержит комментарии и пропуски, поэтому при ее использовании для поиска или замены необходимо указывать модификатор /х). Располагая этим шаблоном, мы расскажем, как:
• Выполнить обычный поиск без «ложных» совпадений.
• Подсчитать, преобразовать (в другую кодировку) и/или отфильтровать
символы.
• Убедиться в том, что проверяемый текст содержит символы данной коди
ровки.
• Узнать, какая кодировка используется в некотором тексте.
222 Глава б • Поиск по шаблону
Во всех приведенных примерах используется кодировка EUC-JP, однако они будут работать и в большинстве других распространенных многобайтовых кодировок, встречающихся при обработке текстов — например, Unicode, Big-5 и т. д.Страховка от ложных совпадений
Ложное совпадение происходит, когда найденное совпадение приходится на середину многобайтового представления одного символа. Чтобы избежать ложных совпадений, необходимо контролировать процесс поиска и следить, чтобы механизм поиска синхронизировался с границами символов.
Для этого можно связать шаблон с началом строки и вручную пропустить байты, для которых в текущей позиции не может произойти нормальное совпадение. В примере с EUC-JP за «пропуск символов» отвечает часть шаблона /(? :$eucjp)*?/. $eucjp совпадает с любым допустимым символом. Поскольку он применяется с минимальным квантификатором *?, совпадение возможно лишь в том случае, если не совпадает то, что идет после него (искомый текст). Рассмотрим реальный пример:
/" (?: $eucjp )*? \xC5\xEC\xB5\xFE/ox n Пытаемся найти Токио
В кодировке EUC- JP японское название Токио записывается двумя символами — первый кодируется двумя байтами \xC5\xEC, а второй — двумя байтами \xB5\xFE. С точки зрения Perl мы имеем дело с обычной 4-байтовой последовательностью \xC5\xEC\xB5\xFE. Однако, поскольку использование (9:$еис]р)*? обеспечивает перемещение в строке только по символам целевой кодировки, мы знаем, что синхронизация сохраняется.
Не забывайте о модификаторах /ох. Модификатор /х особенно важен из-за наличия пропусков в шаблоне $eucjp. Модификатор /о повышает эффективность, поскольку значение $eucjp заведомо остается неизменным.
Аналогично выполняется и замена, но поскольку текст перед настоящим совпадением также является частью общего совпадения, мы должны заключить его в круглые скобки и включить в заменяющую строку. Предположим, переменным $Токуо и $0saka были присвоены последовательности байтов с названиями городов Токио и Осака в кодировке EUC-JP. Замена Токио на Осаку происходит следующим образом:
/" ( (?:eucjp).? ) $Tokyo/$10saka/ox
При использовании модификатора /д поиск должен быть привязан не к началу строки, а к концу предыдущего совпадения. Для этого достаточно заменить " на \G:
/\G ( C:eucjp)«? ) $Tokyo/$10saka/gox
Разделение строк в многобайтовой кодировке
Другая распространенная задача — разбивка входной строки на символы. Для однобайтовой кодировки достаточно вызвать функцию split//, но для многобайтовых конструкция будет выглядеть так:
©chars = /$eucjp/gox; # По одному символу на каждый элемент списка
6.18. Поиск многобайтовых символов 223
Теперь каждый элемент ©chars содержит один символ строки. В следующем фрагменте этот прием используется для создания фильтра:
while (о) {
my @chars = /$eucjp/gox; # Каждый элемент списка содержит один символ for my $char (@chars) { if (length($char) == 1) {
# Сделать что-то интересное с однобайтовым символом
} else {
# Сделать что-то интересное с многобайтовым символом
my $line = join("",(g>chars); # Объединить символы списка в строке print $line; }
Любые изменения $char в двух фрагментах, где происходит «что-то интересное», отражаются на выходных данных при объединении символов @chars.
Проверка многобайтовых строк
Успешная работа приемов, подобных /$eucjp/gox, существенно зависит от правильного форматирования входных строк в предполагаемой кодировке (EUC-JP). Если кодировка не соблюдается, шаблон /$eucj p/ не будет работать, что приведет к пропуску байтов.
Одно из возможных решений — использование /\6$eucjp/gox. Этот шаблон запрещает механизму поиска пропускать байты при поиске совпадений (модификатор \G означает, что новое совпадение должно находиться сразу же после предыдущего). Но и такой подход не идеален, потому что он просто прекращает выдавать совпадения для входных данных неправильного формата.
Более удачный способ убедиться в правильности кодировки строки — воспользоваться конструкцией следующего вида:
$is_eucjp = m/"C:$eucjp)*$/xo;
Если строка от начала до конца состоит только из допустимых символов, значит, она имеет правильную кодировку.
И все же существует потенциальная проблема, связанная с особенностями работы метасимвола конца строки $: совпадения возможны как в конце строки (что нам и требуется), так и перед символом перевода строки в ее конце. Следовательно, успешное совпадение возможно даже в том случае, если символ перевода строки не является допустимым в кодировке. Проблема решается заменой $ более сложной конструкцией (?!\п).
Базовая методика проверки позволяет определить кодировку. Например, японский текст обычно кодируется либо в EUC-JP, либо в другой кодировке, которая называется Shift-JIS. Имея шаблоны $eucjp и $sjis, можно определить кодировку следующим образом:
$is_eucjp = m/"(?:$eucjp)«$/xo; $is_sjis = m/~(?:$sjis)*$/xo;
224 Глава 6 • Поиск по шаблону
Если обе проверки дают истинный результат, вероятно, мы имеем дело с ASCII-текстом (поскольку ASCII, в сущности, является подмножеством обеих кодировок). Однако такое решение не дает стопроцентной гарантии, поскольку некоторые строки с многобайтовыми символами могут оказаться допустимыми в обеих кодировках. В таких случаях автоматическое распознавание становится невозможным, хотя по относительным частотам символов можно выдвинуть разумное предположение.
Преобразование кодировок
Преобразование может сводиться к простому расширению описанного выше процесса перебора символов. Для некоторых взаимосвязанных кодировок достаточно тривиальных математических операций с байтами, в других случаях потребуются огромные таблицы соответствия. В любом случае код вставляется в те фрагменты, где происходит «что-то интересное» (см. выше).
Следующий пример преобразует строки из EUC-JP в Unicode, при этом в качестве таблицы соответствия используется хэш %euc2um:
while (о) {
my ©chars = /$eucjp/gox, # Каждый элемент списка содержит один символ for my $char (§chars) { my $um = $euc2um{$char}, if (defined $um) {
$euc = $um, > else { # Обработать неизвестное преобразование из EUC в Unicode
my $line = jom( ,@>chars), print $line, }
Поиск и обработка многобайтовых символов играет особенно важную роль в Unicode, имеющей несколько разновидностей. В UCS-2 и UCS-4 символы кодируются фиксированным числом байтов. UTF-8 использует от одного до шести байтов на символ. UTF-16, наиболее распространенный вариант Unicode, представляет собой 16-битную кодировку переменной длины.
6.19. Проверка адресов электронной почты
Проблема
Требуется построить шаблон для проверки адресов электронной почты.
Решение
Задача в принципе неразрешима, проверка адреса электронной почты в реальном времени невозможна. Приходится выбирать один из возможных компромиссов.
Комментарий
Многие шаблоны, предлагаемые для решения этой проблемы, попросту неверны. Допустим, адрес f red&barney@stonehedge com правилен и по нему возможна доставка почты (на момент написания книги), однако большинство шаблонов, претендующих на проверку почтовых адресов, бесславно споткнутся на нем.
Документы RFC- 822 содержат формальную спецификацию синтаксически правильного почтового адреса. Однако полная обработка требует рекурсивного анализа вложенных комментариев — задача, с которой одно регулярное выражение не справится. Если предварительно удалить комментарии:
1 while $addr =" s/\([-()]A)//g,
тогда теоретически можно воспользоваться довольно длинным шаблоном для проверки соответствия стандарту RFC, но и это недостаточно хорошо по трем причинам.
Во-первых, не по всем адресам, соответствующим спецификации RFC, возможна доставка. Например, адрес foo@foo foo foo foo теоретически правилен, но на практике доставить на него почту невозможно. Некоторые программисты пытаются искать записи MX на серверах DNS или даже проверяют адрес на хосте, обрабатывающем его почту. Такой подход неудачен, поскольку большинство узлов не может напрямую подключиться к любому другому узлу, но даже если бы это было возможно, получающие почту узлы обычно либо игнорируют команду SMTP VRFY, либо откровенно врут.
Во-вторых, почта может прекрасно доставляться по адресам, не соответствующим RFC. Например, сообщение по адресу postmaster почти наверняка будет доставлено, но этот адрес не соответствует канонам RFC — в нем нет символа @.
В-третьих (самая важная причина), даже если адрес правилен и по нему возможна доставка, это еще не означает, что он вам подойдет. Например, адрес president@whitehouse gov соответствует стандартам RFC и обеспечивает доставку. И все же крайне маловероятно, чтобы этот адресат стал поставлять информацию для вашего сценария CGI.
Отважная (хотя и далеко не безупречная) попытка приведена в сценарии по адресу http://www.perl.com/CPAN/authors/Tom_Christiansen/scripts/ckaddr.gz. Эта программа выкидывает множество фортелей, среди которых — проверка регулярного выражения на соответствие RFC-822, просмотр записей MX DNS и стоп-спис-ки для ругательств и имен знаменитостей. Но и такой подход оказывается откровенно слабым.
При проверке почтового адреса мы рекомендуем организовать его повторный ввод, как это часто делается при проверке пароля. При этом обычно исключаются опечатки. Если обе версии совпадут, отправьте на этот адрес личное сообщение следующего содержания:
Дорогой someuser@host com,
Просим подтвердить почтовый адрес, сообщенный вами в 09 38 41 6 мая 1999 года Для этого достаточно ответить на настоящее сообщение Включите в ответ строку Rumpelstiltskin , но в обратном порядке (то есть начиная с Nik ') После этого ваш подтвержденный адрес будет занесен в нашу базу данных
Возможна и другая стратегия, которая обеспечивает лучшую защиту от подде-'лок, — присвойте своему адресату личный идентификатор (желательно случайный) и сохраните его вместе с адресом для последующей обработки. В отправленном сообщении попросите адресата включать личный идентификатор в свои ответы. Однако идентификатор будет присутствовать и при возврате недоставленного сообщения, и при включении рассылки в сценарий. Поэтому попросите адресата слегка изменить идентификатор — например, поменять порядок символов, прибавить или вычесть 1 из каждой цифры и т. д.
> Смотри также Рецепт 18.9.
6.20. Поиск сокращений
Проблема
Предположим, у вас имеется список команд — например, "send", "abort", "list" и "edit". Пользователь вводит лишь часть имени команды, и вы не хотите заставлять его вводить всю команду до конца.
Решение
Воспользуйтесь следующим решением, если все строки начинаются с разных символов или если одни совпадения имеют более высокий приоритет по сравнению с другими (например, если "SEND" отдается предпочтение перед STOP"):
chomp ($answer = о);
if ('SEND" =" /"\Q$answer\i) { print 'Action is send\n" }
elsif ("STOP" =" /~\Q$answer\i) { print "Action is stop\n" }
elsif ("ABORT" =" /"\Q$answer\i) { print 'Action is abort\n" }
elsif ("LIST" =" /~\Q$answer\i) { print "Action is list\n" }
elsif ('EDIT" =" /"\Q$answer\i) { print "Action is edit\n ' }
Кроме того, можно воспользоваться модулем Text::Abbrev:
use Text. Abbrev;
$href = abbrev qw(send abort list edit),
for (print "Action: "; <>; print "Action1 ") {
chomp;
my $action = $href->{ lc($_) },
print "Action is $action\n";
Комментарий
В первом решении изменяется стандартный порядок поиска; обычно слева указывается переменная, а справа — шаблон. Мы бы также могли попытаться опре-
делить, какое действие выбрал пользователь, с помощью конструкции $answer= =~ /"ABORT/i. Выражение будет истинным, если $answer начинается со строки "ABORT". Однако совпадение произойдет и в случае, если после "ABORT" в $answer следует что-то еще — скажем, для строки "ABORT LATER". Обработка сокращений обычно выглядит весьма уродливо: $answer =~ /"A(B(O(R(T)?)?)?)?$/i.
Сравните классическую конструкцию "переменная =~ шаблон" с "ABORT" =~ / "\Q$answer/i. \Q подавляет интерпретацию метасимволов, чтобы ваша программа не «рухнула» при вводе пользователем неверного шаблона. Когда пользователь вводит что-нибудь типа "ab", после замены переменной шаблон принимает вид "ABORT" =" /"ab/i. Происходит совпадение.
Стандартный модуль Text::Abbrev работает иначе. Вы передаете ему список слов и получаете ссылку на хэш, ключи которого представляют собой все однозначные сокращения, а значения — полные строки. Если ссылка Shref создается так, как показано в решении, $href->{$var} возвращает строку "abort".
Подобная методика часто используется для вызова функции по имени, вводимому пользователем. При этом применяется символическая ссылка:
$name = 'send'; &$name();
Впрочем, это небезопасно — пользователь сможет выполнить любую функцию нашей программы, если он знает ее имя. Кроме того, такое решение противоречит директиве use strict 'refs'.
Ниже приведена часть программы, создающая хэш, в котором ключ представляет собой имя команды, а значение — ссылку на функцию, вызываемую этой командой:
# Предполагается, что &invoke_editor, &deliver_message,
# $flie и $PAGER определяются в другом месте,
use Text' Abbrev,
my($href, %actions, Serrors); %actions = (
"edit" => \&mvoke_editor,
'send" => \&deliver_message,
"list" => sub { system($PAGER, $file) },
"abort" => sub {
print "See ya'\n"; exit; }, => sub {
print "Unknown command $cmd\n", $errors++;
$href = abbrev(keys factions),
local $_;
for (print 'Action' "; <>; print "Action: ") <
s/\s+$//;
$actions->{ $href->{ lc($_) } }->(); >
Если вы не любите слишком кратких выражений или хотите приобрести навыки машинистки, последнюю команду можно записать так:
$abbreviation =
Sexpansion = $href->{$abbreviation};
$coderef = $actions->{$expansion};
&$coderef();
> Смотри также
Документация по стандартному модулю Text::Abbrev. Интерполяция рассматривается в разделе «Scalar Value Constructors» perldata(l).
6.21. Программа: urlify
Программа urlify оформляет URL-адреса, найденные в файлах, в виде ссылок HTML. Она работает не для всех возможных URL, но справляется с наиболее распространенными. Программа старается избежать включения знаков препинания, завершающих предложения, в помеченный URL.
Программа является типичным фильтром Perl и потому может использоваться для перенаправленного ввода:
% gunzip -с ~/mail/archive.gz | urlify > archive.urlified Исходный текст программы приведен в примере 6.13.
Пример 6.13. urlify
#!/usr/bin/perl
# urlify - оформление URL-подобных конструкций в виде ссылок HTML
$urls = '(http|telnet(gopher 1 file(waisfftp)';
$ltrs = AW;
$gunk = •/»--. .?+=&»©! V;
$punc = '. :?\-';
$any = "${ltrs}${gunk}${punc}";
while (<>) { s{
\b # Начать с границы слова
( It Начать сохранение $1 {
$urls : Я Искать имя ресурса и двоеточие,
[$апу] +•? # за которыми следует один или более
# любых допустимых символов, но
# проявлять умеренность и брать лишь то,
# что действительно необходимо ....
) # Завершить сохранение $1 }
6.22. Программа: tcgrep 229
(?= # Опережающая проверка без смещения
[$punc]* # либо 0, либо знак препинания,
[~$апу] # за которыми следует символ, не входящий в url,
| # или
$ # конец строки
HREF="$1">$K/A>}igox;
print; }
6.22. Программа: tcgrep
Ниже приведена программа UNIX grep, написанная на Perl. Хотя она работает медленнее версий, написанных на С (особенно GNU-версии grep), зато обладает многими усовершенствованиями.
Первая и самая важная особенность — эта программа работает везде, где работает Perl. Имеется ряд дополнительных возможностей — tcgrep игнорирует все файлы, кроме простых текстовых; распаковывает сжатые или обработанные утилитой gzip файлы; выполняет просмотр в подкаталогах; ищет полные абзацы или записи, определенные пользователем; ищет более свежие версии файлов, а также подчеркивает или выделяет найденные совпадения. Кроме того, параметр -с выводит количество найденных записей, а параметр -С — число найденных совпадений, которые могут содержать несколько записей.
Распаковка сжатых файлов выполняется утилитами gzcat или zcat, поэтому данная возможность отсутствует в системах, где эти программы недоступны, а также в системах, не позволяющих запускать внешние программы (например, Macintosh).
При запуске программы без аргументов на экран выводится краткая справка по ее использованию (см. процедуру usage в программе). Следующая командная строка рекурсивно и без учета регистра ищет во всех файлах почтового ящика "/mail сообщения с отправителем "kate" и выводит имена найденных файлов:
% tcgrep -ril '"From: .*kate' "/mail
Исходный текст программы приведен в примере 6.14.
Пример 6.14. tcgrep
#!/usr/bin/perl -w
# tcgrep: версия grep, написанная на Perl
# версия 1.0: 30 сентября 1993 года
# версия 1.1: 1 октября 1993 года
# версия 1.2: 26 июля 1996 года
# версия 1.3: 30 августа 1997 года
# версия 1.4: 18 мая 1998 года
use strict;
# Глобальные переменные
продолжение
use vars qw($Me $Errors $Grand_Total $Mult %Compress SMatches);
my ($matcher, $opt);
8 matcher - анонимная функция
# для поиска совпадений
# opt - ссылка на хэш, содержащий
# параметры командной строки
# Инициализировать глобальные переменные
($opt, $matcher) = parse_args(); # Получить параметры командной строки
# и шаблоныmatchfile($opt, Smatcher, @ARGV); # Обработать файлы
exit(2) if SErrors; exit(O) if $Grand_Total; exit(1);
sub init {
($Me = $0) =" s!.*/!!; SErrors = $Grand_Total = 0; $Mult = "•'; $| = 1;%Compress = (
2 => 'gzcaf, gz => 'gzcaf, Z => 'zcaf,
# Получить базовое имя программы, "tcgrep"
# Инициализировать глобальные счетчики
# Флаг для нескольких файлов в @ARGV
# Автоматическая очистка выходного буфера
# Расширения и имена программ
# для распаковки
sub usage {
die «EOFusage: $Me [flags] [files]
Standard grep options:
l case insensitive
n number lines
с give count of lines matching
С ditto, but >1 match per line possible
w word boundaries only
s silent mode
x exact matches only
v invert search sense (lines that DON'T match)
h hide filenames
e expression (for exprs beginning with -)
6.22. Программа: tcgrep 231
f file with expressions
1 list filenames matching
Specials:
1 1 match per file
H highlight matches
u underline matches
r recursive on directories or dot if none
t process directories in 'Is -f order
p paragraph mode (default: line mode)
P ditto, but specify separator, e.g. -P '%%\\n'
a all files, not just plain text files
q quiet about failed file and dir opens
T trace files as opened
May use a TCGREP environment variable to set default options.
EOF
sub parse_args { use Getopt::Std;
my (Soptstring, $zeros, $nulls, %opt, Spattern, ^patterns, $match_code); my ($S0, $SE);
if ($_ = $ENV{TCGREP}) { и Получить переменную окружения TCGREP s/"([~\-])/-$V; * Если начальный - отсутствует, добавить unshift(@ARGV, $_); # Включить строку TCGREP в @ARGV
Soptstring = "incCwsxvhe:f :HHurtpP:aqT";
Szeros = 'mCwxvhelut'; # Параметры, инициализируемые О
й (для отмены предупреждений)
Snulls = 'рР'; # Параметры, инициализируемые ""
# (для отмены предупреждений)
split //, Szeros } = ( о ) х length($zeros); split //, Snulls } = ( " ) х length(Snulls);
getopts($optstring, \%opt) or usage();
if ($opt{f}) { # -f файл с шаблонами
open(PATFILE, $opt{f}) or die qq($Me: Can't open '$opt{f}': $!);
# Проверить каждый шаблон в файле
while ( defined($pattern = <PATFILE>) ) {
продолжение
232 Глава 6 * Поиск по шаблону Пример 6.14 (продолжение)
chomp Spattern,eval { 'foo =~ /$pattern/, 1 } or
die "$Me: $opt{f}'$.. bad pattern: $<g>"
push ©patterns, $pattern; > close PATFILE;
}
else { # Проверить шаблон
Spattern = $opt{e} || shift(@ARGV) || usage(); eval { 'foo' =~ /Spattern/, 1 } or
die "$Me: bad pattern: $@"; ©patterns = ($pattern);
if ($opt{H> || $opt{u}) { # Выделить или подчеркнуть my $term = $ENV<TERM} || 'vt100'; my Sterminal;
eval { й Попытаться найти служебные
й последовательности для выделения require POSIX; # или подчеркнуть через Term''Cap use Term::Cap;
my $termios = POSIX::Termios->new();
$termios->getattr;
my $ospeed = $termios->getospeed;
$termmal = Tgetent Term: Cap { TERM=>undef, OSPEED=>$ospeed >
unless ($@) { # Если успешно, получить служебные
# последовательности для выделения (-Н)
local $~W =0; К или подчеркивания (-и)
($S0, $SE) = $opt{H>
? ($terminal->Tputs('so'), $terminal->Tputs('se'))
: ($terminal->Tputs('us'), $terminal->Tputs('ue'));
>
else { # Если попытка использования Term::Cap
# заканчивается неудачей, получить
($S0, $SE) = $opt<H} й служебные последовательности
Я командой tput
' ('tput -T $term smso', 'tput -T $term rmso') : ('tput -T $term smul', 'tput -T $term rmul')
if ($opt{i>) <
©patterns = map C'(7i)$_"} ©patterns;
6.22. Программа: tcgrep 233
if ($opt<p} || $opt<P}) <
©patterns = map Г(?т)$_") ©patterns;
$opt{p} && ($/ = ¦¦);
$opt{P> && ($/ = eval(qq("$opt{P}"))); # for -P '%%\n
$opt{w> && (©patterns = map {'\b' . $_ . '\b'> ©patterns);
$opt{'x'} && (©patterns = map {""$_\$"} ©patterns);
if (@ARGV) {
$Mult = 1 if ($opt{r} || (©ARGV > 1) || -d $AR6V[0]) && !$opt{h>, >
$opt{1) += $opt<l); tt Единица и буква 1
$opt{H> += $opt{u}; $opt{c> += $opt{C}; $opt{'s'} += $opt{c}; $opt{1> += $opt{'s'} && !$opt{c), # Единица
©ARGV = ($opt{r} ' ¦.' : ¦-') unless ©ARGV;
$opt{r} = 1 if '$opt{r} && grep(-d, ©ARGV) == ©ARGV;
$match_code = '';
$match_code = 'study; if ©patterns > 5; # Может немного
# ускорить работу
foreach (©patterns) { s(/)(\\/)g }
if ($opt<H}) <
foreach Spattern (©patterns) {
$match_code = "\$Matches += s/($pattern)/${S0}\$1${SE}/g, ';
elsif ($opt{v}) {
foreach $pattern (©patterns) {
$match_code .= "\$Matches += !/$pattern/,';
elsif ($opt{C>) {
foreach $pattern (©patterns) {
$match_code = "\$Matches++ while /$pattern/g;
else {
foreach $pattern (©patterns) {
$match_code = "\$Matches++ if /$pattern/;";
продолжение
234 Глава 6 • Поиск по шаблону Пример 6.14 (продолжение)
$matcher = eval "sub { $matcti_code }"; die if $@;return (\%opt, Smatcher);
sub matchfile {
$opt = shift; # Ссылка на хэш параметров
$matcher = shift; # Ссылка на функцию поиска совпадений
ray ($file, ©list, $total, $name);
local($_);
Stotal = 0;
FILE: while (defined ($file = shift(@_))) {
if (-d $file) {
if (-1 $file && @ARGV != 1) {
warn "$Me: \"$file\" is a symlink to a directory\n" if $opt->{T};
next FILE; } if (!$opt->{r}) {
warn "$Me: \"$file\" is a directory, but no -r given\n" if $opt->{T};
next FILE; } unless (opendir(DIR, $file)) {
unless ($opt->{'q'}) {
warn "$Me: can't opendir $file: $!\n"; $Errors++;
>
next FILE; }
@list =(); for (readdir(DIR)) {
push(@list, "$file/$ ") unless /~\.{1.2}$/; }
closedir(OIR); if ($opt->{t}) {
my (©dates);
for (©list) { push(@dates, -M) }
@list = @list[sort { $dates[$a] <=> $dates[$b] } O..$#dates]; } else {
@list = sort ©list;
6.22. Программа: tcgrep 23S
matchfile($opt, Smatcher, ©list); # process files next FILE;
if (Sfile eq '-¦) {
warn "$Me: reading from stdin\n" if -t STDIN && !$opt->{'q'}; $name = '<STDIN>';
} else {
$name = $file; unless (-e Sfile) {
warn qq($Me: file "$file" does not exist\n)
unless $opt->{'q'}; $Errors++; next FILE; } unless (-f $file || $opt->{a}) {
warn qq($Me: skipping non-plain file "$file"\n)
if $opt->{T}; next FILE;
my ($ext) = Sfile =" /\.([".]+)$/;
if (defined Sext && exists SCompress{$ext}) {
Sfile = "$Conpress{$ext} <$file |"; } elsif (! (-T Sfile || $opt->{a})) {
warn qq($Me: skipping binary file "$file"\n) if $opt->{T};
next FILE;
warn "$Me: checking $file\n" if $opt->{T};
unless (open(FILE, Sfile)) { unless ($opt->{'q'}) {
warn "$Me; Sfile: $!\n";
$Errors++; } next FILE;
Stotal = 0; SMatches = 0;
LINE: while (<FILE>) < SMatches = 0;
продолжение
##############
&{$matcher}(); # Поиск совпадений
##############
next LINE unless $Matches; $total += $Matches;
if ($opt->{p} || $opt->{P}) {
s/\n{2,}$/\n/ if $opt->{p};
chomp if $opt->{P};
pnnt("$name\n"), next FILE if $opt->{l};
$opt->{'s'} || print $Mult && "$name:", $opt->{n} ? "$. :" : ¦•", $_, ($opt->{p} || $opt->{P}) && ('-¦ x 20) . "\n";
next FILE if $opt->{1}; # Единица
continue {
print $Mult && "$name:", $total, "\n" if $opt->{c};
$Grand_Total += $total; }
6.23. Копилка регулярных выражений
Следующие регулярные выражения показались нам особенно полезными или интересными.
Римские цифры
m/~m*(d'c{0,3}|c[dm])(1?x{0,3}|x[1c])(v?i{0,3}|i[vx])$/i
Перестановка двух первых слов
s/(\S+))\s+)(\S+)/$3$2$1/
Ключевое слово = значение
m/(\w+)\s*=\s*(.*)\s*$/ # Ключевое слово в $1, значение - в $2
Строка содержит не менее 80 символов
т/ {80,}/
ММ/ДД/ГГ ЧЧ:ММ:СС
т| (\d+)/(\d+)/\d+) (\d+):(\d+):(\d+) |
Смена каталога
s(/usr/bin)(/usr/local/bm)g
Расширение служебных последовательностей %7Е(шестн.)
s/%([O-9A-Fa-f][O-9A-Fa-f])/chr hex 41/ge
Удаление комментариев С (не идеальное)
s{
/\» # Начальный ограничитель
. •? # Минимальное количество символов
\*/ и Конечный ограничитель ) []gsx;
Удаление начальных и конечных пропусков
s/\s+$//;
Преобразование символа \ и следующего за ним п в символ перевода строки
s/\\n/\n/g;
Удаление пакетных префиксов из полностью определенных символов 1Р-адрес
m/-[01]?\d\d|2[0-4]\d|25[0-5])\.([01]'\d\d|2[0-4]\d|25[0-5])\. ([01]Ad\d|2[0-4]\d|25[0-5])\.([01]'\d\d|2[0-4]\d|25[0-5])$/;
Удаление пути из полного имени файла
Определение ширины строки с помощью TERMCAP
$cols = ( ($ENV{TERMCAP} ]| " ") =~ m/:co#(\d+):/ ) ? $1 : 80;
Удаление компонентов каталогов из имени программы и аргументов
($name = join(" ", map { s,"\S+/,.: $_ } ($0 @ARGV));
Проверка операционной системы
die "This isn't Linux" unless $"0 =~m/linux/i;
Объединение строк в многострочных последовательностях
s/\n\s+/ /g,
Извлечение всех чисел из строки
@nums = ra/(\d+\-?\d*|\.\d+)/g;
Поиск всех слов, записанных символами верхнего регистра
@capwords = m/(\b["\Wa-zO-9_]+\b)/g;
Поиск всех слов, записанных символами нижнего регистра
@capwords = m/(\b["\WA-Z0-9_]+\b)/g;
Поиск всех слов, начинающихся с буквы верхнего регистра
@icwords = m/(\b["\Wa-z0-9_][-\WA-Z0-9_]*\b)/;
238 Глава 6 • Поиск по шаблону Поиск ссылок в HTML-документах
©links = m/<A[->]+?HREF\s*=\s*["-P(["-1 >]+?)[Поиск среднего инициала в $__
Sinitial = m/"\S+\s+(\s)\S*\s+\S/ ? $1 : "";
Замена кавычек апострофами
Выборка предложений (разделитель — два пробела)
< local $/ = "¦¦; while (о) { s/\n/ /g, s/ {3,}/ /g, push ^sentences, m/(\S.*?[i?.])(?= |\Z)/g,
ГГГГ-ММ-ДД
m/(\d{4})-(\d\d)-(\d\d)/ # ГГГГ в $1, MM в $2 и ДД в $3
Выборка строк независимо от терминатора (завершающего символа)
push(@lines, $1)
while ($input =" s/"(["\012\015].)(\012\015?|\015\012?)//),
Доступ к файлам
Я — вечности наследник В анналах времени...
А. Теннисоп, "Локсли-Холл"
Введение
Файлы занимают центральное место в обработке данных. Как и во всем остальном в Perl, простые операции с файлами выполняются просто, а сложные... как-нибудь да выполняются. Стандартные задачи (открытие файлов, чтение данных, запись данных) используют простые функции ввода/вывода и операторы, а более экзотические функции способны даже на асинхронный ввод/вывод и блокировку (locking) файлов.
В этой главе рассматривается механика доступа к файлам: открытие файлов, передача сведений о том, с какими файлами вы собираетесь работать, блокировка и т. д. Глава 8 «Содержимое файлов» посвящена работе с содержимым файлов: чтению, записи, перестановке строк и другим операциям, которые становятся возможными после получения доступа к файлу.
Следующий фрагмент выводит все строки файла /usr/local/widgets/data, содержащие слово "blue":
open (INPUT, '< /usr/local/widgets/data")
or die "Couldn't open /usr/local/widgets/data for reading' $'\n",
while (<INPUT>) {
print if /blue/, } close(INPUT),
Получение файлового манипулятора
Доступ к файлам в Perl организуется при помощи файловых манипуляторов (filehandle) — таких, как INPUT из предыдущего примера. Манипулятор — это символическое имя, которое представляет файл в операциях чтения/записи. Файло-
$var = *STDIN, mysub($var, «LOGFILE),
Файловые манипуляторы, сохраняемые в переменных подобным образом, не используются напрямую. Они называются косвенными файловыми манипуляторами (indirect filehandle), поскольку косвенно ссылаются на настоящие манипуляторы. Два модуля, IO::File (стал стандартным, начиная с версии 5.004) и FileHandle (стандартный с версии 5.000), могут создавать анонимные файловые манипуляторы.
Когда в наших примерах используются модули IO::File или IO::Handle, аналогичные результаты можно получить с применением модуля FileHandle, поскольку сейчас он является интерфейсным модулем (wrapper).
Ниже показано, как выглядит программа для поиска blue" с применением модуля IO::File в чисто объектной записи:
use 10 File,
Sinput = 10 File->new( < /usr/local/widgets/data )
or die Couldn t open /usr/local/widgets/data for reading $'\n ,
while (defmed($line = $input->getline())) <
chomp($line),
STDOUT->prmt($line) if $line =' /blue/, } $input->close(),
Как видите, без прямого использования файловых манипуляторов программа читается намного легче. Кроме того, она гораздо быстрее работает.
Но поделимся одним секретом: из этой программы можно выкинуть все стрелки и вызовы методов. В отличие от большинства объектов, объекты IOr.File не обязательно использовать объектно-ориентированным способом. В сущности, они представляют собой анонимные файловые манипуляторы и потому могут использоваться везде, где допускаются обычные косвенные манипуляторы. В рецепте 7.16 рассматриваются эти модули и префикс *. Модуль IO::File и символические файловые манипуляторы неоднократно встречаются в этой главе.
Стандартные файловые манипуляторы
Каждая программа при запуске получает три открытых глобальных файловых манипулятора: STDIN, STDOUT и STDERR. STDIN {стандартный ввод) является источником входных данных по умолчанию. В STDOUT (стандартный вывод) по умолчанию направляются выходные данные. В STDERR (стандартный поток ошибок) по умолчанию направляются предупреждения и ошибки. В интер-
Введение 241
активных программах STDIN соответствует клавиатуре, a STDOUT и STDERR — экрану монитора:
while(<STDIN>) { # Чтение из STDIN
unless (/W) {
warn "No digit found \n', й Вывод в STDERR
}
print Read , $_, # Запись в STDOUT > END { close(STDOUT) or die "couldn't close STDOUT- $' }
Файловые манипуляторы существуют на уровне пакетов. Это позволяет двум пакетам иметь разные файловые манипуляторы с одинаковыми именами (по аналогии с функциями и переменными). Функция open связывает файловый манипулятор с файлом или программой, после чего его можно использовать для ввода/ вывода. После завершения работы вызовите для манипулятора функцию close, чтобы разорвать установленную связь.
Операционная система работает с файлами через файловые дескрипторы, значение которых определяется функцией f lleno. Для большинства файловых операций хватает манипуляторов Perl, однако в рецепте 7.19 показано, как файловый дескриптор преобразуется в файловый манипулятор, используемый в программе.
Операции ввода/вывода
Основные функции для работы с файлами в Perl — open, print, < > (чтение записи) и close. Они представляют собой интерфейсные функции для процедур буферизованной библиотеки ввода/вывода С stdio. Функции ввода/вывода Perl документированы в perlfunc(i) и страницах руководства stdio(3S) вашей системы. В следующей главе операции ввода/вывода — такие, как оператор> о, print, seek и tell — рассматриваются более подробно.
Важнейшей функцией ввода/вывода является функция open. Она получает два аргумента — файловый манипулятор и строку с именем файла и режимом доступа. Например, открытие файла /tmp/log для записи и его связывание с манипулятором LOGFILE выполняется следующей командой:
open(LOGFILE, '> /tmp/log ) or die Can't write /trap/log $• ,
Три основных режима доступа — < (чтение), > (запись) и » (добавление). Дополнительные сведения о функции open приведены в рецепте 7.1.
При открытии файла или вызове практически любой системной функции1 необходимо проверять возвращаемое значение. Не каждый вызов open заканчивается успешно; не каждый файл удается прочитать; не каждый фрагмент данных, выводимый функцией print, достигает места назначения. Многие программисты для повышения устойчивости своих программ проверяют результаты open, seek, tell и close. Иногда приходится вызывать и другие функции. В документации Perl описаны возвращаемые значения всех функций и операторов. При неудачном завершении системная функция возвращает undef (кроме функций wait, waitpid и
Для чтения записей в Perl применяется оператор <МАНИПУЛЯТОР>, также часто дублируемый функцией readline. Обычно запись представляет собой одну строку, однако разделитель записей можно изменить (см. главу 8). Если МАНИПУЛЯТОР не указывается, Perl открывает и читает файлы из @ARGV, а если они не указаны — из STDIN. Нестандартные и просто любопытные применения этого факта описаны в рецепте 7.7.
С абстрактной точки зрения файл представляет собой обычный поток байтов. Каждый файловый манипулятор ассоциируется с числом, определяющим текущую позицию внутри файла. Текущая позиция возвращается функцией tell и устанавливается функцией seek. В рецепте 7.10 мы перезаписываем файл, обходясь без закрытия и повторного открытия, — для этого мы возвращаемся к началу файла функцией seek.
Когда надобность в файловом манипуляторе отпадает, закройте его функцией close. Функция получает один аргумент (файловый манипулятор) и возвращает true, если буфер был успешно очищен, а файл — закрыт, и false в противном случае. Закрывать все манипуляторы функцией close необязательно. При открытии файла, который был открыт ранее, Perl сначала неявно закрывает его. Кроме того, все открытые файловые манипуляторы закрываются при завершении программы.
Неявное закрытие файлов реализовано для удобства, а не для повышения надежности, поскольку вы не узнаете, успешно ли завершилась системная функция. Не все попытки закрытия завершаются успешно. Даже если файл открыт только для чтения, вызов close может завершиться неудачей — например, если доступ к устройству был утрачен из-за сбоя сети. Еще важнее проверять результат close, если файл был открыт для записи, иначе можно просто не заметить переполнения диска:
close(FH) or die "FH didn't close: $'";
Усердный программист даже проверяет результат вызова close для STDOUT в конце программы на случай, если выходные данные были перенаправлены в командной строке, а выходная файловая система оказалась переполнена. Вообще-то об этом должна заботиться runtime-система, Но она этого не делает.
Впрочем, проверка STDERR выглядит сомнительно. Даже если этот поток не закроется, как вы собираетесь на это реагировать?
Манипулятор STDOUT по умолчанию используется для вывода данных функциями print, printf и write. Его можно заменить функцией select, которая получает новый и возвращает предыдущий выходной манипулятор, используемый по умолчанию. Перед вызовом select должен быть открыт новый манипулятор вывода:
$old_fh = select(LOGFILE); « Переключить вывод на LOGFILE
print "Countdown initiated ...\n";
select($old_fh); # Вернуться к выводу на прежний манипулятор
print "You have 30 seconds to reach minumum safety distance.\n";
Некоторые специальные переменные Perl изменяют поведение текущего файлового манипулятора вывода. Особенно важна переменная $ |, которая управляет
буферизацией вывода для файловых манипуляторов. Буферизация рассматривается в рецепте 7.12.
Функции ввода/вывода в Perl делятся на буферизованные и небуферизованные (табл. 7.1). Несмотря на отдельные исключения, не следует чередовать их вызовы в программе. Связь между функциями, находящимися в одной строке таблицы, весьма условна. Например, по семантике функция sys read отличается от <...>, однако они находятся в одной строке, поскольку выполняют общую задачу — получение входных данных из файлового манипулятора.
Таблица 7.1 Функции ввода/вывода в Perl
Действие Буферизованные функции Небуферизованные функции
|
Открытие |
open, sysopen |
sysopen |
|
Закрытие |
close |
close |
|
Ввод |
<.. >, readline |
sysread |
|
Вывод |
print |
syswrite |
|
Позиционирование |
seek, tell |
sysseek |
7.1. Открытие файла
Проблема
Известно имя файла. Требуется открыть его для чтения или записи в Perl.
Решение
Функция open отличается удобством, sysopen — точностью, а модуль IO::File позволяет работать с анонимным файловым манипулятором.
Функция open получает два аргумента: открываемый файловый манипулятор и строку с именем файла и специальными символами, определяющими режим открытия:
open(SOURCE, "< $path")
or die "Couldn't open $path for reading: $!\n";
open(SINK, "> $path")
or die "Couldn't open $path for writing: $!\n";
где SOURCE — файловый манипулятор для ввода, a SINK — для вывода.
Функции sysopen передаются три или четыре аргумента: файловый манипулятор, имя файла, режим и необязательный параметр, определяющий права доступа. Режим представляет собой число, конструируемое из констант модуля Fcntl:
use Fcntl;
sysopen(SOURCE, $path, O_RDONLY)
244 Глава 7 • Доступ к файлам
or die "Couldn't open $path for reading: $!\n";sysopen(SINK, $path, O_WRONLY)
or die "Couldn't open $path for writing: $!\n";
Аргументы метода new модуля IO::File могут задаваться в стиле как open, так и sysopen. Метод возвращает анонимный файловый манипулятор. Кроме того, также возможно задание режима открытия в стиле fopen(3):
use 10':File,
# По аналогии с open
$smk = 10:'File->new("> $filename")
or die 'Couldn't open $filename for writing $'\n";
# По аналогии с sysopen
$fh = IO:-File->new($filename, O_WRONLY|O_CREAT)
or die "Couldn't open $filename for reading: $'\n";
# По аналогии с fopen(3) библиотеки stdio
$fh = 10' File->new($filename, "r+")
or die "Couldn't open $filename for read and write: $'\n";
Комментарий
Все операции ввода/вывода осуществляются через файловые манипуляторы независимо от того, упоминаются манипуляторы в программе или нет. Файловые манипуляторы не всегда связаны с конкретными файлами — они также применяются для взаимодействия с другими программами (см. главу 16 «Управление процессами и межпроцессные взаимодействия») и в сетевых коммуникациях (см. главу 17 «Сокеты»). Функция open также применяется для работы с файловыми дескрипторами, данная возможность рассматривается в рецепте 7.19.
Функция open позволяет быстро и удобно связать файловый манипулятор с файлом. Вместе с именем файла передаются сокращенные обозначения стандартных режимов (чтение, запись, чтение/запись, присоединение). Функция не позволяет задать права доступа для создаваемых файлов и вообще решить, нужно ли создавать файл. Если вам потребуются подобные возможности, воспользуйтесь функцией sysopen, которая использует константы модуля Fcntl для управления отдельными компонентами режима (чтение, запись, создание и усечение).
Большинство программистов начинает работать с open задолго до первого использования sysopen. В таблице показано соответствие между режимами функции open («Файл»), константами sysopen («Флаги») и строками fopen(3), передаваемыми 10:: File->new («Символы»). Столбцы «Чтение» и «Запись» показывают, возможно ли чтение или запись для данного файлового манипулятора. «Присоединение» означает, что выходные данные всегда направляются в конец файла независимо от текущей позиции (в большинстве систем). В режиме усечения функция open уничтожает все существующие данные в открываемом файле.
|
7.1. ( |
Открытие |
файла 245 |
|||||
|
Файл |
Чтение |
Запись |
Присое- |
Созда- |
Очистка |
Флаги |
Символы |
|
динение |
ние |
содержи- |
О_ |
||||
|
мого |
|||||||
|
<файл |
Да |
Нет |
Нет |
Нет |
Нет |
RDONLY |
"г" |
|
> файл, |
Нет |
Да |
Нет |
Да |
Да |
WRONLY |
"w" |
|
режим |
TRUNC |
||||||
|
открытия> |
CREAT |
||||||
|
» файл>, |
Нет |
Да |
Да |
Да |
Нет |
WRONLY |
"a" |
|
режим |
APPEND |
||||||
|
открытия> |
CREAT |
||||||
|
+< файл |
Да |
Да |
Нет |
Нет |
Нет |
RDWR |
Mr+" |
|
+> файл, |
Да |
Да |
Нет |
Да |
Да |
RDWR |
"w+" |
|
режим |
TRUNC |
||||||
|
открытия> |
CREAT |
||||||
|
+» файл>, |
Да |
Да |
Да |
Да |
Нет |
RDWR |
"a+" |
|
режим |
APPEND |
||||||
|
открытия> |
CREAT |
Подсказка: режимы +> и +» почти никогда не используются. В первом случае файл уничтожается еще до того, как он будет прочитан, а во втором часто возникают затруднения, связанные с тем, что указатель чтения может находиться в произвольной позиции, но при записи на многих системах почти всегда происходит переход в конец файла.
Функция sysopen получает три или четыре аргумента:
sysopen(FILEHANDLE, $name, $flags) or die "Can't open $name : $!"; sysopen(FILEHANDLE, $name, $flags, $perms) or die "Can't open $name : $!";
Здесь $name — имя файла без «довесков» в виде < или +; $f lags — число, полученное объединением констант режимов O_CREAT, O_WRONLY, O_TRUNC и т. д. операцией OR. Конкретный состав доступных констант 0_ зависит от операционной системы. Дополнительные сведения модно найти в электронной документации (обычно open(2), но не всегда) или в файле /usr/include/fcntl.h. Обычно встречаются следующие константы:
O_RDONLY Только чтение.
0_WRONLY Только запись.
O_RDWR Чтение и запись.
O_CREAT Создание файла, если он не существует.
O_EXCL Неудачное завершение, если файл уже существует.
O_APPEND Присоединение к. файлу.
O_TRUNC Очистка содержимого файла.
O_NONBLOCK Асинхронный доступ.
К числу менее распространенных констант принадлежат O_SHLOCK, O_EXLOCK, O_BINARY, 0_N0CTTY и O_SYNC. Обращайтесь к странице руководства ореп(2) или к ее эквиваленту.
Если функции sysopen не передается аргумент $perms, Perl использует восьмеричное число 0666. Права доступа задаются в восьмеричной системе и учитыва-
Если у вас возникнут затруднения с масками доступа, воспользуйтесь про стым советом: передавайте значение 0666 для обычных файлов и 0777 для каталогов и исполняемых файлов. У пользователя появляется выбор: если ему понадобятся защищенные файлы, то может выбрать маску 022, 027 или антиобщественную маску 077. Как правило, решения из области распределения прав должны приниматься не программой, а пользователем. Исключения возникают при записи в файлы, доступ к которым ограничен: почтовые файлы, cookies в Web-броузерах, файлы .rhosts и т. д. Короче говоря, функция sysopen почти никогда не вызывается с аргументом 0644, так как у пользователя пропадает возможность выбрать более либеральную маску.
Приведем примеры практического использования open и sysopen.
Открытие файла для чтения:
open(FH, "< $path") or die$!;
sysopen(FH, $path, O_RDONLY) or die$!;
Открытие файла для записи (если файл не существует, он создается, а если существует — усекается):
open(FH, "> $path") or die$!
sysopen(FH, $path, O_WRONLY|O_TRUNC|O_CREAT) or die$!
sysopen(FH, $path, O_WRONLY|O_TRUNC|O_CREAT, 0600) or die$!
Открытие файла для записи с созданием нового файла (файл не должен существовать):
sysopen(FH, $path, O_WRONLY|O_EXCL|O_CREAT) or die$!;
sysopen(FH, $path, O_WRONLY|O_EXCL|O_CREAT, 0600) or die$!;
Открытие файла для присоединения (в случае необходимости файл создается):
open(FH, "» $path") or die$!;
sysopen(FH, $path, O_WRONLY|O_APPEND|O_CREAT) or die$!;
sysopen(FH, $path, O_WRONLY|O_APPEND|O_CREAT, 0600) or die$!;
Открытие файла для присоединения (файл должен существовать):
sysopen(FH, $path, O_WRONLY|O_APPEND) ordie$!;
Открытие файла для обновления (файл должен существовать):
open(FH, "+< $path") or die$!;
sysopen(FH, $path, O_RDWR) or die$!;
Открытие файла для обновления (в случае необходимости файл создается):
sysopen(FH, $path, O_RDWR|O_CREAT) or die$!;
sysopen(FH, $path, O_RDWR|O_CREAT, 0600) or die$!;
Открытие файла для обновления (файл не должен существовать):
sysopen(FH, $path, 0_RDWR|0_EXCL|0_CfiEAT) or die$!;
sysopen(FH, $path, O_RDWR|O_EXCL|O_CREAT, 0600) or die$!;
Маска 0600 всего лишь поясняет, как создаются файлы с ограниченным доступом. Обычно этот аргумент пропускается.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций open, sysopen и umask в perlfunc(i); документация по стан- * дартным модулям IO::File и Fcntl; страницы руководства open(2), fopen(3) и umask(2); рецепт 7.2.
7.2. Открытие файлов с нестандартными именами
Проблема
Требуется открыть файл с нестандартным именем — например, "-"; начинающимся с символа <, > или |; содержащим начальные или конечные пропуски; заканчивающимся символом |. Функция open не должна принимать эти функции за служебные, поскольку вам нужно совершенно иное.
Решение
Выполните предварительное преобразование:
Sfilename =' s#"(\s)#./$1#;
open(HANDLE, "< $filename\0") or die "cannot open $filenaroe : $!\n";
Или просто воспользуйтесь функцией sysopen:
sysopen(HANDLE, Sfilename, O_RDONLY) or die "cannot open Sfilename : $!\n";
Комментарий
Функция open определяет имя файла и режим открытия по одному строковому аргументу. Если имя файла начинается с символа, обозначающего один из режимов, open вполне может сделать что-нибудь неожиданное. Рассмотрим следующий фрагмент:
Sfilename = shift @ARGV;
open(INPUT, $filename) or die "cannot open Sfilename : $!\n";
Если пользователь указывает в командной строке файл ">/etc/passwd", программа попытается открыть /etc/passwd для записи — со всеми вытекающими последствиями! Режим можно задать и явно (например, для записи):
open(OUTPUT, ">$filename")
or die "Couldn't open Sfilename for writing: $!\n";
но даже в этом случае пользователь может ввести имя ">data", после чего программа будет дописывать данные в конец файла data вместо того, чтобы стереть прежнее содержимое.
use Fcntl; # Для файловых констант
sysopen(OUTPUT, $filename, O_WRONLY|O_TRUNC)
or die "Couldn't open $filename for writing $'\n";
А вот как добиться того же эффекта с функцией open для имен файлов, содержащих начальные или конечные пропуски:
$file =' s#~(\s)# /$1#, open(HANDLE, ¦> $file\0")
or die "Could't open $file for OUTPUT $>\n";
Такая подстановка защищает исходные пропуски, но не в абсолютных именах типа " /etc/passwd", а лишь в относительных (" passwd"). Функция open не считает нуль-байт ("\0") частью имени файла, но благодаря ему не игнорируются конечные пропуски.
Волшебная интерпретация файловых имен в функции open почти всегда оказывается удобной. Вам никогда не приходится обозначать ввод или вывод с помощью особой формы " -'. Если написать фильтр и воспользоваться простой функцией open, пользователь сможет передать вместо имени файла строку "gzip -de bible.gz|" — фильтр автоматически запустит программу распаковки.
Вопросы безопасности open актуальны лишь для программ, работающих в особых условиях. Если программа должна работать под управлением чего-то другого — например, сценариев CGI или со сменой идентификатора пользователя, — добросовестный программист всегда учтет возможность ввода пользователем собственного имени файла, при котором вызов open для простого чтения превратится в перезапись файла или даже запуск другой программы. Параметр командной строки Perl -T обеспечивает проверку ошибок.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций open и sysopen вperlfunc(l); рецепты 7.1, 7.7,16.2, 19.4 и 19.6.
7.3. Тильды в именах файлов
Проблема
Имя файла начинается с тильды (например, -username/blah), однако функция open не интерпретирует его как обозначение домашнего каталога (home directory).
Решение
Выполните ручное расширение с помощью следующей подстановки:
$filename =" s{ " " ( ["/]* ) } { $1
? (getpwnam($1))[7]
( $ENV{HOME} || $ENV{LOGDIR}
(getpwurd($>))[7]
) >ех,
Комментарий
Нас интересуют следующие применения тильды:
-user -user/blah
-/blah
где user — имя пользователя.
Если " не сопровождается никаким именем, используется домашний каталог текущего пользователя.
В данной подстановке использован параметр /е, чтобы заменяющее выражение интерпретировалось как программный код Perl. Если за тильдой указано имя пользователя, оно сохраняется в $1 и используется getpwnam для выбора домашнего каталога пользователя из возвращаемого списка. Найденный каталог образует заменяющую строку. Если за тильдой не указано имя пользователя, подставляется либо текущее значение переменной окружения НОМЕ или LOGOIR. Если эти переменные не определены, задается домашний каталог текущего пользователя.
С> Смотри также------------------------------------------------------------------------------------------
Описание функции getpwnam вperlfunc(l); man-страница getpwnam(2) вашей системы; рецепт 9.6.
7.4. Имена файлов в сообщениях об ошибках
Проблема
Программа работает с файлами, однако в предупреждения и сообщения об ошибках Perl включается только последний использованный файловый манипулятор, а не имя файла.
Решение
Воспользуйтесь именем файла вместо манипулятора:
open($path, "< $path")
or die "Couldn't open $path for reading • $!\n";
Комментарий
Стандартное сообщение об ошибке выглядит так:
Argument "3\п" isn't numeric in multiply at tallyweb line 16, <LOG> chunk 17.
Argument "3\n" isn't numeric in multiply at tallyweb line 16, </usr/local/data/mylog3.dat> chunk 17.
К сожалению, этот вариант не работает при включенной директиве strict ref s, поскольку переменная $path в действительности содержит не файловый манипулятор, а всего лишь строку, которая иногда ведет себя как манипулятор. Фрагмент (chunk), упоминаемый в предупреждениях и сообщениях об ошибках, представляет собой текущее значение переменной $..
> Смотри также---------------------------------------------------------------------------------------------
Описание функции open вperlfunc(l); рецепт 7.1.
7.5. Создание временных файлов
Проблема
Требуется создать временный файл и автоматически удалить его при завершении программы. Допустим, вы хотите записать временный конфигурационный файл, который будет передаваться запускаемой программе. Его имя должно быть известно заранее. В других ситуациях нужен временный файл для чтения и записи данных, причем его имя вас не интересует.
Решение
Если имя файла не существенно, воспользуйтесь методом класса new_tmpfile модуля IO::File для получения файлового манипулятора, открытого для чтения и записи:
use 10::File;
$fh = 10::File->new_tmpfile
or die "Unable to make new temporary file: $!";
Если имя файла должно быть известно, получите его функцией tmpnam из модуля POSIX и откройте файл самостоятельно:
use 10::File;
use POSIX qw(tmpnam);
# Пытаться получить временное имя файла до тех пор,
8 пока не будет найдено несуществующее имя
do { $name = tmpnamQ }
until $fh = IO::File->new($name, O_RDWR|O_CREAT|O_EXCL);
# Установить обработчик, который удаляет временный файл
# при нормальном или аварийном завершении программы
7.5. Создание временных файлов 251
END { unlmk($name) or die "Couldn't unlink $name : $!" } # Перейти к использованию файла...
Комментарий
Если все, что вам нужно, — область для временного хранения данных, воспользуйтесь методом new_tmpf ile модуля IO::File. Он возвращает файловый манипулятор для временного файла, открытого в режиме чтения/записи фрагментом следующего вида:
for (;;) {
$name = tmpnam();
sysopen(TMP, $tmpnam, O_RDWR | O_CREAT | O_EXC) 4& last; } unlink $tmpnam;
Файл автоматически удаляется при нормальном или аварийном завершении программы. Вам не удастся определить имя файла и передать другому процессу, потому что у него нет имени. В системах с поддержкой подобной семантики имя удаляется еще до завершения метода. Впрочем, открытый файловый манипулятор может наследоваться производными процессами1.
Ниже показан пример практического применения new_tmpf ile. Мы создаем временный файл, выполняем запись, возвращаемся к началу и выводим записанные данные:
use 10::File;
$fh = 10: :File->new_tmpfile or die "10:.File->new_tmpfile: $!";
$fh->autoflush(1);
print( $fh "$i\n" while $i++ < 10;
seek($fh, 0, 0);
print "Trap file has: ", <$fh>;
Во втором варианте создается временный файл, имя которого можно передать другому процессу. Мы вызываем функцию POSIX: :tmpnam, самостоятельно открываем файл и удаляем его после завершения работы. Перед открытием файла мы не проверяем, существует ли файл с таким именем, поскольку при этом может произойти подмена — кто-нибудь создаст файл между проверкой и созданием2. Вместо этого tmpnam вызывается в цикле, что гарантирует создание нового файла и предотвращает случайное удаление существующих файлов. Теоретически метод new_tmpf ile не должен возвращать одинаковые имена разным процессам.
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартным модулям IO::File и POSIX; рецепт 7.19; страница руководства tmpnam(3) вашей системы.
2 См. рецепт 19.4.
Проблема
Некоторые данные должны распространяться вместе с программой и интерпретироваться как файл, но при этом они не должны находиться в отдельном файле.
Решение
Лексемы_ DATA и__ END после исходного текста программы отмечают начало
блока данных, который может быть прочитан программой или модулем через файловый манипулятор DATA.
В модулях используется лексема____ DATA :
while (<DATA>) {
# Обработать строку
}
__DATA__
# Данные
Аналогично используется____ END в главном файле программы:
while (<main::DATA>) {
# Обработать строку
}
_ END
# Данные
Комментарий
Лексемы_ DATA и__ END_ обозначают логическое завершение модуля или
сценария перед физическим концом файла. Текст, находящийся после DATA
или END_ , может быть прочитан через файловый манипулятор DATA уровня па
кета. Предположим, у нас имеется гипотетический модуль Primes; текст пост
ле_ DATA в файле Primes.pm может быть прочитан через файловый манипуля
тор Primes: :DATA.
Лексема_ END________________________ представляет собой синоним DATA в главном пакете. Текст,
следующий после лексем___ END в модулях, недоступен.
Появляется возможность отказаться от хранения данных в отдельном файле и перейти к построению автономных программ. Такая возможность нередко используется для документирования. Иногда в программах хранятся конфигурационные или старые тестовые данные, использованные при разработке программ, — они могут пригодиться в процессе отладки.
Манипулятор DATA также применяется для определения размера или даты последней модификации текущей программы или модуля. В большинстве систем переменная $0 содержит полное имя файла для работающего сценария. В тех системах, где значение $0 оказывается неверным, можно воспользоваться манипулятором DATA для определения размера, даты модификации и т. д. Вставьте в конец файла
специальную лексему DATA________________________ (и предупреждение о том, что DATA не следует
удалять), и файловый манипулятор DATA будет связан с файлом сценария.
7.7. Создание фильтра 253
use POSIX qw(strftime);
$raw_time = (stat(DATA))[9];
$size = -s DATA;
$kilosize = mt($size / 1024) . 'k';
print "<p>Script size is $kilosize\n";
print strftime("<P>Last script update: %c (%Z)\n", localtime($raw_time));
__DATA__
DO NOT REMOVE THE PRECEDING LINE
Everything else in this file will be ignored.
> Смотри также---------------------------------------------------------------------------------------------
Раздел «Scalar Value Constructors» perldata(l).
7.7. Создание фильтра
Проблема
Вы хотите написать программу, которая получает из командной строки список файлов. Если файлы не заданы, входные данные читаются из STDIN. При этом пользователь должен иметь возможность передать программе " -" для обозначения STDIN или "someprogram |" для получения выходных данных другой программы. Программа может непосредственно модифицировать файлы или выводить результаты на основании входных данных.
Решение
Читайте строки оператором, оператор> <>:
while (о) {
# Сделать что-то со строкой
Комментарий
Встречая конструкцию:
while (о) {
Perl преобразует ее к следующему виду1:
unshift(@ARGV, ¦-') unless @ARGV; while($ARGV = shift @ARGV) {
unless (open(ARGV, $ARGV)) {
next; } while (defined($_ = <ARGV>)) {
#...
Внутри цикла с помощью ARGV и $ARGV можно получить дополнительные данные или узнать имя текущего обрабатываемого файла. Давайте посмотрим, как это делается.
Общие принципы
Если пользователь не передает аргументы, Perl заносит в @ARGV единственную строку,"-". Это сокращенное обозначение соответствует STDIN при открытии для чтения и STDOUT — для записи. Кроме того, пользователь может передать "-"в командной строке вместо имени файла для получения входных данных из STDIN.
Далее в цикле из @ARGV последовательно извлекаются аргументы, а имена файлов копируются в глобальную переменную SARGV. Если файл не удается открыть, Perl переходит к следующему файлу. В противном случае начинается циклическая обработка строк открытого файла. После завершения обработки открывается следующий файл, и процесс повторяется до тех пор, пока не будет исчерпано все содержимое @ARGV.
При вызове open не используется форма open(ARGV, "> $ARGV"). Это позволяет добиться интересных эффектов — например, передать в качестве аргумента строку "gzip -de file, gz |", чтобы программа получила в качестве входных данных результаты команды "gzip -de file. gz". Такое применение open рассматривается в рецепте 16.15.
Массив @ARGV может изменяться перед циклом или внутри него. Предположим, вы хотите, чтобы при отсутствии аргументов входные данные читались не из STDIN, а из всех программных и заголовочных файлов С и C++. Вставьте следующую строку перед началом обработки <ARGV>:
@ARGV = glob("*.[Cch]") unless @ARGV;
Перед началом цикла следует обработать аргументы командной строки — либо с помощью модулей Getopt (см. главу 15 «Пользовательские интерфейсы»), либо вручную:
# Аргументы 1: Обработка необязательного флага -с if ((°>ARGV && $ARGV[O] eq '-с') {
$chop_first++;
shift;
# Аргументы 2; Обработка необязательного флага -NUMBER if (@ARGV && $ARGV[0] =* /"-(\d+)$/) {
Scolumns = $1;
shift;
7.7. Создание фильтра 255
>
# Аргументы 3: Обработка сгруппированных флагов -a, -i -n, и -и while (@ARGV && $ARGV[0] =" /"-(.+)/ & (shift, ($_ = $1), 1)) {
next if /"$/;
s/a// && (++$append, redo);
s/i// && (++$ignore_ints, redo);
s/n// && (++$nostdout, redo);
s/u// && (++$unbuffer, redo);
die "usage: $0 [-ainu] [filenames] ...\n";
Если не считать неявного перебора аргументов командной строки, о не выделяется ничем особенным. Продолжают действовать все специальные переменные, управляющие процессом ввода/вывода (см. главу 8). Переменная $/ определяет разделитель записей, а $. содержит номер текущей строки (записи). Если $/ присваивается неопределенное значение, то при каждой операции чтения будет получено не объединенное содержимое всех файлов, а полное содержимое одного файла:
undef $/; while (о) {
# Теперь в $_ находится полное содержимое файла,
# имя которого хранится в $ARGV
Если значение $/ локализовано, старое значение автоматически восстанавливается при выходе из блока:
{ и Блок для local
local $/; # Разделитель записей становится неопределенным while (<>) {
# Сделать что-то; в вызываемых функциях
# значение $/ остается неопределенным
} # Восстановить $/
Поскольку при обработке <ARGV> файловые манипуляторы никогда не закрываются явно, номер записи $. не сбрасывается. Если вас это не устраивает, самостоятельно организуйте явное закрытие файлов для сброса $.:
while (о) {
print "$ARGV:$.:$_"; close ARGV if eof;
Функция eof проверяет достижение конца файла при последней операции чтения. Поскольку последнее чтение выполнялось через манипулятор ARGV, eof сообщает, что мы находимся в конце текущего файла. В этом случае файл закрывается, а переменная $. сбрасывается. С другой стороны, специальная запись eof () с круглыми скобками, но без аргументов проверяет достижение конца всех файлов при обработке <ARGV>.
В Perl предусмотрены специальные параметры командной строки —п, -р и -i,
упрощающие написание фильтров и однострочных программ.
Параметр -п помещает исходный текст программы внутрь цикла while(o). Обычно он используется в фильтрах типа grep или программах, которые накапливают статистику по прочитанным данным.
Пример 7.1. findloginl
#!/usr/bin/perl
# findloginl - вывести все строки, содержащие подстроку "login"
while (о) { # Перебор файлов в командной строке
print if /login/; >
Программу из примера 7.1 можно записать так, как показано в примере 7.2.
Пример 7.2. findlogin2
#!/usr/bin/perl -n
# findlogin2 - вывести все строки, содержащие подстроку "login"
print if /login/;
Параметр -n может объединяться с -е для выполнения кода Perl из командной строки:
% perl -ne 'print if /login/'
Параметр -р аналогичен -п, однако он добавляет print в конец цикла. Обычно он используется в программах для преобразования входных данных.
Пример 7.3. lowercasel
#!/usr/bin/perl
# lowercase - преобразование всех строк в нижний регистр
use locale;
while (<>) { # Перебор в командной строке
s/(["\W0-9_])/\l$1/g; # Перевод всех букв в нижний регистр
print; }
Программу из примера 7.3 можно записать так, как показано в примере 7.4. Пример 7.4. Iowercase2
#!/usr/bin/perl -p
# lowercase - преобразование всех строк в нижний регистр
use locale;
s/(["\W0-9_])/\l$1/g; # Перевод всех букв в нижний регистр
Или непосредственно в командной строке следующего вида:
% perl -Mlocale -pe 's/(["\W0-9_])/\1$1/g'
При использовании —п или —р для неявного перебора входных данных для всего цикла негласно создается специальная метка LINE:. Это означает, что из внутреннего цикла можно перейти к следующей входной записи командой next LINE (аналог next в awk). При закрытии ARGV происходит переход к следующему файлу (аналог nextfile в awk). Обе возможности продемонстрированы в примере 7.5.
Пример 7.5. countchunks
#'/usr/bin/perl -n
# countchunks - подсчет использованных слов
# с пропуском комментариев. При обнаружении _ END или DATA
# происходит переход к следующему файлу
for (split /\W+/) <
next LINE if /"#/;
close ARGV if /__(DATA|END)__/;
$chunks++; } END { print "Found $chunks chunks\n" }
В файле .history, создаваемым командным интерпретатором tcsh, перед каждой строкой указывается время, измеряемое в секундах с начала эпохи:
#+0894382237
less /etc/motd
#+0894382239
vi V.exrc
#+0894382242
date
#+0894382239
who
#+0894382288
telnet home
Простейшая однострочная программа приводит его к удобному формату:
%perl -ре ls/"#\+(\d+)\n/localtime($1) . " "/е1
Tue May 5 09:30:37 1998 less /etc/motd
Tue May 5 09:30:39 1998 vi "/.exrc
Tue May 5 09:30:42 1998 date
Tue May 5 09:30:42 1998 who
Tue May 5 09:30:28 1998 telnet home
Параметр -i изменяет каждый файл в командной строке. Он описан в рецепте 7.9 и обычно применяется в сочетании с -р.
Для работы с национальными наборами символов используется директива use
locale.
> Смотри также------------------
perlrun(l); рецепты 7.9; 16.6.
Проблема
Требуется обновить содержимое файла на месте. При этом допускается применение временного файла.
Решение
Прочитайте данные из исходного файла, запишите изменения во временный файл и затем переименуйте временный файл в исходный:
open(0LD, "< $old") or die "can't open $old. $!",
open(NEW, "< $new") or die "can't open $new $!";
select(NEW); # Новый файловый манипулятор,
# используемый print по умолчанию while (<OLD>) {
# Изменить $_, затем. .
print NEW $_ or die 'can't write $new: $'";
>
close(OLD) or die "can't close Sold $'";
close(NEW) or die 'can t close $new: $'";
rename($old, "$old.orig") or die "can t rename Sold to Sold orig: $! ';
rename($new, Sold) or die "can t rename $new to Sold. $!";
Такой способ лучше всего приходит для обновления файлов «на месте».
Комментарий
Этот метод требует меньше памяти, чем другие подходы, не использующие временных файлов. Есть и другие преимущества — наличие резервной копии файла, надежность и простота программирования.
Показанная методика позволяет внести в файл те же изменения, что и другие версии, не использующие временных файлов. Например, можно вставить новые строки перед 20-й строкой файла:
while (<OLD>) {
if ($. == 20) {
print NEW "Extra line 1\n";
print NEW "Extra line 2\n";
>
print NEW $_;
}
Или удалить строки с 20 по 30:
while (<OLD>) {
next if 20 .. 30; print NEW $_;
Программист-перестраховщик непременно заблокирует файл на время обновления.
£> Смотри также-------------------------------------------------------------------------------------------
Рецепты 7.1; 7.9-7.10
7.9. Непосредственная модификация файла с помощью параметра -i
Проблема
Требуется обновить файл на месте из командной строки, но вам лень1 возиться с файловыми операциями из рецепта 7.8.
Решение
Воспользуйтесь параметрами -i и -р командной строки Perl. Запишите свою программу в виде строки:
% perl -l.orig -p 'ФИЛЬТР' файл1 файл2 файлЗ ...
Или воспользуйтесь параметрами в самой программе:
#!/usr/bin/perl -l.orig -p # Фильтры
Комментарий
Параметр командной строки -i осуществляет непосредственную модификацию файлов. Он создает временный файл, как и в предыдущем рецепте, однако Perl берет на себя все утомительные хлопоты с файлами. Используйте -i в сочетании с -р (см. рецепт 7.7), чтобы превратить:
% perl -pi.ong -e 's/DATE/localtime/e' в следующий фрагмент:
while (о) {
if ($ARGV ne Soldargv) { # Мы перешли к следующему файлу'
rename($ARGV, $ARGV '.ong'), open(ARGVOUT, ">$ARGV); # Плюс проверка ошибок select(ARGVOUT); Soldargv = $ARGV; >
s/DATE/localtime/e; } continue!
}
select (STDOUT); # Восстановить стандартный вывод
Параметр -i заботится о создании резервных копий (если вы не желаете сохранять исходное содержимое файлов, используйте -i вместо -i.orig), а -р заставляет Perl перебирать содержимое файлов, указанных в командной строке (или STDIN при их отсутствии).
Приведенная выше однострочная программа приводит данные:
Dear Sir/Madam/Ravenous Beast,
As of DATE, our records show your account is overdue Please settle by the end of the month. Yours in cheerful usury,
--A. Moneylender
к следующему виду:
Dear Sir/Madam/Ravenous Beast,
As of Sat Apr 25 12¦ 28 33 1998, our records show your account is overdue. Please settle by the end of the month Yours in cheerful usury,
--A Moneylender
Этот параметр заметно упрощает разработку и чтение программ-трансляторов. Например, следующий фрагмент заменяет все изолированные экземпляры "hisvar" на "hervar" во всех файлах С, C++ иуасс:
%perl -I old -pe 's{\bhisvar\b}{hervar}g * [Cchy]
%perl -l.old -ne print unless /"STARTS/ . /"ENDS/ bigfile text
Действие -i может включаться и выключаться с помощью специальной переменной $"1. Инициализируйте @>ARGV и затем примените <> так, как применили бы -i для командной строки:
# Организовать перебор файлов *.с в текущем каталоге,
# редактирование на месте и сохранение ста'рого файла с расширением . опд
local $"I = '.orig'; # Эмулировать -l.ong
local @ARGV = glob('*.C); # Инициализировать список файлов while (о) {
if ($ == 1) {
print "This line should appear at the top of each file\n",
}
s/\b(p)earl\b/{1}erl/ig, # Исправить опечатки с сохранением регистра
print; } continue {close ARGV if eof)
Учтите, что при создании резервной копии предыдущая резервная копия уничтожается.
> Смотри также---------------------------------------------------------------------------------------------
Описание переменных $"1 и $. Bperlvar(l); описание оператора . . в разделе «Range Operator» perlop(l); perlrun{\).
Проблема
Требуется вставить, удалить или изменить одну или несколько строк файла. При этом вы не хотите (или не можете) создавать временный файл.
Решение
Откройте файл в режиме обновления ("+<"), прочитайте все его содержимое в массив строк, внесите необходимые изменения в массиве, после чего перезапишите файл и выполните усечение до текущей позиции.
open(FH, "+< FILE" or die "Opening: $'";
@ARRAY = <FH>;
# Модификация массива ARRAY
seek(FH,O,O) or die "Seeking: $!";
print FH ©ARRAY or die "Printing: $!";
truncate(FH,tell(FH)) or die "Truncating: $•";
close(FH) or die "Closing: $'";
Комментарий
Как сказано во введении, операционная система интерпретирует файлы как неструктурированные потоки байтов. Из-за этого вставка, непосредственная модификация или изменение отдельных битов невозможны (кроме особого случая, рассматриваемого в рецепте 8.13 — файлов с записями фиксированной длины). Для хранения промежуточных данных можно воспользоваться временным файлом. Другой вариант — прочитать файл в память, модифицировать его и записать обратно.
Чтение в память всего содержимого подходит для небольших файлов, но с большими возникают сложности. Попытка применить его для 800-мегабайтных файлов журналов на Web-сервере приведет либо к переполнению виртуальной памяти, либо общему сбою системы виртуальной памяти вашего компьютера. Однако для файлов малого объема подойдет такое решение:
open(F, "+< $infile") or die "can't read $infile: $'"; $out = "; while (<F>) {
s/DATE/localt ime/eg;
$out .= $_;
seek(F, 0, 0) print F $out truncate(F, tell(F)) close(F)
or die "Seeking: $!"; or die "Printing: $!"; or die "Truncating: $! or die "Closing: $!";
Другие примеры операций, которые могут выполняться на месте, приведены в рецептах главы 8.
Если вы особо мнительны, не забудьте заблокировать файл.
> Смотри также------------------------------------------------------------------------
Описание функций seek, truncate, open и sysopen вperlfunc{\); рецепты 7.8—7.9.
7.11. Блокировка файла
Проблема
Несколько процессов одновременно пытаются обновить один и тот же файл.
Решение
Организуйте условную блокировку с помощью функции flock:
open(FH, "+< $path") or die "can't open $path- $'";
flock(FH,2) or die "can't flock $path. $' ';
# Обновить файл, затем...
close(FH) or die "can't close $path. $'";
Комментарий
Операционные системы сильно отличаются по типу и степени надежности используемых механизмов блокировки. Perl старается предоставить программисту рабочее решение даже в том случае, если операционная система использует другой базовый механизм. Функция flock получает два аргумента: файловый манипулятор и число, определяющее возможные действия с данным манипулятором. Числа обычно представлены символьными константами типа LOCK_EX, имена которых можно получить из модуля Fcntl или IO::File.
Символические константы LOCK_SH, LOCK_EX, LOCK_UN и LOCK_NB появились в модуле Fcntl лишь начиная с версии 5.004, но даже теперь они доступны лишь по специальному запросу с тегом : flock. Они равны соответственно 1, 2, 4 и 8, и эти значения можно использовать вместо символических констант. Нередко встречается следующая запись:
sub LOCK_SH() { 1 > # Совместная блокировка (для чтения)
sub LOCK_EX() { 2 } # Монопольная блокировка (для записи)
sub LOCK_NB() { 4 } # Асинхронный запрос блокировки
sub LOCK_UN() { 8 } # Снятие блокировки (осторожно!)
Блокировки делятся на две категории: совместные (shared) и монопольные (exclusive). Термин «монопольный» может ввести вас в заблуждение, поскольку процессы не обязаны соблюдать блокировку файлов. Иногда говорят, что flock реализует условную блокировку, чтобы операционная система могла приостано-
вить все операции записи в файл до того момента, когда с ним закончит работу последний процесс чтения.
Условная блокировка напоминает светофор на перекрестке. Светофор работает лишь в том случае, если люди обращают внимание на цвет сигнала: красный или зеленый — или желтый для условной блокировки. Красный цвет не останавливает движение; он всего лишь сообщает, что движение следует прекратить. Отчаянный, невежественный или просто наглый водитель проедет через перекресток независимо от сигнала светофора. Аналогично работает и функция flock — она тоже блокирует другие вызовы flock, а не процессы, выполняющие ввод/вывод. Правила должны соблюдаться всеми, иначе могут произойти (и непременно произойдут) несчастные случаи.
Добропорядочный процесс сообщает о своем намерении прочитать данные из файла, запрашивая блокировку LOCK_SH. Совместная блокировка файла может быть установлена сразу несколькими процессами, поскольку они (предположительно) не будут изменять данные. Если процесс собирается произвести запись в файл, он должен запросить монопольную блокировку с помощью LOCK_EX. Затем операционная система приостанавливает этот процесс до снятия блокировок остальными процессами, после чего приостановленный процесс получает блокировку и продолжает работу. Можно быть уверенным в том, что на время сохранения блокировки никакой другой процесс не сможет выполнить flock(FH, LOCK_EX) для того же файла. Это похоже на другое утверждение — «в любой момент для файла может быть установлена лишь одна монопольная блокировка», но не совсем эквивалентно ему. В некоторых системах дочерние процессы, созданные функцией fork, наследуют от своих родителей не только открытые файлы, но и установленные блокировки. Следовательно, при наличии монопольной блокировки и вызове fork без exec производный процесс может унаследовать монопольную блокировку файла.
Функция flock по умолчанию приостанавливает процесс. Указывая флаг LOCK_NB, при запросе можно получить блокировку без приостановки. Благодаря этому можно предупредить пользователя об ожидании снятия блокировок другими процессами:
unless (flock(FH, LOCK_EX|LOCK_NB)) {
warn "can't immediately write-lock the file ($!), blocking ..."; unless (flock(FH, LOCK_EX)) {
die "can't get write-lock on numfile: $!";
Если при использовании LOCK_NB вам было отказано в совместной блокировке, следовательно, кто-то другой получил LOCK_EX и обновляет файл. Отказ в монопольной блокировке означает, что другой процесс установил совместную или монопольную блокировку, поэтому пытаться обновлять файл не следует.
Блокировки исчезают с закрытием файла, что может произойти лишь после завершения процесса. Ручное снятие блокировки без закрытия файла — дело рискованное. Это связано с буферизацией. Если между снятием блокировки и очисткой буфера проходит некоторое время, то данные, заменяемые содержимым буфера, могут быть прочитаны другим процессом. Более надежный путь выглядит так:
264 Глава 7 • Доступ к файлам
if ($] < 5.004) { # Проверить версию Perlmy $old_fh = select(FH);
local $|=1; # Разрешить буферизацию команд
local $\ = ''; # Очистить разделитель выходных записей
print ""; 8 Вызвать очистку буфера
select($old_fh); # Восстановить предыдущий манипулятор
}
flock(FH, LOCKJJN);
До появления Perl версии 5.004 очистку буфера приходилось выполнять принудительно. Программисты часто забывали об этом, поэтому в 5.004 снятие блокировки изменилось так, чтобы несохраненные буферы очищались непосредственно перед снятием блокировки.
А вот как увеличить число в файле с применением flock:
use Fcntl qw(:DEFAULT .-flock);
sysopen(FH, "numfile", O_RDWR|O_CREAT)
or die "can't open numfile: $!";
flock(FH, LOCK.EX) or die "can't write-lock numfile: $!";
# Блокировка получена, можно выполнять ввод/вывод
$num = <FH> || 0; # HE ИСПОЛЬЗУЙТЕ "or" !!
seek(FH, 0, 0) or die "can't rewind numfile : $'";
truncate(FH, 0) or die "can't truncate numfile: $!";
print FH $num+1, "\n" or die "can't write numfile: $!";
close(FH) or die "can't close numfile: $!";
Закрытие файлового манипулятора приводит к очистке буферов и снятию блокировки с файла. Функция truncate описана в главе 8.
С блокировкой файлов дело обстоит сложнее, чем можно подумать — и чем нам хотелось бы. Блокировка имеет условный характер, поэтому если один процесс использует ее, а другой — нет, все идет прахом. Никогда не используйте факт существования файла в качестве признака блокировки, поскольку между проверкой существования и созданием файла может произойти вмешательство извне. Более того, блокировка файлов подразумевает концепцию состояния и потому не соответствует моделям некоторых сетевых файловых систем — например, NFS. Хотя некоторые разработчики утверждают, что fcntl решает эти проблемы, практический опыт говорит об обратном.
В блокировках NFS участвует как сервер, так и клиент. Соответственно, нам не известен общий механизм, гарантирующий надежную блокировку в NFS. Это возможно в том случае, если некоторые операции заведомо имеют атомарный характер в реализации сервера или клиента. Это возможно, если и сервер, и клиент поддерживают flock или fcntl; большинство не поддерживает. На практике вам не удастся написать код, работающий в любой системе.
Не путайте функцию Perl flock с функцией SysV lockf. В отличие от lockf flock блокирует сразу весь файл. Perl не обладает непосредственной поддержкой lockf. Чтобы заблокировать часть файла, необходимо использовать функцию fcntl (см. программу lockarea в конце главы).
> Смотри также---------------------------------------------------------------------------------------------
Описание функций flock и fcntl в perlfunc(l); документация по стандартным модулям Fcntl и DB_File; рецепт 7.21—7.22.
7.12. Очистка буфера
Проблема
Операция вывода через файловый манипулятор выполняется не сразу. Из-за этого могут возникнуть проблемы в сценариях CGI на некоторых Web-серверах, враждебных по отношению к программисту. Если Web-сервер получит предупреждение от Perl до того, как увидит (буферизованный) вывод вашего сценария, он передает броузеру малосодержательное сообщение 500 Server Error. Проблемы буферизации возникают при одновременном доступе к файлам со стороны нескольких программ и при взаимодействии с устройствами или сокетами.
Решение
Запретите буферизацию, присвоив истинное значение (обычно 1) переменной $ | на уровне файлового манипулятора:
$old_fh = select(OUTPUT_HANDLE);
$1 = 1;
select($old_fh);
Или, если вас не пугают последствия, вообще запретите буферизацию вызовом метода autof lush из модулей 10:
use 10':Handle; OUTPUT_HANDLE->autoflush( 1);
Комментарий
В большинстве реализаций stdio буферизация определяется типом выходного устройства. Для дисковых файлов применяется блочная буферизация с размером буфера, превышающим 2 Кб. Для каналов (pipes) и сокетов часто применяется буфер размера от 0,5 до 2 Кб. Последовательные устройства, к числу которых относятся терминалы, модемы, мыши и джойстики, обычно буферизуются построчно; stdio передает всю строку лишь при получении перевода строки.
Функция Perl print не поддерживает по-настоящему небуферизованного вывода — физической записи каждого отдельного символа. Вместо этого поддерживается командная буферизация, при которой физическая запись выполняется после каждой отдельной команды вывода. По сравнению с полным отсутствием буферизации обеспечивается более высокое быстродействие, при этом выходные данные получаются сразу же после вывода.
Для управления буферизацией вывода используется специальная переменная $|. Присваивая ей true, вы тем самым разрешаете командную буферизацию.
Пример 7.6. seeme
#!/usr/bin/perl -w
# seeme - буферизация вывода в stdio
$| = (@ARGV > 0); # Командная буферизация при наличии аргументов
print "Now you don't see it...";
sleep 2;
print "now you do\n";
Если программа запускается без аргументов, STDOUT не использует командную буферизацию. Терминал (консоль, окно, сеанс telnet и т. д.) получит вывод лишь после завершения всей строки, поэтому вы ничего не увидите в течение 2 секунд, после чего будет выведена полная строка "Now you don't see it... now you do".
В сомнительном стремлении к компактности кода программисты включают возвращаемое значение select (файловый манипулятор, который был выбран в настоящий момент) в другой вызов select:
select((select(OUTPUT_HANDLE), $| = 1)[0]);
Существует и другой выход. Модули FileHandle и 10 содержат метод autof lush. Его вызов с аргументом true или false (по умолчанию используется true) управляет автоматической очисткой буфера для конкретного выходного манипулятора:
use FileHandle;
STDERR->autoflush; # Уже небуферизован в stdio $filehandle->autoflush(0);
Если вас не пугают странности косвенной записи (см. главу 13 «Классы, объекты и связи»), можно написать нечто похожее на обычный английский текст:
use 10: -.Handle;
# REMOTE_CONN - манипулятор интерактивного сокета,
# a DISK_F1LE - манипулятор обычного файла.
autoflush REMOTE_CONN 1; # Отказаться от буферизации для ясности autoflush DISK_FIIE 0; # Буферизовать для повышения быстродействия
Мы избегаем жутких конструкций select, и программа становится более понятной. К сожалению, при этом увеличивается время компиляции, поскольку включение модуля IO::Handle требует чтения и компиляции тысяч строк кода. Научитесь напрямую работать с $ |, этого будет вполне достаточно.
Чтобы выходные данные оказались в нужном месте в нужное время, необходимо позаботиться о своевременной очистке буфера. Это особенно важно для соке-тов, каналов и устройств, поскольку они нередко участвуют в интерактивном вводе/выводе, а также из-за того, что вы не сможете полагаться на построчную буферизацию. Рассмотрим программу из примера 7.7.
7.13. Асинхронное чтение из нескольких манипуляторов 267 Пример 7.7. getcomidx
#!/usr/bin/perl# getpcomidx - получить документ index.html с www.perl.com
use 10::Socket;
$sock = new 10::Socket::INET (PeerAddr => 'www.perl.com',
PeerPort => 'http(80)'); die "Couldn't create socket: $@" unless $sock;
# библиотека не поддерживает $!; в ней используется $@
$sock->autoflush(1);
# На Mac \n\n «обязательно» заменяется последовательностью \015\012\015\012.
# Спецификация рекомендует это и для других систем,
# однако в реализациях рекомендуется поддерживать и "\cJ\cJ".
# Наш опыт показывает, что именно так и получается.
$sock->print("GET /index.html http/1.1\n\n");
Sdocument = joinC', $sock->getlmes());
print "DOC IS: $document\n";
Ни один из рассмотренных нами типов буферизации не позволяет управлять буферизацией ввода. Для этого обращайтесь к рецептам 15.6 и 15.8.
> Смотри также---------------------------------------------------------------------------------------------
Описание переменной $| вperlvar(l); описание функции select вperlfunc(i); документация по стандартным модулям FileHandle и IO::Handle.
7.13. Асинхронное чтение из нескольких манипуляторов
Проблема
Вы хотите узнавать о наличии данных для чтения, вместо того чтобы приостанавливать процесс в ожидании ввода, как это делает о. Такая возможность пригодится при получении данных от каналов, сокетов, устройств и других программ.
Решение
Если вас не смущают операции с битовыми векторами, представляющими наборы файловых дескрипторов, воспользуйтесь функцией select с нулевым тайм-аутом:
$rin = ";
# Следующая строка повторяется для всех опрашиваемых манипуляторов
vec($rin, fileno(FHI), 1) = 1;
vec($rin, fileno(FH2), 1) = 1;
vec($rin, fileno(FH3), 1) = 1;
# На одном или нескольких манипуляторах имеются входные данные
if (vec($r,fileno(FH1),1)) { tt Сделать что-то с FH1
}
if (vec($r,fileno(FH2),1)) {
# Сделать что-то с FH2
}
if (vec($r,fileno(FH3),1)) {
# Сделать что-то с FH3
Модуль IO::Select позволяет абстрагироваться от операций с битовыми векторами:
use 10.-Select,
Sselect = 10:'Select->new();
# Следующая строка повторяется для всех опрашиваемых манипуляторов
$select->add(*FILEHANDLE);
if (@ready = $select->can_read(O)) {
# Имеются данные на манипуляторах из массива @>ready }
Комментарий
Функция select в действительности объединяет сразу две функции. Вызванная с одним аргументом, она изменяет текущий манипулятор вывода по умолчанию (см. рецепт 7.12). При вызове с четырьмя аргументами она сообщает, какие файловые манипуляторы имеют входные данные или готовы получить вывод. В данном рецепте рассматривается только 4-аргументный вариант select.
Первые три аргумента select представляют собой строки, содержащие битовые векторы. Они определяют состояние файловых дескрипторов, ожидающих ввода, вывода или сообщений об ошибках (например, сведений о выходе данных за пределы диапазона для срочной передачи сокету). Четвертый аргумент определяет тайм-аут — интервал, в течение которого select ожидает изменения состояния. Нулевой тайм-аут означает немедленный опрос. Тайм-аут также равен вещественному числу секунд или undef. В последнем варианте select ждет, пока состояние изменится:
$пп = '' ;
vec($nn, fileno(FILEHANDLE), 1) = 1;
Snfound = select($rin, undef, undef, 0); # Обычная проверка
if (Snfound) {
Sline = <FILEHANOLE>;
print "I read Sline"; }
Однако такое решение не идеально. Если среди передаваемых символов не встретится символ перевода строки, программа переходит в ожидание в <FILEHANDLE>.
Чтобы справиться с этой проблемой, мы последовательно читаем по одному символу и обрабатываем готовую строку при получении "\п". При этом отпадает необходимость в синхронном вызове <FILEHANDLE>. Другое решение (без проверки файлов) описано в рецепте 7.15.
Модуль IO::Select скрывает от вас операции с битовыми векторами. Метод 10: :Select->new() возвращает новый объект, для которого можно вызвать метод add, чтобы дополнить набор новыми файловыми манипуляторами. После включениях всех интересующих вас манипуляторов вызываются функции can_read, can_write и can_exception. Функции возвращают список манипуляторов, ожидающих чтения, записи или непрочитанных срочных данных (например, информации о нарушении диапазона TCP).
Вызовы 4- аргументной версии select не должны чередоваться с вызовами каких-либо функций буферизованного вывода, перечисленных во введении (read, о, seek, tell и т. д.). Вместо этого следует использовать sysread — вместе с sysseek, если вы хотите изменить позицию внутри файла для данного манипулятора.
Чтение данных из сокета или канала с немедленным продолжением работы описано в рецепте 17.13. Асинхронному чтению с терминала посвящены рецепты 15.6 и 15.8.
t> Смотри также--------------------------------------------------------------------------------------------
Описание функции select вperlfunc(l); документация по стандартному модулю IO::Select; рецепт 7.14.
7.14. Асинхронный ввод/вывод
Проблема
Требуется прочитать или записать данные через файловый манипулятор так, чтобы система не приостанавливала процесс до наступления готовности программы, файла, сокета или устройства на другом конце. Такая задача чаще возникает для специальных, нежели для обычных файлов.
Решение
Откройте файл функцией sysopen с параметром 0_NOCBLOCK: use Fcntl;
sysopen(MODEM, "/dev/cuaO", 0_N0NBLOCK|O_RDWR) or die "Can't open modem: $!\n";
Если у вас уже есть файловый манипулятор, измените флаги с помощью функции fcntl:
use Fcntl;
$flags = " ;
fcntl(HANDLE, F_GETFL, $flags)
or die "Couldn't get flags for HANDLE : $!\n";
or die "Couldn't set flags for HANDLE: $!\n";
После того как файловый манипулятор будет открыт для асинхронного ввода/вывода, измените флаги с помощью функции fcntl:
use POSIX qw(:errno_h);
$rv = syswrite(HANDLE, $buffer, length Sbuffer); if (!defined($rv) && $! == EAGAIM) {
# Ожидание
} elsif ($rv != length Sbuffer) {
U Незавершенная запись } else {
# Успешная запись
$rv = sysread(HANDLE, Sbuffer, $BUFSIZ);
or die "sysread: $!"; if (!defined($rv) 8.8, $! == EAGAIN) {
# Ожидание
} else {
# Успешно прочитано $rv байт из HANDLE
Комментарий
Константа O_NONBLOCK входит в стандарт POSIX и потому поддерживается большинством компьютеров. Мы используем модуль POSIX для получения числового значения ошибки EAGAIN.
> Смотри также------------------------------------------------------------------------
Описание функций sysopen и fcntl вperlfunc(l); документация по стандартному модулю POSIX; страницы руководства ореп(2) и/ся£/(2); рецепты 7.13 и 7.15.
7.15. Определение количества читаемых байтов
Проблема
Требуется узнать, сколько байтов может быть прочитано через файловый манипулятор функцией read или sysread.
Решение
Воспользуйтесь функцией ioctl в режиме FIONREAD:
$size = pack("L", 0);
ioctl(FH, $FIONREAD, $size) or die "Couldn't call ioctl: $!\n";
7.15. Определение количества читаемых байтов 271
$size = unpaokC'L", $size);
# Могут быть прочитаны $size байт
Комментарий
Функция Perl ioctl предоставляет прямой интерфейс к системной функции ioctl(2). Если ваш компьютер не поддерживает запросы FIONREAD при вызове ioctl(2), вам не удастся использовать этот рецепт. FIONREAD и другие запросы ioctl(2) соответствуют числовым значениям, которые обычно хранятся в заголовочных файлах С.
Вам может понадобиться утилита Perl h2ph, преобразующая заголовочные файлы С в код Perl. FIONREAD в конечном счете определяется как функция в файле sys/ioctl.ph:
require 'sys/ioctl.ph1;
$size = pack("L", 0);
ioctl(FH, FIONREADO, $size) or die "Couldn't call ioctl: $!\n";
$size = unpack("L", $size);
Если утилита h2ph не установлена или не подходит вам, найдите нужное место в заголовочном файле с помощью grep:
%grep FIONREAD /usr/include/*/*
/usr/include/asm/ioctls.h:«define FIONREAD 0x541B
Также можно написать небольшую программу на С в «редакторе настоящего программиста»:
% cat > fionread.c «include <sys/ioctl.h> main() {
pnntf("%#08x\n", FIONREAD); >
"D
% cc -o fionread fionread % ./fionread 0x4004667f
Затем жестко закодируйте полученное значение в программе. С переносимостью пускай возится ваш преемник:
SFIONREAD = 0x4004667f; # XXX: зависит от операционной системы
$size = pack("L", 0);
ioctl(FH, SFIONREAD, $size) or die "Couldn't call ioctl: $!\n";
$size = unpack("L", $size);
FIONREAD требует, чтобы файловый манипулятор был подключен к потоку. Следовательно, сокеты, каналы и терминальные устройства будут работать, а файлы — нет.
Если вам это покажется чем-то вроде системного программирования, взгляните на проблему под другим углом. Выполните асинхронное чтение данных из ма-
> Смотри также---------------------------------------------------------------------------------------------
Рецепт 7.14; страница руководства ioctl(2) вашей системы; описание функции ioctl вperlfunc(l).
7.16. Хранение файловых манипуляторов в переменных
Проблема
Вы собираетесь использовать файловый манипулятор как обычную переменную, чтобы его можно было передать или вернуть из функции, сохранить в структуре данных и т. д.
Решение
Если у вас уже имеется символьный файловый манипулятор (например, STDIN или LOGFILE), воспользуйтесь записью тип-глоба, «FH. Такой подход является самым эффективным.
Svanable = «FILEHANDLE, it Сохранить в переменной
subroutine(*FILEHANDLE); tt или передать функции
sub subroutine {
my $fh = shift;
print $fh "Hello, filehandle'\n"; >
Если вы хотите работать с анонимным файловым манипулятором, воспользуйтесь функцией return_fh (см. ниже) или новыми методами модулей IO::File или IO::Handle, сохраните его в скалярной переменной и используйте так, словно это обычный файловый манипулятор:
use FileHandle; # Анонимные манипуляторы
$fh = FileHandle->new();
use 10::File; » 5.004 и выше
$fh = I0::File->new();
Комментарий
Существует немало способов передать файловый манипулятор функции или сохранить его в структуре данных. Самое простое и быстрое решение заключается в применении тип-глоба, *FH. Рассматривайте запись *FH как обозначение типа файлового манипулятора, подобно тому, как представляли молекулы на уроках химии в виде цветных шариков — не совсем точно, зато удобно.
Когда вы начнете понимать недостатки этой модели, она вам уже не понадобится.
Конечно, в простых ситуациях этого вполне достаточно, но что если вам потребовался массив файловых манипуляторов с неизвестными именами? Как показано в главе 11 «Ссылки и записи», построение анонимных массивов, хэшей и даже функций во время выполнения программы оказывается исключительно удобным приемом. Нам хотелось бы иметь аналогичную возможность и для файловых манипуляторов. На помощь приходят модули 10.
Метод new модуля IO::Handle или IO::File генерирует анонимный файловый манипулятор. Его можно передать функции, сохранить в массиве и вообще применять везде, где используются именованные тип-глобы файловых манипуляторов — и не только. Эти модули также могут использоваться в иерархии наследования, поскольку конструктор new возвращает полноценные объекты, для которых могут вызываться методы.
Объекты могут косвенно использоваться в качестве файловых манипуляторов, что избавляет вас от необходимости придумывать для них имена.
Чтобы получить тип-глоб из именованного файлового манипулятора, снабдите его префиксом *:
$fh_a = 10::File->new("< /etc/motd") or die "open /etc/motd: $!"; $fh_b = «STDIN, some_sub($fh_a, $fh_b);
Существуют и другие способы, но этот проще и удобнее всех остальных. Единственное ограничение — в том, что его нельзя превратить в объект вызовом bless. Bless вызывается для ссылки на тип-глоб — именно это и происходит в IOr.Handle. Ссылки на тип-глоб, как и сами тип-глобы, можно косвенно использовать в качестве файловых манипуляторов, с приведением посредством bless или без него.
Создание и возврат нового файлового манипулятора из функции происходит следующим образом:
sub return_fh { и Создание анонимных файловых манипуляторов
local »FH; tt Должны быть local, не my
# now open it if you want to, then...
return *FH;
$handle = return_fh();
Функция, получающая файловый манипулятор в качестве аргумента, может либо сохранить его в переменной (желательно лексической) и затем косвенно использовать его:
sub accept_fh <
my $fh = shift;
print $fh "Sending to indirect filehandle\n"; }
либо локализовать тип-глоб и использовать файловый манипулятор напрямую:
local »FH = shift,
print FH Sending to localized filehandle\n }
Оба варианта работают как с объектами IO:-Handle, так и с тип-глобами и настоящими файловыми манипуляторами
accept_fh(*STDOUT) accept_fh($handle)
Perl позволяет использовать строки, тип-глобы и ссылки на тип-глобы в качестве косвенных файловых манипуляторов, но без передачи тип-глобов или объектов 10 Handle можно нарваться на неприятности Применение строк ( L06FILE вместо *LOGFILE) между пакетами потребует специальных усилий, а функции не могут возвращать ссылки на тип-глобы
В предыдущих примерах файловый манипулятор перед использованием присваивался скалярной переменной Дело в том, что во встроенных функциях (print или pnntf) или в операторе о могут использоваться только простые скалярные переменные, но не выражения или элементы хэшей и массивов Следующие строки даже не пройдут компиляцию
@fd = («STDIN -STDOUT *STDERR)
print $fd[1] Type it U НЕВЕРНО
$got = <$fd[O]> # НЕВЕРНО
print $fd[2] What was that $got # НЕВЕРНО
BprintHprintf это ограничение удается обойти — воспользуйтесь блоком и выражением, в котором находится файловый манипулятор
print { $fd[1] } funny stuff\n
pnntf { $fd[1] } Pity the poor %x \n 3_735_928_559
Pity the poor deadbeef
Внутри блока может находиться и более сложный код Следующий фрагмент отправляет сообщение в один из двух адресов
|
$ок = |
-x /bin/cat |
|||||
|
print |
{ $ok ' |
> $fd[1] |
$fd[2] } |
cat |
stat |
$ok\n |
|
print |
{ $fd[ |
1 + ($ok |
II 0) ] |
} cat |
stat |
$ok\n |
$got = readlme($fd[0])
> Смотри также---------------------------------------------------------------------------------------------
Рецепт 7 1, документация по стандартному модулю FileHandle, описание функции open в perlfunc(i)
7.17. Кэширование открытых файловых манипуляторов
Проблема
Требуется одновременно открыть больше файлов, чем позволяет ваша система.
Решение
Воспользуйтесь стандартным модулем FileCache:
use FileCache
cacheout ($path) # При каждом применении манипулятора
print $path output ,
Комментарий
Функция cacheout модуля FileCache позволяет одновременно открывать больше файлов, чем позволяет операционная система Если воспользоваться ей для открытия существующего файла, который FileCache видит впервые, этот файл без лишних вопросов усекается до нулевой длины Однако во время фонового открытия и закрытия файлов cacheout следит за открывавшимися ранее файлами и не стирает их, а присоединяет к ним данные Она не умеет создавать каталоги, поэтому, если попытаться открыть файл /usr/local/dates/menno ewe в несуществующем каталоге/usr/local/dates, из cacheout будет вызвана die
Функция cacheout () проверяет значение константы NOFILE уровня С из стандартного заголовочного файла sys/params h, чтобы определить, сколько файлов разрешается открывать одновременно. В некоторых системах это значение может быть неверным или вовсе отсутствовать (например, там, где максимальное количество дескрипторов является лимитом ресурса процесса и устанавливается командой limit или ulimit). Если cacheout() не может получить значение NOFILE, достаточно присвоить $FileCache maxopen значение, на 4 меньше правильного, или подобрать разумное число методом проб и ошибок.
В примере 7. 8 файл xferlog, создаваемый популярным FTP-сервером wuftpd, разбивается на файлы, имена которых соответствуют именам пользователей. Поля файла xferlog разделяются пробелами; имя пользователя хранится в четвертом поле с конца.
Пример 7.8. splitwulog
ff'/usr/bm/perl
# splitwulog - разделение журнала wuftpd по именам пользователей
use FileCache,
Soutdir = /var/log/ftp/by-user ,
while (о) <
unless (defined ($user = (split)[-4])) { warn Invalid line $ \n , next,
продолжение &
ir« глава 7 • Доступ к файлам Пример 7.8 (продолжение)
$path = "$outdir/$user"; cacheout $path; print $path $_;> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю FileCache; описание функции open в perlfunc(l).
7.18. Одновременный вывод через несколько файловых манипуляторов
Проблема
Одни и те же данные требуется вывести через несколько разных файловых манипуляторов.
Решение
Если вы предпочитаете обходиться без создания новых процессов, напишите цикл f о reach для перебора файловых манипуляторов:
foreach $filehandle (@FILEHANDLES) { print $filehandle $stuff_to_print;
Если новые процессы вас не пугают, откройте файловый манипулятор, связав его с программой tee:
open(MANY, "| tee filei file2 file3 > /dev/null") or die $!
print MANY "data\n" or die $!
close(MANY) or die $!
Комментарий
Файловый манипулятор передает выходные данные лишь одному файлу или программе. Чтобы дублировать вывод, следует многократно вызвать print или связать манипулятор с программой распределения выходных данных (например, tee). В первом варианте проще всего занести файловые манипуляторы в список или массив и организовать их перебор:
# 'use strict' пожалуется на эту команду:
for $fh ('FH1', 'FH2', 'FH3') { print $fh "whatever\n'- }
# но не возразит против этой:
for $fh (*FH1, *FH2, *FH3) { print $fh "whatever\n" }
Но если ваша система включает программу tee или вы установили Perl-версию tee из рецепта 8.19, можно открыть канал к tee и поручить ей всю работу по копированию файла в несколько приемников. Не забывайте, что tee обычно ко-
пирует выходные данные в STDOUT; если лишняя копия данных вам не нужна, перенаправьте стандартный вывод tee в /dev/null:
open (FH, "| tee filei file2 file3 >/dev/null"); print FH "whatever\n";
Вы даже можете перенаправить процессу tee свой собственный STDOUT и использовать при выводе обычную функцию print:
# Продублировать STDOUT в трех файлах с сохранением исходного STDOUT
open (STDOUT, "| tee filei file2 file3") or die "Teeing off: $!\n";
print "whatever\n" or die "Writing: $!\n";
close(STDOUT) or die "Closing: $!\n";
> Смотри также---------------------------------------------------------------------------------------------
Описание функции print вperlfunc(l). Аналогичная методика используется в рецептах 8.19 и 13.15.
7.19. Открытие и закрытие числовых файловых дескрипторов
Проблема
Вам известны файловые дескрипторы, через которые должен выполняться ввод/вывод, но Perl вместо числовых дескрипторов требует манипуляторы.
Решение
Для открытия файлового дескриптора воспользуйтесь режимами "<&=" и "<&" или методом fdopen модуля IO::Handle:
open(FH, "<&=$FDNUM"); # FH открывается для дескриптора
open(FH, "<&$FDNUM"); и FH открывается для копии дескриптора
use 10::Handle;
$fh->fdopen($FDNUM, "r"); # Открыть дескриптор 3 для чтения
Чтобы закрыть дескриптор, воспользуйтесь функцией POSIX:: close или откройте его описанным выше способом.
Комментарий
Иногда вам известен файловой дескриптор, а не манипулятор. В системе ввода/ вывода Perl вместо дескрипторов используются манипуляторы, поэтому для уже открытого файлового дескриптора придется создать новый манипулятор. Режимы open "<&", ">&" и "+<&" решают эту задачу соответственно для чтения, записи и обновления. Режимы со знаком равенства ("<&=", ">&=" и "+<&=") работают с дескрипторами более экономно, при этом почти всегда делается именно то,
Если у вас установлена версия Perl 5.004 и выше, воспользуйтесь методом объекта IO::Handle:
use 10::Handle;
$fh = 10::Handle->new();
$fh->fdopen(3, "r"); # Открыть fd 3 для чтения
Закрытие числовых файловых дескрипторов встречается еще реже. Задача напрямую решается функцией POSIX::close. Если в вашей системе нет библиотеки POSIX, но зато имеется работающая функция syscall (и ваш системный администратор установил файл sys/syscall.ph, созданный транслятором h2ph), можно воспользоваться функцией syscall, хотя переносимость в этом случае оставляет желать лучшего. Вам придется добавлять 0 к числам и присоединять "" к строкам, чтобы обеспечить правильность типов С; кроме того, код ошибки равен -1, а не false, как в других функциях Perl. He стоит и говорить, что syscall применяется лишь в крайнем случае.
Ниже показано, как открыть файловые дескрипторы, которые почтовая система МН передает своим дочерним процессам. Дескрипторы идентифицируются по переменной окружения MHCONTEXTFD:
$fd = $ENV{MHCONTEXTFD};
open(MHCONTEXT, "<&=$fd") or die "couldn't fdopen $fd: $!";
# after processing
close(MHCONTEXT) or die "couldn't close context file: $!";
Чтобы закрыть дескриптор по числовому значению, достаточно сначала вызвать для него open.
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартным модулям POSIX и IO::Handle; страница руководства fdopen(3) вашей системы; описание функции open вperlfunc(l).
7.20. Копирование файловых манипуляторов
Проблема
Требуется создать копию файлового манипулятора.
Решение
Синоним файлового манипулятора создается следующей командой:
-СИНОНИМ = «ОРИГИНАЛ;
Чтобы создать независимую копию файлового дескриптора для существующего манипулятора, воспользуйтесь функцией open в режиме &:
7.20. Копирование файловых манипуляторов 279
open(OUTCOPY, ">&STDOUT") or die "Couldn't dup STDOUT: $!"; open(INCOPY, "<&STDIN" ) or die "Couldn't dup STDIN : $!";
Чтобы создать синоним файлового дескриптора для существующего манипулятора, воспользуйтесь функцией open в режиме &=:
open(OUTALIAS, ">&=STDOUT") or die "Couldn't alias STDOUT: $!"; open(INALIAS, "<&=STDIN") or die "Couldn't alias STDIN : $!"; open(BYNUMBER, ">&=5") or die "Couldn't alias file descriptor 5: $!";
Комментарий
Если синоним манипулятора создан с помощью тип-глоба, программа по-прежнему работает лишь с одним объектом ввода/вывода Perl. При закрытии манипулятора-синонима закрывается и объект ввода/вывода. Все последующие попытки использования копий этого манипулятора лишь приводят к выдаче сообщений типа "print on closed filehandle". Чередование записи через разные синонимы не вызывает проблем, поскольку при этом не создаются дублирующиеся структуры данных, способные вызвать десинхронизацию.
При копировании дескриптора командой open (КОПИЯ, ">&МАНИПУЛЯТОР") вызывается системная функция dup(2). Вы получаете два независимых дескриптора с общей текущей позицией, блокировкой и флагами, но разными буферами ввода/вывода. Закрытие одного дескриптора не отражается на его копии. Одновременная работа с файлом через оба дескриптора — верный путь к катастрофе. Обычно этот прием используется для сохранения и восстановления STDOUT и STDERR:
# Получить копии дескрипторов
open(OLDOUT, ">&STDOUT");
open(OLDERR, ">&STDERR");
# Перенаправить stdout и stderr
open(STDOUT, "> /tmp/program.out") or die "Can't redirect stdout: $!";
open(STOERR, ">&STDOUT") or die "Can't dup stdout: $!";
й Запустить программу system($j oe_random_p rog ram);
# Закрыть измененные манипуляторы
close(STDOUT) or die "Can't close STDOUT: $!";
close(STDERR) or die "Can't close STDERR: $!";
# Восстановить stdout и stderr
open(STDERR, ">&OLDERR") or die "Can't restore stderr: $!"; open(STDOUT, ">&OLDOUT") or die "Can't restore stdout: $!";
# Для надежности закрыть независимые копии
close(OLDOUT) or die "Can't close OLDOUT: $!";
close(OLDERR) or die "Can't close OLDERR: $.'";
Если синоним дескриптора создается командой ореп(СИНОНИМ, "^МАНИПУЛЯТОР"), в действительности вызывается системная функция ввода/вывода fdopen(3).
> Смотри также---------------------------------------------------------------------------------------------
Страница руководства dup(2) вашей системы; описание функции open в perl-/ияс(1).
7.21. Программа: netlock
При блокировке файлов мы рекомендуем по возможности использовать функцию flock. К сожалению, в некоторых системах блокировка через flock ненадежна. Допустим, функция flock может быть настроена на вариант блокировки без поддержки сети или вы работаете в одной из редких систем, в которой вообще не существует эмуляции flock.
Приведенная ниже программа и модуль содержат базовую реализацию механизма блокировки файлов. В отличие от обычной функции flock, данный модуль блокирует файлы по именам, а не по дескрипторам.
Следовательно, он может применяться для блокировки каталогов, сокетов и других нестандартных файлов. Более того, вы даже сможете блокировать несуществующие файлы. При этом используется каталог, созданный в иерархии на одном уровне с блокируемым файлом, поэтому вы должны иметь право записи в каталог, содержащий его. Файл в каталоге блокировки содержит сведения о владельце блокировки. Это пригодится в рецепте 7.8, поскольку блокировка сохраняется, несмотря на изменение файла, которому принадлежит данное имя.
Функция nf lock вызывается с одним или двумя аргументами. Первый определяет имя блокируемого файла; второй, необязательный — промежуток времени, в течение которого происходит ожидание. Функция возвращает true при успешном предоставлении блокировки и false при истечении времени ожидания. При возникновении различных маловероятных событий (например, при невозможности записи в каталог) инициируется исключение.
Присвойте true переменной $File:; LockOir:: Debug, чтобы модуль выдавал сообщения при неудачном ожидании. Если вы забудете снять блокировку, при выходе из программы модуль снимет ее за вас. Этого не произойдет, если ваша программа получит неперехваченный сигнал.
Вспомогательная программа из примера 7.9 демонстрирует применение модуля File::LockDir.
Пример 7.9. drivelock
#!/usr/bm/perl -w
# drivelock - демонстрация модуля File:.LockDir
use strict;
use File::LockDir;
$SIG{INT} = sub { die "outta here\n" };
$File::LockDir::Debug = 1;
my $path = shift or die "usage: $0 <path>\n";
unless (nflock($path, 2)) {
die "couldn't lock $path in 2 seconds\n"; >
sleep 100; nunflock($path);
Исходный текст модуля приведен в примере 7.10. За дополнительными сведениями о построении модулей обращайтесь к главе 12 «Пакеты, библиотеки и модули».
Пример 7.10. File::LockDir
package File::LockOir;
# Модуль, обеспечивающий простейшую блокировку
# на уровне имен файлов без применения хитрых системных функций.
# Теоретически информация о каталогах синхронизируется в NFS.
# Стрессовое тестирование не проводилось.
use strict;
use Exporter;
use vars qw(@ISA ©EXPORT); @ISA = qw(Exporter); ©EXPORT = qw(nflock nunflock);
use vars qw($Debug $Check);
$Debug ||= 0; # Может определяться заранее
$Check ||= 5; # Может определяться заранее
use Cwd;
use Fcntl;
use Sys::Hostname;
use File.:Basename;
use File::stat;
use Carp;
my %Locked_Files = ();
# Применение: пИоск(ФАЙЛ; ТАЙМАУТ)
sub nflock($;$) {
my $pathname = shift;
my $naptirae = shift 11 0;
my $lockname = name21ock($pathname);
my $whosegot = "$lockname/owner";
my $start = time();
продолжение &
282 Глава 7 • Доступ к файлам Пример 7.10 (продолжение)
my Smissed = 0; local «OWNER;# Если блокировка уже установлена, вернуться if ($Locked_Files{$pathname}) {
carp "$pathname already locked";
return 1
if (!-w dirname($pathname)) {
croak "can't write to directory of $pathname";
while (1) {
last if mkdir($lockname, 0777);
confess "can't get Slockname: $!" if $missed++ > 10
&& '-d Slockname; if (SDebug) {<
open(0WNER, "< $whosegot") || last; # exit "if"!
my Slockee = <OWNER>;
chomp($lockee);
printf STDERR "%s $0\[$$]: lock on %s held by %s\n",
scalar(localtime), Spathname, Slockee; close OWNER; И
sleep $Check;
return if $naptime && time > $start+$naptime; } sysopen(OWNER, Swhosegot, O_WRONLY|O_CREAT|O_EXCL)
or croak "can't create Swhosegot: S1' printf OWNER "$0\[$$] on %s since %s\n",
hostname(), scalar(localtime); close(OWNER)
or croak "close Swhosegot: $!"; $Locked_Files{$pathname}++; return 1;
# Освободить заблокированный файл sub nunflock(S) {
my Spathname = shift;
my Slockname = name21ock($pathname);
my Swhosegot = "Slockname/owner";
unlink(Swhosegot);
carp " releasing lock on Slockname" if SDebug;
delete $Locked_Files<Spathname};
return rmdir(Slockname);
# Вспомогательная функция
Функция Perl flock блокирует только целые файлы, но не отдельные их области. Хотя fcntl поддерживает частичную блокировку файлов, из Perl с ней работать трудно — в основном из-за отсутствия модуля XS, который бы обеспечивал переносимую упаковку необходимой структуры данных. Программа из примера 7.11 реализует fcntl, но лишь для трех конкретных архитектур: SunOS, BSD и Linux. Если вы работаете в другой системе, придется узнать формат структуры flock. Для этого мы просмотрели заголовочный файл С sys/ fcntl.h и запустили программу c2ph, чтобы получить информацию о выравнивании и типах. Эта программа, распространяемая с Perl, работает только в системах с сильным влиянием Беркли (как те, что перечислены выше). Вы не обязаны использовать c2ph, но эта программа несомненно облегчит ваше существование. Функция struct_flock в программе lockarea выполняет упаковку и распаковку структуры, руководствуясь переменной $"0 с именем операционной системы. Объявления функции struct_flock не существует, мы просто создаем синоним для версии, относящейся к конкретной архитектуре. Синонимы функции рассматриваются в рецепте 10.14. Программа lockarea открывает временный файл, уничтожая его текущее содержимое, и записывает в него полный экран (80x23) пробелов. Все строки имеют одинаковую длину. Затем программа создает производные процессы и предоставляет им возможность одновременного обновления файла. Первый аргумент, N, определяет количество порождаемых процессов (2**N). Следовательно, lockarea 1 порождает два процесса, lockarea 2 — четыре, lockarea 3 — восемь, lockarea 4 — шестнадцать |
sub name21ock($) {
my $pathname = shift;
my $dir = dirname($pathname);
my $file = basename(Spathname);
$dir = getcwd() if $dir eq ".';
my $lockname = "$dir/$file.LOCKDIR";
return $lockname;
№ Ничего не забыли' END {
for my $pathname (keys %Locked_Files) {
my $lockname = name21ock($pathname);
my $whosegot = "$lockname/owner";
carp "releasing forgotten Slockname",
unlink($whosegot);
return rmdir($lockname);
7.22. Программа: lockarea
7.22. Программа: lockarea 283
Каждый процесс выбирает из файла случайную строку, блокирует и обновляет ее. Он записывает в строку свой идентификатор процесса с префиксом — количеством обновлений данной строки:
4: 18584 was just here
Если в момент запроса блокировки строка уже была заблокирована, то после предоставления блокировки в сообщение включается идентификатор предыдущего процесса:
29: 24652 ZAPPED 24656
Попробуйте запустить программу lockarea в фоновом режиме и отображайте изменения файла с помощью программы гер из главы 15. Получается видеоигра для системных программистов.
%lockarea 5 &
% гер -1 'cat /tmp/lkscreen'
Если работа основной программы прерывается клавишами Ctrl+C или сигналом SIGINT из командной строки, она уничтожает всех своих потомков, посылая сигнал всей группе процессов.
Пример 7.11. lockarea
#!/usr/bin/perl -w
# lockarea - частичная блокировка с использованием fcntl
use strict;
my $FORKS = shift || 1; my $SLEEP = shift || 1;
use Fcntl;
use POSIX qw(:unistd_h :errno_h);
my $COLS = 80; my $ROWS = 23;
# Когда вы в последний раз видели «этот* режим правильно работающим?
open(FH, "+> /tmp/lkscreen") or die $!;
select(FH);
$l = 1; select STDOUT;
# Очистить экран
for (1 .. $ROWS) {
print FH " " x $COLS, 1-\n";
7.22. Программа: lockarea 285
my $progenitor = $$; fork while SFORKS-- > 0;
print "hello from $$\n";
if ($progenitor == $$) {
$SIG{INT> = \&genocide; } else {
$SIG{INT} = sub { die "goodbye from $$" };
while (1) {
my $line_num = mt rand($R0WS); my $line; my $n;
# Перейти к строке
seek(FH, $n = $line_num • ($C0LS+1), SEEK_SET) or next;
# Получить блокировку
my $place = tell(FH);
my $him;
next unless defined($him = lock(*FH, $place, $COLS));
# Прочитать строку :
,
read(FH, $line, $COLS) == $COLS or next;
my $count = ($line =' /(\d+)/) ? $1 : 0; $count++;
# Обновить строку
seek(FH, $place, 0) or die $!;
my $update = sprintf($him
? "%6d: %d ZAPPED %d" : "%6d: %d was just here", $count, $$, $him);
my $start = int(rand($COLS - length($update))); die "XXX" if $start + length($update) > $COLS; printf FH "%*.*s\n", -$COLS, $COLS, " " x $start . $update;
# Снять блокировку и сделать паузу
unlock(*FH, $place, $COLS);
sleep $SLEEP if $SLEEP;
}
die "NOT REACHED"; # На всякий случай
# lock($handle, $offset, $timeout) - get an fcntl lock sub lock {
my ($fh, $start, Still) = @_;
##print "$$: Locking $start, $till\n";
продолжение
286 Глава 7 • Доступ к файлам Пример 7.11 (продолжение)
my $lock = struct_flock(F_WRLCK, SEEK_SET, Sstart, Still, 0);my Sblocker = 0;
unless (fcntl($fh, F_SETLK, Slock)) {
die "F_SETLK S$ @_: $!" unless $! == EAGAIN || $! == EDEADLK;
fcntl($fh, F_GETLK, Slock) or die "F_GETLK $$ @_: $!'
Sblocker = (struct_flock($lock))[-1J;
##print "lock $$ @_: waiting for $blocker\n";
Slock = struct_flock(F_WRLCK, SEEK_SET, $start, Still, 0);
unless (fcntl($fh, F_SETLKW, Slock)) { warn "F_SETLKW $$ @_: $!\n"; return; # undef
return Sblocker;
# unlock($handle, Soffset, Stimeout) - снять блокировку fcntl sub unlock {
my ($fh, Sstart, Still) = @_;
##print "$$: Unlocking Sstart, $till\n";
my Slock = struct_flock(F_UNLCK, SEEK_SET, Sstart, Still, 0);
fcntl($fh, F_SETLK, Slock) or die "FJJNLCK $$ @_: $!";
# Структуры flock для разных ОС
# Структура flock для Linux
# short l_type;
# short l_whence;
# off_t l_start;
# off_t l_len;
# pid_t l_pid;
BEGIN {
# По данным c2ph: typedef='s2 12 i', sizeof=16 my $FLOCK_STRUCT = 's s 1 1 Г;
sub linux_flock { if (wantarray) {
my (Stype, Swhence, Sstart, $len, Spid) =
unpack($FLOCK_STRUCT, $_[0]); return (Stype, Swhence, Sstart, Slen, Spid); } else {
my (Stype, Swhence, Sstart, Slen, $pid) = @_ return pack($FLOCK_STRUCT,
Stype, Swhence, Sstart, Slen, Spid);
# Структура flock для SunOS
# short l_type; /• F_RDLCK, F_WRLCK или F_UNLCK ¦/
# short l_whence; /* Флаг выбора начального смещения */
# long l_start; /* Относительное смещение в байтах */
# long l_len; /* Длина в байтах;
О - блокировка до EOF •/
# short l_pid; /* Возвращается F_GETLK */
# short l_xxx; /• Зарезервировано на будущее ¦/
BEGIN {
# По данным c2ph: typedef='s2 12 s2', sizeof=16 my $FLOCK_STRUCT = 'ssllss';
sub sunos_flock { if (wantarray) {
my ($type, Swhence, $start, $len, $pid, $xxx) =
unpack($FLOCK_STRUCT, $_[0]); return ($type, $whence, $start, $len, $pid); } else {
my ($type, $whence, $start, $len, $pid) = @_; return pack($FLOCK_STRUCT,
Stype, Swhence, $start, $len, $pid, 0);
# Структура flock для (Free)BSD:
# off_t l_start; /* Начальное смещение •/
# off_t l_len; /* len = 0 означает блокировку до конца файла */
# pid_t lpid; /¦ Владелец блокировки */
# short l_type; /* Тип блокировки: чтение/запись и т. д. */
# short l_whence, /* Тип l_start */
BEGIN {
# По данным c2ph: typedef="q2 l s2", size=24 my $FLOCK_STRUCT = 'lllliss';
sub bsd_flock {
if (wantarray) {
my (Sxxstart, $start, $xxlen, $len, $pid, $type, Swhence) =
unpack($FLOCK_STRUCT, $_[0]); return ($type, Swhence, Sstart, $len, $pid); } else <
my (Stype, Swhence, $start, $len, $pid) = @_; my (Sxxstart, Sxxlen) = (0,0); return pack($FLOCK_STRUCT,
Sxxstart, Sstart, Sxxlen, $len, Spid, Stype, Swhence);
продолжение
288 Глава 7 • Доступ к файлам Пример 7.11 (продолжение)
# Синоним структуры fcntl на стадии компиляции BEGIN {for ($"0) {
*struct_flock = do
/bsd/ && \&bsd_flock
II /lmux/ && \&linux_flock
II /sunos/ && \&sunos_flock
II die "unknown operating system $"0, bailing out";
# Установить обработчик сигнала для потомков BEGIN {
my $called = 0;
sub genocide {
exit if $called++;
print "$$. Time to die, kiddies.\n" if $$ == Sprogemtor;
my $job = getpgrpO;
$SIG{INT} = 'IGNORE-;
kill -2, $]ob if $]ob; # killpg(SIGINT, job)
1 while wait > 0; '
print "$$¦ My turn\n" if $$ == $progemtor?
exit;
END { Sgenocide }
 |
Содержимое файлов
Из всех решений UNIX самым гениальным был выбор одном символа для перевода строки.
Майк О'Цели, лишь с долей шутки
Введение
До революции UNIX всевозможные источники и приемники данных не имели ничего общего. Чтобы две программы пообщались друг с другом, приходилось идти на невероятные ухищрения и отправлять в мусор целые горы перфокарт. При виде этой компьютерной Вавилонской башни порой хотелось бросить программирование и подыскать себе менее болезненное хобби — например, податься в секту флаггелантов.
В наши дни этот жестокий и нестандартный стиль программирования в основном ушел в прошлое. Современные операционные системы всячески стараются создать иллюзию, будто устройства ввода/вывода, сетевые подключения, управляющие данные процессов, другие программы, системные консоли и даже терминалы пользователей представляют собой абстрактные потоки байтов, именуемые файлами. Теперь можно легко написать программу, которая нисколько не заботится о том, откуда взялись ее входные данные и куда отправятся результаты.
Поскольку чтение и запись данных осуществляется через простые байтовые потоки, любая программа может общаться с любой другой программой. Трудно переоцепить всю элегантность и мощь такого подхода. Пользователи перестают зависеть от сборников магических заклинаний JCL (или СОМ) и могут собирать собственные нестандартные инструменты, используя простейшее перенаправление ввода/вывода и конвейерную обработку.
Интерпретация файлов как неструктурированных байтовых потоков однозначно определяет круг возможных операций. Вы можете читать и записывать последовательные блоки данных фиксированного размера в любом месте файла, увеличивая его размер при достижении конца. Чтение/запись блоков переменной длины (например, строк, абзацев и слов) реализуется в Perl на базе стандартной библиотеки ввода/вывода С.
Самый распространенный тип файлов — текстовые файлы, а самый распространенный тип операций с ними — построчное чтение и запись. Для чтения строк используется оператор о (или его внутренняя реализация, readline), а для записи — функция print. Эти способы также могут применяться для чтения или записи любых блоков с конкретным разделителем. Строка представляет собой запись с разделителем "\п".
При достижении конца файла оператор о возвращает undef или ошибку, поэтому его следует использовать в цикле следующего вида:
while (defined ($lme = <OATAFILE>)) {
chomp $lme;
$size = length $line;
print f$size\n"; it Вывести длину строки
>
Поскольку эта операция встречается довольно часто, в Perl для нее предусмотрена сокращенная запись, при которой строки читаются в $_ вместо $line. Переменная $_ используется по умолчанию и в других строковых операциях и вообще куда удобнее, чем может показаться на первый взгляд:
while (<DATAFILE>) {
chomp;
print length, "\n\ # Вывести длину строки }
В скалярном контексте оператор <> читает следующую строку. В списковом контексте он читает оставшиеся строки:
@lines = <DATAFILE>;
При чтении очередной записи через файловый манипулятор <> увеличивает значение специальной переменной $. (текущий номер входной записи). Переменная сбрасывается лишь при явном вызове close и сохраняет значение при повторном открытии уже открытого манипулятора.
Заслуживает внимания и другая специальная переменная — $/, разделитель входных записей. По умолчанию ей присваивается "\п", маркер конца строки. Ей можно присвоить любое желаемое значение — например, "\0" для чтения записей, разделяемых нуль-байтами. Для чтения целых абзацев следует присвоить $/ пустую строку, "". Это похоже на присваивание "\п\п", поскольку для разделения записей используются пустые строки, однако "" интерпретирует две и более смежных пустых строки как один разделитель, а "\п\п" в таких случаях возвращает пустые записи. Присвойте $/ неопределенное значение, чтобы прочитать остаток файла как одну скалярную величину:
Введение 291
undef $/;
$whole_file = <FILE>; # Режим поглощения
Запуск Perl с флагом -0 позволяет задать $/ из командной строки:
% perl -040 -е 'Sword = <>; print "First word is $word\n"; '
Цифры после -0 определяют восьмеричное значение отдельного символа, который будет присвоен $/. Если задать недопустимое значение (например, -0777), Perl присваивает $/ неопределенное значение undef. Если задать -00, $/ присваивается "". Ограничение в один восьмеричный символ означает, что вы не сможете присвоить $/ многобайтовую строку — например, "%%\п" для чтения файлов программы fortune. Вместо этого следует воспользоваться блоком BEGIN:
% perl -ne 'BEGIN { $/='%%\n" } chomp, print if /Unix/i' fortune.dat
Запись строк и других данных выполняется функцией print. Она записывает свои аргументы в порядке указания и по умолчанию не добавляет к ним разделители строк или записей:
print HANDLE "One", "two", "three', # ' Onetwothree" print "Baa baa black sheep \n , # Передается выходному манипулятору
# по умолчанию
Между манипулятором и выводимыми данными не должно быть запятых. Если поставить запятую, Perl выдает сообщение об ошибке "No comma allowed after filehandle". По умолчанию для вывода используется манипулятор STDOUT. Для выбора другого манипулятора применяется функция select (см. главу 7 «Доступ к файлам»).
Во всех системах строки разделяются виртуальным разделителем "\п", который называется переводом строки (newline). He существует такого понятия, как символ перевода строки. Это всего лишь иллюзия, которая по общему сговору поддерживается операционной системой, драйверами устройств, библиотеками С и Perl. Иногда это приводит к изменению количества символов в прочитанных или записываемых строках. Подробности заговора изложены в рецепте 8.11.
Записи фиксированной длины читаются функцией read. Функция получает три аргумента: файловый манипулятор, скалярную переменную и количество читаемых байт. Возвращается количество прочитанных байт, а в случае ошибки — undef. Для записи используется функция print:
$rv = read(HANDLE, $buffer, 4096)
or die "Couldn't read from HANDLE ' $'\n'; # $rv - количество прочитанных байт, й Sbuffer содержит прочитанные данные
Функция truncate изменяет длину файла, который задается с помощью манипулятора или по имени. Функция возвращает true, если усечение прошло успешно, и false в противном случае:
truncate(HANDLE, Slength) >
or die "Couldn't truncate: $'\n"; truncate("/tmp/$$. pid", Slength)
or die 'Couldn't truncate. $'\n";
$pos = tell(DATAFILE),
print I m $pos bytes from the start of DATAFILE \n ,
Функция seek получает три аргумента файловый манипулятор, новое смещение (в байтах) и число, определяющее интерпретацию смещения. Если оно равно О, смещение отсчитывается от начала файла (в соответствии со значениями, возвращаемыми tell); 1 — от текущей позиции (положительное число означает прямое перемещение в файле, а отрицательное — обратное); 2 — от конца файла.
seek(LOGFILE 0, 2) or die Couldn t seek to the end $'\n , seek(DAtAFILE $pos, 0) or die Couldn t seek to $pos $'\n seek(0Ut, -20, 1) or die Couldn t seek back 20 bytes $'\n ,
Все сказанное выше относится к буферизованному вводу/выводу. Другими словами, операции о, print, read, seek и tell используют буферы для повышения скорости. В Perl также предусмотрены небуферизованные операции ввода/ вывода: sysopen, sysread, syswrite, sysseek и close. Буферизация, sysopen и close рассматриваются в главе 7.
Функции sysread и syswrite отличаются от своих аналогов, о и print. Они получают одинаковые аргументы — файловый манипулятор; скалярную переменную, с которой выполняется чтение или запись; и количество читаемых или записываемых байт. Кроме того, они могут получать необязательный четвертый аргумент — смещение внутри скалярной переменной:
$wntten = syswrite(DATAFILE Smystring length($myst ring)), die syswrite failed $'\n unless $written == length($mystring) $read = sysread(INFILE, $ block 256, 5) warn only read $read bytes not 256 if 256 ' = $read,
Функция syswrite посылает содержимое Smystring в DATAFILE. При вызове sysread из INFILE читаются 256 символов, сохраняемых с шестого символа в $Ыоск, при этом первые пять символов остаются без изменений. И sysread и syswrite возвращают фактическое количество переданных байт; оно может не совпадать с тем, которое пытались передать вы. Например, файл содержал меньше данных, чем вы рассчитывали, и чтение получилось укороченным. Может быть, произошло переполнение носителя, на котором находился файл. А может быть, процесс был прерван на середине записи. Stdio заботится о завершении записи в случае прерывания, но при вызовах sysread и syswrite этим придется заняться вам. Пример приведен в рецепте 9.3.
Функция sysseek является небуферизованной заменой для seek и tell. Она получает те же аргументы, что и seek, но возвращает новую позицию при успешном вызове или undef в случае ошибки. Текущая позиция внутри файла определяется следующим образом:
$pos = sysseek(HANDLE, 0, 1), # Не изменять позицию die Couldn t sysseek $'\n unless defined $pos,
Мы описали базовые операции с файлами, которые находятся в вашем распоряжении. Искусство программирования как раз и заключается в применении простейших операций для решения сложных проблем — например, определения количества строк в файле, перестановки строк, случайного выбора строки из файла, построения индексов и т д.
8.1. Чтение строк с символами продолжения
Проблема
Имеется файл с длинными строками, которые делятся на две и более строки. Символ \ означает, что данная строка продолжается на следующей. Вы хотите объединить разделенные строки. Подобное разделение длинных строк на короткие встречается в make-файлах, сценариях командного интерпретатора, конфигурационных файлах и многих языках сценариев.
Решение
Последовательно объединяйте прочитанные строки, пока не встретится строка без символа продолжения:
while (defined($lme = <FH>) ) { chomp $line, if ($line =- s/\\$//) { $line = <FH>, redo unless eof(FH) >
# Обработать полную запись в $line }
Комментарий
Рассмотрим пример входного файла:
OISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) \
$(TEXINFOS) $(INFOS) $(MANS) $(DATA) OEP_DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) \
$(TEXINFOS) $(INFO_DEPS) $(MANS) $(DATA) \
$(EXTRA_DIST)
Вы хотите обработать текст, игнорируя внутренние разрывы строк. В приведенном примере первая запись занимает две строки, вторая — три строки и т. д.
У файлов такого формата имеется одна распространенная проблема — невидимые пробелы между \ и концом строки. Менее строгий вариант подстановки выглядит так:
if ($lme =~ s/\\\s*$//) {
# Как и прежде }
К сожалению, даже если ваша программа прощает мелкие погрешности, существуют и другие, которые этого не делают. Будьте снисходительны к входным данным и строги — к выходным.
t> Смотри также------------------------------------------------------------ ¦----------------------------
Описание функции chomp вperlfunc(l); описание ключевого слова redo в разделе «Loop Control» perlsyn(l).
8.2. Подсчет строк (абзацев, записей) в файле
Проблема
Требуется подсчитать количество строк в файле.
Решение
Во многих системах существует программа we, подсчитывающая строки в файле:
Scount = 'we -I < $file'; die 'we failed: P ' if $'; chomp($count),
Кроме того, можно открыть файл и последовательно читать строки до конца, увеличивая значение счетчика:
open(FILE, "< $file") or die "can't open $file: $'";
$count++ while <FILE>;
# $count содержит число прочитанных строк
Самое быстрое решение предполагает, что строки действительно завершаются "\п":
Scount += tr/\n/\n/ while sysread(FILE, $_, 2 ** 16);
Комментарий
Хотя размер файла в байтах можно определить с помощью -s $f lie, обычно полученная цифра никак не связана с количеством строк. Оператор -s рассматривается в главе 9 «Каталоги».
Если вы не хотите или не можете перепоручить черную работу другой программе, имитируйте работу we — самостоятельно откройте и прочитайте файл:
open(FILE, '< $file") or die "can't open $file. S1";
$count++ while <FILE>,
# $count содержит число прочитанных строк
Другой вариант выглядит так:
open(FILE, "< $flie' ) or die 'can't open $file: $'"; for ($count=0; <FILE>; $count++) { }
Если вы не читаете из других файлов, можно обойтись без переменной Scount. Специальная переменная $. содержит количество прочитанных строк с момента последнего явного вызова close для файлового манипулятора:
1 while <FILE>, Scount = $.,
В этом варианте все записи файла последовательно читаются без использования временных переменных.
Чтобы подсчитать абзацы, присвойте перед чтением глобальному разделителю входных записей $/ пустую строку (""), и тогда оператор о будет считывать не строки, а целые абзацы:
$/ = ' ; # Включить режим чтения абзацев open(FILE, $file) or die "can t open $file: $'"; 1 while <FILE>; $para_count = $ ;
t> Смотри также--------------------------------------------------------------------------------------------
Описание специальной переменной $/ вperlvar{\); введение главы 9; страница руководства wc{\).
8.3. Обработка каждого слова в файле
Проблема
Требуется выполнить некоторую операцию с каждым словом файла, по аналогии с функцией f о reach.
Решение
Разделите каждую строку по пропускам с помощью функции split:
while (о) {
for $chunk (split) {
Глава 8 • Содержимое файлов
# Сделать что-то с $chunkИли воспользуйтесь оператором m//g для последовательного извлечения фрагментов строки:
while (<>) {
while ( /(\w[\w -].)/9 ) { # Сделать что-то с $1
Комментарий
Сначала необходимо решить, что же подразумевается под «словом». Иногда это любые последовательности символов, кроме пропусков; иногда — идентификаторы программ, а иногда — слова английского языка. От определения зависит и используемое регулярное выражение.
Два варианта решения, приведенные выше, работают по-разному. В первом варианте шаблон определяет, что не является словом. Во втором варианте все наоборот — шаблон решает, что им является.
На основе этой методики нетрудно подсчитать относительные частоты всех слов в файле. Количество экземпляров каждого слова сохраняется в хэше:
8 Подсчет экземпляров слов в файле %seen = (), while (о) {
while ( /(\w[ \w-]*)/g ) { $seen{lc $1}++,
# Отсортировать выходной хэш по убыванию значений
foreach $word ( sort { $seen{$b} <=> $seen{$a} } keys %seen) {
printf %5d %s\n , $seen{$word}, Sword,
>
Чтобы программа подсчитывала количество строк вместо слов, уберите второй цикл while и замените его на $seen{lc $_}++:
# Подсчет экземпляров строк в файле
%seen = (),
while (о) {
$seen{lc $_}++, } foreach $line ( sort { $seen{$b} <=> $seen{$a} } keys %seen ) {
printf %5d %s , $seen{$line}, $line, }
Порой слова могут выглядеть довольно странно — например, «M.I.T», «Micro-Soft», «o'clock», «49ers», «street-wise», «and/or», «&», «с/о», «St.», «TschuB» или
> Смотри также---------------------------------------------------------------------------------------------
Описание функции split вperlfunc(l); рецепты 6.3; 6.23.
8.4. Чтение файла по строкам или абзацам в обратном направлении
Проблема
Требуется обработать каждую строку или абзац файла в обратном направлении.
Решение
Прочитайте все строки в массив и организуйте обработку элементов массива от конца к началу:
Wines = <FILE>,
while ($lme = pop (alines) {
# Сделать что-то с $line
}
Или занесите строки в массив в обратном порядке:
@lines = reverse <FILE>, foreach $line (@lines) {
# Сделать что-то с $lme
>
Комментарий
Ограничения, связанные с доступом к файлам (см. введение), не позволяют последовательно читать строки с конца файла. Приходится читать строки в память и обрабатывать их в обратном порядке. Конечно, расходы памяти при этом будут по крайней мере не меньше размера файла.
В первом варианте массив строк перебирается в обратном порядке. Такая обработка является деструктивной, поскольку при каждой итерации из массива выталкивается последний элемент. Впрочем, то же самое можно сделать и недеструктивно:
for ($1 = $#lines, $i i= -1, $i--) {
$line = $lines[$i], }
Во втором варианте генерируется массив строк, изначально расположенных в обратном порядке. Его тоже можно обработать недеструктивно. Мы получаем массив с обратным порядком строк, поскольку присваивание @lmes обеспечива-
Показанные решения легко распространяются на чтение абзацев, достаточно изменить значение $/:
# Внешний блок обеспечивает существование временной локальной копии $/ {
local $/ = ,
^paragraphs = reverse <FILE>,
foreach $paragraph (^paragraphs) { # Сделать что-то
> Смотри также---------------------------------------------------------------------------------------------
Описание функции reverse в perlfunc(l); описание специальной переменной $/ bperlvar{\); рецепты 4.10; 1.6.
8.5. Чтение из дополняемого файла
Проблема
Требуется читать данные из непрерывно растущего файла, однако при достижении конца файла (текущего) следующие попытки чтения завершаются неудачей.
Решение
Читайте данные, пока не будет достигнут конец файла. Сделайте паузу, сбросьте флаг EOF и прочитайте новую порцию данных. Повторяйте, пока процесс не прервется. Флаг EOF сбрасывается либо функцией seek:
for (,,) {
while (<FH>) { }
sleep $SOMETIME,
seek(FH, 0, 1), }
либо методом с lea re г г модуля IO::Handle:
use 10 Seekable,
for (,,) {
while (<FH>) { }
sleep $SOHETIME, FH->clearerr(),
Комментарий
При достижении конца файла во время чтения устанавливается внутренний флаг, который препятствует дальнейшему чтению. Для сброса этого флага проще всего воспользоваться методом clearer г, если он поддерживается (присутствует в модулях IO::Handle и FileHandle). Кроме того, можно вызвать метод POSIX¦ clearerr:
Snaptime = 1,
use 10 Handle,
open (LOGFILE, /tmp/logfile ) or die can t open /tmp/logfile $'
for (,,) {
while (<LOGFILE>) { print } # Или другая операция
sleep $naptime,
LOGFILE->clearerr(), # Сбросить флаг ошибки ввода/вывода }
Если простейший вариант в вашей системе не работает, воспользуйтесь функцией seek. Приведенный выше фрагмент с seek пытается переместиться на 0 байт от текущей позиции, что почти всегда завершается успехом. Текущая позиция при этом не изменяется, но зато для манипулятора сбрасывается признак конца файла, благодаря чему при следующем вызове <LOGFILE> будут прочитаны новые данные.
Если и этот вариант не работает (например, из-за того, что он полагается на так называемую «стандартную» реализацию ввода/вывода библиотек С), попробуйте следующий фрагмент — он явно запоминает старую позицию в файле и напрямую возвращается к ней:
for (,,) {
for ($curpos = tell(LOGFILE), <LOGFILE>, Scurpos = tell(LOGFILE}) { # Обработать $_
}
sleep $naptime,
seek(LOGFILE, $curpos, 0), # Вернуться к прежней позиции }
Некоторые файловые системы позволяют удалить файл во время чтения из него. Вероятно, в таких случаях нет смысла продолжать работу с файлом. Чтобы программа в подобных ситуациях завершалась, вызовите stat для манипулятора и убедитесь в том, что количество ссылок на него (третье поле возвращаемого списка) не стало равным нулю:
exit if (stat(L0GFILE))[3] == 0
Модуль File::stat позволяет записать то же самое в более понятном виде:
use File stat,
exit if stat(*LOGFILE)->nlink == 0,
t> Смотри также--------------------------------------------------------------------------------------------
Описание функции seek вperlfunc(l); документация по стандартным модулям POSIX и IO::Seekable; страницы руководства tail(l) и stdio(3).
Проблема
Требуется прочитать из файла случайную строку.
Решение
Воспользуйтесь функцией rand и переменной $ (текущим номером строки):
srand,
rand($ ) < 1 && ($lme = $__) while о,
# $lme - случайно выбранная строка
Комментарий
Перед вами — изящный и красивый пример неочевидного решения. Мы читаем все строки файла, но не сохраняем их в памяти. Это особенно важно для больших файлов. Вероятность выбора каждой строки равна 1/N (где N — количество прочитанных строк).
Следующий фрагмент заменяет хорошо известную программу fortune:
$/ = %%\п ,
$data = /usr/share/games/fortunes ,
srand,
rand($ ) < 1 && ($adage = $_) while <>,
print $adage,
Если вам известны смещения строк (например, при наличии индекса) и их общее количество, можно выбрать случайную строку и перейти непосредственно к ее смещению в файле. Впрочем, индекс доступен далеко не всегда.
Приведем более формальное пояснение работы данного алгоритма. Функция rand ($ ) выбирает случайное число от 0 до текущего номера строки. Строка с номером N сохраняется в возвращаемой переменной с вероятностью 1/N. Таким образом, первая строка сохраняется с вероятностью 100 %, вторая — с вероятностью 50%, третья — 33% и т. д. Вопрос лишь в том, насколько это честно для любого положительного целого N.
Начнем с конкретных примеров, а затем перейдем к абстрактным.
Разумеется, для файла из одной строки (N=1) все предельно честно: первая строка сохраняется всегда, поскольку 1/1 = 100 %. Для файла из двух строк N = 2. Первая строка сохраняется всегда; когда вы достигаете второй строки, она с вероятностью 50 % заменяет первую. Следовательно, обе строки выбираются с одинаковой вероятностью, и для N = 2 алгоритм тоже работает корректно. Для файла из трех строк N = 3. Третья строка сохраняется с вероятностью 1/3 (33 %). Вероятность выбора одной из двух первых строк равна 2/3 (66 %). Но как показано выше, две строки имеют одинаковую вероятность выбора (50 %). Пятьдесят процентов от 2/3 равны 1/3. Таким образом, каждая из трех строк файла выбирается с вероятностью 1/3.
В общем случае для файла из N+1 строк последняя строка выбирается с вероятностью l/(N+l),,a одна из предыдущих строк — N/(N+1). Деление N/(N+1) на
N дает вероятность 1/(N+1) для каждой из N первых строк и те же 1/(N+1) для строки с номером N+1. Следовательно, алгоритм корректно работает для любого положительного целого N.
Нам удалось случайным образом выбрать из файла строку со скоростью, пропорциональной количеству строк в файле. При этом максимальный объем используемой памяти даже в худшем случае равен размеру самой длинной строки.
t> Смотри также--------------------------------------------------------------------------------------------
Описание специальной переменной $ в perluar(l); рецепты 2.7—2.8.
8.7. Случайная перестановка строк
Проблема
Требуется скопировать файл и случайным образом переставить строки копии.
Решение
Прочитайте все строки в массив, перетасуйте элементы массива (см. рецепт 4.17) и запишите полученную перестановку:
# Используется функция shuffle из главы 4 while (<INPUT>) {
push(@lines, $_), }
©reordered = shuffle(@lines), foreach (^reordered) {
print OUTPUT $_, }
Комментарий
Самое простое решение — прочитать все строки файла и переставить их в памяти. Смещения строк в файле неизвестны, поэтому нельзя перетасовать список с номерами строк и затем извлечь строки в порядке их появления в файле. Впрочем, даже при известных смещениях такое решение, вероятно, будет работать медленнее, поскольку придется многократно перемещаться по файлу функцией seek вместо простого последовательного чтения.
> Смотри также---------------------------------------------------------------------------------------------
Рецепты 2.7-2.8; 4.17.
8.8. Чтение строки с конкретным номером
Проблема
Требуется извлечь из файла строку с известным номером.
Простейший выход — читать строки до обнаружения нужной:
# Выборка строки с номером $DESIRED_LINE_NUMBER
$ = О
do < $LINE = <HANOLE> } until $ == $DESIRED_LINE_NUMBER || eof,
Если подобная операция должна выполняться многократно, а файл занимает не слишком много места в памяти, прочитайте его в массив:
©lines = <HANDLE>
$LINE = $lmes[$DESIREO_LINE_NUMBER],
Если вы собираетесь многократно извлекать строки по номеру, а файл не помещается в памяти, постройте индекс смещений для отдельных строк и переходите к началу строки функцией seek:
# Применение build_inclex(*МАНИПУЛЯТОР_ДАННЫХ, *МАНИПУЛЯТОР_ИНДЕКСА)
sub build_index {
my $data_file = shift my $index_file = shift, my $offset = 0,
while (<$data_file>) {
print $mdex_file pack( N $offset), Soffset = tell($data_file)
П Применение linejvith_index(*MAHMnWlflTOPJlAHHblX *МАНИПУЛЯТОР_ИНДЕКСА,
$НОМЕР_СТРОКИ)
t) Возвращает строку или undef, если НОМЕР_СТРОКИ выходит за пределы файла sub lme_with_index {
my $data_file = shift
my $index_file = shift,
my $line_number = shift,
my Ssize, # Размер элемента индекса
my $i_offset, # Смещение элемента в индексе
my Sentry # Элемент индекса
my $d_offset, # Смещение в файле данных
$size = length(pack( N 0)), $i_offset = $size ¦ ($line_number-1), seek($mdex_file, $i_offset, 0) or return read($index_file, $entry, $size), $d_offset = unpack( N , Sentry), seek($data_file, $d_offset, 0), return scalar(<$data_file>),
# Применение
open(FILE, < $file ) or die Can t open $file for reading $'\n ,
open(INDEX, +>$file ldx )
or die Can t open $file ldx for read/write $'\n , build_mdex(*FILE, «INDEX), $line = line_with_index(*FILE, «INDEX, Sseeking),
При наличии модуля DB_File можно воспользоваться методом DB_RECNO, который связывает массив с файлом (по строке на элемент массива):
use DB_File, use Fcntl,
$tie = tie(@lines $FILE, O_RDWR 0666, $DB_RECNO) or die Cannot open file $FILE $'\n
# Извлечь строку
$line = $lines[$sought-1]
Комментарий
Каждый вариант имеет свои особенности и может пригодиться в конкретной ситуации. Линейное чтение легко программируется и идеально подходит для коротких файлов. Индексный метод обеспечивает ускоренную выборку, но требует предварительного построения индекса. Он применяется в случаях, когда индексируемый файл редко изменяется по сравнению с количеством просмотров. Механизму DB_File присущи некоторые начальные издержки, зато последующая выборка строк выполняется намного быстрее, чем при линейном чтении. Обычно он применяется для многократных обращений к большим файлам.
Необходимо знать, с какого числа начинается нумерация строк — с 0 или 1. Переменной $ присваивается 1 после чтения первой строки, поэтому при линейном чтении нумерацию желательно начинать с 1. В индексном механизме широко применяются смещения, и нумерацию лучше начать с 0. DB_File интерпретирует записи файла как элементы массива, индексируемого с 0, поэтому строки также следует нумеровать с 0.
Ниже показаны три реализации одной и той же программы, prmt_line. Программа получает два аргумента — имя файла и номер извлекаемой строки.
Версия print_line из примера 8. 1 просто читает строки файла до тех пор, пока не найдет нужную.
Пример 8.1. print_line-vl
#'/usr/bin/perl -w
# print_line-v1 - линейное чтение
(aARGV == 2 or die usage print_lme FILENAME LINE_NUMBER\n ,
(Sfilename, $line_number) = (a>ARGV,
open(INFILE, < Sfilename ) or die Can t open $filename for reading $!\n ,
while (<INFILE>) {
$lme = $_,
last if $ == $line_number,
продолжение #
304 Глава 8 • Содержимое файлов Пример 8.1 (продолжение)
if ($. != $line_number) {die "Didn't find line $line_number in $filenarae\n"; } print;
Версия из примера 8.2 сначала строит индекс. При большом количестве обращений индекс строится один раз, а затем используется во всех последующих чтениях.
Пример 8.2. printjine-v2
й!/usr/bin/perl -w
Я print_line-v2 - построение индекса
U Функции build_mdex и line_with_index приведены выше.
@argv == 2 or
die "usage: print_line FILENAME LINEJWMBER";
($filename, $line_number) = @ARGV; open(ORIG, "< Sfilename")
or die "Can't open Sfilename for reading: $!";
# Открыть индекс и при необходимости построить его
й Если две копии программы замечают, что индекс не существует, И они могут одновременно попытаться построить его.
# Проблема легко решается с применением блокировки.
Sindexname = "Sfilename.index";
sysopen(IDX, Sindexname, O_CREAT|O_RDWR)
or die "Can't open Sindexname for read/write: $!"; build_index(*ORIG, -IDX) if -z Sindexname;
$line = line_with_index(*ORIG, »IDX, $line_number);
die "Didn't find line $line_number in $filename" unless defined $line;
print $lme;
Версия с модулем DB_File из примера 8.3 похожа на волшебство. Пример 8.3. printjine-v3
#!/usr/bin/perl -w
# print_line-v3 - решение с применением DB_File
use DB_File;
use Fcntl;
(SiARGV == 2 or
die "usage: pnnt_line FILENAME LINE_NUMBER\n";
(Sfilename, $line_number) = @>ARGV;
$tie = tie(@lines, "DB_File", $filename, O_RDWR, 0666, $DB_RECNO) or die "Cannot open file Sfilename: $!\n";
unless ($line__number < $tie->length) {
8.9. Обработка текстовых полей переменной длины 305
die "Didn't find line $line_number in $filename\n" }
print $lines[$line_number-1]; # Легко, правда9
> Смотри также---------------------------------------------------------------------------------------------
Описание функции tie в perlfunc(l); описание специальной переменной $. в perlvar(l); документация по стандартному модулю DB_File.
8.9. Обработка текстовых полей переменной длины
Проблема
Требуется извлечь из входных данных поля переменной длины.
Решение
Воспользуйтесь функцией split с шаблоном, совпадающим с разделителями полей:
# Имеется $ЗАПИСЬ с полями, разделенными шаблоном ШАБЛОН. П Из записи извлекаются @ПОЛЯ. (ЭПОЛЯ = splltC/ШАБЛОН/, $ЗАПИСЬ);
Комментарий
Функция split вызывается с тремя аргументами: шаблон, выражение и лимит (максимальное количество извлекаемых полей). Если количество полей во входных данных превышает лимит, лишние ноля возвращаются неразделенными в последнем элементе списка. Если лимит не указан, возвращаются все поля (кроме завершающих пустых полей). Выражение содержит разделяемую строковую величину. Если выражение не указано, разделяется переменная $_. Шаблон совпадает с разделителем полей. Если шаблон не указан, в качестве разделителей используются смежные последовательности пропусков, а начальные пустые поля отбрасываются.
Если разделитель входных полей не является фиксированной строкой, можно вызвать split так, чтобы функция возвращала разделители полей вместе с данными, — для этого в шаблон включаются круглые скобки. Например:
])/, "3+5-2");
возвращает список:
(3, '+¦, 5, ¦-', 2)
Поля, разделенные двоеточиями (в стиле файла /etc/passwd), извлекаются следующим образом:
^fields = split(/:/, $record);
©fields = split(/\s+/, Srecord);
Если $ЗАПИСЬ начинается с пропуска, в последнем варианте первому эле менту списка будет присвоена пустая строка, поскольку split сочтет, что запись имеет начальное пустое поле. Если это не подходит, используйте особую форму split:
@fields = splitC ", $ЗАПИСЬ);
В этом случае split ведет себя так же, как и с шаблоном /\s+/, но игнорирует начальный пропуск.
Если разделитель может присутствовать внутри самих полей, возникает проблема. Стандартное решение — снабжать экземпляры разделителя в полях префиксом \. См. рецепт 1.13.
D> Смотри также------------------------------------------------------------------------------------------
Описание функции split вperlfunc(l).
8.10. Удаление последней строки файла
Проблема
Требуется удалить из файла последнюю строку.
Решение
Читайте файл по одной строке и запоминайте байтовое смещение последней прочитанной строки. Когда файл будет исчерпан, обрежьте файл по последнему сохраненному смещению:
open (FH, "+< $file") or die "can't update $file: $!"; while ( <FH> ) {
$addr = tell(FH) unless eof(FH);
>
truncate(FH, $addr) or die "can't truncate $file: $!";
Комментарий
Такое решение намного эффективнее загрузки всего файла, поскольку в любой момент времени в памяти хранится всего одна строка. Хотя вам все равно приходится читать весь файл, программу можно использовать и для больших файлов, размер которых превышает объем доступной памяти.
> Смотри также-------------- ;--------------------------------------------------------------------------------------------------------
Описание функций open и binmode в perlfunc(l); man-страницы ореп(2) и /ореп(3) вашей системы.
8.11. Обработка двоичных файлов 307
8.11. Обработка двоичных файлов
Проблема
Операционная система отличает текстовые файлы от двоичных. Как это сделать в программе?
Решение
Вызовите функцию binmode для файлового манипулятора:
Ыптос)е(МАНИПУЛЯТОР);
Комментарий
Не существует единого мнения по поводу того, что является строкой текстового файла; текстовые символы одного компьютера могут превратиться в двоичную белиберду на другом. Но даже если все станут пользоваться кодировкой ASCII вместо EBCDIC, Rad50 или Unicode, могут возникнуть затруднения.
Как говорилось во введении, конкретного символа перевода строки не существует. Это чисто абстрактное понятие, которое поддерживается операционной системой, стандартными библиотеками, драйверами устройств и Perl.
В Unix или Р1ап9 "\п" представляет физическую последовательность "\cJ" (служебная последовательность Perl, соответствующая Ctrl+J). Однако на терминале, не работающем в «чистом» (raw) режиме, нажатие на клавишу Enter генерирует код "\сМ" (возврат курсора), транслируемый в "\cj", а выходной код "\cJ" транслируется в "\cM\cJ". Подобные странности характерны не для обычных файлов, а лишь для терминальных устройств, и обрабатываются строго на уровне драйвера устройства.
На Мае код "\п" обычно представляется "\сМ"; чтобы жизнь была интереснее (а также из-за стандартов, требующих различий между "\п" и "\г"), "V" соответствует "\cJ". Такая интерпретация в точности противоположна стандартам UNIX, Plan9, VMS, CP/M... словом, почти всем. Следовательно, программисты Мае, которые пишут файлы для других систем или общаются с ними по сети, должны проявлять осторожность. Если отправить "\п", вы получите "\сМ", a "\cJ" исчезнет. Многие сетевые службы предпочитают отправлять и принимать в качестве разделителя строк последовательность "\cM\cJ", однако большинство позволяет ограничиться простым "\cJ".
В VMS, DOS и их производных "\п" также представляет "\cJ", по аналогии с Unix и Р1ап9. С терминальной точки зрения UNIX и DOS ведут себя одинаково: при нажатии пользователем клавиши Enter генерируется "\сМ", однако в программу поступает уже "\п", то есть "\cJ". Код "\п", переданный терминалу, превращается в "\cM\cJ".
Эти странные преобразования выполняются и с файлами Windows. В тексто вых файлах DOS каждая строка завершается двумя-символами, "\cM\cJ". Последний блок файла содержит код "\cZ", определяющий окончание текста. В таких системах при записи строки "bad news\n" файл будет содержать "bad news\cM\cJ", как при выводе на терминал.
Такое наследие старой файловой системы СР/М, в которой хранились лишь сведения о количестве блоков, но не о размере файлов, бесит программистов уже несколько десятилетий, и конца-края этому не видно. Ведь DOS была совместима с файловым форматом СР/М, Windows — с форматом DOS, a NT — с форматом Windows. Грехи отцов преследуют потомков в четвертом поколении.
Впрочем, проблему одиночного "\п" можно обойти — достаточно сообщить Perl (и операционной системе), что вы работаете с двоичными данными. Функция binmode означает, что прочитанные или записанные через конкретный манипулятор данные не должны преобразовываться по правилам, установленным в системе для текстовых файлов.
Sgifname = 'picture gif",
open(GIF, Sgifname) or die 'can t open $gifname $'';
binmode(GIF), ft Теперь DOS не преобразует двоичные
ft входные данные GIF
binmode(STDOUT), й Теперь DOS не преобразует двоичные
# выходные данные STDOUT
while (read(GIF, $buff, 8 * 2**10)) {
print STDOUT Sbuff; }
Вызов binmode в системах, где отличия между текстовыми и двоичными файлами несущественны (в том числе UNIX, Mac и Plan9), не принесет никакого вреда. Однако несвоевременный вызов функции в других системах (включая MVS, VMS и всех разновидностей DOS) может исказить содержимое файлов.
Если функция bmmode не используется, в данных, прочитанных с помощью о, строковый терминатор системы заменяется на "\п", даже если $/ было присвоено другое значение. Аналогично, любой "\п", выводимый через манипулятор функцией print, превращается в строковый терминатор данной системы. Дополнительные сведения приведены во введении.
Если вы хотите, чтобы прочитанные данные совпадали с содержимым файла байт в байт, и при этом работаете в одной из перечисленных странных систем, — вызовите bmmode. Конечно, если вы захотите использовать их с о, вам придется присвоить $/ настоящий разделитель записей.
> Смотри также
Описание функций open и binmode вperlfunc(i); страницы руководства ореп(2) и fopen(3) вашей системы.
8.12. Ввод/вывод с произвольным доступом
Проблема
Нужно прочитать двоичную запись из середины большого файла, но вам не хочется добираться до нее, последовательно читая все предыдущие записи.
Решение
Определите размер записи и умножьте его на номер записи, чтобы получить смещение в байтах. Затем вызовите seek для полученного смещения и прочитайте запись:
$АДРЕС = SPA3MEP * $НОМЕР,
seek(FH, $АДРЕС, 0) or die 'seek $'' ,
read(FH, $БУФЕР, SPA3MEP);
Комментарий
В решении предполагается, что $НОМЕР первой записи равен нулю. Если нумерация начинается с единицы, измените первую строку фрагмента:
$АДРЕС = $РАЗМЕР * (SH0MEP-1),
Для текстовых файлов это решение не работает — только строки не имеют одинаковую длину. Но такие ситуации встречаются очень редко.
> Смотри также---------------------------------------------------------------------------------------------
Описание функции seek в perlfunc(l); рецепт 8.13.
8.13. Обновление файла с произвольным
доступом
Проблема
Требуется прочитать старую запись из двоичного файла, изменить ее содержимое и записать обратно.
Решение
Прочитайте (read) старую запись, упакуйте (pack) обновленное содержимое и запишите обратно.
use Fcntl; # Для SEEK_SET и SEEK_CUR
SADDRESS = SRECSIZE * $RECNO,
seek(FH, SADDRESS, SEEK_SET) or die 'Seeking. $' ';
or die Reading $' , ^FIELDS = unpack($FORMAT, $BUFFER), # Обновить содержимое, затем SBUFFER = pack($FORMAT, ©FIELDS),
seek(FH, -$RECSIZE SEEK_CUR) or die Seeking $i ,
print FH SBUFFER,
close FH or die Closing $i ,
Комментарий
Для вывода записей в Perl не потребуется ничего, кроме функции print Помните, что антиподом read является print, а не write, хотя, как ни странно, антиподом sysread все же является syswrite.
В примере 8 4 приведен исходный текст программы weekearly, которой передается один аргумент — имя пользователя. Программа смещает дату регистрации этого пользователя на неделю в прошлое Конечно, на практике с системными файлами экспериментировать не следует — впрочем, из этого все равно ничего не выйдет! Программа должна иметь право записи для файла, поскольку тот открывается в режиме обновления. После выборки и изменения записи программа упаковывает данные, возвращается на одну запись назад и записывает буфер.
Пример 8.4. weekearly
#'/usr/bin/perl
8 weekearly - смещение даты регистрации на неделю назад use User pwent, use 10 Seekable
Stypedef = L A12 A16 # Формат linux в sunos - L A8 A16
Ssizeof = length(pack($typedef ())),
$user = shift(@ARGV) || $ENV{USER} || $ENV{LOGNAME)
Saddress = getpwnam($user)->uid * $sizeof
open (LASTLOG, +</var/log/lastlog )
or die can t update /usr/adm/lastlog $' seek(LASTLOG, $address, SEEK_SET)
or die seek failed $t read(LASTLOG, $buffer, Ssizeof) == $sizeof
or die read failed V ,
(Stime, $line, $host) = unpack($typedef Sbuffer) $time -= 24 * 7 ¦ 60 * 60 # На неделю назад $buffer = pack($typedef, $time, $line, $time)
seek(LASTLOG, -Ssizeof SEEK_CUR) » Вернуться на одну запись
or die seek failed $' print LASTLOG Srecord,
close(LASTLOG)
or die close failed $' ,
> Смотри также
Описание функций open, seek, read, pack и unpack вperlfunc(l); рецепты 8.12; 8.14.
8.14. Чтение строки из двоичного файла
Проблема
Требуется прочитать из файла строку, завершенную нуль-символом, начиная с определенного адреса.
Решение
Присвойте $/ нуль-символ ASCII и прочитайте строку с помощью <>:
$old_rs = $/, # Сохранить старое значение $/
$/ = \0 й Нуль-символ
seek(FH, $addr, SEEK_SET) or die Seek error $i\n
$string = <FH> # Прочитать строку
chomp Sstring, # Удалить нуль-символ
$/ = $old_rs, # Восстановить старое значение $/
При желании сохранение и восстановление $/ можно реализовать с помощью
local:
local $/ = \0
#
} # $/ восстанавливается автоматически
Комментарий
Программа bgets из примера 8.5 получает в качестве аргументов имя файла и одно или несколько байтовых смещений. Допускается десятичная, восьмеричная или шестнадцатеричная запись смещений. Для каждого смещения программа читает и выводит строку, которая начинается в данной позиции и завершается нуль-символом или концом файла:
Пример 8.5. bgets
Jt'/usr/bin/perl
# bgets - вывод строк по смещениям в двоичном файле
use 10 Seekable,
($flie, @addrs) = @ARGV or die usage $0 addr
open(FH $file) or die cannot open $file S1 ,
$/ = \000 ,
foreach $addr (@addrs) {
$addr = oct $addr if $addr =~ /"0/, seek(FH, $addr, SEEK_SET)
продолжение ¦&
or die can t seek to $addr in $file $' , pnntf qq{%#x %#o %d %s \n} $addr, $addr, $addr scalar о >
Приведем простейшую реализацию программы UNIX strings-Пример 8.6. strings
#'/usr/bin/perl
# strings - извлечение строк из двоичного файла
$/ = \0
while (о) {
while (/([\040-\176\s]{4 })/g) { print $1, \n
> Смотри также---------------------------------------------------------------------------------------------
Описание функций seek, getc и ord вperlfunc(l); описание qq// в разделе «Quote and Quote-like Operators» man-страницы peiiop( 1)
8.15. Чтение записей фиксированной длины
Проблема
Требуется прочитать файл с записями фиксированной длины
Решение
Воспользуйтесь функциями pack и unpack:
# SRECORDSIZE - длина записи в байтах
U STEMPLATE - шаблон распаковки для записи
# FILE - файл из которого читаются данные
# @FIELDS - массив для хранения полей
until ( eof(FILE) ) {
read(FILE $record SRECORDSIZE) == SRECORDSIZE
or die short read\n (SFIELDS = unpack($TEMPLATE Srecord),
Комментарий
Поскольку мы работаем не с текстовым, а с двоичным файлом, для чтения записей нельзя воспользоваться оператором < > или методом getline модулей 10 Вместо этого приходится считывать конкретное количество байт в буфер
функцией read. После этого буфер содержит данные одной записи, которые декодируются функцией unpack с правильным форматом.
При работе с двоичными данными трудности часто начинаются как раз с правильного выбора формата. Если данные были записаны программой на С, приходится просматривать заголовочные файлы С или страницы руководства с описанием структур, для чего необходимо знание языка С. Заодно вы должны близко подружиться с компилятором С, поскольку без этого вам будет трудно разобраться с выравниванием полей (например, х2 в формате из рецепта 8 18) Если вам посчастливилось работать в Berkeley UNIX или в системе с поддержкой дсс, вы сможете воспользоваться утилитой c2ph, распространяемой с Perl, и заставить компилятор С помочь вам в этом.
Программа tailwtmp в конце этой главы использует формат, описанный в utmp(5) системы Linux, и работает с файлами /var/log/wtmp и /var/run/utmp Но стоит вам привыкнуть к работе с двоичными данными, как возникает другая напасть — особенности конкретных компьютеров Вероятно, программа не будет работать в вашей системе без изменений, но выглядит она поучительно. Приведем соответствующую структуру из заголовочного файла С для Linux:
|
«define UT_LINESIZE |
12 |
||
|
«define UT_NAMESIZE |
8 |
||
|
«define UT_HOSTSIZE |
16 |
||
|
struct utmp { |
/* Коды для шаблона распаковки |
*/ |
|
|
short ut_type, |
/* s - short должно быть дополнено |
Ч |
|
|
pid_t ut_pid, |
/* 1 для integer |
Ч |
|
|
char ut_lme[UT_LINESIZE] |
|
/* А12 - 12-символьная строка |
Ч |
|
char ut_id[2] |
/* А2, но для выравнивания |
||
|
необходимо х2 |
-/ |
||
|
time_t ut_time |
/* 1 - long |
Ч |
|
|
char ut_user[UT_NAMESIZE] |
|
/* А8 - 8-символьная строка |
* / |
|
char ut_host[UT_HOSTSIZE] |
|
/* А16 - 16-символьная строка |
ч |
|
long ut_addr |
/• 1 - long |
ч |
Если записи представляют собой текстовые строки, используйте шаблон распаковки а или А .
Записи фиксированной длины хороши тем, что n-я запись начинается в файле со смещения SIZE*(n-1), где SIZE — размер одной записи. Пример приведен в программе с построением индекса из рецепта 8.8.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций unpack, pack и read в perlfunc(l), рецепт 1.1.
Проблема
Вы хотите, чтобы пользователи вашей программы могли изменить ее поведение с помощью конфигурационного файла.
Решение
Организуйте обработку файла в тривиальном формате ПЕРЕМЕННАЯ=ЗНАЧЕНИЕ, созда вая для каждого параметра элемент хэша «ключ/значение»:
while (<CONFIG>) {
chomp, # Убрать перевод строки
s/#.*//, # Убрать комментарии
s/"\s+//; # Убрать начальные пропуски
s/\s+$//; й Убрать конечные пропуски
next unless length; # Что-нибудь осталось9
my ($var, Svalue) = split(/\s*=\s*/, $_¦ 2);
$User_Preferences{$var} = Svalue; }
Существует другой более изящный вариант — интерпретировать конфигурационный файл как полноценный код Perl:
do '$ENV{HOME}/ progrc ,
Комментарий
В первом решении конфигурационный файл интерпретируется в тривиальном формате следующего вида (допускаются комментарии и пустые строки):
# Сеть класса С NETMASK = 255.255 255 О MTU = 296
DEVICE = cual RATE = 115200 MODE = adaptive
После этого можно легко получить значение нужных параметров — например, $User_Preferences{"RATE"} дает значение 115200. Если вы хотите, чтобы конфигурационный файл непосредственно устанавливал значения переменных в программе вместо заполнения хэша, включите в программу следующий фрагмент:
no strict 'refs'; $$var = Svalue;
и переменная $RATE будет содержать значение 115200.
Во втором решении do организует непосредственное выполнение кода Perl. Если вместо блока используется выражение, do интерпретирует его как имя файла. Это практически идентично применению require, но без риска фатальных
исключений. В формате второго решения конфигурационный файл принимает следующий вид:
# Сеть класса С
SNETMASK = '255.255.255 О';
$MTU = 0x128;
SDEVICE = 'сиаГ,
$RATE = 115_200;
$MODE = adaptive';
Если вам непонятно, зачем включать в файл лишние знаки препинания, задумайтесь — в вашем распоряжении оказывается весь синтаксис Perl. Теперь простые присваивания можно дополнить логикой и проверкой условий:
if (SDEVICE =' /1$/) {
SRATE = 28_800, } else {
$RATE = 115_200, }
Во многих программах предусмотрены системные и личные конфигурационные файлы. Если вы хотите, чтобы предпочтения пользователя отменяли действия системных параметров, загрузите личный файл после системного:
SAPPDFLT = "/usr/local/share/myprog' ,
do "$APPDFLT/sysconfig.pl', do "$ENV{HOME}/.myprogrc";
Если при существующем личном файле системный файл должен игнорироваться, проверьте возвращаемое значение do:
do '$APPDFLT/sysconfig.pl'
or do '$ENV{HOME}/.myprogrc';
Возможно, вас интересует, в каком контексте должны выполняться эти файлы. Они будут принадлежать пакету, в котором была откомпилирована команда do. Обычно пользователи устанавливают значения конкретных переменных, которые представляют собой неуточненные глобальные величины и потому принадлежат текущему пакету. Если вы предпочитаете, чтобы неуточненные переменные относились к конкретному пакету, воспользуйтесь записью вида:
{ package Settings; do "$ENV{HOME}/ myprogrc" }
Файл, прочитанный с помощью do (а также require и use), представляет собой отдельную, самостоятельную область действия. Это означает как то, что конфигурационный файл не может обратиться к лексическим (ту) переменным вызывающей стороны, так и то, что вызывающая сторона не сможет найти такие переменные, заданные в файле. Кроме того, пользовательский код не подчиняется директивам типа use strict или use integer, способным воздействовать на вызывающую сторону.
eval 'cat $ENV{HOME}/.myprogгс';
Мы еще Pie видели, чтобы кто-нибудь (кроме Ларри) использовал такой подход в рабочем коде.
Во-первых, do проще вводится. Кроме того, do учитывает @INC, который обычно просматривается при отсутствии полиостью указанного пути, но в отличие от require в do не выполняется неявная проверка ошибок. Следовательно, вам не придется заворачивать do в eval для перехвата исключений, от которых ваша программа может скончаться, поскольку do уже работает как eval.
При желании можно организовать собственную проверку ошибок:
$file = "someprog.pi": unless ($return = do $file) {
warn "couldn't parse $file: $@" if $@;
warn "couldn't do $file: $!" unless defined Sreturn;
warn "couldn't run $file" unless $return;
}
Программисту намного проще отследить это в исходном тексте, чем изобретать новый, сложный синтаксис. Проще будет и пользователю, которому не придется изучать правила синтаксиса очередного конфигурационного файла. Приятно и то, что пользователь получает доступ к мощному алгоритмическому языку программирования.
Однако не следует забывать о безопасности. Как убедиться в том, что файл не модифицировался никем, кроме пользователя? Традиционный подход — не делать ничего, полагаясь исключительно на права доступа каталогов и файлов. В девяти случаях из десяти такое решение оказывается правильным, поскольку большинство проектов попросту не оправдывает подобной паранойи. А если все же оправдывает, загляните в следующий рецепт.
> Смотри также-------------------------------- '¦----------------------------------------------------------
Описание функций eval и require вperlfunc{\); рецепты 8.17; 10.12.
8.17. Проверка достоверности файла
Проблема
Требуется прочитать файл (например, содержащий данные о конфигурации). Вы хотите использовать файл лишь в том случае, если правом записи в него (а возможно, даже правом чтения) не обладает никто, кроме его владельца.
Решение
Получите данные о владельце и правах доступа с помощью функции stat. Можно воспользоваться встроенной версией, которая возвращает список:
( $dev, $ipo, $mode, $nlink,
$uid, $gid, $rdev, $size,
$atime, $mtime, $ctime,
$blksize, $blocks ) = stat($filename)
or die "no $filename: $!";
$mode &= 07777; # Отбросить информацию о типе файла
Или воспользуйтесь интерфейсом с именованными полями:
$infо = stat($filename) or die "no $filename: $!";
if ($info->uid == 0) {
print "Superuser owns $filename\n"; } if ($info->atime > $mfo->mtime) {
print "$ filename has been read since it was written.\n"; }
Комментарий
Обычно мы доверяем пользователям и позволяем им устанавливать права доступа по своему усмотрению. Если они захотят, чтобы другие могли читать или даже записывать данные в их личные файлы — это их дело. Однако многие приложения (редакторы, почтовые программы, интерпретаторы) часто отказываются выполнять код конфигурационных файлов, если запись в них осуществлялась кем-то, кроме владельца. Это помогает избежать нападений «троянских» программ. Программы, следящие за безопасностью — например, ftp или rlogin, — могут даже отвергнуть конфигурационные файлы, прочитанные кем-то, кроме владельца.
Если файл может быть записан кем-то, кроме владельца, или принадлежит кому-то, отличному от текущего или привилегированного пользователя, он не признается достоверным. Информация о владельце и правах доступа может быть получена с помощью функции stat. Следующая функция возвращает true для достоверных файлов и false для всех остальных. Если вызов stat завершается неудачей, возвращается undef.
use File::stat;
sub is_safe {
my $path = shift;
my $info = stat($path);
return unless $info;
# Проверить владельца (привилегированный или текущий пользователь)
# Настоящий идентификатор пользователя хранится в переменной $<.
if (($info->uid != 0) && ($info->uid != $<)) {
return 0;
# Проверить, может ли группа или остальные пользователи
# записывать в файл.
# Для проверки чтения/записи используйте константу 066
if ($info->mode & 022) { tt Если другие имеют право записи
# но каталоги с битом запрета (01000) - достоверны return 0 unless $info->mode & 01000; }
return 1; }
Каталог считается достоверным даже в том случае, если другие имеют право записи в него — при условии, что для него установлен бит 01000 (разрешающий удаление только владельцу каталога).
Осторожный программист также проследит, чтобы запись была запрещена и для всех каталогов верхнего уровня. Это связано с известной «проблемой chown», при которой любой пользователь может передать принадлежащий ему файл и сделать его владельцем кого-то другого. Приведенная ниже функция is_very_safe обращается к функции POSIX: :sysconf, чтобы выяснить, существует ли «проблема chown» в системе. Если проблема существует, далее функцией проверяются is_safe все каталоги верхнего уровня вплоть до корневого. Если в вашей системе установлена ограниченная версия chown, функция is_very_safe ограничивается простым вызовом is_safe.
use Cwd;
use POSIX qw(sysconf _PC_CHOWN_RESTRICTED); sub is_verysafe { ray $path = shift;
return is_safe($path) if sysconf(_PC_CHOWN_RESTRICTED); $path = getcwdO . '/' . $path if $path Г m{"/}; do <
return unless is_safe($path);
$path =~ s#(["/]+|/)$##; # Имя каталога
$path =~ s#/$«# if length($path) > 1; # Последний символ / } while length $path;
return 1; }
В программе эта функция используется примерно так;
$file = "$ENV{HOME}/.myprogrc"; readconfig($flie) if is_safe($file);
При этом возникает потенциальная опасность перехвата, поскольку предполагается, что файл открывается гипотетической функцией readconfig. Между получением сведений о файле (is_safe) и его открытием функцией readconfig теоретически может случиться что-нибудь плохое. Чтобы избежать перехвата, передавайте is_safe уже открытый файловый манипулятор;
$file = "$ENV{HOME}/.myprogrc"; if (open(FILE, -< $file")) {
readconfig(*FILE) if is_safe(*FILE); }
Впрочем, вам также придется позаботиться о том, чтобы функция readconfig принимала файловый манипулятор вместо имени.
8.18. Программа: tailwtmp
В начале и конце рабочего сеанса пользователя в системе UNIX в файл wtmp добавляется новая запись. Вам не удастся получить ее с помощью обычной программы tail, поскольку файл хранится в двоичном формате. Программа tailwtmp из примера 8.7 умеет работать с двоичными файлами и выводит новые записи по мере их появления. Формат pack придется изменить для конкретной системы.
Пример 8.7. tailwtmp
#!/usr/bin/perl
# tailwtmp - отслеживание начала/конца сеанса
# Использует структуру linux utmp, см. utmp(5)
$typedef = 's х2 i A12 A4 1 A8 A16 1';
$sizeof = length pack($typedef, () );
use 10::File;
open(WTMP, '/var/log/wtmp') or die "can't open /var/log/wtmp: $!";
seek(WTMP, 0, SEEK_END);
for (;;) {
while (read(WTMP, $buffer, $sizeof) == Ssizeof) { ($type, $pid, $line, $id, Stime, $user, $host, $addr)
= unpack($typedef, $buffer); next unless $user && ord($user) && $time; printf "%1d %-8s %-12s %2s %-24s %-16s %5d %08x\n", $type,$user,$line,$id,scalar(localtime($time)), $host,$pid,$adcir; >
for ($size = -s WTMP; $size == -s WTMP; sleep 1) {> WTMP->clearerr();
8.19. Программа: tctee
Во многих системах существует классическая программа tee для направления выходных данных в несколько приемников. Например, следующая команда передает выходные данные someprog ъ/tmp/output а через конвейер — в почтовую систему:
% someprog | tee /tmp/output | Mail -s 'check this' user@host.org
Программа tctee пригодится не только тем пользователям, которые работают вне UNIX и не имеют tee. Она обладает некоторыми возможностями, отсутствующими в стандартной версии tee.
При запуске программа может получать четыре флага:
-i — игнорировать прерывания,
-а — дописывать данные в конец выходных файлов,
-и — выполнять небуферизованный вывод,
-п — отменить копирование выходных данных в стандартный вывод.
% someprog | tctee f1 " | cat -n' f2 "»f3"
В примере 8.8 приведена программа-ветеран, написанная на Perl почти 10 лет назад и работающая до сих пор. Если бы нам пришлось писать ее заново, вероятно, мы бы использовали strict, предупреждения и модули с десятками тысяч строк. Но как известно, «лучшее — враг хорошего».
Пример 8.8. tctee
#'/usr/bin/perl
# tctee - клон tee
# Программа совместима с perl версии 3 и выше.
while ($ARGV[O] =" /"-(.+)/ && (shift, ($_ = $1), 1)) { next if /"$/;
s/i// && (++$ignore_ints, redo); s/a// && (++$append, redo), s/u// && (++$unbuffer, redo), s/n// && (++$nostdout, redo), die "usage tee [-aiun] [filenames] ..\n";
if ($ignore_ints) {
for $sig ('INT', 'TERM', 'HUP', 'QUIT') { $SIG{$sig} = 'IGNORE'; }
$SIG{'PIPE'} = 'PLUMBER'; $node = Sappend 9 '»' : '>'; $fh = 'FHOOO1,
unless ($nostdout) {
%fh = ('STDOUT', 'standard output'); # Направить в STDOUT
$| = 1 if Sunbuffer;
for (@ARGV) {
if (!open($fh, (/~[">|]/ && $mode) . $_)) {
warn "$0. cannot open $_: $!\n"; # Как в sun, я предпочитаю die
$status++;
next;
select((select($fh), $| = 1)[0]) if $unbuffer; $fh{$fh++} = $_;
while (<STDIN>) {
for $fh (keys %fh) {
8.20. Программа: laston 321
print $fh $_;
for $fh (keys %fh) {
next if close($fh) || Idefined $fh{$fh}; warn "$0: couldnt close $fh{$fh>: $!\n"; $status++;
exit Sstatus;
sub PLUMBER {
warn "$0: pipe to \"$fh{$fh}\" broke!\n"
$status++;
delete $fh{$fh};
8.20. Программа: laston
Во время регистрации в системе UNIX на экран выводятся сведения о времени последней регистрации. Эта информация хранится в двоичном файле с именем lastlog. Каждый пользователь имеет собственную запись в этом файле; данные пользователя с UID 8 хранятся в записи 8, UID 239 — в записи 239 и т. д. Чтобы узнать, когда пользователь с заданным UID регистрировался в последний раз, преобразуйте имя пользователя в числовое значение UID, найдите соответствующую запись в файле, прочитайте и распакуйте данные. Средствами интерпретатора это сделать очень сложно, зато в программе laston все очень легко. Приведем пример:
% laston gnat
gnat UID 314 at Mon May 25 08:32:52 1998 on ttypO from below.perl.com
Программа из примера 8.9 была написана гораздо позже программы tctee из примера 8.8, однако она менее переносима, поскольку в ней используется двоичная структура файла lastlog системы UNIX. Для других систем ее необходимо изменить.
Пример 8.9. laston
#!/usr/bin/perl
# laston - определение времени последней регистрации пользователя
use User::pwent;
use IO::Seekable qw(SEEK_SET);
open (LASTLOG, "/var/log/lastlog") or die "can't open /usr/adm/lastlog: $!";
$typedef = ' L A12 A16'; # Формат lmux; для SunOS - "L A8 A16" $sizeof = length(pack($typedef, ()));
продолжение ¦&
322 Глава 8 • Содержимое файлов Пример 8.9 (продолжение)
for $user (@ARGV) {$U = ($user =~ /"\d+$/) ? getpwuid($user) : getpwnam($user);
unless ($U) { warn "no such uid $user\n', next; }
seek(LASTLOG, $U->uid * $sizeof, SEEK_SET) or die "seek failed $!'
read(LASTLOG, Sbuffer, $sizeof) == $sizeof or next;
($time, $lme, $host) = unpack($typedef, $buffer),
printf "%-8s UID %5d %s%s%s\n", $U->name, $U->uid,
$time "? ("at " . localtime($time)) : "never logged in",
$lme && " on $lme' ,
$host && ' from $hosf ;
 |
Каталоги
У UNIX есть свои недостатки, но файловая система к ним не относится.
Крис Торек
Введение
Для полноценного понимания работы с каталогами необходимо понимать механизмы, заложенные в ее основу. Наш материал ориентирован на файловую систему UNIX, поскольку функции каталогов Perl разрабатывались для системных функций и особенностей именно этой системы, однако в определенной степени он относится и к большинству других платформ.
Файловая система состоит из двух компонентов: набора блоков данных, где хранится содержимое файлов и каталогов, и индекса к этим блокам. Каждому объекту файловой системы, будь то обычный файл, каталог, ссылка или специальный файл (вроде файлов из каталога /dev), соответствует определенный элемент индекса. Элементы индекса называются индексными узлами (inode). Поскольку индекс является одномерным, индексные узлы определяются по номерам.
Каталог представляет собой файл специального формата, помеченный в индексном узле как каталог. Блоки данных каталога содержат множество пар. Каждая пара содержит имя объекта каталога и соответствующий ему индексный узел. Блоки данных каталога /usr/bin могут содержать следующую информацию:
|
Имя |
Индексный узел |
|
be |
17 |
|
du |
29 |
|
nvi |
8 |
|
pine |
55 |
|
vi |
8 |
Имена, хранящиеся в каталогах, не являются полными. Файл /usr/bin/vi хранится в каталоге /usr/bin под именем vi. Если открыть каталог /usr/bin и последовательно читать его элементы, вы увидите имена файлов (patch, login и vi) вместо полных имен /usr/bin/patch, /usr/bin/rlogin и /usr/bin/vi.
Однако индексный узел — больше, чем просто указатель на блоки данных. Каждый индексный узел также содержит информацию о типе представляемого объекта (каталог, обычный файл и т. д.) и его размере, набор битов доступа, информацию о владельце и группе, время последней модификации объекта, количество элементов каталога, ссылающихся на данный узел, и т. д.
Одни операции с файлами изменяют содержимое блоков данных файла; другие ограничиваются изменением индексного узла. Например, при дополнении или усечении файла в его индексном узле изменяется информация о размере. Некоторые операции изменяют элемент каталога, содержащий ссылку на индексный узел файла. Изменение имени файла влияет только на элемент каталога; ни данные файла, ни его индексный узел не изменяются.
В трех полях структуры индексного узла хранится время последнего обращения, изменения и модификации: atime, ctime и mtime. Поле atime обновляется при каждом чтении данных файла через указатель на его блоки данных. Поле mtime обновляется при каждом изменении содержимого файла. Поле ctime обновляется при каждом изменении индексного узла файла. Ctime не является временем создания; в стандартных версиях UNIX время создания файла определить невозможно.
При чтении файла изменяется только значение atime. Переименование файла не отражается на atime, ctime или mtime, поскольку изменяется лишь элемент каталога (хотя при этом меняются atime и mtime для каталога, в котором находится файл). Усечение файла не влияет на atime (поскольку мы не читаем, а лишь изменяем поле размера в элементе каталога), но изменяет ctime (из-за изменения поля размера) и mtime (из-за изменения содержимого, хотя бы и косвенного).
Чтобы получить индексный узел по имени файла или каталога, можно воспользоваться встроенной функцией stat. Например, индексный узел файла /usr/bin/vi может быть получен следующим образом:
gentry = stat("/usr/bin/vi") Or die "Couldn't stat /usr/bin/vi : $!"; Следующий фрагмент получает индексный узел для каталога /usr/bin: gentry = stat("/usr/bin") or die "Couldn't stat /usr/bin : $!"; Функция stat также вызывается и для файловых манипуляторов:
@entry = stat(INFILE) or die "Couldn't stat INFILE : $!";
Функция stat возвращает список значений, хранящихся в полях элемента каталога. Если получить информацию не удалось (например, если файл не существует), функция возвращает пустой список. В приведенных примерах пустой список проверялся конструкцией о г die. Не путайте с конструкцией 11 die, поскольку выражение будет преобразовано в скалярный контекст и функция stat сообщит лишь о том, успешно ли она была вызвана. Список при этом не возвращается. Впрочем, кэш _ (см. ниже) все же будет обновлен.
Элементы списка, возвращаемые функцией stat, перечислены в следующей таблице.
Элемент Обозначение Описание
dev Номер устройства в файловой системе
ino Номер индексного узла
mode Режим файла (тип и права доступа)
nlink Количество (прямых) ссылок на файл
uid Числовой идентификатор пользователя владельца
файла
gid Числовой идентификатор группы владельца файла
rdev Идентификатор устройства (только
для специальных файлов)
size Общий размер файла в байтах
at ime Время последнего обращения (в секундах с начала
эпохи)
mtime Время последней модификации (в секундах с начала
эпохи)
ctime Время изменения индексного узла (в секундах с начала
эпохи)
blksize Предпочтительный размер блока для операций
ввода/вывода в файловой системе
blocks Фактическое количество выделенных блоков
Стандартный модуль File::stat предоставляет именованный интерфейс к этим значениям. Он переопределяет функцию stat, поэтому вместо массива, описанного выше, функция возвращает объект с методами для получения каждого атрибута:
use File::stat;$inode = statC'/usr/bin/vi"); $ctime = $inode->ctime; $size = $inode->size;
Кроме того, в Perl предусмотрен набор операторов, вызывающих функцию stat и возвращающих лишь один атрибут. Эти операторы совокупно называются «операторами -X», поскольку их имена состоят из дефиса, за которым следует один символ. Они построены по образцу операторов test командного интерпретатора.
326 Глава 9 • Каталоги
-X Поле stat Значение
|
-г |
mode |
|
-w |
mode |
|
-X |
mode |
|
-0 |
mode |
|
-R |
mode |
|
-W |
mode |
|
-X |
mode |
|
-0 |
mode |
|
-e |
|
|
-z |
size |
|
-s |
size |
|
-f |
mode, rdev |
|
-d |
mode, rdev |
|
-1 |
mode |
|
-P |
mode |
|
-S |
mode |
|
-b |
rdev |
|
-c |
rdev |
|
-t |
rdev |
|
-u |
mode |
|
-g |
mode |
|
-k |
mode |
|
-T |
_ |
|
-B |
- |
|
-M |
mtime |
|
-A |
atime |
Файл может читаться фактическими UID/GID Файл может записываться фактическими UID/GID Файл может исполняться фактическими UID/GID Владельцем файла является фактический UID
Файл существует
Размер файла равен нулю
Размер файла отличен от нуля (возвращает размер)
Файл является обычным файлом
Файл является каталогом
Файл является символической ссылкой
Файл является именованным каналом (FIFO)
Файл является сокетом
Файл является блочным специальным файлом
Файл является символьным специальным файлом
Файловый манипулятор открыт для терминала
У файла установлен бит setuid У файла установлен бит setgid У файла установлен бит запрета
Файл является текстовым
Файл является двоичным (противоположность-Т)
Возраст файла в днях на момент запуска сценария То же для времени последнего обращения
Функция stat и операторы -X кэшируют значения, полученные при вызове системной функции stat(2). Если stat или оператор -X вызывается для специального файлового манипулятора _ (один символ подчеркивания), то вместо повторного вызова stat будет использована информация, хранящаяся в кэше. Это позволяет проверять различные атрибуты файла без многократного вызова stat(2) или возникновения опасности перехвата:
ореп( F, "< $filename" )or die "Opening Sfilename1 $!\n";
Введение 327
unless (-s F && -T _) {
die "$filename doesn't have text in it.\n , }
Однако отдельный вызов stat возвращает информацию лишь об одном индексном узле. Как же получить список содержимого каталога? Для этой цели в Perl предусмотрены функции opendir, readdir и closedir:
opendir(DIRHANDLE, "/usr/bin") or die "couldn't open /usr/bin ' $!"; while ( defined ($filename = readdir(DIRHANDLE)) ) {
print 'Inside /usr/bin is something called $filename\n '; } closedir(DIRHANDLE),
Функции чтения каталога намеренно разрабатывались по аналогии с функциями открытия и закрытия файлов. Однако если функция open вызывается для манипулятора файла, то opendir получает манипулятор каталога. Внешне они похожи, но работают по-разному: в программе могут соседствовать вызовы open (BIN, "/a/file ') и opendir(BIN, "/a/dir'), и Perl не запутается. Вы — возможно, но Perl точно не запутается. Поскольку манипуляторы файлов отличаются от манипуляторов каталогов, вы не сможете использовать оператор о для чтения из манипулятора каталога.
Имена файлов в каталоге не обязательно хранятся в алфавитном порядке. Чтобы получить алфавитный список файлов, прочитайте все содержимое каталога и отсортируйте его самостоятельно.
Отделение информации каталога от информации индексного узла может быть связано с некоторыми странностями. Операции, изменяющие каталог, требуют права записи для каталога, но не для файла. Большинство операций, изменяющих содержимое файла, требует права записи в файл. Операции, изменяющие права доступа к файлу, требуют, чтобы вызов осуществлялся владельцем файла или привилегированным пользователем. Могут возникнуть странные ситуации — например, появляется возможность удаления файла, который нельзя прочитать, или записи в файл, который нельзя удалить.
Хотя из-за подобных ситуаций файловая система на первый взгляд кажется нелогичной, в действительности они способствуют широте возможностей UNIX. Реализация ссылок (два имени, ссылающиеся на один файл) становится чрезвычайно простой — в двух элементах каталога просто указывается один номер индексного узла. Структура индексного узла содержит количество элементов каталога, ссылающихся на данный файл (nlink в списке значений, возвращаемых stat), что позволяет операционной системе хранить и поддерживать лишь одну копию времени модификации, размера и других атрибутов файла. При уничтожении ссылки на элемент каталога блоки данных удаляются лишь в том случае, если это была последняя ссылка для индексного узла данного файла, а сам файл не остается открытым ни в одном процессе. Можно вызвать unlink и для открытого файла, но дисковое пространство будет освобождено лишь после его закрытия последним процессом.
Ссылки делятся на два типа. Тип, описанный выше (два элемента каталога, в которых указан один номер индексного узла), называется прямой (или жесткой)
Резюме
Имена файлов хранятся в каталогах отдельно от размера, атрибутов защиты и прочих метаданных, хранящихся в индексном узле.
Функция stat возвращает информацию индексного узла (метаданные).
Функции opendir, readdir и их спутники обеспечивают доступ к именам файлов в каталоге с помощью манипулятора каталога.
Манипулятор каталога похож на файловый манипулятор, но не идентичен ему. В частности, для манипулятора каталога нельзя вызвать о.
Права доступа к каталогу определяют, можете ли вы прочитать или записать список имен файлов. Права доступа к файлу определяют, можете ли вы изменить метаданные или содержимое файла.
В индексном узле хранятся три атрибута времени. Ни один из них не определяет время создания файла.
9.1. Получение и установка атрибутов времени
Проблема
Требуется получить или изменить время последней модификации (записи или изменения) или обращения (чтения) для файла.
Решение
Функция stat получает атрибуты времени, а функция utime устанавливает их значения. Обе функции являются встроенными в Perl:
(SREADTIME, SWRITETIME) = (stat($filename))[8,9]; utime($NEWREADTIME, $NEWWRITETIME, Sfilename);
Комментарий
Как говорилось во введении, в традиционной файловой системе UNIX с каждым индексным узлом связываются три атрибута времени. Любой пользователь может установить значения atime и mtime функцией utime, если он имеет право записи в каталог, содержащий файл. Изменить ctime практически невозможно. Следующий пример демонстрирует вызов функции utime:
$SECONDS_PER_DAY = 60 » 60 * 24; ($atime, Smtime) = (stat($file))[8,9]; Satime -= 7 * $SECONDS_PER_DAY; Smtime -= 7 ¦ $SEC0NDS_PER_0AY;
utime($atime, Smtime, $file)
or die "couldn't backdate $file by a week w/ utime: $!";
Функция utime должна вызываться для обоих атрибутов, atime и mtime. Если вы хотите задать лишь одно из этих значений, необходимо предварительно получить другое с помощью функции stat:
Smtime = (stat $file)[9J; utime(time, Smtime, Sfile);
Применение модуля File::stat упрощает этот фрагмент:
use File::stat;
utime(time, stat($file)->mtime, Sfile);
Функция utime позволяет сделать вид, будто к файлу вообще никто не притрагивался (если не считать обновления ctime). Например, для редактирования файла можно воспользоваться программой из примера 9.1.
Пример 9.1. uvi
#!/usr/bin/perl -w
# uvi - редактирование файла в vi без изменения атрибутов времени
Sfile = shift or die "usage: uvi filename\n"; ($atime, Smtime) = (stat($file))[8,9]; system($ENV{EDITOR} || "vi", Sfile); utime($atime, Smtime, Sfile)
or die "couldn't restore Sfile to orig times: $!";
D> Смотри также------------------------------------------------------------------------------------------
Описание функций stat и utime в perlfunc(l); стандартный модуль File;:stat и страница руководства utime(3).
9.2. Удаление файла
Проблема
Требуется удалить файл. Функция Perl delete вам не подходит.
Решение
Воспользуйтесь функцией Perl unlink:
unlink(SFILENAME) or die "Can't delete SFILENAME: $!\n"
unlink(@FILENAMES) == ^FILENAMES or die
"Couldn't unlink all of ©FILENAMES: $!\n";
Функция unlink была названа по имени системной функции UNIX. В Perl она получает список имен файлов и возвращает количество успешно удаленных файлов. Возвращаемое значение можно проверить с помощью | | или or:
unlmk($file) or die Can t unlink $file V
Функция unlink не сообщает, какие файлы не были удалены — лишь их общее количество. Следующий фрагмент проверяет, успешно ли состоялось удаление нескольких файлов, и выводит количество удаленных файлов:
unless (($count = unlmk(@filelist)) == @fllelist) { warn could only delete Scount of (@filelist) files , >
Перебор @fllelist в цикле foreach позволяет выводить отдельные сообщения об ошибках.
В UNIX удаление файла из каталога требует права записи для каталога1, а не для файла, поскольку изменяется именно каталог. В некоторых ситуациях появляется возможность удаления файла, в который запрещена запись, или записи в файл, который нельзя удалить.
Если удаляемый файл открыт некоторым процессом, операционная система удаляет элемент каталога, но не освобождает блоки данных до закрытия файла во всех процессах. Именно так работает функция newjtrnpf lie в IO.File (см рецепт 7.5).
> Смотри также---------------------------------------------------------------------------------------------
Описание функции unlink в perlfunc(l); страница руководства unhnk{2). Идея с удаленным файлом, который продолжает оставаться доступным, применяется в рецепте 7.5.
9.3. Копирование или перемещение файла
Проблема
Необходимо скопировать файл, однако в Perl не существует встроенной команды копирования.
Решение
Воспользуйтесь функцией сору стандартного модуля File::Copy.
use File Copy, copy($oldfile, Snewfile),
9.3. Копирование или перемещение файла 331 То же самое делается и вручную:
|
open(IN, |
< |
Soldfile ) |
or |
die |
can |
t |
open |
$oldfile |
$i |
|
open(OUT, |
> |
Snewfile ) |
or |
die |
can |
t |
open |
Snewfile |
$' |
while ($len = sysread IN, $buf, $blksize) { if (idefined $len) {
next if V =~ /"Interrupted/ die System read error $'\n , >
$offset = 0,
while ($len) { # Частичные операции записи
defmed($written = syswnte OUT $buf, $len, Soffset)
or die System write error $'\en $len -= $written, $offset += Swntten,
close(IN) close(OUT),
Также можно воспользоваться программой сору вашей системы:
system( cp $oldfile $newfile ), # unix
systera( copy Soldfile $newfile ) # dos, vms
Комментарий
Модуль File::Copy содержит функции copy и move. Они удобнее низкоуровневых функций ввода/вывода и обладают большей переносимостью по сравнению с вызовом system. Функция move допускает перемещение между каталогами, а стандартная функция Perl rename — нет (обычно).
use File Copy,
сору( datafile dat , datafile bak ) or die copy failed $'
move( datafile new , datafile dat ) or die move failed $' ,
Поскольку обе функции возвращают лишь простой признак успешного завершения, вы не сможете легко определить, какой файл помешал успешному копированию или перемещению. При ручном копировании файлов можно узнать, какие файлы не были скопированы, но в этом случае ваша программа забивается сложными вызовами sysread и syswnte.
Смотри также
Описание функций rename, read и syswnte вperlfunc(l); документация по стандартному модулю File::Copy.
Проблема
Требуется узнать, соответствуют ли два имени файла из списка одному и тому же файлу на диске (благодаря жестким и символическим ссылкам два имени могут ссылаться на один файл). Такая информация поможет предотвратить модификацию файла, с которым вы уже работаете.
Решение
Создайте хэш, кэшируемый по номеру устройства и индексного узла для уже встречавшихся файлов. В качестве значений хэша используются имена файлов:
%seen = ();
sub do_my_thing {
my $filename = shift;
my ($dev, $ino) = stat $filename;
unless (! $seen{$dev, $ino}++) {
# Сделать что-то с Sfilename, поскольку это имя
# нам еще не встречалось
Комментарий
Ключ %seen образуется объединением номеров устройства ($dev) и индексного узла ($ino) каждого файла. Для одного файла номера устройства и индексного узла совпадут, поэтому им будут соответствовать одинаковые ключи.
Если вы хотите вести список всех файлов с одинаковыми именами, то вместо подсчета экземпляров сохраните имя файла в анонимном массиве:
foreach $filenarne (©files) {
($dev, $ino) = stat Sfilename;
push( @< $seen{$dev,$ino} >, Sfilename);
foreach $devino (sort keys %seen) {
($dev, $ino) = split(/$;/o, $devino); if (@{$seen{$devino}> > 1) {
# @{$seen{$devino}} - список имен одного файла
Переменная $; содержит строку-разделитель и использует старый синтаксис эмуляции многомерных массивов, $hash{$x, $y, $z}. Хэш остается одномерным,
однако он имеет составной ключ. В действительности ключ представляет собой join($; =>$x, $y, $z). Функция split снова разделяет составляющие. Хотя многоуровневый хэш можно использовать и напрямую, здесь в этом нет необходимости и дешевле будет обойтись без него.
> Смотри также---------------------------------------------------------------------------------------------
Описание переменной $; вperlvai~(l); описание функции stat вperlfunc(\).
9.5. Обработка всех файлов каталога
Проблема
Требуется выполнить некоторые действия с каждым файлом данного каталога.
Решение
Откройте каталог функцией opendir и последовательно читайте имена файлов функцией readdir:
opendir(DIR, $dirname) or die "can't opendir $dirname: $!"; while (defined($file = readdir(DIR))) { # Сделать что-то с "$dirname/$file" } closedir(DIR);
Комментарий
Функции opendir, readdir и closedir работают с каталогами по аналогии с функциями open, read и close, работающими с файлами. В обоих случаях используются манипуляторы, однако манипуляторы каталогов, используемые opendir и другими функциями этого семейства, отличаются от файловых манипуляторов функции open и других. В частности, для манипулятора каталога нельзя использовать оператор о.
В скалярном контексте readdi г возвращает следующее имя файла в каталоге, пока не будет достигнут конец каталога — в этом случае возвращается undef. В списковом контексте возвращаются остальные имена файлов каталога или пустой список, если файлов больше нет. Как объяснялось во введении, имена файлов, возвращаемые readdir, не содержат имя каталога. При работе с именами, полученными от readdir, необходимо либо заранее перейти в нужный каталог, либо вручную присоединить его к имени.
Ручное присоединение может выглядеть так:
$dir = "/usr/local/bin"; print "Text files in $dir are:\n"; opendir(BIN, $dir) or die "Can't open $dir: $!"; wbile( defined ($file = readdir BIN) ) { print "$file\n" if -T "$dir/$file";
Мы проверяем $file с помощью defined, поскольку простое условие while ($file = readdi г BIN) проверяет истинность, а не определенность. Хотя наш цикл завершается после перебора всех файлов, возвращаемых readdi г, он также завершится преждевременно при наличии файла с именем "О".
Функция readdi г также возвращает специальные каталоги "." (текущий каталог) и ". ." (родительский каталог). Обычно они пропускаются фрагментом следующего вида:
while ( defined ($file = readdir BIN) ) {
next if $file =" /"\.\.?$/; # Пропустить . и ..
Манипуляторы каталогов, как и файловые манипуляторы, существуют на уровне пакетов. Более того, локальный манипулятор каталога можно получить двумя способами: с помощью local *DIRHANDLE или модуля (см. рецепт 7.16). В данном случае нужен модуль DirHandle. Следующий фрагмент использует DirHandle для получения отсортированного списка обычных файлов, которые не являются «скрытыми» (имена которых не начинаются с "."):
use DirHandle;
sub plainflies {
my $dir = shift;
my $dh = DirHandle->new($dir) or die "can't opendir $dir: $!";
return sort # Отсортировать имена
grep { -f } # Выбрать "обычные" файлы
map { "$dir/$_" } # Построить полные пути
grep { !/~\./ } # Отфильтровать скрытые файлы
$dh->read(); й Прочитать все элементы }
Метод read модуля DirHandle работает так же, как и readdir, и возвращает остальные имена файлов. Нижний вызов grep оставляет лишь те имена, которые не начинаются с точки. Вызов тар преобразует имена файлов, полученные от read, в полные, а верхний вызов g rep отфильтровывает каталоги, ссылки и т. д. Полученный список сортируется и возвращается.
В дополнение к readdir также существуют функции rewinddir (перемещает манипулятор каталога к началу списка файлов), seekdir (переходит к конкретному смещению в списке) и telldir (определяет смещение от начала списка).
> Смотри также---------------------------------------------------------------------------------------------
Описание функций closedir, opendir, readdir, rewinddir, seekdir и telldir в perlfunc(i); документация по стандартному модулю DirHandle.
9.6. Получение списка файлов по шаблону
Проблема
Требуется получить список файлов по шаблону, аналогичному конструкциям *.* (MS-DOS) и *.h (UNIX).
Решение
Семантика командного интерпретатора С shell системы UNIX поддерживается в Perl с помощью ключевого слова glob и оператора <>:
©list = о. о; @list = glob("*.c");
Для ручного извлечения имен файлов можно воспользоваться функцией readdir:
opendir(DIR, $path);
©files = grep { /\.c$/ } readdir(DIR);
closedir(DIR);
Модуль File::KGlob от CPAN получает список файлов без ограничений длины:
use File::KGlob;
©files = glob("*.c");
Комментарий
Встроенная функция Perl glob и запись <ШАБЛОН> (не путать с записью <МАНИПУ-ЛЯТОР>!) в настоящее время на большинстве платформ используют внешнюю программу для получения списка файлов. В UNIX это программа csh\ а в Windows — dosglob.exe. На Macintosh и в VMS это реализуется на внутреннем уровне, без внешних программ. Предполагается, что шаблоны обеспечивают семантику С shell во всех системах, отличных от UNIX, и улучшают переносимость. Из-за использования интерпретатора в UNIX такое решение не подходит для сценариев с атрибутом setuid.
Чтобы справиться с затруднениями, можно реализовать собственный механизм отбора с применением встроенного оператора opendir или модуля File::KGlob от CPAN — в обоих случаях внешние программы не используются. File::KGlob обеспечивает семантику отбора по типу интерпретаторов UNIX, тогда как opendir позволяет отбирать файлы с помощью регулярных выражений Perl.
В простейшем решении с opendir список, возвращаемый readdir, фильтруется с помощью grep:
©files = grep { /\.[ch]$/i } readdir(OH);
use DirHandle,
$dh = DirHandle->new($path) or die Can t open $path $'\n , @files = grep { /\ [ch]$/i } $dh->read(),
Как обычно, возвращаемые имена файлов не содержат каталога. При использовании имени каталог приходится присоединять вручную:
opendir(DH, $dir) or die Couldn t open $dir for reading $' ,
©files = ()
while( defined ($file = readdir(DH)) ) { next unless /\ [ch]$/i
my $filename = $dir/$file , push(@files, $filename) if -T $file,
В следующем примере чтение каталога и фильтрация для повышения эффективности объединяются с преобразованием Шварца (см. главу 4 «Массивы»), В массив @dirs заносится отсортированный список подкаталогов, имена которых представляют собой числа:
|
# |
Извлечение имен |
||
|
->[0] } |
# |
Числовая сортировка |
имен |
|
# |
Каталоги |
||
|
_ ] } |
# |
Сформировать (имя, |
путь) |
|
й |
Только числа |
||
|
# |
Все файлы |
sort { $а->[0] <=> grep { -d $_->[1] } тар { [ $_, $path/$_ grep { /~\d+$/ } readdir(DIR),
В рецепте 4.14 показано, как читать подобные странные конструкции. Как обычно, форматирование и документирование кода заметно упрощает его чтение и понимание.
D> Смотри также---------------------------------------------------------------------------------------------
Описание функций closedir, opendir, readdir, rewinddir, seekdir и telldir в perlfunc(l); документация по стандартному модулю DirHandle; раздел «I/O Operators» perlop(l); рецепты 6.9; 9.7.
9.7. Рекурсивная обработка всех файлов каталога
Проблема
Требуется выполнить некоторую операцию с каждым файлом и подкаталогом некоторого каталога.
Решение
Воспользуйтесь стандартным модулем File::Find.
use File Find, sub process_file {
# Делаем то, что хотели } find(\&process_file, @DIRLIST),
Комментарий
Модуль File:: Fmd обеспечивает удобные средства рекурсивной обработки файлов. Просмотр каталога и рекурсия организуются без вашего участия. Достаточно передать find ссылку на функцию и список каталогов. Для каждого файла в этих каталогах find вызовет заданную функцию.
Перед вызовом функции find переходит в указанный каталог, имя которого по отношению к начальному каталогу хранится в переменной $File Find dir. Переменной $_ присваивается базовое имя файла, а полный путь к этому файлу находится в переменной $File Find name. Ваша программа может присвоить $File Find prune истинное значение, чтобы функция find не спускалась в только что просмотренный каталог.
Использование File::Find демонстрируется следующим простым примером. Мы передаем find анонимную подпрограмму, которая выводит имя каждого обнаруженного файла и добавляет к именам каталогов /:
@ARGV = qw( ) unless @ARGV
use File Find,
find sub { print $File Find name, -d && / , \n }, @ARGV,
Для вывода / после имен каталогов используется оператор проверки -d, который при отрицательном результате возвращает пустую строку ''.
Следующая программа выводит суммарный размер всего содержимого каталога. Она передает find анонимную подпрограмму для накопления текущей суммы всех рассмотренных ей файлов. Сюда входят не только обычные файлы, но и все типы индексных узлов, включая размеры каталогов и символических ссылок. После выхода из функции find программа выводит накопленную сумму.
use File Find,
@ARGV = (' ') unless @ARGV,
my $sum = 0,
find sub { $sum += -s }, @ARGV,
print @ARGV contains $sum bytes\n ,
Следующий фрагмент ищет самый большой файл в нескольких каталогах:
use File Find,
@ARGV = ( ) unless @ARGV,
my ($saved_size, $saved_name) = (-1, ''),
sub biggest {
return unless -f && -s _ > $saved_size,
$saved_size = -s _,
$saved_name = $File Find name, }
find(\&biggest, @ARGV), print Biggest file $saved_name in @ARGV is $saved_size bytes long \n ,
Программу нетрудно изменить так, чтобы она находила файл, который изменялся последним:
use File::Find;
@ARGV = ('.') unless @ARGV;
my (Sage, $name);
sub youngest {
return if defined Sage && Sage > -M;
$age = (stat(_))[9];
$name = $File::Find::name; }
find(\&youngest, @ARGV); print "Sname " . scalar(localtime($age)) . "\n";
Модуль File::Find не экспортирует имя переменной $name, поэтому на нее следует ссылаться по полному имени. Пример 9.2 демонстрирует скорее работу с пространствами имен, нежели рекурсивный перебор в каталогах. Он делает переменную $name текущего пакета синонимом переменной File::Find (в сущности, именно на этом основана работа модуля Exporter). Затем мы объявляем собственную версию find с прототипом, обеспечивающим более удобный вызов.
Пример 9.2. fdirs
#!/usr/bin/perl -lw
# fdirs - поиск всех каталогов
@ARGV = qw(.) unless @ARGV;
use File::Find ();
sub find(&@) { &File::Find::find }
«name = *File::Find::name;
find { print $name if -d } @ARGV;
Наша версия find вызывает File::Find, импортирование которой предотвращается включением пустого списка () в команду use. Вместо записи вида:
find sub { print $File::Find::name if -d }, @ARGV; можно написать более приятное
find { print $name if -d > @>ARGV;
> Смотри также---------------------------------------------------------------------------------------------
Man-страница find(l); рецепт 9.6; документация по стандартным модулям File::Find и Exporter.
9.8. Удаление каталога вместе с содержимым
Проблема
Требуется рекурсивно удалить ветвь дерева каталога без применения гт -г.
Решение
Воспользуйтесь функцией f inddepth модуля File::Find (см. пример 9.3). Пример 9.3. rmtreel
#!/usr/bin/perl
# rmtreel - удаление ветви дерева каталогов (по аналогии с гт -г)
use File::Find qw(finddepth);
die "usage: $0 dir ..\n" unless @ARGV; «name = *File::Find::name; finddepth \&zap, @ARGV; sub zap {
if (!-l && -d _) {
print "rmdir $name\n";
rmdir($name) or warn "couldn't rmdir $name: $!"; } else {
print "unlink $name";
unlink($name) or warn "couldn't unlink $name: $!"; } }
Или воспользуйтесь функцией rmtree модуля File::Path (см. пример 9.4). Пример 9.4. rmtree2
#!/usr/bin/perl
# rmtree2 - удаление ветви дерева каталогов (по аналогии с гт -г)
use File::Path;
die "usage: $0 dir . .\n" unless @ARGV;
foreach $dir (@ARGV) {
rmtree($dir); }
> Предупреждение------------------------------------------------------------------------------ ¦——
Эти программы удаляют целые ветви дерева каталогов. Применяйте крайне осторожно!
Комментарий
Модуль File::Find экспортирует функцию find, которая перебирает содержимое каталога практически в случайном порядке следования файлов, и функцию finddepth, гарантирующую перебор всех внутренних файлов перед посещением самого каталога. Именно этот вариант поведения использован нами для удаления каталога вместе с содержимым.
Перед тем как проверять, является ли файл каталогом, необходимо узнать, не является ли он символической ссылкой, -d возвращает true и для каталога, и для символической ссылки на каталог. Функции stat, lstat и операторы проверки (типа -d) используют системную функцию stat(2), которая возвращает всю информацию о файле, хранящуюся в индексном узле. Эти функции и операторы сохраняют полученную информацию и позволяют выполнить дополнительные проверки того же файла с помощью специального манипулятора _. При этом удается избежать лишних вызовов системных функций, возвращающих старую информацию и замедляющих работу программы.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций unlink, rmdir, lstat и stat в perlfunc(l); документация по стандартному модулю File::Find; man-страницы ?ти(1) и stat(2); раздел perl-func(l), посвященный операторам -X.
9.9. Переименование файлов
Проблема
Требуется переименовать файлы, входящие в некое множество.
Решение
Воспользуйтесь циклом foreach и функцией rename:
foreach $file (@NAMES) { my Inewname = $file; ft change $file rename($file, $newname) or
warn "Couldn't rename $file to Snewname: $!\n";
Комментарий
Программа вполне тривиальна. Функция rename получает два аргумента — старое и новое имя. Функция rename предоставляет интерфейс к системной функции переименования, которая обычно позволяет переименовывать файлы только в том случае, если старое и новое имена находятся в одной файловой системе.
После небольших изменений программа превращается в универсальный сценарий переименования вроде написанного Ларри Уоллом (см. пример 9.5).
Пример 9.5. rename
#'/usr/bin/perl -w
# rename - переименование файлов от Ларри
$ор = shift or die "Usage: rename expr [files]\n";
chomp(@ARGV = <STDIN>) unless @ARGV;
for (@ARGV) { $was = $_; eval Sop; die $@ if $@; rename($was,$_) unless $was eq $_;
Первый аргумент сценария — код Perl, который изменяет имя файла, хранящееся в $_, и определяет алгоритм переименования. Вся черная работа поручается функции eval. Кроме того, сценарий пропускает вызов rename в том случае, если имя осталось прежним. Это позволяет просто использовать универсальные символы (rename EXPR *) вместо составления длинных списков имен.
Приведем пять примеров вызова программы rename из командного интерпретатора:
% rename 's/\.orig$//' ¦.orig
% rename 'tr/A-Z/a-z/ unless /"Make/' *
% rename '$_ .= ".bad"' *.f
% rename 'print "$_: "; s/foo/bar/ if <STDIN> =~ /~y/i' *
% find /tmp -name '•"' -print | rename 's/"(.+)"$/.#$1/'
Первая команда удаляет из имен файлов суффикс .orig.
Вторая команда преобразует символы верхнего регистра в символы нижнего регистра. Поскольку вместо функции 1с используется прямая трансляция, такое преобразование не учитывает локальный контекст. Проблема решается следующим образом:
% rename 'use locale; $_ = lc($_) unless/"Make/' *
Третья команда добавляет суффикс .bad к каждому файлу Fortran с суффиксом ". f" — давняя мечта многих программистов.
Четвертая команда переименовывает файлы в диалоге с пользователем. Имя каждого файла отправляется на стандартный вывод, а из стандартного ввода читается ответ. Если пользователь вводит строку, начинающуюся с "у" или "Y", то все экземпляры "foo" в имени файла заменяются на "bar".
Пятая команда с помощью find ищет в /tmp файлы, имена которых заканчиваются тильдой. Файлы переименовываются так, чтобы они начинались с префикса .#. В сущности, мы переключаемся между двумя распространенными конвенциями выбора имен файлов, содержащих резервные копии.
В сценарии rename воплощена вся мощь философии UNIX, основанной на утилитах и фильтрах. Конечно, можно написать специальную команду для преобразования символов в нижний регистр, однако ничуть не сложнее написать гибкую, универсальную утилиту с внутренним eval. Позволяя читать имена файлов из стандартного ввода, мы избавляемся от необходимости рекурсивного перебора каталога. Вместо этого мы используем функцию find, которая прекрасно справляется с этой задачей. Не стоит изобретать колесо, хотя модуль File::Find позволяет это сделать.
> Смотри также---------------------------------------------------------------------------------------------
Описание функции rename вperifunc{\)\ страницы руководства mv(l) и гепате(2); документация по стандартному модулю File::Find.
342 Глава 9 • Каталоги
9.10. Деление имени файла на компонентыПроблема
Имеется строка, содержащая полное имя файла. Из нее необходимо извлечь компоненты (имя, каталог, расширение (-я)).
Решение
Воспользуйтесь функциями стандартного модуля File::Basename.
use File::Basename;
$base = basename(Spath);
$dir = dirname($path);
($base, $dir, $ext) = fileparse($path);
Комментарий
Функции деления имени файла присутствуют в стандартном модуле File::Base-name. Функции dirname и basename возвращают соответственно каталог и имя файла:
$path = '/usr/lib/libc.a'; $file = basename($path); $dir = dirname($path);
print "dir is $dir, file is $file\n"; tt dir is /usr/lib, file is libc.a
Функция fileparse может использоваться для извлечения расширений. Для этого передайте fileparse полное имя и регулярное выражение для поиска расширения. Шаблон необходим из-за того, что расширения не всегда отделяются точкой. Например, что считать расширением в ".tar.gz" — ".tar", ".gz" или ".tar.gz"? Передавая шаблон, вы определяете, какой из перечисленных вариантов будет возвращен:
$path = '/usr/lib/libc.a'; ($name,$dir,$ext) = fileparse($path,'\-¦*')'.
print "dir is $dir, name is $name, extension is $ext\n"; # dir is /usr/lib/, name is libc, extension is .a
По умолчанию в работе этих функций используются разделитель, определяемый стандартными правилами вашей операционной системы. Для этого используется переменная $~0; содержащаяся в ней строка идентифицирует текущую систему. Ее значение определяется в момент построения и установки Perl. Значение по умолчанию можно установить с помощью функции f ileparse_set_f stype. В результате изменится и поведение функций File::Basename при последующих вызовах:
9.11. Программа: symirror 343
fileparse_set_fstype("MacOS");
$path = "Hard%20Drive:System%20Folder:README.txt";
($nane,$dir,$ext) = fileparse($path,'\..*');
print "dir is $dir, name is $name, extension is $ext\n";
# dir is Hard%20Drive:System%20Folder, name is README, extension is .txt
Расширение можно получить следующим образом: ,
sub extension {
my $path = shift;
my $ext = (fileparse($path, Д.. *'))[2];
$ext =~ s/"\.//;
return $ext; }
Для файла source.c.bak вместо простого "bak" будет возвращено расширение "с. bak". Если вы хотите получить именно "bak", в качестве второго аргумента fileparse используйте ' \. . *?'.
Если передаваемое полное имя заканчивается разделителем каталогов (например, lib/), fileparse считает, что имя каталога равно "lib/", тогда как dirname считает его равным ".".
\> Смотри также--------------------------------------------------------------------------------------------
Описание переменной $"0 вperlvai-(l); документация по стандартному модулю File::Basename.
9.11. Программа: symirror
Программа из примера 9.6 рекурсивно воспроизводит каталог со всем содержимым и создает множество символических ссылок, указывающих на исходные файлы.
Пример 9.6. symirror
#! /usr/bin/perl -w
# symirror - дублирование каталога с помощью символических ссылок
use strict;
use File;:Find;
use Cwd;
my ($srcdir, Sdstdir);
my $cwd = getcwd();
die "usage: $0 realdir mirrordir" unless @ARGV == 2;
for ((Ssrcdir, $dstdir) = @ARGV) { my $is_dir = -d;
next if $is_dir; # Нормально
if (defined ($is_dir)) {
die "$0: $_ is not a directory\n";
продолжение &
344 Глава 9 • Каталоги Пример 9.6 (продолжение)
} else { # Создать каталогmkdir($dstdir, 07777) or die "can't mkdir $dstdir: $!"; } } continue {
s#~(?!/)#$cwd/#; # Исправить относительные пути
chdir $srcdir; find(\&wanted, '.');
sub wanted {
my($dev, $ino, $mode) = lstat($_); my $name = $File::Find::name;
$mode &= 07777; # Сохранить права доступа
$name =~ s!~\./!!.' # Правильное имя
if (-d _) { # Затем создать каталог
mkdir("$dstdir/$name", $mode)
or die "can't mkdir $dstdir/$name: $!";
} else { # Продублировать все остальное
symlink("$srcdir/$name", "$dstdir/$name")
or die "can't symlink $srcdir/$name to $dstdir/$name: $!'
9.12. Программа: 1st
Вам не приходилось отбирать из каталога самые большие или созданные последними файлы? В стандартной программе Is предусмотрены параметры для сортировки содержимого каталогов по времени (флаг -t) и для рекурсивного просмотра подкаталогов (флаг -R). Однако Is делает паузу для каждого каталога и выводит только его содержимое. Программа не просматривает все подкаталоги, чтобы потом отсортировать найденные файлы.Следующая программа 1st справляется с этой задачей. Ниже показан пример подробного вывода, полученного с использованием флага -1:
% 1st -1 /etc
|
12695 0600 1 |
root |
wheel |
|
/etc/ssh_random_seed |
||
|
12640 0644 1 |
root |
wheel |
|
/etc/Id.so.cache |
||
|
12626 0664 1 |
root |
wheel |
|
/etc/psdevtab |
||
|
12304 0644 1 |
root |
root |
|
/etc/exports |
||
|
12309 0644 1 |
root |
root |
|
/etc/inetd.conf |
||
|
12399 0644 1 |
root |
root |
|
/etc/sendmail.cf |
||
|
18774 0644 1 |
gnat |
perldoc |
10104 Моп May 25 7:39:19 1998
12288 Sun May 24 19:23:08 1998
237 Sun May 24 13:59:33 1998
3386 Sun May 24 13:24:33 1998
30205 Sun May 24 10:08:37 1998
2199 Sun May 24 9:35:57 1998
9.12. Программа: 1st 345
/etc/X11/XMetroconfig 12636 0644 1 root wheel 290 Sun May 24 9:05:40 1998
/etc/mtab 12627 0640 1 root root 0 Sun May 24 8:24:31 1998
/etc/wtmplock 12310 0644 1 root tchrist 65 Sun May 24 8:23:04 1998
/etc/issue
Файл /etc/X11/XMetroconfig оказался посреди содержимого /etc, поскольку листинг относится не только к /etc, но и ко всему, что находится внутри каталога.
К числу поддерживаемых параметров также относится сортировка по времени последнего чтения вместо записи (-и) и сортировка по размеру вместо времени (-s). Флаг -i приводит к получению списка имен из стандартного ввода вместо рекурсивного просмотра каталога функцией find. Если у вас уже есть готовый список имен, его можно передать 1st для сортировки.
Исходный текст программы приведен в примере 9.7.
Пример 9.7. 1st
#!/usr/bin/perl
# 1st - вывод отсортированного содержимого каталогов
use Getopt::Std;
use File::Find;
use File::stat;
use User::pwent;
use User::grent;
getopts('lusrcmi') or die «DEATH; Usage: $0 [-mucsril] [dirs ...] or $0 -i [-mucsrl] < filelist
Input format:
-i read pathnames from stdin Output format:
-1 long listing Sort on:
-m use mtime (modify time) [DEFAULT]
-u use atime (access time)
-c use ctime (inode change time)
-s use size for sorting Ordering:
-r reverse sort
NB: You may only use select one sorting option at a time. DEATH
unless ($opt_i || @ARGV) { @ARGV = ('.') }
if ($opt_c + $opt_u + $opt_s + $opt_m > 1) {
продолжение &
die can only sort on one time or size , }
$IDX = mtine ,
$IDX = atime if $opt_u,
$IDX = ctime if $opt_c,
$IDX = size if $opt_s,
$TIME_IDX = $opt_s ? mtime $IDX
*name = *File Find name, # Принудительное импортирование переменной
Я Флаг $opt_i заставляет wanted брать имена файлов # из ARGV вместо получения от find
if ($opt_i) {
•name = *_ # $name теперь является синонимом $_ while (о) { chomp, &wanted } В Все нормально это не stdin } else {
fmd(\&wanted, @ARGV)
# Отсортировать файлы по кэшированным значениям времени,
# начиная с самых новых
@skeys = sort { $time{$b} <=> $time{$a} } keys %time,
# Изменить порядок, если в командной строке был указан флаг -г
@skeys = reverse @skeys if $opt_r
for ((°>skeys) {
unless ($opt_l) { # Эмулировать Is -1, кроме прав доступа print $_\n , next, }
$now = localtine $stat{$_}->$TIME_IDX(), printf %6d %04o %6d %8s %8s %8d %s %s\n , $stat{$_}->mo(), $stat{$_}->mode() & 07777, $stat{$_}->nlink(), user($stat{$_}->uid()), group($stat{$J->gid()), $stat{$_}->size(), Snow, $_,
# Получить от stat информацию о файле сохраняя критерий
# сортировки (mtime, atime, ctime или size)
# в хэше %time, индексируемом по имени файла
# Если нужен длинный список, весь объект stat приходится
# сохранять в %stat Да, это действительно хэш объектов sub wanted {
my $sb = stat($_), # XXX stat или lstaf
return unless $sb,
$time{$name} = $sb->$IDX(), # Косвенный вызов метода
$stat{$name} = $sb if $opt_l,
# Кэширование преобразований идентификатора пользователя в имя sub user {
my $uid = shift,
$user{$uid} = getpwuid($uid)->name || #$uid unless defined $user{$uid}
return $user{$uid},
# Кэширование преобразований номера группы в имя sub group {
my $gid = shift,
$group{$gid> = getgrgid($gid)->name || unless defined $group{$gid},
return $group{$gid}
Подпрограммы
Огнем бессмертным наполняя смертных... В. Оден, «Три песни ко Дню святой Сесилии»
Введение
Практика вставки/копирования кода довольно опасна, поэтому в больших программах многократно используемые фрагменты кода часто оформляются в виде подпрограмм. Для нас термины «подпрограмма» (subroutine) и «функция» (function) будут эквивалентными, поскольку в Perl они различаются ничуть не больше, чем в С. Даже объектно-ориентированные методы представляют собой обычные подпрограммы со специальным синтаксисом вызова, описанным в главе 13 «Классы, объекты и связи».
Подпрограмма объявляется с помощью ключевого слова sub. Пример определения простой подпрограммы выглядит так:
sub hello {
$greeted++; # Глобальная переменная
print 'hi there\n'' ; }
Типичный способ вызова этой подпрограммы выглядит следующим образом:
helloQ; # Подпрограмма hello вызывается без аргументов/параметров
Перед выполнением программы Perl компилирует ее, поэтому место объявления подпрограммы не имеет значения. Определения не обязаны находиться в одном файле с основной программой. Они могут быть взяты из других файлов с помощью операторов do, require или use (см. главу 12 «Пакеты, библиотеки и модули»), создаваться «на месте» с помощью ключевого слова eval или механизма AUTOLOAD или генерироваться посредством замыканий, используемых в шаблонах функций.
Если вы знакомы с другими языками программирования, некоторые особенности функций Perl могут показаться странными. В большинстве рецептов этой главы показано, как применять эти особенности в свою пользу.
• Функции Perl не имеют формальных, именованных параметров, но это не
всегда плохо (см. рецепты 10.1 и 10.7).
• Все переменные являются глобальными, если обратное не следует из объяв
ления. Дополнительная информация приведена в рецептах 10.1 и 10.7.
• Передача или возвращение нескольких массивов или хэшей обычно приво
дит к потере ими «индивидуальности». О том, как избежать этого, расска
зано в рецептах 10.5, 10.8, 10.9 и 10.11.
• Функция может узнать свой контекст вызова (списковый или скалярный),
количество аргументов при вызове и даже имя функции, из которой она
была вызвана. О том, как это сделать, рассказано в рецептах 10.4 и 10.6.
• Используемое в Perl значение undef может использоваться в качестве при
знака ошибки, поскольку ни одна допустимая строка или число никогда не
принимает это значение. В рецепте 10.10 описаны некоторые неочевидные
трудности, связанные с undef, которых следует избегать, а в рецепте 10.12 по
казано, как обрабатываются другие катастрофические случаи.
• В Perl функции обладают рядом интересных возможностей, редко встреча
ющихся в других языках (например, анонимные функции, создание функ
ций «на месте» и их косвенный вызов через указатель на функцию). Эти
мистические темы рассматриваются в рецептах 10.14 и 10.16.
При вызове вида $х = &func; функция не получает аргументов, но зато может напрямую обращаться к массиву @_ вызывающей стороны! Если убрать ампер-санд и воспользоваться формой func() или func, создается новый, пустой экземпляр массива @_.
10.1. Доступ к аргументам подпрограммы
Проблема
В своей функции вы хотите использовать аргументы, переданные вызывающей стороной.
Решение
Все значения, переданные функции в качестве аргументов, хранятся в специальном массиве @_. Следовательно, первый аргумент хранится в элементе $_[0], второй — в $_[1] и т. д. Общее число аргументов равно scalar(@_). Например:
sub hypotenuse {
return sqrt( ($_[0] •• 2) + ($_[1] *¦ 2) );
$diag = hypotenuse(3,4); # $diag = 5
sub hypotenuse {
my ($side1, $side2) = <°>_;
return sqrt( ($side1 ** 2) + ($side1 ** 2) );
Комментарий
Говорят, в программировании есть всего три удобных числа: ноль, единица и «сколько угодно». Механизм работы с подпрограммами Perl разрабатывался для упрощения написания функций со сколь угодно большим (или малым) числом параметров и возвращаемых значений. Все входные параметры хранятся в виде отдельных скалярных значений в специальном массиве @_, который автоматически становится локальным для каждой функции (см. рецепт 10.13). Для возвращения значений из подпрограмм следует использовать команду return с аргументом. Если она отсутствует, возвращаемое значение представляет собой результат последнего вычисленного выражения.
Приведем несколько примеров вызова функции hypotenuse, определенной в решении:
print hypotenuse(3, 4), "\n"; # Выводит 5
@а = (3, 4);
print hypotenuse(@a), "\n"; # Выводит 5
Если взглянуть на аргументы, использованные во втором вызове hypotenuse, может показаться, что мы передали лишь один аргумент — массив @а. Но это не так — элементы @а копируются в массив @_ по отдельности. Аналогично, при вызове функции с аргументами (@>а, @Ь) мы передаем ей все аргументы из обоих массивов. При этом используется тот же принцип, что и при сглаживании списков:
@both = (@men, @women);
Скалярные величины в @_ представляют собой неявные синонимы для передаваемых значений, а не их копии. Таким образом, модификация элементов @_ в подпрограмме приведет к изменению значений на вызывающей стороне. Это тяжкое наследие пришло из тех времен, когда в Perl еще не было нормальных ссылок.
Итак, функцию можно записать так, чтобы она не изменяла свои аргументы — для этого следует скопировать их в закрытые переменные:
@nums = (1.4, 3.5, 6.7);
@ints = int_all((g>nums); # @nums не изменяется
sub int_all {
ray ©retlist = @_; 8 Сделать копию для return
for my $n (iaretlist) { $n = int($n) }
return @retlist;
Впрочем, функция также может изменять значения переменных вызывающей стороны:
@nums = (1.4, 3.5, 6.7);
trunc_en(@nums); # @nums = (1,3,6)
sub trunc_em {
for (@_) < $_ = int($_) } # Округлить каждый аргумент }
Таким функциям не следует передавать константы — например, trunc_em(1.4, 3.5, 6.7). Если попытаться это сделать, будет возбуждено исключение Modification of a read-only value attempted at... («Попытка модифицировать величину, доступную только для чтения»).
Встроенные функции chop и chomp работают именно так — они модифицируют переменные вызывающей стороны и возвращают удаленный символ(-ы). Многие привыкают к тому, что функции возвращают измененные значения, и часто пишут в программах следующее:
$line = chomp(o); # НЕВЕРНО
пока не поймут, что происходит в действительности. Учитывая широкие возможности для ошибок, перед модификацией @_ в подпрограмме стоит дважды подумать.
> Смотри также---------------------------------------------------------------------------------------------
perlsub(l).
10.2. Создание закрытых переменных в функциях
Проблема
В подпрограмме потребовалось создать временную переменную. Использование глобальных переменных нежелательно, поскольку другие подпрограммы могут получить к ним доступ.
Решение
Воспользуйтесь ключевым словом ту для объявления переменной, ограниченной некоторой областью программы:
sub somefunc {
my $variable; # Переменная $variable невидима
№ за пределами somefunc() my (Sanother, @an_array, %a_hash); # Объявляем несколько
# переменных сразу # ...
Оператор ту ограничивает использование переменной и обращение к ней определенным участком программы. За пределами этого участка переменная недоступна. Такой участок называется областью действия (scope).
Переменные, объявленные с ключевым словом ту, обладают лексической областью действия — это означает, что они существуют лишь в границах некоторого фрагмента исходного текста. Например, областью действия переменной $vanable из решения является функция somef unc, в которой она была определена. Переменная создается при вызове somef unc и уничтожается при ее завершении. Переменная доступна внутри функции, но не за ее пределами.
Лексическая область действия обычно представляет собой программный блок, заключенный в фигурные скобки, — например, определение тела подпрограммы somefunc или границы команд if, while, for, foreach и eval. Лексическая область действия также может представлять собой весь файл или строку, переданную eval. Поскольку лексическая область действия обычно является блоком, иногда мы говорим, что лексические переменные (переменные с лексической областью действия) видны только в своем блоке — имеется в виду, что они видны только в границах своей области действия. Простите нам эту неточность, иначе слова «область действия» и «подпрограмма» заняли бы половину этой книги.
Поскольку фрагменты программы, в которых видна переменная ту, определяются во время компиляции и не изменяются позднее, лексическая область действия иногда не совсем точно называется «статической областью действия». Ее противоположностью является динамическая область действия, рассмотренная в рецепте 10.13.
Объявление ту может сочетаться с присваиванием. При определении сразу нескольких переменных используются круглые скобки:
my ($name, $age) = @ARGV;
ту $start = fetch_time();
Эти лексические переменные ведут себя как обычные локальные переменные. Вложенный блок видит лексические переменные, объявленные в родительских по отношению к нему блоках, но не в других, не связанных с ними блоках:
my ($a, $b) = @pair; ту $с = fetch_time();
sub check_x {
ту $х = $_[0]; ту $у = 'whatever"; run_check(), if ($condition) { print "got $x\n";
В приведенном выше фрагменте блок if внутри функции может обращаться к закрытой переменной $х. Однако в функции run_check, вызванной из этой области, переменные $х и $у недоступны, потому что она предположительно определяется в другой области действия. Однако check_x может обращаться к $а, $Ь и $с из
внешней области, поскольку определяется в одной области действия с этими переменными.
Именованные подпрограммы не следует объявлять внутри объявлений других именованных подпрограмм. Такие подпрограммы, в отличие от полноценных замыканий, не обеспечивают правильной привязки лексических переменных. В рецепте 10.16 показано, как справиться с этим ограничением.
При выходе лексической переменной за пределы области действия занимаемая ей память освобождается, если на нее не существует ссылок, как для массива ^arguments в следующем фрагменте:
sub save_array {
my ©arguments = @_;
push(@Global_Array, \@arguments), }
Система сборки мусора Perl знает о том, что память следует освобождать лишь для неиспользуемых объектов. Это и позволяет избежать утечки памяти при возвращении ссылки на закрытую переменную.
> Смотри также---------------------------------------------------------------------------------------------
Раздел «Private Variables via my()» perlsub(l).
10.3. Создание устойчивых закрытых переменных
Проблема
Вы хотите, чтобы переменная сохраняла значение между вызовами подпрограммы, но не была доступна за ее пределами. Например, функция может запоминать, сколько раз она была вызвана.
Решение
«Заверните» функцию во внешний блок и объявите переменные ту в области действия этого блока, а не в самой функции:
{
my $variable, sub mysub {
П . обращение к $variable
Если переменные требуют инициализации, снабдите блок ключевым словом BEGIN, чтобы значение переменных заведомо задавалось перед началом работы основной программы:
BEGIN {
my $variable = 1, # Начальное значение
Глава 10 • Подпрограммы
sub othersub { # обращение к SvanableКомментарий
В отличие от локальных переменных в языках С и C++, лексические переменные Perl не всегда уничтожаются при выходе из области действия. Если нечто, продолжающее существовать, все еще помнит о лексической переменной, память не освобождается. В нашем примере mysub использует переменную $variable, поэтому Perl не освобождает память переменной при завершении блока, вмещающего определение mysub.
Счетчик вызовов реализуется следующим образом:
{
ray $counter,
sub next_counter { return ++$counter } }
При каждом вызове next_counter функция увеличивает и возвращает переменную $counter. При первом вызове переменная $counter имеет неопределенное значение, поэтому для оператора ++ она интерпретируется как 0. Переменная входит не в область действия next_counter, а в окружающий ее блок. Никакой внешний код не сможет изменить $counter без вызова next_counter.
Для расширения области действия обычно следует использовать ключевое слово BEGIN. В противном случае возможен вызов функции до инициализации переменной.
BEGIN {
my $counter = 42,
sub next_counter { return ++$counter }
sub prev_counter { return --$counter } }
Таким образом, в Perl создается аналог статических переменных языка С. В действительности он даже лучше — переменная не ограничивается одной функцией, и обе функции могут совместно использовать свою закрытую переменную.
t> Смотри также--------------------------------------------------------------------------------------------
Раздел «Private Variables via my()» perlsub{\); раздел «Package Constructors and Destructors» perlmod{l)\ рецепт 11.4.
10.4. Определение имени текущей функции
Проблема
Требуется определить имя функции, работающей в настоящий момент. Оно пригодится для сообщений об ошибках, которые не изменяются при копировании/ вставке исходного текста подпрограммы.
Решение
Воспользуйтесь функцией caller: $this_function = (caller(0))[3],
Комментарий
Программа всегда может определить текущей номер строки с помощью специ
альной метапеременной____ LINE____ . Текущий файл определяется с помощью мета-
переменной FILE_ , а текущий пакет — PACKAGE_ . Однако не существует ме
тапеременной для определения имени текущей подпрограммы, не говоря уже
об имени той, из которой она была вызвана.
Встроенная функция caller справляется со всеми затруднениями В скалярном контексте она возвращает имя пакета вызывающей функции, а в списковом контексте возвращается список с разнообразными сведениями. Функции также можно передать число, определяющее уровень вложенности получаемой информации: 0 — ваша функция, 1 — функция, из которой она была вызвана, и т. д.
Полный синтаксис выглядит следующим образом ($i — количество уровней вложенности):
(Spackage, $filenatne $line $subr $has_args $wantarray )= caller($i)
#0 1 2 3 4 5
Возвращаемые значения имеют следующий смысл:
Spackage
Пакет, в котором был откомпилирован код:
Sfilename
Имя файла, в котором был откомпилирован код Значение -е возвращается при запуске из командной строки, а значение - (дефис) — при чтении сценария из STDIN.
$line
Номер строки, из которой был вызван данный кадр стека:
$subr
Имя функции данного кадра, включающее ее пакет. Замыкания возвращают име
на вида main ____ ANON , вызов по ним невозможен. Для eval возвращается (eval) .
$has_args
Признак наличия аргументов при вызове функции:
$wantarray
Значение, возвращаемое функцией wantarray для данного кадра стека. Равно либо true, либо false, либо undef. Сообщает, что функция была вызвана в списковом, скалярном или неопределенном контексте.
Вместо непосредственного вызова caller, продемонстрированного в решении, можно написать вспомогательные функции:
$me = whoami(),
sub whoami { (caller(1))[3] } sub whowasi { (caller(2))[3] }
Аргументы 1 и 2 используются для функций первого и второго уровня вложенности, поскольку вызов whoami или whowasi будет иметь нулевой уровень.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций wantarray и caller в perlfunc(l); рецепт 10.6.
10.5. Передача массивов и хэшей по ссылке
Проблема
Требуется передать функции несколько массивов или хэшей и сохранить их как отдельные сущности. Например, вы хотите выделить в подпрограмму алгоритм поиска элементов одного массива, отсутствующих в другом массиве, из рецепта 4.7, При вызове подпрограмма должна получать два массива, которые не должны смешиваться.
array_diff( \@>аггау1, \@аггау2 ),
Комментарий
Операции со ссылками рассматриваются в главе 11 «Ссылки и записи». Ниже показана подпрограмма, получающая ссылки на массивы, и вызов, в котором эти ссылки генерируются:
@а = (1, 2),
@Ь = (5, 8),
@с = add_vecpair( \@a, \@Ь ),
print @c\n ,
6 10
sub add_vecpair { и Предполагается, что оба вектора
й имеют одинаковую длину
ту ($х, $у) = @>_, # Скопировать ссылки на массивы
my @result,
for (my $i=0, $i < (Э$х $result[$i] = $x->[$i]
return ©result, }
Функция обладает одним потенциальным недостатком: она не проверяет, что ей были переданы в точности два аргумента, являющиеся ссылками на массивы. Проверку можно организовать следующим образом:
unless (@_ == 2 && ref($x) eq ARRAY && ref($y) eq ARRAY ) <
die usage add_vecpair ARRAYREF1 ARRAYREF2 , }
Если вы собираетесь ограничиться вызовом die в случае ошибки (см. рецепт 10.12), проверка обычно пропускается, поскольку при попытке разыменования недопустимой ссылки все равно возникает исключение.
> Смотри также---------------------------------------------------------------------------------------------
Раздел «Pass by Reference» perbub(l); раздел «Prototypes»perlsub(l); рецепт 10.11; глава 11.
10.6. Определение контекста вызова
Проблема
Требуется узнать, была ли ваша функция вызвана в скалярном или списковом контексте. Это позволяет решать разные задачи в разных контекстах, как это делается в большинстве встроенных функций Perl.
Решение
Воспользуйтесь функцией wantarray(), которая возвращает три разных значения в зависимости от контекста вызова текущей функции:
if (wantarray()) {
# Списковый контекст
>
elsif (defined wantarrayO) {
# Скалярный контекст
}
else {
# Неопределенный контекст
Комментарий
Многие встроенные функции, вызванные в скалярном контексте, работают совсем не так, как в списковом контексте. Пользовательская функция может узнать контекст своего вызова с помощью значения, возвращаемого встроенной функцией wantarray. Для спискового контекста wantarray возвращает true. Если возвращается ложное, но определенное значение, функция используется в скалярном контексте. Если возвращается undef, от функции вообще не требуется возвращаемого значения.
if (wantarray()) {
print "In list context\n';
return (9>many_things; } elsif (defined wantarrayO) {
print "In scalar context\n";
return $one_thmg; } else {
print "In void context\n';
return, # Ничего
mysub(); # Неопределенный контекст
$a = mysub(); # Скалярный контекст
if (mysubO) { } # Скалярный контекст
@>a = mysub(); # Списковый контекст
print mysubQ; # Списковый контекст
> Смотри также---------------------------------------------------------------------------------------------
Описание функций return и wantarray в perlfunc(l).
10.7. Передача именованных параметров
Проблема
Требуется упростить вызов функции с несколькими параметрами, чтобы программист помнил смысл параметров, а не порядок их следования.
Решение
Укажите имена параметров при вызове:
thefunc(INCREMENT => "20s", START => '+5m", FINISH => "+30m");
thefunc(START => '+5m", FINISH => "+30m");
thefunc(FINISH => "+30m");
thefunc(START => "+5m", INCREMENT => '15s");
Затем в подпрограмме создайте хэш, содержащий значения по умолчанию и массив пар:
|
sub |
thefunc { |
|||
|
my |
%args = ( |
|||
|
INCREMENT |
=> '10s', |
|||
|
FINISH |
=> 0, |
|||
|
START |
=> 0, |
|||
|
Ф_, |
# Список |
пар аргументов |
||
|
> |
if |
($args{INCREMENT} =" |
/m$/ ) { ... |
Комментарий
Функции, аргументы которых должны следовать в определенном порядке, удобны для небольших списков аргументов. Но с ростом количества аргументов становится труднее делать некоторые из них необязательными или присваивать им значения по умолчанию. Пропускать можно только аргументы, находящиеся в конце списка, и никогда — в начале.
Более гибкое решение — передача пар значений. Первый элемент пары определяет имя аргумента, а второй — значение. Программа автоматически документируется, поскольку смысл параметра можно понять, не читая полное определение функции. Более того, программистам, использующим такую функцию, не придется запоминать порядок аргументов, и они смогут пропускать любые аргументы.
Решение построено на объявлении в функции закрытого хэша, хранящего значения параметров по умолчанию. В конец хэша заносится массив текущих аргументов, @_ — значения по умолчанию заменяются фактическими значениями аргументов.
> Смотри также---------------------------------------------------------------------------------------------
Глава 4 «Массивы».
10.8. Пропуск некоторых возвращаемых значений
Проблема
Имеется функция, которая возвращает много значений, однако вас интересуют лишь некоторые из них. Классический пример — функция stat; как правило, требуется лишь одно значение из длинного возвращаемого списка (например, режим доступа).
Решение
Присвойте результат вызова списку, некоторые позиции которого равны undef: ($а, undef, $с) = func(),
Либо создайте срез списка возвращаемых значений и отберите лишь то, что вас интересует:
($а, $с) = (func())[0,2],
Комментарий
Применять фиктивные временные переменные слишком расточительно:
($dev,$mo,$DUMMY,$DUMMY,$uid) = stat($filename);
Чтобы отбросить ненужное значение, достаточно заменить фиктивные переменные на undef:
Также можно создать срез и включить в него лишь интересующие вас значения:
($dev,$ino,$uid,$gid) = (stat($filename))[O,1 4,5],
Если вы хотите перевести результат вызова функции в списковый контекст и отбросить все возвращаемые значения (вызывая его ради побочных эффектов), начиная с версии 5.004, можно присвоить его пустому списку:
() = some_function()
t> Смотри также--------------------------------------------------------------------------------------------
Описание срезов в perlsub(l); рецепт 3.1.
10.9. Возврат нескольких массивов или хэшей
Проблема
Необходимо, чтобы функция возвратила несколько массивов или хэшей, однако возвращаемые значения сглаживаются в один длинный список скалярных величин.
Решение
Возвращайте ссылки на хэши или массивы:
($array_ref, $hash_ref) = somefunc(),
sub somefunc { my @array, ray %hash,
й
return ( \@array \%hash ) }
Комментарий
Как говорилось выше, все аргументы функции сливаются в общий список скалярных величин. То же самое происходит и с возвращаемыми значениями. Функция, возвращающая отдельные массивы или хэши, должна возвращать их по ссылке, и вызывающая сторона должна быть готова к получению ссылок. Например, возвращение трех отдельных хэшей может выглядеть так:
sub fn {
return (\%a, \%b, \%c), ft или
return \(%a, %b, %с) # то же самое }
Вызывающая сторона должна помнить о том, что функция возвращает список ссылок на хэши. Она не может просто присвоить его списку из трех хэшей.
(%hO, %h1, %h2) = fn(), # НЕВЕРНО1
@array_of_hashes = fn() # например $array_of_hashes[2]->{ keystring }
($rO, $r1, $r2) = fn() # например $r2->{ keystring }
t> Смотри также--------------------------------------------------------------------------------------------
Общие сведения о ссылках в главе И; рецепт 10.5.
10.10. Возвращение признака неудачного вызова
Проблема
Функция должна возвращать значение, свидетельствующее о неудачной попытке вызова.
Решение
Воспользуйтесь командой return без аргументов, которая в скалярном контексте возвращает undef, а в списковом — пустой список ().
Комментарий
return без аргументов означает следующее:
sub enpty_retval {
return ( wantarray ? () undef ) }
Ограничиться простым retu rn undef нельзя, поскольку в списковом контексте вы получите список из одного элемента: undef. Если функция вызывается в виде:
if (@>а = yourfuncO) { }
то признак ошибки будет равен true, поскольку @а присваивается список (undef), интерпретируемый в скалярном контексте. Результат будет равен 1 (количество элементов в @а), то есть истинному значению. Контекст вызова можно определить с помощью функции wantarray, однако return без аргументов обеспечивает более наглядное и изящное решение, которое работает в любых ситуациях:
unless ($a = sfunc()) { die sfunc failed } unless (@a = afunc()) { die afunc failed } unless (%a = hfuncO) { die hfunc failed }
Некоторые встроенные функции Perl иногда возвращают довольно странные значения. Например, fcntl и loctl в некоторых ситуациях возвращают строку
ioctl(..,.) or die "can't ioctl: $!";
В этом случае программе не нужно отличать определенный ноль от неопределенного значения, как пришлось бы делать для функций read или glob. В числовой интерпретации "О but true" является нулем. Необходимость в возвращении подобных значений возникает довольно редко. Более распространенный (и эффектный) способ сообщить о неудаче при вызове функции заключается в инициировании исключения (см. рецепт 10.12).
> Смотри также---------------------------------------------------------------------------------------------
Описание функций wantarray и return вperlfunc(i); рецепт 10.12.
10.11. Прототипы функций
Проблема
Вы хотите использовать прототипы функций, чтобы компилятор мог проверить типы аргументов.
Решение
В Perl существует нечто похожее на прототипы, но это сильно отличается от прототипов в традиционном понимании. Прототипы функций Perl больше напоминают принудительный контекст, используемый при написании функций, которые ведут себя аналогично некоторым встроенным функциям Perl (например, push и pop).
Комментарий
Фактическая проверка аргументов функции становится возможной лишь во время выполнения программы. Если объявить функцию до ее реализации, компилятор сможет использовать очень ограниченную форму прототипизации. Не путайте прототипы Perl с теми, что существуют в других языках. В Perl прототипы предназначены лишь для эмуляции поведения встроенных функций.
Прототип функции Perl представляет собой ноль и более пробелов, обратных косых черт или символов типа, заключенных в круглые скобки после определения или имени подпрограммы. Символ типа с префиксом \ означает, что аргумент в данной позиции передается по ссылке и должен начинаться с указанного символа типа.
Прототип принудительно задает контекст аргументов, используемых при вызове данной функции. Это происходит во время компиляции программы и в большинстве случаев вовсе не означает, что Perl проверяет количество или тип аргументов функции. Если Perl встретит вызов func(3, 5) для функции с прото-
типом sub func($), он завершит компиляцию с ошибкой. Но если для того же прототипа встретится вызов func(@array), компилятор всего лишь преобразует @аггау в скалярный контекст; он не скажет: «Массив передавать нельзя — здесь должна быть скалярная величина».
Это настолько важно, что я повторю снова: не пользуйтесь прототипами Perl, если вы надеетесь, что компилятор будет проверять тип и количество аргументов.
Тогда зачем нужны прототипы? Существуют два основных применения, хотя во время экспериментов вы можете найти и другие. Во-первых, с помощью прототипа можно сообщить Perl количество аргументов вашей функции, чтобы опустить круглые скобки при ее вызове. Во-вторых, с помощью прототипов можно создавать подпрограммы с тем же синтаксисом вызова, что и у встроенных функций.
Пропуск скобок
Обычно функция получает список аргументов, и при вызове скобки ставить не
обязательно:
©results = myfunc 3 , 5;
Без прототипа такая запись эквивалентна следующей:
^results = myfunc(3 , 5);
При отсутствии скобок Perl преобразует правую часть вызова подпрограммы в списковый контекст. Прототип позволяет изменить такое поведение:
sub myfunc($);
©results = myfunc 3 , 5;
Теперь эта запись эквивалентна следующей:
@results = ( myfunc(3), 5 );
Кроме того, можно предоставить пустой прототип, показывающий, что функция вызывается без аргументов, как встроенная функция time. Именно так реализованы константы LOCK_SH, LOCK_EX и LOCK_UN в модуле Fcntl. Они представляют собой экспортируемые функции, определенные с пустым прототипом:
sub LOCK_SH (){1} sub LOCK_EX () { 2 } sub LOCKJJN () { 4 }
Имитация встроенных функций
Прототипы также часто применяются для имитации поведения таких встроенных функций, как push и shift, передающих аргументы без сглаживания. При вызове push (@а г ray, 1, 2, 3) функция получает ссылку на @а г ray вместо самого массива. Для этого в прототипе перед символом @ ставится обратная косая черта:
sub mypush (\@@) { my $array_ref = shift; my ©remainder = @_;
mypush( $х > 10 ? @а : @b , 3, 5 ); # НЕВЕРНО
Вместо этого приходится изощряться со ссылками: mypush( @{ $х > 10 ? @а : @b }, 3, 5 ); # ВЕРНО
Приведенная ниже функция hpush работает аналогично push, но для хэшей. Функция дописывает в существующий хэш список пар <<ключ/значение>>, переопределяя прежнее содержимое этих ключей.
sub hpush(\%@) {
my $href = shift;
while ( my ($k, $v) = splice(@_, 0, 2) ) {
$href->{$k} = $v;
> }
hpush(%pieces, "queen" => 9, "rook" => 5);
t> Смотри также--------------------------------------------------------------------------------------------
Описание функции prototype вperlfunc(l);perlsub(l); рецепт 10.5.
10.12. Обработка исключений
Проблема
Как организовать безопасный вызов функции, способной инициировать исключение? Как создать функцию, инициирующую исключение?
Решение
Иногда в программе возникает что-то настолько серьезное, что простого возвращения ошибки оказывается недостаточно, поскольку та может быть проигнорирована вызывающей стороной. Включите в функцию конструкцию die СТРОКА, чтобы инициировать исключение:
die "some message"; # Инициировать исключение
Чтобы перехватить исключение, вызывающая сторона вызывает функцию из eval, после чего узнает результат с помощью специальной переменной $@:
eval { func() }; if ($@) {
warn "func raised an exception; $@>";
Комментарий
Инициирование исключения — крайняя мера, и относиться к ней следует серьезно. В большинстве функций следует возвращать признак ошибки с помощью простого оператора return. Перехватывать исключения при каждом вызове функции скучно и некрасиво, и это может отпугнуть от применения исключений.
Но в некоторых ситуациях неудачный вызов функции должен приводить к аварийному завершению программы. Вместо невосстановимой функции exit следует вызвать die — по крайней мере, у программиста появится возможность вмешаться в происходящее. Если ни один обработчик исключения не был установлен с помощью eval, на этом месте программа аварийно завершается.
Чтобы обнаружить подобные нарушения, можно поместить вызов функции в блок eval. Если произойдет исключение, оно будет присвоено переменной $@; в противном случае переменная равна false.
eval { $val = func() };
warn "func blew up: $@" if $@;
Блок eval перехватывает все исключения, а не только те, что интересуют вас. Непредусмотренные исключения обычно следует передать внешнему обработчику. Предположим, функция инициирует исключение, описываемое строкой "Full moon!". Можно спокойно перехватить это исключение и дать другим обработчикам просмотреть переменную $@. При вызове die без аргументов новая строка исключения конструируется на основании содержимого $@ и текущего контекста.
eval { $val = func() };
if ($(Э && $(5> Г /Full moon!/) {
die; # Повторно инициировать неизвестные ошибки }
Если функция является частью модуля, можно использовать модуль Carp и вызвать croak или confess вместо die. Единственное отличие die от croak заключается в том, что croak представляет ошибку с позиции вызывающей стороны, а не модуля. Функция confess по содержимому стека определяет, кто кого вызвал и с какими аргументами.
Другая интересная возможность заключается в том, чтобы функция могла узнать о полном игнорировании возвращаемого ею значения (то есть о том, что она вызывается в неопределенном контексте). В этом случае возвращение кода ошибки бесполезно, поэтому вместо него следует инициировать исключение.
Конечно, вызов функции в другом контексте еще не означает, что возвращаемое значение будет должным образом обработано. Но в неопределенном контексте оно заведомо не проверяется.
if (defined wantarrayO) {
return; } else {
die "pay attention to my error!"; }
> Смотри также ——-----------------------------------------------------------------
Описание переменной $@ вperlvar(i); описание функций die и eval вperlfunc(l); рецепты 10.15, 12.2 и 16.21.
Проблема
Требуется временно сохранить значение глобальной переменной.
Решение
Воспользуйтесь оператором local, чтобы сохранить старое значение и автоматически восстановить его при выходе из текущего блока:
$аде = 18; # Глобальная переменная
if (CONDITION) {
local $age = 23;
func(); # Видит временное значение 23 } # Восстановить старое значение при выходе из блока
Комментарий
К сожалению, оператор Perl local не создает локальной переменной — это делается оператором my. local всего лишь сохраняет существующее значение на время выполнения блока, в котором он находится.
Однако в трех ситуациях вы должны использовать local вместо ту.
1. Глобальной переменной (особенно $_) присваивается временное значение.
2. Создается локальный манипулятор файла или каталога или локальная
функция.
3. Вы хотите временно изменить один элемент массива или хэша.
Применение local() для присваивания временных значений глобальным переменным
Первая ситуация чаще встречается для стандартных, нежели пользовательских переменных. Нередко эти переменные используются Perl в высокоуровневых операциях. В частности, любая функция, явно или косвенно использующая $_, должна иметь локальную копию $_. Об этом часто забывают. Одно из возможных решений приведено в рецепте 13.15.
В следующем примере используется несколько глобальных переменных. Переменная $/ косвенно влияет на поведение оператора чтения строк, используемого в операциях <FH>.
$para = get_paragraph(*FH); Я Передать glob файлового манипулятора $рага = get_paragraph(\*FH); # Передать манипулятор по ссылке на glob $para = get_paragraph(*IO{FH}); # Передать манипулятор по ссылке на 10 sub get_paragraph {
my $fh = shift;
local $/ = '';
my $paragraph = <$fh>;
chomp($paragraph);
return $paragraph;
Применение local() для создания локальных манипуляторов Вторая ситуация возникает в случае, когда требуется локальный манипулятор файла или каталога, реже — локальная функция. Начиная с Perl версий 5.000, можно воспользоваться стандартными модулями Symbol, Filehandle или IO::Handle, но и привычная методика с тип-глобом по-прежнему работает. Например:
$contents = get_motd(); sub getjnotd {
local *MOTD;
open(MOTD, "/etc/motd") or die "can't open motd: $!";
local $/ = undef; # Читать весь файл
local $_ = <MOTD>;
close (MOTD);
return $_; }
Открытый файловый манипулятор возвращается следующим образом:
return *MOTD;
Применение local() в массивах и хэшах
Третья ситуация на практике почти не встречается. Поскольку оператор local в действительности является оператором «сохранения значения», им можно воспользоваться для сохранения одного элемента массива или хэша, даже если сам массив или хэш является лексическим!
my @nums = (0 .. 5); sub first {
local $nums[3] = 3.14159;
secondO; } sub second {
print "@nums\n"; }
secondO; 0 12 3 4 5 firstO; 0 1 2 3.14159 4 5
Единственное стандартное применение — временные обработчики сигналов.
sub first {
local $SIG{INT> = 'IGNORE';
secondO; }
Теперь во время работы secondO сигналы прерывания будут игнорироваться. После выхода из first () автоматически восстанавливается предыдущее значение $SIG{INT}.
Хотя local часто встречается в старом коде, от него следует держаться подальше, если это только возможно. Поскольку local манипулирует значениями
Оператор local создает динамическую область действия. Она отличается от другой области действия, поддерживаемой Perl и значительно более понятной на интуитивном уровне. Речь идет об области действия ту — лексической области действия, иногда называемой «статической».
В динамической области действия переменная доступна в том случае, если она находится в текущей области действия — или в области действия всех кадров (блоков) стека, определяемых во время выполнения. Все вызываемые функции обладают полным доступом к динамическим переменным, поскольку последние остаются глобальными, но получают временные значения. Лишь лексические переменные защищены от вмешательства извне. Если и это вас не убедит, возможно, вам будет интересно узнать, что лексические переменные примерно на 10 процентов быстрее динамических.
Старый фрагмент вида:
sub func {
local($x $y) = @_
# }
почти всегда удается заменить без нежелательных последствий следующим фрагментом:
sub func {
my($x, $y) = @_,
# }
Единственный случай, когда подобная замена невозможна, — если работа программы основана на динамической области действия. Это происходит в ситуации, когда одна функция вызывает другую и работа второй зависит от доступа к временным версиям глобальных переменных $х и $у первой функции. Код, который работает с глобальными переменными и вместо нормальной передачи параметров издалека вытворяет нечто странное, в лучшем случае ненадежен. Хорошие программисты избегают подобных выкрутасов как чумы.
Если вам встретится старый код вида:
&func(*Global_Array) sub func {
local(*aliased_array) = shift,
for (@>aliased_array) { }
}
вероятно, его удастся преобразовать к следующей форме:
f unc(\(°>Global_Array), sub func {
my $array_ref = shift
for ((g>$array_ref) { }
До появления в Perl нормальной поддержки ссылок, использовалась старая стратегия передачи тип-глобов. Сейчас это уже дело прошлое.
Смотри также
Описание функций local и ту вperlfunc(l); разделы «Private Variables via my()» и «Temporary Values via local()» perlsub(l); рецепты 10.2; 10.16.
10.14. Переопределение функции
Проблема
Требуется временно или постоянно переопределить функцию, однако функциям нельзя «присвоить» новый код.
Решение
Чтобы переопределить функцию, присвойте ссылку на новый код тип-глобу имени функции. Используйте local для временной замены.
undef &grow, # Заглушить жалобы -w на переопределение
¦grow = \&expand
grow() ft Вызвать expandO
local ¦grow = \&shrnk, # Только в границах блока
grow() # Вызывает shnnk()
Комментарий
В отличие от переменных (но по аналогии с манипуляторами) функции нельзя напрямую присвоить нужное значение. Это всего лишь имя. Однако с ней можно выполнять многие операции, выполняемые с переменными, поскольку вы можете напрямую работать с таблицей символов с помощью тип-глобов вида *foo и добиваться многих интересных эффектов.
Если присвоить тип-глобу ссылку, то при следующем обращении к символу данного типа будет использовано новое значение. Именно это делает модуль Exporter при импортировании функции или переменной из одного пакета в другой. Поскольку операции выполняются непосредственно с таблицей символов пакета, они работают только для пакетных (глобальных) переменных, но не для лексических.
¦one var = \%two Table, # %one var становится синонимом для %two Table ¦one big = \&two small, # &one big становится синонимом для &two small
С тип-глобом можно использовать local, но не ту. Из-за local синоним действует только в границах текущего блока.
local ¦fred = \&barney, it временно связать &fred c &barney
Присваивание тип-глобов в сочетании с замыканиями позволяет легко и удоб но дублировать функции. Представьте, что вам понадобилась функция для генерации HTML-кода, работающего с цветами. Например:
Sstring = red("careful here");
print $string;
<FONT COLORS red ^careful here</FONT>
Функция red выглядит так:
sub red { "<FONT C0LOR='red'>@_</FONT>" }
Если вам потребуются другие цвета, пишется нечто подобное:
sub color_font {
my $color = shift;
return "<FONT COLOR='$color'>@_</FONT>"; }
sub red { color_font("red", @_) } sub green { color_font("green", @_) } sub blue { color_font("blue", @_) } sub purple { color_font("purple", @_) } # И т. д.
Сходство функций наводит на мысль, что общую составляющую можно как-то выделить. Для этого следует воспользоваться косвенным присваиванием тип-глобы. Если вы используете рекомендуемую директиву use strict, сначала отключите strict 'refs'для этого блока.
gcolors = qw(red blue green yellow orange purple violet); for my $name (©colors) {
no strict 'refs';
¦$narae = sub { "<FONT COLOR='$name'>
Функции кажутся независимыми, однако фактически код был откомпилирован лишь один раз. Подобная методика экономит время компиляции и память. Для создания полноценного замыкания все переменные анонимной подпрограммы должны быть лексическими. Именно поэтому переменная цикла объявляется с ключевым словом ту.
Перед вами одна из немногочисленных ситуаций, в которых создание прототипа для замыкания оправдано. Если вам захочется форсировать скалярный контекст для аргументов этих функций (вероятно, не лучшая идея), ее можно записать в следующем виде:
Однако прототип проверяется во время компиляции, поэтому приведенное выше присваивание произойдет слишком поздно и никакой пользы не принесет. Следовательно, весь цикл с присваиваниями следует включить в BEGIN-блок, чтобы форсировать его выполнение при компиляции.
> Смотри также---------------------------------------------------------------------------------------------
Описание замыканий в perlref(l); раздел «Symbol tables» perlmod(l); рецепты 10.11; 11.4.
10.15. Перехват вызовов неопределенных функций с помощью AUTOLOAD
Проблема
Требуется перехватить вызовы неопределенных функций и достойно обработать их.
Решение
Объявите функцию с именем AUTOLOAD для пакета, вызовы неопределенных функций которого вы собираетесь перехватывать. Во время ее выполнения переменная $AUTOLOAD этого пакета содержит имя вызванной неопределенной функции.
Комментарий
В подобных ситуациях обычно применяются вспомогательные функции (proxy). При вызове неопределенной функции вместо автоматического инициирования исключения также можно перехватить вызов. Если пакет, к которому принадлежит вызываемая функция, содержит функцию с именем AUTOLOAD, то она будет вызвана вместо неопределенной функции, а специальной глобальной переменной пакета $AUTOLOAD будет присвоено полное имя функции. Затем функция AUTOLOAD сможет делать все, что должна была делать исходная функция.
sub AUTOLOAD {
use vars qw($AUTOLOAD);
my $color = SAUTOLOAD;
$color =~ s/.¦:://;
return "<FONT COLOR='$color'xa_</FONT>"; }
# Примечание: функция sub chartreuse не определена print chartreuse("stuff');
При вызове несуществующей функции main: : chartreuse вместо инициирования исключения будет вызвана функция main: :AUTOLOAD с аргументами, переданными chartreuse. Пакетная переменная $AUTOLOAD будет содержать строку
main: :chartreuse.
{
local «yellow = \&violet;
local (*red, *green) = (\&green, \&red);
pnnt_stuff (); }
При работе pnnt_stuff или любой вызванной ей функции все, что должно выводиться желтым цветом, выводится фиолетовым; красный цвет заменяется зеленым, и наоборот.
Однако подстановка функций не позволяет обрабатывать вызовы неопределенных функций. AUTOLOAD справляется с этой проблемой.
> Смотри также---------------------------------------------------------------------------------------------
Раздел «Autoloading» perlsub(l); документация по стандартным модулям Auto-Loader и AutoSplit; рецепты 10.12; 12.10; 13.11.
10.16. Вложенные подпрограммы
Проблема
Требуется реализовать вложение подпрограмм, чтобы одна подпрограмма была видна и могла вызываться только из другой. Если попытаться применить очевидный вариант sub F00 { sub BAR { } .. }, Perl предупреждает о переменных, которые «не останутся общими».
Решение
Вместо того чтобы оформлять внутренние функции в виде обычных подпрограмм, реализуйте их в виде замыканий и затем временно присвойте их тип-глобу правого имени, чтобы создать локальную функцию.
Комментарий
Вероятно, в других языках программирования вам приходилось работать с вложенными функциями, обладающими собственными закрытыми переменными. В Perl для этого придется немного потрудиться. Интуитивная реализация приводит к выдаче предупреждения. Например, следующий фрагмент не работает:
sub outer {
my $x = $_[0] + 35,
sub inner { return $x * 19 } # НЕВЕРНО
return $x + inner();
Обходное решение выглядит так:
sub outer {
my $x = $_[0] + 35;
local *inner = sub { return $x * 19 };
return $x + inner(); }
Теперь благодаря временно присвоенному замыканию inner() может вызываться только из outer(). При вызове inner() получает нормальный доступ к лексической переменной $х из области действия outer().
В сущности, мы создаем функцию, которая является локальной для другой функции — подобная возможность не поддерживается в Perl напрямую. Впрочем, ее реализация не всегда выглядит понятно.
> Смотри также---------------------------------------------------------------------------------------------
Описание замыканий в perlref(l); раздел «Symbol tables» perlmod(l); рецепты 10.13-10.14.
10.17. Сортировка почты
Программа из примера 10. 1 сортирует почтовый ящик по темам. Для этого она читает сообщения по абзацам и ищет абзац, начинающийся с "From:". Когда такой абзац будет найден, программа ищет тему, удаляет из нее все пометки "Re:", преобразует в нижний регистр и сохраняет в массиве @suiD. При этом сами сообщения сохраняются в массиве @msgs. Переменная $msgno следит за номером сообщения.
Пример 10.1. bysubl
#'/usr/bin/perl
# bysubl - simple sort by subject
my(@)msgs, @>sub);
my $msgno = -1;
$/=''; й Чтение по абзацам
while (<>) {
if (/"From/m) {
/~Subjecf\s*(9:Re:\s*)*( *)M; $sub[++$msgno] = lc($1) || ';
}
$msgs[$msgno] .= $_; > for my $i (sort < $sub[$a] cmp $sub[$b] || $a <=> $b } (0 .. $#msgs)) {
print $msgs[$i]; }
В этом варианте сортируются только индексы массивов. Если темы совпадают, cmp возвращает 0, поэтому используется вторая часть | |, в которой номера сообщений сравниваются в порядке их исходного следования.
В примере 10.2 показано, как бы написал эту программу программист с большим опытом работы на awk. Ключ -00 используется для чтения абзацев вместо строк.
Пример 10.2. bysub2
#!/usr/bin/perl -n00
# bysub2 - сортировка по темам в стиле awk
BEGIN { $msgno = -1 }
$sub[++$msgno] = (/"Subject:\s*(?:Re:\s*)*(. »)/mi)[0] if /"From/rn;
$msg[$msgno] .= $_;
END { print <amsg[ sort { $sub[$a] cmp $sub[$b] || $a <=> $b } (0 .. $#msg) ] }
Параллельные массивы широко использовались лишь на ранней стадии существования Perl. Более элегантное решение состоит в том, чтобы сохранять сообщения в хэше. Анонимный хэш (см. главу 11) сортируется по каждому полю.
Программа из примера 10.3 построена на тех же принципах, что и примеры 10.1 и 10.2.
Пример 10.3. bysub3
#!/usr/bin/perl -00
# bysub3 - sort by subject using hash records
use strict;
my @msgs = (); while (<>) {
push @msgs, {
SUBJECT => /"Subject:\s*(?:Re:\s*)*(-*)/mi, NUMBER => scalar @>msgs, # Номер сообщения TEXT => ' ', > if /"From/m; $msgs[-1]{TEXT} .= $_;
for my $msg (sort {
$a->{SUBJECT} cmp $b->{SUBJECT}
II
$a->{NUMBER) <=> $b->{NUMBER} } (amsgs
print $msg->{TEXT}; }
Работая с полноценными хэшами, нетрудно добавить дополнительные критерии сортировки. Почтовые ящики часто сортируются сначала по теме, а затем по дате сообщения. Основные трудности связаны с анализом и сравнением дат. Модуль Date::Manip помогает справиться с ними и возвращает строку, которую можно сравнивать с другими. Тем не менее программа datesort из примера 10.4, исполь-
зующая Date::Manip, работает в 10 раз медленнее предыдущей. Анализ дат в непредсказуемых форматах занимает слишком много времени.
Пример 10.4. datesort
#!/usr/bin/perl -00
# datesort - сортировка почтового ящика по теме и дате
use strict;
use Date::Manip;
my @msgs = ();
while (<>) {
next unless /"From/m;
my $date = '';
if (/-Date:\s*(.*)/m) {
($date = $1) =" s/\s+\(-*//; $date = ParseDate($date); } push @msgs, {
SUBJECT => /~Subject:\s.(?:Re:\s*)*(-*)/mi, DATE => $date, NUMBER => scalar @msgs, TEXT => ' ',
};
} continue {
$msgs[-1]{TEXT} .= $_;
for my $msg (sort {
$a->{SUBJECT} cmp $b->{SUBJECT}
II $a->{DATE} cmp $b->{DATE}
II
$a->{NUMBER} <=> $b-><NUMBER} } @>msgs
print $msg->{TEXT}; }
Особого внимания в примере 10.4 заслуживает блок continue. При достижении конца цикла (нормальном выполнении или переходе по next) этот блок выполняется целиком. Он соответствует третьему компоненту цикла for, но не ограничивается одним выражением. Это полноценный блок, который может состоять из нескольких команд.
> Смотри также---------------------------------------------------------------------------------------------
Описание функции sort в perlfunc(l); описание переменной $/ в perlvar(l) и во введении главы 8 «Содержимое файлов»; рецепты 3.7, 4.15, 5.9 и 11.9.
Ссылки и записи
.,+ "¦¦> ¦.'Л ¦*-.*«• «\
В э/ш/ маленькую паутинку Я поймаю такую большую муху, как Кассио.
Шекспир, «Отелло», акт II, сцепа 1
Введение
В Perl существуют три основных типа данных: скалярные величины, массивы и хэши. Конечно, многие программы удается написать и без сложных структур данных, но обычно простых переменных и списков все же оказывается недостаточно.
Три встроенные структуры данных Perl в сочетании со ссылками позволяют строить сколь угодно сложные и функциональные структуры данных — те самые записи, которых так отчаянно не хватало в ранних версиях Perl. Правильно выбирая структуру данных и алгоритм, вы иногда выбираете между элегантной программой, которая быстро справляется со своей задачей, и убогой поделкой, работающей с черепашьей скоростью и нещадно пожирающей системные ресурсы.
Первая часть этой главы посвящена созданию и использованию простых ссылок. Во второй части рассказывается о применении ссылок для создания структур данных более высокого порядка.
Ссылки
Чтобы хорошо понять концепцию ссылок, сначала необходимо разобраться с тем, как в Perl хранятся значения переменных. С любой определенной переменной ассоциируется имя и адрес области памяти. Идея хранения адресов играет для ссылок особую роль, поскольку в ссылке хранятся данные о местонахождении другой величины. Скалярная величина, содержащая адрес области памяти, называется ссылкой. Значение, хранящееся в памяти по данному адресу, называется субъектом (referent) (рис. 11.1).
Субъект может относиться к одному из встроенных типов данных (скалярная величина, массив, хэш, ссылка, код или глоб) или представлять собой пользовательский тип, основанный на одном из встроенных типов.
Reference Ox83c6c Referent
ARRAY (0x83c6c)
(3, ' is a magic number' )
Субъекты в Perl типизованы. Это означает, что ссылку на массив нельзя интерпретировать как ссылку на хэш. При подобных попытках инициируется исключение. В Perl не предусмотрен механизм преобразования типов, и это было сделано намеренно.
На первый взгляд кажется, что ссылка — обычный адрес с сильной типизацией. На самом деле это нечто большее. Perl берет на себя автоматическое выделение и освобождение памяти (сборку мусора) для ссылок так же, как и для всего остального. С каждым блоком памяти в Perl связан счетчик ссылок, который определяет количество ссылок на данный субъект. Память, используемая субъектом, возвращается в пул свободной памяти процесса лишь при обнулении счетчика ссылок. Тем самым гарантируется, что вы никогда не получите недопустимую ссылку — забудьте об аварийных завершениях и ошибках защиты, часто возникающих при неправильной работе с указателями в С.
Освобожденная память передается Perl для последующего использования, но лишь немногие операционные системы возвращают ее себе. Это связано с тем, что в большинстве схем распределения памяти используется стек, а при освобождении памяти в середине стека операционная система не сможет вернуть ее без перемещения всех остальных блоков. Перемещение нарушит целостность указателей и прикончит вашу программу.
Чтобы перейти от ссылки к субъекту, снабдите ссылку символом типа для тех данных, к которым вы обращаетесь. Например, если $sref является ссылкой на скалярную величину, возможна следующая запись:
print $$sref, # Выводится скалярная величина, на которую ссылается Jsref $$sref =3, # Присваивается субъекту $sref
Для обращения к отдельному элементу массива или хэша, на который у вас имеется ссылка, используется ассоциативный оператор, оператор -> («стрелка») — например, $rv->[37] или $rv->{"wilma' }. Помимо разыменования ссылок на массивы и хэши, стрелка также применяется при косвенном вызове функций через ссылки — например, $code_ref->("arg1", "arg2") (см. рецепт 11.4). Если вы работаете с объектами, то с помощью стрелки можно вызывать их методы, $object->methodname("arg1", "arg2"), как показано в главе 13 «Классы, объекты и связи».
Правила синтаксиса Perl делают разыменование сложных выражений нетривиальной задачей. Чередование правых и левых ассоциативных операторов не рекомендуется. Например, $$х[4] — то же самое, что и $х->[4]; иначе говоря, $х интерпретируется как ссылка на массив, после чего из массива извлекается четвертый элемент. То же самое записывается в виде ${$х}[4]. Если вы имели в виду «взять четвертый элемент @х и разыменовать его в скалярное выражение», воспользуйтесь ${$х[4]}. Старайтесь избегать смежных символов типов ($@%&) везде, кроме простых и однозначных ситуаций типа %hash = %$hashref.
print ${$sref}; # Выводится скалярная величина, на которую ссылается $sref ${$sref} =3; # Присваивается субъекту $sref
Некоторые программисты для уверенности используют только эту форму.
Функция ref получает ссылку и возвращает строку с описанием субъекта. Строка обычно принимает одно из значений SCALAR, ARRAY, HASH или CODE, хотя иногда встречаются и другие встроенные типы GLOB, REF, 10, Regexp и LVALUE. Если ref вызывается для аргумента, не являющегося ссылкой, функция возвращает false. При вызове ref для объекта (ссылки, для субъекта которой вызывалась функция bless) возвращается класс, к которому был приписан объект: CGI, IO::Socket или даже ACME::Widget.
Ссылки в Perl можно создавать для субъектов уже определенных или определяемых с помощью конструкций [ ], { } или sub { }. Использовать оператор \ очень просто: поставьте его перед субъектом, для которого создается ссылка. Например, ссылка на содержимое массива @аггау создается следующим образом:
$rv = \@array;
Создавать ссылки можно даже для констант; при попытке изменить значение субъекта происходит ошибка времени выполнения:
$pi = \3.14159;
=4; # Ошибка
Анонимные данные
Ссылки на существующие данные часто применяются для передачи аргументов функции, но в динамическом программировании они бывают неудобны. Иногда ситуация требует создания нового массива, хэша, скалярной величины или функции, но вам не хочется возиться с именами.
Анонимные массивы и хэши в Perl могут создаваться явно. При этом выделяется память для нового массива или хэша и возвращается ссылка на нее:
$aref = [ 3, 4, 5 ]; # Новый анонимный массив
$href = { "How" => "Now", "Brown" => "Cow" }; # Новый анонимный хэш
В Perl также существует возможность косвенного создания анонимных субъектов. Если попытаться присвоить значение через неопределенную ссылку, Perl автоматически создаст субъект, который вы пытаетесь использовать.
undef $aref; @$aref = (1, 2, 3); print $aref; ARRAY(0x80c04f0)
Обратите внимание: от undef мы переходим к ссылке на массив, не выполняя фактического присваивания. Perl автоматически создает субъект неопределенной ссылки. Благодаря этому свойству программа может начинаться так:
$а[4][23][53][21] = "fred"; print $a[4][23][53][21];
В следующей таблице перечислены способы создания ссылок для именован
ных и анонимных скалярных величин, массивов, хэшей и функций. Анонимные
тип-глобы выглядят слишком страшно и практически никогда не используются.
Вместо них следует применять 10: :Handle->new().
Ссылка на Именованный субъект Анонимный субъект
|
Скалярная величина |
\$scalar |
|
Массив |
\@array |
|
Хэш |
\%hash |
|
Функция |
\&function |
{ СПИСОК }
{ СПИСОК }
_______________________________________________________________ sub { КОД }_____________________
Отличия именованных субъектов от анонимных поясняются на приведенных далее рисунках. На рис. 11.2 изображены именованные субъекты, а на рис. 11.3 — анонимные.
Иначе говоря, в результате присваивания $а = \$Ь переменные $$а и $Ь занимают одну и ту же область памяти. Если вы напишете $$а = 3, значение $Ь станет равно 3.
|
Initial state: |
0x305108 |
0x3051f00 |
|
|
5 |
|||
|
$a=\$b; |
0x305108 0x3051f00 |
||
|
SCALAR 0x351f00 |
5 |
||
|
$$a=3; |
0x305108 0x3051f00 |
||
|
SCALAR 0X351f00 |
5 |
||
|
print "$$a $b\n 3 3 |
J |
Все ссылки по определению оцениваются как t rue, поэтому, если ваша функция возвращает ссылку, в случае ошибки можно вернуть undef и проверить возвращаемое значение следующим образом:
p_cit = cite($ibid)
or die "couldn't make a reference";
380 Глава 11 • Ссылки и записи
|
Initial state: $$а=3, |
0x305108 |
0x3051f00 |
||
|
0x305108 |
||||
|
SCALAR 0x351f00 |
3 |
-* — (made by Perl) |
||
|
print "$$a $b\n 3 3 |
Рис. 11.3. Анонимные субъекты
Оператор undef может использоваться с любой переменной или функцией Perl для освобождения занимаемой ей памяти. Однако не следует полагать, что при вызове undef всегда освобождается память, вызываются деструкторы объектов и т. д. В действительности оператор всего лишь уменьшает счетчик ссылок на 1. Без аргумента undef дает неопределенное значение.
Записи
Ссылки традиционно применялись в Perl для обхода ограничения, согласно которому массивы и хэши могут содержать только скаляры. Ссылки являются скалярами, поэтому для создания массива массивов следует создать массив ссылок на массивы. Аналогично, хэши хэшей реализуются как хэши со ссылками на хэши; массивы хэшей — как массивы ссылок на хэши; хэши массивов — как хэши ссылок на массивы и т. д. "
Имея в своем распоряжении эти сложные структуры, можно воспользоваться ими для реализации записей. Запись представляет собой отдельную логическую единицу, состоящую из различных атрибутов. Например, запись, описывающая человека, может содержать имя, адрес и дату рождения. В С подобные вещи называются структурами (structs), а в Pascal — записями (RECORDs). В Perl для них не существует специального термина, поскольку эта концепция может быть реализована разными способами.
Наиболее распространенный подход в Perl заключается в том, чтобы интерпре тировать хэш как запись, где ключи хэша представляют собой имена полей записи, а ассоциированные величины — значения этих полей.
Например, запись «человек» может выглядеть так;
$Nat = { Name => Leonhard Euler ,
Address => 1729 Ramanujan Lane\nMathworld, PI 31416 , Birthday => 0x5bb5580,
Поскольку ссылка $NAT является скалярной величиной, ее можно сохранить в элементе хэша или массива с информацией о целой группе людей и далее использовать приемы сортировки, объединения хэшей, выбора случайных записей и т. д., рассмотренные в главах 4 и 5.
Атрибуты записи, в том числе и «человека» из нашего примера, всегда являются скалярами. Конечно, вместо строк можно использовать числа, но это банально. Настоящие возможности открываются в том случае, если атрибуты записи также представляют собой ссылки. Например, атрибут "Birthday" может храниться в виде анонимного массива, состоящего из трех элементов: день, месяц и год. Выражение $person->{"BIrthday"}->[0] выделяет из даты рождения поле «день». Дата также может быть представлена в виде хэша, для доступа к полям которого применяются выражения вида $person->{ Birthday }->{' day' }. После включения ссылок в коллекцию приемов перед вами откроются многие нетривиальные и полезные стратегии программирования.
На этом этапе мы концептуально выходим за пределы простых записей и переходим к созданию сложных структур, которые представляют запутанные отношения между хранящимися в них данных. Хотя они могут использоваться для реализации традиционных структур данных (например, связанных списков), рецепты второй части этой главы не связаны ни с какими конкретными структурами. В них описываются обобщенные приемы загрузки, печати, копирования и сохранения обобщенных структур данных. Завершающая программа этой главы демонстрирует работу с бинарными деревьями.
О Смотри также--------------------------------------------------------------------------------------------
perlref( I); perllol( I); perldsc{ 1).
11.1. Ссылки на массивы
Проблема
Требуется работать с массивом через ссылку.
Решение
Ссылка на массив создается следующим образом:
$aref = \@array
$anon_array = [1, 3, 5, 7, 9],
$anon_copy = [ @array ]
(s>$implicit_creation = (2, 4, 6, 8, 10),
Чтобы разыменовать ссылку на массив, поставьте перед ней символ @:
push(ia$anon_array, 11),
Или воспользуйтесь стрелкой с указанием индекса конкретного элемента в квадратных скобках:
$two = $implicit_creation->[0],
Для получения индекса последнего элемента массива по ссылке или определения количества элементов в массиве применяется следующая запись:
$last_idx = $#$aref, $num items = @$aref,
$last_idx = $#{ $aref }; $num_itens = scalar @{ $aref };
Комментарий
Рассмотрим примеры использования ссылок на массивы:
# Проверить, содержит ли Ssomeref ссылку на массив if (ref($someref) ne 'ARRAY') {
die "Expected an array reference, not $someref\n";
print "@{$array_ref}\n", # Вывести исходные данные border = sort @{ $array_ref }; # Отсортировать их
push @{ $array_ref }, $item; # Добавить в массив новый элемент
Если вы не можете выбрать между использованием ссылки на именованный массив и созданием нового массива, существует простое правило, которое в большинстве случаев оказывается верным. Получение ссылки на существующий массив используется либо для возврата ссылки за пределы области действия, либо при передаче массива функции по ссылке. Практически во всех остальных случаях используется [@аггау], что приводит к созданию ссылки на новый массив с копиями старых значений.
Автоматический подсчет ссылок в сочетании с оператором \ обладает большими возможностями:
sub array_ref { my @array; return \@array,
$aref1 = array_ref(); $aref2 = array_ref(),
При каждом вызове array_ref функция выделяет для @array новый блок памяти. Если бы мы не вернули ссылку на @аггау, то занимаемая массивом память была бы возвращена при выходе из блока, то есть при завершении подпрограммы. Однако ссылка на ©array продолжает существовать, поэтому Perl не освобождает память, и мы получаем ссылку на блок памяти, недоступный через таблицу символов. Такие блоки памяти называются анонимными, поскольку с ними не связано никакое имя.
К определенному элементу массива, на который указывает ссылка $aref, можно обратиться в форме $$aref[4], но $aref->[4] делает то же самое и обладает большей наглядностью.
print $array_ref->[$N]; # Обращение к N-му элементу (лучший вариант) print $$array_ref[$N]; # To же, но менее наглядно print ${$array_ref}[$N]; # То же, но непонятно и уродливо
Имея ссылку на массив, можно получить срез субъектного массива?
@$pie[3. 5]; # Срез массива, но читается плохо
@{$pie}[3..5]; # Срез массива, читается лучше С)
Срезы массивов, даже при обращении через ссылки, допускают присваивание. В следующей строке сначала происходит разыменование массива, после чего элементам среза присваиваются значения:
@{$pie}[3. 5] = ("blackberry", "blueberry", "pumpkin");
Срез массива полностью идентичен списку отдельных элементов. Поскольку ссылку на список получить нельзя, вам не удастся получить ссылку на срез массива:
Ssliceref = \@{$pie}[3..5]; # НЕВЕРНО1
Для перебора в массиве применяется цикл foreach или for:
foreach $item ( @{$array_ref} ) { # Данные в $item
for ($idx = 0; $idx <= $#{ $array_ref }; $idx++) {
# Данные в $array_ref->[$idx] }
> Смотри также---------------------------------------------------------------------------------------------
perlref{\) nperlhl(i); рецепты 2.14; 4.5.
11.2. Создание хэшей массивов
Проблема
С каждым ключом хэша может быть ассоциирована лишь одна скалярная величина, однако вам хочется использовать один ключ для хранения и извлечения нескольких величин. Иначе говоря, вы хотите, чтобы ассоциированное значение представляло собой список.
Решение
Сохраните в элементе хэша ссылку на массив. Используйте push для присоединения новых элементов:
push(@{ $hash{"KEYNAME'} }, "new value');
Затем при выводе хэша разыменуйте значение как ссылку на массив:
foreach Sstring (keys %hash) {
print "$stnng: @{$hash{$string}}\n",
Комментарий
В хэше могут храниться только скалярные величины. Впрочем, ссылки и являются скалярными величинами. Они помогают решить проблему сохранения не-
Присвоение ключу нескольких значений осуществляется следующим образом:
$hash{ a key } = [ 3, 4, 5 ] # Анонимный массив
Ключ с ассоциированным массивом используется так:
©values = @{ $hash{ a key } }
Для присоединения новых значений к массиву, ассоциированному с конкретным ключом, используется функция push:
push @>{ $hash{ a key } } $value
Классическое применение этой структуры данных — инвертирование хэша, в котором одно значение ассоциируется с несколькими ключами. В хэше, полученном после инвертирования, один ключ ассоциирован с несколькими значениями. Эта проблема рассматривается в рецепте 5.8.
Учтите, что запись вида:
Residents = @{ $phone2name{$number} },
при действующей директиве use st net вызовет исключение, поскольку вы пытаетесь разыменовать неопределенную ссылку без автоматического создания. Приходится использовать другую формулировку:
©residents = exists( $phone2name{$number} ) 7 (s>{ $phone2name{$number} } О >
t> Смотри также--------------------------------------------------------------------------------------------
Раздел «Hashes of Arrays» perldsc(l); рецепт 5.8; пример «Хэш с автоматическим дополнением» из рецепта 13.15.
11.3. Получение ссылок на хэши
Проблема
Требуется работать с хэшем по ссылке. Например, ссылка может передаваться функции или входить во внешнюю структуру данных.
Решение
Получение ссылки на хэш:
$href = \%hash,
$anon_hash = { key1 => valuel key2 => value2 }
$anon_hash_copy = { %hash }
Разыменование ссылки на хэш:
%hash = %$href,
Svalue = $href->{$key}
(as]ice = @$href{$key1 $key2 $key3}, # Обратите внимание стрелки нет1
@keys = keys %$hash,
Проверка того, является ли переменная ссылкой на хэш:
if (ref($someref) ne HASH ) {
die Expected a hash reference, not $someref\n
Комментарий
Следующий пример выводит все юпочи и значения двух заранее определенных хэшей:
foreach $href ( \%ENV, \%INC ) { # ИЛИ for $href ( \(%ENV %INC) ) { foreach $key ( keys %$href ) {
print $key => $href->{$key}\n ,
Операции со срезами хэшсй по ссылке выполняются так же, как со срезами массивов. Например:
lvalues = @$hash_ref{ key1 , key2 , кеуЗ },
for $val ((§)$hash_ref{ key1 key2 , кеуЗ }) {
$val +=7 # Прибавить 7 к каждому значению в срезе хэша
> Смотри также
Глава 5 «Хэши»; perlref(l), рецепт 11.9.
11.4. Получение ссылок на функции
Проблема
Требуется создать ссылку для вызова подпрограммы. Такая задача возникает при создании обработчиков сигналов, косвенно-вызываемых функций Тк и указателей на хэши функций.
Решение
Получение ссылки на функцию:
$cref = \&func, $cref = sub { },
Вызов функции по ссылке:
^returned = $cref->(@arguments), ^returned = &$cref(^arguments).
Комментарий
Чтобы получить ссылку на функцию, достаточно снабдить ее имя префиксом \&. Кроме того, формулировка sub {} позволяет создавать анонимные функции. Ссылка на анонимную функцию может быть сохранена так же, как и любая другая.
В Perl 5.004 появилась постфиксная запись для разыменования ссылок на функции. Чтобы вызвать функцию по ссылке, раньше приходилось писать &$f uncname (@ARGS), где Sfuncname — имя функции. Возможность сохранить имя функции в переменной осталась и сейчас:
Sfuncname = "thefunc"; &$funcname();
однако подобное решение нежелательно по нескольким причинам. Во-первых, в нем используются символические, а не настоящие (жесткие) ссылки, поэтому при действующей директиве use strict 'refs' оно отпадает. Символические ссылки обычно не рекомендуются, поскольку они не могут обращаться к лексическим, а только к глобальным переменным, и для них не ведется подсчет ссылок.
Во-вторых, оно не содержит данных о пакете, поэтому выполнение фрагмента в другом пакете может привести к вызову неверной функции. Наконец, если функция была в какой-то момент переопределена (хотя это происходит нечасто), символическая ссылка будет обращаться к текущему определению функции, а жесткая ссылка сохранит старое определение.
Вместо того чтобы сохранять имя функции в переменной, создайте ссылку на нее с помощью оператора \. Именно так следует сохранять функцию в переменной или передавать ее другой функции. Ссылки на именованные функции можно комбинировать со ссылками на анонимные функции:
my %commands = (
"happy" => \&]оу,
"sad" => \&sullen,
"done" => sub { die "See ya1" },
"mad" => \&angry,
)
print "How are you' "; chomp($strmg = <STDIN>); if ($commands{$stnng}) {
$commands{$string}->(); } else {
print "No such command: $strmg\n"; }
Если вы создаете анонимную функцию, которая ссылается на лексическую (ту) переменную из вмещающей области действия, схема подсчета ссылок гарантирует, что память лексической переменной не будет освобождена при наличии ссылок на нее:
sub counterjnaker {
my $start = 0;
return sub { # Замыкание
return $start++; # Лексическая переменная
# из вмещающей области действия
Scounter = counter_maker();
for ($i =0; $i < 5; $i ++) { print &$counter, "\n";
Даже несмотря на то что функция countermaker завершилась, а переменная $start вышла из области действия, Perl не освобождает ее, поскольку анонимная подпрограмма (на которую ссылается $counter) все еще содержит ссылку на $start. Если повторно вызвать counter_maker, функция вернет ссылку на другую анонимную подпрограмму, использующую другое значение $start:
$counter1 = counter_maker(); $counter2 = counter_maker();
for ($i =0; $i < 5; $i ++) { print &$counter1, "\n",
print &$counter1,
01
2
3
&$counter2, "\n",
5 0
Замыкания часто используются в косвенно-вызываемых функциях (callbacks). В графических интерфейсах и вообще в программировании, основанном на событиях, определенные фрагменты кода связываются с событиями нажатий клавиш, щелчков мышью, отображения окон и т. д. Этот код вызывается много позже, возможно, из совсем другой области действия. Переменные, используемые в замыкании, должны быть доступными к моменту вызова. Для нормальной работы они должны быть лексическими, а не глобальными.Замыкания также используются в генераторах функций, то есть в функциях, которые создают и возвращают другие функции. Функция counter_maker является генератором. Приведем еще один простой пример:
sub timestamp {
my $start_time = time();
return sub { return time() - $start_time }; }
$early = timestampO; sleep 20;
Slater = timestampO; sleep 10;
printf "It's been %d seconds since early.\n", $early->(); printf "It s been %d seconds since later.\n", $later->(); It's been 30 seconds since early. It's been 10 seconds since later.
> Смотри также---------------------------------------------------------------------------------------------
Описание замыканий в perlref(l); рецепты 10.11; 11.4.
11.5. Получение ссылок на скаляры
Проблема
Требуется создать ссылку на скалярную величину и работать с ней.
Решение
Для создания ссылки на скалярную величину воспользуйтесь оператором \:
$scalar_ref = \$scalar; # Получение ссылки на именованный скаляр
Чтобы создать ссылку на анонимную скалярную величину (то есть скаляр, не являющийся переменной), присвойте нужное значение через разыменование неопределенной переменной:
undef $anon_scalar_ref; $$anon_scalar_ref = 15;
Ссылка на скалярную константу создается следующим образом:
$anon_scalar_ref = \15;
Разыменование выполняется конструкцией ${...}:
print ${ $scalar_ref }; # Разыменовать
${ $scalar_ref } .= "string"; # Изменить значение субъекта
Комментарий
Если вам понадобилось создать много новых анонимных скаляров, воспользуйтесь функцией, возвращающей ссылку на лексическую переменную вне области действия, как объяснялось во введении:
sub new_anon_scalar {
my $temp;
return \$temp; }
Perl почти никогда не выполняет косвенного разыменования. Исключение составляют ссылки на файловые манипуляторы, программные ссылки на sort и ссылочный аргумент функции bless. Из-за этого для разыменования скалярной переменной следует снабдить ее префиксом $, чтобы получить все ее содержимое:
$sref = new_anon_scalar();
$$sref = 3;
print "Three = $$sref\n";
11.6. Создание массивов ссылок на скаляры 389
@array_of_srefs = ( new_anon_scalar(), new_anon_scalar() );
${ $array[0] } = 6.02е23;
${ $array[1] } = "avocado";
print "уэаггау contains: ", join(", ", map { $$_ } @array ), "\n";
Обратите внимание на фигурные скобки вокруг $аггау[0] и $аггау[1]. Если бы мы попытались ограничиться простым $$аггау[0], то в процессе разыменования получили бы $аггау->[0]. Переменная $аггау интерпретировалась бы как ссылка на массив, поэтому в результате был бы возвращен элемент с нулевым индексом.
Приведем другие примеры, в которых фигурные скобки необязательны:
$var = 'uptime'; й $var содержит текст
$vref = \$var; # $vref "указывает на" $var
if ($$vref =~ /load/) {} # Косвенное обращение к $var
chomp $$vref; й Косвенное изменение $var
Как упоминалось во введении, для определения типа субъекта по ссылке применяется встроенная функция ref. При вызове ref для ссылки на скаляр возвращается строка "SCALAR":
# Проверить, содержит ли Ssomeref ссылку на скаляр if (ref(Ssomeref) ne 'SCALAR') {
die "Expected a scalar reference, not $someref\n";
О Смотри также--------------------------------------------------------------------------------------------
perlref(l).
11.6. Создание массивов ссылок на скаляры
Проблема
Требуется создать массив ссылок на скаляры. Такая задача часто возникает при передаче функциям переменных по ссылке, чтобы функция могла изменить их значения.
Решение
Чтобы создать массив, либо снабдите префиксом \ каждый скаляр в списке:
(9>array_of_scalar_refs = ( \$а, \$Ь );
либо просто поставьте \ перед всем списком, используя свойство дистрибутивности оператора \:
@array_of_scalar_refs = \( $а, $Ь );
Чтобы получить или задать значение элемента списка, воспользуйтесь конструкцией ${...}:
${ $array_of_scalar_refs[1] } = 12; # $b = 12
Комментарий
В следующих примерах предполагается, что @аггау — простой массив, содержащий ссылки на скаляры (не путайте массив ссылок со ссылкой на массив). При косвенных обращениях к данным необходимы фигурные скобки.
©array = (\$a, \$b, \$c, \$d); # Ссылки на все скаляры
@аггау = \( $а, $b, $c, $d); # To же самое!
${ $аггау[2] } += 9; # $с = 12
$< $аггау[ $#аггау ] } *= 5; # $d = 20
${ $array[-1] } •= 5; # То же; $d = 100
$tmp = $array[-1]; # Использование временной переменной
$$tmp *= 5; #'$d = 500
Две формы присваивания @аггау эквивалентны — оператор \ обладает свойством дистрибутивности. Следовательно, \ перед списком (но не массивом!) эквивалентно применению \ к каждому элементу списка. Следующий фрагмент изменяет значения переменных, ссылки на которые хранятся в массиве.
А вот как работать с массивом без явного индексирования.
use Math::Trig qw(pi); # Загрузить константу pi
foreach $sref (@array) { # Подготовиться к изменению $а,$b,$c, $d
($$sref *•= 3) •= (4/3 * pi); # Заменить объемом сферы
}
В этом фрагменте используется формула вычисления объема сферы: V - 4/Злр3.
Переменная цикла $sref перебирает все ссылки ©array, а в $$sref заносятся сами числа, то есть исходные переменные $а, $Ь, $с и $d. Изменение $$sref в цикле приводит к изменению этих переменных. Сначала мы возводим $$sref в куб, а затем умножаем полученный результат на 4/Зя. При этом используется то обстоятельство, что присваивание в Perl возвращает левостороннее выражение. Это позволяет сцеплять операторы присваивания, как это делается с операторами •¦= и *=.
Вообще говоря, анонимные скаляры обычно бесполезны — ведь скалярная величина занимает столько же места, что и ссылка на нее. По этой причине не предусмотрены и специальные конструкции для их создания. Скалярные ссылки существуют только для поддержки синонимов, которые могут быть реализованы и другими способами.
> Смотри также--------------------------------------------------------------------------------------------
Раздел «Assignment Operators» perlop(l).
11.7. Применение замыканий вместо объектов
Проблема
Вы хотите работать с записями, обладающими определенным состоянием, поведением и идентичностью, но вам не хочется изучать для этого объектно-ориентированное программирование.
Решение
Напишите функцию, которая возвращает (по ссылке) хэш ссылок на фрагменты кода. Все эти фрагменты представляют собой замыкания, созданные в общей области действия, поэтому при выполнении они будут совместно использовать одни и те же закрытые переменные.
Комментарий
Поскольку замыкание представляет собой совокупность кода и данных, одна из реализаций позволяет имитировать поведение объекта.
Следующий пример создает и возвращает хэш анонимных функций. Функция mkcounter получает начальное значение счетчика и возвращает ссылку, позволяющую косвенно оперировать им.
|
$d = |
mkcounter(20); |
|
|
$с2 = |
mkcounter(77); |
|
|
pnntf |
"next d: |
%d\n", |
|
printf |
"next c2: |
%d\n", |
|
printf |
"next d: |
%d\n", |
|
printf |
"last d. |
%d\n", |
|
printf |
"old c2: |
%d\n", |
$c2->{NEXT}->(); # 78
$c1->{NEXT}->(); U 22
$d->{PREV}->(); # 21
$c2->{RESET}->(); # 77
Каждая ссылка на хэш, $с1 и $с2, отдельно хранит информацию о своем состоянии. Реализация выглядит так:
|
sub mkcounter { |
|||||
|
my |
Scount = |
shift; |
|||
|
ray |
$start = |
Scount; |
|||
|
my |
Sbundle = |
{ |
|||
|
"NEXT" |
=> |
sub { |
return ++$count |
} |
|
|
"PREV" |
=> |
sub { |
return --Scount |
} |
|
|
"GET" |
=> |
sub { |
return Scount |
} |
|
|
"SET" |
=> |
sub { |
Scount = shift |
} |
|
|
"BUMP" |
=> |
sub { |
Scount += shift |
} |
|
|
"RESET" |
=> |
sub { |
Scount = Sstart |
} |
$bundle->{"LAST"} = $bundle->{"PREV"}; return $bundle; }
Поскольку лексические переменные, используемые замыканиями в ссылке на хэш $bundle, используются функцией, они не освобождаются. При следующем вызове mkcounter замыкания получают другой набор привязок переменных для того же кода. Никто не сможет обратиться к этим двум переменным за пределами замыканий, поэтому полная инкапсуляция гарантирована.
В результате присваивания, расположенного непосредственно перед return, значения "prev" и "last" будут ссылаться на одно и то же замыкание. Если вы разбираетесь в объектно-ориентированном программировании, можете считать их двумя разными сообщениями, реализованными с применением одного метода.
Возвращаемая нами совокупность не является полноценным объектом, поскольку не поддерживает наследования и полиморфизма (пока). Однако она несом-
> Смотри также--------------------------------------------------------------------------------------------
Замыкания рассматриваются вperlref(l). Также см. главу 13, рецепты 10.11; 11.4.
11.8. Создание ссылок на методы
Проблема
Требуется сохранить ссылку на метод.
Решение
Создайте замыкание, обеспечивающее вызов нужного метода для объекта.
Комментарий
Ссылка на метод — это нечто большее, чем простой указатель на функцию. Вам также придется определить, для какого объекта вызывается метод, поскольку исходные данные для работы метода содержатся в объекте. Оптимальным решением будет использование замыкания. Если переменная $obj имеет лексическую область действия, воспользуйтесь следующим фрагментом:
$mref = sub { $ob]->meth(@_) };
# Позднее...
$mref->("args", "go", "here");
Даже когда переменная $obj выходит из области действия, она остается в замыкании, хранящемся в $mref. Позднее при косвенном вызове метода будет использован правильный объект.
Учтите, что формулировка:
$sref = \$obj->meth;
работает не так, как можно предположить. Сначала она вызывает метод объекта, а затем дает ссылку либо на возвращаемое значение, либо на последнее из возвращаемых значений, если метод возвращает список.
Метод сап из базового класса UNIVERSAL выглядит заманчиво, но вряд ли делает именно то, что вы хотите:
$cref = $obj->can("meth");
Он дает ссылку на код соответствующего метода (если он будет найден), не несущую информации об объекте. В сущности, вы получаете обычный указатель на функцию. Информация об объекте теряется. Из-за этого и понадобилось замыкание, запоминающее как состояние объекта, так и вызываемый метод.
> Смотри также —---------------------------------------------------------------------------------------
Описание методов во введении к главе 13; рецепты 11.7; 13.7.
11.9. Конструирование записей
Проблема
Требуется создать тип данных для хранения атрибутов (запись).
Решение
Воспользуйтесь ссылкой на анонимный хэш.
Комментарий
Предположим, вам захотелось создать тип данных, содержащий различные атрибуты — аналог структур С или записей Pascal. Проще всего сделать это с помощью анонимного хэша. Следующий пример демонстрирует процесс инициализации и применения записи, содержащей информацию о работнике фирмы:
|
$record = |
{ |
||
|
NAME |
=> |
'Jason", |
|
|
EMPNO |
=> |
132, |
|
|
TITLE |
=> |
"deputy peon", |
|
|
AGE |
=> |
23, |
|
|
SALARY |
=> |
37_000, |
|
|
PALS |
=> |
[ "Norbert", "Rhys' , |
"Phineas"], |
|
printf "I |
am 1 |
is, and my pals are %s |
An", |
|
$record->{NAME}, |
|||
|
]oin(" |
, @{$record->{PALS}}); |
# Сохранить запись
$byname{ $record->{NAME} } = $record;
# Позднее искать по имени
if ($rp = $byname{"Aron"}) { # false, если отсутствует missing
printf "Aron is employee %d \n", $rp-><EMPNO};
# Дать Джейсону нового друга
push @{$byname{"Jason"}->{PALS}}, "Theodore";
printf "Jason now has %d pals\n", scalar @{$byname{"Jason"}->{PALS}};
В результате %byname превращается в хэш хэшей, поскольку хранящиеся в нем значения представляют собой ссылки на хэши. Поиск работника но имени с применением такой структуры оказывается простой задачей. Если значение найдено в хэше, мы сохраняем ссылку на запись во временной переменной $гр, с помощью которой далее можно получить любое нужное поле.
Для операций с %byname можно использовать стандартные средства работы с хэшами. Например, итератор each организует перебор элементов в произвольном порядке:
Глава 11 • Ссылки и записи
# Перебор всех записейwhile (($name, $record) = each %bynane) {
printf "%s is employee number %d\n", $name, $record->{EMPNO}, }
А как насчет поиска работников по номеру? Достаточно построить другую структуру данных — массив хэшей ^employees. Если работники нумеруются непоследовательно (скажем, после 1 следует номер 159997), выбор массива окажется неудачным. Вместо этого следует воспользоваться хэшем, в котором номер работника ассоциируется с записью. Для последовательной нумерации подойдет и массив:
# Сохранить запись
$employees[ $record->{EMPNO} ] = Srecord,
# Поиск по номеру
if ($rp = $employee[132]) {
printf 'employee number 132 is %s\n , $rp->{NAME}, >
При работе с подобными структурами данных обновление записи в одном месте обновляет ее везде. Например, следующая команда повышает жалование Джейсо-на на 3,5%:
$byname{'Jason¦}->{SALARY} *= 1 035,
Внесенные изменения отражаются во всех представлениях этих записей. Помните о том, что $byname{ 'Jason '} и $employees[ 132] ссылаются на одну и ту же запись, поскольку хранящиеся в них ссылки относятся к одному анонимному хэшу.
Как отобрать все записи, удовлетворяющие некоторому критерию? Для этого и была создана функция g rep. Например, в следующем фрагменте отбираются два подмножества записей — работников, чья должность содержит слово "peon", и тех, чей возраст равен 27 годам.
(Speons = grep { $_->{TITLE} =~ /peon/i } ©employees,
(atsevens = grep { $_->{AGE} == 27 } ^employees;
Каждый элемент @peons и @tsevens представляет собой ссылку на запись, поэтому они, как и ©employees, являются массивами хэшей.
Вывод записей в определенном порядке (например, по возрасту) выполняется так:
# Перебрать все записи
foreach $rp (sort { $a->{AGE> <=> $b->{AGE} } values %byname) {
printf '%s is age %d.\n", $rp->{NAME>, $rp->{AGE};
# или со срезом хэша через ссылку
printf "%s is employee number %d.\n", @$rp{'NAME', 'EMPNO'}; >
Вместо того чтобы тратить время на сортировку по возрасту, можно просто создать для этих записей другое представление, @byage. Каждый элемент массива (например, $byage[27]) является массивом всех записей с данным возрастом. Фактически мы получаем массив массивов хэшей. Он строится так:
# Используем @byage, массив массивов записей push @{ $byage[ $record->{AGE> ] >, Srecord;
Далее отбор осуществляется следующим образом:
for ($age = 0; $age <= $#byage; $age++) { next unless $byage[$age]; print "Age $age-foreach $rp (@{$byage[$age]}) {
print $rp->{NAME}, ' ", } print "\n",
}
Аналогичное решение заключается в применении map, что позволяет избежать цикла foreach:
for ($age = 0, $age <= $#byage; $age++) { next unless $byage[$age]; printf "Age %d: %s\n", Sage,
', map {$_->{NAME}} @{$byage[$age]}),
> Смотри также--------------------------------------------------------------------------------------------
Рецепты 4.13; 11.3.
11.10. Чтение и сохранение записей в текстовых файлах
Проблема
Требуется прочитать или сохранить хэш записи в текстовом файле.
Решение
Воспользуйтесь простым форматом, при котором каждое поле занимает отдельную строку вида:
ИмяПоля: Значение и разделяйте записи пустыми строками.
Комментарий
Если у вас имеется массив записей, которые должны сохраняться в текстовом файле и читаться из него, воспользуйтесь простым форматом, основанным на заголовках почтовых сообщений. Из-за простоты формата ключи не могут быть двоеточиями и переводами строк, а значения — переводами строк. Следующий фрагмент записывает данные в файл:
foreach Srecord (@Array_of_Records) { for $key (sort keys %$record) {
print \n'; }
Прочитать записи из файла тоже несложно:
$/ = "', # Режим чтения абзацев
while (<>) {
my ©fields = { split /"([":]+) \s*/m >,
shift ©fields; # Удалить начальное пустое поле
push-(@Array_of_Records, { ©fields }); >
Функция split работает с $_, своим вторым аргументом по умолчанию, в котором находится прочитанный абзац. Шаблон ищет начало строки (не просто начало записи благодаря /ш), за которым следует один или более символов, не являющихся двоеточиями, затем двоеточие и необязательный пропуск. Если шаблон split содержит скобки, они возвращаются вместе со значениями. Возвращаемые значения заносятся в @f lleds в порядке «ключ/значение»; пустое поле в начале убирается. Фигурные скобки в вызове push создают ссылку на новый анонимный хэш, куда копируется содержимое ©fields. Поскольку в массиве сохранился порядок «ключ/значение», мы получаем правильно упорядоченное содержимое хэша.
Все происходящее сводится к операциям чтения и записи простого текстового файла, поэтому вы можете воспользоваться другими рецептами. Рецепт 7.11 поможет правильно организовать параллельный доступ. В рецепте 1.13 рассказано о сохранении в ключах и значениях двоеточий и переводов строк, а в рецепте 11.3 — о сохранении более сложных структур.
Если вы готовы пожертвовать элегантностью простого текстового файла в пользу быстрой базы данных с произвольным доступом, воспользуйтесь DBM-фай-лом (см. рецепт 11.14).
> Смотри также---------------------------------------------------------------------------------------------
Описание функции split вperlfunc(l)-;рецепты 11.9, 11.13—11.14.
11.11. Вывод структур данных
Проблема
Требуется вывести содержимое структуры данных.
Решение
Если важна наглядность вывода, напишите нестандартную процедуру вывода. В отладчике Perl воспользуйтесь командой х:
0B<1> $reference = [ { 'foo' => "bar" }, 3, sub { print "hello, world\n } ], DB<2> x Sreference 0 ARRAY(0x1d033c) 0 HASH(0x7b39O)
'foo' = 'bar'> 1 3
2 C0DE(0x21e3e4) - & in ???>
В программе воспользуйтесь функцией Dumper модуля Data::Dumper от CPAN:
use Data..Dumper;
print Dumper($reference),
Комментарий
Иногда для вывода структур данных в определенном формате пишутся специальные функции, но это часто оказывается перебором. В отладчике Perl существуют команды х и X, обеспечивающие симпатичный вывод. Команда х полезнее, поскольку она работает с глобальными и лексическими переменными, а X — только с глобальными. Передайте х ссылку на выводимую структуру данных.
D<1> х \@INC
О ARRAY(0x807d0a8)
О '/home/tchrist/perllib'
1 '/usr/lib/perl5/i686-linux/5.00403' 2 7usr/lib/perl5'
3 7usr/lib/perl5/site_perl/i686-linux' 4 '/usr/lib/perl5/site_perl' 5 '.'
Эти команды используют библиотеку dumpvar.pl. Рассмотрим пример:
{ package mam, require 'dumpvar.pl' }
•dumpvar = \&mairr dumpvar if _ _PACKAGE_ _ ne mam ;
dumpvar('main', "INC"); # Выводит и @INC, и %INC
Библиотека dumpvar.pl не является модулем, но мы хотим использовать ее как модуль и поэтому заставляем импортировать функцию dumpvar. Первые две строки форсируют импортирование функции mam: :dumpvar из пакета mam в текущий пакет, предполагая, что эти функции отличаются. Выходные данные будут выглядеть так:
§INC = (
0 7home/tchrist/perllib/i686-linux'
1 '/home/tchrist/perllib'
2 7usr/lib/perl5/i686-linux/5.00404'
3 '/usr/lib/perl5'
4 '/usr/lib/perl5/site_perl/i686-linux'
5 7usr/lib/perl5/site_perl'
6 '.'
)
XINC = (
'dumpvar.pl' = '/usr/lib/perl5/i686-linux/5.00404/dumpvar.pl' 'strict, pm' = 7usr/Ub/perl5/i686-linux/5.00404/strict.pm'
use Data::Dumper; print Dumper(\@INC); $VAR1 = [
'/home/tchrist/perllib', 7usr/lib/perl5/i686-linux/5.00403', 7usr/lib/perl5',
7usr/lib/perl5/site_perl/i686-linux', '/us r/lib/pe rl5/site_pe rl',
Datar.Dumper поддерживает разнообразные форматы вывода. За подробностями обращайтесь к документации.
> Смотри также--------------------------------------------------------------------------------------------
Документация по модулю Data::Dumper с CPAN; раздел «The Perl Debugger» perldebug(l).
11.12. Копирование структуры данных
Проблема
Требуется скопировать сложную структуру данных.
Решение
Воспользуйтесь функцией dclone модуля Storable от CPAN:
use Storable,
$r2 = dclone($r1),
Комментарий
Существуют два типа копирования, которые иногда путают. Поверхностное копирование (surface copy) ограничивается копированием ссылок без создания копий данных, на которые они ссылаются:
©original = ( \@а, \@Ь, \@с ); ©surface = ©original;
Глубокое копирование (deep copy) создает абсолютно новую структуру без перекрывающихся ссылок. Следующий фрагмент копирует ссылки на один уровень вглубь:
©deep = map { [ @$_ ] } ©original;
Если переменные §а, @Ь и @с сами содержат ссылки, вызов тар не решит всех проблем. Написание специального кода для глубокого копирования структур — дело трудоемкое и быстро надоедающее.
Модуль Storable, доступный на CPAN, содержит функцию dclone, которая обеспечивает рекурсивное копирование своего аргумента:
use Storable qw(dclone); $г2 = dclone($r1);
Функция работает только со ссылками или приписанными к конкретному пакету (blessed) объектами типа SCALAR, ARRAY и HASH; ссылки на CODE, GLOB и 10 и другие экзотические типы не поддерживаются. Функция saf eFreeze модуля FreezeThaw обеспечивает такую возможность для одного адресного пространства посредством использования кэша ссылок, который при некоторых обстоятельствах вмешивается в процесс сборки мусора и работу деструкторов объектов.
Поскольку dclone принимает и возвращает ссылки, при копировании хэша ссылок в нее приходится включать дополнительные символы:
%newhash = %{ dclone(\%oldhash) };
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулям Storable, Data::Dumper и FreezeThaw с CPAN.
11.13. Сохранение структур данных на диске
Проблема
Требуется сохранить большую, сложную структуру данных на диске, чтобы ее не пришлось заново строить при каждом запуске программы.
Решение
Воспользуйтесь функциями store и retrieve модуля Storable с CPAN:
use Storable; store(\%hash, "filename");
# later on ..
$href = retneve("filename"), # По ссылке
%hash = %{ retrieve("filename") }; # Прямо в хэш
Комментарий
Модуль Storable использует функции С и двоичный формат для обхода внутренних структур данных Perl и описания данных. По сравнению со строковой реализацией сохранения записей в Perl такой вариант работает эффективнее, однако он менее надежен.
Функции store и retrieve предполагают, что в передаваемых двоичных данных используется порядок байтов, стандартный для данного компьютера. Это означает, что созданные этими функциями файлы нельзя передавать между различными архитектурами. Функция nstore делает то же, что и store, но сохраняет дан-
use Storable qw(nstore), nstore(\%hash, filename ), # Позднее $href = retneve( filename )
Независимо от того, какая функция сохраняла данные — store или nstore, для их восстановления в памяти используется одна и та же функция retrieve. О переносимости должен заботиться создатель данных, а не их потребитель. Если создатель изменит свое решение, ему достаточно изменить программу всего в одном месте. Тем самым обеспечивается последовательный интерфейс со стороны потребителя, который ничего не знает об этих изменениях.
Функции store и nstore не блокируют файлы, с которыми они работают. Если вас беспокоят проблемы параллельного доступа, откройте файл самостоятельно, заблокируйте его (см. рецепт 7.11) и воспользуйтесь функцией storefd или более медленной, но независимой от платформы версией, nstore_fd.
Следующий фрагмент сохраняет хэш в файле с установкой блокировки При открытии файла не используется флаг O_TRUNC, поскольку до стирания содержимого нам приходится ждать получения блокировки.
use Storable qw(nstore_fd),
use Fcntl qw( DEFAULT flock)
sysopen(DF, /tmp/datafile , O_RDWR|O_CREAT 0666)
or die can t open /tmp/datafile S1 , flock(DF LOCK_EX) or die can t lock /tmp/datafile $i nstore_fd(\%hash, *DF)
or die can t store hash\n truncate(OF, tell(DF)) close(DF),
Другой фрагмент восстанавливает хэш из файла, также с применением блокировки:
use Storable,
use Fcntl qw( DEFAULT flock),
open(DF, < /tmp/datafile ) or die can t open /tmp/datafile $' ,
flock(DF, LOCK_SH) or die can t lock /tmp/datafile $' ,
$href = retrieve(*DF),
close(DF),
Внимательное применение этой стратегии позволяет эффективно передавать большие объекты данных между процессами, поскольку файловый манипулятор канала или сокета представляет собой байтовый поток, похожий на обычный файл.
В отличие от связей с различными реализациями DBM, модуль Storable не ограничивается одними хэшами (или массивами, как DB_File). На диске могут сохраняться произвольные структуры данных. Вся структура должна читаться или записываться полностью.
0 Смотри также---------------------------------------------------------------------------------------------
Рецепт 11.14.
11.14. Устойчивые структуры данных
Проблема
Существует сложная структура данных, которую требуется сделать устойчивой (persistent)1.
Решение
Воспользуйтесь модулем MLDBM и либо DB_File (предпочтительно), либо GDBM_File:
use MLDBM qw(DB_File), use Fcntl,
tie(%hash MLDBM , testfile db , O_CREAT|O_RDWR 0666) or die can t open tie to testfile db $' ,
# Операции с %hash
untie %hash,
Комментарий
Конечно, построение хэша из 100 000 элементов займет немало времени. Сохранение его на диске (вручную или с помощью Storable) также потребует немалых расходов памяти и вычислительных ресурсов.
Модули DBM решают эту проблему посредством связывания хэшей с файлами баз данных на диске. Вместо того чтобы читать всю структуру сразу, они извлекают данные лишь при необходимости. Для пользователя все выглядит так, словно состояние хэша сохраняется между вызовами программы
К сожалению, значения устойчивого хэша должны представлять собой простые строки. Вам не удастся легко использовать базу данных для хранения хэша хэшей, хэша массивов и т. д. — только хэши строк.
Однако модуль MLDBM с CPAN позволяет сохранять ссылки в базе данных. Преобразование ссылок в строки для внешнего хранения осуществляется с помощью Data::Dumper:
use MLDBM qw(DB_File) use Fcntl,
tie(%hash MLDBM testfile db , O_CREAT|O_RDWR, 0666) or die can t open tie to testfile db $' ,
Теперь %hash может использоваться для выборки или сохранения сложных записей на диске. Единственный недостаток заключается в том, что к ссылкам нельзя обращаться напрямую. Приходится извлекать ссылку из базы, работать с ней, а затем снова сохранять в базе.
# Не будет работать1
$hash{ some key }[4] = fred ,
$aref = $hash{"some key"}; $aref->[4] = "frecf; $hash{"sorae key") = $aref;
> Смотри также------------------------------------------------------------------------
Документация по модулю MLDBM с CPAN; рецепты 14.1; 14.7; 14.11.
11.15. Программа: бинарные деревья
Встроенные типы данных Perl представляют собой мощные, динамические структуры. В большинстве программ этих стандартных возможностей оказывается вполне достаточно. Для выполнения простого поиска почти всегда следует использовать простые хэши. Как выразился Ларри, «Весь фокус в том, чтобы использовать сильные, а не слабые стороны Perl».
Однако хэши не обладают внутренним упорядочиванием элементов. Чтобы перебрать элементы хэша в определенном порядке, необходимо сначала извлечь ключи, а затем отсортировать их. При многократном выполнении это может отразиться на быстродействии программы, что, однако, вряд ли оправдывает затраты времени на разработку хитроумного алгоритма.
Древовидные структуры обеспечивают упорядоченный перебор. Как реализовать дерево на Perl? Для начала загляните в свой любимый учебник по структурам данных. Воспользуйтесь анонимным хэшем для представления каждого узла дерева и переведите алгоритмы, изложенные в книге, на Perl. Обычно это задача оказывается проще, чем кажется.
Программа в примере 11.1 демонстрирует простую реализацию бинарного дерева, построенную на базе анонимных хэшей. Каждый узел состоит из трех полей: левый потомок, правый потомок и значение. Важнейшее свойство упорядоченных бинарных деревьев заключается в том, что значение левого потомка всегда меньше, чем значение текущего узла, а значение правого потомка всегда больше.
Основная программа выполняет три операции. Сначала она создает дерево с 20 случайными узлами, затем выводит три варианта обхода узлов дерева и, наконец, запрашивает у пользователя ключ и сообщает, присутствует ли этот ключ в дереве.
Функция insert использует механизм неявной передачи скаляров по ссылке для инициализации пустого дерева при вставке пустого узла. Присваивание $_[0] созданного узла приводит к изменению значения на вызывающей стороне.
Хотя такая структура данных занимает гораздо больше памяти, чем простой хэш, и обычный перебор элементов в ней происходит медленнее, упорядоченные перемещения выполняются быстрее.
Исходный текст программы приведен в примере 11.1.
Пример 11.1. bintree
#!/usr/bin/perl -w
# bintree - пример работы с бинарным деревом
use strict;
my($root, $n);
# Сгенерировать 20 случайных узлов
while ($п++ < 20) { insert($root, int(rand(1000))# Вывести узлы дерева в трех разных порядках
|
print "Pre order: print "In order: print "Post order: |
# Запрашивать до получения EOF
for (print 'Search'' "; <>; print "Search'' ") {chomp;
my Sfound = search($root, $_);
if (Sfound) { print "Found $_ at Sfound, $found->{VALUE}\n" }
else { print "No $_ in tree\n" }
exit; #########################################
# Функция вставляет передаваемое значение в правильную позицию
# передаваемого дерева. Если дерево не передается,
# для @_ используется механизм косвенной передачи по ссылке,
# что приводит к созданию дерева на вызывающей стороне,
sub insert {
my($tree, Svalue) = (s>_; unless (Stree) {
Stree = {}, tf Создать новый узел
Stree->{VALUE} = Svalue;
$tree->{LEFT} = undef;
$tree->{RIGHT} = undef;
$_[0] = $tree; # $_[0] - ссылочный параметр!
return;
if ($tree->{VALUE} > Svalue) { insert($tree->{LEFT}, Svalue) }
elsif ($tree->{VALUE} < Svalue) { msert($tree->{RIGHT}, Svalue) }
else { warn "dup insert of $value\n" }
# XXX: узлы не должны повторяться
# Рекурсия по левому потомку,
# вывод текущего значения
# и рекурсия по правому потомку,
sub m_order {
my($tree) = @>_; return unless $tree; in_order($tree->{LEFT}); print $tree->{VAI_UE}, " "; m_order($tree->{RIGHT>);
продолжение ¦&
404 Глава 11 • Ссылки и записи Пример 11.1 (продолжение)
# Вывод текущего значения,# рекурсия по левому потомку
# и рекурсия по правому потомку
sub pre_order {
my($tгее) = @_, return unless $tree, print $tree->{VALUE}, ' ' , pre_order($tree->{LEFT}), pre_order($tree->{RIGHT}),
# Рекурсия по левому потомку,
# рекурсия по правому потомку
# и вывод текущего значения,
sub post_order {
my($tree) = @_, return unless $tree, post_order($tree->{LEFT}), post_order($tree->{RIGHT}), print $tree->{VALUE},
# Функция определяет, присутствует ли передаваемое значение в дереве
# Если значение присутствует, функция возвращает соответствующий узел
# Поиск ускоряется за счет ограничения перебора нужной ветвью
sub search {
my($tree, Svalue) = @_,
return unless $tree,
if ($tree->{VALUE} == $value) {
return $tree, } search($tree->{ (Svalue < $tree->{VALUE}) ? 'LEFT' RIGHT'}, $value)
Пакеты, библиотеки
и модули м есе обладатели библиотек, Аурелиаи сознавал свою вину за то, что он недостаточно хорошо знал ее содержимое.
Хорхе Луис Борхес, «Теологи»
Введение
Представьте, что у вас есть две программы, каждая из которых хорошо работает сама по себе. Возникает идея — создать третью программу, объединяющую лучшие свойства первых двух. Вы копируете обе программы в новый файл и начинаете перемещать фрагменты. Выясняется, что в программах встречаются переменные и функции с одинаковыми именами, которые невозможно объединить. Например, каждая программа может содержать функцию mit или глобальную переменную $count. При объединении эти компоненты вступают в конфликт.
Проблема решается с помощью пакетов. Пакеты используются в Perl для разделения глобального пространства имен. Они образуют основу как для традиционных модулей, так и для объектно-ориентированных классов. Подобно тому, как каталог содержит файлы, пакет содержит идентификаторы. Каждый глобальный идентификатор (переменная, функция, манипулятор файла или каталога, формат) состоит из двух частей: имени пакета и собственно идентификатора. Эти две части разделяются символами : .. Например, переменная $CGI. ,needs_binmode представляет собой глобальную переменную с именем $needs_binmode, принадлежащую пакету CGI (до выхода версии 5.000 для этой цели использовался апостроф — например, $CGI'needs_bin_mode). Переменная $Names: :startup — это переменная $startup пакета Names, a $Dates:: startup — переменная Sstartup пакета Dates. Идентификатор Sstartup без имени пакета означает глобальную переменную Sstartup текущего пакета (при условии, что в данный момент не видна лексическая переменная Sstartup; о лексических переменных рассказано в главе 10 «Подпрограммы»). При указании неполного имени (то есть имени переменной без пакета) лексические переменные переопределяют глобальные. Лексическая переменная существует в области действия; глобальная — на уровне пакета. Если вам нужна глобальная переменная, укажите ее полное имя.
package Alpha; $name = "first";
package Onega; $name = "last";
package mam;
print "Alpha is $Alpha::name, Omega is $Omega:;name.\n";
Alpha is first, Omega is last.
В отличие от пользовательских идентификаторов, встроенные переменные со специальными именами (например, $_ и $.) и идентификаторы STDIN, STDOUT, STDERR, ARGV, ARGVOUT, ENV, ING и SIG без указания имени пакета считаются принадлежащими к пакету main. Благодаря этому STDIN, @ARGV, %ENV и $_ всегда означают одно и то же независимо от текущего пакета; например, @ARGV всегда относится к @main: : ARGV, даже если вы измените пакет по умолчанию командой package. Уточненное имя ©ElseWhere: : ARGV относится к нестандартному массиву @ARGV и не обладает специальным значением. Не забудьте локализовать переменную $_, если вы используете ее в своем модуле.
Модули
Многократное использование кода в Perl осуществляется с помощью модулей. Модуль представляет собой файл, содержащий набор взаимосвязанных функций, которые используются другими программами и библиотечными модулями. У каждого модуля имеется внешний интерфейс — набор переменных и функций, предназначенных для использования за его пределами. Внутри модуля интерфейс определяется инициализацией некоторых пакетных переменных, с которыми работает стандартный модуль Exporter. За пределами модуля доступ к интерфейсу организуется посредством импортирования имен, что является побочным эффектом команды use. Внешний интерфейс модуля Perl объединяет все, что документировано для всеобщего применения. К недокументированному интерфейсу относится все, что не предназначено для широкой публики. Говоря о модулях в этой главе и о традиционных модулях вообще, мы имеем в виду модули, использующие Exporter.
Команды require и use подключают модуль к вашей программе, хотя и облада ют несколько разной семантикой. Команда require загружает модуль во время выполнения с проверкой, позволяющей избежать повторной загрузки модуля.
Команда use работает аналогично, но с двумя дополнительными свойствами: загрузкой модуля на стадии компиляции и автоматическим импортированием.
Модули, включаемые командой use, обрабатываются на стадии компиляции, а обработка require происходит во время выполнения. Это существенно, поскольку при отсутствии необходимого модуля программа даже не запустится — use не пройдет компиляцию сценария. Другое преимущество use перед require заключается в том, что компилятор получает доступ к прототипам функций в подпрограммах модуля. Прототипы принимаются во внимание только компилятором, но не интерпретатором (впрочем, как говорилось выше, мы рекомендуем пользоваться прототипами только для замены встроенных команд, у которых они имеются).
Обработка команды use на стадии компиляции позволяет передавать указания компилятору. Директива (pragma) представляет собой специальный модуль, влияющий на процесс компиляции Perl-кода. Имена директив всегда записываются в нижнем регистре, поэтому при написании обычного модуля следует выбирать имена, начинающиеся с большой буквы. К числу директив, поддерживаемых Perl 5.004, принадлежат autouse, constant, diagnostics, integer, lib, locale, overload, sigtrap, strict, subs и vars. Каждой директиве соответствует отдельная страница руководства.
Другое отличие use и require заключается в том, что use выполняет неявное импортирование пакета включаемого модуля. Импортирование функции или переменной из одного пакета в другой создает некое подобие синонима — иначе говоря, появляются два имени, обозначающих одно и то же. Можно провести аналогию с созданием ссылки на файл, находящийся в другом каталоге, командой In / somedir/somefile. После подключения уже не придется вводить полное имя для того, чтобы обратиться к файлу. Аналогично, импортированное имя не приходится уточнять именем пакета (или заранее объявлять с помощью use vars или use subs). Импортированные переменные можно использовать так, словно они являются частью вашего пакета. После импортирования $English: :OUTPUT_AUTOFLUSH в текущий пакет на нее можно ссылаться в виде $OUTPUT_AUTOFLUSH.
Модули Perl должны иметь расширение .рт. Например, модуль FileHandle хранится в файле FileHandle.рт. Полный путь к файлу зависит от включаемых путей, хранящихся в глобальном массиве @INC. В рецепте 12.7 показано, как работать с этим массивом.
Если имя модуля содержит одну или несколько последовательностей : ;, они преобразуются в разделитель каталогов вашей системы. Следовательно, модуль File::Find в большинстве файловых систем будет храниться в файле File/Find.pm. Например:
require "FileHandle pm"; # Загрузка во время выполнения
require FileHandle; # Предполагается ".pm";
# то же, что и выше
use FileHandle; # Загрузка во время компиляции
require "Cards/Poker, pm"; # Загрузка во время выполнения
require Cards::Poker; # Предполагается ".pm"; ч
# то же, что и выше
use Cards::Poker; # Загрузка во время компиляции
Процесс экспортирования демонстрируется ниже на примере гипотетического модуля Cards::Poker. Программа хранится в файле Poker.pm в каталоге Cards, то есть Cards/ Poker.рт (о том, где должен находиться каталог Cards, рассказано в рецепте 12.7). Приведем содержимое этого файла с пронумерованными для удобства строками:
1 package Cards :Poker,
2 use Exporter,
3 @ISA = ('Exporter'),
4 ©EXPORT = qw(&shuffle ig>card_deck),
5 @card_deck = (), # Инициализировать глобальные
# переменные пакета
6 sub shuffle { } # Определение
U заполняется позднее
7 1 # Не забудьте1
8 строке 1 объявляется пакет, в который модуль поместит свои глобальные
переменные и функции. Обычно модуль начинается с переключения на конкрет
ный пакет, что позволяет ему хранить глобальные переменные и функции так,
чтобы они не конфликтовали с переменными и функциями других программ. Имя
пакета должно быть записано точно так же, как и при загрузке модуля соответству
ющей командой use.
Не пишите package Poker только потому, что модуль хранится в файле Poker.pml Используйте package Cards:: Poker, поскольку в пользовательской программе будет стоять команда use Cards: ' Poker. Эту распространенную ошибку трудно обнаружить. Если между командами package и use нет точного соответствия, проблемы возникнут лишь при попытке вызвать импортированную функцию или обратиться к импортированной переменной — те будут загадочным образом отсутствовать.
Строка 2 загружает модуль Exporter, управляющий внешним интерфейсом модуля (см. ниже). Строка 3 инициализирует специальный, существующий на уровне пакета массив @ISA строкой "Exporter'. Когда в программе пользователя встречается команда use Cards: .Poker, Perl неявно вызывает специальный метод, Cards' :Poker->import(). В пакете нет метода import, но это нормально — такой метод есть в пакете Exporter, и вы наследуете его благодаря присваиванию @ISA (ISA = «is а», то есть «является»). Perl обращается к массиву ©ISA пакета при обращении к неопределенному методу. Наследование рассматривается в главе 13 «Классы, объекты и связи». Пока не обращайте на него внимания, но не забывайте вставлять код строк 2 и 3 в каждый новый модуль.
Строка 4 заносит список ('&shuffle', '@card_deck') в специальный, существующий на уровне пакета массив ©EXPORT. При импортировании модуля для переменных и функций, перечисленных в этом массиве, создаются синонимы в вызывающем пакете. Благодаря этому после импортирования вам не придется вызывать функцию в виде Poker: :Deck: :shuffle(23) — хватит простого shuffle(23). Этого не произойдет при загрузке Cards::Poker командой require Cards::Poker; импортирование выполняется только для use.
Строки 5 и 6 готовят глобальные переменные и функции пакета к экспортированию (конечно, вы предоставите более конкретные инициализации и определе-
ния, чем в нашем примере). Добавьте другие переменные и функции, включая и те, которые не были включены в внешний интерфейс посредством ©EXPORT. Об использовании модуля Exporter рассказано в рецепте 12.1.
Наконец, строка 7 определяет общее возвращаемое значение модуля. В нашем случае это просто 1. Если носледнее вычисляемое выражение модуля не дает истинного значения, инициируется исключение. Обработка исключений рассматривается в рецепте 12.2. Подойдет любое истинное выражение, будь то 6.02е23 или "Because tchrist and gnat told us to put this here"; однако 1 — каноническая истинная величина, используемая почти во всех модулях.
Пакеты обеспечивают группировку и организацию глобальных идентификаторов. Они не имеют ничего общего с ограничением доступа. Код, откомпилированный в пакете Church, может свободно просматривать и изменять переменные пакета State. Пакетные переменные всегда являются глобальными и общедоступными. Но это вполне нормально, поскольку модуль представляет собой больше, чем простой пакет; он также является файлом, а файлы обладают собственной областью действия. Следовательно, если вам нужно ограничить доступ, используйте лексические переменные вместо глобальных. Эта тема рассматривается в рецепте 12.4.
Другие типы библиотечных файлов
Библиотека представляет собой набор неформально взаимосвязанных функций, используемых другими программами. Библиотеки не обладают жесткой семантикой модулей Perl. Их можно узнать по расширению файла .pi — например, syslog.pl и chat2.pl.
Библиотека Perl (а в сущности, любой файл, содержащий код Perl) может загружаться командой do ' file, pi' или require ' f il. pi'. Второй вариант лучше, поскольку в отличие от do require выполняет неявную проверку ошибок. Команда инициирует исключение, если файл не будет найден в пути @INC, не компилируется или не возвращает истинного значения при выполнении инициализирующего кода (последняя строка с 1, о которой говорилось выше). Другое преимущество require заключается в том, что команда следит за загруженными файлами с помощью глобального хэша % IN С. Если %INC сообщает, что файл уже был загружен, он не загружается повторно.
Библиотеки хорошо работают в программах, однако в ситуациях, когда одна библиотека использует другую, могут возникнуть проблемы. Соответственно, простые библиотеки Perl в значительной степени устарели и были заменены более современными модулями. Однако некоторые программы продолжают пользоваться библиотеками, обычно загружая их командой require вместо do.
В Perl встречаются и другие расширения файлов. Расширение .ph используется для заголовочных файлов С, преобразованных в библиотеки Perl утилитой h2ph (см. рецепт 12.14). Расширение .xs соответствует исходному файлу С (возможно, созданному утилитой h2xs), скомпилированному утилитой xsubpp и компилятором С в машинный код. Процесс создания смешанных модулей рассматривается в рецепте 12.15.
До настоящего времени мы рассматривали лишь традиционные модули, которые экспортируют свой интерфейс, предоставляя вызывающей стороне прямой доступ к некоторым подпрограммам и переменным. К этой категории относится
Пользуйтесь готовыми решениями
CPAN (Comprehensive Perl Archive Network) представляет собой гигантское хранилище практически всех ресурсов, относящихся к Perl, — исходные тексты, документацию, версии для альтернативных платформ и, что самое главное, модули. Перед.тем как браться за новый модуль, загляните на CPAN и поищите там готовое решение. Даже если его не существует, может найтись что-нибудь похожее, полезное в вашей работе.
На CPAN можно обратиться по адресу http://www.perl.com/CPAN/CPAN.html (или ftp://www.perl.com/pub/perl/CPAN/CPAN.html). В этом файле кратко описан каждый модуль, входящий в CPAN. Поскольку файл редактируется вручную, в нем могут отсутствовать описания последних модулей. Необходимую информацию можно получить по адресу CF'AN/RECENT'или CPAN/RECENT.html.
Каталог модулей находится по адресу CPAN/modules. В нем содержатся индексы всех зарегистрированных модулей, а также имеются три удобных подкаталога: byjnodule (сортировка по модулям), by_author (сортировка по авторам) и byjoategory (сортировка по категориям). В каждом подкаталоге перечислены одни и те же модули, но подкаталог by_category, вероятно, наиболее удобен. Находящиеся в нем подкаталоги соответствуют конкретным прикладным областям, среди которых — интерфейсы операционной системы, сетевые взаимодействия, модемы и межпроцессные коммуникации, интерфейсы баз данных, пользовательские интерфейсы, интерфейсы к другим языкам программирования, аутентификация, безопасность и шифрование, World Wide Web, HTML, HTTP, CGI и MIME, графика, операции с растровыми изображениями, построение графиков — и это лишь малая часть.
> Смотри также---------------------------------------------------------------------------------------------
Разделы «Packages» и «Modules» Bperlmod(l).
12.1. Определение интерфейса модуля
Проблема
Требуется определить внешний интерфейс модуля с помощью стандартного модуля Exporter.
Решение
Включите в файл модуля (например, YourModule.pm) приведенный ниже фрагмент. Многоточия заполняются в соответствии с инструкциями, приведенными в разделе «Комментарий».
package YourModule;
use strict;
use vars qw(@ISA ©EXPORT ©EXPORTJ)K %EXPORT_TAGS $VERSION);
use Exporter;
SVERSION =1.00; # Или выше
©ISA = qw(Exporter);
©EXPORT = qw(...); # Автоматически экспортируемые имена
й (набор :DEFAULT)
@EXP0RT_OK = qw(...); й Имена, экспортируемые по запросу
%EXPORT_TAGS = ( # Определение имен для наборов
TAG1 => [...],
TAG2 => [...],
#####й##йй######й###й##й й Ваш программный код #################йй#####
1; й Так должна выглядеть последняя строка
Чтобы воспользоваться модулем YourModule в другом файле, выберите один из следующих вариантов:
use YourModule; # Импортировать в пакет имена по умолчанию
use YourModule qw(..,); # Импортировать в пакет перечисленные имена
use YourModule (); й Не импортировать никаких имен
use YourModule qw(:TAG1); й Импортировать набор имен
Комментарий
Внешний интерфейс модуля определяется с помощью стандартного модуля Exporter. Хотя в пакете можно определить собственный метод import, почти никто этого не делает.
Когда в программе встречается команда use YourModule, в действительности выполняется команда require "YourModule. pm", за которой вызывается метод YourModule->import(). Это происходит во время компиляции. Метод import, унаследованный из пакета Exporter, ищет в вашем пакете глобальные переменные, управляющие его работой. Поскольку они должны быть пакетными, мы используем директиву use vars, чтобы избежать проблем с use strict. Это следующие переменные.
$VERSION
При загрузке модуля можно указать минимальный допустимый номер версии. Если версия окажется ниже, use инициирует исключение.
use YourModule 1.86 # Если $VERSION < 1.86, происходит исключение
$EXPORT
Массив содержит список функций и переменных, экспортируемых в пространство имен вызывающей стороны, чтобы в дальнейшем к ним можно было
(SEXPORT = qw(&F1 &F2 @List)
(SEXPORT = qw( F1 F2 @List) # To же
После выполнения простой команды use YourModule вы сможете вызывать функцию &F1 в виде F1 () вместо YourModule F1 () и обращаться к массиву @List вместо ©YourModule List. Амперсанд (&) перед спецификацией экспортированной функции необязателен.
Чтобы загрузить модуль во время компиляции, но при этом запретить экспортирование каких-либо имен, воспользуйтесь специальной формой с пустым списком use Exporter^).
@EXPORT_OK
Массив содержит имена, которые могут импортироваться по конкретному запросу. Если массив заполнен следующим образом:
@EXP0RT_0K = qw(0p_Func %Table), то пользователь сможет загрузить модуль командой:
use YourModule qw(0p_Func %Table F1)
и импортировать только функцию Op_Func, хэш %ТаЫе и функцию F1. Функция F1 присутствует в массиве ©EXPORT. Обратите внимание: команда не выполняет автоматического импортирования F2 или @List, хотя эти имена присутствуют в ©EXPORT. Чтобы получить все содержимое ©EXPORT и плюс к тому все дополнительное содержимое @EXPORT_OK, воспользуйтесь специальным тегом DEFAULT:
use YourModule qw( DEFAULT %Table)
%EXPORT_TAGS
Хэш используется большими модулями (типа CGI или POSIX) для высокоуровневой группировки взаимосвязанных импортируемых имен Его значения представляют собой ссылки на массивы символических имен, каждое из которых должно присутствовать либо в ©EXPORT, либо в @EXPORT_OK. Приведем пример инициализации:
%EXPORT_TAGS = (
Functions => [ qw(F1 F2 Op_Func) ]
Variables => [ qw(@List %Table) ], )
Импортируемое имя с начальным двоеточием означает импортирование группы имен. Например, команда:
use YourModule qw( Functions %Table) импортирует все имена из
@{ SYourModule EXPORT_TAGS{Functions} }, то есть функции F1, F2 и Op_Func, а затем — хэш %ТаЫе.
Хотя тег DEFAULT не указывается в %EXPORT_TAGS, он обозначает все содержимое ©EXPORT.
Все эти переменные не обязательно определять в каждом модуле. Ограничьтесь лишь теми, которые будут использоваться.
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю Exporter, рецепты 12.7; 12.18
12.2. Обработка ошибок require и use
Проблема
Загружаемый модуль может отсутствовать в системе. Обычно это приводит к фатальной ошибке. Вы хотите обнаружить и перехватить эту ошибку.
Решение
Поместите require или use в eval, a eval — в блок BEGIN.
tt He импортировать BEGIN {
unless (eval require $mod ) { warn couldn t load $mod $@>
# Импортировать в текущий пакет BEGIN {
unless (eval use $mod ) { warn couldn t load $mod
Комментарий
Попытка загрузки отсутствующего или неполного модуля обычно должна приводить к аварийному завершению программы. Однако в некоторых ситуациях программа должна продолжить работу — например, попытаться загрузить другой модуль. Как и при других исключениях, для изолирования ошибок компиляции применяется конструкция eval.
Использовать eval { БЛОК } нежелательно, поскольку в этом случае будут перехватываться только исключения времени выполнения, a use относится к событиям времени компиляции. Вместо этого следует использовать конструкцию eval СТРОКА , что позволит перехватывать и ошибки компиляции. Помните: вызов require для простого слова' имеет несколько иной смысл, чем вызов requi re
Если вы хотите последовательно попытаться загрузить несколько модулей и остановиться на первом работающем, поступите так:
BEGIN {
my($found, @DBs, $mod);
$found = 0;
@DBs = qw(Giant: :Eeme Giant: :Meame Mouse: :Mynie Мое);
for $mod (@>DBs) {
if (eval "require $mod") <
$mod->import(); # При необходимости
$found = 1;
last;
die "None of @DBs loaded" unless Sfound; }
Мы включаем eval в блок BEGIN, чтобы гарантировать загрузку модуля во время компиляции, а не во время выполнения.
> Смотри также-------------------------------------------------------------------------
Рецепт 10.12; рецепт 12.3. Функции eval, die, use и require описаны в perl-func(l).
12.3. Отложенное использование модуля
Проблема
Необходимо организовать загрузку модуля на определенной стадии работы программы или вообще отказаться от его загрузки при некоторых обстоятельствах.
Решение
Разбейте use на отдельные компоненты require и import, либо воспользуйтесь директивой use autouse.
Комментарий
Если программа проверяет свои аргументы и завершает работу с информационным сообщением или ошибкой, загружать неиспользуемые модули бессмысленно. Это лишь вызывает задержки и раздражает пользователей. Но как говорилось во введении, команды use обрабатываются во время компиляции, а не во время выполнения.
Наиболее эффективная стратегия состоит в проверке аргументов внутри блока BEGIN до загрузки модулей. Следующая программа перед загрузкой необходимых модулей проверяет, что она была вызвана ровно с двумя аргументами, каждый из которых является целым числом:
BEGIN {
unless (@ARGV == 2 && (2 == grep {/"\d+$/> @ARGV)) die "usage: $0 num1 num2\n";
use Some::Module; use More::Modules;
Похожая ситуация возникает в программах, которые при разных запусках могут использовать разные наборы модулей. Например, программа factors из главы 2 «Числа» загружает библиотеку вычислений с повышенной точностью лишь при вызове с флагом -Ь. Команда use в данном случае бессмысленна, поскольку она обрабатывается во время компиляции, задолго до проверки условия if. По этой причине мы используем команду require:
if ($opt_b) {
require Math::BigInt; >
Math::BigInt является не традиционным, а объектно-ориентированным модулем, поэтому импортирование не требуется. Если у вас имеется список импортируемых объектов, укажите его в конструкции qw() так, как это было бы сделано для use. Например, вместо:
use Fcntl qw(O_EXCL O_CREAT O_RDWR); можно использовать следующую запись:
require Fcntl;
Fcntl->import(qw(0_EXCL O_CREAT 0_RDWR));
Откладывая импортирование до времени выполнения, мы сознательно идем на то, что оставшаяся часть программы не узнает об изменениях импортированной семантики, которые были бы видны компилятору при использовании use. В частности, не будут своевременно видны прототипы функций и переопределения встроенных функций.
Возникает идея — инкапсулировать отложенную загрузку в подпрограмме. Следующее, простое на первый взгляд решение не работает:
sub loadjnodule {
require $_[0]; «НЕВЕРНО
import $_[0]; «НЕВЕРНО }
Понять причину неудачи непросто. Представьте себе вызов require с аргументом "Math: : BigFloat". Если это простое слово, ;: преобразуется в разделитель каталогов операционной системы, а в конец добавляется расширение .рт. Но простая переменная интерпретируется как литерал — имя файла. Дело усугубляется тем, что Perl не имеет встроенной функции import. Существует лишь метод класса import, который мы пытаемся применить с сомнительным косвенным объектным синтаксисом. Как и в случае с косвенным применением файловых манипуляторов, косвенный объект можно использовать лишь для простой ска-
loadjnoduleC Fcntl1, qw(0_EXCL O_CREAT 0_RDWR));
sub load_module {
eval ' require $_[0]";
die if $@,
$_[0]->import((8>_[1 . $#_]); }
Но и он в общем случае не идеален. Функция должна импортировать имена не в свой пакет, а в пакет вызвавшей стороны. В принципе эта проблема решается, но процедура становится все сложнее и сложнее.
Удобное альтернативное решение — применение директивы autouse. Она появилась в Perl 5.004. Эта новая директива экономит время для редко загружаемых функций, откладывая их загрузку до момента фактического использования:
use autouse Fcntl => qw( O_EXCL() O.CREAT() O_RDWR() );
Круглые скобки после O_EXCL, O_CREAT и O_RDWR нужны для autouse, но не для use или import. Директива autouse принимает не только имена функций, ио также позволяет передать прототип функции. В соответствии с прототипами константы Fcntl вызываются без аргументов, поэтому их можно использовать в программе как простые слова без возни с use strict.
Также помните, что проверка use strict осуществляется во время компиляции. Если модуль Fcntl подключается командой use, прототипы модуля Fcntl будут откомпилированы и мы сможем использовать копстанты без круглых скобок. Если использована команда require или вызов use заключен в eval, как это делалось выше, компилятор не сможет прочитать прототипы, поэтому константы Fcntl не будут использоваться без скобок.
За сведениями об особенностях директивы autouse обращайтесь к электронной документации.
t> Смотри также--------------------------------------------------------------------------------------------
Рецепт 12.2; документация по стандартному модулю Exporter (описание метода import); документация по стандартной директиве use autouse.
12.4. Ограничение доступа к переменным модуля
Проблема
Требуется сделать переменную или функцию закрытой (то есть разрешить ее использование только в границах пакета).
Решение
Общего решения не существует. Однако можно ограничить доступ на уровне файла, в котором находится модуль, — обычно этого достаточно.
Комментарий
Помните, что пакет всего лишь определяет способ группировки переменных и функции и потому не поддерживает ограничения доступа. Все содержимое пакета по определению является глобальным и доступным отовсюду. Пакеты лишь группируют, ничего не скрывая.
Ограничение доступа возможно только с применением лексических переменных. Предположим, модуль реализован в виде файла Module.pm, а все его глобальные имена принадлежат пакету Module. Поскольку файл по определению образует самостоятельную область действия, а лексические переменные ограничиваются ею, создание лексической переменной с файловой областью действия фактически эквивалентно переменной, ограниченной данным модулем.
Однако переключение пакетов внутри области действия может привести к тому, что лексические переменные этой области остаются видны в любом месте области. Дело в том, что команда package всего лишь устанавливает новый префикс для глобальных идентификаторов.
package Alpha; my $aa = 10; $х = "azure";
package Beta; my $bb = 20; $x = "blue";
package main;
print "$aa, $bb, $x, $Alpha::x, $Beta::x\n";
10, 20, , azure, blue
На это ли вы рассчитывали? Две лексические переменные, $аа и $bb, остаются в области действия, поскольку они не вышли за границы текущего блока, файла или eval. Считайте, что глобальные и лексические переменные существуют в раз-.ных изменениях, никак не связанных друг с другом. Пакетные команды не имеют ничего общего с лексическими переменными. После установки текущего префикса первая глобальная переменная $х в действительности представляет собой $Alpha:: х, а вторая — $Beta:: х, поскольку промежуточная команда package изменила префикс по умолчанию. Доступ к пакетным идентификаторам при указании полного имени может осуществляться откуда угодно, как это делается в команде print.
Итак, пакеты не позволяют ограничивать доступ — зато на это способны модули, поскольку они находятся в файлах, а файл всегда обладает собственной областью действия. Приведенный ниже простой модуль находится в файле Flipper.pm и экспортирует две функции, f lip_words и f lip_boundary. Первая функция переставляет слова строки в обратном порядке, а вторая изменяет определение границы слова.
require Exporter;
use vars qw(@ISA ©EXPORT SVERSION);
@ISA = qw(Exporter);
@EXP0RT = qw(flip_words flip_boundary);
$VERSION =1.0;
my SSeparatrix = ' '; # По умолчанию пробел; предшествует функциям
sub flip_boundary {
my $prev_sep = SSeparatrix;
if (@_) { SSeparatrix = $_[0] }
return $prev_sep; > sub flip_words {
my $lme = $_[0];
my @words = split(SSeparatrix, Sline);
return ]oin(SSeparatrix, reverse @words); } 1;
Модуль задает значения трех пакетных переменных, необходимых для работы Exporter, а также инициализирует лексическую переменную SSeparatrix уровня файла. Как говорилось выше, эта переменная ограничивается границами файла, а не пакета. Весь код той же области действия, расположенный после ее объявления, прекрасно видит SSeparatrix. Хотя глобальные переменные не экспортировались, к ним можно обращаться по полному имени — например, $Flipper: : VERSION.
Лексические переменные, существующие в некоторой области действия, нельзя прочитать или изменить вне этой области, которая в данном случае соответствует всему файлу после объявления переменной. На лексические переменные нельзя ссылаться по полному имени или экспортировать их; экспортирование возможно лишь для глобальных переменных. Если кому-либо за пределами модуля потребуется просмотреть или изменить лексические переменные файла, они должны обратиться с запросом к модулю. Именно здесь в игру вступает функция f lip_boundary, обеспечивающая косвенный доступ к закрытым компонентам модуля.
Работа приведенного выше модуля ничуть не изменилась бы, будь SSeparatrix пакетной глобальной переменной, а не файловой лексической. Теоретически к ней можно было бы обратиться снаружи так, что модулю об этом ничего не было известно. С другой стороны, не стоит увлекаться чрезмерными ограничениями и щедро уснащать модули лексическими переменными с файловой областью действия. У вас уже имеется пространство имен (в нашем примере — Flipper), в котором можно сохранить все необходимые идентификаторы. Собственно, для этого оно и предназначено. Хороший стиль программирования на Perl почти всегда избегает полностью уточненных идентификаторов.
Если уж речь зашла о стиле, регистр символов в идентификаторах модуля Flipper выбирался не случайно. В соответствии с руководством по стилю программирования на Perl, символами верхнего регистра записываются идентификато-
ры, имеющие специальное значение для Perl. Имена функций и локальных переменных записываются в нижнем регистре. Устойчивые переменные модуля (файловые лексические или пакетные глобальные) начинаются с символа верхнего регистра. Если идентификатор состоит из нескольких слов, то для удобства чтения эти слова разделяются символами подчеркивания. Пожалуйста, не разделяйте слова символами верхнего регистра без подчеркиваний — в конце концов, вряд ли вам захотелось бы читать эту книгу без пробелов.
!> Смотри также--------------------------------------------------------------------------------------------
perlstyle(l); рецепты 10.2—10.3. Лексические переменные с файловой областью действия рассматриваются в perlmod(l).
12.5. Определение пакета вызывающей стороны
Проблема
Требуется узнать текущий или вызывающий пакет.
Решение
Текущий пакет определяется так:
$this_pack = __ PACKAGE__ ;
Пакет вызывающей стороны определяется так:
$that_pack = caller();
Комментарий
Метапеременная______ PACKAGE возвращает пакет, в котором был откомпилирован
текущий код. Значение не интерполируется в строках, заключенных в кавычки:
print "I am in package __PACKAGE__\n"; # НЕВЕРНО!
I am in package __ PACKAGE
Необходимость узнать пакет вызывающей стороны чаще возникает в старом коде, которому в качестве входных данных была передана строка для eval, файловый манипулятор, формат или имя манипулятора каталога. Рассмотрим гипотетическую функцию runit:
package Alpha; runit('$line = <TEMP>');
package Beta; sub runit {
my $codestr = shift;
eval Scodestr;
die if $@;
package Beta; sub runit {
my Scodestr = shift;
my Shispack = caller;
eval "package Shispack; $codestr";
die if $<s>; }
Новое решение не только работает с лексическими переменными, но и обладает дополнительным преимуществом — синтаксис кода проверяется во время компиляции, а это существенный плюс.
При передаче файлового манипулятора стоит воспользоваться более переносимым решением — функцией Symbol:: qualify. Она получает имя и пакет, для которого оно уточняется. Если имя нуждается в уточнении, оно исправляется, а в противном случае остается без изменений. Однако это решение заметно уступает по эффективности прототипу *.
Следующий пример читает и возвращает п строк из файлового манипулятора. Перед тем как работать с манипулятором, функция qualify уточняет его.
open (FH, "< /etc/termcap")
or die "can't open /etc/termcap• $!"; ($a, $b, $c) = nreadlme(3, 'FH');
use Symbol ();
use Carp;
sub nreadlme {
my ($count, $handle) = §_;
my(@retlist,$line);
croak "count must be > 0" unless $count > 0;
$handle = Symbol::qualify($handle, (caller())[0]);
croak "need open filehandle" unless defined fileno($handle),
push(@retlist, $line) while defined($line = <$handle>) && $count--; return ©retlist; }
Если при вызове функции nreadline файловый манипулятор всегда передается в виде тип-глоба *FH, ссылки на глоб \*FH или с помощью объектов FileHandle или 10:: Handle, уточнение не потребуется. Оно необходимо лишь на случай передачи минимального "FH".
1> Смотри также-------------------------------------------------------------------------------------------
Документация по стандартному модулю Symbol; рецепт 12.12. Специальные
метапеременные FILE__ ,__ LINE__ и__ PACKAGE_ описаны в perldata{ 1).
12.6. Автоматизированное выполнение завершающего кода
Проблема
Требуется создать для модуля начальный и завершающий код, вызываемый автоматически без вмешательства пользователя.
Решение
Начальный код реализуется просто — разместите нужные команды вне определений подпрограмм в файле модуля. Завершающий код помещается в блок END модуля.
Комментарий
В некоторых языках программист должен вызвать инициализирующий код модуля, прежде чем вызывать какие-либо его функции. Аналогично, при завершении программы от программиста может потребоваться вызов завершающего кода, выполняющего деинициализацию модуля.
В Perl дело обстоит иначе. Инициализирующий код модуля образуют команды, не входящие ни в одну подпрограмму модуля. Этот код выполняется непосредственно при загрузке модуля. Пользователю никогда не приходится следить за вызовом начального кода, поскольку это происходит автоматически.
Для чего нужен автоматический вызов завершающего кода? Все зависит от модуля. Допустим, вам захотелось записать информацию о завершении в системный журнал, приказать серверу базы данных актуализировать все незаконченные операции, обновить состояние экрана или вернуть терминал в исходное состояние.
Предположим, модуль должен регистрировать начало и завершение своей работы в журнале. Вставьте следующий фрагмент в блок END, чтобы он выполнялся при завершении программы:
$Logfile = "Amp/mylog" unless defined SLogfile; open(LF, "»$Logfile")
or die "can't append to SLogfile: $!";
select(((select(LF), $|=1))[0]); # Отменить буферизацию LF logmsgC'startup");
sub logmsg {
my $now = scalar gmtime;
print LF "$0 $$ $now: @_\n"
or die "write to SLogfile failed: $!"; >
END {
logmsg("shutdown"); close(LF)
or die "close SLogfile failed: $!";
Блоки END не отличаются от других функций завершения — trap 0 в командном интерпретаторе, atexit в языке С или глобальные деструкторы в объектно-ориентированных языках. Порядок выполнения END противоположен порядку загрузки модулей; иначе говоря, первым выполняется блок END последнего загруженного модуля. Завершающий код вызывается независимо от причины завершения — нормального достижения конца основной программы, непосредственного вызова функции exit или необработанного исключения (например, die или ошибки деления на ноль).
Однако с неперехваченными сигналами дело обстоит иначе. При завершении по сигналу блоки завершения не вызываются. Проблема решается следующей директивой:
use sigtrap qw(die normal-signals error-signals)
END также не вызывается в случае, если процесс вызывает функцию exec, поскольку процесс остается тем же самым, изменяется лишь программа. Все стандартные атрибуты (идентификатор процесса и его родителя, идентификаторы пользователя и группы, маска доступа, текущий каталог, переменные окружения, ограничения ресурсов и накопленная статистика), открытые файловые дескрипторы (однако см. описание переменной $~F в perlvar(l)) сохраняются. Другой подход привел бы к лишним вызовам блоков завершения в программах с ручной обработкой fork и exec. Это было бы нежелательно.
О Смотри также--------------------------------------------------------------------------------------------
Стандартная директива use sigtrap описана вperlmod(i), а переменная $"F — в perldata(i). Функции fork и exec рассматриваются вperlmod(l).
12.7. Ведение собственного каталога модулей
Проблема
Вы не хотите включать собственные модули в стандартную библиотеку расширений системного уровня.
Решение
Возможно несколько вариантов: воспользоваться параметром командной строки Perl -I; присвоить значение переменной окружения PERL5LIB; применить директиву use lib (возможно, в сочетании с модулем FindBin).
Комментарий
Массив @INC содержит список каталогов, которые просматриваются при каждой компиляции кода из другого файла, библиотеки или модуля командой do, require или use. Содержимое массива легко вывести из командной строки:
% perl -e 'for (@INC) { printf %d %s\rf , $1++, $_ Г
0 /usr/local/perl/lib/i686-linux/5.004
1 /usr/local/perl/lib
2 /usr/local/perl/lib/site_perl/i686-linux
3 /usr/local/perl/lib/site_perl
4 .
Первые два элемента (0 и 1) массива @INC содержат обычные платформенно-за-висимый и платформенно-независимый каталоги, с которыми работают все стандартные библиотеки, модули и директивы. Этих каталогов два, поскольку некоторые модули содержат данные или форматирование, имеющие смысл лишь для конкретной архитектуры. Например, модуль Config содержит информацию, относящуюся лишь к некоторым архитектурам, поэтому он находится в 0 элементе массива. Здесь же хранятся модули, содержащие откомпилированные компоненты на С (например, Socket.so). Однако большинство модулей находится в элементе 1 (независимый от платформы каталог).
Следующая пара, элементы 2 и 3, по своим функциям аналогична элементам О и 1, но относится к конкретной системе. Допустим, у вас имеется модуль, который не поставлялся с Perl, — например, модуль, загруженный с CPAN или написанный вами. Когда вы (или, что более вероятно, ваш системный администратор) устанавливаете этот модуль, его компоненты попадают в один из этих каталогов. Эти каталоги следует использовать для любых модулей, удобный доступ к которым должен быть в вашей системе.
Последний стандартный элемент, " " (текущий рабочий каталог), используется только в процессе разработки и тестирования программ. Если модули находятся в каталоге, куда вы перешли последней командой chdir, все хорошо. Если в любом другом месте — ничего не получится.
Иногда ни один из каталогов, указанных в @INC, не подходит. Допустим, у вас имеются личные модули или ваша рабочая группа использует свой набор модулей, относящихся только к данному проекту. В этом случае необходимо дополнить поиск по стандартному содержимому @INC.
В первом варианте решения используется флаг командной строки -1список_ка-талогов. После флага указывается список из одного или нескольких каталогов, разделенных двоеточиями1. Список вставляется в начало массива @INC. Этот вариант удобен для простых командных строк и потому может использоваться на уровне отдельных команд (например, при вызове простой однострочной программы из сценария командного интерпретатора).
Подобную методику не следует использовать в строках #!. Во-первых, редактировать каждую программу в системе скучно. Во-вторых, в некоторых старых
Нередко самое удачное решение заключается в использовании переменной окружения PERL5LIB, значение которой обычно задается в стартовом сценарии интерпретатора. Если системный администратор задаст переменную в стартовом файле системного уровня, результаты будут доступны для всех пользователей. Предположим, ваши модули хранятся в каталоге -/perllib. Включите одну из следующих строк в стартовый файл командного интерпретатора (в зависимости от того, каким интерпретатором вы пользуетесь):
# Синтаксис для sh, bash, ksh и zsh
$ export PERL5LIB=$H0ME/perllib
# Синтаксис для csh или tcsh
% setenv PERL5LIB "/perllib
Возможно, самое удобное решение с точки зрения пользователя — включение директивы use lib в начало сценария. При этом пользователям программы вообще не придется выполнять специальных действий для ее запуска. Допустим, у нас имеется гипотетический проект Spectre, программы которого используют собственный набор библиотек. Такие программы могут начинаться с команды:
use lib "/projects/spectre/lib",
Что делать, если точный путь к библиотеке неизвестен? Ведь проект может устанавливаться в произвольный каталог. Конечно, можно написать детально проработанную процедуру установки с динамическим обновлением сценария, но даже в этом случае путь будет жестко фиксироваться на стадии установки. Если позднее файлы переместятся в другой каталог, библиотеки не будут найдены.
Модуль FindBin легко решает эту проблему. Он пытается вычислить полный путь к каталогу выполняемого сценария и присваивает его важной пакетной переменной $Вт. Обычно он применяется для поиска модулей в одном каталоге с программой или в каталоге lib того же уровня.
Рассмотрим пример для первого случая. Допустим, у вас имеется программа /wherever/spectre/myprog, которая ищет свои модули в каталоге /wherever/spectrem, однако вы не хотите жестко фиксировать этот путь:
use FindBin;
use lib $FmdBin: :Bin;
Второй случай — если ваша программа находится в каталоге /wherever/spectre/ bin/myprog, но ее модули должны находиться в каталоге /wherever/spectre/lib:
use FindBin qw($Bin); use lib "$Bm/. /lib";
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартной директиве use lib и стандартному модулю FindBin. Переменная окружения PERL5LIB описана врег1(1). Переменные окружения рассматриваются в руководстве по синтаксису командного интерпретатора.
12.8. Подготовка модуля к распространению
Проблема
Вы хотите подготовить модуль в стандартном формате распространения, чтобы им можно было легко поделиться с другом. Или, что еще лучше, вы собираетесь загрузить модуль на CPAN и сделать его общедоступным.
Решение
Начните со стандартной утилиты Perl h2xs. Предположим, вы хотите создать модуль Planets или Astronomy::Orbits. Введите следующие команды:
% h2xs -XA -n Planets
% h2xs -XA -n Astronomy Orbits
Эти команды создают подкаталоги ./Planets/ и ./Astronomy/Orbits/ соответственно. В каталогах находятся все компоненты, необходимые для начала работы. Флаг -п задает имя создаваемого модуля, -X запрещает создание компонентов XS (внешних подпрограмм), а -А означает, что модуль не будет использовать AutoLoader.
Комментарий
Написать модуль несложно, если знать, как это делается. Написание «правильного» модуля похоже на заполнение юридического контракта — перед вами множество мест для инициалов, подписей и дат, и все нужно заполнить правильно. Если вы что-нибудь пропустите, контракт не имеет законной силы. Вместо того чтобы нанимать специалиста, можно воспользоваться утилитой h2xs. Она создает «скелет» файла модуля с заполненными данными об авторских правах, а также другие файлы, необходимые для правильной установки и документирования модуля, для включения его в CPAN или распространения среди друзей.
Название утилиты h2xs может сбить с толку, поскольку XS представляет собой интерфейс внешних подпрограмм Perl для компоновки с С или C++. Однако утилита h2xs также в высшей степени удобна для подготовки распространяемых модулей, даже если они и не используют интерфейс XS.
Давайте рассмотрим один из модулей, созданных утилитой h2xs. Поскольку модуль будет называться Astronomy::Orbits, вместо команды use Orbits пользователь должен вводить use Astronomy: Orbits. Следовательно, нам потребуется
package Astronomy Orbits,
Команда определяет пакет (префикс по умолчанию) для всех глобальных идентификаторов (переменных, функций, файловых манипуляторов и т. д.) данного файла. Следовательно, переменная @ISA в действительности является глобальной переменной ©Astronomy Orbits ISA.
Как было сказано во введении, использовать команду package Orbits только потому, что она находится в файле Orbits.pm, будет ошибкой. Команда package в модуле должна точно совпадать с формулировкой use или require; это означает присутствие префикса каталога, а также совпадение регистра символов. Более того, необходим промежуточный каталог Astronomy. Утилита h2xs позаботится обо всем, включая правило установки в Make-файле. Если вы готовите модуль вручную, помните об этом (см. рецепт 12.1).
Если вы собираетесь использовать автоматическую загрузку (см. рецепт 12.10), уберите флаг -А из вызова h2xs. В результате будет создан фрагмент вида:
require Exporter,
require Autoloader,
@ISA = qw(Exporter Autoloader)
Если ваш модуль использует и Perl и С (см. рецепт 12.14), уберите флаг -X из вызова h2xs. Сгенерированный фрагмент выглядит так:
require Exporter,
require DynaLoader,
@ISA = qw(Exporter DynaLoader),
Далее перечисляются переменные модуля Exporter (см. рецепт 12.1). Если вы пишете объектно-ориентированный модуль (см. главу 13), вероятно, вам вообще не придется использовать Exporter.
Подготовка завершена. Переходите к написанию кода своего модуля. Когда модуль будет готов к распространению, преобразуйте модуль в tar-архив для удобства распространения. Для этого используется команда make dist в командном интерпретаторе (имя программы make может зависеть от системы).
%make dist
Команда создает файл с именем вида Astronomy-Orbits- 1.03.tar.Z. Чтобы зарегистрироваться в качестве разработчика CPAN, обратитесь по адресу http://www.perl.com/CPAN/modules/04pause.html.
> Смотри также---------------------------------------------------------------------------------------------
h2xs(i); документация по стандартным модулям Exporter, Auto Loader, Auto-Spht и ExtUtils::MakeMaker. По адресу http://www.perl.com/CPANможно найти ближайший зеркальный узел и рекомендации, касающиеся предоставления модулей.
12.9. Ускорение загрузки модуля с помощью SelfLoader
Проблема
Вам хочется быстро загрузить очень большой модуль.
Решение
Воспользуйтесь модулем SelfLoader:
require Exporter,
require SelfLoader,
@ISA = qw(Exporter SelfLoader)
# "
# Прочие инициализации и объявления
ft
__DATA__
sub abc { }
sub def { }
Комментарий
При загрузке модуля командой require или use необходимо прочитать содержимое всего файла модуля и откомпилировать его (во внутренние деревья лексического анализа, не в байт-код или машинный код). Для очень больших модулей эта раздражающая задержка совершенно не нужна, если вам нужны всего несколько функций из конкретного файла.
Модуль SelfLoader решает эту проблему, откладывая компиляцию каждой под
программы до ее фактического вызова. Использовать SelfLoader несложно: до
статочно расположить подпрограммы вашего модуля под маркером DATA , что
бы они были проигнорированы компилятором, обратиться к SelfLoader с помощью
require и включить SelfLoader в массив @ISA модуля. Вот и все, что от вас требует
ся. При загрузке модуля SelfLoader создает заглушки для функций, перечислен
ных в секции__ DATA___________________________________ . При первом вызове функции заглушка компилирует насто
ящую функцию и вызывает ее.
В модулях, использующих SelfLoader (или AutoLoader — см. рецепт 12.10), дей
ствует одно важное ограничение. Функции, загружаемые SelfLoader или AutoLoader,
не имеют доступа к лексическим переменным файла, в чьем блоке___ DATA они на
ходятся, поскольку они компилируются функцией eval в импортированном бло
ке AUTOLOAD. Следовательно, динамически сгенерированные функции компи
лируются в области действия AUTOLOAD модуля SelfLoader или AutoLoader.
Как скажется применение SelfLoader на быстродействии программы — положительно или отрицательно? Ответ на этот вопрос зависит от количества функций в модуле, от их размера и от того, вызываются ли они на протяжении всего жизненного цикла программы или нет.
Модуль SelfLoader не следует применять на стадии разработки и тестирова
ния модулей. Достаточно закомментировать строку___ DATA , и функции станут
видны во время компиляции.
Документация по стандартному модулю SelfLoader; рецепт 12.10.
12.10. Ускорение загрузки модуля с помощью AutoLoader
Проблема
Вы хотите воспользоваться модулем AutoLoader.
Решение
Простейшее решение — воспользоваться утилитой h2xs для создания каталога и всех необходимых файлов. Предположим, у вас имеется каталог -/perllib, содержащий ваши личные библиотечные модули.
% h2xs -Xn Sample
% cd Sample
% perl Makefile.PL LIB=7perllib
% (edit Sample.pm)
% make install
Комментарий
Модуль AutoLoader, как и SelfLoader, предназначен для ускорения работы про
граммы. Он также генерирует функции-заглушки, которые заменяются настоя
щими функциями при первом вызове. Но вместо того чтобы искать все функции
в одном файле под маркером DATA__, AutoLoader ищет определение каждой функ
ции в отдельном файле. Например, если модуль Sample.pm содержит две функ
ции, f оо и ba г, то AutoLoader будет искать их в файлах Sample/auto/foo.al и Sample/
auto/bar.al соответственно. Модули, загружающие функции с помощью AutoLoader,
работают быстрее тех, что используют SelfLoader, но за это приходится расплачи
ваться созданием дополнительных файлов, местом на диске и повышенной слож
ностью.
Процесс подготовки выглядит сложно. Вероятно, сделать это вручную дей
ствительно непросто. К счастью, h2xs оказывает громадную помощь. Помимо со
здания каталога с шаблонами Sample.pm и других необходимых файлов, утилита
также генерирует Make-файл, который использует модуль AutoSplit для разделе
ния функций модуля по маленьким файлам, по одной функции на файл. Прави
ло make install устанавливает их так, чтобы они находились автоматически. Все,
что от вас нужно, — разместить функции модуля после строки__ END (вместо стро
ки _ DATA______________________________________ в SelfLoader), которая, как вы убедитесь, генерируется автоматически.
Как и в случае с SelfLoader, разработку и тестирование модуля лучше осуще
ствлять без AutoLoader. Достаточно закомментировать строку__ END , пока модуль
не придет к окончательному виду.
При работе с AutoLoader действуют те же ограничения видимости файловых лексических переменных, что и для SelfLoader, поэтому использование файловых
лексических переменных для хранения закрытой информации состояния не подойдет. Если вопрос хранения состояния становится настолько важным и труднореализуемым, подумайте о том, чтобы написать объектный модуль вместо традиционного.
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю SelfLoader; /z2xs(l); рецепт 12.9.
12.11. Переопределение встроенных функций
Проблема
Вы хотите заменить стандартную функцию собственной версией.
Решение
Импортируйте нужную функцию из другого модуля в свое пространство имен.
Комментарий
Многие (хотя и не все) встроенные функции Perl могут переопределяться. К этому шагу следует относиться серьезно, но в принципе это возможно. Например, необходимость в переопределении может возникнуть при работе на платформе, которая не поддерживает эмулируемой функции. Также переопределение используется для создания интерфейсных оболочек для встроенных функций.
Не все зарезервированные слова одинаковы. Те, что возвращают отрицательное число в функции С keyword() файла token.c исходной поставки Perl, могут переопределяться. В версии 5.004 не допускалось переопределение следующих ключевых слов: chop, defined, delete, do, dump, each, else, elsif, eval, exists, for, foreach, format, glob, goto, grep, if, keys, last, local, m, map, my, next, no, package, pop, pos, print, printf, prototype, push, q, qq, qw, qx, redo, return, s, scalar, shift, sort, splice, split, study, sub, tie, tied, tr, undef, unless, unshift, untie, until, use, while и у.
Стандартный модуль Perl Cwd переопределяет функцию chdir. Также переопределение встречается во многих модулях с функциями, возвращающими списки: File::stat, Net::hostent, Net::netent, Net::protoent, Net::servent, Time::gmtime, Time::localtime, Time::tm, User::grent и User::pwent. Эти модули содержат переопределения встроенных функций (например, stat или getpwnam), которые возвращают объект с возможностью доступа по имени — например, getpwnam( "daemon" )->di r. Для этого они переопределяют исходные, списковые версии этих функций.
Переопределение осуществляется импортированием функции из другого пакета. Импортирование действует только в импортирующем пакете, а не во всех возможных пакетах. Простого переобъявления недостаточно, функцию необходимо импортировать. Это защищает от случайного переопределения встроенных функций.
Предположим, вы решили заменить встроенную функцию time, которая возвращает целое количество секунд, другой, возвращающей вещественное число. Для
package FineTime;
use strict;
require Exporter;
use vars qw(@ISA @EXPORT_OK);
@ISA = qw(Exporter);
@EXPORT_OK = qw(time);
sub time() { }
Затем пользователь, желающий использовать усовершенствованную версию time, пишет что-то вроде:
use FineTime qw(time);
$start = time();
1 while print time() - $start, "\n";
Предполагается, что в вашей системе есть функция, соответствующая приведенной выше спецификации. Некоторые решения, которые могут работать в вашей системе, рассматриваются в рецепте 12.14.
Переопределение методов и операторов рассматривается в главе 13.
О Смотри также--------------------------------------------------------------------------------------------
Раздел «Overriding Built-in Functions» perlsub(l).
12.12. Вывод сообщений об ошибках и предупреждений по аналогии со встроенными функциями
Проблема
Ваш модуль генерирует ошибки и предупреждения, однако при использовании warn или die пользователь видит имя вашего файла и номер строки. Вы хотите, чтобы функции модуля вели себя по аналогии со встроенными функциями и сообщали об ошибках с точки зрения пользовательского, а не вашего кода.
Решение
Соответствующие функции присутствуют в стандартном модуле Carp. Вместо warn используйте функцию carp, а вместо die — функцию croak (для коротких сообщений) или confess (для длинных сообщений).
Комментарий
Некоторые функции модуля, как и встроенные функции, могут генерировать предупреждения или ошибки. Предположим, вы вызвали функцию sqrt с отри-
дательным аргументом (и не воспользовались модулем Math::Complex) — возникает исключение с выводом сообщения вида "Can't take sqrt of -3 at /tmp/ negroot line 17", где/tmp/negroot — имя вашей программы. Но если вы напишете собственную функцию с использованием die:
sub even_only {
my $n = shift;
die "$n is not even" if $n & 1; # Один из способов проверки
#.... }
то в сообщении вместо пользовательского файла, из которого вызывалась ваша функция, будет указан файл, в котором была откомпилирована функция even_only. На помощь приходит модуль Carp. Вместо die мы используем функцию croak:
use Carp;
sub even_only {
my $n = shift;
croak "$ n is not even" if $n % 2; Другой способ
П.... }
Если вы хотите просто вывести сообщение с номером строки пользовательской программы, где произошла ошибка, вызовите carp вместо warn (в отличие от warn и die, завершающий перевод строки в сообщениях carp и croak не имеет особой интерпретации). Например:
use Carp; sub even_only { my $n = shift;
if ($n & 1) { # Проверка нечетности carp "$n is not even, continuing"; ++$n; }
П. . . . }
Многие встроенные функции выводят предупреждения лишь при использовании ключа командной строки -w. Переменная $"W сообщает о его состоянии. Например, предупреждения можно выдавать лишь при наличии запроса от пользою вателя:
carp "$n is not even, continuing" if $"W;
Наконец, в модуле Carp существует третья функция — confess. Она работает аналогично croak за исключением того, что при аварийном завершении выводится полная информация о состоянии стека, вызовах функций и значениях аргументов.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций warn и die вperlmod(l); описание метапеременных_ WARN
и__ DIE_ в разделе «Global Special Arrays» perlvar{\.) и в рецепте 16.15; доку
ментация по стандартному модулю Carp; рецепт 19.2.
Проблема
Требуется сослаться на переменную или функцию в пакете, имена которых неизвестны до момента выполнения программы, однако синтаксис Spackname: :$varname недопустим.
Решение
Воспользуйтесь символическими ссылками:
{
по strict 'refs';
$val = ${ Spackname , "::" . $varname >;
@vals = ig>{ Spackname . "::" . Saryname };
&{ Spackname . "::" . Sfuncname }("args");
(Spackname . "::" . Sfuncname) -> ("args"); }
Комментарий
Объявление пакета имеет смысл во время компиляции. Если имя пакета или переменной неизвестно до времени выполнения, придется прибегнуть к символическим ссылкам и организовать прямые обращения к таблице символов пакета. Включите в блок директиву no strict ' refs' и постройте строку с полным именем интересующей вас переменной или функции. Затем разыменуйте полученную строку так, словно она является нормальной ссылкой Perl.
До выхода Perl версии 5 программистам в подобных случаях приходилось использовать eval:
eval "package Spackname; \$'$val = \$$varname"; # Задать $mai-n'val die if $@;
Как видите, такой подход затрудняет построение строки. Кроме того, такой код работает относительно медленно. Впрочем, вам никогда не придется делать это лишь для того, чтобы косвенно обращаться к переменным по именам. Символические ссылки обеспечивают необходимый компромисс.
Функция eval также используется для определения функций во время выполнения программы. Предположим, вы хотите иметь возможность вычислять двоичные и десятичные логарифмы:
printf "Iog2 of 100 is %.2f\n", 1од2(100); printf "1од10 of 100 is %.2f\n", Iog10(100);
В Perl существует функция log для вычисления натуральных логарифмов. Давайте посмотрим, как использовать eval для построения функций во время выполнения программы. Мы создадим функции с именами от 1од2 до 1од999:
Spackname = 'main'; for ($i = 2; Si < 1000; $i++) { SlogN = log($i);
По крайней мере в данном случае это не нужно. Следующий фрагмент делает то же самое, но вместо того, чтобы компилировать новую функцию 998 раз, мы откомпилируем ее всего единожды в виде замыкания. Затем мы воспользуемся символическим разыменованием в таблице символов и присвоим одну и ту же ссылку на функцию по многим именам:
$packname = 'main';
for ($i =2; $i < 1000; $i++) {
my $logN = log($i);
no strict ' refs';
*{"${packname}::log$i"} = sub { log(shift) / $logN }; }
Присваивая ссылку тип-глобу, вы всего лишь создаете синоним для некоторого имени. На этом принципе построена работа Exporter. Первая строка следующего фрагмента вручную экспортирует имя функции Colors::blue в текущий пакет. Вторая строка назначает функцию main::blue синонимом функции Colors::azure.
*blue = \&Colors::blue; •main::blue = \&Colors::azure;
Принимая во внимание гибкость присваиваний тип-глобов и символических ссылок, полноценные конструкции eval "СТРОКА" почти всегда оказываются излишеством, последней надеждой отчаявшегося программиста. Ничего худшего себе и представить нельзя — разве что если бы они были недоступны.
О Смотри также--------------------------------------------------------------------------------------------
Раздел «Symbolic References» perlsub(l); рецепт 11.4
12.14. Применение h2ph для преобразования заголовочных файлов С
Проблема
Полученный от кого-то код выдает устрашающее сообщение об ошибке:
Can't locate sys/syscall.ph in §INC (did you run h2ph?) (•INC contains: /usr/lib/perl5/i686-linux/5.00404 /usr/lib/perl5 /usr/lib/perl5/site_perl/ie86-linux /usr/lib/perl5/site_perl .) at some_program line 7.
Вы хотите понять, что это значит и как справиться с ошибкой.
Решение
Попросите системного администратора выполнить следующую команду с правами привилегированного пользователя:
Однако многие заголовочные файлы включают другие заголовочные файлы; иными словами, придется преобразовать Их все:
% cd /usr/include; h2ph *.h */*.h
Если вы получите сообщение о слишком большом количестве файлов или если некоторые файлы в подкаталогах не будут найдены, попробуйте другую команду:
% cd /usr/include; find . -name '*.h' -print | xargs h2ph
Комментарий
Файлы с расширением .ph создаются утилитой h2ph, которая преобразует директивы препроцессора С из ftinclude-файлов в Perl. Это делается для того, чтобы программа на Perl могла работать с теми же константами, что и программа на С. Утилита h2xs обычно оказывается более удачным решением, поскольку вместо кода Perl, имитирующего код С, она предоставляет откомпилированный код С. Однако работа с h2xs требует намного большего опыта программирования (по крайней мере, в том, что касается С), чем h2ph.
Если процесс преобразования h2ph работает, все прекрасно. Если нет — что ж, вам не повезло. Усложнение системных архитектур и заголовочных файлов приводит к более частым отказам h2ph. Если повезет, необходимые константы уже будут присутствовать в модулях Fcntl, Socket или POSIX. В частности, модуль POSIX реализует константы из sys/file.h, sys/ermoh и sys/wait.h. Кроме того, он обеспечивает выполнение нестандартных операций с терминалом (см. рецепт 15.8).
Так что же можно сделать с файлом .ph? Рассмотрим несколько примеров. В первом примере непереносимая функция syscall используется для вызова системной функции gettimeofday. Перед вами реализация модуля FineTime, описанного в рецепте 12.11.
# Файл FineTime.pm package main; require 'sys/syscall.ph'; die "No SYS_gettimeofday in sys/syscall.ph" unless defined &SYS_gettimeofday;
package FineTime;
use strict; require Exporter; use vars qw(@ISA @EXPORT_OK); @ISA = qw(Exporter); @EXPORT_OK = qw(time);
sub time() {
my $tv = pack("LL", ()); # presize buffer to two longs syscall(&main::SYS_gettimeofday, $tv, undef) >= 0 or die "gettimeofday: $!";
12.14. Применение h2ph для преобразования заголовочных файлов С 435
my($seconds, $microseconds) = unpack("LL", $tv); return $seconds + ($microseconds / 1_000_000);1;
Если вам приходится вызывать require для старых файлов .pi или .ph, сделайте это из главного пакета (package main в приведенном выше коде). Эти старые библиотеки всегда помещают свои символические имена в текущий пакет, a main служит «местом встречи». Чтобы использовать имя, уточните его, как мы поступили с main:: SYS_gettimeofday.
Файл sys/ioctl.ph, если вам удастся построить его в своей системе, открывает доступ к функциям ввода/вывода вашей системы через функции ioctl. К их числу принадлежит функция TIOCSTI из примера 12.1. Сокращение TIOCSTI означает «управление терминальным вводом/выводом, имитация терминального ввода» (terminal I/O control, simulate terminal input). В системах, где эта функция реализована, она вставляет один символ в поток устройства, чтобы при следующем чтении из устройства со стороны любого процесса был получен вставленный символ.
Пример 12.1. jam
#!/usr/bin/perl -w
U jam - вставка символов в STDIN
require 'sys/ioctl.ph';
die "no TIOCSTI" unless defined &TIOCSTI;
sub jam {
local $SIG<TT0U} = "IGNORE"; # "Остановка для вывода на терминал"
local «TTY; п Создать локальный манипулятор
open(TTY, "+</dev/tty") or die "no tty: $'";
for (split(//, $_[0])) <
ioctl(TTY, &TI0CSTI, $_) or die "bad TIOCSTI: $!";
}
close(TTY); > jam("@ARGV\n");
Поскольку преобразование sys/ioctl. h может вызвать некоторые сложности, вероятно, для получения кода TIOCSTI вам придется запустить следующую программу на С:
% cat > tio.c «EOF && ее tio.c && a.out
«include <sys/ioctl.h>
main() { printf("%#08x\n", TIOCSTI); }
EOF
0x005412
Функция ioctl также часто применяется для определения размеров текущего окна в строках/столбцах и даже в пикселях. Исходный текст программы приведен в примере 12.2.
436 Глава 12 • Пакеты, библиотеки и модули Пример 12.2. winsz
#!/usr/bin/perl# winsz - определение размеров окна в символах и пикселях
require 'sys/ioctl.ph';
die "no TIOCGWINSZ " unless defined &TIOCGWINSZ;
open(TTY, "+</dev/tty") or die "No tty: $!";
unless (ioctl(TTY, &TIOCGWINSZ, $winsize='')) {
die sprintf "$0: ioctl TIOCGWINSZ (%08x: $')\n", &TIOCGWINSZ; }
($row, $col, $xpixel, $ypixel) = unpack('S4', Swinsize); print '(row,col) = ($row,$col)";
print " (xpixel,ypixel) = ($xpixel,$ypixel)" if Sxpixel || Sypixel; print "\n",
Как видите, для экспериментов с файлами .ph, распаковкой двоичных данных и вызовами syscall и ioctl необходимо хорошо знать прикладной интерфейс С, обычно скрываемый Perl. Единственное, что требует такого же уровня знаний С — это интерфейс XS. Одни считают, что программисты должны бороться с искушением и за версту обходить подобные непереносимые решения. По мнению других, жесткие требования, поставленные перед рядовым программистом, оправдывают самые отчаянные меры.
К счастью, все большее распространение получают менее хрупкие механизмы. Для большинства этих функций появились модули CPAN. Теоретически они работают надежнее, чем обращения к файлам .ph.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций syscall и ioctl вperlmod(l); инструкции по работе с h2ph в файле INSTALL исходной поставки Perl; h2ph{\); рецепт 12.15.
12.15. Применение h2xs для создания модулей с кодом С
Проблема
Вам хотелось бы работать с функциями С из Perl.
Решение
Воспользуйтесь утилитой h2xs для построения необходимых файлов шаблонов, заполните их соответствующим образом и введите:
% perl 'Makefile.PL % make
Комментарий
При написании модуля Perl необязательно ограничиваться одним Perl. Как и для любого другого модуля, выберите имя и вызовите для него утилиту h2xs. Мы со-
здадим функцию FineTime::time с той же семантикой, что и в предыдущем рецепте, но на этот раз реализуем ее на С.
Сначала выполните следующую команду:
% h2xs -en FineTime
Если бы у нас был файл .h с объявлениями прототипов функций, его можно было бы включить, но поскольку мы пишем модуль с нуля, используется флаг -с — тем самым мы отказываемся от построения кода, преобразующего директивы #def ine. Флаг -п требует создать для модуля каталог FineTime/, в котором будут находиться следующие файлы:
Файл Список файлов в поставке
Makefile.PL Мета-таке-файл
FineTime.pm Компоненты Perl
FineTime.xs Будущие компоненты С
test.pl_________ Тестовая программа______
Перед тем как вводить команду make, необходимо сгенерировать make-файл для текущей системной конфигурации с помощью шаблона Makefile.PL. Вот как это делается:
% perl Makefile.PL
Если код XS вызывает библиотечный код, отсутствующий в нормальном наборе библиотек Perl, сначала добавьте в Makefile.pl новую строку. Например, если мы хотим подключить библиотеку librpm.a из каталога /usr/redhat/lib, то нам надо изменить строку Makefile. PL:
'LIBS' =>["], # e.g , '-lm
и привести ее к виду:
'LIBS' => ['-L/usr/redhat/lib -lrpm1],
Наконец, отредактируйте файлы FineTime.pm и FineTime.xs. В первом случае большая часть работы уже сделана за нас. Нам остается создать список экспортируемых функций. На этот раз мы помещаем его в @EXPORT_OK, чтобы нужные функции запрашивались пользователем по имени. Файл FineTime.pm выглядит так:
package FineTime;
use strict;
use vars qw($VERSION @ISA @EXPORT_OK),
require Exporter;
require OynaLoader;
@ISA = qw(Exporter DynaLoader);
@EXPORT_OK = qw(time);
SVERSION = '0.01';
bootstrap FineTime $VERSION;
1;
Кроме хороших познаний в С, вы также должны разбираться в интерфейсе C-Perl, который называется XS (eXternal Subroutine). Подробности и нюансы XS выходят за рамки этой книги. Автоматически сгенерированный файл FineTimejcs содержит заголовочные файлы, специфические для Perl, а также объявление MODULE. Мы добавили несколько дополнительных файлов и переписали код новой функции time. На С пока не похоже, но после завершения работы xsubpp все придет в норму.
Использованный нами файл FineTimejcs выглядит так:
#include <unistd.h> Sinclude <sys/time.h> «include "EXTERN.h" «include "perl.h" «include "XSUB.h"
MODULE = FineTime PACKAGE = FineTime
double time() CODE:
struct timeval tv; gettimeofday(&tv,0);
RETVAL = tv.tv_sec + ((double) tv.tv_usec) / 1000000; OUTPUT: RETVAL
Определение функции с именем, присутствующем в стандартной библиотеке С, не вызовет проблем при компиляции — это не настоящее имя, а лишь псевдоним, используемый Perl. Компоновщик С увидит функцию с именем XS_FineTime_ time, поэтому конфликта не будет.
При выполнении команды make install происходит следующее (с небольшими исправлениями):
% make install
mkdir ./blib/lib/auto/FineTime
cp FineTime.pm ./blib/lib/FineTime.pm
/usr/local/bin/perl -I/usr/lib/perl5/i686-linux/5.00403 -I/usr/lib/perl5
/usr/lib/perl5/ExtUtils/xsubpp -typemap
/usr/lib/perl5/ExtUtils/typemap FineTime.xs FineTime.tc && mv FineTime.tc FineTime.ccc -c -Dbool=char -DHAS_BOOL
-02-DVERSI0N=\"0.01\" -DXS_VERSI0N=\"0.01\" -fpic
-I/usr/lib/perl5/i686-linux/5.00403/CORE FineTime.cRunning Mkbootstrap for FineTime () chmod 644 FineTime.bs LD_RUN_PATH="" cc -o blib/arch/auto/FineTime/FineTime. so
-shared -L/usr/local/lib FineTime.о chmod 755 blib/arch/auto/FineTime/FineTime.so
ср FineTime.bs ./blib/arch/auto/FineTime/FineTime.bs
chmod 644 blib/arch/auto/FineTime/FineTime.bs
Installing /home/tchrist/perllib/i686-linux/./auto/FineTime/FineTime.so
Installing /home/tchrist/perllib/ieee-linux/./auto/FineTime/FineTime.bs
Installing /home/tchrist/perllib/./FineTime.pm
Writing /home/tchrist/perllib/i686-linux/auto/FineTine/.packlist
Appending installation info to /home/tchrist/perllib/i686-linux/perllocal.pod
Когда все будет готово, в интерпретаторе вводится следующая команда:
% perl -I Vperllib -MFineTime=time -le '1 while print time()' | head
888177070.090978
888177070.09132
888177070.091389
888177070.091453
888177070.091515
888177070.091577
888177070.091639
888177070.0917
888177070.091763
888177070.091864
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю ExtUtils::MakeMaker; h2ph(\) hxsu-bpp(l). Вызовы функций С из Perl описаны в perlxstut(l) и perlxs(l), а вызовы функций Perl из С — в perlembed(l). Внутренний API Perl рассматривается в perlcall(Y) nperlguts(l). По адресу http://www.perl.com/CPAN/authors/Dean _ Roehrich/ находится подробное руководство по XS с рекомендациями по организации интерфейса с C++.
12.16. Документирование модуля в формате pod
Проблема
Вы хотите документировать свой модуль, но не знаете, какой формат следует использовать.
Решение
Включите документацию в файл модуля в формате pod.
Комментарий
Сокращение pod означает «plain old documentation», то есть «простая документация». Документация в формате pod включается в программу с применением очень простого формата разметки. Как известно, программисты сначала пишут программу, а документацию... не пишут вообще. Формат pod был разработан для максимальной простоты документирования, чтобы с этой задачей справился даже лентяй. Иногда это даже помогает.
Вместе с Perl поставляется несколько программ-трансляторов, которые фильтруют документацию в формате pod и преобразуют ее в другой формат вывода. Утилита pod2man преобразует pod в формат troff, используемый в программе man или в системах верстки и печати. Утилита pod2html создает Web-страницы, работающие в системах, не принадлежащих к семейству UNIX. Утилита pod2text преобразует pod в простой ASCII-текст. Другие трансляторы (pod2ipf, pod2fm, pod2text, pod2latex и pod2ps) могут входить в поставку Perl или распространяются через CPAN
Многие книги пишутся в коммерческих текстовых редакторах с ограниченными сценарными возможностями... но только не эта! Она была написана в формате pod в простых текстовых редакторах (Том использовал ы, а Нат — emacs). На стадии технической правки книга была преобразована в формат troff специальным транслятором pod2ora, написанным Ларри. Окончательный вариант книги был получен преобразованием pod-файлов в формат FrameMaker.
Хотя в perlpod{ 1) приведено общее описание pod, вероятно, этот формат удобнее изучать на примере готовых модулей Если вы начали создавать собственные модули с помощью утилиты h2xs, то у вас уже имеются образцы. Утилита Makefile знает, как преобразовать их в формат man и установить страницы руководства так, чтобы их могли прочитать другие. Кроме того, программа perldoc может транслировать документацию pod с помощью pod2text.
Абзацы с отступами остаются без изменений. Другие абзацы переформатируются для размещения на странице. В pod используются лишь два вида служебной разметки: абзацы, начинающиеся со знака = и одного или нескольких слов, и внутренние последовательности в виде буквы, за которой следует текст в угловых скобках. Теги абзацев определяют заголовки, перечисляемые элементы списков и служебные символы, предназначенные для конкретного транслятора Последовательности в угловых скобках в основном используются для изменения начертания (например, выбора полужирного, курсивного или моноширинного шрифта). Приведем пример директивы =head2 в сочетании с изменениями шрифта:
=head2 Discussion
If we had a dot-h file with function prototype declarations, we could include that, but since we re writing this one from scratch, we 11 use the -c flag to omit building code to translate any Sdefine symbols The -n flag says to create a module directory named FmeTime/, which will have the following files
Последовательность =for определяет код для выходных файлов конкретного формата. Например, в этой книге, главным образом написанной в формате pod, присутствуют вызовы стандартных средств troff: eqn, tbl и pic. Ниже показан пример внутреннего вызова eqn, который обрабатывается лишь трансляторами, производящими данные в формате troff:
=for troff
EQ log sub n (x) = { {log sub e (x)} over {log sub e (n)} }
EN
Формат pod также позволяет создавать многострочные комментарии. В языке С комментарий /* */ может включать несколько строк текста — вам не придется ставить отдельный маркер в каждой строке. Поскольку Perl игнорирует директивы pod, этим можно воспользоваться для блочного комментирования. Весь фокус заключается в том, чтобы найти директиву, игнорируемую трансляторами pod. Например, можно воспользоваться тегом for later или for nobody:
=for later
next if 1 ?"$?,
s/( {73}) */$1<SNIP>/,
= cut back to perl или парой =begin и =end: =begin comment
if ('open(FILE, $file)) { unless ($opt_q) {
warn $me $file $'\n
$Errors++, } next FILE,
$total = 0, $matches = 0,
=end comment
> Смотри также---------------------------------------------------------------------------------------------
Раздел «POD: Enbedded Documentation» вperlsyn(l);perlpod(l),pod2man(l), pod2html{ 1) и pod2text( 1).
12.7. Построение и установка модуля CPAN
Проблема
Требуется установить файл модуля, загруженный с CPAN или взятый с компакт-диска.
Введите в интерпретаторе следующие команды (на примере установки модуля Some::Module версии 4.54):
% gunzip Some-Module-4 54 tar gz
% tar xf Some-Module-4 54
% cd Some-Module-4 54
% perl Makefile PL
% make
% make test
% make install
Комментарий
Модули Perl, как и большинство программ в Сети, распространяются в архивах tar, сжатых программой GNU zip1. Если tar выдает предупреждение об ошибках контрольных сумм каталогов ( Directory checksum errors"), значит, вы испортили двоичный файл, приняв его в текстовом формате.
Вероятно, для установки модуля в системные каталоги необходимо стать привилегированным пользователем с соответствующими правами доступа. Стандартные модули обычно устанавливаются в каталог /usr/lib/perl5, а прочие — в каталог /usr/lib/perl5/site_perl.
Рассмотрим процесс установки модуля MD5:
% gunzip MD5-1 7 tar gz
% tar xf MD5-1 7 tar
% cd MD5-1 7
% perj Makefile PL
Checking if your kit is complete...
Looks good
Writing Makefile for MD5
% make
mkdir ./blib
mkdir ./blib/lib
cp MD5.pm ./blib/lib/MD5.pm
AutoSplitting MD5 (./blib/lib/auto/MD5)
/usr/bin/perl -I/usr/local/lib/perl5/i386
cp MD5.bs ./blib/arch/auto/MD5/MD5.bs
chmod 644 ./blib/arch/auto/MD5/HD5.bsmkdir ./ЬИЬ/тапЗ
Manifying ./blib/man3/MD5.3
% make test
PERL_DL_NONLAZY=1 /usr/bin/perl -I./blib/arch -I./blib/lib
-I/usr/local/lib/perl5/i386-freebsd/5.00404 -I/usr/local/lib/perl5 test.pi
1..14 ок 1 ок 2
ок 13
ок 14
% sudo make install
Password:
Installing /usr/local/lib/perl5/site_perl/i386-freebsd/./auto/MD5/
HD5.so Installing /usr/local/lib/perl5/site_perl/i386-freebsd/./auto/MD5/
MD5.bs
Installing /usr/local/lib/perl5/site_perl/./auto/MD5/autosplit.ix
Installing /usr/local/lib/perl5/site_perl/./MD5. pm Installing /usr/local/lib/perl5/man/man3/./MD5.3
Writing /usr/local/lib/perl5/site_perl/i386-freebsd/auto/MD5/.packlist
Appending installation info to /usr/local/lib/perl5/i386-freebsd/ 5.00404/perllocal.pod
Если ваш системный администратор где-то пропадает или у него нет времени на установку, не огорчайтесь. Используя Perl для построения .make-файла по шаблону Makefile.PL, можно выбрать альтернативный каталог для установки.
# Если вы хотите установить модули в свой каталог
% perl Makefile PL LIB=~/lib
# Если у вас имеется полная поставка
% perl Makefile PL PREFIX="/perl5-pnvate
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю ExtUtils::MakeMaker. Файл INSTALL в исходной поставке Perl содержит сведения о построении двоичного файла perl со статической компоновкой.
12.18. Пример: шаблон модуля
Ниже приведен «скелет» модуля. Если вы собираетесь написать собственный модуль, попробуйте скопировать и отредактировать его.
package Some::Module, # Должен находиться в Some/Module pm use strict;
require Exporter;
use vars qw($VERSION @ISA ©EXPORT @EXPORT_OK %EXP0RT_TA6S);
# Установка версии для последующей проверки $VERSION = 0.01;
@EXP0RT = qw(&fund &func2 &func4);
%EXPORT_TAGS = ( ); # например: TAG => [ qw!namel name2! ],
# Здесь находятся экспортируемые глобальные переменные,
# а также функции с необязательным экспортированием
@EXPORT_OK = qw($Var1 %Hashit &func3);
use vars qw($Var1 %Hashit);
# Здесь находятся неэкспортируемые глобальные имена пакета
use vars qw(@more $stuff);
# Инициализировать глобальные переменные пакета,
# начиная с экспортируемых
$Vari = '¦;
%Hashit = ();
# Затем все остальные (к которым можно обращаться
# в виде $Some::Module::stuff)
Sstuff = '';
@more = ();
# Все лексические переменные с файловой областью действия
# должны быть созданы раньше функций, которые их используют.
# Лексические переменные, доступ к которым
й ограничивается данным файлом.
my $priv_var = ' '; ту %secret_hash = ();
# Закрытая функция, оформленная в виде замыкания
# и вызываемая через &$priv_func.
my $priv_func = sub {
# Содержимое функции.
# Все ваши функции, экспортируемые и нет;
# не забудьте вставить что-нибудь в заглушки {>
sub fund {....} # без прототипа
sub func2() {....} # прототип - void
sub func3($$) {....} # прототип - 2 скаляра
# Функция не экспортируется автоматически, но может вызываться!
sub func4(\%) {....} # прототип - 1 ссылка на хэш
END { > # Завершающий код модуля (глобальный деструктор)
1;
Perl распространяется вместе с множеством модулей. Еще больше модулей можно найти в CPAN. Следующая программа выводит имена, версии и описания всех модулей, установленных в вашей системе. Она использует стандартные модули (например, File::Find) и реализует некоторые приемы, описанные в этой главе. Программа запускается следующей командой:
% pmdesc
Она выводит список модулей с описаниями:
FileHandle (2.00) - supply object methods for filehandles I0::Flle (1.06021) - supply object methods for filehandles I0::Select (1.10) - 00 interface to the select system call 10::Socket (1.1603) - Object interface to socket communications
С флагом -v программа pmdesc выводит имена каталогов, в которых находятся файлы:
% pmdesc -v
<«Modules from /usr/lib/perl5/i686-linux/5.00404>»
FileHandle (2.00) - supply object methods for filehandles
Флаг -w предупреждает о том, что модуль не включает документации в формате pod, а флаг -s сортирует список модулей в каждом каталоге. Исходный текст программы приведен в примере 12.3.
Пример 12.3. pmdesc
#!/usr/bin/perl -w
№ pmdesc - вывод описаний файлов pm
# tchrist@perl.com
use strict;
use File::Find qw(find); use Getopt::Std qw(getopts); use Carp;
use vars (
q!$opt_v!, # Вывод отладочной информации
q!$opt_w!, # Предупреждения об отсутствующих
# описаниях модулей
q!$opt_a!, # Вывод относительных путей
q!$opt_s!, # Сортировка данных по каждому каталогу
);
продолжение ё>
$1 = 1;
getopts('wvas') or die "bad usage";
@ARGV = @INC unless @ARGV;
# Глобальные переменные. Я бы предпочел обойтись без этого.
use vars (
q!$Start_Dir!, # Каталог верхнего уровня, для которого
# вызывалась функция find
q!%Future>, # Другие каталоги верхнего уровня,
# для которых find вызывается позднее
);
my $Module;
# Установить фильтр для сортировки списка модулей,
# если был указан соответствующий флаг,
if ($opt_s) {
if (open(ME, "4")) { $/ = ¦'; while (<ME>) { chomp;
print join("\n", sort split /W), "\n"; } exit;
MAIN: {
my %visited; my ($dev,$ino);
@Future{@ARGV} = (1) x @ARGV;
foreach $Start_Dir (@ARGV) { delete $Future{$Start_Dir};
print "\n«Modules from $Start_Dir»\n\n" if $opt_v;
next unless ($dev,$ino) = stat($Start_Oir);
next if $visited{$dev,$ino}++;
next unless $opt_a || $Start_Dir =" m!"/!;
find(\&wanted, $Start_Dir); } exit;
local $_ = $File::Find::name;
if (index($_, $Start_Dir . '/') == 0) {
substr($_, 0, 1+length($Start_Dir)) = ";
s { /
s { \.p(m|od)$
return $_;
# Решить, нужен ли нам данный модуль sub wanted {
if ( $Future{$File::Find::name} ) {
warn "\t(Skipping $File::Find::name, qui venit in future)\n"
if 0 and $opt_v; $File::Find::prune = 1; return; }
return unless /\.pra$/ && -f; $Module = &modname; # skip obnoxious modules if (SModule =' /~CPAN(\Z|::)/) {
warn("$Module -- skipping because it misbehaves\n"); return;
my $file = $_;
unless (open(P0D, "< $file")) { warn "\tcannot open $file: $!
в if $opt_w; return 0;
$: = " -:";
|
local |
$/ = ' ¦; |
|
local |
$_; |
|
while |
(<P00>) { |
|
if (/=head\d\s+NAME/) { |
|
|
|
chomp($_ = <POD>); |
|
s/\n/ /g; |
|
|
Bwrite; |
|
|
my $v; |
if (defined ($v = getversion($Module))) print "$Module ($v) ";
} else {
print "$Module ";
}
print "- $_\n"; • return 1;
warn "\t(MISSING DESC FOR $File::Find::name)\n" if $opt_w;
return 0;
# Загрузить модуль и вывести его номер версии,
# перенаправляя ошибки в /dev/null
sub getversion {
my $mod = shift;
my $vers = '$"X -m$mod -e 'print \$${mod}: .'VERSION' 2>/dev/null' $vers =~ s/"\s*(.*?)\s*$/$1/; # Удалить лишние пропуски return ($vers || undef);
format = SModule,
Классы, объекты и связи
v:-
По всему миру я призываю массы на борьбу с классами. Уильям Гладстон, речь в Ливерпуле, 28 июня 1886 г.
Введение
Наряду со ссылками и модулями в Perl версии 5.000 появились объекты. Как обычно, Perl не заставляет всех использовать единственно правильный стиль, а поддерживает несколько разных стилей. Благодаря этому люди решают свои задачи так, как им нравится.
При написании программ необязательно пользоваться объектами, в отличие от языка Java, где программы представляют собой экземпляры объектов. Однако при желании можно написать Perl-программу, в которой используется практически весь арсенал приемов объектно-ориентированного программирования. В Perl поддерживаются классы и объекты, одиночное и множественное наследование, методы экземпляров и методы классов, переопределение методов, конструкторы и деструкторы, перегрузка операторов, методы-посредники с автозагрузкой, делегирование, иерархия объектов и два уровня сборки мусора.
Вы можете выбрать ровно столько объектно-ориентированных принципов, сколько захочется. Связи (ties) являются единственной частью Perl, где объектно-ориентированный подход обязателен. Но даже здесь об этом должен знать лишь программист, занимающийся реализацией модуля; случайный пользователь остается в блаженном неведении относительно внутренних механизмов. Связи, рассматриваемые в рецепте 13.14, позволяют организовать прозрачный перехват обращений к переменной. Например, с помощью связей можно создать хэш с возможностью поиска по ключу или по значению.
Под капотом
Если спросить десятерых программистов, что такое «объектная ориентация», вы получите десять разных ответов. Люди рассуждают об «абстракции» и «инкапсуляции», пытаются выделить основные черты объектно-ориентированных языков
Мы будем использовать терминологию из документации Perl и страницы руководства perlobj(l). Объект представляет собой переменную, принадлежащую к некоторому классу. Методами называются функции, ассоциируемые с классом или объектом. В Perl класс представляет собо^ пакет — а обычно и модуль. Объект является ссылкой на что-то, что было приведено (blessed) к классу. Приведение ассоциирует субъект с классом. Для этого используется функция bless, вызываемая с одним или двумя аргументами. Первым аргументом является ссылка на приводимый объект, а необязательным вторым аргументом — пакет, к которому осуществляется приведение.
$object = {>, # Ссылка на хэш
bless($object, "Data.:Encoder"); # Привести Sobject к классу
# Data.'Encoder
bless($object); # Привести Sobject к текущему пакету
Имя класса соответствует имени пакета (Data::Encoder в приведенном выше примере). Поскольку классы являются модулями (обычно), код класса Data::Encoder находится в файле Data/Encoder.pm. Структура каталогов, как и для традиционных модулей, существует исключительно для удобства; она никак не связана с наследованием, ограничением доступа к переменным или чем-нибудь еще. Однако в отличие от традиционных модулей, объектные модули очень редко используют Exporter. Вся работа должна вестись только через вызовы методов, но не через импортированные функции или переменные.
После приведения объекта вызов функции ref для ссылки на него возвращает имя класса вместо фундаментального типа субъекта:
$ob] = [3,5];
print ref($obj), " ", $obj->[1], "\n";
bless($obj, "Human: Cannibal");
print ref($obj), " ", $ob]->[1], "\n";
ARRAY 5
Human::Cannibal 5
Как видите, приведенную ссылку все еще можно разыменовать. Чаще всего объекты реализуются с помощью приведенных ссылок на хэши. Вы можете использовать любые типы ссылок, но ссылки на хэш обеспечивают максимальную гибкость. Они позволяют создавать в объекте поля данных с произвольными именами:
$obj->{Stomach} = "Empty"; # Прямое обращение к данным объекта $ob]->{NAME} = "Thag";
# Символы верхнего регистра в имени поля
# помогают выделить его (необязательно)
Хотя Perl позволяет любому коду за пределами класса напрямую обращаться к данным объекта, это считается нежелательным. Согласно общепринятому мне-
Введение 451
нию, работа с данными должна вестись только с использованием методов, предназначенных для этой цели. У разработчика класса появляется возможность изменить его реализацию без модификации всего кода приложений, использующих данный класс.
Методы
Для вызова методов используется оператор, оператор ->. В следующем примере мы вызываем метод encode() объекта $object с аргументом "data" и сохраняем возвращаемое значение в переменной Sencoded:
Sencoded = $object->encode("data');
Перед нами метод объекта, поскольку мы вызываем метод конкретного объекта. Также существуют методы классов, то есть методы, вызываемые по имени класса:
Sencoded = Data::Encoder->encode("data");
При вызове метода вызывается функция соответствующего класса с неявной передачей в качестве аргумента либо ссылки (для метода объекта), либо строки (для метода класса). В рецепте 13.17 показано, как вызывать методы с именами, определяемыми во время выполнения.
В большинстве классов существуют специальные методы, возвращающие новые объекты — конструкторы. В отличие от некоторых объектно-ориентированных языков, конструкторы Perl не имеют специальных имен. В сущности, конструктор можно назвать, как вам захочется. Программисты C++ обожают присваивать своим конструкторам в Perl имя new. Мы рекомендуем выбирать имя конструктора так, чтобы оно имело смысл в контексте решаемой задачи. Например, конструкторы расширения Тк в Perl называются по именам создаваемых ими элементов (widgets). Менее распространенный подход заключается в экспортировании функции, имя которой совпадает с именем класса; см. пример в разделе «Пример. Перегруженный класс StrNum» в рецепте 13.14.
Типичный конструктор выглядит следующим образом:
sub new {
my Sclass = shift,
my $self = {}; # Выделить новый хэш для объекта
bless($self, Sclass),
return $self; }
Вызов конструктора выглядит так:
Sobject = Class->new();
Если дело обходится без наследования или иных выкрутасов, это фактически эквивалентно
Sobject = Class::new("Class"),
Первым аргументом функции new() является имя класса, к которому приводится новая ссылка. Конструктор должен передать эту строку bless() в качестве второго аргумента.
Деструктором называется функция, которая выполняется при уничтожении субъекта, соответствующего данному объекту, в процессе сборки мусора. В отличие от конструкторов имена деструкторов жестко фиксируются. Методу-деструктору должно быть присвоено имя DESTROY. Этот метод, если он существует, вызывается для всех объектов непосредственно перед освобождением памяти. Наличие деструктора (см. рецепт 13.2) необязательно.
Некоторые языки на уровне синтаксиса позволяют компилятору ограничить доступ к методам класса. В Perl такой возможности нет — программа может вызывать любые методы объекта. Автор класса должен четко документировать открытые методы (те, которые можно использовать). Пользователям класса следует избегать недокументированных (то есть неявно закрытых) методов.
Perl не различает методы, вызываемые для класса (методы классов), и методы, вызываемые для объекта (методы экземпляров). Если вы хотите, чтобы некоторый метод вызывался только как метод класса, поступите следующим образом:
sub class_only_method { my $class = shift, die "class method called on object" if ref $class;
# Дополнительный код
>
Чтобы метод вызывался только как метод экземпляра, воспользуйтесь следующим кодом:
sub instance_only_method { my $self = shift; die "instance method called on class' unless ref $self;
# Дополнительный код
)
Если в вашей программе вызывается неопределенный метод объекта, Perl не будет жаловаться на стадии компиляции; вместо этого произойдет исключение во время выполнения. Аналогично, компилятор не перехватывает ситуации, при которой методу, который должен вызываться для простых чисел, передается комплексный аргумент. Метод представляет собой обычный вызов функции, пакет которой определяется во время выполнения. Методы, как и все косвенные функции, не имеют проверки прототипа — проверка выполняется на стадии компиляции. Даже если бы вызовы методов учитывали наличие прототипа, в Perl компилятор не сможет автоматически установить точный тип или интервал аргумента функции. Прототипы Perl предназначены для форсирования контекста аргумента функции, а не для проверки интервала. Странности прототипов Perl описаны в рецепте 10.11.
Чтобы предотвратить инициирование исключений для неопределенных методов, можно использовать механизм AUTOLOAD для перехвата вызовов несуществующих методов. Данная возможность рассматривается в рецепте 13.11.
Введение 453
Наследование
Отношения наследования определяют иерархию классов. При вызове метода, не определенного в классе, поиск метода с указанным именем осуществляется в иерархии. Используется первый найденный метод. Наследование позволяет строить классы «на фундаменте» других классов, чтобы код не приходилось переписывать заново. Классы являются одной из форм многократного использования кода и потому способствуют развитию Лени — главной добродетели программиста.
В некоторых языках существует специальный синтаксис наследования. В Perl каждый класс (пакет) может занести список своих суперклассов, то есть родителей в иерархии, в глобальную (не лексическую!) пакетную переменную @ISA. Этот список просматривается во время выполнения программы, при вызове метода, не определенного в классе объекта. Если первый пакет, указанный в @ISA, не содержит искомого метода, но имеет собственный массив @ISA, то Perl перед продолжением поиска рекурсивно просматривает @ISA этого пакета.
Если поиск унаследованного метода заканчивается неудачей, проверка выполняется заново, но на этот раз ищется метод с именем AUTOLOAD. Поиск метода $ob->meth(), где объект $ob принадлежит классу Р, происходит в следующей последовательности:
• P.:meth
• Любой метод S: :meth() в пакетах S из @P::ISA, рекурсивно.
• UNIVERSAL::meth
• Подпрограмма Р:: AUTOLOAD.
• Любой метод S:: AUTOLOAD() в пакетах S из @P::ISА, рекурсивно.
• Подпрограмма UNIVERSAL: AUTOLOAD.
В большинстве классов массив @ISA состоит из одного элемента — такая ситуация называется одиночным наследованием. Если массив @ISA содержит несколько элементов, говорят, что класс реализует множественное наследование. Вокруг достоинств и недостатков множественного наследования идут постоянные споры, но Perl поддерживает эту возможность.
В рецепте 13.9 рассматриваются основы наследования и базовые принципы построения классов, обеспечивающие удобство субклассирования. В рецепте 13.10 мы покажем, как субкласс переопределяет методы своих суперкласов.
Perl не поддерживает наследования данных. Класс может напрямую обращаться к данным другого класса, но делать этого не следует. Это не соответствует принципам инкапсуляции и нарушает абстракцию. Если вы последуете рекомендациям из рецептов 13.10 и 13.12, это ограничение не вызовет особых проблем.
Косвенный вызов методов
Косвенный вызов методов:
$lector = new Human::Cannibal; feed $lector "Zak"; move $lector "New York";
представляет собой альтернативный вариант синтаксиса для:
454 Глава 13 • Классы, объекты и связи
Slector = Human::Cannibal->new(); $object->feed("Zak"); $object->move("New York");Косвенный вызов методов привлекателен для англоязычных программистов и хорошо знаком программирующим на C++ (где подобным образом используется new). He поддавайтесь соблазну. Косвенный вызов обладает двумя существенными недостатками. Во-первых, он должен подчиняться тем же ненадежным правилам, что и позиция файлового манипулятора в print и printf:
printf STDERR "stuff here\n";
Эта позиция, если она заполняется, должна содержать простое слово, блок или имя скалярной переменной; скалярные выражения недопустимы. Это приводит к невероятно запутанным проблемам, как в двух следующих строках:
move $obj-><FIELD}; # Вероятно, ошибка
move $ary[$i]; # Вероятно, ошибка
Как ни странно, эти команды интерпретируются следующим образом:
$obj->move->{FIELD}; # Сюрприз!
$ary->move->[$i]; # Сюрприз!
вместо ожидаемого:
$obj->{FIELD}->move(); # Ничего подобного
$ary[$i]->move; . # Ничего подобного
Вторая проблема заключается в том, что во время компиляции Perl приходится гадать, что такое name и move — функции или методы. Обычно Perl угадывает правильно, но в случае ошибки функция будет откомпилирована как метод, и наоборот. Это может привести к появлению невероятно хитрых ошибок, которые очень трудно обнаружить. Формулировке -> э^и раздражающие неоднозначности не присущи, поэтому мы рекомендуем пользоваться только ею.
Некоторые замечания по объектной терминологии
В объектно-ориентированном мире одни и те же концепции часто описываются разными словами. Если вы программировали на другом объектно-ориентированном языке, возможно, вам захочется узнать, как знакомые термины и концепции представлены в Perl.
Например, объекты часто называются экземплярами (instances) классов, а методы этих объектов — методами экземпляров. Поля данных, относящиеся к каждому объекту, часто называются данными экземпляров или атрибутами объектов, а поля данных, общие для всех членов класса, — данными класса, атрибутами класса или статическими переменными класса.
Кроме того, термины базовый класс и суперкласс описывают одно и то же понятие (родитель или другой предок в иерархии наследования), тогда как термины производный класс и субкласс описывают противоположное отношение (непосредственный или отдаленный потомок в иерархии наследования).
Введение 455
Программисты на C++ привыкли использовать статические методы, виртуальные методы и методы экземпляров, но Perl поддерживает только методы классов и методы объектов. В действительности в Perl существует только общее понятие «метод». Принадлежность метода к классу или объекту определяется исключительно контекстом использования. Метод класса (со строковым аргументом) можно вызвать для объекта (с аргументом-ссылкой), но вряд ли это приведет к разумному результату.
Программисты C++ привыкли к глобальным (то есть существующим на уровне класса) конструкторам и деструкторам. В Perl они идентичны соответственно инициализирующему коду модуля и блоку END{}.
С позиций C++ все методы Perl являются виртуальными. По этой причине их аргументы никогда не проверяются на соответствие прототипам функции, как это можно сделать для встроенных и пользовательских функций. Прототипы проверяются компилятором во время компиляции. Функция, вызванная методом, определяется лишь во время выполнения.
Философское отступление
В своих объектно- ориентированных аспектах Perl предоставляет полную свободу выбора: возможность делать одни и те же вещи несколькими способами (приведение позволяет создать объект из данных любого типа), возможности модификации классов, написанных другими (добавление функций в их пакеты), а также полная возможность превратить отладку программы в сущий ад — если вам этого сильно захочется.
В менее гибких языках программирования обычно устанавливаются более жесткие ограничения. Многие языки с фанатичным упорством отстаивают закрытость данных, проверку типов на, стадии компиляции, сложные сигнатуры функций и другие возможности. Все э.ти возможности отсутствуют в объектах Perl, поскольку они вообще не поддерживаются Perl. Помните об этом, если объектно-ориентированные аспекты Perl покажутся вам странными. Все странности происходят лишь от того, что вы привыкли к философии других языков. Объектно-ориентированная сторона Perl абсолютно разумна — если мыслить категориями Perl. Для любой задачи, которую нельзя решить на Perl по аналогии с Java или C++, найдется прекрасно работающее решение в идеологии Perl. Программист-параноик даже сможет обеспечить полную закрытость: Bperltoot(l) рассказано о том, как с помощью приведения замыканий получить объекты, по степени закрытости не уступающие объектам C++ (и даже превосходящие их).
Объекты Perl не плохи; просто они другие.
> Смотри также---------------------------------------------------------------------------------------------
В литературе по объектно-ориентированному программированию Perl упоминается очень редко. Изучение объектно-ориентированных аспектов языка лучше всего начать с документации Perl — особенно с учебника по объектам perltoot(l). За справочной информацией обращайтесь кperlobj(l). Вероятно, этот документ понадобится вам при чтении руководстваperlbot(l), полного объектно-ориентированных фокусов.
456 Глава 13 • Классы, объекты и связи
13.1. Конструирование объектаПроблема
Необходимо предоставить пользователю возможность создания новых объектов,
Решение
Создайте конструктор. В Perl метод-конструктор не только инициализирует объект, но и предварительно выделяет память для него — как правило, с использованием анонимного хэша. Конструкторы C++, напротив, вызываются после выделения памяти. В объектно-ориентированном мире конструкторы C++ было бы правильнее назвать инициализаторами.
Канонический конструктор объекта в Perl выглядит так:
sub new {
my $class = shift;
my $self = {};
bless($self, $class);
return $self; }
Данный фрагмент эквивалентен следующей строке:
sub new { bless( { >, shift ) }
Комментарий
Любой метод, который выделяет память для объекта и инициализирует его, фактически является конструктором. Главное, о чем следует помнить, — ссылка становится объектом лишь после того, как для нее будет вызвана функция bless. Простейший, хотя и не особенно полезный конструктор выглядит так:
sub new { bless({ >) >
Давайте включим в него инициализацию объекта:
sub new {
my $self = { }; # Выделить анонимный хэш
bless($self);
# Инициализировать два атрибута/поля/переменных экземпляра
$self->{START} = time();
$self-><AGE} = 0;
return $self; >
Такой конструктор не очень полезен, поскольку в нем используется одноаргу-ментная форма bless, которая всегда приводит объект в текущий пакет. Это означает, что полезное наследование от него становится невозможным; сконструированные объекты всегда будут приводиться к классу, в котором была откомпилирована функция new. При наследовании этот класс не обязательно совпадет с тем, для которого вызывался данный метод.
Проблема решается просто: достаточно организовать в конструкторе обработку первого аргумента. Для метода класса он представляет собой имя пакета. Передайте имя класса функции bless в качестве второго аргумента:
sub new {
my Iclassname = shift; tt Какой класс мы конструируем'
my $self = {>; # Выделить память
bless($obref, $classname); tt Привести к нужному типу
$self->{START} = time(); # Инициализировать поля данных
$self->{AGE} = 0;
return $obref; # И вернуть
>
Теперь конструктор будет правильно наследоваться производными классами.
Выделение памяти и приведение можно отделить от инициализации данных экземпляра. В простых классах это не нужно, однако такое разделение упрощает наследование; см. рецепт 13.10.
sub new {
my Sclassname = shift; # Какой класс мы конструируем9
my $self = {}; # Выделить память
bless($self, $classname); # Привести к нужному типу
$self->_init(@_); # Вызвать _imt
# с остальными аргументами
return $self,
# "Закрытый" метод для инициализации полей. Он всегда присваивает START tt текущее время, a AGE - 0. При вызове с аргументами _imt tt интерпретирует их как пары ключ/значение и инициализирует ими объект, sub _imt {
my $self = shift;
$self->{START} = time();
$self->{AGE} = 0;
if «3>J {
my %extra = @_;
<s>$self{keys %extra} = values Stextra;
£> Смотри также
perltoot{\) иperlobj(l); рецепты 13.6; 13.9-13.10.
13.2. Уничтожение объекта
Проблема
Некоторый фрагмент кода должен выполняться в случае, если надобность в объекте отпадает. Например, объект может использоваться в интерфейсе с внешним миром или содержать циклические структуры данных — в этих случаях он
Решение
Создайте метод с именем DESTROY. Он будет вызываться в том случае, когда на объект не остается ни одной ссылки или при завершении программы (в зависимости от того, что произойдет раньше). Освобождать память не нужно; лишь выполните все завершающие действия, которые имеют смысл для данного класса.
sub DESTROY {
my $self = shift,
pnntf("$self dying at %s\n", scalar localtime),
Комментарий
У каждой истории есть начало и конец. История объекта начинается с выполнения конструктора, который явно вызывается при создании объекта. Жизненный цикл объекта завершается в деструкторе — методе, который неявно вызовется при уходе объекта из жизни. Весь завершающий код, относящийся к объекту, помещается в деструктор, который должен называться DESTROY.
Почему деструктору нельзя присвоить произвольное имя, как это делается для конструктора? Потому что конструктор явно вызывается по имени, а деструктор — нет. Уничтожение объекта выполняется автоматически через систему сборки мусора Perl, реализация которой в настоящее время основана на системе подсчета ссылок. Чтобы знать, какой метод должен вызываться при уничтожении объекта, Perl требует присвоить деструктору имя DESTROY. Если несколько объектов одновременно выходят из области действия, Perl не гарантирует вызова их деструкторов в определенном порядке.
Почему имя DESTROY пишется в верхнем регистре? В Perl это обозначение говорит о том, что данная функция вызывается автоматически. К числу других автоматически вызываемых функций принадлежат BEGIN, END, AUTOLOAD и все методы связанных объектов (см. рецепт 13.15) — например, STORE и FETCH.
Пользователь не должен беспокоиться о том, когда будет вызван конструктор. Просто это произойдет в нужный момент. В языках, не поддерживающих сборку мусора, программисту приходится явно вызывать деструктор для очистки памяти и сброса состояния — и надеяться на то, что он не ошибся в выборе момента. Беднягу можно только пожалеть.
Благодаря автоматизированному управлению памятью в Perl деструкторы объектов используются редко. Но даже в случаях, когда они нужны, явный вызов деструктора — вещь не только излишняя, но и попросту опасная. Деструктор будет вызван системой времени исполнения в тот момент, когда объект перестанет использоваться. В большинстве классов деструкторы не нужны, поскольку Perl сам решает основные проблемы — такие, как освобождение памяти.
Система сборки мусора не поможет лишь в одной ситуации — при наличии циклических ссылок в структуре данных:
$self-><WHATEVER} = $self,
13.3. Работа с данными экземпляра 459
В этом случае циклическую ссылку приходится удалять вручную, чтобы при работе программы не возникали утечки памяти. Такой вариант чреват ошибками, но это лучшее, что мы можем сделать. Впрочем, в рецепте 13.13 представлено элегантное решение этой проблемы. Однако вы можете быть уверены, что при завершении программы будут вызваны деструкторы всех ее объектов. При завершении работы интерпретатора выполняется тотальная сборка мусора. Даже недоступные или циклические объекты не переживут последней чистки. Следовательно, можно быть уверенным в том, что объект когда-нибудь будет уничтожен должны образом, даже если выход из программы никогда не происходит. Если Perl работает внутри другого приложения, вторая форма сборки мусора встречается чаще (при каждом завершении интерпретатора).
Метод DESTROY не вызывается при завершении программы, вызванной функцией exec.
> Смотри также--------------------------------------------------------------------------------------------
perltoot(l) иperlobj(l); рецепты 13.10; 13.13.
13.3. Работа с данными экземпляра
Проблема
Для работы с каждым атрибутом данных объекта (иногда называемым переменной экземпляра или свойством) необходим специальный метод доступа. Как написать функцию для работы с данными экземпляра?
Решение
Напишите пару методов для чтения и присваивания соответствующего ключа в хэше объекта:
sub get_name {
my $self = shift; return $self->{NAME>,
sub set_name {
my $self = shift,
$self->{NAME} = shift, }
Или воспользуйтесь одним методом, который решает ту или иную задачу в зависимости от того, был ли передан аргумент при вызове:
sub name {
my $self = shift;
if (@_) { $self->{NAME> = shift }
return $self->{NAME},
460 Глава 13 • Классы, объекты и связи
Иногда при установке нового значения полезно вернуть старое:sub age {
my $self = shift;
my $prev = $self->{AGE>;
if (@_) { $self->{AGE} = shift >
return $prev; }
tt Пример одновременного чтения и записи атрибута $obj->age( 1 + $obj->age );
Комментарий
Работа методов зависит от того, как вы организуете открытый интерфейс к объекту. Нормальный класс не любит, чтобы окружающие копались у него во внутренностях. Для каждого атрибута данных должен существовать метод, обеспечивающий его чтение или обновление. Если пользователь пишет фрагмент вида:
$him = Person->new(); $him->{NAME} = "Sylvester"; $him->{AGE} = 23;
он нарушает интерфейс объекта и напрашивается на неприятности.
Для номинально закрытых атрибутов вы просто не создаете методы, позволяющие обращаться к ним.
Интерфейс на базе функций позволяет изменить внутреннее представление, не рискуя нарушить работу программ. Он позволяет выполнять любые проверки диапазона, а также выполнять необходимое форматирование или преобразование данных.
Продемонстрируем сказанное на примере улучшенной версии метода name:
use Carp; sub name {
my $self = shift;
return $self->{NAME} unless <g>_;
local $_ = shift;
croak "too many arguments" if @_;
if ($~W) {
/["\s\w'-]/ && carp "funny characters in name";
/\d/ && carp "numbers in name";
/\S+(\s+\S+)+/ || carp "prefer multiword name";
/\S/ II carp "name is blank";
}
s/(\w+)/\u\L$1/g; # Начинать с символа верхнего регистра $self->{NAME} = $_; }
Если пользователи (или даже другие классы посредством наследования) обращаются к полю "NAME" напрямую, вы уже не сможете добавить подобный код. Настаивая на косвенном обращении ко всем атрибутам данных через функции, вы оставляете за собой свободу выбора.
Программисты, которым приходилось работать с объектами C++, привыкли к тому, что к атрибутам объекта можно обращаться из методов в виде простых переменных. Модуль Alias с CPAN обеспечивает эту и многие другие возможности — например, создание открытых методов, которые могут вызываться объектом, но недоступны для кода за его пределами.
Рассмотрим пример создания класса Person с применением модуля Alias. Обновление «магических» переменных экземпляра автоматически обновляет поля данных в хэше. Удобно, правда?
package Person;
# То же, что и раньше... sub new {
my $that = shift;
ray $class = ref($that) || $that;
my $self = {
NAME => undef, AGE => undef, PEERS => [],
bless($self, $class); return $self;
use Alias qw(attr);
use vars qw($NAME $AGE $PEERS);
sub name {
my $self = attr shift;
if (@_) { $NAME = shift; }
return $NAME;
sub age {
my $self = attr shift; if (@J { SAGE = shift; } return SAGE;
sub peers {
my $self = attr shift; if (@_) { ©PEERS = @_; } return @PEERS;
sub exclaim {
my $self = attr shift;
return sprintf "Hi, I'm %s, age %d, working with %s" SNAME, SAGE, join(", ", ©PEERS);
462 Глава 13 • Классы, объекты и связи
sub happy_birthday {my $self = attr shift;
return ++SAGE; }
Директива use va rs понадобилась из-за того, что Alias играет с пакетными глобальными переменными, имена которых совпадают с именами полей. Чтобы использовать глобальные переменные при действующей директиве use strict, необходимо заранее объявить их. Эти переменные локализуются в блоке, содержащем вызов attr(), словно они объявлены с ключевым словом local. Таким образом, они остаются глобальными пакетными переменными с временными значениями.
> Смотри также------------------------------------------------------------------------
perltoot(l), perlobj(l) nperlbot(l); документация по модулю Alias с CPAN; рецепты 13.11-13.12.
13.4. Управление данными класса
Проблема
Вам нужен метод, который вызывается для класса в целом, а не для отдельного объекта. Например, он может обрабатывать глобальный атрибут данных, общий для всех экземпляров класса.
Решение
Первым аргументом метода класса является не ссылка, как в методах объектов, а строка, содержащая имя класса. Методы классов работают с данными пакета, а не данными объекта, как показывает приведенный ниже метод population:
package Person;
$Body_Count = 0;
sub population { return $Body_Count >
sub new { # Конструктор
$Body_Count++; return bless({}, shift);
sub DESTROY { --SBodyCount } # Деструктор
# Позднее пользователь может написать: package main;
for (1..10) { push ^people, Person->new }
printf "There are %d people alive.\n", Person->population();
There are 10 people alive.
Комментарий
Обычно каждый объект обладает определенным состоянием, полная информация о котором хранится в самом объекте. Значение атрибута данных одного объекта никак не связано со значением этого атрибута в другом экземпляре того же класса. Например, присваивание атрибуту gender объекта her никак не влияет на атрибут gender объекта him, поскольку это разные объекты с разным состоянием:
$him = Person->new(); $him->gender("male");
* $her = Person->new(); $her->gender("female");
Представьте атрибут, общий для всего класса — изменение атрибута для одного экземпляра приводит к его изменению для остальных экземпляров. Подобно тому, как имена глобальных переменных часто записываются с большой буквы, некоторые программисты предпочитают записывать имя символами верхнего регистра, если метод работает с данными класса, а не с данными экземпляра. Рассмотрим пример использования метода класса с именем Max_Bounds:
FixedArray->Max_Bounds(100); # Устанавливается для всего класса
Salpha = FixedArray->new();
printf "Bound on alpha is %d\n", $alpha->Max_Bounds();
100
$beta = FixedArray->new();
$beta->Max_Bounds(50); # Также устанавливается для всего класса
printf "Bound on alpha is %d\n", $alpha->Max_Bounds();
SO
Реализация выглядит просто:
package FixedArray; SBounds =7; # default sub new { bless( {}, shift ) } sub Max_Bounds {
my $proto = shift;
SBounds = shift if @_; # Разрешить обновления
return SBounds; >
Чтобы фактически сделать атрибут доступным только для чтения, просто удалите команды обновления:
sub Max_Bounds { SBounds }
Настоящий параноик сделает SBounds лексической переменной, которая ограничена областью действия файла, содержащего класс. В этом случае никто не сможет обратиться к данным класса через SFixedArray: : Bounds. Работать с данными придется через интерфейсные методы.
Следующий совет поможет вам строить расширяемые классы: храните данные объекта в пространстве имен объекта (в хэше), а данные класса — в пространстве имен класса (пакетные переменные или лексические переменные с файловой об-
sub new {
my $class = shift; my $self = bless({>, $class); $self->{Max_Bounds_ref} = \$Bounds; return $self,
> Смотри также---------------------------------------------------------------------------------------------
perltoot(l), perlobj(l) иperlbot(l); рецепт 13.3; пример использования метода places в разделе «Пример. Перегруженный класс FixNum» в рецепте 13.14.
13.5. Использование класса как структуры
Проблема
Вы привыкли работать со структурированными типами данных — более сложными, чем массивы и хэши Perl (например, структуры С и записи Pascal). Вы слышали о том, что классы Perl не уступают им по возможностям, но не хотите изучать объектно-ориентированное программирование.
Решение
Воспользуйтесь стандартным модулем Class::Struct для объявления С-подобных структур:
use Class::Struct, # Загрузить модуль построения структур
struct Person => { й Создать определение класса "Person"
name =>'$', # Имя - скаляр
age =>'$', # Возраст - тоже скаляр
peers => '@', # Но сведения о друзьях - массив (ссылка)
>:
my $p = Person->new(); # Выделить память для пустой структуры Person
$p->name("Jason Smythe"), # Задать имя
$p->age(13); # Задать возраст
$p->peers( ["Wilbur", "Ralph", "Fred' ] ); # Задать друзей
# Или так:
?->peers} = ("Wilbur", "Ralph", "Fred");
# Выбрать различные значения, включая нулевого друга pnntf "At age %d, %s's first friend is %s.\n", $p->age, $p->name, $p->peers(0);
Комментарий
Функция Class: : St met: st ruct автоматически создает классы, дублирующие структуры. Она создает класс с именем, передаваемым в первом аргументе, и генерирует для него конструктор new и методы доступа к полям.
В определении структуры ключи соответствуют именам полей, а значения — типам данных. Существуют три основных значения типа: ' $' для скаляров,' @' для массивов и '%' для хэшей. Каждый метод доступа может вызываться без аргументов (выборка текущего значения) или с аргументами (присваивание значения). Для полей с типом «массив» или «хэш» вызов метода без аргументов возвращает ссылку на весь массив или хэш, вызов с одним аргументом получает значение по указанному индексу1, а вызов с двумя аргументами задает значение для указанного индекса.
Однако тип может быть именем другой структуры (или любого класса), имеющей конструктор new.
use Class:'Struct,
struct Person => {name => '$', age => '$'};
struct Family => {head => 'Person , address => '$ , members => '©'},
$folks = Family->new(); $dad = $folks->head, $dad->name("John"); $dad->age(34);
pnntf( '%s's age is %d\n", $folks->head->name, $folks->head->age),
Чтобы организовать дополнительную проверку параметров, напишите собственные версии методов доступа, переопределяющие версии по умолчанию. Предположим, вы хотите убедиться, что значение возраста состоит из одних цифр и не превышает нормальной продолжительности человеческой жизни. Функция Может выглядеть так:
sub Person::age { use Carp,
my ($self, $age) = @_;
if (@_ > 2) { confess "too many arguments" } elsif (@_ == 1) { return $struct->{'age'} } elsif (@_ == 2) {
carp "age '$age' isn't numeric" if $age '~ /"\d+/;
carp "age '$age' is unreasonable" if $age > 150;
$self->{'age'} = $age,
Если предупреждения должны выводиться лишь при наличии флага -w в командной строке, проверьте переменную $"W:
466 Глава 13 • Классы, объекты и связи
If ($"W) {carp "age '$age' isn't numeric" if Sage !' /"\d+/;
carp "age '$age' is unreasonable" if $age > 150;
}
Если при наличии флага -w выводится предупреждение, а без него функция должна инициировать исключение, воспользуйтесь следующим фрагментом. Пусть стрелка вас не смущает; это косвенный вызов функции, а не вызов метода.
my $gripe = $"W ? \&carp : \&croak;
$gripe->("age '$age' isn't numeric") if $age !* /~\d+/l
$gripe->("age $age' is unreasonable") if Sage > 150;
Как и большинство классов, наш класс реализован в виде хэша. Это упрощает отладку и сопровождение кода. Представьте себе возможность вывода структуры в отладчике. Однако модуль Class::Struct также поддерживает реализацию на базе массива, для этого достаточно перечислить поля в квадратных скобках вместо фигурных:
struct Family => [head => 'Person', address => '$', members => '©'];
Существуют эмпирические данные, свидетельствующие о том, что выбор массива вместо хэша снижает расходы памяти от 10 до 50 % и примерно на 33 % ускоряет доступ. За это приходится расплачиваться менее содержательной отладочной информацией и трудностями при написании переопределяющих функций (таких, как приведенная выше функция Person::age). Обычно представление объекта в виде массива усложняет наследование. В данном случае это не так, поскольку С-по-добные структуры обеспечивают намного более понятную реализацию агрегирования.
Директива use fields в Perl версии 5. 005 повышает скорость за счет дополнительных затрат памяти и обеспечивает проверку имен полей на стадии компиляции.
Если все поля принадлежат к одному типу, то запись вида:
struct Card => {
name => '$',
color => '$',
cost => '$',
type => '$',
release => '$',
text => '$',
};
упрощается с помощью функции map:
struct Card => map {$_=>'$' } qw(name color cost type release text);
А если вы программируете на С и предпочитаете указывать тип поля перед его именем, а не наоборот, просто измените их порядок:
struct hostent => { reverse qw{ $ name
@ aliases $ addrtype $ length @ addr_list И;
Вы даже можете создавать синонимы в стиле «define (впрочем, такая возможность выглядит сомнительно), позволяющие обращаться к одному полю по нескольким именам. В С можно написать:
«define h_type h_addrtype #defme h_addr h_addr_list[O]
В Perl можно попробовать следующий вариант:
# Сделать (hostent object)->type()
# эквивалентным (hostent object)->addrtype()
•hostent::type = \&hostent::addrtype;
# Сделать (hostenv object)->addr()
# эквивалентным (hostenv object)->addr_list(0)
sub hostent::addr { shift->addr_list(O,@_) }
Как видите, вы можете добавлять методы в класс (или функции в пакет) простым объявлением функции в нужном пространстве имен. Для этого необязательно находиться в файле с определением класса, создавать субкласс или делать что-то хитроумное и запутанное. Однако вариант с субклассированием все же смотрится намного лучше:
package Extra::hostent;
use Net::hostent;
@ISA = qw(hostent);
sub addr { shift->addr_list(O,@_) }
1;
Это решение взято из стандартного класса Net::hostent. Обратитесь к исходным текстам этого модуля, это весьма вдохновляющее чтение. Впрочем, авторы не несут ответственности за возможные последствия вашего вдохновения.
> Смотри также---------------------------------------------------------------------------------------------
perltoot(l), perlobj(l) и perlbot(l); документация по стандартному модулю Class::Struct; исходный текст стандартного модуля Net::hostent; документация по модулю Alias с CPAN; рецепт 13.3.
13.6. Клонирование объектов
Проблема
Вы хотите написать конструктор, который может вызываться для существующего объекта.
Начните свой конструктор примерно так:
my $proto = shift;
ту $class = ref($proto) || $proto;
ту $parent = ref($proto) && $proto;
Переменная $class содержит класс, к которому выполняется приведение, а переменная Sparent либо равна false, либо ссылается на клонируемый объект.
Комментарий
Иногда требуется создать объект, тип которого совпадает с типом другого, существующего объекта. Вариант:
$оЫ = SomeClass->new();
8 Далее
$ob2 = (ref $ob1)->new();
выглядит не очень понятно. Вместо этого хотелось бы иметь конструктор, который может вызываться для класса или существующего объекта. В качестве метода класса он возвращает новый объект, инициализированный по умолчанию. В качестве метода экземпляра он возвращает новый объект, инициализированный данными объекта, для которого он был вызван:
$оЫ = Widget->new(); $оЬ2 = $ot>1->new();
Следующая версия new учитывает эти соображения:
sub new {
my Sproto = shift;
my $class = ref($proto) || $proto;
my Sparent = ref($proto) && $proto;
my $self;
# Проверить, переопределяется ли new из @ISA
if (@ISA && $proto->SUPER::can('new') <
$self = $proto->SUPER::new(@_); } else {
$self = {};
bless ($self, $proto); } bless($self, $class);
$self->{PARENT} = $parent;
$self->{START} = time(); # Инициализировать поля данных $self->{AGE} = 0; return $self; }
Инициализация не сводится к простому копированию данных из объекта-прототипа. Если вы пишете класс связанного списка или бинарного дерева, при вы-
зове в качестве метода экземпляра ваш конструктор может вернуть новый объект, включенный в дерево или список.
[> Смотри также-------------------------------------------------------------------------------------------
perlobj(l); рецепты 13.1; 13.9; 13.13.
13.7. Косвенный вызов методов
Проблема
Требуется вызвать метод по имени, которое станет известно лишь во время выполнения программы.
Решение
Сохраните имя метода в строковом виде в скалярной переменной и укажите имя переменной там, где обычно указывается имя метода — справа от оператора ->:
$methname = "flicker";
$obj->$methname(10); # Вызывает $ob->flicker(10);
# Три метода объекта вызываются по именам foreach $m ( qw(start run stop) ) { $obj->$m();
Комментарий
Имя метода не всегда известно на стадии компиляции. Как известно, получить адрес метода нельзя, но можно сохранить его имя. Если имя хранится в скалярной переменной $meth, то для объекта $crystal этот метод вызывается так:
$crystal->$meth().
©methods = qw(name rank serno);
%his_info = map { $_ => $ob->$_() } ©methods;
# Эквивалентно:
%his_info = (
'name' => $ob->name(),
'rank' => $ob->rank(),
'serno' => $ob->serno(),
);
Если вам никак не обойтись без получения адреса метода, попробуйте переосмыслить свой алгоритм. Например, вместо неправильной записи \$ob->method(), при которой \ применяется к возвращаемому значению или значениям метода, поступите следующим образом:
my $fnref = sub { $ob->method(@_) };
470 Глава 13 • Классы, объекты и связи
Когда придет время косвенного вызова этого метода, напишите:$fnref->(10, "fred"); и это даст правильный вызов метода:
$obj->method(10, "fred");
Такое решение работает даже в том случае, если $ob находится вне области действия и потому является предпочтительным.
Ссылку на код, возвращаемую методом сап() класса UNIVERSAL, вероятно, не следует использовать для косвенного вызова методов. Нельзя быть уверенным в том, что она будет соответствовать правильному методу для объекта произвольного класса.
Например, следующий фрагмент крайне сомнителен:
$ob]->can('method_name')->($obj_target, ©arguments) if $obj_target->isa( ref $obj );
Ссылка, возвращаемая can, может и не соответствовать правильному методу для $ob]2. Вероятно, разумнее ограничиться проверкой метода сап() в логическом условии.
> Смотри также---------------------------------------------------------------------------------------------
perlobj(l); рецепт 11.8.
13.8. Определение принадлежности субкласса
Проблема
Требуется узнать, является ли объект экземпляром некоторого класса или одного из его субклассов. Например, надо выяснить, можно ли вызвать для объекта некоторый метод.
Решение
Воспользуйтесь методами специального класса UNIVERSAL:
$obj->isa("HTTP::Message"); # Как метод объекта
HTTP1 ¦Response->isa("HTTP::Message"); # Как метод класса
if ($obj->can("method_name")) { } n Проверка метода
Комментарий
Для нас было бы очень удобно, чтобы все объекты в конечном счете происходили от общего базового класса. Тогда их можно было бы наделить общими методами, не дополняя по отдельности каждый массив @ISA. В действительности такая возможность существует. Хотя вы этого не видите, но Perl считает,
что в конце @ISA находится один дополнительный элемент — пакет с именем UNIVERSAL.
В версии 5.003 класс UNIVERSAL не содержал ни одного стандартного метода, но вы могли занести в него все, что считали нужным. Однако в версии 5.004 UNIVERSAL уже содержит несколько методов. Они встроены непосредственно в двоичный файл Perl и потому на их загрузку не расходуется дополнительное время. К числу стандартных методов относятся isa, can и VERSION. Метод isa сообщает, «является ли» (is а) объект или класс чем-то другим, избавляя вас от необходимости самостоятельно просматривать иерархию:
$has_io = $fd->isa("IO.:Handle"); $itza_handle = 10 Socket»isa("IO 'Handle'),
Также существует мнение, что обычно лучше попробовать вызвать метод. Считается, что явные проверки типов вроде показанной выше слишком ограничивают свободу действий.
Метод сап вызывается для объекта или класса и сообщает, соответствует ли его строковый аргумент допустимому имени метода для данного класса. Он возвращает ссылку на функцию данного метода:
$his_pnnt_method = $ob]->can('as_string'),
Наконец, метод VERSION проверяет, содержит ли класс (или класс объекта) пакетную глобальную переменную $VERSION с достаточно высоким значением:
Some_Module->VERSI0N(3.0); $his_vers = $obj->VERSION();
Тем не менее нам обычно не приходится вызывать VERSION самим. Вспомните: имена функций, записанные в верхнем регистре, означают, что функция вызывается Perl автоматически. В нашем случае это происходит, когда в программе встречается строка вида:
use Some_Module 3 0;
Если вам захочется включить проверку версии в класс Person, описанный выше, добавьте в файл Person.pm следующий фрагмент:
use vars qw($VERSION); $VERSION = '1.01';
Затем в пользовательской программе ставится команда use Person 1.01; —это позволяет проверить версию и убедиться в том, что она равна указанной или превышает ее. Помните, что версия не обязана точно совпадать с указанной, а должна быть не меньше ее. Впрочем, в настоящее время параллельная установка нескольких версий одного модуля не поддерживается.
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю UNIVERSAL. Ключевое слово use описа
но в perlfunc{\). , ,
Проблема
Вы не уверены в том, правильно ли вы спроектировали свой класс и может ли он использоваться в наследовании.
Решение
Воспользуйтесь «проверкой пустого субкласса».
Комментарий
Допустим, вы реализовали класс Person с конструктором new и методами age и name. Тривиальная реализация выглядит так:
package Person; sub new {
my $class = shift;
my $self = { },
return bless $self, Sclass, } sub name {
my $self = shift;
$self->{NAME} = shift if @>_;
return $self->{NAME>; } sub age {
my $self = shift,
$self->{AGE} = shift if §_,
return $self->{AGE}; }
Пример использования класса может выглядеть так:
use Person,
my $dude = Person->new();
$dude->name("Jason");
$dude->age(23),
printf '%s is age %d \n', $dude->name, $dude->age;
Теперь рассмотрим другой класс с именем Employee:
package Employee; use Person, @ISA = ('Person"); 1;
Ничего особенно интересного. Класс всего лишь загружает класс Person и заявляет, что все необходимые методы Employee наследует от Person. Поскольку Employee не имеет собственных методов, он получит от Person все методы.
Мы хотим, чтобы поведение класса Person полностью воспроизводилось в Employee.
Создание подобных пустых классов называется «проверкой пустого субкласса»; иначе говоря, мы создаем производный класс, который не делает ничего, кроме наследования от базового. Если базовый класс спроектирован нормально, то производный класс в точности воспроизведет его поведение. Это означает, что при простой замене имени класса все остальное будет работать:
use Employee;
my $empl = Employee->new();
$empl->name("Jason");
$empl->age(23);
printf "%s is age %d.\n", $empl->name, $empl->age;
Под «нормальным проектированием» имеется в виду использование только двухаргументной формы bless, отказ от прямого доступа к данным класса и отсутствие экспортирования. В определенной выше функции Person:: new() мы проявили необходимую осторожность; в конструкторе используются некоторые пакетные данные, но ссылка на них хранится в самом объекте. Другие методы обращаются к пакетным данным через эту ссылку, поэтому проблем быть не должно.
Но почему мы сказали «функции PersomwewQ» — разве это не метод? Дело в том, что метод представляет собой функцию, первый аргумент которой определяет имя класса (пакет) или объект (приведенную ссылку). Person;: new — это функция, которая в конечном счете вызывается методами Person->new и Employee->new. Хотя вызов метода очень похож на вызов функции, они все же отличаются. Если вы начнете путать функции с методами, то очень скоро у вас не останется ничего, кроме неработающих программ. Во-первых, функции отличаются от методов фактическими конвенциями вызова — метод вызывается с дополнительным аргументом. Во-вторых, вызовы функций не поддерживают наследования, а методы — поддерживают.
Если вы привыкнете к вызовам вида:
Вызов метода Вызов функции
Employee->new() Person::new("Employee")
Shim = Person::new(); «НЕВЕРНО
в программе возникнет нетривиальная проблема, поскольку функция не получит ожидаемого аргумента "Person" и не сможет привести его к переданному классу. Еще хуже, если вам захочется вызвать функцию Employee:: new(). Такой функции не существует! Это всего лишь вызов унаследованного метода. Мораль: не вызывайте функции там, где нужно вызывать методы.
> Смотри также---------------------------------------------------------------------------------------------
perltoot(i),perlobj(l) иperlbot(l); рецепты 13.1; 13.10.
Проблема
Конструктор переопределяет конструктор суперкласса. Вы хотите вызвать конструктор суперкласса из своего конструктора.
Решение
Используйте специальный класс, SUPER:
sub meth {
my $self = shift;
$self->SUPER::meth(); >
Комментарий
В таких языках, как C++, где конструкторы не выделяют память, а ограничиваются инициализацией объекта, конструкторы базовых классов вызываются автоматически. В таких языках, как Java и Perl, приходится вызывать их самостоятельно.
Для вызова методов конкретного класса используется формулировка $self-> SUPER: :meth(). Она представляет собой расширение обычной записи с началом поиска в определенном базовом классе и допустима только в переопределенных методах. Сравните несколько вариантов:
$self->meth(); # Вызвать первый найденный meth
$self->Where::meth(); # Начать поиск с пакета "Where"
$self->SUPER::meth(); # Вызвать переопределенную версию
Вероятно, простым пользователям класса; следует ограничиться первым вариантом. Второй вариант возможен, но не рекомендуется. Последний вариант может вызываться только в переопределенном методе..
Переопределяющий конструктор должен вызвать конструктор своего класса SUPER, в котором выполняется выделение памяти и приведение объекта, и ограничиться инициализацией полей данных. В данном случае код выделения памяти желательно отделять от кода инициализации объекта. Пусть имя начинается с символа подчеркивания — условного обозначения номинально закрытого метода, аналога таблички «Руками не трогать».
sub new {
my $classname = shift; # Какой класс мы конструируем?
my $self = $classname->SUPER:;new(@_);
$self->_init(@_);
return $self; # Вернуть
sub _inxt { ,,
my $self = shift; $self->{START} = time(); # Инициализировать поля данных
13.11. Генерация методов доступа с помощью AUTOLOAD 475
$self->{AGE> =0; ,
$self->{EXTRA} = { @_ }1 # Прочее
И SUPER: :new и _init вызываются со всеми остальными аргументами, что позволяет передавать другие инициализаторы полей:
Sobj = Widget->new( haircolor => red, freckles => 121 );
Стоит ли сохранять пользовательские параметры в отдельном хэше — решайте сами.
Обратите внимание: SUPER работает только для первого переопределенного метода. Если в массиве @ISA перечислено несколько классов, будет обработан только первый. Ручной перебор @ISA возможен, но, вероятно, не оправдывает затраченных усилий.
my $self = bless {}, Sclass; for my Sclass (@ISA) <
my $meth = Sclass . "::_init";
$self->$meth(@_) if $class->can("_init");
В этом ненадежном фрагменте предполагается, что все суперклассы инициализируют свои объекты не в конструкторе, а в _init. Кроме того, предполагается, что объект реализуется через ссылку на хэш.
> Смотри также---------------------------------------------------------------------------------------------
Класс SUPER рассматривается Bperltoot(l) nperlobj(l).
13.11. Генерация методов доступа с помощью AUTOLOAD
Проблема
Для работы с полями данных объекта нужны методы доступа, а вам не хочется писать повторяющийся код.
Решение
Воспользуйтесь механизмом AUTOLOAD для автоматического построения методов доступа — это позволит обойтись без самостоятельного написания методов при добавлении новых полей данных.
Комментарий
Механизм AUTOLOAD перехватывает вызовы неопределенных методов. Чтобы ограничиться обращениями к полям данных, мы сохраним список допустимых полей в хэше. Метод AUTOLOAD будет проверять, присутствует ли в хэше запрашиваемое поле.
use strict;
use Carp;
use vars qw($AUTOLOAD %ok_field);
# Проверка четырех атрибутов
for my $attr ( qw(name age peers parent) ) { $ok_field{$attr}++; }
sub AUTOLOAD {
my $self = shift;
my $attr = $AUTOL0AD;
$attr =" s/.*:://;
return unless $attr =' /["A-Z]/; # Пропустить DESTROY и другие
# методы, имена которых
# записаны в верхнем регистре
croak "invalid attribute method: ->$attr()" unless $ok_field{$attr}; $self->{uc $attr} = shift if @_;
return $self->{uc $attr}; } sub new {
my Sproto = shift;
my $class = ref($proto) || Sproto;
my $parent = ref($proto) && Sproto;
my $self = {};
bless($self, $class);
$self->parent($parent);
return $self; } 1;
Класс содержит конструктор new и четыре метода атрибутов: name, age, peers и parent. Модуль используется следующим образом:
use Person;
my ($dad, $kid);
$dad = Person->new;
$dad->name("Jason");
$dad->age(23);
$kid = $dad->new;
$kid->name("Rachel");
$kid->age(2);
printf "Kid's parent is %s\n", $kid->parent->name;
Jason
В иерархиях наследования это решение вызывает некоторые затруднения. Предположим, вам понадобился класс Employee, который содержит все атрибуты данных класса Person и еще два атрибута (например, salary и boss). Класс Employee не может определять методы своих атрибутов с помощью унаследованного варианта Person:: AUTOLOAD — следовательно, каждому классу нужна собственная функция AUTOLOAD. Она проверяет атрибуты данного класса, но вместо вызова croak при отсутствии атрибута вызывает переопределенную версию суперкласса.
С учетом этого AUTOLOAD может выглядеть так:
sub AUTOLOAD {
my $self = shift;
my $attr = SAUTOLOAD;
$attr =¦ s/. *:://;
return if $attr eq 'DESTROY';
if ($ok_field{$attr}) {
$self->{uc $attr> = shift if @_;
return $self->{uc $attr}; } else {
my Ssuperior = "SUPER::$attr",
$self->$superior(@_);
Если атрибут отсутствует в списке, мы передаем его суперклассу, надеясь, что он справится с его обработкой. Однако такой вариант AUTOLOAD наследовать нельзя; каждый класс должен иметь собственную версию, поскольку работа с данными осуществляется напрямую, а не через объект.
Еще худшая ситуация возникает, если класс А наследует от классов В и С, каждый из которых определяет собственную версию AUTOLOAD — в этом случае при вызове неопределенного метода А будет вызвана функция AUTOLOAD лишь одного из двух родительских классов.
С этими ограничениями можно было бы справиться, но всевозможные заплатки, исправления и обходные пути вскоре начинают громоздиться друг на друге. Для сложных ситуаций существуют более удачные решения.
> Смотри также---------------------------------------------------------------------------------------------
Рецепты 10.15; 13.12. Пример использования AUTOLOAD приведен в perltoot(l).
13.12. Решение проблемы наследования данных
Проблема
Вы хотите унаследовать от существующего класса и дополнить его несколькими новыми методами, но не знаете, какие поля данных используются родительским классом. Как безопасно дополнить хэш объекта новым пространством имен и не повредить данные предков?
Решение
Снабдите каждое имя поля префиксом, состоящим из имени класса и разделителя, — например, одного или двух подчеркиваний.
В недрах стандартной объектно-ориентированной стратегии Perl спрятана одна неприятная проблема: знание точного представления класса нарушает иллюзию абстракции. Субкласс должен находиться в чрезвычайно близких отношениях со своими базовыми классами.
Давайте сделаем вид, что все мы входим в одну счастливую объектно-ориентированную семью и объекты всегда реализуются с помощью хэшей — мы попросту игнорируем классы, в чьих представлениях используются массивы, и наследуем лишь от классов на основе модели хэша (как показано в perlbot(\), эта проблема решается с помощью агрегирования и делегирования). Но даже с таким предположением наследующий класс не может с абсолютной уверенностью работать с ключами хэша. Даже если мы согласимся ограничиваться методами доступа для работы с атрибутами, значения которых задавались не нами, как узнать, что устанавливаемый нами ключ не используется родительским классом? Представьте себе, что в вашем классе используется поле count, но поле с таким же именем встречается в одном из пра-пра-правнуков. Имя _count (подчеркивание обозначает номинальную закрытость) не поможет, поскольку потомки могут сделать то же самое.
Одно из возможных решений — использовать для атрибутов префиксы, совпадающие с именем пакета. Следовательно, если вы хотите создать поле age в классе Employee, для обеспечения безопасности можно воспользоваться Employee_age. Метод доступа может выглядеть так:
sub Employee'.age {
my $self = shift;
$self->{Employee_age} = shift if @_;
return $self->{Employee_age}; }
Модуль Class::Spirit, описанный в рецепте 13.5, предоставляет еще более радикальное решение. Представьте себе один файл:
package Person,
use Class Attributes; # Объясняется ниже
mkattr qw(name age peers parent),
и другой файл:
package Employee, @ISA = qw(Person); use Class, attributes; mkattr qw(salary age boss);
Вы обратили внимание на общий атрибут age? Если эти атрибуты должны быть логически раздельными, то мы не сможем использовать $self->{age} даже для текущего объекта внутри модуля! Проблема решается следующей реализацией функции Class::Attributes::mkattr:
package Class;'.Attributes; i
use strict, use Carp,
use Exporter (); use vars qw(@ISA ©EXPORT); @ISA = qw(Exporter); ©EXPORT = qw(mkattr); sub mkattr {
my Shispack = caller(); for my $attr (@_) {
my($field, $method); $method = "${hispack}::$attr"; ($field = $method) =" s/:/_/g; no strict 'refs'; *$method = sub { my $self = shift;
confess "too many arguments" if @_ > 1; $self->{$field> = shift if @_; return $self->{$field};
1;
В этом случае $self->{Person_age} и $self->{Employee_age} остаются раздельными. Единственная странность заключается в том, что $obj-> age даст лишь первый из двух атрибутов. В принципе атрибуты можно было бы различать с помощью формулировок $obj ->Person:: age и $obj ->Employee;: age, но грамотно написанный код Perl не должен ссылаться на конкретный пакет с помощью ; :, за исключением крайних случаев. Если это оказывается неизбежным, вероятно, ваша библиотека спроектирована не лучшим образом.
Если вам не нравится подобная запись, то внутри класса Person достаточно использовать age($self), и вы всегда получите age класса Person, тогда как в классе Employee age($self) дает версию age класса Employee. Это объясняется тем, что мы вызываем функцию, а не метода.
> Смотри также---------------------------------------------------------------------------------------------
Документация по директивам use fields и use base для Perl версии 5.005; рецепт 10.14.
13.13. Использование циклических структур данных
Проблема
Имеется структура данных, построенная на циклических ссылках. Система сборки мусора Perl, использующая подсчет ссылок, не заметит, когда данная структура перестает использоваться. Вы хотите предотвратить утечки памяти в программе.
Создайте не-циклический объект-контейнер, содержащий указатель на структуру данных с циклическими ссылками. Определите для объекта-контейнера метод DESTROY, который вручную уничтожает циклические ссылки.
Комментарий
Многие интересные структуры данных содержат ссылки на самих себя. Например, это может происходить в простейшем коде:
$node->{NEXT} = $node;
Как только в вашей программе встречается такая команда, возникает цикличность, которая скрывает структуру данных от системы сборки мусора Perl с подсчетом ссылок. В итоге деструкторы будут вызваны при выходе из программы, но иногда ждать долго не хочется.
Связанный список также обладает циклической структурой: каждый узел содержит указатель на следующий узел, указатель на предыдущий узел и значение текущего узла. Если реализовать его на Perl с применением ссылок, появится циклический набор ссылок, которые также не будут автоматически уничтожаться с исчезновением внешних ссылок на узлы.
Проблема не решается и созданием узлов, представляющих собой экземпляры специального класса Ring. На самом деле мы хотим, чтобы данная структура уничтожалась Perl по общим правилам — а это произойдет в том случае, если объект реализуется в виде структуры, содержащей ссылку на цикл. В следующем примере ссылка хранится в поле DUMMY":
package Ring;
# Вернуть пустую циклическую структуру sub new {
my $class = shift;
my $node = { };
$node->{NEXT} = $node->{PREV} = $node;
my $self = { DUMMY => $node, COUNT => 0 };
bless $self, $classr
return $self; }
Цикличностью обладают узлы кольца, но не сам возвращаемый объект-кольцо. Следовательно, следующий фрагмент не вызовет утечек памяти:
use Ring;
$COUNT = 1000; for (1 .. 20) {
my $r = Ring->new();
for ($1 =0, $i < $COUNT; $i++) { $r->insert($i) } }
Даже если мы создадим двадцать колец по тысяче узлов, то перед созданием нового кольца старое будет уничтожено. Пользователю класса не придется бес-
покоиться об освобождении памяти в большей степени, чем для простых строк. Иначе говоря, все происходит автоматически, как и должно происходить.
Однако при реализации класса необходимо написать деструктор, который вручную уничтожает узлы:
# При уничтожении Ring уничтожить содержащуюся в нем кольцевую структуру sub DESTROY {
my $nng = shift; my $node;
for ( $node = $rmg->{DUMMY}->{NEXT}; $node '= $nng->{DUMMY}; $node = $node->{NEXT} ) {
$nng->delete_node($node); > $node->{PREV} = $node->{NEXT> = undef;
# Удалить узел из циклической структуры
sub delete_node {
my ($ring, $node) = @_; $node->{PREV}->{NEXT} = $node->{NEXT}; $node->{NEXT}->{PREV> = $node->{PREV}; -$nng->{C0UNT}; >
Ниже приведено еще несколько методов, которые следовало бы включить в класс. Обратите внимание на то, что вся реальная работа выполняется с помощью циклических ссылок, скрытых внутри объекта:
# $node = $nng->search( $value ) : найти $value в структуре $nng
sub search {
my ($ring, $value) = @>_;
my $node = $ring->{DUMMY}->{NEXT},
while ($node < = $nng->{0UMMY} && $node->{VALUE} != lvalue) {
$node = $node-><NEXT}; > return $node;
(t $rmg->msert( $value ) : вставить lvalue в структуру $nng sub msert_value {
my ($nng, lvalue) = @_;
my $node = { VALUE => lvalue };
|node->{NEXT} = |ring->{DUMMY}->{NEXT};
$nng->{DUMMY}->{NEXT}->{PREV} = Inode;
$nng->{DUMMY}->{NEXT} = Inode;
|node->{PREV} = |nng->{DUMMY};
++|ring->{COUNT};
482 Глава 13 • Классы, объекты и связи
# $ring->delete_value( $value ) : удалить узел по значению sub delete_value {my ($ring, lvalue) = @_;
my $node = $ring->search($value);
return if $node == $ring->{DUMMY};
$ring->delete_node($node);
1;
> Смотри также---------------------------------------------------------------------------------------------
Раздел «Garbage Collection» perlobj(l).
13.14. Перегрузка операторов
Проблема
Вы хотите использовать знакомые операторы (например, == или +) с объектами написанного вами класса или определить интерполированное значение для вывода объектов.
Решение
Воспользуйтесь директивой use overload. Ниже приведены два самых распространенных и часто перегружаемых оператора:
use overload ('<=>' => \&threeway_compare); sub threeway_compare {
my ($s1, $s2) = @_;
uc($s1->{NAME>) cmp uc($s2->{NAME});
use overload ( ..... => \&stringify );
sub stringify {
my $self = shift;
return sprintf "%s (%05d)",
ucfirst(lc($self->{NAME})), $self->{IONUM};
Комментарий
При работе со встроенными типами используются некоторые операторы (например, оператор + выполняет сложение, а . — конкатенацию строк). Директива use overload позволяет перегрузить эти операторы так, чтобы для ваших собственных объектов они делали что-то особенное.
Директиве передается список пар «оператор/функция»:
package TimeNumber;
use overload '+' => \&my_plus,
13.14. Перегрузка операторов 483
'-' => \&my_minus, ¦*¦ => \&my_star, V => \&my_slash;
Теперь эти операторы можно использовать с объектами класса TimeNumber, и при этом будут вызываться указанные функции. Функции могут делать все, что вам захочется.
Приведем простой пример перегрузки + для работы с объектом, содержащим количество часов, минут и секунд. Предполагается, что оба операнда принадлежат к классу, имеющему метод new, который может вызываться в качестве метода объекта, и что структура состоит из перечисленных ниже имен:
sub my_plus {
my($left, $right) = @_;
my $answer = $left»new();
$answer->{SECONDS} = $left->{SECONDS} + $right->{SECONDS};
$answer->{MINUTES} = $left»{MINUTES} + $right->{MINUTES};
$answer->{HOURS} = $left->{HOURS} + $right->{HOURS>;
if ($answer->{SECONDS> >= 60) { $answer->{SECONDS> %= 60; $answer->{MINUTES} ++;
if ($answer->{MINUTES> >= 60) { $answer->{MINUTES} %= 60; $answer->{H0URS} ++;
return $answer;
Числовые операторы рекомендуется перегружать лишь в том случае, если объекты соответствуют какой-то числовой конструкции — например, комплексным числам или числам с повышенной точностью, векторам или матрицам. В противном случае программа становится слишком сложной, а пользователи делают неверные предположения относительно работы операторов. Представьте себе класс, который моделирует страну. Если вы создадите оператор для сложения двух стран, то почему нельзя заняться вычитанием? Как видите, перегрузка операторов для нечисловых математических объектов быстро приводит к абсурду.
Объекты (а в сущности, и любые ссылки) можно сравнивать с помощью == и eq, но в этом случае вы узнаете лишь о совпадении их адресов (при этом == работает примерно в 10 раз быстрее, чем eq). Поскольку объект является всего лишь высокоуровневым представлением обычного машинного адреса, во многих ситуациях требуется определить собственный критерий того, что следует понимать под равенством двух объектов.
Даже для нечисловых классов особенно часто перегружаются два оператора: сравнения и строковой интерполяции. Допускается перегрузка как оператора <=>, так и стр, хотя преобладает второй вариант. После того как для объекта будет
Оператор строковой интерполяции обозначается странным именем "" (две кавычки). Он вызывается каждый раз, когда происходит строковое преобразование — например, внутри кавычек или апострофов или при вызове функции print.
Прочитайте документацию по директиве overload, прилагаемую к Perl. Перегрузка операторов Perl откроет перед вами некоторые нетривиальные возможности — например, методы строковых и числовых преобразований, автоматическая генерация отсутствующих методов и изменение порядка операндов при необходимости (например, в выражении 5 + $а, где $а является объектом).
Пример. Перегруженный класс StrNum
Ниже приведен класс StrNum, в котором числовые операторы используются для работы со строками. Да, мы действительно собираемся сделать то, против чего настраивали вас, то есть применить числовые операторы к нечисловым объектам, однако программисты по опыту работы в других языках всегда ожидают, что + и == будут работать со строками. Это всего лишь несложный пример, демонстрирующий перегрузку операторов. Подобное решение почти наверняка не будет использоваться в коммерческой версии программы из-за проблем, связанных с быстродействием. Кроме того, перед вами один из редких случаев использования конструктора, имя которого совпадает с именем класса, — наверняка это порадует программистов со знанием C++ и Python.
#!/usr/bm/perl
# show_strnum - пример перегрузки операторов
use StrNum;
$х = StrNum("Red"); $y = StrNum("Black');
$z = $х + $у; $r = $z • 3;
print "values are $x, $y, $z, and $r\n";
print "$x is ", $x < $y ? "LT" ; "GE", " $y\n";
values are Red, Black, RedBlack, and 0 Red Is GE Black
Исходный текст класса приведен в примере 13.1. Пример 13.1. StrNum
package StrNum;
use Exporter ();
@ISA = 'Exporter';
@EXPORT = qw(StrNum); # Необычно
use overload (
¦<=>' => \&spaceship, 'cmp' => \&spaceship,
..... => \&stringify,
'ЬооГ => \&boolify,
'0+' => \&numify,
'+' => \&concat,
'*' => \&repeat,
# Конструктор sub StrNum($) {
my ($value) = @_;
return bless \$value;
sub stnngify { $< $_[0] } }
sub numify { ${ $_[0] > >
sub boolify { ${ $_[0] > }
# H.' -J.<r> _ -
Ss1 $s2 $ir -*^., = ¦_ ¦eturn StrNum $mveriea 9 ($s2 $s1) . ($s1 . $s2);
# Использует stnngify sub repeat {
my ($s1, $s2, $inverted) = @_;
return StrNum $inverted ' ($s2 x $s1) : ($s1 x $s2);
1;
Пример. Перегруженный класс FixNum
В этом классе перегрузка оператора позволяет управлять количеством десятичных позиций при выводе. При этом во всех операциях используется полная точность. Метод places() вызывается для класса или конкретного объекта и задает количество выводимых позиций справа от десятичной точки.
#!/usr/bin/perl
# demo_fixnum - show operator overloading
use FixNum;
FixNum->places(5); $x = FixNum->new(40);
486 Глава 13 • Классы, объекты и связи
$у = FixNum->new(12);print "sum of $x and $y is ", $x + $y, "\n"; print "product of $x and $y is ", $x * $y, "\n";
$2 = $x / $y;
printf "$z has %d places\n", $z->places;
$z->places(2) unless $z->places;
print "div of $x by $y is $z\n";
print "square of that is ", $z • $z, "\n";
sum of STRFixNum: 40 and STRFixNum: 12 is STRFixNum: 52 product of STRFixNum: 40 and STRFixNum: 12 is STRFixNum: 480 STRFixNum: 3 has 0 places
div of STRFixNum: 40 by STRFixNum: 12 is STRFixNum: 3.33 square of that is STRFixNum: 11.11
Исходный текст класса приведен в примере 13.2. Из математических операций в нем перегружаются только операторы сложения, умножения и деления. Также перегружен оператор <=>, обеспечивающий выполнение всех сравнений, оператор строковой интерполяции и оператор числового преобразования. Оператор строковой интерполяции выглядит необычно, но это было сделано для удобства отладки.
Пример. 13.2 FixNum
package FixNum; use strict; my $PLAGES = 0;
sub new {
my Sproto = shift;
my $class = ref(Sproto) || Sproto;
my Sparent = ref(Sproto) && Sproto;
my $v = shift; my Sself = {
VALUE => $v,
PLACES => undef,
};
if (Sparent && defined $parent->{PLACES}) {
$self->{PLACES} = $parent->{PLACES}; } elsif ($v =" /(\.\d*)/) {
$self->{PLACES> = length($1) - 1; } else {
$self->{PLACES} = 0; } return bless Sself, Sclass;
13.14. Перегрузка операторов 487
sub places {
my $proto = shift;
my $self = ref($proto) && $proto;
my $type = ref($proto) || $proto;
if (@J (
ray Splaces = shift;
($self ? $self->{PLACES} ; $PLACES) = $places; }
return $self ? $self->{PLACES} : SPLACES; }
sub _max { $_[0] > $_[1] f $_[0] : $_[1] >
|
use overload '+' |
=> |
\&add, |
|
=> |
\&multiply, |
|
|
V |
=> |
\÷, |
|
<=>¦ |
=> |
\&spaceship, |
|
=> |
\&as_string, |
|
|
•o+- |
=> |
\&as_number; |
my ($this, $that, Sflipped) = @_;
my Sresult = $this->new( $this->{VALUE> + $that->{VALUE} ); $result->places( _max($this->{PLACES>, $that->{PLACES> )); return Sresult;
sub multiply {
my ($this, $that, Sflipped) = @_;
my Sresult = $this->new( $this->{VALUE> * $that->{VALUE> ); $result->places( _max($this->{PLACES}, $that->{PLACES} )); return Sresult;
sub divide {
my ($this, $that, Sflipped) = @_;
my Sresult = $this->new( $this->{VALUE} / $that->{VALUE> ); $result->places( _max($this->{PLACES>, $that->{PLACES> )); return Sresult;
sub as_string {
my Sself = shift;
return sprintf("STR%s: %..f", ref(Sself),
defined($self->{PLACES}) ? $self->{PLACES} : SPLACES, $self->{VALUE});
продолжение
488 Глава 13 • Классы, объекты и связи Пример 13.2 (продолжение)
sub as_number {my $self = shift, return $self->{VALUE},
sub spaceship {
my ($this, $that, Sflipped) = @_, $this->{VALUE) <=> $that->{VALUE},
1,
I> Смотри также--------------------------------------------------------------------------------------------
Документация по стандартной директиве use overload, а также модулям Math::BigInt и Math::Complex.
13.15. Создание «магических» переменных функцией tie
Проблема
Требуется организовать специальную обработку переменной или манипулятора.
Решение
Воспользуйтесь функций tie, чтобы создать объектные связи для обычной переменной.
Комментарий
Каждый, кому приходилось работать с DBM-файлами в Perl, уже использовал связанные объекты. Возможно, самый идеальный вариант работы с объектами — тот, при котором пользователь их вообще не замечает. Функция tie связывает переменную или манипулятор с классом, после чего все обращения к связанной переменной или манипулятору перехватываются специальными методами.
Наиболее важными являются следующие методы tie: FETCH (перехват чтения), STORE (перехват записи) и конструктор, которым является один из методов TIESCALAR, TIEARRAY, TIEHASH или TIEHANDLE.
Выполняемый код
SomeClass->TIESCALAR()
$р = $ob]->FETCH()
$ob]->ST0RE(10)___
Откуда берется объект $ob]? Вызов tie приводит к вызову конструктора TIESCALAR соответствующего класса. Perl прячет возвращенный объект и тайком использует его при последующих обращениях.
Ниже приведен простой пример класса, реализующего кольцевую структуру данных. При каждом чтении переменной выводится следующее значение из кольца, а при записи в кольцо заносится новое значение.
й'/usr/bm/perl
# demo_valuering - демонстрация связывания
use ValueRing,
tie $color, ValueRing , qw(red blue),
print $color $color $color $color $color $color\n ,
red blue red blue red blue
$color = green ,
print $color $color $color $color $color $color\n ,
green red blue green red blue
Простая реализация класса ValueRing приведена в примере 13.3. Пример 13.3. ValueRing
package ValueRing,
И Конструктор для связывания скаляров sub TIESCALAR {
my ($class, ©values) = @_,
bless \@values, $class,
return \@values,
# Перехватывает чтение sub FETCH {
my $self = shift,
push(@$self, shift(@$self)),
return $self->[-1],
# Перехватывает запись
sub STORE {
my ($self, lvalue) = @_, unshift @$self, Svalue, return Svalue,
1,
Вероятно, такой пример кажется надуманным, но он показывает, как легко создать связь произвольной сложности. Для пользователя $color остается старой доброй переменной, а не объектом. Все волшебство спрятано под связью. При связывании скалярной переменной совсем не обязательно использовать скалярную ссылку; мы использовали ссылку на массив, но вы можете выбрать любой другой вариант. Обычно при связывании любых переменных используется ссылка на хэш, поскольку она обеспечивает наиболее гибкое представление объекта.
490 Глава 13 • Классы, объекты и связи
Для массивов и хэшей возможны и более сложные операции. Связывание манипуляторов появилось лишь в версии 5.004, а до появления версии 5.005 возможности применения связанных массивов были несколько ограничены, но связывание хэшей всегда поддерживалось на высоком уровне. Поскольку полноценная поддержка связанных хэшей требует реализации множества методов объекта, многие пользователи предпочитали наследовать от стандартного модуля Tie::Hash, в котором существуют соответствующие методы по умолчанию.Ниже приведены некоторые интересные примеры связывания.
Пример связывания. Запрет $_
Этот любопытный связываемый класс подавляет использование неявной переменной $_. Вместо того чтобы подключать его командой use, что приведет к косвенному вызову метода import() класса, воспользуйтесь командой по для вызова редко используемого метода unimport(). Пользователь включает в программу следующую команду:
no Underscore;
После этого любые попытки использования нелокализованной глобальной переменной $_ приводят к инициированию исключения.
Рассмотрим применение модуля на небольшом тестовом примере:
#!/usr/bin/perl
# nounder_demo - запрет использования $_ в программе
no Underscore;
@tests = (
"Assignment" => sub { $_ = "Bad" },
"Reading" => sub { priat },
"Matching" => sub { $x = /badness/ },
"Chop" => sub < chop },
"Filetest" => sub { -x },
"Nesting" => sub { for (1..3) { print } },
while ( ($name, $code) = splice(@tests, 0, 2) ) {
print "Testing $name: ";
eval { &$code >;
print $@ ? "detected" : "missed!";
print "\n"; }
Результат выглядит так:
Testing Assignment: detected
Testing Reading: detected
Testing Matching: detected
Testing Chop: detected
Testing Filetest: detected
Testing Nesting: 123missed!
В последнем случае обращение к переменной не было перехвачено, поскольку она была локализована в цикле for.
13.15. Создание «магических» переменных функцией tie 491
Исходный текст модуля Underscore приведен в примере 13.4. Обратите внимание, каким маленьким он получился. Функция tie вызывается модулем в инициализирующем коде.
Пример 13.4. Underscore
package Underscore;
use Carp;
sub TIESCALAR {
my $class = shift;
my $dummy;
return bless \$dummy => $class; >
sub FETCH { croak "Read access to \$_ forbidden" > sub STORE { croak "Write access to \$_ forbidden" } sub unimport { tie($_, __PACKAGE__) } sub import { untie $_ > tie($_, __PACKAGE__) unless tied $_; 1;
Чередование вызовов use и по для этого класса в программе не принесет никакой пользы, поскольку они обрабатываются во время компиляции, а не во время выполнения. Чтобы снова воспользоваться переменной $_, локализуйте ее.
Пример связывания. Хэш с автоматическим дополнением
Следующий класс создает хэш, который автоматически накапливает повторяющиеся ключи в массиве вместо их замены.
ft!/usr/bin/perl
« appendhash_demo - хэш с автоматическим дополнением
use Tie::AppendHash;
tie %tab, 'Tie::AppendHash';
$tab{beer} = "guinness"; $tab{food} = "potatoes"; $tab{food} = "peas";
while (my($k, $v) = each %tab) {
print "$k => [@$v]\n"; >
Результат выглядит так:
food -> [potatoes peas] beer => [guinness]
Простоты ради мы воспользовались шаблоном модуля для связывания хэша, входящим в стандартную поставку (см. пример 13.5). Для этого мы загружаем модуль Tie::Hash и затем наследуем от класса Tie::StdHash (да, это действительно разные имена — файл Tie/Hash.pm содержит классы Tie::Hash и Tie::StdHash, несколько отличающиеся друг от друга).
package Tie::AppendHash;
use strict;
use Tie::Hash;
use Carp;
use vars qw(@ISA);
§ISA = qw(Tie::StdHash);
sub STORE {
my ($self, $key, lvalue) = @_;
push @{$self->{key}), $value; > 1;
Пример связывания. Хэш без учета регистра символов
Ниже приведен другой, более хитроумный пример связываемого хэша. На этот раз хэш автоматически преобразует ключи к нижнему регистру.
#!/usr/bin/perl
# folded_demo - хэш с автоматическим преобразованием регистра
use Tie::Folded;
tie %tab, 'Tie::Folded';
$tab{VILLAIN> = "big "; $tab{herOine} = "red riding hood"; $tab{villain> = "bad wolf";
while ( my($k, $v) = each %tab ) {
print "$k is $v\n"; }
Результат демонстрационной программы выглядит так:
heroine is red riding hood villain is big bad wolf
Поскольку на этот раз перехватывается большее количество обращений, класс из примера 13.6 получился более сложным, чем в примере 13.5.
Пример 13.6. Tie::Folded
package Tie::Folded;
use strict;
use Tie::Hash;
use vars qw(@ISA);
@ISA = qw(Tie::StdHash);
sub STORE {
my ($self, $key, $value) = @_;
return $self->{lc $key} = Svalue;
} sub FETCH <
my (Sself, $key) = @_;
13.15. Создание «магических» переменных функцией tie 493
return $self->{lc $key>;
>
sub EXISTS {
my ($self, $key) = @_;
return exists $self->{lc $key}; > sub DEFINED <
my ($self, $key) = @_;
return defined $self->{lc $key}; > 1;
Пример. Хэш с возможностью поиска по ключу и по значению
Следующий хэш позволяет искать элементы как по ключу, так и по значению. Для этого метод STORE заносит в хэш не только значение по ключу, но и обратную пару — ключ по значению.
Если сохраняемое значение представляет собой ссылку, возникают затруднения, поскольку обычно ссылка не может использоваться в качестве ключа хэша. Проблема решается классом Tie::RefHash, входящим в стандартную поставку. Мы унаследуем от него.
|
#!/usr/bin/perl |
-w |
|
# revhash_demo - |
хэш с возможностью поиска по ключу *или» по значению |
|
use strict; |
|
|
use Tie::RevHash |
; |
|
my %tab; |
|
|
tie %tab, 'Tie:: |
RevHash'; |
|
%tab = qw{ |
|
|
Red |
Rojo |
|
Blue |
Azul |
|
Green i. |
Verde |
|
I, $tab{EVIL} = [ " |
No way!", "Way!!" ]; |
print ref($k) ? "[@$k]" : $k, " => ",
ref($v) ? "[e$v]" : $v, An"; >
При запуске программа revhash_demo выдает следующий результат:
[No way! Way!!] = EVIL> EVIL => [No way! Way!!] Blue => Azul Green => Verde Rojo => Red Red => Rojo Azul => Blue Verde => Green
Исходный текст модуля приведен в примере 13.7. Оцените размеры!
494 Глава 13 • Классы, объекты и связи Пример 13.7. TiexRevHash
package Tie::RevHash; use Tie::RefHash; use vars qw(@ISA); @ISA = qw(Tie::RefHash); sub STORE {my ($self, $key, $value) = @_;
$self->SUPER::STORE($key, $value);
$self->SUPER::STORE($value, $key);
sub DELETE {
my ($self, $key) = @_;
my $value = $self->SUPER::FETCH($key);
$self->SUPER::DELETE($key);
$self->SUPER::DELETE($value);
1;
Пример связывания. Манипулятор с подсчетом обращений
Пример связывания для файлового манипулятора выглядит так:
use Counter;
tie *CH, 'Counter';
while (<CH>) {
print "Got $_\n"; }
При запуске эта программа выводит Got 1, Got 2 и так далее — пока вы не прервете ее, не перезафузите компьютер или не наступит конец света (все зависит от того, что случится раньше). Простейшая реализация приведена в примере 13.8.
Пример 13.8. Counter
package Counter; sub TIEHANDLE {
my $class = shift;
my $start = shift;
return bless \$start => $class; > sub READLINE {
my $self = shift;
return ++$$self; } 1;
Пример связывания. Дублирование вывода по нескольким манипуляторам
Напоследок мы рассмотрим пример связанного манипулятора, который обладает tee-подобными возможностями — он объединяет STDOUT и STDERR:
13.15. Создание «магических» переменных функцией tie 495
use Tie::Tee;
tie -TEE, Tie::Tee\ *STDOUT, -STDERR;
print TEE "This line goes both places.\n"
Или более подробно:
#!/usr/bin/perl tt demo_tietee use Tie::Tee; use Symbol;
©handles = (*STD0UT); for $i ( 1 .. 10 ){
push(@handles, $handle = gensymO);
open($handle, ">/tmp/teetest.$i");
tie «TEE, 'Tie::Tee', ©handles;
print TEE "This lines goes many places.\n";
Содержимое файла Tie/Tee.pm показано в примере 13.9.
Пример 13.9. Tie::Tee
package Tie::Tee;
sub TIEHANDLE <
my $class = shift; my Shandies = [@_];
bless Shandies, $class; return Shandies;
sub PRINT {
my $href = shift;
my Shandle;
my Ssuccess = 0;
foreach Shandle (@$href) { Ssuccess += print Shandle
return Ssuccess == @$href;
1;
> Смотри также----------------------------------------------
Функция tie описана в perlfunc(l) иperltie(l).
 |
Базы данных тт-i
Все, чего я прошу, — это информация. Чарльз Диккенс, -«Дэвид Копперфильд»
Введение
Базы данных встречаются везде, где происходит обработка данных. На простейшем уровне базой данных можно считать любой файл, а на самом сложном — дорогую и сложную реляционную базу данных, обрабатывающую тысячи транзакций в секунду. Между этими полюсами расположены бесчисленные механизмы ускоренного доступа к более или менее структурированным данным. Perl поддерживает работу с базами данных на любом из этих уровней.
На заре компьютерной эпохи люди заметили, что базы данных на основе плоских файлов плохо подходят для работы с большими объемами информации. Плоские файлы улучшались посредством введения записей фиксированной длины или индексирования, однако обновление требовало все больших затрат, и некогда простые приложения увязали в болоте ввода/вывода.
Умные программисты почесали в затылках и разработали более удачное решение. Поскольку хеш, находящийся в памяти, обеспечивает более удобный доступ к данным по сравнению с массивом, хеш на диске также упростит работу с данными по сравнению с «массивообразным» текстовым файлом. За ускорение доступа приходится расплачиваться объемом, но дисковое пространство в наши дни стоит дешево (во всяком случае, так принято считать).
Библиотека DBM предоставляет в распоряжение программистов простую и удобную базу данных. С хешами, ассоциированными с DBM-файлами, можно выполнять те же операции, что и с хешами в памяти. В сущности, именно так построена вся работа с базами данных DBM в Perl. Вы вызываете dbmopen с именем хеша и именем файла, содержащего базу данных. Затем при любом обращении к хешу Perl выполняет чтение или запись в базе данных DBM на диске.
Рецепт 14.1 демонстрирует процесс создания базы данных DBM, а также содержит рекомендации относительно ее эффективного использования. Хотя с файлами DBM допускаются все операции, разрешенные для простых хешей, возникают
проблемы быстродействия, неактуальные для хешей в памяти. Рецепты 14.2 и 14.4 разъясняют суть этих проблем и показывают, как справиться с ними. С файлами DBM также можно выполнять операции, недоступные для обычных хешей. Два примера таких операций рассматриваются в рецептах 14.6 и 14.7.
Разные реализации DBM обладают разными возможностями. Старая функция dbmopen позволяла использовать лишь ту библиотеку DBM, с которой был построен Perl. Если вы хотели использовать dbmopen для чтения базы данных одного типа и записи в другой тип — считайте, что вам не повезло. Положение было исправлено в Perl версии 5, где появилась возможность связать хеш с произвольным классом объекта — см. главу 13 «Классы, объекты и связи».
В следующей таблице перечислены некоторые доступные библиотеки DBM.
|
Особенности |
NDBM |
SDBM |
GDBM |
DB |
|
Программное обеспечение для связи |
Да |
Да |
Да |
Да |
|
поставляется с Perl |
||||
|
Исходные тексты поставляются с Perl |
Нет |
Да |
Нет |
Нет |
|
Возможность распространения |
Нет |
Да |
GPL1 |
Да |
|
исходных текстов |
||||
|
Доступность через FTP |
Нет |
Да |
Да |
Да |
|
Легкость построения |
- |
Да |
Да |
Нормально |
|
Частое применение в UNIX |
Да3 |
Нет |
Нет4 |
Нет4 |
|
Нормальное построение в UNIX |
- |
Да |
Да |
Да5 |
|
Нормальное построение в Windows |
- |
Да |
Да |
Да6 |
|
Размер кода |
7 |
Малый |
Большой |
Большой |
|
Использование диска |
9 |
Малое |
Большое |
Нормальное |
|
Скорость |
9 |
Низкая |
Нормальная |
Высокая |
|
Ограничение размера блока |
4Кб |
1Кб10 |
Нет |
Нет |
|
Произвольный порядок байтов |
Нет |
Нет |
Нет |
Да |
|
Порядок сортировки, определяемый |
Нет |
Нет |
Нет |
Да |
|
пользователем |
||||
|
Поиск по неполному ключу |
Нет |
Нет |
Нет |
Да |
За дополнительной информацией обращайтесь на www gnu.org.
2 См. библиотечный метод DB_File. Требует символических ссылок.
3 На некоторых компьютерах может входить в библиотеку совместимости с BSD.
4 Кроме бесплатных версий UNIX - Linux, FreeBSD, OpenBSD и NetBSD.
5 При наличии ANSI-компилятора С.
6 До выхода единой версии 5.005 существовало несколько разных версий Perl для Windows-систем,
включая стандартный порт, построенный по обычной поставке Perl, и ряд специализированных пор
тов. DB, как и большинство модулей CPAN, строится только в стандартной версии.
7 Зависит от поставщика.
8 Уменьшается при компиляции для одного метода доступа.
9 Зависит от поставщика.
10 По умолчанию, но может переопределяться (с потерей совместимости для старых файлов).
Строка «Размер кода» относится к размеру откомпилированной библиотеки, а строка «Использование диска» — к размеру создаваемых ей файлов баз данных. Размер блока определяет максимальный размер ключа или значения в базе. Строка «Произвольный порядок байтов» говорит о том, использует ли система баз данных аппаратный порядок следования байтов или создает переносимые файлы. Сортировка в пользовательском порядке позволяет сообщить библиотеке, в каком порядке должны возвращаться списки ключей, а поиск по неполному ключу позволяет выполнять приблизительный поиск в базе.
Большинство программистов Perl предпочитает берклиевские реализации. На многих системах эта библиотека уже установлена, и Perl может ей пользоваться. Другим мы рекомендуем найти эту библиотеку в С PAN и установить ее. Это заметно упростит вашу жизнь.
DBM-файлы содержат пары «ключ/значение». В терминологии реляционных баз данных вы получаете базу данных, которая содержит всего одну таблицу с двумя полями. В Рецепте 14.8 показано, как использовать модуль MLDBM с CPAN для хранения сложных структур данных в DBM-файлах.
При всех своих достоинствах модуль MLDBM не может преодолеть главное ограничение: критерием для извлечения записи является содержимое лишь одного столбца, ключа хеша. Если вам понадобится сложный запрос, могут возникнуть непреодолимые трудности. В таких случаях подумайте о специализированной системе управления базами данных (СУБД). Проект DBI содержит модули для работы с Oracle, Sybase, mSQL, MySQL, Ingres и другими системами.
По адресам http:/'/www,hermetica.com/technologia/perl/DBI/index.html и http:// www.perl/com/CPAN/modules/by-category/07_Database_Interfaces/BmcTOHUiee время имеются следующие модули:
|
AcsiiDB |
DBIDb |
MLDBM |
OLE |
Pg |
Sybase |
|
CDB File |
DBZ File |
Fame |
Msql |
Obj Store |
Postgres |
|
DBD |
DB File |
Ingperl |
MySQL |
Oraperl |
Sprite |
|
XBase |
Проблема
Вы хотите создать, заполнить, просмотреть или удалить значения из базы данных DBM.
Решение
Воспользуйтесь функцией dbmopen или tie, чтобы открыть базу и сделать ее доступной через хэш. Затем работайте с хэшем, как обычно. После завершения работы вызовите dbmclose или untie.
dbmopen
use DB_File; # необязательно; переопределяет
# стандартный вариант
dbmopen %HASH, FILENAME, 0666 9 открыть базу данных через %HASH or die "Can't open FILENAME: $!\n";
$V = $HASH{KEY}; # Получить данные из базы
$HASH{KEY} = VALUE; # Занести данные в базу
if (exists $HASH{KEY}) { # Проверить наличие данных в базе
# ...
}
delete $HASH{KEY}; # Удалить данные из базы dbmclose %HASH; # Закрыть базу данных
tie
use DB_File; # Загрузить модуль баз данных
tie %HASH, "DB_File", FILENAME 9 Открыть базу данных or die "Can't open FILENAME: $!\n"; # через %HASH
$V = $HASH{KEY}; # Получить данные из базы
$HASH{KEY} = VALUE; # Занести данные в базу
if (exists $HASH{KEY}) { # Проверить наличие данных в базе
# ...
}
delete $HASH{KEY}; # Удалить данные из базы
untie %hash; # Закрыть базу данных
Комментарий
Работа с базой данных через хэш отличается широкими возможностями и простотой. В вашем распоряжении оказывается хэш, состояние которого сохраняется и после завершения программы. Кроме того, он работает намного быстрее, чем хэш, полностью загружаемый при каждом запуске; даже если хэш состоит из миллиона элементов, ваша программа запустится практически мгновенно.
Программа из примера 14.1 работает с базой данных так, словно она является обычным хэшем. Для нее даже можно вызывать keys или each. Кроме того, для связанных DBM-хэшей реализованы функции exists и defined. В отличие от обычного хэша, для DBM-хеша эти функции идентичны.
Пример 14.1. userstats
#!/usr/bin/perl -w
# userstats - вывод статистики о зарегистрированных пользователях.
# При вызове с аргументом выводит данные по конкретным пользователям.
продолжение &
500 Глава 14 • Базы данных Пример 14.1 (продолжение)
use OB_File;$db = '/tmp/userstats.db'; # База для хранения данных между запусками
tie(%db, 'DB_File', $db) or die "Can't open DB_File $db : $!\n";
if (@ARGV) {
if ("@ARGV" eq "ALL") {
@ARGV = sort keys %db; } foreach $user (@ARGV) {
print "$user\t$db{$user}\n"; } } else {
(Nho = 'who'; # Запустить who(1)
if ($?) {
die "Couldn't run who: $">\n"; # Аварийное завершение }
# Извлечь имя пользователя (первое в строке) и обновить foreach $line C@who) {
$line =" /"(\S+)/;
die "Bad line from who: $lme\n" unless $1;
$db{$1>++;
untie %db;
Мы воспользовались командой who для получения списка зарегистрированных пользователей. Обычно результат выглядит следующим образом:
gnat ttypi Hay 29 15:39 (coprolith.frii.com)
Если вызвать программу userstats без аргументов, она проверяет зарегистрированных пользователей и соответствующим образом обновляет базу данных.
Передаваемые аргументы интерпретируются как имена пользователей, о которых следует вывести информацию. Специальный аргумент "ALL" заносит в @ARGV отсортированный список ключей DBM. Для больших хэшей с множеством ключей это обойдется слишком дорого — лучше связать хэш с В-деревом (см. рецепт 14.6).
1> Смотри также-------------------------------------------------------------------------------------------
Документация по стандартным модулям GDBMFile, NDBMFile, SDBM_ File, DBFile;perltie(l); рецепт 13.15. Влияние umask на процесс создания файлов рассматривается в рецепте 7.1.
14.2. Очистка DBM-файла
- Проблема
Требуется стереть все содержимое DBM-файла.
Решение
Откройте базу данных и присвойте ей (). При этом можно использовать функцию dbmopen:
dbmopen(%HASH, $FILENAME, 0666) or die "Can't open FILENAME: $!\n"; %HASH = (); dbmclose %HASH; или tie: use OB_File;
tie(%HASH, 'DB_File", $FILENAME) or die "Can't open FILENAME: $!\n"; %HASH = (); untie %hash;
Существует и другое решение — удалить файл и открыть его заново в режиме создания:
unlink SFILENAME
or die "Couldn't unlink SFILENAME to empty the database: $!\n"; dbmopen(%HASH, SFILENAME, 0666)
or die "Couldn't create SFILENAME database: $!\n";
Комментарий
Возможно, удаление файла с последующим созданием выполняется быстрее, чем очистка, но при этом возникает опасность подмены, которая может нарушить работу неосторожной программы или сделать ее уязвимой для нападения. В промежуток между удалением файла и его повторным созданием нападающий может создать ссылку, указывающую на жизненно важный файл /etc/precious, с тем же именем, что и у вашего файла. При открытии файла библиотекой DBM содержимое /etc/precious будет уничтожено.
При удалении базы данных DB_File с повторным созданием теряются значения всех настраиваемых параметров — размер страницы, фактор заполнения и т. д. Это еще один веский довод в пользу присваивания связанному хэшу пустого списка.
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю DB_File; рецепт 14.1. Функция unlink описана в perlfunc(l).
Проблема
У вас имеется файл в одном формате DBM, однако другая программа желает получить данные в другом формате DBM.
Решение
Прочитайте ключи и значения из исходного DBM-файла и запишите их в другой файл в другом формате DBM, как показано в примере 14.2.
Пример 14.2. db2gbdm
#!/usr/bm/perl -w
# db2gdbm: преобразование DB в GOBM
use strict;
use DB_File; use GDBM_File;
unless (@ARGV == 2) {
die "usage: db2gdbm infile outfile\n";
my ($infile, $outfile) = @ARGV; my (%db_in, %db_out);
# Открыть файлы
tie(%db_in, 'OB_File', $infile)
or die "Can't tie $infile: $!"; tie(%db_out, 'GOBM_File', $outfile, GDBM_WRCREAT, 0666)
or die "Can't tie Soutfile: $!";
fl Скопировать данные (не пользуйтесь %db_out = %db_in,
# потому что для больших баз это работает медленно)
while (my($k, $v) = each %db_in) {
$db_out{$k} = $v;
# Функции untie вызываются автоматически при завершении программы untie %db_in; untie %db_out;
Командная строка выглядит так:
% db2gdbm /tmp/users.db /tmp/users.gdbm
Комментарий
Если в одной программе используются различные типы DBM-файлов, вам придется использовать интерфейс tie, а не dbmopen. Дело в том, что интерфейс
dbmopen позволяет работать лишь с одним форматом баз данных и поэтому считается устаревшим.
Копирование хэшей простым присваиванием (%new = %old) работает и для DBM-файлов, однако сначала все данные загружаются в память в виде списка. Для малых хэшей это несущественно, но для больших DBM-файлов затраты могут стать непозволительно большими. Для хэшей баз данных лучше использовать перебор с помощью функции each.
t> Смотри также--------------------------------------------------------------------------------------------
Документация по стандартным модулям GDBM_File, NDBM_File, SDBM_File, DB_File; рецепт 14.1.
14.4. Объединение DBM-файлов
Проблема
Требуется объединить два DBM-файла в один с сохранением исходных пар «ключ/значение».
Решение
Либо объедините базы данных, интерпретируя их хэши как списки:
%OUTPUT = (96INPUT1. %INPUT2); либо (более разумный вариант) организуйте перебор пар «ключ/значение»:
%output =();
foreach $href ( \%INPUT1, \%INPUT2 ) {
while (my($key, Svalue) = each(%$href)) { if (exists $OUTPUT{$key}) {
# Выбрать используемое значение
# и при необходимости присвоить $OUTPUT{$key}
} else {
$OUTPUT{$key} = Svalue;
Комментарий
Прямолинейный подход из рецепта 5.10 обладает тем же недостатком. Объединение хэшей посредством списковой интерпретации требует, чтобы хэши были предварительно загружены в память, что может привести к созданию огромных временных списков. Если вы работаете с большими хэшами и/или не располагаете достаточной виртуальной памятью, организуйте перебор ключей в цикле each — это позволит сэкономить память.
Между этими двумя способами объединения есть еще одно отличие — в том, как они поступают с ключами, присутствующими в обоих базах. Присваивание
.»«•» г лава 14 • Базы данных
пустого списка просто заменяет первое значение вторым. Итеративный перебор позволяет принять решение, как поступить с дубликатом. Возможные варианты — выдача предупреждения или ошибки, сохранение первого экземпляра, замена первого экземпляра вторым, конкатенация обоих экземпляров. Используя модуль MLDBM, можно даже сохранить оба экземпляра в виде ссылки на массив из двух элементов.> Смотри также---------------------------------------------------------------------------------------------
Рецепты 5.10; 14.8.
14.5. Блокировка DBM-файлов
Проблема
Необходимо обеспечить одновременный доступ к DBM-файлу со стороны нескольких параллельно работающих программ.
Решение
Воспользуйтесь реализацией механизма блокировки DBM, если он имеется, и заблокируйте файл функцией flock либо обратитесь к нестандартной схеме блокировки из рецепта 7.21.
Комментарий
SDBM и GDBM не обладают возможностью блокировки базы данных. Вам придется изобретать нестандартную схему блокировки с применением дополнительного файла.
В GDBM используется концепция доступа для чтения или записи: файл GDBM в любой момент времени может быть открыт либо многими читающими процессами, либо одним записывающим. Тип доступа (чтение или запись) выбирается при открытии файла. Иногда это раздражает.
Версия 1 Berkeley DB предоставляет доступ к файловому дескриптору открытой базы данных, позволяя заблокировать его с помощью flock. Блокировка относится к базе в целом, а не к отдельным записям. Версия 2 реализует собственную полноценную систему транзакций с блокировкой.
В примере 14.3 приведен пример блокировки базы данных с применением Berkeley DB. Попробуйте многократно запустить программу в фоновом режиме, чтобы убедиться в правильном порядке предоставления блокировок.
Пример 14.3. dblockdemo
#!/usr/bin/perl
# dblockdemo - демонстрация блокировки базы данных dbm
use DB_File;
use strict;
sub LOCK_SH { 1 } «На случай, если у вас нет
sub LOCK_EX { 2 > # стандартного модуля Fcntl.
sub LOCK_NB { 4 } # Конечно, такое встречается редко,
sub LOCK_UN { 8 } # но в жизни всякое бывает.
my($oldval, $fd, $db, %db, lvalue, $key);
$key = shift || 'default'; $value = shift || 'magic'; Svalue .= " $$";
$db = tie(%db, 'DB_File', '/tmp/foo.db', O_CREAT|O_RDWR, 0666)
or die "dbcreat /tmp/foo.db $!";
$fd = $db->fd; # Необходимо для блокировки
print "$$: db fd is $fd\n"; open(DB_FH, "+<&=$fd")
or die "dup $!";
unless (flock (DB_FH, LOCK_SH | LOCK_NB)) {
print "$$: CONTENTION; can't read during write update!
Waiting for read lock ($!) ...."; unless (flock (DB_FH, LOCK SH)) { die "flock: $!" > -'Ф '
}
print "$$: Read lock granted\n";
$oldval = $db{$key};
print "$$: Old value was $oldval\n";
flock(DB_FH, LOCK_UN);
unless (flock (DB_FH, LOCK_EX | LOCK_NB)) {
print "$$: CONTENTION; must have exclusive lock!
Waiting for write lock ($!) ...."; unless (flock (DB_FH, LOCK.EX)) { die "flock: $!" >
print "$$: Write lock granted\n"; $db{$key> = $value; $db->sync; # to flush sleep 10;
flock(DB_FH, LOCKJJN);
undef $db;
untie %db;
close(DB_FH);
print "$$: Updated db to $key=$value\n";
D> Смотри также---------------------------------------------------------------------------------
Документация по стандартному модулю DB_File; рецепты 7.11; 16.12.
Проблема
Необходимо обработать большой объем данных, которые должны передаваться в DBM-файл в определенном порядке.
Решение
Воспользуйтесь возможностью связывания В-деревьев модуля DB_File и предоставьте функцию сравнения:
use DB_File;
# Указать функцию Perl, которая должна сравнивать ключи
# с использованием экспортированной ссылки на хэш $DB_BTREE
$DB_BTREE->{' compare'} = sub {
my ($key1, $key2) = @_ ; "\L$key1" cmp "\L$key2" ;
tie(%hash, ¦'DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE) or die "can't tie $filename: $!";
Комментарий
Основной недостаток хэшей (как в памяти, так и в DBM-файлах) заключается в том, что они не обеспечивают нормального упорядочения элементов. Модуль Tie::IxHash с CPAN позволяет создать хэш в памяти с сохранением порядка вставки, но это не поможет при работе с базами данных DBM или произвольными критериями сортировки.
Модуль DB_File содержит изящное решение этой проблемы за счет использования В-деревьев. Одно из преимуществ В-дерева перед обычным DBM-хэшем — его упорядоченность. Когда пользователь определяет функцию сравнения, любые вызовы keys, values и each автоматически упорядочиваются. Так, программа из примера 14.4 создает хэш, ключи которого всегда сортируются без учета регистра символов.
Пример 14.4. sortdemo
#!/usr/bin/perl
# sortdemo - автоматическая сортировка dbm
use strict;
use DB_File;
$DB_BTREE->{' compare'} = sub { my ($key1, $key2) = @_ ; ¦¦\L$keyr cmp "\L$key2" ;
my %hash;
my $filename = '/tmp/sorthash.db';
14.7. Интерпретация текстового файла в виде строковой базы данных 507
tie(%hash, "DB_File", $filename, O_RDWR|O_CREAT, 0666, $DB_BTREE) or die "can't tie $filename: $!";my $i = 0;
for my Sword (qw(Can' t you go camp down by Gibraltar)) { $hash{$word} =
while (my($word, Snumber) = each %hash) {
printf "%-12s %d\n", Sword, Snumber; >
По умолчанию записи баз данных В-деревьев DB_File сортируются по алфавиту. Однако в данном случае мы написали функцию сравнения без учета регистра, поэтому применение each для выборки всех ключей даст следующий результат:
|
by |
6 |
|
camp |
4 |
|
Can't |
1 |
|
down |
5 |
|
Gibraltar |
7 |
|
go |
3 |
|
you |
2 |
tie(%hash, "DB.File", undef, O_RDWR|O_CREAT, 0666, $DB_BTREE) or die "can't tie: $!";
Обеспечивая возможность сравнения для своей базы данных в виде В-дерева, необходимо помнить о двух обстоятельствах. Во-первых, при создании базы необходимо передавать новую функцию сравнения. Во-вторых, вы не сможете изменить порядок записей после создания базы; одна и та же функция сравнения должна использоваться при каждом обращении к базе.
Базы данных BTREE также допускают использование повторяющихся или неполных ключей. За примерами обращайтесь к документации.
> Смотри также---------------------------------------------------------------------------------------------
Рецепт 5.6.
14.7. Интерпретация текстового файла в виде строковой базы данных
Проблема
Требуется организовать работу с текстовым файлом как с массивом строк с привилегиями чтения/записи. Например, это может понадобиться для того, чтобы вы могли легко обновить N-ю строку файла.
508 Глава 14 • Базы данных
РешениеМодуль DB_File позволяет связать текстовый файл с массивом.
use DB_File;
tie(@array, "DB_File", "/tmp/textfile", O_RDWR|O_CREAT, 0666, $DB_RECNO) or die "Cannot open file 'text': $!\en" ;
$array[4] = "a new line"; untie @array;
Комментарий
Обновление текстового файла на месте может оказаться на удивление нетривиальной задачей (см. главу 7 «Доступ к файлам»). Привязка RECNO позволяет удобно работать с файлом как с простым массивом строк — как правило, все полагают, что именно этот вариант является наиболее естественным.
Однако этот способ работы с файлами отличается некоторыми странностями. Прежде всего, нулевой элемент связанного массива соответствует первой строке файла. Еще важнее то, что связанные массивы не обладают такими богатыми возможностями, как связанные хэши. Положение будет исправлено в будущих версиях Perl — в сущности, «заплаты» существуют уже сейчас.
Как видно из приведенного выше примера, интерфейс связанного массива <т раничен. Чтобы расширить его возможности, методы DB_File имитируют <•; i дартные операции с массивами, в настоящее время не реализованные в и 111 > '.• фейс связанных массивов Perl. Сохраните значение, возвращаемое функцией tie, или получите его позднее для связанного хэша функцией tied. Для этого объекта можно вызывать следующие методы:
$X->push(CriMCOK)
Заносит элементы списка в конец массива.
$value = $X->pop
Удаляет и возвращает последний элемент массива.
$X->shift
Удаляет и возвращает первый элемент массива.
$X->unshift(CrmCOK)
Заносит элементы списка в начало массива.
$X->length
Возвращает количество элементов в массиве.
Пример 14.5 показывает, как все эти методы используются на практике. Кроме того, он работает с интерфейсом API так, как рассказано в документации модуля DB_File (большая часть рецепта позаимствована из документации DB_file с согласия Пола Маркесса, автора Perl-порта Berkeley DB; материал использован с его разрешения).
14.7. Интерпретация текстового файла в виде строковой базы данных 509 Пример 14.5. recno_demo
#!/usr/bin/perl -w# recno_demo - применение низкоуровневого API для привязок recno
use strict;
use vars qw(@lines $dbobj $file $i); use DB_File;
$file = "/tmp/textfile";
unlink $file; # На всякий случай
$dbobj = tie(@lines, "DB_File", $file, O_RDWR|O_CREAT, 0666, $DB_RECNO) or die "Cannot open file $file: $!\n";
# Сначала создать текстовый файл.
$lines[O] = "zero";
$lines[1] = "one";
$lines[2] = "two";
$lines[3] = "three";
$lmes[4] = "four";
# Последовательно вывести записи.
# i ¦"•
tt Метод length необходим из-за того, что при использовании
# связанного массива в скалярном контексте
# не возвращается количество элементов в массиве.
print "\nORIGINAL\n"; foreach $i (0 .. $dbobj->length - 1) { print "$i: $lines[$i]\n";
№ Методы push и pop
$a = $dbobj->pop;
$dbobj->push("last");
print "\nThe last record was [$a]\n";
# Методы shift и unshift
$a = $dbobj->shift;
$dbobj->unshift("first");
print "The first record was [$a]\n";
U Использовать API для добавления новой записи после записи 2.
$i = 2;
$dbobj->put($i, "Newbie", RJAFTER);
# и еще одной новой записи после записи 1.
$i = 1;
$dbobj->put($i, "New One", R_IBEFORE);
# Удалить запись 3
продолжение
510 Глава 14 • Базы данных Пример 14.5 (продолжение)
$dbobj->del(3);# Вывести записи в обратном порядке
print "\nREVERSE\n";
for ($i = $dbob]->length - 1; $i >= 0; -- $i) {
print "$i: $lines[$i]\n"; }
# To же самое, но на этот раз с использованием функций API
print "\nREVERSE again\n";
my ($s, $k, $v) = (0, 0, 0); for ($s = $dbobj->seq($k, $v, R_LAST); $s == 0;
$s = $dbobj->seq($k, $v, R_PREV)) {
print "$k: $v\n"
undef $dbobj; untie ©lines;
Результат выглядит так:
ORIGINAL 0: zero 1: one 2: two 3: three 4: four
The last record was [four] The first record was [zero]
|
REVERSE |
|
|
5: |
last |
|
4: |
three |
|
3: |
Newbie |
|
2: |
one |
|
1: |
New One |
|
0: |
first |
|
REVERSE again |
|
|
5: |
last |
|
4: |
three |
|
3: |
Newbie |
|
2: |
one |
|
1: |
New One |
|
0: |
first |
следует использовать либо
foreach $i (0 .. $dbobj->length - 1) { } либо
for ($done_yet = $dbobj->get($k, $v, R_FIRST);
not $done_yet;
$done_yet = $dbobj->get($k, $v, R_NEXT) ) {
# Обработать ключ или значение >
Кроме того, при вызове метода put мы указываем индекс записи с помощью переменной $i вместо того, чтобы передать константу. Дело в том, что put возвращает в этом параметре номер записи вставленной строки, изменяя его значение.
О Смотри также--------------------------------------------------------------------------------------------
Документация по стандартному модулю DB_File.
14.8. Хранение сложных структур данных в DBM-файлах
Проблема
В DBM-файле требуется хранить не скаляры, а что-то иное. Например, вы используете в программе хэш хэшей и хотите сохранить его в DBM-файле, чтобы с ним могли работать другие или чтобы его состояние сохранялось между запусками программы.
Решение
Воспользуйтесь модулем MLDBM от CPAN — он позволяет хранить в хэше более сложные структуры, нежели строки или числа.
use MLDBM 'D8_File';
tie(%HASH, 'MLDBM', [... прочие аргументы DBM]) or die $!;
Комментарий
MLDBM использует модуль Data::Dumper (см. рецепт 11.14) для преобразования структур данных в строки и обратно, что позволяет хранить их в DBM-файлах. Модуль не сохраняет ссылки; вместо них сохраняются данные, на которые эти ссылки указывают:
# %hash - связанный хэш
$hash{"Tom Christiansen"} = [ "book author", 'tchrist@perl.com1 ]; $hash{"Tom Boutell"} = [ "shareware author", 'boutell@boutell.com' ];
# Сравниваемые имена
$tom1 = $hash{$name1}; tl Получить локальный указатель
$tom2 = $hash{$name2}; # И еще один
print "Two Toming: $tom1 $tom2\n";
ARRAY(0x73048)ARRAY(0x73e4o)
Каждый раз, когда MLDBM извлекает структуру данных из файла DBM, строится новая копия данных. Чтобы сравнить данные, полученные из базы данных MLDBM, необходимо сравнить значения полей этой структуры:
if ($tom1->[0] eq $tom2->[0] &&
$tom1->[1] eq $tom2->[1]) {
print "You're having runtime fun with one Tom made two.\n";
} else {
print "No two Toms are ever alike.\n";
}
Этот вариант эффективнее следующего:
if ($hash{$name1}->[0] eq $hash{$name2}->[0] && # НЕЭФФЕКТИВНО
$hash{$name1}->[1] eq $hash{$name2}->[1]) { print "You're having runtime fun with one Tom made two.\n";
} else <
print "No two Toms are ever alike.\n";
}
Каждый раз, когда в программе встречается конструкция $hash{.. .}, происходит обращение к DBM-файлу. Приведенный выше неэффективный код обращается к базе данных четыре раза, тогда как код с временными переменными $tom1 и $tom2 обходится всего двумя обращениями.
Текущие ограничения механизма tie не позволяют сохранять или модифицировать компоненты MLDBM напрямую:
$hash{"Tom Boutell"}->[0] = "Poet Programmer"; # НЕВЕРНО
Любые операции чтения, модификации и присваивания для частей структуры, хранящейся в файле, должны осуществляться через временную переменную:
Sentry = $hash{"Tom Boutell"}; # ВЕРНО
$entry->[0] = "Poet Programmer"; $hash{"Tom Boutell"} = Sentry;
Если MLDBM использует базу данных с ограниченным размером значений (например, SDBM), вы довольно быстро столкнетесь с этими ограничениями. Чтобы выйти из положения, используйте GDBM_File или DB_File, в которых размер ключей или значений не ограничивается. Предпочтение отдается библиотеке DB_File, поскольку она использует нейтральный порядок байтов, что позволяет использовать базу данных в архитектурах как с начальным старшим, так и с начальным младшим байтом.
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулям Data::Dumper, MLDBM и Storable от CPAN; рецепты 11.13; 14.9.
14.9. Устойчивые данные
Проблема
Вы хотите, чтобы значения переменных сохранялись между вызовами программы.
Решение
Воспользуйтесь модулем MLDBM для сохранения значений между вызовами программы:
use MLDBM ' DB_Flle' ;
my ($VARIABLE1,$VARIABLE2);
my $Persistent_Store = '/projects/foo/data';
BEGIN {
my %data;
tie(%data, 'MLDBM', $Persistent_Store)
or die "Can't tie to $Persistent_Store : $!";
$VARIABLE1 = $data{VARIABLE1};
$VARIABLE2 = $data{VARIABLE2};
«...
untie %data; } END {
my %data;
tie (%data, 'MLDBM', $Persistent_Store)
or die "Can't tie to $Persistent_Store : $!";
$data{VARIABLE1} = SVARIABLE1;
$data{VARIABLE2} = $VARIA3LE2;
# . .
untie %data; }
Комментарий
Существенное ограничение MLDBM заключается в том, что структуру нельзя дополнить или изменить по ссылке без присваивания временной переменной. Мы сделаем это в простой программе из примера 14.6, присваивая $array_ref перед вызовом push. Следующая конструкция просто невозможна:
push(@{$db{$user}}, $duration);
Прежде всего, этому воспротивится MLDBM. Кроме того, $db{$user} может отсутствовать в базе (ссылка на массив не создается автоматически, как это делалось бы в том случае, если бы хэш %db не был связан с DBM-файлом). Именно по-
этому мы проверяем exists $db{$user} перед тем, как присваивать $array_ref ис ходное значение. Мы создаем пустой массив в случае, если он не существовал ранее.
Пример 14.6. mldbm-demo
#!/usr/bin/perl -w
# mldbm_demo - применение MLDBM с DB_File
use MLDBM "DB_File";
$db = "/tmp/nldbm-array";
tie %db, 'MLDBM', $db or die "Can't open $db : $!";
while(<DATA>) { chomp;
($user, Sduration) = split(/\s+/, $J; $array_ref = exists $db{$user} ? $db{$user} : []; push(@$array_ref, $duration); $db{$user} = $array_ref;
foreach Suser (sort keys %db) { print "Suser: "; Stotal = 0; foreach Sduration (@{ $db{$user} }) {
print "Sduration ";
Stotal += Sduration;
print "($total)\n";
|
__END__ |
|
|
gnat |
15.3 |
|
tchrist |
2.5 |
|
jules |
22.1 |
|
tchrist |
15.9 |
|
gnat |
8.7 |
use MLDBM qw(DB_File Storable);
D> Смотри также------------------------------------------------------------------------------------------
Документация по модулям Data::Dumper, MLDBM и Storable с CPAN; рецепты 11.13; 14.8.
14.10. Выполнение команд SQL с помощью DBI и DBD
Проблема
Вы хотите направить запрос SQL в систему управления базами данных (например, Oracle, Sybase, mSQL или MySQL) и обработать полученные результаты.
Решение
Воспользуйтесь модулями DBI (DataBase Interface) и DBD (DataBase Driver) от CPAN:
use DBI;
$dbh = D8I->connect( 'DBI:dnver', 'username1, 'auth', { PnntError => 1, RaiseError => 1})
or die "connecting: $DBI::errstr"; $dbh->do(SQL)
or die "doing: ", $dbh->errstr; $sth = DBI->prepare(SOL)
or die "preparing: ", $dbh->errstr; $sth->execute
or die "executing: ", $sth->errstr; while (@row = $sth->fetchrow_array) {
# ... }
$sth->finish; $dbh->disconnect;
Комментарий
DBI является посредником между программой и всеми драйверами, предназначенными для работы с конкретными СУБД. Для большинства операций нужен манипулятор базы данных (в приведенном выше примере — $dbh).OH ассоциируется с конкретной базой данных и драйвером при вызове DBI->connect.
Первый аргумент DBI->connect представляет собой строку, состоящую из трех полей, разделенных двоеточиями. Он определяет источник данных — СУБД, к которой вы подключаетесь. Первое поле всегда содержит символы DBI, а второе — имя драйвера, который вы собираетесь использовать (Oracle, mysql и т. д.). Оставшаяся часть строки передается модулем DBI запрошенному модулю драйвера (например, DBD::mysql) и идентифицирует базу данных.
Второй и третий аргументы выполняют аутентификацию пользователя.
Четвертым, необязательным аргументом является ссылка на хэш с определением атрибутов подключения. Если атрибут PrintError равен true, при каждом неудачном вызове метода DBI будет выдавать предупреждение. Присваивание RaiseError имеет аналогичный смысл, за исключением того, что вместо warn будет использоваться die.
После завершения работы с базой не забудьте отключиться от нее методом disconnect. Если манипулятор базы данных выходит из области действия без предварительного вызова disconnect, модуль DBI выдает предупреждение. Эта мера предосторожности предназначена для тех СУБД, которые должны возвращать память системе и требуют корректного отключения от сервера. Перед отключением манипулятора базы данных манипуляторы команд должны получить неопределенное значение, выйти из области действия или для них должен быть вызван метод finish. Если этого не сделать, вы получите предупреждение следующего вида:
disconnect(DBI::db=HASH(0x9df84)) invalidates 1 active cursor(s) at -e line 1.
Модуль DBI содержит FAQ (perldoc DBI::FAQ) и стандартную документацию (perldoc DBF). Также существует документация для драйверов конкретных СУБД (например, perldoc DBDr.mysql). Прикладной интерфейс DBI не ограничивается простейшим подмножеством, рассмотренным нами; он предоставляет разнообразные возможности выборки результата и взаимодействия со специфическими средствами конкретных СУБД (например, сохраняемыми процедурами). За информацией обращайтесь к документации по модулю драйвера.
Программа из примера 14.7 создает и заполняет таблицу пользователей в MySQL, после чего выполняет в ней поиск. Она использует атрибут RaiseError и потому обходится без проверки возвращаемого значения для каждого метода.
Пример 14.7. dbusers
#!/usr/bin/perl -w
# dbusers - работа с таблицей пользователей в MySQL
use DBI;
use User::pwent;
$dbh = DBI->connect('DBI:mysql:dbname:mysqlserver.domain.com:3306', 'user', 'password', { RaiseError => 1 }) or die "connecting : $DBI::errstr\n";
$dbh->do("CREATE TABLE users (uid INT, login CHAR(8))");
$sql_fmt = "INSERT INTO users VALUES( %d, %s )"; while ($user = getpwent) {
$sql = sprintf($sql_fmt, $user->uid, $dbh->quote($user->name));
$dbh->do($sql):
while ((§row) = $sth->fetchrow) {
print join(", ", map {defined $_?$_: "(null)"} @row), "\n";
$sth->finish;
$dbh->do("OROP TABLE users");
$dbh->disconnect;
> Смотри также---------------------------------------------------------------------------------------------
Документация по DBI и модулям DBD с CPAN, http://www.hermetica.com/ technologia/perl/DBI/index.htmlnhttp://www.perl/com/CPAN/modules/by-category/ 07_Database_Interfaces/.
14.11. Программа: ggh — поиск в глобальном журнале Netscape
Следующая программа выводит содержимое файла Netscape history .db. При вызове ей может передаваться полный URL или (один) шаблон. Если программа вызывается без аргументов, она выводит все содержимое журнала. Если не задан параметр -database, используется файл -/•netscape/history.db.
В каждой выводимой строке указывается URL и время работы. Время преобразуется в формат localtime параметром -localtime (по умолчанию) или в представление gmtime параметром -gmtime или остается в первоначальном формате (параметр -epoch), что может пригодиться для сортировки по дате.
Шаблон задается единственным аргументом, не содержащим : //.
Чтобы вывести данные по одному или нескольким URL, передайте их в качестве аргументов:
% ggh http://www.perl.com/index.html
Вывод сведений о адресах, которые вы помните лишь приблизительно (шаблоном считается единственный аргумент, не содержащий : //):
% ggh perl
Вывод всех адресатов электронной почты:
% ggh mailto:
Для вывода всех посещенных сайтов со списками FAQ используется шаблон Perl с внутренним модификатором /i:
% ggh -regexp '(?i)\bfaq\b'
% ggh -epoch http://www.perl.com/perl/
Если вы предпочитаете формат gmtime, используйте параметр -gmtime:
% ggh -gmtime http://www.perl.com/perl/
Чтобы просмотреть весь файл, не задавайте значения аргументов (вероятно, данные следует перенаправить в утилиту постраничного вывода):
% ggh | less
Чтобы отсортировать выходные данные по дате, укажите флаг -epoch:
% ggh -epoch | sort -rn | less
Для сортировки по времени в формате местного часового пояса используется более сложная командная строка:
% ggh -epoch | sort -rn | perl -ре 's/\d+/localtime $&/e' I less
Сопроводительная документация Netscape утверждает, что в журнале используется формат NDBM. Это не соответствует действительности: на самом деле использован формат Berkeley DB, поэтому вместо NDBM_File (входит в стандартную поставку всех систем, на которых работает Perl) в программе загружается DB_File. Исходный текст программы приведен в примере 14.8.
Пример 14.8. ggh
#!/usr/bin/perl -w
# ggh - поиск данных в журнале netscape
$USAGE = «EO_COMPLAINT;
usage: $0 [-database dbfilename] [-help]
[-epochtime | -localtime | -gmtime]
[ [-regexp] pattern] | href ... ] EO_COMPLAINT
use Getopt::Long;
($opt_database, $opt_epochtime, $opt_localtime,
$opt_gmtime, $opt_regexp, $opt_help,
$pattern, ) = (0) x 7;
usageQ unless GetOptions qw< database=s
regexp=s
epochtime localtime gmtime help
};
if ($opt_help) { print $USAGE; exit; >
usage(" only one of localtime, gmtime, and epochtime allowed") if $opt_localtime + $opt_gmtime + $opt_epochtime > 1;
$pattern = $opt_regexp; } elsif (§ARGV && $ARGV[0] Г m(://)) {
$pattern = shift;
usage("can't mix URLs and explicit patterns") if $pattern && @ARGV;
if (Spattern && !eval { " =" /$pattern/; 1 } ) $@ =" s/ at \w+ line \d+\.//; die "$0: bad pattern $@";
require DB_File; DB_File->import(); # Отложить загрузку до выполнения
$1=1; # Для перенаправления данных
$dotdir = $ENV{HOME} || $ENV{LOGNAME};
$HISTORY = $opt_database || "$dotdir/.netscape/history, db";
die "no netscape history dbase in $HISTORY; $!" unless -e SHISTORY;
die "can't dbmopen $HISTORY: $!" unless dbmopen %hist_db, $HIST0RY, 0666;
# Следующая строка - хак, поскольку программисты С,
# которые работали над этим, путали strlen и strlen+1.
# Так мне сказал jwz :-)
$add_nulls = (ord(substr(each %hist_db, -1)) == 0);
# XXX: Сейчас следовало бы сбросить скалярные ключи, но
# не хочется тратить время на полный перебор,
# необходимый для связанных хэшей.
# Лучше закрыть и открыть заново?
$nulled_href = "";
$byte_order = "V"; # На PC не понимают "N" (сетевой порядок)
if ((3ARGV) {
foreach $href (@ARGV) {
$nulled_href = $href . ($add_nulls && "\0"); unless ($binary_time = $hist_db{$nulled_href}) { warn "$0: No history entry for HREF $href\n"; next; >
$epoch_secs = unpack($byte_order, $binary_time); Sstardate = $opt_epochtime ? $epoch_secs
: $opt_gmtime ? gmtime $epoch_secs : localtime $epoch_secs; print "$stardate $href\n";
продолжение
} else {
while ( ($href, $binary_time) = each %hist_db ) { chop $href if $add_nulls; # gnat reports some binary times are missing $binary_time = pack($byte_order, Q) unless $binary_time; $epoch_secs = unpack($byte_order, $binary_time); Sstardate = $opt_epochtime ? $epoch_secs
: $opt_gmtime ? gmtime $epoch_secs localtime $epoch_secs, print 'Sstardate $href\n' unless Spattern && $href '" /$pattern/o;
sub usage {
print STDERR @_\n" if §_; die SUSAGE;
t> Смотри также Рецепт 6.17.
Пользовательские интерфейсы
Потом разбились Окна — и тогда Пропало все перед глазами...
Э. Дикинсоп,
«Я слышала жужжанье
Мухи — когда я умерла»
Введение
Все, чем мы пользуемся — видеомагнитофоны, компьютеры, телефоны и даже книги, — имеет свой пользовательский интерфейс. Интерфейс есть и у наших программ. Какие аргументы должны передаваться в командной строке? Можно ли перетаскивать мышью файлы? Должны ли мы нажимать Enter после каждого ответа или программа читает входные данные по одному символу?
В этой главе мы не будем обсуждать проектирование пользовательского интерфейса — на эту тему и так написано множество книг. Вместо этого мы сосредоточим внимание на реализации интерфейсов — передаче аргументов в командной строке, посимвольному чтению с клавиатуры, записи в любое место экрана и программированию графического интерфейса.
Простейшим пользовательским интерфейсом обычно считается так называемый консольный интерфейс. Программы с консольным интерфейсом читают целые строки и выводят данные также в виде целых строк. Примером консольного интерфейса являются фильтры (например, grep) и утилиты (например, mail). В этой главе консольные интерфейсы почти не рассматриваются, поскольку им уделено достаточно внимания в остальных частях книги.
Более сложный вариант — так называемый полноэкранный интерфейс. Им обладают такие программы, как elm или lynx. Они читают по одному символу и могут выводить данные в любой позиции экрана. Этот тип интерфейса рассматривается в рецептах 15.4, 15.6, 15.9—15.11.
Последнюю категорию интерфейсов составляют графические пользовательские интерфейсы (GUI, Graphic User Interface). Программы с графическим интерфейсом работают не только с отдельными символами, но и с отдельными пикселями. В графических интерфейсах часто используется метафора окна — программа создает окна, отображаемые на пользовательском устройстве вывода.
Не путайте пользовательский интерфейс программы со средой, в которой она работает. Среда определяет тип запускаемых программ. Скажем, при регистрации на терминале с полноэкранным вводом/выводом вы сможете работать с консольными приложениями, но не с графическими программами. Давайте кратко рассмотрим различные среды.
Некоторые из них позволяют работать лишь с программами, обладающими чисто консольным интерфейсом. Упрощенный интерфейс позволяет объединять их в качестве многократно используемых компонентов больших сценариев; такое объединение открывает чрезвычайно широкие возможности. Консольные программы прекрасно подходят для автоматизации работы, поскольку они не зависят от клавиатуры или экрана. Они используют лишь STDIN и STDOUT, да и то не всегда. Обычно эти программы обладают наилучшей переносимостью, поскольку они ограничиваются базовым вводом/выводом, поддерживаемым практически в любой системе.
Типичный рабочий сеанс, в котором участвует терминал с экраном и клавиатурой, позволяет работать как с консольными, так и полноэкранными интерфейсами. Программа с полноэкранным интерфейсом взаимодействует с драйвером терминала и хорошо знает, как вывести данные в любую позицию экрана. Для автоматизации работы таких программ создается псевдотерминал, с которым взаимодействует программа (см. рецепт 15.13).
Наконец, некоторые оконные системы позволяют выполнять как консольные и полноэкранные, так и графические программы. Например, можно запустить grep (консольная программа) из vi (полноэкранная программа) в окне xterm (графическая программа, работающая в оконной среде). Графические программы автоматизируются труднее всего, если только они не обладают альтернативным интерфейсом на основе вызова удаленных процедур (RPC).
Существуют специальные инструментальные пакеты для программирования в полноэкранных и графических средах. Такие пакеты {curses для полноэкранных программ; Тк — для графических) улучшают переносимость, поскольку программа не зависит от особенностей конкретной системы. Например, программа, написанная с применением curses, работает практически на любом терминале. При этом пользователю не приходится думать о том, какие служебные команды используются при вводе/выводе. Tk-программа будет работать и в UNIX и в Windows — при условии, что в ней не используются специфические функции операционной системы.
Существуют и другие варианты взаимодействия с пользователем, в первую очередь — через Web. Программирование для Web подробно рассматривается в главах 19 и 20, поэтому в этой главе мы не будем задерживаться на этой теме.
15.1. Лексический анализ аргументов
Проблема
Вы хотите, чтобы пользователь могу повлиять на поведение вашей программы, передавая аргументы в командной строке. Например, параметр -v часто управляет степенью детализации вывода.
Решение
Передача односимвольных параметров командной строки обеспечивается стандартным модулем Getopt::Std:
use Getopt::Std;
# -v ARG, -D ARG, -o ARG, присваивает $opt_v, $opt_D, $opt_o
getopt("vDo");
# -v ARG, -D ARG, -o ARG, присваивает $args{v}, $args<D}, $args{o}
getopt("vDo", \%args);
getopts("vDo:"); # -v, -D, -o ARG, присваивает
# $opt_v, $optj), $opt_o
getopts("vDo:", \%args); # -v, -D, -o ARG, присваивает
# sets $args{v}, $args{D}, $args{o}
Или воспользуйтесь модулем Getopt::Long, чтобы работать с именованными аргументами:
use Getopt::Long;
GetOptions( "verbose" => \$verbose, # --verbose "Debug" => \$debug, # --Debug "output=s" => \$output ); # --output=string
Комментарий
Многие классические программы (такие, как Is и rrri) получают односимвольные параметры (также называемые флагами или ключами командной строки) — например, -1 или -г. В командных строках h-lw.rm.-r аргумент является логической величиной: он либо присутствует, либо нет. Иначе дело обстоит в командной строке gcc -о compiled/He source.c, где compiledfile — значение, ассоциированное с параметром -о. Логические параметры можно объединять в любом порядке; например, строка:
% rm -r -f /tmp/testdir эквивалентна следующей:
% rm -rf /tmp/testdir
Модуль Getopt::Std, входящий в стандартную поставку Perl, анализирует эти традиционные типы параметров. Его функция getopt получает одну строку, где каждый символ соответствует некоторому параметру, анализирует аргументы командной строки в массиве @ARGV и для каждого параметра присваивает значение глобальной переменной. Например, значение параметра -D будет храниться в пе-
Модуль Getopt::Std также содержит функцию getopts, которая позволяет указать, является ли параметр логическим или принимает значение. Параметры со значениями (такие, как параметр -о программы gcc) обозначаются двоеточием, как это сделано в следующем фрагменте:
use Getopt::Std; getopts("о:"), if ($opt_o) {
print "Writing output to $opt_o";
Обе функции, getopt и getopts, могут получать второй аргумент — ссылку на хэш. При наличии второго аргумента значения вместо переменных $opt_X сохраняются в $hash{X}:
use Getopt::Std;
%option = (); getopts("Do:", \%option);
if ($option{D}) {
print "Debugging mode enabled.\n";
ft Если параметр -о не задан, направив результаты в '-". П Открытие "-" для записи означает STD0UT $option{o} = "-" unless defined $option{o};
print "Writing output to file $option{o}\n" unless $option{oi eq "-"; open(STDOUT, "> $option{o}")
or die "Can't open $option{o} for output' $!\n";
Некоторые параметры программы могут задаваться целыми словами вместо отдельных символов. Обычно они имеют специальный префикс — двойной дефис:
% gnutar --extract --file latest.tar
Значение параметра -file также может быть задано с помощью знака равенства:
% gnutar --extract —file=latest.tar
Функция GetOptions модуля Getopt::Long анализирует эту категорию параметров. Она получает хэш, ключи которого определяют параметры, а значения представляют собой ссылки на скалярные переменные:
use Getopt::Long;
GetOptions( "extract" => \$extract, "file=s" => \$file );
if (Sextract) {
print "I'm extracting.\n";
die "I wish I had a file" unless defined $file; print "Working on the file $file\n";
Если ключ хэша содержит имя параметра, этот параметр является логическим. Соответствующей переменной присваивается false, если параметр не задан, или 1 в противном случае. Getopt::Long не ограничивается логическими параметрами и значениями Getopt::Std. Возможны следующие описания параметров:
Описание Значение Комментарий
|
option |
Нет |
|
option! |
Нет |
|
option=s |
Да |
|
option:s |
Да |
|
option=i |
Да |
|
option:i |
Да |
|
option=f |
Да |
|
option:f |
Да |
|
> Смотри |
также |
Документация по стандартным модулям getopt::Long и Getopt::Std; примеры ручного анализа аргументов встречаются в рецептах 1.5, 1.17, 6.22, 7.7, 8.19 и 15.12.
Проблема
Требуется узнать, была ли ваша программа запущена в интерактивном режиме или нет. Например, запуск пользователем из командного интерпретатора является интерактивным, а запуск из стоп - нет.
Решение
Воспользуйтесь оператором -t для проверки STOIN и STDOUT:
sub I_am_interactive {
return -t STDIN && -t STDOUT; }
В POSIX-совместимых системах проверяются группы процессов:
use POSIX qw/getpgrp tcgetpgrp/;
sub I_am_interactive {
local *TTY; # local file handle
open(TTY, "/dev/tty") or die "can't open /dev/tty: $!";
my $tpgrp = tcgetpgrp(fileno(TTY));
my $pgrp = getpgrpO;
return ($tpgrp == $pgrp), }
Комментарий
Оператор -t сообщает, соответствует ли файловый манипулятор или файл терминальному устройству (tty); такие устройства являются признаком интерактивного использования. Проверка сообщит лишь о том, была ли ваша программа перенаправлена. Если программа запущена из командного интерпретатора, при перенаправлении STDIN и STDOUT первая версия I_am_mteractive возвращает false. При запуске из сгоп I_am_mteractive также возвращает false.
Второй вариант проверки сообщает, находится ли терминал в монопольном распоряжении программы. Программа, чей ввод и вывод был перенаправлен, все равно при желании может управлять своим терминалом, поэтому POSIX-версия I_am_interactive возвращает true. Профамма, запущенная из сгоп, не имеет собственного терминала, поэтому I_am_interactive возвратит false.
Какой бы вариант I_am_interactive вы ни выбрали, он используется следующим образом:
while (1) {
if (I_am_interactive()) {
print Prompt }
$line = <STDIN>, last unless defined $line,
# Обработать $line
}
Или более наглядно:
sub prompt { print Prompt if I_am_mteractive() } for (prompt() $line = <STDIN>, promptQ) {
# Обработать $line
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю POSIX. Оператор проверки файлов -t описан Bperlop(i).
15.3. Очистка экрана
Проблема
Требуется очистить экран.
Решение
Воспользуйтесь модулем Term::Cap для посылки нужной последовательности символов. Скорость вывода терминала можно определить с помощью модуля
POSIX::Termios (или можно предположить 9600 бит/с). Ошибки, возникающие при работе с POSIX::Termios, перехватываются с помощью eval:
use Term Cap,
$OSPEED = 9600, eval {
require POSIX,
my Stermios = POSIX Termios->new(),
$termios->getattr,
SOSPEED = $termios->getospeed,
Sterminal = Term Cap->Tgetent({OSPEED=>$OSPEED}), $termmal->Tputs( cl , 1, STDOUT),
Или выполните команду clear: system( clear ),
Комментарий
Если вам приходится часто очищать экран, кэшируйте возвращаемое значение Term::Cap или команды clear:
$clear = $terminal->Tputs( cl ), Sclear = clear ,
Это позволит очистить экран сто раз подряд без стократного выполнения clear: print $clear,
О Смотри также--------------------------------------------------------------------------------------------
Man-страницы скаг{\) и termcap(l) (если они есть); документация по стандартному модулю Тегт::Сар; документация по модулю Term::Lib с CPAN.
15.4. Определение размера терминала или окна
Проблема
Требуется определить размер терминала или окна. Например, вы хотите отформатировать текст так, чтобы он не выходил за правую границу экрана.
Решение
Воспользуйтесь функцией loctl (см. рецепт 12.14) или модулем Term::ReadKey с CPAN:
use Term ReadKey,
(Swchar, Shchar, Swpixels, Shpixels) = GetTerminalSizeO,
Функция GetTerminalSize возвращает четыре элемента: ширину и высоту в символах, а также ширину и высоту в пикселях. Если операция не поддерживается для устройства вывода (например, если вывод был направлен в файл), возвращается пустой список.
Следующий фрагмент строит графическое представление lvalues при условии, что среди элементов нет ни одного отрицательного:
use Term::ReadKey;
(Swidth) = GetTerminalSizeO;
die "You must have at least 10 characters" unless Swidth >= 10;
$max = 0;
foreach (©values) {
$max = $_ if $max < $_;
$ratio = ($width-10)/$raax; t* Символов на единицу
foreach (©values) {
printfCP%8.1f %s\n", $_, "¦•¦ x ($ratio*$_));
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулю Term::ReadKey с CPAN; рецепт 12.14.
15.5. Изменение цвета текста
Проблема
Вы хотите выводить на экране символы разных цветов. Например, цвет может использоваться для выделения текущего режима или сообщения об ошибке.
Решение
Воспользуйтесь модулем Term::ANSIColor с CPAN для передачи терминалу последовательностей изменения цвета ANSI:
use Term::ANSIColor;
print color("red"), "Danger, Will Robinson!\n", color("reset");
print "This is just normal text.\n";
print colored("<BLINK>Do you hurt yet?</BLINK>", "blink");
Или воспользуйтесь вспомогательными функциями модуля Term::ANSIColor:
use Term: :ANSIColor qw( '.constants);
print RED, "Danger, Will Robinson!\n", RESET;
Комментарий
Модуль Term::ANSIColor готовит служебные последовательности, которые опознаются некоторыми (хотя далеко не всеми) терминалами. Например, в color-xterm этот рецепт работает. В обычной программе xterm или на терминале vtlOO он работать не будет.
Существуют два варианта использования модуля: либо с экспортированными функциями со1ог($АТРИБУТ) и colored($TEKCT, $АТРИБУТ), либо с вспомогательными функциями (такими, как BOLD, BLUE и RESET).
Атрибут может представлять собой комбинацию цветов и модификаторов. Цвет символов принимает следующие значения: black, red, green, yellow, blue, magenta (черный, красный, зеленый, желтый, синий, малиновый). Цвет фона принимает значения on_black, on_red, on_green, on_yellow, on_blue, on_magenta, on_cyan и onwhite (черный, красный, зеленый, желтый, синий, малиновый, голубой и белый). Допускаются следующие модификаторы: clear, reset, bold, underline, underscore, blink, reverse и concealed (очистка, сброс, жирный, подчеркивание, подчеркивание, мерцание, инверсия и скрытый). Clear и reset являются синонимами (как и underline с underscore). При сбросе восстанавливаются цвета, действовавшие при запуске программы, а при выводе скрытого текста цвет символов совпадает с цветом фона.
Атрибуты могут объединяться:
print color("red on_black"), "venom lack\n"; print color("red on_yellow"), "kill that fellow\n";
print color("green on_cyan blink"), "garish!\n"; print color("reset");
Этот фрагмент можно было записать в виде:
print colored("venom lack\n", "red on_black");
print colored("kill that fellow\n", "red", "on_yellow");
print colored("garish!\n", "green", "on_cyan", "blink"); или:
use Term::ANSIColor qw(constants);
print BLACK, ON_WHITE, "black on white\n";
print WHITE, ON_BLACK, "white on black\n";
print GREEN, ON_CYAN, BLINK, "garish!\n";
print RESET;
где BLACK — функция, экспортированная из Term::ANSIColor.
He забывайте вызвать print RESET или color("reset") в конце программы, если вызов colored не распространяется на весь текст. Если этого не сделать, ваш терминал будет раскрашен весьма экзотическим образом. Сброс даже можно включить в блок END:
END { print color("reset") } чтобы при завершении программы цвета были гарантированно сброшены.
$Term::ANSIColor::EACHLINE = $/;
print colored(«EOF, RED, ON_WHITE, BOLD, BLINK);
This way
each line
has its own
attribute set.
EOF
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулю Term::AnsiColor с CPAN.
15.6. Чтение с клавиатуры
Проблема
Требуется прочитать с клавиатуры один символ. Например, на экран выведено меню с клавишами ускоренного вызова, и вы не хотите, чтобы пользователь нажимал клавишу Enter при выборе команды.
Решение
Воспользуйтесь модулем Term::ReadKey с CPAN, чтобы перевести терминал в режим с break, прочитать символы из STDIN и затем вернуть терминал в обычный режим:
use Term::ReadKey;
ReadMode 'cbreak'; $key = ReadKey(O); ReadMode 'normal':
Комментарий
Модуль Term::ReadKey может переводить терминал в разные режимы, cbreak лишь один из них. В этом режиме каждый символ становится доступным для программы сразу же после ввода (см. пример 15.1). Кроме того, в нем происходит эхо-вывод символов; пример режима без эхо-вывода рассматривается в рецепте 15.10.
Пример 15.1. sascii
й'/usr/bin/perl -w
# sascii - Вывод ASCII-кодов для нажимаемых клавиш
use Term::ReadKey;
ReadMode('cbreak');
print "Press keys to see their ASCII values. Use Ctrl-C to quit \n";
while (1) {
$char = ReadKey(O);
last unless defined $char;
printf(" Decimal: %d\tHex: %x\n", ord($char), ord($char));
ReadMode('normal');
Режим cbreak не мешает драйверу терминала интерпретировать символы конца файла и управления. Если вы хотите, чтобы ваша программа могла прочитать комбинации Ctrl+C (обычно посылает процессу SIGINT) или Ctrl+D (признак конца файла в UNIX), используйте режим raw.
Вызов Read Key с нулевым аргументом означает, что мы хотим выполнить нормальное чтение функцией getc. При отсутствии входных данных программа ожидает их появления. Кроме того, можно передать аргумент -1 (неблокирующее чтение) или положительное число, которое определяет тайм-аут (продолжительность ожидания в целых секундах; дробные значения секунд не допускаются). Неблокирующее чтение и чтение с тайм-аутом возвращает либо undef при отсутствии входных данных, либо строку нулевой длины при достижении конца файла.
Последние версии Term::ReadKey также включают ограниченную поддержку систем, не входящих в семейство UNIX.
t> Смотри также--------------------------------------------------------------------------------------------
Документация по модулю Term::ReadKey с CPAN; рецепты 15.8—15.9. Функции getc и sysread описаны вperlfunc(l).
15.7. Предупреждающие сигналы
Проблема
Требуется выдать предупреждающий сигнал на терминале пользователя.
Решение
Воспользуйтесь символом "\а" для выдачи звукового сигнала:
print "\aWake up!\n";
Другой вариант — воспользуйтесь средством терминала "vb " для выдачи визуального сигнала:
use Term::Cap;
SOSPEED = 9600; eval {
require POSIX;
my $termios = POSIX::Termios->new();
S0SPEED = $termios->getospeed;
Stermmal = Term: .Cap->Tgetent({OSPEED=>$OSPEEO}), $vb = "; eval {
$terminal->Trequire('vb '),
$vb = $terminal->Tputs('vb', 1),
print $vb; # Визуальный сигнал
Комментарий
Служебный символ "\а" — то же самое, что и "\cG", "\007" и "\хО7". Все эти обозначения относятся к символу ASCII BEL, который выдает на терминал противный звонок. Вам не приходилось бывать в переполненном терминальном классе в конце семестра, когда десятки новичков одновременно пытаются перевести Ы в режим ввода? От этой какофонии можно сойти с ума. Чтобы не злить окружающих, можно использовать визуальные сигналы. Идея проста: терминал должен показывать, а не звучать (по крайней мере, не в многолюдных помещениях). Некоторые терминалы вместо звукового сигнала позволяют на короткое время поменять цвет символов с цветом фона, чтобы мерцание привлекло внимание пользователя.
Визуальные сигналы поддерживаются не всеми терминалами, поэтому мы включили их вызов в eval. Если визуальный сигнал не поддерживается, Trequi re инициирует die, при этом переменная $vb останется равной "". В противном случае переменной $vb присваивается служебная последовательность для выдачи сигнала.
Более разумный подход к выдаче сигналов реализован в графических терминальных системах (таких, какх(еггп). Многие из них позволяют включить визуальные сигналы на уровне внешнего приложения, чтобы программа, тупо выводящая chr(7), была менее шумной.
> Смотри также---------------------------------------------------------------------------------------------
Раздел «Quote и Quote-like Operators» в perlop(l); документация по стандартному модулю Term:: Cap.
15.8. Использование termios
Проблема
Вы хотите напрямую работать с характеристиками своего терминала.
Решение
Воспользуйтесь интерфейсом POSIX termios.
Комментарий
Представьте себе богатые возможности команды stty — можно задать все, от служебных символов до управляющих комбинаций и перевода строки. Стандартный модуль POSIX обеспечивает прямой доступ к низкоуровневому терминальному интерфейсу и позволяет реализовать хйг/-подобные возможности в вашей программе.
Программа из примера 15.2 показывает, какие управляющие символы используются вашим терминалом для стирания в предыдущей и текущей позиции курсора (вероятно, это клавиши «забой» и Ctrl+U). Затем она присваивает им исторические значения, # и @>, и предлагает ввести какой-нибудь текст. В конце своей работы программа восстанавливает исходные значения управляющих символов.
Пример 15.2. demo
#'/usr/bin/perl -w
# Демонстрация работы с интерфейсом POSIX termios
use POSIX qw(-termios_h),
$term = POSIX::Termios->new, $term->getattr(fileno(STDIN));
$erase = $term->getcc(VERASE),
Skill = $term->getcc(VKILL),
printf Erase is character %d, %s\n\ $erase, uncontrol(chr($erase)),
pnntf Kill is character %d, %s\n , $кдП, uncontrol(chr($kill)),
$term->setcc(VERASE, ord(¦#')); $tern->setcc(VKILL, ord('@>')); $term->setattr(1, TCSANOW);
print('erase is #, kill is @, type something: ' ),
$line = <STDIN>;
print "You typed: $line";
$term->setcc(VERASE, $erase); $term->setcc(VKILL, Skill); $terrn->setattr(1, TCSANOW);
sub uncontrol {
local $_ = shift,
s/([\200-\377])/spnntf( M-%c",ord($1) & 0177)/eg;
s/([\0-\37\177])/sprintf('"%c",ord($1) " O100)/eg;
return $_; }
Следующий модуль, HotKey, реализует функцию read key на Perl. Он не обладает никакими преимуществами по сравнению с Term::ReadKey, а всего лишь показывает интерфейс termios в действии:
# HotKey pm
package HotKey;
@EXP0RT = qw(cbreak cooked readkey);
use strict;
use POSIX qw(:termios_h);
my ($term, $oterm, $echo, $noecho, $fd_stdin);
$fd_stdin = fileno(STDIN); $term = POSIX:.Termios->new(), $term->getattr($fd_stdin); Soterrn = $term->getlflag(),
$echo = ECHO | ECHOK | ICANON, $noecho = $oterm & ~$echo;
sub cbreak {
$term->setlflag($noecho); # Эхо-вывод не нужен $term->setcc(VTIME, 1), $term->setattr($fd_stdin, TCSANOW);
sub cooked {
$term->setlflag($oterm); $term->setcc(VTIME, 0), $term->setattr($fd_stdin, TCSANOW);
sub readkey { my $key = ''; cbreak(),
sysread(STDIN, $key, 1); cooked(); return $key;
END < cookedO }
> Смотри также
Документация по стандартному модулю POSIX; рецепты 15.6; 15.9.
15.9. Проверка наличия входных данных
Проблема
Требуется узнать, имеются ли необработанные входные данные, не выполняя их фактического чтения.
Решение
Воспользуйтесь модулем Term::ReadKey от CPAN и попытайтесь прочитать символ в неблокирующем режиме, для этого используется аргумент -1:
use Term':ReadKey, ReadMode ('cbreak');
if (defined ($char = ReadKey(-D) ) {
№ Имеется необработанный ввод $char } else {
# Необработанного ввода нет
ReadMode ('normal ); # Восстановить нормальные
# параметры терминала
Комментарий
Аргумент - 1 функции ReadKey означает неблокирующее чтение символа. Если символа нет, ReadKey возвращает undef.
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулю Term::ReadKey с CPAN; рецепт 15.6.
15.10. Ввод пароля
Проблема
Требуется прочитать данные с клавиатуры без эхо-вывода не экране. Например, вы хотите прочитать пароль так, как это делает passwd, то есть без отображения пароля пользователя.
Решение
Воспользуйтесь модулем Term::ReadKey с CPAN, установите режим ввода noecho, после чего воспользуйтесь функцией ReadLine:
use Term ReadKey,
ReadMode noecho'; Spassword = ReadLine 0;
Комментарий
Пример 15.3 показывает, как организовать проверку пароля пользователя. Если в вашей системе используются скрытые пароли, getpwuid вернет зашифрованный пароль лишь привилегированному пользователю. Всем остальным в соответствующем поле базы данных возвращается лишь *, что совершенно бесполезно при проверке пароля.
536 Глава 15 • Пользовательские интерфейсы Пример 15.3. checkuser
#!/usr/bin/perl -w# checkuser - чтение и проверка пароля пользователя
use Term::ReadKey;
print "Enter your password: "; ReadMode 'noecho'; Spassword = ReadLine 0; chomp Spassword; ReadMode 'normal';
print "\n";
($username, Sencrypted) = ( getpwuid $< )[0,1];
if (crypt($password, $encrypted) ne $encrypted) {
die "You are not $username\n"; } else {
print "Welcome, $username\n";
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулю Term::ReadKey с CPAN; man-страницы crypt(3) и passwd(5) вашей системы (если есть). Функции crypt и getpwuid описаны в perlfunc(l).
15.11. Редактирование входных данных
Проблема
Вы хотите, чтобы пользователь мог отредактировать строку перед тем, как отсылать ее вам для чтения.
Решение
Воспользуйтесь стандартной библиотекой Term::ReadLine в сочетании с модулем Term::ReadLine::Gnu с CPAN:
use Term: .'ReadLine;
$term = Term: :Readl_ine->new("APP DESCRIPTION"); $OUT = $term->0UT || *STDOUT;
$term->addhistory($fake_line); $line = $term->readline(PROMPT);
print $0UT "Any program output\n";
Комментарий
Программа из примера 15.4 работает как простейший командный интерпретатор. Она читает строку и передает ее для выполнения. Метод read line читает строку с терминала с поддержкой редактирования и вызова истории команд. Вводимая пользователем строка автоматически включается в историю команд.
Пример 15.4. vbsh
#!/usr/bin/perl -w
# vbsh - очень плохой командный интерпретатор
use strict;
use Term::ReadLine;
use POSIX qw(:sys_wait_h);
my $term = Term: :Readl_ine->new("Simple Shell"); my $0UT = $term->0UT() || *STDOUT; my $cmd;
while (defined ($cmd = $term->readline('$ ') )) { my ©output = '$cmd'; my $exit_value = $? » 8; my $signal_num = $? & 127; my $dumped_core = P & 128; printf $OUT "Program terminated with status %d from signal %d%s\n",
$exit_value, $signal_num,
$dumped_core "> " (core dumped)" : ""; print ©output;
$term->addhistory($seed_line); }
Чтобы занести в историю команд свою строку, воспользуйтесь методом
addhistory:
$term->addhistory($seed_line);
В историю нельзя заносить больше одной строки за раз. Удаление строк из истории команд выполняется методом remove_history, которому передается индекс в списке истории: 0 соответствует первому (самому старому) элементу, 1 — второму и т. д. до самых последних строк.
$term->remove_history($line_number);
Для получения списка истории команд используется метод GetHistory:
©history = $term->GetHistory;
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартным модулям Term::ReadLine и Term::ReadLine::Gnu cCPAN.
Проблема
Вы хотите выделять символы повышенной интенсивностью, перехватывать нажатия специальных клавиш или выводить полноэкранные меню, но не желаете беспокоиться о том, на каком устройстве вывода работает пользователь.
Решение
Воспользуйтесь модулем Curses с CPAN, который использует библиотеку curses(3) вашей системы.
Комментарий
Библиотека curses обеспечивает простое, эффективное и аппаратно-независимое выполнение полноэкранных операций. С его помощью можно писать высокоуровневый код вывода данных на логическом экране по символам или по строкам. Чтобы результаты вывода появились на экране, вызовите функцию refresh. Вывод, сгенерированный библиотекой, описывает только изменения виртуального экрана с момента последнего вызова refresh. Это особенно существенно для медленных подключений.
Работа с модулем Curses демонстрируется программой rep из примера 15.5. Вызовите ее с аргументами, описывающими командную строку запускаемой программы:
% rep ps aux % rep netstat % rep -2 5 lpq
Сценарий rep в цикле вызывает команду и выводит ее данные на экран, обновляя лишь ту часть, которая изменилась с момента предыдущего запуска. Такой вариант наиболее эффективен при малых изменениях между запусками. В правом нижнем углу экрана выводится текущая дата в инвертированном изображении.
По умолчанию rep ожидает 10 секунд перед повторным запуском команды. Чтобы изменить период задержки, передайте нужное количество секунд (допускается дробное число) в качестве аргумента, как это было сделано выше при вызове lpq. Кроме того, нажатие любой клавиши во время ожидания приводит к немедленному выполнению команды.
Пример 15.5. rep
#!/usr/bm/perl -w
# rep - циклическое выполнение команды
use strict;
use Curses;
my Stimeout = 10;
if (@ARGV && $ARGV[O] =~ /~-(\d+\.?\d-)$/) <
Stimeout = $1;
shift,
die "usage: $0 [ -timeout ] end args\n" unless @ARGV;
initscr(); # Инициализировать экран
noecho();
cbreakO;
nodelay(1); # Чтобы функция getch() выполнялась без блокировки
$SIG{INT} = sub { done("0uch!") };
sub done { endwin(); print "@_\n"; exit; }
while (1) {
while ((my $key = getch()) ne ERR) { # Возможен ввод
done("See ya") if $key eq 'q' # нескольких символов
>
ray @data = '(@ARGV) 2>&1'; # Вывод+ошибки
for (my $i =0; $i < $LINES; $i++) {
addstr($i, 0, $data[$i] || ' ' x $COLS);
standout();
addstr($LINES-1, $COLS - 24, scalar localtime);
standend();
move(0,0);
refresh(); # Обновить экран
my (Sin, $out) = ('', '');
vec($in,fileno(STDIN),1) =1; # Искать символ в stdin select($out = $in,undef,undef,$timeout);# Ожидание }
С помощью Curses можно узнать, когда пользователь нажал клавишу со стрелкой или служебную клавишу (например, Ноте или Insert). Обычно это вызывает затруднения, поскольку эти клавиши кодируются несколькими байтами. С Curses все просто:
keypad(1); # Включить режим ввода
$key = getch(); # с цифровой клавиатуры
if ($key eq 'k' 11 # Режим vi
$key eq "\cP" || # Режим emacs
$key eq KEYJJP) # Стрелка
{
# Обработать клавишу }
Другие функции Curses позволяют читать текст в определенной позиции экрана, управлять выделением символов и даже работать в нескольких окнах.
Модуль perlmenu, также хранящийся на CPAN, построен на базе низкоуровневого модуля Curses. Он обеспечивает высокоуровневые операции с меню и экранными формами. Приведем пример экранной формы из поставки perlmenu:
540 Глава 15 • Пользовательские интерфейсы
Template Entry Demonstration
Address Data Example Record #
Name: [______________________________________ ]
Add r: [______________________________________ ]
City: [__________ ] State: [__] Zip: [\\\\\]
Phone: (\\\) \\\-\\\\ Password: [. ]
Enter all information available.
Edit fields with left/right arrow heys or "delete".
Switch fields with "Tab" or up/down arrow keys.
Indicate completion by pressing "Return".
Refresh screen with "Control-L".
Abort this demo here with "Control-X".
Пользователь вводит текст в соответствующих полях. Обычный текст обозначается символами подчеркивания, числовые данные — символами \, а неотобра-жаемые данные — символами ~. Такие обозначения напоминают форматы Perl, за исключением того, что формы предназначены для вывода, а не для ввода данных.
> Смотри также------------------------------------------------------------------------
Man-страница curses(3) вашей системы (если есть); документация по модулям Curses и perlmenu с CPAN; раздел «Formats»perlform(l); рецепт 3.10.
15.13. Управление другой программой с помощью Expect
Проблема
Вы хотите автоматизировать процесс взаимодействия с полноэкранной программой, которая работает с терминалом, не ограничиваясь STDIN и STDOUT.
Решение
Воспользуйтесь модулем Expect с CPAN:
use Expect;
Scommand = Expect->spawn("program to run") or die "Couldn't start program: $!\n";
# Запретить вывод программы в STDOUT
$command->log_stdout(0);
# 10 секунд подождать появления "Password:"
unless ($command->expect(10, "Password")) {
# Тайм-аут
# 20 секунд подождать вывода текста, совпадающего с /[ll_]ogin: ?/ unless ($command->expect(20, -re => '[lL]ogin: ?')) { # Таймаут
# Бесконечно долго ждать появления "invalid" unless ($command->expect(undef, "invalid")) <
# Произошла ошибка; вероятно, работа программы нарушена
# Послать программе "Hello, world" и перевод строки
print $command "Hello, world\n";
# Если программа завершается сама, предоставить ей такую возможность
$command->soft_close();
# Если программа должна быть закрыта извне, завершить ее
$command->hard_close();
Комментарий
Для работы модуля Expect необходимы два других модуля с CPAN: IO::Pty и IO:Stty. Expect создает псевдотерминал для взаимодействия с программами, которые непременно должны общаться с драйвером терминального устройства. Такая возможность часто используется для изменения пароля в программе passwd. К числу других программ, для которых также необходим настоящий терминал, принадлежат telnet (модуль Net::Telnet из рецепта 18.6 более функционален и обладает улучшенной переносимостью) и ftp.
Запустите нужную программу с помощью Expect->spawn, передайте ей имя программы и аргументы — либо в виде одной строки, либо в виде списка. Expect запускает программу и возвращает либо представляющий ее объект, либо undef, если запустить программу не удалось.
Для ожидания вывода программой конкретной строки применяется метод expect. Его первый аргумент равен либо числу секунд, в течение которых ожидается вывод строки, либо undef для бесконечного ожидания. Ожидаемая строка является вторым аргументом expect. Чтобы определить ее с помощью регулярного выражения, передайте в качестве второго аргумента строку "-re", а третьего — строку с шаблоном. Затем можно передать другие строки или шаблоны:
$which = $command->expect(30, "invalid", "succes", "error", "boom"); if ($which) {
# Найдена одна из указанных строк }
В скалярном контексте expect возвращает номер аргумента, для которого произошло совпадение. В предыдущем примере expect вернет 1 при выдаче программой строки "invalid", 2 - при выводе "succes" и т. д. Если ни одна строка или шаблон не совпали, expect возвращает false.
Передача данных программе, находящейся под управлением Expect, сводится к простейшему вызову print. Единственная трудность состоит в том, что терминалы, устройства и сокеты отличаются по тем последовательностям, которые они передают и принимают в качестве разделителя строк, — мы покинули убежище стандартной библиотеки ввода/вывода С, поэтому автоматическое преобразование в "\гГ не происходит. Рекомендуем начать с ' \г"; если не получится, попробуйте '\п и "\г\п".
После завершения работы с запущенной программой у вас есть три возможности. Во-первых, можно продолжить работу с главной программой; вероятно, запущенная программа будет принудительно завершена по завершении главной программы. Однако в этом случае плодятся лишние процессы. Во-вторых, если запущенная программа должна нормально завершиться после вывода всех данных или по некоторому внешнему условию (как, например, telnet при выходе из удаленного командного интерпретатора), вызовите метод soft_close. Если запущенная программа будет работать бесконечно (например, tail -/), вызовите метод hard_close; он уничтожает запущенный процесс.
> Смотри также-------------------------------------------------------------------------
Документация по модулям Expect, IO:Pty и IO:Stty от CPAN.
15.14. Создание меню с помощью Тк
Проблема
Требуется создать окно, в верхней части которого находится меню.
Решение
Воспользуйтесь элементами Tk Menubutton и Frame:
use Tk,
$main = MainWmdow->new(),
9 Создать для меню горизонтальную область
# в верхней части окна.
Smenubar = $main->Frame(-relief => ' raised1,
-borderwidth => 2)
->pack (-anchor => "nw",
-fill => 'x"),
# Создать кнопку с надписью "File для вызова меню.
$file_menu = $menubar->Menubutton(-text => "File",
-underline => 1) ->pack (-side => "left" );
# Создать команды меню "File"
$file_menu->command(-label => "Print',
-command => \&Print);
To же самое можно сделать намного проще, если воспользоваться сокращенной записью -menuitems:
$file_menu = $menubar->Menubutton(-text => 'File",
-underlined 1, -menuitems=> [
[ Button => "Print",-command => \&Print ], [ Button => "Save",-command => \&Save ] ]) ->pack(-side => "left");
Комментарий
Меню приложения можно рассматривать как совокупность четырех компонентов: области (Frame), кнопок меню (Menubutton), меню (Menus) и команд меню (Menu Entries). Область представляет собой горизонтальную полосу в верхней части окна, в котором находится меню. Внутри области находится набор кнопок меню, открывающих различные меню: File, Edit, Format, Buffers и т. д. Когда пользователь щелкает на кнопке меню, на экране появляется соответствующее меню — вертикальный список команд.
В меню могут включаться разделители — горизонтальные линии, отделяющие один набор команд от другого.
С командами (например, Print в меню File) ассоциируются фрагменты кода. При выборе команды меню вызывается соответствующая функция. Обычно это делается так:
$file_menu->command(-label => "Quit Immediately", -command => sub { exit } ),
С разделителями действия не связываются:
$file_menu->separator();
Команда-флажок может находиться в установленном (on) или сброшенном (off) состоянии, и с ней ассоциируется некоторая переменная. Если переменная находится в установленном состоянии, рядом с текстом команды-флажка стоит специальная пометка (маркер). Если переменная сброшена, маркер отсутствует. При выборе команды-флажка переменная переходит в прртивоположное состояние.
$options_menu->checkbutton(-label => "Create Debugging File",
-variable => \$debug,
-onvalue => 1,
-offvalue => 0);
Группа команд-переключателей ассоциируется с одной переменной. В любой момент времени установленной может быть лишь одна команда-переключатель,
$debugjnenu->radiobutton(-label => "Level 1",
-variable => \$log_level, -value => 1);
$debug_menu->radiobutton(-label => "Level 2",
-variable => \$log_level, -value => 2);
$debug_menu->radiobutton(-label => "Level 3",
-variable => \$log_level, -value => 3);
Вложенные меню создаются с помощью каскадных команд. Например, в Netscape Navigator кнопка меню File содержит каскадную команду New, которая открывает подменю с несколькими вариантами. Создать каскадную команду сложнее, чем любую другую: вы должны создать каскадную команду, получить ассоциированное с ней новое меню и создать команды в этом меню.
# Шаг 1: создать каскадную команду меню
$format_menu->cascade (-label => "Font");
# Шаг 2: получить только что созданное меню
$font_menu = $format_menu->cget("-menu");
# Шаг 3: заполнить это меню
$font_menu->radiobutton (-label => "Courier",
-variable => \$font_name,
-value => "courier");
$fontjnenu->radiobutton (-label => "Times Roman",
-variable => \$font_name,
-value => "times");
Отсоединяемый разделитель позволяет перемещать меню, в котором он находится. По умолчанию все кнопки меню и каскадные команды открывают меню, в верхней части которого находится отсоединяемый разделитель. Чтобы создать меню без него, воспользуйтесь параметром -tearoff:
$format_menu = $menubar->Menubutton(-text => "Format",
-underline => 1
-tearoff => 0)
->pack;
$font_menu = $format_menu->cascade(-label => "Font",
-tearoff => 0);
Параметр -menuitems метода Menubutton представляет собой сокращенную форму для создания команд меню. В нем передается ссылка на массив с описаниями команд Menubutton. В свою очередь, каждая команда описывается анонимным мае-
сивом. Первые два элемента массива команды определяют тип кнопки ("command", "radiobutton", "checkbutton", "cascade" или "tearoff") и название меню.
my $f = $menubar->Menubutton(-text => "File", -underline => 0,
-menuitems => t
[Button => 'Copy', -command => \&edit_copy ], [Button => 'Cut', -command => \&edit_cut ], [Button => 'Paste', -command => \&edit_paste ], [Button => 'Delete', -command => \&edit_delete ], [Separator => ''], [Cascade => 'Object .,.', -tearoff => 0,
-menuitems => [
[ Button => "Circle", -command => \&edit_circle ], [ Button => "Square", -command => \&edit_square ], [ Button => "Point", -command => \&edit_point ] ] ], ])->grid(-row => 0, -column => 0, -sticky => 'w');
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулю Tk с CPAN.
15.15. Создание диалоговых окон с помощью Тк
Проблема
Требуется создать диалоговое окно, то есть новое окно верхнего уровня с кнопками для его закрытия. Диалоговое окно также может содержать другие элементы -например, надписи и текстовые поля для ввода информации. Например, в диалоговом окне можно ввести регистрационные данные и закрыть его после передачи сведений или в том случае, если пользователь не захочет регистрироваться.
Решение
В простых случаях воспользуйтесь элементом Tk::DialogBox:
use Tk-:DialogBox;
Sdialog = $main->DialogBox( -title => "Register This Program",
-buttons => [ "Register", "Cancel" ] );
U Добавьте элементы в диалоговое окно методом $dialog->Add()
# Позднее, когда понадобится отобразить диалоговое окно Sbutton = $dialog->Show(); if (Sbutton eq "Register") {
# ... } elsif (Sbutton eq "Cancel") {
} else {
# Такого быть не должно
Комментарий
Диалоговое окно состоит из набора кнопок (в нижней части) и произвольных элементов (в верхней части). Вызов Show выводит диалоговое окно на экран и возвращает кнопку, выбранную пользователем.
Пример 15.6 содержит полную программу, демонстрирующую принципы работы с диалоговыми окнами.
Пример 15.6. tksample3
#!/usr/bin/perl -w
# tksample3 - работа с диалоговыми окнами
use Tk;
use Tk::DialogBox;
$main = MainWindow->new();
Sdialog = $main->DialogBox( -title => "Register",
-buttons => [ "Register", "Cancel" ],
# В верхней части окна пользователь вводит имя, при этом
# надпись (Label) действует как подсказка.
$dialog->add("Label", -text => "Name")->pack(); Sentry = $dialog->add("Entry", -width => 35)->pack();
# Диалоговое окно вызывается кнопкой
$main->Button( -text => "Click Here For Registration Form",
-command => \®ister) ->pack(-side => "left");
$main->Button( -text => "Quit",
-command => sub { exit > ) ->pack(-side => "left");
MainLoop;
#
# register
#
# Вызывает диалоговое окно регистрации.
#
sub register { my $button; my $done = 0;
do {
# Отобразит диалоговое окно.
Sbutton = $dialog->Show;
# Действовать в зависимости от того, какая кнопка была нажата,
if (Sbutton eq "Register") {
my $name = $entry->get;
if (defined($name) && length($name)) { print "Welcome to the fold, $name\n"; $done = 1; > else {
print "You didn't give me your name!\n"; } } else {
print "Sorry you decided not to register.\n"; $done = 1; }
} until $done; }
В верхней части диалогового окна расположены два элемента: надпись и текстовое поле. Для ввода дополнительной информации понадобятся другие надписи и текстовые поля.
Диалоговые окна часто применяются для вывода предупреждений или сообщений об ошибках. Пример 15.7 показывает, как вывести в диалоговом окне результаты вызова функции warn.
Пример 15.7. tksample4
#' /usr/bm/perl -w
# tksample4 - диалоговые окна для предупреждений
use Tk;
use Tk::DialogBox;
my $main;
tf Создать обработчик предупреждений, который отображает
# предупреждение в диалоговом окне Tk
BEGIN {
$SIG{ WARN } = sub {
if (defined $main) {
my $dialog = $main->DialogBox( -title => "Warning",
-buttons => [ "Acknowledge" ]);
$dialog->add("Label", -text => $_[0])->pack;
$dialog->Show; } else {
print STDOUT join("\n", @_), "n";
}
продолжение &
}, >
й Команды вашей программы $main = MainWindow->new();
$main->Button( -text => 'Make A Warning",
-command => \&make_warnmg) ->pack(-side => "left"); $mam->Button( -text => "Quit',
-command => sub { exit } ) ->pack(-side => "left");
MamLoop;
# Фиктивная подпрограмма для выдачи предупреждения
sub make_warmng {
my $a;
my $b = 2 * $a; }
> Смотри также---------------------------------------------------------------------------------------------
Страница руководства Tk::DialogBox в документации по модулю Тк с CPAN; страница руководства тепи(п) (если она есть).
15.16. Обработка событий масштабирования в Тк
Проблема
Вы написали программу на базе Тк, но при изменении размеров окна пользователем нарушается порядок элементов.
Решение
Перехватывая событие Configure, можно запретить пользователю изменять размеры окна:
use Tk;
$main = MainWindow->new();
$main->bind('<Configure>' => sub { $xe = $main->XEvent; $mam->maxsize($xe->w, $xe->h), $main->minsize($xe->w, $xe->h);
Кроме того, можно определить особенности масштабирования элементов при изменении размеров контейнера с помощью метода pack:
$widget->pack( -fill => "both", -expand => 1 ), $widget->pack( -fill => "x', -expand => 1 );
Комментарий
По умолчанию упакованные элементы изменяют размеры вместе с контейнером — они не масштабируют себя или свое содержимое в соответствии с новым размером. В результате между элементами возникают пустые места, а их содержимое обрезается или искажается.
Первое решение — вообще запретить изменение размеров. Мы перехватываем событие <Conf igure>, которое возникает при изменении размера или положения элемента, и регистрируем косвенно-вызываемую функцию (callback) для восстановления прежнего размера окна. Именно так обеспечивается фиксированный размер окон с сообщениями об ошибках.
Иногда запрещать изменение размеров окна нежелательно; в этом случае необходимо определить, как каждый элемент должен реагировать на изменения. Для этого используются аргументы метода pack: -fill управляет той областью, внутри которой должен находиться элемент, a -expand говорит о том, должен ли элемент изменять свой размер для заполнения доступного места. Параметр -expand принимает логические значения, true или false. Строковый параметр -fill обозначает оси, по которым может изменяться размер элемента: "х", "у", "both" или "попе".
Для правильной работы необходимы оба параметра: -expand без -fill не узнает, в какой области должен увеличиваться элемент, -fill без -expand захватит область нужного размера, но сохранит прежние размеры.
Разные части вашего приложения ведут себя по-разному. Например, главная область Web-броузера при изменении размера окна, вероятно, должна изменить свои размеры в обоих направлениях. Метод pack для такого элемента выглядит так:
$mamarea->pack( -fill => 'both', -expand => 1);
Однако меню, расположенное над главной областью, может расшириться по горизонтали, но не по вертикали:
$menubar->pack( -fill => "x' , -expand => 1 );
С изменением размеров связана и другая задача — закрепление элементов в определенной точке контейнера. Например, полоса меню закрепляется в левом верхнем углу контейнера следующим образом:
$menubar->pack (-fill => "х",
-expand => 1, -anchor => "nw" );
Теперь при изменении размеров окна меню останется на своем месте и не будет выровнено по центру пустой области.
> Смотри также---------------------------------------------------------------------------------------------
Страницы руководства pack(n), XEvent(3) и XConfigureEuent(3) (если есть).
Проблема
Вы написали программу для Windows-версии Perl и Тк, однако при каждом запуске программы открывается окно DOS-сеанса.
Решение
Запускайте программу из другого сценария Perl. В примере 15.8 содержится пример загрузчика, который запускает программу realprogram без окна DOS.
Пример 15.8. loader
#!/usr/bin/perl -w
# loader - запуск сценариев Perl без раздражающего окна DOS
use strict;
use Win32;
use Win32::Process;
# Создать объект процесса.
Win32- -Process: :Create($Wm32: .'Process: :Create: :ProcessOb],
'C'/perl5/bin/perl.exe', # Местонахождение Perl
'perl realprogram', #
О, # Не наследовать
DETACHED_PROCESS, #
" ") or # Текущий каталог
die pnnt_error();
sub print_error() {
return Win32: :FormatMessage( Win32: :Getl_astError() ); }
Комментарий
Программа проще, чем кажется. Окно DOS появляется потому, что интерпретатор Perl был откомпилирован как консольное приложение. Для чтения из STDIN и записи в STDOUT ему нужно окно DOS. Это нормально в приложениях, работающих в режиме командной строки, но если все общение с пользователем организовано с помощью Тк, то окно DOS не понадобится.
Загрузчик использует модуль Win32::Process для запуска программы в качестве нового процесса. Этот процесс отделяется от текущего, поэтому при завершении загрузчика окно DOS пропадет вместе с ним. Ваша программа будет прекрасно работать, не отягощенная пережитками прошлого.
Если произойдет какая-нибудь беда и программа не запустится, загрузчик умрет с выдачей сообщения об ошибке Windows.
Смотри также
Документация по модулю Win32::Process, входящая в поставки Perl для систем Microsoft Windows.
15.18. Программа: tcapdemo
Описание
Следующая программа очищает экран и рисует на нем до тех пор, пока не будет прервана. Она показывает, как использовать модуль Term::Cap для очистки экрана, перемещения курсора и записи в любую позицию экрана. В ней также используется рецепт 16.6.
Пример 15.9. tcapdemo
#! /usr/bin/perl -w
# tcapdemo - прямое позиционирование курсора
use POSIX; use Term':Cap;
# Инициализация Term:'Cap.
# Рисование линий на экране.
finishQ, # Последующая очистка.
exit();
# Две вспомогательные функции Смысл clear_screen очевиден, а
# clear_end очищает до конца экрана.
sub clear_screen { $tcap->Tputs('сГ, 1, «STDOUT) } sub clear_end { $tcap->Tputs('cd', 1, «STDOUT) }
# Переместить курсор в конкретную позицию,
sub gotoxy {
my($x, $y) = @_;
$tcap->Tgoto('cm', $x, $y, «STOOUT);
# Определить скорость терминала через модуль POSIX и использовать
# для инициализации Term::Cap.
sub init {
$| = 1;
Sdelay = (shift() || 0) * 0.005;
my $termios = POSIX:,Termios->new();
$termios->getattr;
my Sospeed = $termios->getospeed;
$tcap = Term--Cap->Tgetent ({ TERM => undef, OSPEED => Sospeed });
$tcap->Trequire(qw(cl cm cd));
продолжение
# Рисовать линии на экране, пока пользователь й не нажмет Ctrl-С sub zip {
clear_screen(),
(Smaxrow, Smaxcol) = ($tcap->{_li} - 1, $tcap->{_co} - 1),
@chars = qw(* - / | \ _ ),
sub circle { push(@chars shift @chars), }
Smterrupted = 0,
$SIG{INT} = sub { ++$mterrupted },
$col = $row = 0,
($row_sign, $col_sign) = (1 1),
do {
gotoxy($col $row)
print $chars[0]
select(undef, undef, undef Sdelay)
$row += $row_sign, $col += $col_sign,
if ($row == $maxrow) { $row_sign = -1 circle } elsif ($row == 0 ) { $row_sign = +1, circle, }
if ($col == Smaxcol) { $col_sign = -1 circle, } elsif ($col == 0 ) { $col_sign = +1 circle }
} until $mterrupted,
# Очистить экран sub finish {
gotoxy(0, Smaxrow),
clear_end(),
> Смотри также
Документация по стандартному модулю Term::Cap; termcap(5) (если есть).
15.19. Программа: tkshufflepod
Эта короткая программа с помощью Тк выводит список всех заголовков =head1 в
файле и позволяет изменить порядок их следования перетаскиванием. Клавиша
s сохраняет изменения, a q завершает программу. Двойной щелчок на элемен-
те списка выводит его содержимое в элементе Pod. Текст раздела записывается во временный файл, находящийся в каталоге /tmp; файл удаляется при уничтожении элемента Pod.
При запуске программе передается имя просматриваемого pod-файла:
% tkshufflepod chap15 pod
Мы часто использовали эту программу при работе над книгой. Исходный текст программы приведен в примере 15.10.
Пример 15.10. tkshufflepod
#'/usr/bin/perl -w
# tkshufflepod - изменение порядка разделов =head1 в pod-файле
use Tk use strict,
# declare variables
my Spodfile, # Имя открываемого файла
my $m, # Главное окно
my $1, # Элемент Listbox
my (Sup, $down) # Перемещаемые позиции
my ©sections, # Список разделов pod
my $all_pod ft Текст pod-файла (используется при чтении)
# Прочитать pod-файл в память и разбить его на разделы
Spodfile = shift || - ,
undef $/
open(F, < Spodfile )
or die Can t open Spodfile $'\n $all_pod = <F>, close(F) ©sections = split(/C==head1)/, $all_pod),
# Превратить ©sections в массив анонимных массивов Первый элемент
# каждого массива содержит исходный текст сообщения а второй -
# текст следующий за =head1 (заголовок раздела)
foreach (©sections) { /( *)/, $_ = [ $_, $1 ]
0 Запустить Tk и вывести список разделов
$m = MainWindow->new(),
$1 = $m->Listbox( -width => 60)->pack( -expand => 1, -fill => both ),
продолжение ¦&
554 Глава 15 • Пользовательские интерфейсы Пример 15.10 (продолжение)
foreach my $section (©sections) { $l->insert("end", $section->[1]);# Разрешить перетаскивание для элемента Listbox.
$l->bind( '<Any-Button>' => \&down );
$l->bind( '<Any-ButtonRelease>' => \&up );
U Разрешить просмотр при двойном щелчке $l->bind( '<Double-Button>' => \&view );
# 'q' завершает программу, a 's' сохраняет изменения.
$m->bmd( '<q>' => sub { exit } );
$m->bind( '<s>' => \&save );
MainLoop;
# down(widget): вызывается, когда пользователь щелкает в Listbox
sub down {
my $self = shift;
$down = $self->curselection;;
tt up(widget): вызывается, когда пользователь отпускает # кнопку мыши в Listbox.
sub up {
my $self = shift; my $elt;
Sup = $self->curselection;, return if $down == Sup;
# change selection list $elt = $sections[$down]; splice(@sections, $down, 1); splicefgsections, Sup, 0, Selt); $self->delete($down); $self->insert($up, $sections[$up]->[1]);
# save(widget): сохранение списка разделов,
sub save {
my $self = shift;
open(F, "> $podfile")
or die "Can't open $podfile for writing: S1"; print F map { $_->[0] } ©sections; close F;
exit;
# view(widget): вывод раздела. Использует элемент Pod.
sub view {
my $self = shift;
my $temporary = "/tmp/$$-section.pod";
my $popup;
open(F, "> Stemporary")
or warn ("Can't open Stemporary : $!\n"), return; print F $sections[$down]->[0]; close(F); Spopup = $m->Pod('-file' => Stemporary);
$popup->bind('<Destroy>' => sub { unlink Stemporary } );
|
 |
Управление процессами
и межпроцессные
взаимодействия
Это задета как раз на три трубки.
Я прошу вас минут пятьдесят
не разговаривать со мной.
Шерлок Холмс, «Союз рыжих»
Введение
Многие из нас относятся к Perl по-своему, но большинство считает его чем-то вроде «клея», объединяющего разнородные компоненты. Эта глава посвящена командам и отдельным процессам — их созданию, взаимодействию и завершению. Итак, речь пойдет о системном программировании.
В области системного программирования на Perl, как обычно, все простое упрощается, а все сложное становится доступным. Если вы хотите работать на высоком уровне, Perl с радостью вам поможет. Если вы собираетесь закатать рукава и заняться низкоуровневым программированием, уподобившись хакерам С, — что ж, возможно и это.
Perl позволяет очень близко подобраться к системе, но при этом могут возникнуть некоторые проблемы переносимости. Из всей книги эта глава в наибольшей степени ориентирована на UNIX. Изложенный материал чрезвычайно полезен для тех, кто работает в UNIX-системах, и в меньшей степени — для всех остальных. Рассматриваемые в ней возможности не являются универсальными, как, например, строки, числа или базовая арифметика. Большинство базовых операций более или менее одинаково работает повсюду. Но если вы не работаете в системе семейства UNIX или другой POSIX-совместимой системе, многие интересные возможности у вас будут работать иначе (или не будут работать вообще). В сомнительных ситуациях обращайтесь к документации, прилагаемой к вашей версии Perl.
Создание процессов
В этой главе рассматриваются порожденные процессы. Иногда вы просто выполняете автономную команду (с помощью system) и оставляете созданный процесс на произвол судьбы. В других случаях приходится сохранять тесную связь с созданным процессом, скармливать ему тщательно отфильтрованные данные или уп-
равлять его потоком вывода ('...' и конвейерные вызовы open). Наконец, даже без запуска нового процесса вызов exec позволяет заменить текущую программу чем-то совершенно новым.
Сначала мы рассмотрим самые переносимые и распространенные операции управления процессами: '...', system, open и операции с хэшем %SI6. Здесь нет ничего сложного, но мы не остановимся на этом и покажем, что делать, когда простые решения не подходят.
Допустим, вы хотите прервать свою программу в тот момент, когда она запустила другую программу. Или вам захотелось отделить стандартный поток ошибок порожденного процесса от его стандартного вывода. Или вы собираетесь одновременно управлять и как вводом, так и выводом программы. Или вы решили воспользоваться преимуществами многозадачности и разбить свою программу на несколько одновременно работающих процессов, взаимодействующих друг с другом.
В подобных ситуациях приходится обращаться к системным функциям: pipe, fork и exec. Функция pipe создает два взаимосвязанных манипулятора, записывающий и читающий; при этом все данные, записываемые в первый, могут быть прочитаны из первого. Функция fork является основой многозадачности, но, к сожалению, она не поддерживается некоторыми системами, не входящими в семейство UNIX. Функция создает процесс-дубликат, который практически во всех отношениях идентичен своему родителю, включая значения переменных и открытые файлы. Самые заметные изменения — идентификатор процесса и идентификатор родительского процесса. Новые программы запускаются функцией fork, после чего функция exec заменяет программу порожденного процесса чем-то другим. Функции fork и exec не всегда используются вместе, поэтому наличие отдельных примитивов оказывается более выразительным и мощным по сравнению с ситуацией, когда ваши возможности ограничиваются выполнением system. На практике fork по отдельности используется чаще, чем с exec.
При уничтожении порожденного процесса его память возвращается операционной системе, но соответствующий элемент таблицы процессов не освобождается. Благодаря этому родитель может проверить статус завершения всех порожденных процессов. Процессы, которые умерли, но не были удалены из таблицы процессов, называются зомби; их следует своевременно удалять, чтобы они не заполнили всю таблицу процессов. ^Оператор '...', а также функции system и open автоматически следят за этим и работают в большинстве систем, не входящих в семейство UNIX. При выходе за рамки этих простых переносимых функций и запуске программ с помощью низкоуровневых примитивов возникают дополнительные хлопоты. Кроме того, не стоит забывать и о сигналах.
Сигналы
Ваш процесс узнает о смерти созданного им порожденного процесса с помощью сигнала. Сигналы представляют собой нечто вроде оповещений, доставляемых операционной системой. Они сообщают о произошедших ошибках (когда ядро говорит: «Не трогай эту область памяти!») и событиях (смерть порожденного процесса, тайм-аут процесса, прерывание по Ctrl+C). При ручном запуске процесса обычно указывается подпрограмма, которая должна вызываться при завершении потомка.
558 Глава 16 • Управление процессами и межпроцессные взаимодействия
Каждый процесс имеет стандартные обработчики для всех возможных сигналов. Вы можете установить свой собственный обработчик или изменить отношение программы к большинству сигналов. Не изменяются только SIGKILL и SIGTOP — все остальные сигналы можно игнорировать, перехватывать и блокировать.Приведем краткую сводку важнейших сигналов.
SIGINT
Обычно возникает при нажатии Ctrl+C. Требует, чтобы процесс завершил свою работу. Простые программы (например, фильтры) обычно просто умирают, но более сложные программы — командные интерпретаторы, редакторы и программы FTP — обычно используют SIGINT для прерывания затянувшихся операций.
SIGQUIT
Обычно генерируется терминалом, как правило, при нажатии Ctrl+\. По умолчанию выводит в файл содержимое памяти.
SIGTERM
Посылается командой kill при отсутствии явно заданного имени сигнала. Может рассматриваться как вежливая просьба умереть, адресованная процессу.
SIGUSR1 и SIGUSR2
Никогда не вызываются системными событиями, поэтому пользовательские приложения могут смело использовать их для собственных целей.
SIGPIPE
Посылается ядром, когда ваш процесс пытается записать в канал (pipe) или со-кет, а процесс на другом конце канала/сокета отсоединился (обычно потому, что он перестал существовать).
SIGALRM
Посылается при истечении промежутка времени, установленного функцией alarm (см. рецепт 16.21).
SIGHUP
Посылается процессу при разрыве связи (hang-up) на управляющем терминале (например, при потере несущей модемом), но также часто означает, что программа должна перезапуститься или заново прочитать свою конфигурацию.
SIGCHLD
Вероятно, самый важный сигнал во всем низкоуровневом системном программировании. Система посылает процессу сигнал SIGSHLD в том случае, если один из его порожденных процессов перестает выполняться — или, что более вероятно, при его завершении. Дополнительные сведения о SIGCHLD приведены в рецепте 16.19.
Имена сигналов существуют лишь для удобства программистов. С каждым сигналом связано определенное число, используемое операционной системой вместо имени. Хотя мы говорим о сигнале SIGCHLD, операционная система опозна-
ет его по номеру — например, 20 (в зависимости от операционной системы). Perl преобразует номера сигналов в имена, поэтому вы можете работать с именами сигналов.
Обработка сигналов рассматривается в рецептах 16.7, 16.15, 16.18, 16.20 и 16.21.
16.1. Получение вывода от программы
Проблема
Требуется запустить программу и сохранить ее вывод в переменной.
Решение
Воспользуйтесь либо оператором ... ' :
$output = 'ПРОГРАММА АРГУМЕНТЫ ; # Сохранение данных в одной
й многострочной переменной. §output = 'ПРОГРАММА АРГУМЕНТЫ ; # Сохранение данных в массиве,
# по одной строке на элемент
либо решением из рецепта 16.4:
open(README, ' ПРОГРАММА АРГУМЕНТЫ Г) or die 'Can't run program. $>\n"; while(<README>) { $output .= $_; } close(README);
Комментарий
Оператор '. . . ' является удобным средством для запуска других программ и получения их выходных данных. Возврат из него происходит лишь после завершения вызванной программы. Для получения вывода Perl предпринимает некоторые дополнительные усилия, поэтому было бы неэффективно использовать '. , ' и игнорировать возвращаемое значение:
'fsck -у /dev/rsd1a , # ОТВРАТИТЕЛЬНО
И функция open, и оператор ' .. ' обращаются к командному интерпретатору для выполнения команд. Из-за этого они недостаточно безопасно работают в привилегированных программах.
Приведем низкоуровневое обходное решение с использованием pipe, fork и exec:
use POSIX qw(:sys_wait_h);
pipe(README, WRITEME); if ($pid = fork) {
# Родительский процесс
$SIG{CHLD} = sub { 1 while ( waitpid(-1, WNOHANG)) > 0 };
close(WRITEME);
die "cannot fork: $!" unless defined $pid;
# Порожденный процесс
open(STDOUT, ">&=WRITEME") or die "Couldn't redirect STDOUT: $!';
close(README);
exec($program, $arg1, $arg2) or die "Couldn't run $program : $!\n";
while (<README>) {
$string .= $_;
# or push(@strings, $_); > с lose(README);
> Смотри также
perlsec(i); рецепты 16.2; 16.4; 16.19; 19.6.
16.2. Запуск другой программы
Проблема
Вы хотите запустить другую программу из своей, дождаться ее завершения и затем продолжить работу. Другая программа должна использовать те же STDIN и STDOUT, что и основная.
Решение
Вызовите функцию system со строковым аргументом, который интерпретируется как командная строка:
$status = system("vi $myfile");
Если вы не хотите привлекать командный интерпретатор, передайте system список:
Sstatus = system("vi", Imyfile);
Комментарий
Функция system обеспечивает самую простую и универсальную возможность запуска других программ в Perl. Она не возвращает выходные данные внешней программы, как '.. . ' или open. Вместо этого ее возвращаемое значение (фактически) совпадает с кодом завершения программы. Во время работы новой программы основная приостанавливается, поэтому новая программа может взаимодействовать с пользователем посредством чтения данных из STDIN и записи в STDOUT. При вызове с одним аргументом функция system (как и open, exec и '...') использует командный интерпретатор для запуска программы. Это может пригодиться для перенаправления или других фокусов:
system("cmd1 args | cmd2 | cmd3 >outfile"); system("cmd args <infile >outfile 2>errfile");
Чтобы избежать обращений к интерпретатору, вызывайте system со списком аргументов:
Sstatus = system($ргодram, $arg1, $arg);
die "Sprogram exited funny: $?" unless $status == 0;
Возвращаемое значение не является обычным кодом возврата; оно включает номер сигнала, от которого умер процесс (если он был). Это же значение присваивается переменной $? функцией wait. В рецепте 16.19 рассказано о том, как декодировать tuj.
Функция system (но не '...'!) игнорирует SIGINT и SIGQUIT во время работы порожденных процессов. Сигналы убивают лишь порожденные процессы. Если вы хотите, чтобы основная программа умерла вместе с ними, проверьте возвращаемое значение system или переменную $?:
if (($signo = system(@arglist)) &= 127) {
die "program killed by signal $signo\n"; }
Чтобы игнорировать SIGINT, как это делает system, установите собственный обработчик сигнала, а затем вручную вызовите fork и exec:
if ($pid = fork) {
# Родитель перехватывает INT и предупреждает пользователя
local $SIG{INT} = sub { print "Tsk tsk, no process interruptus\n" }; waitpid($pid, 0); } else {
die "cannot fork: $!" unless defined $pid;
# Потомок игнорирует INT и делает свое дело
$SIG{INT} = "IGNORE";
ехес("summarize", "/etc/logfiles") or die "Can't exec: $!\n";
($pid = fork) ? waitpid($pid, 0) : exec(@ARGV)
or die "Can't exec: $!\n";
Некоторые программы просматривают свое имя. Командные интерпретаторы узнают, были ли они вызваны с префиксом -, обозначающим интерактивность. Программа ехрп в конце главы 18 при вызове под именем vrfy работает иначе; такая ситуация возникает при создании двух ссылок на файл (см. описание ехрп). По этой причине не следует полагать, что $0 всегда содержит имя вызванной программы.
Если вы хотите подсунуть запускаемой программе другое имя, укажите настоящий путь в виде «косвенного объекта» перед списком, передаваемым system (также работает для exec). После косвенного объекта не ставится запятая, по аналогии с вызовом printf для файлового манипулятора или вызовом методов объекта без ->.
$shell = '/bin/tcsh';
system Sshell '-csh'; # Прикинуться другим интерпретатором
Или непосредственно:
system {'/bin/tcsh'} '-csh'; # Прикинуться другим интерпретатором
U Вызвать ехрп как vrfy
system {'/home/tchnst/scripts/expn'} 'vrfy', ©ADDRESSES,
Применение косвенных объектов с system более надежно. В этом случае аргументы заведомо интерпретируются как список, даже если он состоит лишь из одного элемента. Это предотвращает расширение метасимволов командным интерпретатором или разделение слов, содержащих пропуски.
@args = ( "echo surprise' );
system @args, # Если @args == 1, используются
# служебные преобразования интерпретатора system { $args[0] } @args; tt Безопасно даже для одноаргументного списка
Первая версия ( без косвенного объекта) запускает программу echo и передает ей аргумент "surprise". Вторая версия этого не делает — она честно пытается запустить программу "echo surprise", не находит ее и присваивает $? ненулевое значение, свидетельствующее об ошибке.
> Смотри также---------------------------------------------------------------------------------------------
perlsec(l); описание функций waitpid, fork, exec, system и open вperlfunc(l); рецепты 16.1; 16.4; 16.19; 19.6.
16.3. Замена текущей программы
Проблема
Требуется заменить работающую программу другой — например, после проверки параметров и настройки окружения, предшествующих выполнению основной программы.
Решение
Воспользуйтесь встроенной функцией exec. Если exec вызывается с одним аргументом, содержащим метасимволы, для запуска будет использован командный интерпретатор:
ехес("archive *.data")
or die "Couldn't replace myself with archive: $!\n";
Если exec передаются несколько аргументов, командный интерпретатор не используется:
ехес("archive", "accounting.data")
or die "Couldn't replace myself with archive: $'\n";
При вызове с одним аргументом, не содержащим метасимволов, аргумент разбивается по пропускам и затем интерпретируется так, словно функция exec была вызвана для полученного списка:
exec("archive accounting.data")
or die "Couldn't replace myself with archive: $'\n",
Комментарий
Функция Perl exec обеспечивает прямой интерфейс к системной функции execlp(2), которая заменяет текущую программу другой без изменения идентификатор процесса. Программа, вызвавшая exec, стирается, а ее место в таблице процессов операционной системы занимает программа, указанная в качестве аргумента exec. В результате новая программа сохраняет тот же идентификатор процесса ($$), что и у исходной программы. Если указанную программу запустить не удалось, exec возвращает false, а исходная программа продолжает работу. Не забывайте проверять такую ситуацию.
При переходе к другой программе с помощью exec не будут автоматически вызваны ни блоки END, ни деструкторы объектов, как бы это произошло при нормальном завершении процесса.
> Смотри также---------------------------------------------------------------------------------------------
Описание функции exec в perlfunc(l); страница руководства execlp(2) вашей системы (если есть); рецепт 16.2.
16.4. Чтение или запись в другой программе
Проблема
Вы хотите запустить другую программу и либо прочитать ее вывод, либо предоставить входные данные.
Решение
Вызовите open с символом | в начале или конце строки. Чтобы прочитать вывод программы, поставьте | в конце:
$pid = open(README, "program arguments |") or die Couldn't fork. $!\n', while (<README>) {
# .. .
}
close(README) or die 'Couldn't close' $'\n",
Чтобы передать данные, поставьте | в начале:
$pid = open(WRITEME, "| program arguments") or die "Couldn't fork: $!\n",
print WRITEME "data\n";
close(WRITEME) or die 'Couldn't close: $'\n",
При чтении происходящее напоминает , разве что на этот раз у вас имеется
идентификатор процесса и файловый манипулятор. Функция open также использует командный интерпретатор, если встречает в аргументе метасимволы, и не использует в противном случае. Обычно это удобно, поскольку вы избавляетесь от хлопот с расширением метасимволов в именах файлов и перенаправлением ввода/вывода.
Однако в некоторых ситуациях это нежелательно. Конвейерные вызовы open, в которых участвуют непроверенные пользовательские данные, ненадежны при работе в режиме меченых данных или в ситуациях, требующих абсолютной уверенности. Рецепт 19.6 показывает, как имитировать эффект конвейерных вызовов open без риска, связанного с использованием командного интерпретатора.
Обратите внимание на явный вызов close для файлового манипулятора. Когда функция open используется для подключения файлового манипулятора к порожденному процессу, Perl запоминает этот факт и при закрытии манипулятора автоматически переходит в ожидание. Если порожденный процесс к этому моменту не завершился, Perl ждет, пока это произойдет. Иногда ждать приходится очень, очень долго:
$pid = open(F, sleep 100000| ), # Производный процесс приостановлен
close(F), # Родитель надолго задумался
Чтобы избежать этого, уничтожьте производный процесс по значению PID, полученному от open, или воспользуйтесь конструкцией pipe-fork-exec (см. рецепт 16.10)
При попытке записать данные в завершившийся процесс, ваш процесс получит сигнал SIGPIPE. По умолчанию этот сигнал убивает ваш процесс, поэтому программист-параноик на всякий случай установит обработчик SIGPIPE.
Если вы хотите запустить другую программу и предоставить содержимое ее STDIN, используется аналогичная конструкция:
$pid = open(WRITEME, | program args ),
print WRITEME hello\n , # Программа получит hello\n в STDIN
close(WRITEME), # Программа получит EOF в STDIN
Символ | в начале аргумента функции open, определяющего имя файла, сообщает Perl о необходимости запустить другой процесс. Файловый манипулятор, открытый функцией open, подключается к STDIN порожденного процесса. Все, что вы запишете в этот манипулятор, может быть прочитано процессом из STDIN После закрытия манипулятора (close) при следующей попытке чтения из STDIN порожденный процесс получит eof.
Описанная методика может применяться для изменения нормального вывода вашей программы. Например, для автоматической обработки всех данных утилитой постраничного вывода используется фрагмент вида:
= $ENV{PAGER> || /usr/bin/less , # XXX может не существовать open(STDOUT, | $pager ),
Теперь все данные, направленные в стандартный вывод, будут автоматически проходить через утилиту постраничного вывода. Вам не придется исправлять другие части программы.
Как и при открытии процесса для чтения, в тексте, передаваемом командному интерпретатору, происходит расширение метасимволов. Чтобы избежать обращения к интерпретатору, следует воспользоваться решением, аналогичным приведенному выше. Как и прежде, родитель должен помнить о close. При закрытии файлового манипулятора, подключенного к порожденному процессу, родитель блокируется до завершения потомка. Если порожденный процесс не завершается, то и закрытие не произойдет. Приходится либо заранее убивать порожденный процесс, либо использовать низкоуровневый сценарий pipe-fork-exec.
При использовании сцепленных открытий всегда проверяйте значения, возвращаемые open и close, не ограничиваясь одним open. Дело в том, что возвращаемое значение open не говорит о том, была ли команда успешно запущена. При сцепленном открытии команда выполняется вызовом fork для порожденного процесса. Если возможности создания процессов в системе не исчерпаны, fork немедленно возвращает PID порожденного процесса.
К тому моменту, когда порожденный процесс пытается выполнить команду exec, он уже является самостоятельно планируемым. Следовательно, если команда не будет найдена, практически не существует возможности сообщить об этом функции open, поскольку она принадлежит другому процессу!
Проверка значения, возвращаемого close, позволяет узнать, успешно ли выполнилась команда. Если порожденный процесс завершается с ненулевым кодом (что произойдет в случае, если команда не найдена), то close возвращает false, a переменной $? присваивается статус ожидания процесса. Об интерпретации содержимого этой переменной рассказано в рецепте 16.2.
t> Смотри также--------------------------------------------------------------------------------------------
Описание функции open вperlfunc(l); рецепты 16.10; 16.15; 16.19; 19.6.
16.5. Фильтрация выходных данных
Проблема
Требуется обработать выходные данные вашей программы без написания отдельного фильтра.
Решение
Присоедините фильтр с помощью разветвляющего (forking) вызова open. Например, в следующем фрагменте вывод программы ограничивается сотней строк:
head(100), while (о) { print,
sub head {
my $lines = shift || 20,
return if $pid = open(STDOUT, |- ),
566 Глава 16 • Управление процессами и межпроцессные взаимодействия
die "cannot fork: $!" unless defined $pid; while (<STDIN>) {print;
last unless --$lines ; } exit;
Комментарий
Создать выходной фильтр несложно — достаточно открыть STDOUT разветвляющим вызовом open, а затем позволить порожденному процессу фильтровать STDIN в STDOUT и внести те изменения, которые он посчитает нужным. Обратите внимание: выходной фильтр устанавливается до генерации выходных данных. Это вполне логично — нельзя отфильтровать вывод, который уже покинул вашу программу.
Все подобные фильтры должны устанавливаться в порядке очередности стека — последний установленный фильтр работает первым.
Рассмотрим пример, в котором используются два выходных фильтра. Первый фильтр нумерует строки; второй — снабжает их символами цитирования (как в сообщениях электронной почты). Для файла /etc/motd результат выглядит примерно так:
1: > Welcome to Linux, version 2.0.33 on a 1686
2: >
3: > "The software required 'Windows 95 or better',
4: > so I installed Linux."
Если изменить порядок установки фильтров, вы получите следующий результат:
> 1: Welcome to Linux, Kernel version 2.0.33 on a i686
> 2:
> 3: "The software required 'Windows 95 or better',
> 4: so I installed Linux."
Исходный текст программы приведен в примере 16.1. Пример 16.1. qnumcat
й1/usr/bin/perl
# qnumcat - установка сцепленный выходных фильтров
number(); # Установить для STDOUT нумерующий фильтр
quote(); # Установить для STDOUT цитирующий фильтр
while (о) { # Имитировать /bin/cat print;
close STDOUT; # Вежливо сообщить потомкам о завершении exit,
sub number {
my $pid;
return if $pid = open(STDOUT, "|-').
die " cannot fork' V" unless defined $pid;
while (<STDIN>) { printf "%d- %s", $ , $_ }
exit;
sub quote {
my $pid;
return if $pid = open(STDOUT, "|-');
die "cannot fork: $!" unless defined $pid,
while (<STDIN>) { print "> $_' }
exit; }
Как и при любых разветвлениях, для миллиона процессов такое решение не подойдет, но для пары (или даже нескольких десятков) процессов расходы будут небольшими. Если ваша система изначально проектировалась как многозадачная (как UNIX), все обойдется дешевле, чем можно себе представить. Благодаря виртуальной памяти и копированию во время записи такие операции выполняются достаточно эффективно. Разветвление обеспечивает элегантное и недорогое решение многих (если не всех) задач, связанных с многозадачностью.
> Смотри также---------------------------------------------------------------------------------------------
Описание функции open вperlfunc(l); рецепт 16.4.
16.6. Предварительная обработка ввода
Проблема
Ваша программа умеет работать лишь с обычным текстом в локальных файлах. Однако возникла необходимость работать с экзотическими файловыми форматами — например, сжатыми файлами или Web-документами, заданными в виде URL.
Решение
Воспользуйтесь удобными средствами Perl для работы с каналами и замените имена входных файлов каналами перед тем, как открывать их.
Например, следующий фрагмент автоматически восстанавливает архивные файлы, обработанные утилитой gzip:
@ARGV = map { /\.(gz|Z)$/ ? "gzip -de $_ |" : $_ } @AR6V, while (<>) {
#.............
}
А чтобы получить содержимое URL перед его обработкой, воспользуйтесь программой GET из модуля LWP (см. главу 20 «Автоматизация в Web»):
@ARGV = map { m#"\w+://# ? "GET $_ |" : $_ } @ARGV; while (<>) {
Й ...................
}
Конечно, вместо HTML- кода можно принять простой текст. Для этого достаточно воспользоваться другой командой (например, lynx -dump).
Комментарий
Как показано в рецепте 16.1, встроенная функция Perl open очень удобна: каналы открываются в Perl так же, как и обычные файлы. Если то, что вы открываете, похоже на канал, Perl открывает его как канал. Мы используем эту особенность и включаем в имя файла восстановление архива или иную предварительную обработку. Например, файл "09tails.gz" превращается в "gzcat -de 09tails.gz ".
Эта методика применима и в других ситуациях. Допустим, вы хотите прочитать /etc/passwd, если компьютер не использует NIS, и вывод ypcat passwd в противном случае. Мы определяем факт использования NIS по выходным данным программы domainname, после чего выбираем в качестве открываемого файла строку "</etc/passwd" или "ypcat passwd ".
Spwdinfo = 'domainname' =~ /"(\(none\))?$/ ? '< /etc/passwd' : 'ypcat passwd |';
open(PWD, $pwdinfo) or die "can't open Spwdinfo: $!",
Но и это еще не все! Даже если вы не собирались встраивать подобные возможности в свою программу, Perl делает это за вас! Представьте себе фрагмент вида:
print "File, please? ";
chomp($file = о);
open (FH, $file) or die "can't open $file: $' ';
Пользователь может ввести как обычное имя файла, так и строку вида "webget http://www. perl. com |" — и ваша программа вдруг начинает получать выходные данные от webget! А если ввести всего один символ, дефис (-), то при открытии для чтения будет интерполирован стандартный ввод.
В рецепте 7.7 эта методика использовалась для автоматизации обработки ARGV.
> Смотри также---------------------------------------------------------------------------------------------
Рецепты 7.7; 16.4.
16.7. Чтение содержимого STDERR
Проблема
Вы хотите выполнить программу с помощью system, '. . . ' или open, но содержи мое ее STDERR не должно выводиться в ваш STDERR. Необходимо либо игнорировать содержимое STDERR, либо сохранять его отдельно.
Решение
Воспользуйтесь числовым синтаксисом перенаправления и дублирования для файловых дескрипторов. Для упрощения примеров мы не проверяем возвращаемое значение open, но вы обязательно должны делать это в своих программах! Одновременное сохранение STDERR и STDOUT:
|
$output = 'cmd |
2>&1'; |
# |
Для '... |
|
# или |
|||
|
$pid = open(PH, |
"cmd 2>&1 |"), |
# |
Для open |
|
while (<PH>) { |
} |
8 |
Чтение |
Soutput = 'cmd 2>/dev/null , й Для '...' 8 или
$pid = open(PH, "cmd 2>/dev/null |"); 8 Для open
while (<PH>) { } 8 Чтение
Сохранение STDERR с игнорированием STDOUT:
$output = 'cmd 2>&1 1>/dev/null'; # Для '...'
# или
$pid = open(PH, "cmd 2>&1 1>/dev/null |"), # Для open
while (<PH>) { } # Чтение
Замена STDOUT и STDERR команды, то есть сохранение STDERR и направление STDOUT в старый STDERR:
Soutput = 'cmd 3>&1 1>&2 2>&3 3>&-'; # Для '...'
# или
$pid = open(PH, "cmd 3>&1 1>&2 2>&3 3>&-|"); # Для open
while (<PH>) { } # Чтение
Чтобы организовать раздельное чтение STDOUT и STDERR команды, проще и надежнее всего будет перенаправить их в разные файлы, а затем прочитать из этих файлов после завершения команды:
system("prog args 1>/tmp/program.stdout 2>/tmp/program.stderr");
Комментарий
При выполнении команды оператором '... ', сцепленным вызовом open или system для одной строки Perl проверяет наличие символов, имеющих особый смысл для командного интерпретатора. Это позволяет перенаправить файловые дескрипторы новой программы. STDIN соответствует файловому дескриптору с номером О, STDOUT — 1, a STDERR — 2. Например, конструкция 2>файл перенаправляет STDERR в файл. Для перенаправления в файловый дескриптор используется специальная конструкция &N, где N — номер файлового дескриптора. Следовательно, 2>&1 направляет STDERR в STDOUT.
Ниже приведена таблица некоторых интересных перенаправлений файловых дескрипторов.
1>/dev/null Игнорировать STDOUT
2>/dev/null Игнорировать STDERR
2>&1 Направить STDERR в STDOUT
2>&- Закрыть STDERR (не рекомендуется)
3<>/dev/tty Связать файловый дескриптор 3 с /dev/tty в режиме
чтения/записи________________________________________
На основании этой таблицы мы рассмотрим самый сложный вариант перенаправления в решении:
Soutput = cmd 3>&1 1>&2 2>&3 3>&-'; Он состоит из четырех этапов.
Этап 1: 3>&1
Скопировать файловый дескриптор 1 в новый дескриптор 3. Прежнее место назначения STDOUT сохраняется в только что открытом дескрипторе.
Этап 2: 1>&2
Направить STDOUT по месту назначения STDERR. В дескрипторе 3 остается
прежнее значение STDOUT.
Этап 3: 2>&3
Скопировать файловый дескриптор 3 в дескриптор 2. Данные STDERR будут
поступать туда, куда раньше поступали данные STDOUT.
Этап 4: 3>&-
Перемещение потоков закончено, и мы закрываем временный файловый дескриптор. Это позволяет избежать «утечки» дескрипторов.
Если подобные цепочки сбивают вас с толку, взгляните на них как на обычные переменные и операторы присваивания. Пусть переменная $fd1 соответствует STDOUT, a $fd2 — STDERR. Чтобы поменять значения двух переменных, понадобится временная переменная для хранения промежуточного значения. Фактически происходит следующее:
$fd3 = $fd1,
$fd1 = $fd2;
$fd2 = $fd3,
$fd3 = undef;
Когда все будет сказано и сделано, возвращаемая оператором -. . . ' строка будет соответствовать STDERR выполняемой команды, a STDOUT будет направлен в прежний STDERR.
Во всех примерах важна последовательность выполнения. Это связано с тем, что командный интерпретатор обрабатывает перенаправления файловых дескрипторов слева направо.
system("prog args 1>tmpflie 2>&1');
systemf prog args 2>&1 1>tmpfile');
# system ("prog args 1>tmpfile 2>&1 '),
$fd1 = "tmpfile"; # Сначала изменить место назначения STDOUT
$fd2 = $fd1; # Направить туда же STDERR
сильно отличается от другого фрагмента:
# system("prog args 2>&1 1>tmpfile');
$fd2 = $fd1; # Совместить STDERR со STDOUT
$fd1 = "tmpfile"; # Изменить место назначения STDOUT
> Смотри также---------------------------------------------------------------------------------------------
Дополнительные сведения о перенаправлении файловых дескрипторов приведены в странице руководства s/z(l) вашей системы (если есть). Функция system описана в perlfunc(l).
16.8. Управление потоками ввода и вывода другой программы
Проблема
Вы хотите управлять как входными, так и выходными данными другой программы. Функция open позволяет решить одну из этих задач, но не обе сразу.
Решение
Воспользуйтесь стандартным модулем 1РС::Ореп2:
use IPC::0pen2;
open2(«README, *WRITEME, Sprogram); print WRITEME "here's your input\n'; $output = <README>; close(WRITEME); close(README);
Комментарий
Желание управлять вводом и выводом другой программы возникает очень часто, однако за ним таится на удивление много опасностей. Поэтому вам не удастся вызвать open в виде:
open(DOUBLE_HANDLE, "| программа аргументы |") # НЕВЕРНО
Большая часть трудностей связана с буферизацией. Поскольку в общем случае нельзя заставить другую программу использовать небуферизованный вывод, нет
Если вы можете управлять буферизацией другого процесса (потому что вы сами написали программу и знаете, как она работает), возможно, вам поможет модуль 1РС::Ореп2. Первые два аргумента функции ореп2, экспортируемой 1РС::Ореп2 в ваше пространство имен, представляют собой файловые манипуляторы. Либо передавайте ссылки на typeglobs, как это сделано в решении, либо создайте собственные объекты IO::Handle и передайте их:
use IPC::0pen2; use 10::Handle;
($reader, $writer) = (10:¦Handle->new, 10.:Handle->new); open2($reader, $writer, $program);
Чтобы передать объекты, необходимо предварительно создать их (например, функцией 10: :Handle->new). Если передаваемые переменные не содержат файловых манипуляторов, функция ореп2 не создаст их за вас.
Другой вариант — передать аргументы вида "<&OTHERFILEHANDLE" или ">&OTHERFILEHANDLE", определяющие существующие файловые манипуляторы для порожденных процессов. Эти файловые манипуляторы не обязаны находиться под контролем вашей программы; они могут быть подключены к другим программам, файлам или сокетам.
Программа может задаваться в виде списка (где первый элемент определяет имя программы, а остальные элементы — аргументы программы) или в виде отдельной строки (передаваемой интерпретатору в качестве команды запуска программы). Если вы также хотите управлять потоком STDERR программы, воспользуйтесь модулем 1РС::ОрепЗ (см. следующий рецепт).
Если произойдет ошибка, возврат из ореп2 и орепЗ не происходит. Вместо этого вызывается die с сообщением об ошибке, которое начинается с "ореп2" или "орепЗ". Для проверки ошибок следует использовать конструкцию eval БЛОК:
eval {
open2($readme, Swriteme, @program_and_arguments); }; if ($@) {
if ($@ =~ /-open2/) {
warn "open2 failed: $!\n$@\n"; return; } die; # Заново инициировать непредвиденное исключение
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартным модулям 1РС::Ореп2 и 1РС::ОрепЗ; рецепт 10.12; описание функции eval вperlfunc(i); описание переменной $@ в разделе «Special Global Variables» perlvar{\).
Проблема
Вы хотите полностью управлять потоками ввода, вывода и ошибок запускаемой команды.
Решение
Аккуратно воспользуйтесь стандартным модулем 1РС::ОрепЗ, возможно — в сочетании с модулем IO::Select (появившимся в версии 5.004).
Комментарий
Если вас интересует лишь один из потоков STDIN, STDOUT или STDOUT программы, задача решается просто. Но если потребуется управлять двумя и более потоками, сложность резко возрастает. Мультиплексирование нескольких потоков ввода/вывода всегда выглядело довольно уродливо. Существует простое обходное решение:
@all,= '($cmd | sed -e 's/"/stdout: /' ) 2>&1';
for (@all) { push @{ s/stdout: // ? \@outlines : \@errlines }, $__ }
print "STDOUT:\n", ^outlines, "\n":
print 'STDERR:\n", @errlines, '\n",
Если утилита sed не установлена в вашей системе, то в простых случаях вроде показанного можно обойтись командой perl -ре, которая работает практически так же.
Однако то, что здесь происходит, в действительности нельзя считать параллельными вычислениями. Мы всего лишь помечаем строки STDOUT префиксом "stdout:" и затем удаляем их после чтения всего содержимого STDOUT и STDERR, сгенерированного программой.
Кроме того, можно воспользоваться стандартным модулем 1РС::ОрепЗ. Как ни странно, аргументы функции 1РС::ОрепЗ следуют в другом порядке, нежели в 1РС::Ореп2.
open3(«WRITEHANDLE, *READHANDLE, «ERRHANDLE, "ЗАПУСКАЕМАЯ ПРОГРАММА");
Открываются широкие потенциальные возможности для создания хаоса — еще более широкие, чем при использовании ореп2. Если попытаться прочитать STDERR программы, когда она пытается записать несколько буферов в STDOUT, процесс записи будет заблокирован из-за заполнения буферов, а чтение заблоки-руется из-за отсутствия данных.
Чтобы избежать взаимной блокировки, можно имитировать орепЗ с помощью fork, open и exec; сделать все файловые манипуляторы небуферизованными и использовать sysread, syswrite и select, чтобы решить, из какого доступного для чтения манипулятора следует прочитать байт. Однако ваша программа становится медленной и громоздкой, к тому же при этом не решается классическая пробле-
use IPC::0pen3;
$pid = open3(.HIS_IN, *HIS_OUT, *HIS_ERR, $cmd);
close(HIS_IN); # Передать порожденному процессу EOF или данные
©outlines = <HIS_OUT>; й Читать до конца файла
@errlines = <HIS_ERR>; # XXX: Возможная блокировка
# при больших объемах print "STDOUT:\n", ©outlines, "\n"; print "STDERR:\n", @errlines, "\n";
Кроме того (как будто одной взаимной блокировки недостаточно), такое решение чревато нетривиальными ошибками. Существуют по крайней мере три неприятных ситуации: первая — когда и родитель и потомок пытаются читать одновременно, вызывая взаимную блокировку. Вторая — когда заполнение буферов заставляет потомка блокироваться при попытке записи в STDERR, тогда как родитель блокируется при попытке чтения из STDOUT потомка. Третья - когда заполнение буферов заставляет родителя блокировать запись в STDIN потомка, а потомок блокируется при записи в STDOUT или STDERR. Первая проблема в общем случае не решается, хотя ее можно обойти, создавая таймеры функцией alarm и предотвращая перезапуск блокирующих операций при получении сигнала SIGALRM.
Мы используем модуль IO::Select, чтобы узнать, из каких файловых манипуляторов можно прочитать данные (для этой цели можно использовать встроенную функцию select). Это решает вторую, но не третью проблему. Для решения третьей проблемы также потребуются alarm и SIGALRM.
Если вы хотите отправить программе входные данные, прочитать ее вывод и затем либо прочитать, либо проигнорировать ошибки, работы заметно прибавится (см. пример 16.2).
Пример 16.2. cmcBsel
#!/usr/bin/perl
# cmd3sel - управление всеми тремя потоками порожденного процесса
# (ввод, вывод и ошибки),
use IPC::0pen3;
use 10::Select;
$cmd = "grep vt33 /none/such - /etc/termcap"; $pid = open3(*CMD_IN, «CMD_OUT, *CMD_ERR, $cmd);
$SIG{CHLD} = sub {
print "REAPER: status $? on $pid\n" if waitpid($pid, 0) > 0
print CMO_IN "This line has a vt33 lurking in it\n"; close(CMD_IN);
Sselector = 10::Select->new();
16.10. Взаимодействие между родственными процессами 575
$selector->add(*CMD_ERR, *CMD_OUT);
while (@ready = $selector->can_read) { foreach $fh (@ready) {
if (fileno($fh) == fileno(CMD_ERR))
{print "STDERR: ", scalar <CMO_ERR>} else
{print "STDOUT: ", scalar <CMD_OUT>} $selector->remove($fh) if eof($fh);
close(CMD_CUT); close(CMD_ERR);
Мы отправляем короткую входную строку, а затем закрываем манипулятор. Тем самым предотвращается ситуация взаимной блокировки двух процессов, каждый из которых ожидает записи данных другим процессом.
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартным модулям IO::Select; IPC::Open2 и 1РС::ОрепЗ; описание функции alarm вperlfunc(l); рецепты 16.8; 16.15—16.16.
16.10. Взаимодействие между родственными процессами
Проблема
Имеются два взаимосвязанных процесса, которые должны обмениваться данными. Вам требуется более высокая степень контроля по сравнению с той, что обеспечивают open, system и '...'.
Решение
Воспользуйтесь pipe, а затем - fork:
pipe(READER, WRITER); if (fork) {
# Выполнить родительский код, в котором происходит либо чтение,
# либо запись (что-то одно).
} else {
# Выполнить код потомка, в котором происходит либо чтение,
# либо запись (что-то одно).
}
Либо используйте особую форму open:
if ($pid = open(CHILD, "|-")) {
# Выполнить родительский код, передающий данные потомку
die cannot fork $' unless defined $pid,
# Иначе выполнить код потомка, принимающий данные от родителя
>
Или по-другому:
if ($pid = open(CHILD, -| )) {
# Выполнить родительский код, принимающий данные от потомка
} else {
die cannot fork $' unless defined $pid
# Иначе выполнить код потомка, передающий данные родителю
>
Комментарий
Канал представляет собой два файловых манипулятора, связанных так, что записанные в один файловый манипулятор данные могут быть прочитаны из другого. Функция pipe создает два манипулятора, связанных в капал; первый (приемник) предназначен для чтения, а второй (передатчик) — для записи Хотя вы не сможете взять два существующих манипулятора и объединить их в канал, функция pipe часто используется при обмене данными между процессами. Один процесс создает пару манипуляторов функцией pipe, после чего создает потомка с помощью fork; в результате возникают два разных процесса, выполняющих одну и ту же программу, каждый из которых обладает копией связанных манипуляторов.
Неважно, какой процесс будет приемником, а какой — передатчиком; когда процесс начинает играть одну из этих ролей, его напарнику достается другая. Такой обмен данными может быть только односторонним (но не бросайте читать!)
Мы воспользуемся модулем IO::Handle, в котором нас интересует метод autoflush() (если вы предпочитаете более эффективные решения, воспользуйтесь решением с select, описанным в главе 7). Если этого не сделать, наша отдельная строка вывода застрянет в канале и не доберется до другого конца до закрытия канала.
Версия родителя, передающего данные потомку, приведена в примере 16.3.
Пример 16.3. pipel
#'/usr/bm/perl -w
# pipel - применение pipe и fork для отправки данных родителем потомку
use 10 Handle, pipe(READER WRITER), WRITER->autoflush(1),
if ($pid = fork) <
close READER,
print WRITER Parent Pid $$ is sending this\n ,
close WRITER,
waitpid($pid,O), > else {
die cannot fork $' unless defined $pid,
close WRITER,
chomp($line = <READER>),
print Child Pid $$ just read this $lme \n close READER # Все равно это произойдет exit }
В примерах этого рецепта основная проверка ошибок была оставлена читателю для самостоятельной работы Мы так поступили для того, чтобы взаимодействие функций стало более наглядным. В реальной жизни проверяются возвращаемые значения всех вызовов системных функций
В примере 16 4 показана версия потомка, передающего данные родителю
Пример 16.4. pipe2
#' /usr/bm/perl -w
И pipe2 - применение pipe и fork для передачи данных потомком родителю
use 10 Handle pipe(READER WRITER) WRITER->autoflush(1)
if ($pid = fork) {
close WRITER
chomp($line = <READER>)
print Parent Pid $$ just read this $lme \n
close READER
waitpid($pid 0) } else {
die cannot fork $' unless defined $pid
close READER
print WRITER Child Pid $$ is sending this\n ,
close WRITER # Все равно это произойдет
exit >
Обычно обе половины входят в цикл и приемник продолжает читать до конца файла. Это происходит до тех пор, пока передатчик не закроет канал или не завершится
Поскольку манипуляторы каналов работают лишь в одном направлении, каждый процесс использует лишь один канал из пары и закрывает неиспользуемый манипулятор. Причина, по которой это делается, нетривиальна; представьте себе ситуацию, при которой принимающий процесс не закрыл передающий манипулятор Если после этого передающий процесс завершится, пока принимающий процесс пытается что-нибудь прочитать, последний намертво «зависнет» Система не может сообщить приемнику о том, что данных для чтения больше не будет, пока не будут закрыты все копии передающего манипулятора.
Функция open, получая в качестве второго аргумента -| или |= .неявно вызывает pipe и fork. Это несколько упрощает приведенный выше фрагмент. Порожденный процесс общается с родителем через STDIN или STDOUT в зависимости от того, какая строка была использована, -1 или [ - .
Пример 16.5. pipe3
#!/usr/bin/perl -w
# pipe3 - применение разветвляющего вызова open
# для передачи данных от родителя к потомку
use 10::Handle;
if ($pid = open(CHILD, "]-")) {
CHILD->autoflush(1);
print CHILD "Parent Pid $$ is sending this\n";
close(CHILD); } else {
die "cannot fork: $!" unless defined $pid;
chomp($line = <STDIN>);
print "Child Pid $$ just read this: '$line'\n";
exit; >
Поскольку STDIN потомка уже подключен к родителю, потомок может запустить через exec другую программу, читающую данные из стандартного ввода — например, Ipr. Это полезная и часто используемая возможность.
Если потомок захочет передать данные родителю, он делает нечто похожее на пример 16.6.
Пример 16.6. pipe4
й!/usr/bin/perl -w
# pipe4 - применение разветвляющего вызова open
# для передачи данных от потомка к родителю
use 10::Handle;
if ($pid = open(CHILD, "-|")) {
chomp($line = <CHILD>);
print "Parent Pid $$ just read this: '$line'\n";
close(CHILD); } else {
die "cannot fork: $!" unless defined $pid;
STD0UT->autoflush(1);
print STDOUT "Child Pid $$ is sending this\n";
exit; }
И снова, поскольку STDOUT потомка уже подключен к родителю, потомок может запустить через exec другую программу, выдающую нечто интересное в его стандартный вывод. Эти данные также будут переданы родителю как ввод от <CHILD>.
При подобном использовании open мы не обязаны вручную вызывать waitpid, поскольку не было явного вызова fork. Однако close вызвать все же надо. В обоих случаях переменная $? содержит статус ожидания порожденного процесса (о том, как интерпретировать это значение, рассказано в рецепте 16.19).
В предыдущих примерах рассматривалась однонаправленная связь. Что делать, если вы хотите, чтобы данные передавались в обе стороны? Дважды вызовите pipe перед вызовом fork. Вам придется следить за тем, кто, что и когда передает, иначе может возникнуть взаимная блокировка (см. пример 16.7).
Пример 16.7. pipe5
#!/usr/bin/perl -w
# pipe5 - двусторонний обмен данными с использованием двух каналов
й без применения socketpair
use 10: .'Handle; pipe(PARENT_RDR, CHILD_WTR); pipe(CHILD_RDR, PARENT_WTR); CHILD_WTR->autoflush(1); PARENT_WTR->autoflush(1);
if ($pid = fork) {
close PARENT_RDR; close PARENT_WTR;
print CHILD_WTR "Parent Pid $$ is sending this\n";
chomp($line = <CHILD_RDR>);
print "Parent Pid $$ just read this: '$line'\n";
close CHILD_RDR; close CHILD_WTR;
waitpid($pid,0); } else {
die "cannot fork: $!" unless defined $pid;
close CHILD_RDR; close CHILD_WTR;
chomp($lme = <PARENT_RDR>);
print "Child Pid $$ just read this: '$line'\n";
print PARENT_WTR "Child Pid $$ is sending this\n";
close PARENT_RDR; close PARENT,WTR;
exit: }
Ситуация усложняется. Оказывается, существует специальная системная функция socketpair (см. пример 16.8), которая упрощает предыдущий пример. Она работает аналогично pipe, за исключением того, что оба манипулятора могут использоваться как для приема, так и для передачи.
Пример 16.8. pipe6
#!/usr/bin/perl -w
# pipe6 - двусторонний обмен данными с применением socketpair
use Socket; use 10::Handle;
# Мы говорим AF_UNIX, потому что хотя константа *_LOCAL
# соответствует POSIX 1003.1g, на многих компьютерах
# она еще не поддерживается.
socketpair(CHILD, PARENT, AF_UNIX, SOCK_STREAM, PF_UNSPEC) or die "socketpair: $!";
продолжение &
580 Глава 16 • Управление процессами и межпроцессные взаимодействия Пример 16.8 (продолжение)
CHIL0->autoflush(1), PARENT->autoflush(1),if ($pid = fork) {
close PARENT,
print CHILD Parent Pid $$ is sending this\n
chomp($line = <CHILD>)
print Parent Pid $$ just read this $line \n ,
close CHILD
waitpid($pid 0), } else {
die cannot fork $' unless defined $pid,
close CHILD,
chomp($lme = <PARENT>)
print Child Pid $$ just read this $line \n ,
print PARENT Child Pid $$ is sending this\n
close PARENT,
exit }
В некоторых системах каналы исторически были реализованы как два полузакрытых конца пары сокетов. Фактически реализация pipe(READER, WRITER) выглядела так:
socketpair(READER WRITER AF_UNIX, SOCK_STREAM, PF_UNSPEC)
shutdown(READER, 1), # Запретить запись для READER
shutdown(WRITER 0) # Запретить чтение для WRITER
В ядрах Lmux до версии 2.0.34 системная функция shutdown(2) работала неверно. Приходилось запрещать чтение для READER и запись для WRITER.
О Смотри также--------------------------------------------------------------------------------------------
Описания всех использованных функций вperlfunc(l); документация но стандартному модулю 1РС::Ореп2; рецепт 16.8.
16.11. Имитация файла на базе именованного канала
Проблема
Вы хотите, чтобы процесс перехватывал все обращения к файлу. Например, файл -/.plan должен превратиться в программу, которая будет возвращать случайную цитату.
Решение
Воспользуйтесь именованными каналами. Сначала создайте канал (вероятно, в командном интерпретаторе):
% mkfifo /path/to/named pipe Принимающий фрагмент выглядит так:
ореп(FIFO, < /path/to/named pipe ) or die $',
while (<FIFO>) {
print Got $_ , } close(FIFO),
Передающий фрагмент выглядит так:
open(FIFO, > /path/to/named pipe ) or die $1,
print FIFO Smoke this \n ,
close(FIFO),
Комментарий
Именованный канал (также встречается термин FIFO) представляет собой специальный файл, используемый в качестве буфера для взаимодействия процессов на одном компьютере. Обычные каналы также позволяют процессам обмениваться данными, но они должны наследовать файловые манипуляторы от своих родителей. Для работы с именованным каналом процессу достаточно знать его имя. В большинстве случаев процессы даже не обязаны сознавать, что они читают данные из FIFO.
Операции чтения и записи для именованных каналов выполняются точно так же, как и для обычных файлов (в отличие от сокетов UNIX, рассматриваемых в главе 17). Данные, записанные в FIFO, буферизуются операционной системой, а затем читаются обратно в порядке записи. Поскольку FIFO играет роль буфера для взаимодействия процессов, открытие канала для чтения блокирует его до тех пор, пока другой процесс не откроет его для записи, и наоборот. Если открыть канал для чтения и записи с помощью режима +< функции open, блокировки (в большинстве систем) не будет, поскольку ваш процесс сможет и принимать, и передавать данные.
Давайте посмотрим, как использовать именованный канал, чтобы при каждом запуске finger люди получали разные данные. Чтобы создать именованный канал с именем .plan в основном каталоге, воспользуйтесь mkfifo или mknod:
% mkfifo '/ plan # Есть практически везде
% mknod "7 plan p # На случай, если у вас все же нет mkfifo
В некоторых системах приходится использовать mknod(8). Имена и местонахождение этих программ могут быть другими — обращайтесь к системной документации.
Затем необходимо написать программу, которая будет поставлять данные программам, читающим из файла -/.plan. Мы ограничимся выводом текущей даты и времени (см. пример 16.9).
Пример 16.9. dateplan
#'/usr/bin/perl -w
й dateplan - вывод текущей даты и времени в файл plan
продолжение ¦&
582 Глава 16 • Управление процессами и межпроцессные взаимодействия Пример 16.9 (продолжение)
while (1) {open(FIFO, "> $ENV{HOME}/.plan")
or die "Couldn't open $ENV{HOME}/.plan for writing: $!\n";
print FIFO "The current time is ", scalar(localtime), "\n";
close FIFO;
sleep 1; }
К сожалению, такое решение работает не всегда, потому что некоторые варианты finger и соответствующие демоны проверяют размер файла .plan перед тем, как пытаться читать из него. Поскольку именованные каналы в файловой системе представлены в виде специальных файлов нулевого размера, некоторые клиенты и серверы не станут открывать именованный канал и читать из него, и наш фокус не удастся.
В примере с .plan демон был передатчиком. Приемники-демоны тоже встреча ются не так уж редко. Например, именованный канал может применяться для ведения централизованного журнала, собирающего данные от нескольких процессов. Программа-сервер читает сообщения из именованного канала и записывает их в базу данных или файл. Клиенты передают сообщения в именованный канал. Такая схема избавляет клиентов от хлопот, связанных с логикой передачи данных, и позволяет легко внести необходимые изменения в реализацию механизма передачи.
В примере 16.10 приведена простая программа для чтения двухстрочных блоков, где первая строка определяет процесс, а вторая — текст сообщения. Все сообщения от httpd игнорируются, а сообщения от login сохраняются в /var/log/login.
Пример 16.10. fifolog
#!/usr/bin/perl -w
# fifolog - чтение и сохранение сообщений из FIFO
use 10::File;
$SIG{ALRM} = sub { close(FIFO) }; # Переход к следующему
# процессу в очереди
while (1) {
alarm(O); # Отключить таймер
open(FIFO, "< /tmp/log") or die* "Can't open /tmp/log : $!\n";
alarm(1); # 1 секунда на регистрацию
Sservice = <FIFO>;
next unless defined Sservice; # Прерывание или нечего регистрировать
chomp Sservice;
Smessage = <FIFO>;
next unless defined Smessage; # Прерывание или нечего регистрировать
chomp Smessage;
alarm(O); 8 Отключить таймеры
# для обработки сообщений
if ($service eq "http") {
# Игнорировать
} elsif ($service eq "login") {
# Сохранить в /var/log/login
if ( open(L0G, "» /tmp/login") ) {
print LOG scalar(localtime), " $service $message\n";
close(LOG); } else {
warn "Couldn't log $service $message to /var/log/login : $!\n";
Программа получилась сложнее предыдущей по нескольким причинам. Прежде всего, мы не хотим, чтобы наш сервер ведения журнала надолго блокировал передатчики. Нетрудно представить ситуацию, при которой злонамеренный или бестолковый передатчик открывает именованный канал для записи, но не передает полного сообщения. По этой причине мы используем alarm и SIGALRM для передачи сигналов о нарушениях во время чтения.
При использовании именованных каналов могут возникнуть лишь два исключительных состояния: когда у приемника исчезает передатчик, и наоборот. Если процесс читает из именованного канала, а передатчик закрывает его со своего конца, то принимающий процесс получит признак конца файла (о возвращает undef). Однако если приемник отключается от канала, то при следующей попытке записи передатчик получит сигнал SIGPIPE. Если игнорировать сигналы о нарушении канала конструкцией $SIG{PIPE} =' IGNORE', print возвращает false, a переменной $! присваивается значение EPIPE:
use POSIX qw(:errno_h);
$SIG{PIPE} = 'IGNORE';
# . . .
$status = print FIFO "Are you there?\n";
if (!$status && $! == EPIPE) {
warn "My reader has forsaken me!\n";
next; >
Возможно, у вас возник вопрос: «Если сто процессов одновременно пытаются передать данные серверу, как можно быть уверенным в том, что я получу сто разных сообщений, а не хаотическую мешанину из символов или строк разных процессов?» Хороший вопрос. Согласно стандарту POSIX, запись менее PIPE_BUF байт будет доставлена автоматически, то есть не перепутается с другими. Значение константы PIPE_BUF можно узнать из модуля POSIX:
use POSIX;
print _POSIX_PIPE_BUF, "\n";
Но что если вам понадобилось зарегистрировать более 512 байт? Разделите каждое большое сообщение на несколько маленьких (менее 512 байт), снабдите каждое сообщение уникальным идентификатором клиента (например, идентификатором процесса) и организуйте их сборку на сервере. Нечто похожее происходит при разделении и сборке сообщений TCP/IP.
Один именованный канал не обеспечивает двухстороннего обмена данными между передатчиком и приемником, что усложняет аутентификацию и другие способы борьбы с передачей ложных сообщений (если не делает их невозможными). Вместо того чтобы упрямо втискивать эти возможности в модель, в которой они неуместны, лучше ограничить доступ к именованному каналу средствами файловой системы (на уровне прав владельца и группы).
D> Смотри также------------------------------------------------------------------------------------------
Страницы руководтва mkfifo(8) или mknod(8) (если они есть); рецепт 17.6.
16.12. Совместное использование переменных в разных процессах
Проблема
Требуется организовать совместный доступ к переменным в разветвлениях или неродственных процессах.
Решение
Используйте средства SysV IPC, если ваша система их поддерживает.
Комментарий
Хотя средства SysV IPC (общая память, семафоры и т. д.) реже используются в межпроцессных коммуникациях, нежели каналы, именованные каналы и сокеты, они все же обладают рядом интересных свойств. Тем не менее для совместного использования переменной несколькими процессами обычно нельзя рассчитывать на работу с общей памятью через shmget или mmap(2). Дело в том, что Perl заново выделит память под строку тогда, когда вы этого совсем не ждете.
Проблема решается с помощью модуля IPC::Shareable с CPAN. Умный модуль tie, общая память SysV и модуль Shareable с CPAN позволяют организовать совместный доступ к структурам данных произвольной сложности для процессов на одном компьютере. При этом процессы даже не обязаны быть родственными.
В примере 16.11 продемонстрирован несложный случай применения этого модуля.
Пример 16.11. sharetest
#' /usr/bm/perl
# sharetest - совместный доступ к общим переменным в разветвлениях
$handle = tie $buffer, IPC Shareable , undef, { destroy => 1 }, $SIG{INT} = sub { die $$ dying\n },
for (1 10) {
unless ($child = fork) { # Я - потомок
die cannot fork $' unless defined $child,
squabble(),
exit, } push (s>kids, $child # Если нас интересуют идентификаторы процессов
while (1) {
print Buffer is $buffer\n
sleep 1 } die Not reached ,
sub squabble { my $i = 0, while (1) {
next if $buffer =~ /~$$\b/o
$handle->shlock(),
$buffer = $$ $i $handle->shunlock()
Исходный процесс создает общую переменную, разветвляется на 10 потомков, а затем выводит значение буфера примерно каждую секунду в бесконечном цикле или до тех пор, пока вы не нажмете Ctrl+C.
Поскольку обработчик SIGINT был установлен до всех вызовов fork, его наследуют все потомки, которые также уничтожаются при прерывании группы процессов. Сигналы с клавиатуры передаются целой группе процессов, а не одному процессу.
Что же происходит в squabble? Потомки разбираются, кому из них удастся обновить общую переменную. Каждый порожденный процесс смотрит, изменилось ли состояние переменной с момента последнего визита. Если буфер начинается с его собственной сигнатуры (идентификатора процесса), процесс не трогает его. Если буфер был изменен кем-то другим, процесс блокирует общую переменную вызовом специального метода для манипулятора, полученного от tie, обновляет ее и снимает блокировку.
Программа заработает намного быстрее, если закомментировать строку, начинающуюся с next, где каждый процесс проверяет, кто последним прикасался к буферу.
Шаблон /~$$\Ь/о выглядит подозрительно, поскольку /о указывает на однократную компиляцию шаблона, а переменная $$ меняется при разветвлении. Впрочем,
Модуль IPC::Shareable также поддерживает совместное использование переменных не-родственными процессами на одном компьютере. За подробностями обращайтесь к документации.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций semctl, semget, semop, shmctl, shmget, shmread и shmwrite в perlfunc(l); документация по модулю IPC::Shareable с CPAN.
16.13. Получение списка сигналов
Проблема
Вы хотите знать, какие сигналы поддерживаются вашей операционной системой.
Решение
Если ваш командный интерпретатор поддерживает встроенную команду kill -/, используйте ее:
% kill -1
HUP INT QUIT ILL TRAP ABRT BUS FPE KILL USR1 SEGV USR2 PIPE ALRM TERM CHLO CONT STOP TSTP TTIN TTOU URG XCPU XFSZ VTALRM PROF WINCH POLL PWR
Чтобы сделать то же самое только на Perl версии 5 004 и выше, выведите ключи хэша %SIG:
% perl -e print ]oin( , keys %SIG) \n
XCPU ILL QUIT STOP EMT ABRT BUS USR1 XFSZ TSTP INT IOT USR2 INFO TTOU
ALRM KILL HUP URG PIPE CONT SEGV VTALRM PROF TRAP 10 TERM WINCH CHLD
FPE TTIN SYS
До выхода версии 5.004 приходилось использовать модуль Config:
% perl -MConfig -e print $Config{sig_name}
ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM URG STOP TSTP CONT CHLD TTIN TTOU 10 XCPU XFSZ VTALRM PROF WINCH INFO USR1 USR2 IOT
Комментарий
Если вы работаете в Perl версии младше 5.004, для получения списка сигналов вам также придется использовать @signame и %signo модуля Config, поскольку конструкция keys %SIG в ранних версиях еще не реализована.
Следующий фрагмент извлекает имена и номера доступных сигналов из стандартного модуля Config.pm. Индексирование @signame по номеру дает имя сигнала, а индексирование %signo по имени — номер сигнала.
use Config
defined $Config{sig_name} or die No sigs' ,
$i=0, # Config добавляет ложный сигнал 0
# с именем ZERO foreaoh $name (split( , $Config{sig_name})) {
$signo{$name} = $i,
$signame[$i] = $name,
> Смотри также
Документация по стандартному модулю Config; раздел «Signals» perlipc(\).
16.14. Посылка сигнала
Проблема
Требуется послать сигнал процессу. Возможна посылка сигнала как вашему собственному процессу, так и другому процессу в той же системе. Например, вы перехватили SIGINT и хотите передать его потомкам.
Решение
Функция kill отправляет сигнал с заданным именем или номером процессам, идентификаторы которых перечисляются в качестве остальных аргументов:
kill 9 => $pid, # Послать $pid сигнал 9
kill -1 => $pgrp, # Послать всему заданию сигнал 1
kill USR1 => $$, # Послать себе SIGUSR1
kill HUP => @pids, # Послать SIGHUP процессам из @pids
Комментарий
Функция Perl kill обеспечивает интерфейс к системной функции с тем же именем. Первый аргумент определяет посылаемый сигнал и задается по номеру или по имени; остальные аргументы определяют идентификаторы процессов, которым отправляется сигнал. Функция возвращает количество процессов, успешно получивших сигнал. Сигналы можно отправлять только процессам, для которых реальный или сохраненный идентификатор пользователя совпадает с вашим реальным или текущим идентификатором — если только вы не являетесь привилегированным пользователем.
Если номер сигнала отрицателен, Perl интерпретирует остальные аргументы как идентификаторы групп процессов и отправляет сигнал процессам, входящим в эти группы, с помощью системной функции killpg(2).
Группа процессов фактически представляет собой задание. Именно так операционная система объединяет родственные процессы. Например, когда вы с помощью командного интерпретатора сцепляете две команды, при этом запускаются два процесса, но лишь одно задание. Когда текущее задание прерывается по Ctrl+C
Функция kill также позволяет проверить, жив ли процесс. Посылка специального псевдосигнала с номером 0 сообщает, можно ли послать сигнал процессу — хотя сам сигнал при этом не передается. Если функция возвращает true, процесс жив. Если возвращается false, процесс либо сменил свой действующий идентификатор (в этом случае переменной $' присваивается EPERM), либо прекратил существование ($! присваивается ESRCH). Для процессов-зомби (см. рецепт 16.19) также возвращается ESRCH.
use POSIX qw( errno_h)
if (kill 0 => $mimon) {
print Sminion is alive1\n , } elsif ($i == EPERM) { # Изменился UID
print $ mimon has escaped my control1 \n , } elsif ($' == ESRCH) {
print $mimon is deceased \n , 8 Или зомби } else {
warn Odd, I couldn t check on the status of $mimon $>\n
D> Смотри также------------------------------------------------------------------------------------------
Раздел «Signals» perlipc{\); страницы руководства sigaction{2), signaled) и Ы1{2) вашей системы (если есть); описание функции kill в perljunc(l).
16.15. Установка обработчика сигнала
Проблема
Вы хотите управлять реакцией программы на сигналы. Это может понадобиться для перехвата Ctrl+C, избежания накопления завершившихся подпроцессов или предотвращения гибели вашего процесса при попытке передать данные исчезнувшему потомку.
Решение
Воспользуйтесь хэшем %SIG для установки обработчика по имени или ссылке на код:
SSIGiQUIT} = \&got_sig_quit, й Вызвать &got_sig_quit
# для каждого SIGQUIT
$SIG{PIPE} = got_sig_pipe , # Вызвать mam got_sig_pipe
# для каждого SIGPIPE
$SIG{INT) = sub { $ouch++ } й Увеличить $ouch для каждого SIGINT
Хэш %SIG также позволяет игнорировать сигнал:
$SIG{INT} = IGNORE , # Игнорировать сигнал INT
Также есть возможность восстановить стандартный обработчик сигнала:
16.16. Временное переопределение обработчика сигнала 589
$SIG{STOP) = DEFAULT # Восстановить стандартный обработчик
# сигнала STOP
Комментарий
Хэш %SIG используется в Perl для управления тем, что происходит при получении сигналов. Каждый ключ %SIG соответствует определенному сигналу, а значение — действию, которое должно предприниматься при его получении. В Perl предусмотрены два особых ассоциированных значения: IGNORE означает, что при получении сигнала не следует выполнять никаких действий, a DEFAULT выполняет стандартные действия UNIX для данного сигнала.
Хотя программисты на С привыкли к термину SIGINT, в Perl используется только INT. Предполагается, что имена сигналов используются только в функциях, связанных с обработкой сигналов, поэтому префикс SIG оказывается лишним. Следовательно, чтобы изменить действия вашего процесса при получении сигнала SIGCHLD, следует присвоить значение $SIG{CHLD}.
Чтобы ваш код выполнялся при получении конкретного сигнала, в хэш заносится либо ссылка на код, либо имя функции (следовательно, при сохранении строки вам не удастся использовать обработчик с именем IGNORE или DEFAULT; впрочем, для обработчика сигнала эти имена выглядят довольно странно) Если имя функции не содержит информации о пакете, Perl считает, что функция принадлежит пакету main , а не тому пакету, в котором обработчик был установлен. Ссылка на код относится к конкретному пакету, и этот вариант считается предпочтительным.
Perl передает коду обработчика один аргумент: имя сигнала, по которому он вызывается (например, INT или USR1 ). При выходе из обработчика продолжается выполнение действий, выполнявшихся в момент поступления сигнала
Perl определяет два специальных сигнала,_ DIE и___ WARN . Обработчики этих
сигналов вызываются каждый раз, когда программа на Perl выводит предупреж
дение (warn) или умирает (die). Это позволяет нам перехватывать предупреждения
и по своему усмотрению обрабатывать их или передавать дальше. На время свое
го выполнения обработчики die и warn отключаются, поэтому вы можете спокой
но вызвать die в обработчике DIE_ или warn в обработчике WARN , не опаса
ясь рекурсии.
> Смотри также---------------------------------------------------------------------------------------------
Раздел «Signals» perlipc(l); страницы руководства sigaction(2), signal(3) и kill(2) вашей системы (если есть).
16.16. Временное переопределение обработчика сигнала
Проблема
Вы хотите установить обработчик сигнала, действующий только на время выполнения конкретной подпрограммы. Например, ваша подпрограмма перехватывает
Решение
Используйте local для временного переопределения обработчика:
# Обработчик сигнала sub ding {
$SIG{INT) = \&ding;
warn "\aEnter your name'\n";
# Запросить имя с переопределением SIGINT sub get_name {
local $SIG{INT} = \&dmg;
my $name;
print "Kindly Stranger, please enter your name' chomp( $name = <> ); return $name;
Комментарий
Для временного сохранения одного элемента %SIG необходимо использовать local, а не ту. Изменения продолжают действовать во время выполнения блока, включая все, что может быть вызвано из него. В приведенном примере это подпрограмма get_name. Если сигнал будет доставлен во время работы другой функции, вызванной вашей функцией, сработает ваш обработчик сигнала — если только вызванная подпрограмма не установила собственный обработчик. Предыдущее значение элемента хэша автоматически восстанавливается при выходе из блока. Это один из немногочисленных случаев, когда динамическая область действия оказывается скорее удобной, нежели запутанной.
> Смотри также---------------------------------------------------------------------------------------------
Рецепты 10.13; 16.15; 16.18.
16.17. Написание обработчика сигнала
Проблема
Требуется написать подпрограмму, которая будет вызываться программой при каждом получении сигнала.
Решение
Обработчик сигнала представляет собой обычную подпрограмму. С некоторой степенью риска в обработчике можно делать все, что допустимо в любой другой подпрограмме Perl, но чем больше вы делаете, тем больше рискуете.
В некоторых системах обработчик должен переустанавливаться после каждого сигнала:
$SIG{INT} = \&got_int; sub got_int {
$SIG{INT} = \&got_mt; tt Но не для SIGCHLD!
# . . . }
Некоторые системы перезапускают блокирующие операции (например, чтение данных). В таких случаях необходимо вызвать в обработчике die и перехватить вызов eval:
my Sinterrupted = 0;
sub got_int {
Sinterrupted = 1;
$SIG{INT} = 'DEFAULT'; # или 'IGNORE'
die;
eval {
$SIG{INT} = \&got_int;
# .. Длинный код, который нежелательно перезапускать
if (Sinterrupted) {
# Разобраться с сигналом
Комментарий
Установка собственного обработчика сигнала напоминает игру с огнем: это очень интересно, но без исключительной осторожности вы рано или поздно обожжетесь. Создание кода Perl, предназначенного для обработки сигналов, чревато двумя опасностями. Во-первых, многие библиотечные функции нереентерабельны. Если сигнал прерывает выполнение какой-то функции (например, malloc(3) или printf(3)), а ваш обработчик сигнала снова вызовет ее, результат окажется непредсказуемым — обычно работа программы прерывается с выводом в файл содержимого памяти (core dump). Во-вторых, на нижних уровнях нереентерабелен сам Perl (версия 5.005 будет поддерживать облегченные процессы, называемые нитями (threads), но на момент издания этой книги она еще не вышла). Если сигнал прерывает Perl в момент изменения его собственных внутренних структур данных, результат тоже непредсказуем — как правило, выдаются случайные дампы.
Перед вами открываются два пути: параноидальный и практический. Параноик постарается ничего не делать внутри обработчика сигнала; примером служит код с eval и die в решении — мы присваиваем значение переменной и тут же выходим из обработчика. Но даже это покажется слишком рискованным настоящему параноику, который избегает die в обработчиках — вдруг система на что-нибудь обидится? Практический подход — вы говорите: «Кто не рискует, тот не выигрывает», — и делаете в обработчике все, что заблагорассудится.
Первоначальная реализация сигналов была ненадежной. Это означало, что во время работы обработчика при других поступлениях сигнала происходило некоторое стандартное действие (обычно аварийное завершение программы). Новые системы решают эту проблему (конечно, каждая — в своем, слегка особом стиле), позволяя подавлять другие экземпляры сигналов с данным номером до завершения обработчика. Если Perl обнаружит, что ваша система может использовать надежные сигналы, он генерирует соответствующие вызовы системных функций, чтобы программы вели себя более логично и безопасно. Система сигналов POSIX позволяет запретить доставку сигналов и в другие моменты времени (см. рецепт 16.20).
Чтобы получить по-настоящему переносимый код, программист-параноик заранее предполагает самое худшее (ненадежные сигналы) и вручную переустанавливает обработчик сигналов, обычно в самом начале функции:
$SIG{INT} = \&catcher sub catcher {
П
$SIG{INT} = \&catcher, }
Особый случай перехвата SIGCHLD описан в рецепте 16.19. System V ведет себя очень странно и может сбить с толку.
Чтобы узнать, располагаете ли вы надежными сигналами, воспользуйтесь модулем Config:
use Config,
print Hurrah1\n if $Config{d_sigaction}
Наличие надежных сигналов еще не означает, что вы автоматически получаете надежную программу. Впрочем, без них программа заведомо окажется ненадежной.
Первые реализации сигналов прерывали медленные вызовы системных функций, которые требовали взаимодействия со стороны других процессов или драйверов устройств. Если сигнал поступает во время выполнения этих функций, они (и их аналоги в Perl) возвращают признак ошибки и присваивают коду ошибки EINTR, Interrupted system call . Проверка этого условия настолько усложняет программу, что во многих случаях это вообще не делается, поэтому при прерывании сигналом медленных системных функций программа начинает вести себя неверно или аварийно завершается. Большинство современных версий UNIX позволяет изменить ход событий. Perl всегда делает системные функции перезапускаемыми, если эта возможность поддерживается системой. В системах POSIX можно управлять перезапуском с помощью модуля POSIX (см. рецепт 16.20).
Чтобы узнать, будет ли прерванная системная функция автоматически перезапущена, загляните в заголовочный файл signal.h вашей системы:
% egrep S[AV]_(RESTART|INTERRUPT) /usr/include/*/signal h
16.18. Перехват Ctrl+C 593
Два сигнала не перехватываются и не игнорируются: SIGKILL и SIGSTOP. Полная информация о сигналах вашей системы и об их значении приведена в странице руководства signal{2>).
\> Смотри также-------------------------------------------------------------------------------------------
Раздел «Signals» perlipc{\); страницы руководства sigaction(2), signal(3) и kill{2) вашей системы (если есть).
16.18. Перехват Ctrl+C
Проблема
Требуется перехватить нажатие Ctrl+C, приводящее к остановке работы программы. Вы хотите либо игнорировать его, либо выполнить свою собственную функцию при получении сигнала.
Решение
Установите обработчик для SIGINT. Присвойте ему IGNORE , чтобы нажатие Ctrl+C игнорировалось:
$SIG{INT} = IGNORE ,
Или установите собственную подпрограмму, которая должна реагировать на Ctrl+C:
$SIG{INT} = \&tsktsk,
sub tsktsk {
$SIG{INT} = \&tsktsk, # См Написание обработчика сигнала warn \aThe long habit of living mdisposeth us for dying \n ,
}
Комментарий
Ctrl+C не влияет на вашу программу напрямую. Драйвер терминала, обрабатывающий нажатия клавиш, опознает комбинацию Ctrl+C (или другую комбинацию, заданную вами в качестве символа прерывания при настройке параметров терминала) и посылает SIGINT каждому процессу активной группы {активного задания) данного терминала. Активное задание обычно состоит из всех программ, запущенных отдельной строкой в командном интерпретаторе, а также всех программ, запущенных этими программами. За подробностями обращайтесь к разделу введения «Сигналы».
Символ прерывания — не единственный служебный символ, интерпретируемый драйвером терминала. Текущие параметры терминала можно узнать с помощью команды stty -a:
% stty -a
speed 9600 baud; 38 rows; 80 columns;
lflags: ioanon lsig lexten echo echoe -echok echoke -echonl echoctl
brkint -inpck -ignpar -parmrk oflags: opost onlcr oxtabs cflags: cread cs8 -parenb -parodd hupcl -clocal -cstopb -crtscts -dsrflow
-dtrflow -radmbuf cchars: discard = "0; dsusp = "Y; eof = "D; eol = <undef;>
eol2 = <undef; erase = "H; intr = "C; kill = ~U; lnext = ~V;>
min = 1; quit = "\; reprint = "R; start = "Q; status = <undef;>
stop = ~S; susp = ~Z; time = 0; werase = ~W;
В последней секции, cchars:, перечисляются служебные символы. В рецепте 15.8 показано, как изменить в сценарии без вызова программы stty.
> Смотри также---------------------------------------------------------------------------------------------
Страница руководства stty(l) вашей системы (если есть); рецепты 15.8; 16.17.
16.19. Уничтожение процессов-зомби
Проблема
Программа создает порожденные процессы с помощью fork. Зомби накапливаются, забивают таблицу процессов и раздражают системного администратора.
Решение
Если вам не нужно регистрировать завершившихся потомков, используйте:
$SIG{CHLD} = IGNORE',
Чтобы следить за умирающими потомками, установите обработчик SIGCHLD с вызовом waitpid:
use POSIX sys_wait_h",
$SIG{CHLD} = \&REAPER; sub REAPER {
my $stiff;
while ($stiff = waitpid(-1, &WNOHANG) > 0) { # Обработать Sstiff, если нужно
}
$SIG<CHLD} = \&REAPER; # Установить «после* вызова waitpid
Комментарий
Когда процесс завершается, система оставляет его в таблице процессов, чтобы родитель мог проверить его статус, то есть узнать, как завершился потомок, нормально или аварийно. Определение статуса потомка (после которого он получает воз-
можность навсегда покинуть систему) называется «чисткой» (reaping). В этом рецепте приведены различные рекомендации по чистке зомби. В процессе чистки используется вызов wait или waitpid. Некоторые функции Perl (конвейерные вызовы open, system и . . ') автоматически вычищают созданных ими потомков, но при запуске другого процесса с помощью fork вам придется дожидаться его завершения.
Чтобы избежать накопления зомби, достаточно сообщить системе, что они вас не интересуют. Для этого $SIG{CHLD} присваивается значение ' IGNORE". Если вы хотите узнать, когда скончался тот или иной потомок, необходимо использовать waitpid.
Функция waitpid вычищает один процесс. Ее первый аргумент определяет идентификатор процесса (-1 означает любой процесс), а второй — набор флагов. Флаг WNOHANG заставляет waitpid немедленно вернуть 0, если нет ни одного мертвого потомка. Флаг 0 поддерживается всеми системами и означает блокирующий вызов. Вызов waitpid в обработчике SIGCHLD (см. решение) вычищает потомков сразу после их смерти.
Функция wait тоже вычищает потомков, но она вызывается только в блокирующем режиме. Если случайно вызвать ее при наличии работающих потомков, ни один из которых не умер, программа приостанавливается до появления зомби.
Поскольку ядро следит за недоставленными сигналами посредством битового вектора (по одному биту на сигнал), если до перехода вашего процесса в активное состояние умрут два потомка, процесс все равно получит один сигнал SIGCHLD. Чистка в обработчике SIGCHLD всегда выполняется в цикле, поэтому wait использовать нельзя.
И wait и waitpid возвращают идентификатор только что вычищенного процесса и присваивают Р его статус ожидания. Код статуса в действительности состоит из двух 8-разрядных значений, объединенных в одном 16-разрядном числе. Старший байт определяет код возврата процесса. Младшие 7 бит определяют номер сигнала, убившего процесс, а 8-й бит показывает, произошла ли критическая ошибка. Составляющие можно выделить следующим образом:
$exit_value = $? » 8, $signal_num = Р & 127; $dumped_core = р & 128;
Стандартный модуль POSIX содержит специальные макросы для выделения составляющих статуса: WIFEXITED, WEXITSTATUS, WIFSIGNALLED и WTERMSIG. Как ни странно, POSIX не содержит макроса для определения того, произошла ли критическая ошибка.
При использовании SIGCHLD необходимо помнить о двух обстоятельствах. Во-первых, сигнал SIGCHLD посылается системой не только при завершении потомка; сигнал также посылается при остановке. Процесс может остановиться по многим причинам — он может ожидать перехода в активное состояние для выполнения терминального ввода/вывода, получить сигнал SIGSTOP (после чего будет ожидать SIGCONT для продолжения работы) или быть приостановленным с терминала. Проверьте статус функцией WIFEXITED1
модуля POSIX, чтобы убедиться, что процесс действительно умер, а не был остановлен:
$SIG{CHLD} = \&REAPER, sub REAPER { my $pid,
$pid = waitpid(-1, &WNOHANG),
if ($pid == -1) {
# Ожидающих потомков нет Игнорировать } elsif (WIFEXITED($'?)) {
print Process $pid exited \n , } else {
print False alarm on $pid \n , }
$SIG{CHLD} = \&REAPER, # На случай ненадежных сигналов
}
Вторая ловушка, связанная с SIGCHLD, относится к Perl, а не к операционной
системе. Поскольку system, open и запускают подпроцессы через fork, а опера-
ционная система отправляет процессу SIGCHLD при выходе из любого подпроцесса, вызов обработчика может быть и непредвиденным. Встроенные операции сами ожидают завершения потомков, поэтому иногда SIGCHLD прибывает до того, как вызов close для манипулятора заблокирует его для чистки. Если первым до него доберется обработчик сигнала, то к моменту нормального закрытия зомби уже не будет. В результате close вернет false и присвоит $'значение No child processes . Если вызов close первым доберется до умершего потомка, waitpid возвращает 0.
В большинстве систем поддерживается неблокирующий режим waitpid. Об этом можно узнать из стандартного модуля Perl Config.pm:
use Config,
$has_nonblocking = $Config{d_waitpid} eq define | | $Config{d_wait4} eq define ,
System V определяет сигнал SIGCLD, который имеет тот же номер, что и SIGCHLD, но слегка отличается по семантике. Чтобы избежать путаницы, используйте SIGCHLD.
Е> Смотри также-------------------------------------------------------------------------------------------
Раздел «Signals» perlipc(l); описание функций wait и waitpid в perlfunc(l); документация по стандартному модулю POSIX; страницы руководства sigaction{2), signal(3) и kill(2) вашей системы (если есть); рецепт 16.17.
16.20. Блокировка сигналов
Проблема
Требуется отложить прием сигнала — например, чтобы предотвратить непредсказуемые последствия от сигналов, которые могут прервать программу в любой момент.
Решение
Воспользуйтесь интерфейсом модуля POSIX к системной функции sigprocmask (только в POSIX-совместимых системах).
Блокировка сигнала на время выполнения операции выполняется так:
use POSIX qw( signal_h),
$sigset = POSIX SigSet->new(SIGINT), # Определить блокируемые сигналы
$old_sigset = POSIX SigSet->new, ft Для хранения старой маски
unless (defined sigprocmask(SIG_BLOCK $sigset, $old_sigset)) {
die Could not block SIGINT\n , }
Снятие блокировки выполняется так:
unless (defined sigprocmask(SIG_UNBLOCK, $old_sigset)) {
die Could not unblock SIGINT\n , }
Комментарий
В стандарт POSIX входят функции sigaction и sigprocmask, которые позволяют лучше управлять доставкой сигналов. Функция sigprocmask управляет отложенной доставкой сигналов, a sigaction устанавливает обработчики. При изменении %SIG Perl по возможности использует sigaction.
Чтобы использовать sigprocmask, сначала постройте набор сигналов методом POSIX SigSet->new. В качестве аргумента передается список номеров сигналов. Модуль POSIX экспортирует функции, возвращающие номера сигналов; имена функций совпадают с именами сигналов:
use POSIX qw( signal_h),
$sigset = POSIX SigSet->new( SIGINT, SIGKILL ),
Передайте объект POSIX::SigSet функции sigprocmask с нужным флагом. Флаг SIG_BLOCK откладывает доставку сигнала. Флаг SIG_UNBLOCK восстанавливает нормальную доставку сигналов, a SIG_GETMASK блокирует только сигналы, содержащиеся в POSIX::SigSet. Самые отчаянные перестраховщики блокируют сигналы при вызове fork, чтобы предотвратить вызов обработчика сигнала в порожденном процессе перед тем, как Perl обновит его переменную $$ (идентификатор процесса). Если обработчик сигнала вызывается немедленно и сообщает значение $$, то вместо своего собственного $$ он может использовать родительское значение. Такая проблема возникает очень редко.
> Смотри также---------------------------------------------------------------------------------------------
Страница руководства sigprocmask(2) вашей системы (если есть); документация по стандартному модулю POSIX.
Проблема
Вы хотите гарантировать, что продолжительность некоторой операции не превышает заданный промежуток времени. Допустим, вы проводите архивацию файловой системы и хотите прервать ее, если она затянется более чем на час. Или вы хотите, чтобы через час произошло некоторое событие.
Решение
Чтобы прервать затянувшуюся операцию, используйте обработчик SIGALRM и вызовите в нем die. Установите таймер функцией alarm и включите код в eval:
$SIG{ALRM} = sub { die timeout },
eval {
alarm(3600),
# Продолжительные операции
alarm(O),
if ($<9>) {
if ($@ =~ /timeout/) <
# Тайм-аут, сделайте то, что считаете нужным } else {
die, # Передать дальше неожиданное исключение
Комментарий
Функция alarm получает один аргумент: целое число секунд, после истечения которых ваш процесс получит SIGALRM. В сильно загруженных системах с разделением времени сигнал может быть доставлен позже указанного времени. По умолчанию SIGALRM завершает программу, поэтому вы должны установить собственный обработчик сигнала.
Функции alarm нельзя ( с пользой) передать дробное число секунд; если вы попытаетесь это сделать, число секунд будет округлено до целого. Создание более точных таймеров рассматривается в рецепте 3.9.
> Смотри также---------------------------------------------------------------------------------------------
Раздел «Signals» perlipc(l); описание функции alarm в perlfunc(i); рецепт 3.9.
16.22. Программа: sigrand
Следующая программа выдает случайные подписи с применением именованных каналов. Предполагается, что файл подписей хранится в формате программы fortune — то есть каждый многострочный блок завершается последовательностью %%\п . Приведем пример:
Make is like Pascal everybody likes it, so they go in and change it
--Dennis Ritchie %%
I eschew embedded capital letters m names, to my prose-oriented eyes, they are too awkward to read comfortably They jangle like bad typography
--Rob Pike %% God made the integers, all else is the work of Man
--Kronecker %%
I'd rather have rofix than const --Dennis Ritchie %%
If you want to program in C, program in С It s a nice language
I use it occasionally -) --Larry Wall
%% Twisted cleverness is my only skill as a programmer
--Elizabeth Zwicky %%
Basically, avoid comments If your code needs a comment to be understood, it would be better to rewrite it so it s easier to understand
--Rob Pike %% Comments on data are usually much more helpful than on algorithms
--Rob Pike %% Programs that write programs are the happiest programs in the world
--Andrew Hume %%
Мы проверяем, не была ли программа запущена ранее — для этого используется файл с идентификатором процесса. Если посылка сигнала с номером 0 показывает, что идентификатор процесса все еще существует (или, что случается редко — что им воспользовался кто-то другой), программа просто завершается. Также мы проверяем текущую отправку Usenet и решаем, следует ли искать специализированные файлы подписей для конкретных конференций. В этом случае можно завести разные подписи для каждой конференции, в которую вы пишете. Для большего разнообразия глобальный файл подписей иногда применяется даже при наличии специализированного файла.
Программа sigrand может использоваться даже в системах без именованных каналов — достаточно удалить код создания именованного канала и увеличить паузу перед обновлениями файла. После этого .signature может быть обычным файлом. Другая проблема переносимости возникает при переходе программы в фоновый режим (при котором она почти становится демоном). Если функция fork недоступна, просто закомментируйте ее.
Полный текст программы приведен в примере 16.12.
Пример 16.12. sigrand
#'/usr/bin/perl -w
# sigrand - выдача случайных подписей для файла signature
продолжение &
use strict;
# Конфигурационные переменные
use vars qw( $NG_IS_DIR $MKNOO $FULLNAME $FIFO $ART $NEWS $SIGS $SEMA SGLOBRAND $NAME );
# Глобальные имена
use vars qw( $Home $Fortune_Path @Pwd );
####################й##########################################Я tf Начало секции конфигурации
# В действительности следует читать из Y.sigrandrc
gethome();
# rec/humor/funny вместо гее.humor funny
$NG_IS_DIR = 1;
$MKNOD = "/bin/mknod",
$FULLNAME = "$Home/.fullname",
$FIFO = "$Home/ signature";
$ART = " $Home/.article";
$NEWS = "$Hoine/News";
$SIGS = "$NEWS/SIGNATURES ;
$SEMA = "$Home/.sigrandpid';
$GLOBRAND = 1/4; # Вероятность использования глобальных
# подписей при наличии специализированного файла
# $NAME следует: (1) оставить неопределенным, чтобы программа
# попыталась угадать адрес подписи (возможно, заглянув
# в "/ fullname, (2) присвоить точный адрес, или (3) присвоить
8 пустую строку, чтобы отказаться от использования имени
$NAME = ' '; и Означает, что имя не используется ## $NAME = "me\@home.org\n";
й Конец секции конфигурации -- НОМЕ и FORTUNE
# настраиваются автоматически
################################################################
setup(); # Выполнить инициализацию
justmeQ; # Убедиться, что программа еще не работает
fork && exit; # Перейти в фоновый режим
open (SEMA, "> $SEMA") or die "can't write $SEMA' $'";
print SEMA "$$\n";
close(SEMA) or die "can't close $SEMA- $!";
tt В бесконечном цикле записывать подпись в FIFO.
16.22. Программа: sigrand 601
й Если именованные каналы у вас не поддерживаются, измените 8 паузу в конце цикла (например, 10, чтобы обновление
# происходило только каждые 10 секунд),
for (;;) {
open (FIFO, ¦> $FIFO") or die "can't write $FIFO: $'";
my $sig = pick_quote();
for ($sig) {
s/"((:?[~\n]*\n){4}).4/$1/s, # Ограничиться 4 строками s/"(.{1,80}) *' *$/$1/gm; # Обрезать длинные строки
}
# Вывести подпись с именем, если оно присутствует,
# и дополнить до 4 строк
if ($NAME) {
print FIFO $NAME, "\n" x (3 - ($sig =~ tr/\n//)), $sig; } else {
print FIFO $sig, } close FIFO;
# Без небольшой паузы приемник не закончит чтение к моменту,
# когда передатчик снова попытается открыть FIFO;
# поскольку приемник существует, попытка окажется успешной.
# В итоге появятся сразу несколько подписей.
й Небольшая пауза между открытиями дает приемникам возможность
# завершить чтение и закрыть канал.
select(undef, undef, undef, 0 2); # Выждать 1/5 секунды } die "XXX: NOT REACHED"; # На эту строку вы никогда не попадете
#й###й#й##ййййй######й#й##й##й#####й##й#й#й##й################йй
# Игнорировать SIGPIPE на случай, если кто-то открыл FIFO и
8 снова закрыл, не читая данных; взять имя пользователя из файла
й .fullname. Попытаться определить полное имя хоста. Следить за
й амперсандами в паролях. Убедиться, что у нас есть подписи или
й цитаты. При необходимости построить FIFO.
sub setup {
$SIG{PIPE} = 'IGNORE';
unless (defined $NAME) { # Если $NAME не определено if (-e $FULLNAME) { # при конфигурации $NAME = 'cat $FULLNAME'; die "$FULLNAME should contain only 1 line, aborting'
if $NAME =" tr/\n// > 1; } else {
my($user, $host); chop($host = 'hostname');
продолжение &
($host) = gethostbyname($host) unless Shost =" /\ /, $user = $ENV{USER} || $ENV{LOGNAME} || $Pwd[O]
or die "intruder alert", ($NAME = $Pwd[6]) =- s/, *//,
$NAME =" s/&/\u\L$user/g; # До сих пор встречается $NAME = "\t$NAME\t$user\(3$host\n";
check_fortunes() if '-e $SIGS,
unless (-p $FIFO) { ft -p проверяет, является ли операнд
# именованным каналом if С-е _) {
system('$MKNOD $FIFO p') && die 'can't mknod $FIFO'; warn 'created $FIFO as a named pipe\n"; } else {
die '$0 won t overwrite file signature\n"; } } else {
warn '$0. using existing named pipe $FIFO\n",
# Получить хорошее начальное значение для раскрутки генератора. 8 Не нужно в версиях 5 004 и выше srand(time() " ($$ + ($$ « 15)));
# Выбрать случайную подпись sub pick_quote {
my $sigflie = signame(),
if (i-e Ssigfile) { return fortune();
}
open (SIGS, "< $sigfile' ) or die 'can't open $sigfile'
local $/ = '%%\n",
local $_; *
my $quip;
rand($ ) < 1 && ($quip = $_) while <SIGS>;
close SIGS,
chomp $quip;
return $quip || 'ENOSIG This signature file is empty \n';
# Проверить, содержит ли "/ article строку Newsgroups. Если содержит,
# найти первую конференцию и узнать, существует ли для нее
# специализированный набор цитат, в противном случае вернуть глобальный
и набор. Кроме того, время от времени возвращать глобальный набор
S для внесения большего разнообразия в подписи.
sub signame {
(rand(1 0) > ($GLOBRAND) && open ART) || return $SIGS,
local $/ = " ;
local $_ = <ART>;
my($ng) = /Newsgroups-\s*([",\s]*)/,
$ng =" s'\.!/»g if $NG_IS_DIR; # if rn -/, or SAVEDIR=%p/%c
$ng = "$NEWS/$ng/SIGNATURES",
return -f $ng ? $ng : $SIGS;
# Вызывать программу fortune с параметром -s до тех пор,
# пока мы не получим достаточно короткую цитату или не
# превысим лимит попыток
sub fortune {
local $_;
my $tnes = 0,
do {
$_ = $Fortune_Path -s', } until tr/\n// < 5 || $tnes++ > 20, s/7 /mg, $_ || " SIGRAND: deliver random signals to all processes.\n',
# Проверить наличие программы fortune, Определить полный путь
# и занести его в глобальную переменную
sub check_fortunes {
return if $Fortune_Path; # Уже найден
for my $dir (split(/:/, $ENV{PATH}), '/usr/games') <
return if -x ($Fortune_Path = "$dir/fortune"), > die "Need either $SIGS or a fortune program, bailing out';
# Определение каталога sub gethome <
@Pwd = getpwuid($<);
$Home = $ENV{HOME} || $ENV{LOGDIR} || $Pwd[7] or die 'no home directory for user $<";
# 'Останется только один' -- из фильма 'Горец' sub justme {
if (open SEMA) {
my $pid,
chop($pid = <SEMA>),
kill(0, $pid) and die "$0 already running (pid $pid), bailing out'
close SEMA;
 |
Сокеты
Глендаур: Я духов вызывать могу из бездны.
Хотспер: И я могу, и каждый это может,
Вопрос лишь, явятся ль они на зов.
Вильям Шекспир, «Генрих IV»
Введение
Сокеты являются «конечными пунктами» в процессе обмена данными. Одни типы сокетов обеспечивают надежный обмен данными, другие почти ничего не гарантируют, зато обеспечивают низкий расход системных ресурсов. Обмен данными через сокеты может осуществляться на одном компьютере или через Интернет.
В этой главе мы рассмотрим два самых распространенных типа сокетов: потоковые и датаграммные. Потоковые сокеты обеспечивают двусторонние, последовательные и надежные коммуникации; они похожи на каналы (pipes). Датаграммные сокеты не обеспечивают последовательную, надежную доставку, но они гарантируют, что в процессе чтения сохранятся границы сообщений. Ваша система также может поддерживать сокеты других типов; за подробностями обращайтесь к man-странице socket(2) или эквивалентной документации.
Сокеты делятся по областям (domain): сокеты Интернета и сокеты UNIX. Имя сокета Интернета содержит две составляющие: хост (IP-адрес в определенном формате) и номер порта. В мире UNIX сокеты представляют собой файлы (например, /tmp/mysock).
Кроме области и типа, с сокетом также ассоциируется определенный протокол. Протоколы не имеют особого значения для рядового программиста, поскольку для конкретного сочетания области и типа сокета редко используется более одного протокола.
Области и типы обычно идентифицируются числовыми константами (которые возвращаются функциями, экспортируемыми модулями Socket и IO::Socket). Потоковые сокеты имеют тип SOCK_STREAM, а датаграммные — SOCK_DGRAM. Области Интернета соответствует константа PF_INET, а области UNIX — константа PF_UNIX (в POSIX вместо PF_UNIX используется PF_LOCAL, но PF_UNIX почти всегда допустима просто потому, что используется в огромном количестве
существующих программ). Используйте символические имена вместо числовых значений, поскольку последние могут измениться (что неоднократно происходило).
Имена протоколов (например, tcp и udp) тоже соответствуют числам, используемым операционной системой. Встроенная функция Perl getprotobyname возвращает номер по имени протокола. Если функциям сокетов передается значение 0, система выберет подходящий протокол по умолчанию.
Perl содержит встроенные функции для создания сокетов и управления ими; они в основном дублируют свои прототипы на С. Хотя это удобно для получения низкоуровневого, прямого доступа к системе, большинство предпочитает работать с более удобными средствами. На помощь приходят классы IO::Socket::INET и IO::Socket::UNIX — они обеспечивают высокоуровневый интерфейс к низкоуровневым системным функциям.
Начнем с рассмотрения встроенных функций. В случае ошибки все они возвращают undef и присваивают $! соответствующее значение. Функция socket создает сокет, bind — назначает ему локальное имя, connect — подключает локальный сокет к другому (возможно, удаленному). Функция listen готовит сокет к подключениям со стороны других сокетов, a accept последовательно принимает подключения. При обмене данными с потоковыми сокетами можно использовать как print и о, так и syswrite и sysread, а при обмене с датаграммными сокетами — send и recv.
Типичный сервер вызывает socket, bind и listen, после чего в цикле вызывает accept в блокирующем режиме, ожидая входящих подключений (см. рецепты 17.2 и 17.5). Типичный клиент вызывает socket и connect (см. рецепты 17.1 и 17.4). Да-таграммные клиенты ведут себя особым образом. Они не обязаны вызывать connect для передачи данных, поскольку могут указать место назначения в качестве аргумента send.
При вызове bind, connect или send для конкретного приемника необходимо указать имя сокета. Имя сокета Интернета состоит из хоста (IP-адрес, упакованный функцией met_aton) и порта (числа), объединенных в С-подобную структуру функцией sockadd г_ш:
use Socket;
$packed_ip = inet_aton('208.146 240 1'); $socket_name = sockaddr_in($port, $packed_ip);
Имя сокета UNIX представляет собой имя файла, упакованное в структуру С функцией sockaddr_un:
use Socket,
$socket_name = sockaddr_un("/tmp/mysock'),
Чтобы преобразовать упакованное имя сокета и снова получить имя файла или пару «хост/порт», вызовите sockaddr_un или sockaddr_in в списковом контексте:
(Sport, $packed_ip) = sockaddr_in($socket_name); U Для сокетов PF_INET (Sfilename) = sockaddr_un($socket_name); # Для сокетов PF_UNIX
Функция inet_ntoa преобразует упакованный IP-адрес в ASCII-строку.
606 Глава 17 • Сокеты
$ip_address = inet_ntoa($packed_ip); $packed_ip = met_aton( "204.148.40.9"); $packed_ip = inet_aton("www.oreilly.com");В большинстве рецептов используются сокеты Интернета, однако практически все сказанное в равной мере относится и к сокетам UNIX. В рецепте 17.6 объясняются отличия и возможные расхождения.
Сокеты являются основой для работы сетевых серверов. Мы рассмотрим три варианта построения серверов: в первом для каждого входящего подключения создается порожденный процесс (рецепт 17.11), во втором сервер создает порожденные процессы заранее (рецепт 17.12), а в третьем процесс-сервер вообще не создает порожденные процессы (рецепт 17.13).
Некоторые серверы должны одновременно вести прослушивание по многим IP-адресам (см. рецепт 17.14). Хорошо написанный сервер деинициализируется и перезапускается при получении сигнала HUP; в рецепте 17.16 показано, как реализовать такое поведение в Perl. Кроме того, вы узнаете, как идентифицировать оба конца соединения (см. рецепты 17.7 и 17.8).
17.1. Написание клиента TCP
Проблема
Вы хотите подключиться к сокету на удаленном компьютере.
Решение
Следующее решение предполагает, что связь осуществляется через Интернет. TCP-подобные коммуникации на одном компьютере рассматриваются в рецепте 17.6. Либо воспользуйтесь стандартным (для версии 5.004) классом IO::Socket;:INET:
use 10::Socket;
$socket = 10::Socket::INET->new(PeerAddr => $remote_host,
PeerPort => $remote_port, Proto => "tcp", Type => SOCK_STREAM) or die "Couldn't connect to $remote_host:$remote_port ; $@\n",
# .. . Сделать что-то с сокетом
print Ssocket "Why don't you call me anymoreAn";
$answer = <$socket>;
# Отключиться после завершения
close($socket);
либо создайте сокет вручную, чтобы лучше управлять его поведением:
use Socket;
й Создать сокет
socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname(' top'));
# Построить адрес удаленного компьютера $mternet_addr = inet_aton($remote_host)
or die "Couldn't convert $remote_host into an Internet address: $'\n";
jr = sockaddr_in($remote_port, $internet_addr);
# Подключиться
connect(TO_SERVER, $paddr)
or die "Couldn't connect to $remote_host:$remote_port : $'\n",
# ... Сделать что-то с сокетом
print TO_SERVER "Why don't you call me anymore'^";
# И отключиться после завершения
close(TO_SERVER);
Комментарий
Ручное кодирование состоит из множества действий, а класс IO::Socket::INET объединяет их все в удобном конструкторе. Главное, что необходимо знать, — куда вы направляетесь (параметры PeerAddr и PeerPort) и каким образом (параметр Туре). По переданной информации IO::Socket::INET пытается узнать все остальное. Так, протокол по возможности вычисляется по типу и номеру порта; если это не удается сделать, предполагается протокол tcp.
Параметр PeerAddr содержит строку с именем хоста ("www. oreilly. com") или его IP-адресом ("204.148.40.9"). PeerPort — целое число, номер порта для подключения. Номер порта можно включить в адрес в виде "www. oreilly. com: 80". Параметр Туре определяет тип создаваемого сокета: SOCK_DGRAM для датаграммного со-кета или SOCK_STREAM для потокового.
Чтобы подключиться через SOCK_STREAM к порту конкретного компьютера, не поддерживающего других возможностей, передайте 10: :Socket: :INET->new одну строку с именем хоста и портом, разделенными двоеточием:
Sclient = 10: :Socket::INET->new("www.yahoo,com:80") or die $@;
При возникновении ошибки IO::Socket::INET возвращает undef, а переменной $§ (не $!) присваивается сообщение об ошибке.
$s = 10::Socket::INET->new(PeerAddr => "Does not Exist",
Peerport => 80,
Type => SOCK_STREAM )
or die $@;
Если ваши пакеты бесследно исчезают в глубинах сети, вероятно, невозможность подключения к порту будет обнаружена лишь через некоторое время. Вы можете уменьшить этот промежуток, передавая параметр Timeout при вызове 10::Socket::INET->new():
$s = 10::Socket::INET->new(PeerAddr => "bad.host.com",
PeerPort => 80,
Туре => SOCK_STREAM,
Timeout => 5 ) or die $@;
Но в этом случае вы уже не сможете использовать $' или $@, чтобы узнать причину неудачи — невозможность подключения или тайм-аут. Иногда бывает удобнее установить тайм-аут вручную, без использования модуля.
INADDR_ANY — специальный адрес, означающий «прослушивание на всех интерфейсах». Если вы хотите ограничить его конкретным IP-адресом, включите параметр LocalAddr в вызов 10:: Socket:: INET->new. При ручном кодировании это делается так:
$inet_addr = inet_aton("208 146 240.1"), $paddr = sockaddr_m($port, $inet_addr); bind(SOCKET, $paddr) or die 'bind. $!",
Если вам известно только имя, действуйте следующим образом:
$inet_addr = gethostbyname("www.yahoo.com")
or die "Can't resolve www.yahoo.com: $'";
$paddr = sockaddr_in($port, $inet_addr);
bmd(SOCKET, $paddr) or die "bind. $!";
> Смотри также---------------------------------------------------------------------------------------------
Описание функций socket, bind, connect и gethostbyname вperlfunc(l); документация по стандартным модулям Socket, IO::Socket и Net::hostent; раздел «Internet TCP Clients and Servers» perlipc(l); рецепты 17.2—17.3.
17.2. Написание сервера TCP
Проблема
Вы хотите написать сервер, который ожидает подключения клиентов по сети к определенному порту.
Решение
Следующее решение предполагает, что связь осуществляется через Интернет. TCP-подобные коммуникации на одном компьютере рассматриваются в рецепте 17.6.
Воспользуйтесь стандартным (для версии 5.004) классом IO::Socket::INET:
use Ю- 'Socket;
$server = 10::Socket::INET->new(LocalPort => $server_port,
Type => SOCK_STREAM,
Reuse => 1,
Listen => 10 ) # or SOMAXCONN
or die "Couldn't be a tcp server on port $server_port : $@>\n";
while ($client = $server->accept()) { # Sclient - новое подключение
close($server);
Или создайте сокет вручную, что позволит получить полный контроль над ним:
use Socket;
# Создать сокет
socket(SERVER, PF_INET, SOCK_STREAM. getprotobyname('tcp'));
# Чтобы мы могли быстро перезапустить сервер
setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1);
# Построить свой адрес сокета
$my_addr = sockaddr_m($server_port, INADDR_ANY); bind(SERVER, $my_addr)
or die "Couldn't bind to port $server_port : $!\n";
# Установить очередь для входящих соединений
listen(SERVER, SOMAXCONN)
or die "Couldn't listen on port $server_port : $!\n";
(t Принимать и обрабатывать подключения while (accept(CLIENT, SERVER)) { # Сделать что-то с CLIENT
close(SERVER);
Комментарий
Написать сервер сложнее, чем клиент. Необязательная функция listen сообщает операционной системе, сколько подключений могут находиться в очереди к серверу, ожидая обслуживания. Функция setsockopt, использованная в решении, позволяет избежать двухминутного интервала после уничтожения сервера перед его перезапуском (полезна при тестировании). Функция bind регистрирует сервер в ядре. Наконец, функция accept последовательно принимает входящие подключения.
Числовой аргумент listen определяет количество не принятых функцией accept подключений, которые будут поставлены в очередь операционной системой перед тем, как клиенты начнут получать ошибки «отказ в обслуживании». Исторически максимальное значение этого аргумента было равно 5, но и сегодня многие операционные системы тайно устанавливают максимальный размер очереди равным примерно 20. Сильно загруженные Web-серверы стали распространенным явлением, поэтому многие поставщики увеличивают это значение. Максималь-
Функции accept передаются два аргумента: файловый манипулятор, подключаемый к удаленному клиенту, и файловый манипулятор сервера. Она возвращает IP-адрес и порт клиента, упакованные inet_ntoa:
use Socket;
while ($client_address = accept(CLIENT, SERVER)) {
(Sport, $packed_ip) = sockaddr_in($client_address);
$dotted_quad = inet_ntoa($packed_ip);
# Обработать }
В классах IO::Socket accept является методом, вызываемым для манипулятора сервера:
while (($client,$client_address) = $server->accept()) {
Если ожидающих подключений нет, программа блокируется на вызове accept до того, как появится подключение. Если вы хотите гарантировать, что вызов accept не будет блокироваться, воспользуйтесь неблокирующими сокетами:
use Fcntl qw(F_GETFL F_SETFL OJIONBLOCK);
$flags = fcntl($SERVER, F_GETFL, 0)
or die "Can t get flags for the socket $'\n',
$flags = fcntl($SERVER, F.SETFL, $flags | OJIONBLOCK)
or die 'Can' t set flags for the socket. $'\n";
Если теперь при вызове accept не окажется ожидающих подключений, accept вернет undef и присвоит $! значение EWOULDBLOCK.
Может показаться, что при возвращении нулевых флагов от F_GETFL будет вызвана функция die, как и при неудачном вызове, возвращающем undef. Это не так — неошибочное возвращаемое значение fcntl, как и для ioctl, преобразуется Perl в специальное значение "О but true". Для этой специальной строки даже не действуют надоедливые предупреждения флага -w о нечисловых величинах, поэтому вы можете использовать ее в своих функциях, когда возвращаемое значение равно 0 и тем не менее истинно.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций socket, bind, listen, accept, fcntl и setsockopt вperlfunc(l); страницы руководства fcntl(2), socket(2), setsockopt(2) вашей системы (если они есть); документация по стандартным модулям Socket, IO::Socket и Net::hostent; раздел «Internet TCP Clients and Servers» perlipc(l); рецепты 7.13—7.14; 17.1; 17.3; 17.7.
17.3. Передача данных через TCP
Проблема
Требуется передать или принять данные по ТСР-соединению.
Решение
Следующее решение предполагает, что связь осуществляется через Интернет. TCP-подобные коммуникации на одном компьютере рассматриваются в рецепте 17.6.
Первый вариант — print или <>:
print SERVER "What is your name'Xn", chomp ($response = <SERVER>);
Второй вариант — функции send и recv:
defined (send(SERVER, $data_to_send, Sflags)) or die "Can't send . $'\n";
recv(SERVER, $data_read, $maxlen, Sflags) or die 'Can't receive $j\n';
Третий вариант — соответствующие методы объекта IO::Socket:
use 10.:Socket;
$server->send($data_to_send, $flags) or die "Can't send $'\n ,
$server->recv($data_read, $flags) or die "Can't recv $!\n',
Чтобы узнать, могут ли быть получены или приняты данные, воспользуйтесь функцией select, для которой в классе IO::Socket также предусмотрена удобная оболочка:
use 10 'Select;
$select = 10 -Select->new();
$select->add(*FROM_SERVER);
$select->add($to_client);
@>read_from = $select->can_read($timeout); foreach $socket (@read_from) {
# Прочитать ожидающие данные из Ssocket }
Комментарий
Сокеты используются в двух принципиально различных типах ввода/вывода, каждый из которых обладает своими достоинствами и недостатками. Стандартные функции ввода/вывода Perl, используемые для файлов (кроме seek и sysseek),
При программировании сокетов очень важно помнить о буферизации. Хотя буферизация и была спроектирована для повышения быстродействия, она может повлиять на интерактивное поведение некоторых программ. Если при вводе данных с помощью о будет обнаружен разделитель записей, программа может попытаться прочитать из сокета больше данных, чем доступно в данный момент. И print и <> используют буферы stdio, поэтому без включения автоматической очистки буфера (см. введение главы 7 «Доступ к файлам») для манипулятора сокета данные не отправятся на другой конец в момент их передачи функцией print. Вместо этого они будут ждать заполнения буфера
Вероятно, для клиентов и серверов с построчным обменом данных это подходит — при условии, что вы не забыли включить автоматическую очистку буфера. Новые версии IO::Socket делают это автоматически для анонимных файловых манипуляторов, возвращаемых 10 Socket->new.
Но стандартный ввод/вывод — не единственный источник буферизации Операции вывода (print, printf, syswrite — или send для сокета TCP) буферизуются на уровне операционной системы по так называемому алгоритму Нейгла. Если пакет данных отправлен, но еще не подтвержден, другие передаваемые данные ставятся в очередь и отправляются либо после набора следующего полного пакета, либо при получении подтверждения. В некоторых ситуациях (события мыши в оконных системах, нажатия клавиш в приложениях реального времени) такая буферизация оказывается неудобной или попросту неверной. Буферизация Нейгла отключается параметром сокета TCP_NODELAY:
use Socket
require sys/socket ph , ft Для &TCP_NODELAY
setsockopt(SOCKET, SOL_SOCKET &TCP_NODELAY 1)
or die Couldn t disable Nagle s algorithm $'\n ,
Ее повторное включение происходит так:
setsockopt(SOCKET, SOL_SOCKET &TCPJJODEIAY, 0) or die Couldn t enable Nagle s algorithm $'\n
Как правило, TCP_NODELAY все же лучше не указывать. Буферизация TCP существует не зря, поэтому не отключайте ее без крайней необходимости — например, если ваше приложение работает в режиме реального времени с крайне интенсивным обменом пакетов.
ТС P_NO DELAY загружается из sys/socket.ph — этот файл не устанавливается автоматически вместе с Perl, но может быть легко построен. Подробности приведены в рецепте 12.14.
Буферизация чрезвычайно важна, поэтому в вашем распоряжении имеется функция select. Она определяет, какие манипуляторы содержат непрочитанный ввод, в какие манипуляторы возможна запись и для каких имеются необработанные «исключительные состояния». Функция select получает три строки, интерпретируемые как двоичные данные; каждый бит соответствует файловому манипулятору. Типичный вызов select выглядит так:
$пп = , # Инициализировать маску
vec($nn, fileno(SOCKET), 1) = 1, # Пометить SOCKET в $rin # Повторить вызовы vec() для каждого проверяемого сокета
$timeout = 10, # Подождать 10 секунд
$nfound = select($rout = $пп, undef, undef, $timeout), if (vec($rout fileno(socket) 1)){
# В SOCKET имеются данные для чтения >
Функция select вызывается с четырьмя аргументами. Три из них представляют собой битовые маски: первая проверяет в манипуляторах наличие непрочитанных данных в манипуляторах; вторая — возможность безопасной записи без блокировки; третья — наличие в них исключительных состояний. Четвертый аргумент определяет максимальную длительность ожидания в секундах (может быть вещественным числом).
Функция модифицирует передаваемые ей маски, поэтому при выходе из нее биты будут установлены лишь для манипуляторов, готовых к вводу/выводу. Отсюда один стандартный прием — входная маска ($пп в предыдущем примере) присваивается выходной ($rout), чтобы вызов select изменил только $rout и оставил $пп в прежнем состоянии.
Нулевой тайм-аут определяет режим опроса (проверка без блокировки). Некоторые начинающие программисты не любят блокировки, и в их программах выполняется «занятое ожидание» (busy-wait) — программа в цикле выполняет опрос, снова и снова. Когда программа блокируется, операционная система понимает, что процесс ждет ввода, и передает процессорное время другим программам до появления входных данных. Когда программа находится в «занятом ожидании», система не оставляет ее в покое, поскольку программа всегда что-то делает — проверяет ввод! Иногда опрос действительно является правильным решением, но гораздо чаще это не так. Тайм-аут, равный undef, означает отсутствие тайм-аута, поэтому ваша программа терпеливо блокируется до появления ввода.
Поскольку select использует битовые маски, которые утомительно создавать и трудно интерпретировать, в решении используется стандартный модуль IO::Select. Он обходит работу с битовыми масками и, как правило, более удобен.
Полное объяснение исключительных состояний, проверяемых третьей маской select, выходит за рамки настоящей книги.
Другие флаги send и recv перечислены в страницах руководства этих системных функций.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций send, recv, fileno, vec и setsockopt в perlfunc(i); разделы «I/O Operators» и «Bitwise String Operators» ърег1ор(1); страница руководства setsockopt(2) вашей системы (если есть); документация по стандартным модулям Socket и IO::Socket; раздел «Internet TCP Clients and Servers» perlipc(i); рецепты 17.1—17.2.
Проблема
Вы хотите обмениваться сообщениями с другим процессом, используя UDP (да-таграммы).
Решение
Чтобы создать манипулятор для сокета UDP, воспользуйтесь либо низкоуровневым модулем Socket для уже существующего манипулятора:
use Socket;
socket(SockHandle, PF_INET, SOCK_DGRAM, getprotobyname("udp')) or die "socket. $'";
либо модулем IO::Socket, возвращающим анонимный манипулятор:
use 10' -.Socket;
Shandle = 10::Socket::INET->new(Proto => 'udp')
or die "socket: $@"; # Да, здесь используется $@>
Отправка сообщения на компьютер с именем SHOSTNAME и адресом порта $PORTNO выполняется так:
$ipaddr = inet_aton(SHOSTNAME); Sportaddr = sockaddr_in($PORTNO, Sipaddr); send(SockHandle, $MSG, 0, Sportaddr) == length($MSG)
or die "cannot send to $HOSTNAME($PORTNO): $'';
Получение сообщения, длина которого не превышает $MAXLEN:
Sportaddr = recv(SockHandle, SMSG, $MAXLEN, 0) or die "recv: $'";
(Sportno, Sipaddr) = sockaddr_in($portaddr); Shost = gethostbyaddr($ipaddr, AF_INET); print "$host($portno) said SMSG\n';
Комментарий
Датаграммные сокеты не похожи на потоковые. Поток создает иллюзию постоянного соединения. Он напоминает телефонный звонок — установка связи обходится дорого, но в дальнейшем связь надежна и проста в использовании. Дата-граммы больше похожи на почту — если ваш знакомый находится на другом конце света, дешевле и проще отправить ему письмо, чем дозвониться по телефону. Да-таграммы потребляют меньше системных ресурсов, чем потоки. Вы пересылаете небольшой объем информации, по одному сообщению за раз. Однако доставка сообщений не гарантируется, и они могут быть приняты в неверном порядке. Если очередь получателя переполнится, как маленький почтовый ящик, то дальнейшие сообщения теряются.
Если датаграммы настолько ненадежны, зачем же ими пользоваться? Просто некоторые приложения наиболее логично реализуются с применением датаграмм. Например, при пересылке аудиоданных важнее сохранить поток в целом, чем гарантировать прохождение каждого пакета, особенно если потеря пакетов вызва-
на недостаточной пропускной способностью. Датаграммы также часто применяются в широковещательной рассылке (аналог массовой рассылки рекламных объявлений по почте). В частности, широковещательные пакеты используются для отправки в локальную подсеть сообщений типа: «Есть здесь кто-нибудь, кто хочет быть моим сервером?»
Поскольку датаграммы не создают иллюзии постоянного соединения, в работе с ними вы располагаете несколько большей свободной. Вам не придется вызывать connect для подключения сокета к удаленной точке, с которой вы обмениваетесь данными. Вместо этого каждая датаграмма адресуется отдельно при вызове send. Предполагая, что $remote_addr является результатом вызова sockaddr_in, поступите следующим образом:
send(MYSOCKET, $msg_buffer, $flags, $retrrote_addr) or die "Can't send: $'\n",
Единственный часто используемый флаг, MSG_OOB, позволяет отправлять и принимать внеполосные (out-of-band) данные в нетривиальных приложениях.
Удаленный адрес ($remote_addr) должен представлять собой комбинацию порта и адреса Интернета, возвращаемую функцией sockaddr_in модуля Socket. Если хотите, вызовите connect для этого адреса — в этом случае последний аргумент при вызове send можно опускать, а все сообщения будут отправлены этому получателю. В отличие от потоковых коммуникаций, один датаграммный сокет позволяет подключиться к другому компьютеру.
В примере 17.1 приведена небольшая программа, использующая протокол UDP. Она устанавливает связь с портом времени UDP на компьютере, имя которого задается в командной строке, или по умолчанию на локальном компьютере. Программа работает не на всех компьютерах, но при наличии сервера UDP вы получите 4-байтовое целое число, байты которого упакованы в сетевом порядке; число равно количеству секунд с 1900 года по данным этого компьютера. Чтобы передать это время функции преобразования localtime или gmtime, необходимо вычесть из него количество секунд от 1900 до 1970 года.
Пример 17.1. dockdrift
#'/usr/bin/perl
# clockdrift - сравнение текущего времени с другой системой use strict; use Socket,
my ($host, $him, $src, Sport, Sipaddr, $ptime, $delta); my $SECS_of_70_YEARS = 2_208_988_800;
socket(MsgBox, PF_INET, SOCK_DGRAM, getprotobyname("udp"))
or die "socket: $!"; $hin = sockaddr_in(scalar(getservbyname("time", "udp")),
met_aton(shift || '127.1')); defined(send(MsgBox, 0, 0, $him))
or die "send. $! ';
продолжение •£>¦
defined($src = recv(MsgBox, $ptime, 4, 0))
or die "recv: $!";
(Sport, Sipaddr) = sockaddr_in($src); Shost = gethostbyaddr($ipaddr, AF_INET);
my Sdelta = (unpack("N", Sptime) - $SECS_of_70_YEARS) - time(); print "Clock on $host is $delta seconds ahead of this one.\n";
Если компьютер, с которым вы пытаетесь связаться, не работает или ответ потерян, программа застрянет при вызове recv в ожидании ответа, который никогда не придет.
t> Смотри также--------------------------------------------------------------------------------------------
Описание функций send, recv, gethostbyaddr и unpack вperlfunc(\); документация по стандартным модулям Socket и IO::Socket; раздел «UDP: message passing» perlipc(l); рецепт 17.5.
17.5. Создание сервера UDP
Проблема
Вы хотите написать сервер UDP.
Решение
Сначала вызовите функцию bind для номера порта, по которому будет осуществляться связь с вашим сервером. С модулем IO::Socket это делается просто:
use 10::Socket;
Sserver = 10: .'Socket: :INET->new(LocalPort => $server_port,
Proto => "udp") or die "Couldn't be a udp server on port $server_port : $@\n";
Затем в цикле принимайте сообщения:
while ($him = $server->recv($datagram, $MAX_TO_READ, $flags)) {
# Обработать сообщение }
Комментарий
Программирование для UDP намного проще, чем для TCP. Вместо того чтобы последовательно принимать клиентские подключения и вступать в долгосрочную связь с клиентом, достаточно просто принимать сообщения от клиентов по мере их поступления. Функция recv возвращает адрес отправителя, подлежащий декодированию.
В примере 17. 2 показан небольшой сервер UDP, который просто ожидает сообщений. Каждый раз, когда приходит очередное сообщение, мы выясняем, кто его послал, и отправляем ответ-сообщение с принятым текстом, после чего сохраняем новое сообщение.
17.5. Создание сервера UDP 617 Пример 17.2. udpqotd
#!/usr/bin/perl -wй udpqotd - сервер сообщений UDP
use strict;
use 10::Socket;
my($sock, Soldmsg, $newmsg, $hisaddr, Shishost, SMAXLEN, $P0RTN0);
SMAXLEN = 1024;
$P0RTN0 = 5151;
$sock = 10:'Socket:-INET->new(LocalPort => SPORTNO, Proto => 'udp')
or die "socket: $@",
print "Awaiting UDP messages on port $P0RTN0\n"; $oldmsg = "This is the starting message."; while ($sock->recv($newmsg, SMAXLEN)) {
my($port, $ipaddr) = sockaddr_in($sock->peername);
Shishost = gethostbyaddr($ipaddr, AF_INET),
print "Client Shishost said ' 'Snewmsg''\n";
$sock->send(Soldmsg);
Soldmsg = "[Shishost] Snewmsg"; } die "recv: $!";
С использованием модуля IO::Socket программа получается проще, чем с низкоуровневым модулем Socket. Нам не приходится указывать, куда отправить сообщение, поскольку библиотека сама определяет отправителя последнего сообщения и сохраняет его в объекте $sock. Метод peername извлекает данные для декодирования.
Программа telnet не подходит для общения с этим сервером; для этого необходим специальный клиент. Один из вариантов приведен в примере 17.3.
Пример 17.3. udpmsg
#!/usr/bin/perl -w
# udpmsg - отправка сообщения серверу udpquotd
use 10::Socket; use strict;
my($sock, $server_host, $msg, Sport, Sipaddr, Shishost, SMAXLEN, SPORTNO, STIMEOUT);
SMAXLEN = 1024; SPORTNO = 5151; STIMEOUT = 5;
$server_host = shift;
$msg = "@ARGV";
Ssock = 10::Socket::INET->new(Proto => 'udp',
PeerPort => SPORTNO,
PeerAddr => $server_host)
продолжение &
or die "Creating socket. $(\п"; $sock->send($msg) or die "send: $!';
eval {
local $SIG{ALRM} = sub { die "alarm time out" };
alarm $TIMEOUT;
$sock->recv($msg, SMAXLEN) or die "recv. $i";
alarm 0;
1; # Нормальное возвращаемое значение eval } or die "recv from $server_host timed out after $TIMEOUT seconds \n',
(Sport, Sipaddr) = sockaddr_in($sock->peername), $hishost = gethostbyaddr($ipaddr, AF_INET); print 'Server $hishost responded '$msg''\n";
При создании сокета мы с самого начала указываем хост и номер порта, что позволяет опустить эти данные при вызовах send.
Тайм-аут (alarm) был добавлен на случай, если сервер не отвечает или вообще не работает. Поскольку recv является блокирующей системной функцией, выход из которой может и не произойти, мы включаем ее в стандартный блок eval для прерывания блокировки по тайм-ауту.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций send, recv и alarm вperlfunc(l); документация по стандартным модулям Socket и IO::Socket; раздел «UDP: message passing» perlipc(l); рецепты 16.21; 17.4.
17.6. Использование сокетов UNIX
Проблема
Вы хотите обмениваться данными с другими процессами, находящимися исключительно на локальном компьютере.
Решение
Воспользуйтесь сокетами UNIX. При этом можно использовать программы и приемы из предыдущих рецептов для сокетов Интернета со следующими изменениями:
• Вместо socketaddr_m используется socketaddr_un.
• Вместо IO::Socket::UNIX используется IO::Socket::INET.
• Вместо PF_INET используется PF_UNIX, а при вызове socket в качестве
аргумента передается PF_UNSPEC.
• Клиенты SOCK_STREAM не обязаны вызывать bind для локального адреса
перед вызовом connect.
Комментарий
Имена сокетов UNIX похожи на имена файлов в файловой системе. Фактически в большинстве систем они реализуются в виде специальных файлов; именно это и делает оператор Perl -S — он проверяет, является ли файл сокетом UNIX.
Передайте имя файла в качестве адресного аргумента 10: .Socket: :UNIX->new или закодируйте его функцией sockaddr_un и передайте его connect. Посмотрим, как создаются серверные и клиентские сокеты UNIX в модуле IO::Socket::UNIX:
use 10 .'Socket;
unlink '/tmp/mysock",
$server = 10.'Socket::UNIX->new(LocalAddr => "/tmp/mysock",
Type => SOCK_DGRAM,
Listen => 5 ) or die $@;
$client = 10::Socket':UNIX->new(PeerAddr => "/tmp/mysock",
Type => SOCK_DGRAM,
Timeout => 10 )
or die $@,
Пример использования традиционных функций для создания потоковых сокетов выглядит так:
use Socket;
socket(SERVER, PF_UNIX, SOCK_STREAM, 0), unlink "/tmp/mysock", bind(SERVER, sockadd r_un("/tmp/mysock")) or die "Can't create server $!";
socket(CLIENT, PFJJNIX, SOCK_STREAM, 0); connect(CLIENT, sockaddr_un("/tmp/mysock")) or die "Can't connect to /tmp/mysock' $!";
Если вы не уверены полностью в правильном выборе протокола, присвойте аргументу Proto при вызове 10::Socket::UNIX->new значение 0 для сокетов PF_UNIX. Сокеты UNIX могут быть как датаграммными (SOCK_DGRAM), так и потоковыми (SOCK_STREAM), сохраняя при этом семантику аналогичных сокетов Интернета. Изменение области не меняет характеристик типа сокета.
Поскольку многие системы действительно создают специальный файл в файловой системе, вы должны удалить этот файл перед попыткой привязки сокета функцией bind. Хотя при этом возникает опасность перехвата (между вызовами unlink и bind кто-то может создать файл с именем вашего сокета), это не вызывает особых погрешностей в системе безопасности, поскольку bind не перезаписывает существующие файлы.
> Смотри также---------------------------------------------------------------------------------------------
Рецепты 17.1-17.5.
Проблема
Имеется сокет. Вы хотите идентифицировать компьютер, находящийся на другом конце.
Решение
Если вас интересует только IP-адрес удаленного компьютера, поступите следующим образом:
use Socket,
$other_end = getpeername(SOCKET)
or die Couldn t identify other end $'\n ,
(Sport Siaddr) = unpack_sockaddr_in($other_end),
$ip_address = inet_ntoa($iaddr),
Имя хоста определяется несколько иначе:
use Socket,
$other_end = getpeername(SOCKET)
or die Couldn t identify other end $'\n , (Sport, Siaddr) = unpack_sockaddr_in($other_end), $actual_ip = inet_ntoa($iaddr), $claimed_hostname = gethostbyaddr($iaddr, AF_INET), @name_lookup = gethostbyname($claimed_hostnane)
or die Could not look up $claimed_hostname $'\n , @resolved_ips = map { inet_ntoa($_) }
@name_lookup[ 4 $#ips_for_hostnane ]
Комментарий
В течение долгого времени задача идентификации подключившихся компьютеров считалась более простой, чем на самом деле. Функция getpeername возвращает IP-адрес удаленного компьютера в упакованной двоичной структуре (или undef в случае ошибки). Распаковка выполняется функцией inet_ntoa. Если вас интересует имя удаленного компьютера, достаточно вызвать gethostbyaddr и поискать его в таблицах DNS, не так ли?
Не совсем. Это лишь половина решения. Поскольку поиск по имени выполняется на сервере DNS владельца имени, а поиск по IP-адресу — на сервере DNS владельца адреса, приходится учитывать возможность, что компьютер, к которому вы подключились, выдает неверные имена. Например, компьютер evil.crackers.org может принадлежать злобным киберпиратам, которые сказали своему серверу DNS, что их IP-адрес (1.2.3.4) следует идентифицировать как trusted.dod.gov. Если ваша программа доверяет trusted.dod.gov, то при подключении с evil.crackers.org функция getpeername вернет правильный IP-адрес (1.2.3.4), однако gethostbyaddr вернет ложное имя.
Чтобы справиться с этой проблемой, мы берем имя (возможно, ложное), полученное от gethostbyaddr, и снова вызываем для него функцию gethostbyname. В примере с evil.crackers.org поиск для trusted.dod.gov будет выполняться на сервере DNS dod.gov и вернет настоящий IP-адрес (адреса) trusted.dod.gov Поскольку многие компьютеры имеют несколько IP-адресов (очевидный пример — распределенные Web-серверы), мы не можем использовать упрощенную форму gethostbyname:
$packed_ip = gethostbyname($name) or die Couldn t look up $name $'\n , $ip_address = inet_ntoa($packed__ip),
До настоящего момента предполагалось, что мы рассматриваем приложение с сокетами Интернета. Функцию getpeername также можно вызвать для сокета UNIX. Если на другом конце была вызвана функция bind, вы получите имя файла, к которому была выполнена привязка. Однако если на другом конце функция bind не вызывалась, то getpeername может вернуть пустую (неупакованную) строку, упакованную строку со случайным мусором, или undef как признак ошибки.., или ваш компьютер перезагрузится (варианты перечислены по убыванию вероятности и возрастанию неприятностей). В нашем компьютерном деле это называется «непредсказуемым поведением».
Но даже этого уровня паранойи и перестраховки недостаточно. При желании можно обмануть сервер DNS, не находящийся в вашем непосредственном распоряжении, поэтому при идентификации и аутентификации не следует полагаться на имена хостов. Настоящие параноики и мизантропы обеспечивают безопасность с помощью криптографических методов.
D> Смотри также------------------------------------------------------------------------------------------
Описание функций gethostbyaddr, gethostbyname и getpeername в perlfunc(l); описание функции met_ntoa в стандартном модуле Socket; документация по стандартным модулям IO.:Socket и Net::hostnet.
17.8. Определение вашего имени и адреса
Проблема
Требуется узнать ваше (полное) имя хоста.
Решение
Сначала получите свое (возможно, полное) имя хоста. Воспользуйтесь либо стандартным модулем Sys::Hostname:
use Sys Hostname, $hostname = hostnarae(), либо функцией uname модуля POSIX:
use POSIX qw(uname),
622 Глава 17 • Сокеты
(Skernel Shostname, $release, Sversion, Shardware) = unameQ,Shostname = (uname)[1],
Затем превратите его в IP-адрес и преобразуйте в каноническую форму:
use Socket, # Для AF_INET
Saddress = gethostbyname($hostname)
or die Couldn t resolve Shostname $!
,
Shostname = gethostbyaddr($address, AF_INET)
or die Couldn t re-resolve Shostname V
Комментарий
Для улучшения переносимости модуль Sys:: Hostname выбирает оптимальный способ определения имени хоста, руководствуясь сведениями о вашей системе. Он пытается получить имя хоста несколькими различными способами, но часть из них связана с запуском других программ. Это может привести к появлению меченых данных (см. рецепт 19.1).
С другой стороны, POSIX uname работает только в POSIX-системах и не гарантирует получения полезных данных в интересующем нас поле nodename. Впрочем, на многих компьютерах это значение все же приносит пользу и не страдает от проблем меченых данных в отличие от Sys::Hostname.
Однако после получения имени хоста следует учесть возможность того, что в нем отсутствует имя домена. Например, Sys::Hostname вместо guanaco.camehds.org может вернуть просто guanaco. Чтобы исправить ситуацию, преобразуйте имя в IP-адрес функцией gethostbyname, а затем — снова в имя функцией gethostbyaddr. Привлечение DNS гарантирует получение полного имени.
> Смотри также---------------------------------------------------------------------------------------------
Описание функций gethostbyaddr и gethostbyname в perlfunc(l); документация по стандартным модулям Net::hostnet и Sys::Hostname.
17.9. Закрытие сокета после разветвления
Проблема
Ваша программа разветвилась, и теперь другому концу необходимо сообщить о завершении отправки данных. Вы попытались вызвать close для сокета, но удаленный конец не получает ни EOF, ни SIGPIPE.
Решение
Воспользуйтесь функцией shutdown:
shutdown(SOCKET, 0), # Прекращается чтение данных shutdown(SOCKET, 1), # Прекращается запись данных shutdown(SOCKET, 2), й Прекращается работа с сокетом
Используя объект IO::Socket, также можно написать-
$socket->shutdown(0), # Прекращается чтение данных
17.10. Написание двусторонних клиентов 623
Комментарий
При разветвлении (forking) процесса потомок получает копии всех открытых файловых манипуляторов родителя, включая сокеты. Вызывая close для файла или сокета, вы закрываете только копию манипулятора, принадлежащую текущему процессу. Если в другом процессе (родителе или потомке) манипулятор остался открытым, операционная система не будет считать файл или сокет закрытым.
Рассмотрим в качестве примера сокет, в который посылаются данные. Если он открыт в двух процессах, то один из процессов может закрыть его, и операционная система все равно не будет считать сокет закрытым, поскольку он остается открытым в другом процессе. До тех пор пока он не будет закрыт другим процессом, процесс, читающий из сокета, не получит признак конца файла. Это может привести к недоразумениям и взаимным блокировкам.
Чтобы избежать затруднений, либо вызовите close для незакрытых манипуляторов, либо воспользуйтесь функцией shutdown. Функция shutdown является более радикальной формой close — она сообщает операционной системе, что, даже несмотря на наличие копий манипулятора у других процессов, он должен быть помечен как закрытый, а другая сторона должна получить признак конца файла при чтении или SIGPIPE при записи.
Числовой аргумент shutdown позволяет указать, какие стороны соединения закрываются. Значение 0 говорит, что чтение данных закончено, а другой конец сокета при попытке передачи данных должен получить SIGPIPE. Значение 1 говорит о том, что закончена запись данных, а другой конец сокета при попытке чтения данных должен получать признак конца файла. Значение 2 говорит о завершении как чтения, так и записи.
Представьте себе сервер, который читает запрос своего клиента до конца файла и затем отправляет ответ. Если клиент вызовет close, сокет станет недоступным для ввода/вывода, поэтому ответ от сервера не доберется до клиента. Вместо этого клиент должен вызвать shutdown, чтобы закрыть соединение наполовину.
print SERVER my request\n , # Отправить данные
shutdown(SERVER, 1), # Отправить признак конца данных,
# запись окончена
Sanswer = <SERVER>, # Хотя чтение все еще возможно
> Смотри также---------------------------------------------------------------------------------------------
Описание функций close и shutdown вperlfunc(i); страница руководства shut-down{2) вашей системы (если есть).
17.10. Написание двусторонних клиентов
Проблема
Вы хотите написать полностью интерактивного клиента, в котором можно ввести строку, получить ответ, ввести другую строку, получить новый ответ и т. д. — словом, нечто похожее на telnet.
После того как соединение будет установлено, разветвите процесс. Один из близнецов только читает ввод и передает его серверу, а другой — читает выходные данные сервера и копирует их в поток вывода.
Комментарий
В отношениях «клиент/сервер» бывает трудно определить, чья сейчас очередь «говорить». Однозадачные решения, в которых используется версия select с четырьмя аргументами, трудны в написании и сопровождении. Однако нет причин игнорировать многозадачные решения, а функция fork кардинально упрощает эту проблему.
После подключения к серверу, с которым вы будете обмениваться данными, вызовите fork. Каждый из двух идентичных (или почти идентичных) процессов выполняет простую задачу. Родитель копирует все данные, полученные из сокета, в стандартный вывод, а потомок одновременно копирует все данные из стандартного ввода в сокет.
Исходный текст программы приведен в примере 17.4.
Пример 17.4. biclient
#i/usr/bin/perl -w
# biclient - двусторонний клиент с разветвлением
use strict, use 10 Socket, my ($host, Sport, $kidpid, $handle, $line),
unless (@ARGV == 2) { die usage $0 host port } ($host, $port) = @ARGV,
tt Создать tcp-подключение для заданного хоста и порта $handle = 10 Socket INET->new(Proto => tcp ,
PeerAddr => $host
PeerPort => Sport) or die can t connect to port Sport on $host $' ,
$handle->autoflush(1), # Запретить буферизацию print STDERR [Connected to $host $port]\n ,
# Разделить программу на два идентичных процесса
die can t fork S1 unless defmed($kidpid = fork()),
if (Skidpid) {
# Родитель копирует сокет в стандартный вывод while (defined (Sline = <$handle>)) {
print STDOUT $lme, } kill( TERM => Skidpid), # Послать потомку SIGTERM
else {
# Потомок копирует стандартный ввод в сокет while (defined ($line = <STDIN>)) { print $handle $line,
exit,
Добиться того же эффекта с одним процессом намного труднее. Проще создать два процесса и поручить каждому простую задачу, нежели кодировать выполнение двух задач в одном процессе. Стоит воспользоваться преимуществами мультизадачности и разделить программу на несколько подзадач, как многие сложнейшие проблемы упрощаются на глазах.
Функция kill в родительском блоке if нужна для того, чтобы послать сигнал потомку (в настоящее время работающему в блоке else), как только удаленный сервер закроет соединение со своего конца. Вызов kill в конце родительского блока ликвидирует порожденный процесс с завершением работы сервера.
Если удаленный сервер передает данные по байтам и вы хотите получать их немедленно, без ожидания перевода строки (которого вообще может не быть), замените цикл while родительского процесса следующей конструкцией:
my $byte,
while (sysread($handle, $byte, 1) == 1) { print STDOUT $byte,
E> Смотри также-------------------------------------------------------------------------------------------
Описание функций sysread и fork вperlfunc{\.)\ документация по стандартному модулю IO::Socket; рецепты 16.5; 16.10; 17.11.
17.11. Разветвляющие серверы
Проблема
Требуется написать сервер, который для работы с очередным клиентом ответвляет специальный подпроцесс.
Решение
Ответвляйте подпроцессы в цикле accept и используйте обработчик $SIG{CHLD} для чистки потомков.
# Создать сокет SERVER, вызвать bind и прослушивать use POSIX qw( sys_wait_h),
sub REAPER {
1 until (-1 == waitpid(-1, WNOHANG)),
$SIG<CHLD} = \&REAPER, # если $] >= 5 002
$SIG{CHLD} = \&REAPER;
while ($hisaddr = accept(CUENT, SERVER)) {
next if $pid = fork; # Родитель
die "fork: $(" unless defined $pid; # Неудача
# otherwise child
close(SERVER); # He нужно для потомка
ft ... Сделать что-то
exit; # Выход из потомка
} continue {
close(CLIENT); # He нужно для родителя
Комментарий
Подобный подход очень часто используется в потоковых (SOCK_STREAM) серверах на базе сокетов Интернета и UNIX. Каждое входящее подключение получает собственный дубликат сервера. Общая модель выглядит так:
1. Принять потоковое подключение.
2. Ответвить дубликат для обмена данными с этим потоком.
3. Вернуться к п. 1.
Такая методика не используется с датаграммными сокетами (SOCK_ DGRAM) из-за особенностей обмена данными в них. Из-за времени, затраченного на разветвление, эта модель непрактична для UDP-серверов. Вместо продолжительных соединений, обладающих определенным состоянием, серверы SOCK_DGRAM работают с непредсказуемым набором датаграмм, обычно без определенного состояния. В этом варианте наша модель принимает следующий вид:
1. Принять датаграмму.
2. Обработать датаграмму.
3. Вернуться к п. 1.
Новое соединение обрабатывается порожденным процессом. Поскольку сокет SERVER никогда не будет использоваться этим процессом, мы немедленно закрываем его. Отчасти это делается из стремления к порядку, но в основном — для того, чтобы серверный сокет закрывался при завершении родительского (серверного) процесса. Если потомки не будут закрывать сокет SERVER, операционная система будет считать его открытым даже после завершения родителя. За подробностями обращайтесь к рецепту 17.9.
96SIG обеспечивает чистку таблицы процессов после завершения потомков (см. главу 16).
> Смотри также---------------------------------------------------------------------------------------------
Описание функций fork и accept вperlfunc(i); рецепты 16.15; 16.19; 17.12—17.13.
17.12. Серверы с предварительным ветвлением
Проблема
Вы хотите написать сервер, параллельно обслуживающий нескольких клиентов (как и в предыдущем разделе), однако подключения поступают так быстро, что ветвление слишком сильно замедлит работу сервера.
Решение
Организуйте пул заранее разветвленных потомков, как показано в примере 17.5. Пример 17.5. preforker
#' /usr/bin/perl
# preforker - сервер с предварительным ветвлением
use 10::Socket;
use Symbol; use POSIX;
# Создать сокет SERVER, вызвать bind и прослушивать порт.
Sserver = I0::Socket INET->new(LocalPort => 6969,
Type => SOCK_STREAM,
Proto => 'tcp1,
Reuse => 1,
Listen => 10 )
or die 'making socket $@\n";
8 Глобальные переменные
$PREFORK =5; 8 Количество поддерживаемых потомков
$MAX_CLIENTS_PER_CHILD =5; # Количество клиентов, обрабатываемых
# каждым потомком.
%children = О; # Ключами являются текущие
# идентификаторы процессов-потомков
$children =0; # Текущее число потомков
sub REAPER { 8 Чистка мертвых потомков
$SIG{CHLD} = \&REAPER; my $pid = wait; $children --; delete $children{$pid};
sub HUNTSMAN { 8 Обработчик сигнала SIGINT
local($SIG{CHLD}) = 'IGNORE'; # Убиваем своих потомков
kill 'INT' => keys %children,
exit; # Корректно завершиться
>
продолжение
п Создать потомков, for (1 SPREFORK) { make_new_child();
# Установить обработчики сигналов.
$SIG{CHLD} = \&REAPER;
$SIG{INT} = \&HUNTSMAN,
# Поддерживать численность процессов
while (1) {
sleep; # Ждать сигнала (например,
# смерти потомка), for ($i = Schildren; $i < $PREFORK, $i++) {
make_new_child(), # Заполнить пул потомков
sub make_new_child { my $pid; my $sigset;
# Блокировать сигнал для fork. $sigset = POSIX::SigSet->new(SIGINT); sigprocmask(SIG_BLOCK, $sigset)
or die "Can' t block SIGINT for fork: $!\n';
die 'fork: $'" unless defined ($pid = fork),
if ($pid) {
# Родитель запоминает рождение потомка и возвращается.
sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n"; $children{$pid} = 1, $children++; return; } else {
# Потомок *не может* выйти из этой подпрограммы
$SIG{INT} = 'DEFAULT1; # Пусть SIGINT убивает процесс,
# как это было раньше.
# Разблокировать сигналы
sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";
# Обрабатывать подключения, пока их число не достигнет
# $MAX_CLIENTS_PER_CHILD.
for ($1=0, $i < $MAX_CLIENTS_PER_CHILD; $i++) {
$client = $server->accept() or last,
# Сделать что-то с соединением
# Корректно убрать мусор и завершиться.
# Этот выход ОЧЕНЬ важен, в противном случае потомок начнет
# плодить все больше и больше потомков, что в конечном счете
# приведет к переполнению таблицы процессов,
exit;
}
Комментарий
Программа получилась большой, но ее логика проста: родительский процесс никогда не работает с клиентами сам, а вместо этого ответвляет $PREFORK потомков. Родитель следит за количеством потомков и своевременно плодит процессы, чтобы заменить мертвых потомков. Потомки завершаются после обработки $MAX_CLIENTS_PER_CHILD клиентов.
Пример 17.5 более или менее прямолинейно реализует описанную логику. Единственная проблема связана с обработчиками сигналов: мы хотим, чтобы родитель перехватывал SIGINT и убивал своих потомков, и устанавливает для этого свой обработчик сигнала &HUNTSMAN. Но в этом случае нам приходится соблюдать меры предосторожности, чтобы потомок не унаследовал тот же обработчик после ветвления. Мы используем сигналы POSIX, чтобы заблокировать сигнал на время ветвления (см. рецепт 16.20).
Используя этот код в своих программах, проследите, чтобы в make_new_child никогда не использовался выход через return. В этом случае потомок вернется, станет родителем и начнет плодить своих собственных потомков. Система переполнится процессами, прибежит разъяренный системный администратор — и вы будете долго и мучительно жалеть, что не обратили должного внимания на этот абзац.
В некоторых операционных системах (в первую очередь — Solaris) несколько потомков не могут вызывать accept для одного сокета. Чтобы гарантировать, что лишь один потомок вызывает accept в произвольный момент времени, придется использовать блокировку файлов.
Смотри также
Описание функции select в perlfunc(i); страница руководства fcntl{2) вашей системы (если есть); документация по стандартным модулям Fcntl, Socket, IO::Select, IO::Socket и Tie::Refflash; рецепты 17.11-17.12.
17.13. Серверы без ветвления
Сервер должен обрабатывать несколько одновременных подключений, но вы не хотите ответвлять новый процесс для каждого соединения.
Решение
Создайте массив открытых клиентов, воспользуйтесь select для чтения информации по мере ее поступления и работайте с клиентом лишь после получения полного запроса от него, как показано в примере 17.6.
630 Глава 17 • Сокеты Пример 17.6. nonforker
#!/usr/bin/perl -w# nonforker - мультиплексный сервер без ветвления
use POSIX;
use 10: '.Socket; use 10::Select; use Socket; use Fcntl; use Tie::RefHash;
Sport = 1685; # Замените по своему усмотрению
# Прослушивать порт.
Sserver = 10: :Socket: :INET->new(l_ocalPort => Sport,
Listen => 10 ) or die "Can't make server socket: $@\n";
# Начать с пустыми буферами
%inbuffer = ();
%outbuffer =();
«ready = ();
tie %ready, 'Tie::RefHash';
nonblock($server);
Sselect = 10::Select->new($server);
# Главный цикл: проверка чтения/принятия, проверка записи,
# проверка готовности к обработке
while (1) {
my Sclient; my $rv; my $data;
Я Проверить наличие новой информации на имеющихся подключениях
# Есть ли что-нибудь для чтения или подтверждения? foreach $client ($select->can_read(1)) {
if ($client == Sserver) {
# Принять новое подключение
$client = $server->accept(); $select->add($client); nonblock($client); } else {
# Прочитать данные
$data = ";
$rv = $client->recv($data, POSIX::BUFSIZ, 0);
unless (defined($rv) && length $data) {
# Это должен быть конец файла, поэтому закрываем клиента delete $inbuffer{$client}; delete $outbuffer{$cllent}; delete $ready{$client};
$select->remove($client);
close $client;
next;
$inbuffer{$client} .= $data;
й Проверить, говорят ли данные в буфере или только что В прочитанные данные о наличии полного запроса, ожидающего
# выполнения. Если да - заполнить $ready{$client}
# запросами, ожидающими обработки.
while ($inbuffer{$client} =" s/(.*\n)//) { push( @{$ready{$client}}, $1 );
й Есть ли полные запросы для обработки? foreach $client (keys %ready) { handle($client);
В Сбрасываемые буферы ?
foreach $client ($select->can_write(1)) {
# Пропустить этого клиента, если нам нечего сказать
next unless exists $outbuffer{$client};
$rv = $client->send($outbuffer{$client}, 0); unless (defined $rv) {
# Пожаловаться, но следовать дальше.
warn "I was told I could write, but I can't.\n";
next; } if ($rv == length $outbuffer{$client} ||
{$! == POSIX::EWOULDBLOCK) {
substr($outbuffer{$client>, 0, $rv) = ";
delete $outbuffer{$client} unless length $outbuffer{$client}; } else {
# He удалось записать все данные и не из-за блокировки.
# Очистить буферы и следовать дальше,
delete $inbuffer{$client};
delete $outbuffer{$client}; delete $ready{$client};
$select->remove($client);
продолжение
close($client), next,
# Внеполосные данные9
foreach $client ($select->has_exception(0)) { # аргумент - тайм-аут # Обработайте внеполосные данные если хотите
# handle($socket) обрабатывает все необработанные запросы
# для клиента Sclient
sub handle {
# Запрос находится в $ready{$client}
# Отправить вывод в $outbuffer{$client}
my $client = shift
my $request,
foreach $request (@{$ready{$client}}) {
# $request - текст запроса
# Занести текст ответа в $outbuffer{$client}
}
delete $ready{$client},
# nonblock($socket) переводит сокет в неблокирующий режим sub nonblock {
my $socket = shift,
my $flags
$flags = fcntl($socket, F_GETFL, 0)
or die Can t get flags for socket $'\n fcntl($socket F_SETFL, $flags | O_NONBLOCK)
or die Can t make socket nonblockmg $'\n
Комментарий
Как видите, одновременно обрабатывать несколько клиентов в одном процессе сложнее, чем ответвлять специальные процессы-дубликаты. Приходится выполнять много работы за операционную систему — например, делить время между разными подключениями и следить, чтобы чтение осуществлялось без блокировки. Функция select сообщает, в каких подключениях есть данные, ожидающие чтения, какие подключения позволяют записать данные или имеют непрочитанные внеполосные данные. Мы могли бы использовать встроенную функцию Perl select, но это усложнит работу с манипуляторами Поэтому мы используем стандартный (для версии 5.004) модуль IO:.Select.
Функции getsockopt и setsockopt включают неблокирующий режим для серверного сокета. Иначе заполнение буферов сокета одного клиента привело бы к приостановке работы сервера до очистки буферов. Однако применение неблокирующего ввода/вывода означает, что нам придется разбираться с неполными операциями чтения/записи. Мы не сможем просто использовать оператор о, блокирующий до того, как станет возможным чтение всей записи, или print для вывода всей записи. Буфер %mbuffer содержит неполные команды, полученные от клиентов, %outbuffer — неотправленные данные, a %ready — массивы необработанных сообщений.
Чтобы использовать этот код в своей программе, выполните три действия. Во-первых, измените вызов IO::Socket::INET и включите в него порт своего сервера. Во-вторых, измените код, который переносит записи из inbuffer в очередь ready. В настоящее время каждая строка (текст, заканчивающийся \п) рассматривается как запрос. Если ваши запросы не являются отдельными строками, внесите необходимые изменения.
while ($mbuffer{$client} =" s/( *\n)//) {
push( @{$ready{$client}}, $1 ) >
Наконец, измените середину цикла в handler так, чтобы в ней действительно создавался ответ на запрос. В простейшей программе эхо-вывода это выглядит так:
$outbuffer{$client} = $request,
Обработка ошибок предоставляется читателю в качестве упражнения для самостоятельной работы. На данный момент предполагается, что любая ошибка при чтении или записи завершает подключение клиента. Вероятно, это слишком сурово, поскольку «ошибки» вроде EINTR или EAGAIN не должны приводить к разрыву соединения (впрочем, при использовании select вы никогда не должны получать EAGAIN).
> Смотри также---------------------------------------------------------------------------------------------
Описание функции select в perlfunc(l); страница руководства fcntl(2) вашей системы (если есть); документация по стандартным модулям Fcntl, Socket, IO::Select, IO::Socket и Tie::Refflash; рецепты 17.11-17.12.
17.14. Написание распределенного сервера
Проблема
Требуется написать сервер для компьютера с несколькими IP-адресами, чтобы он мог выполнять различные операции для каждого адреса.
Решение
Не привязывайте сервер к определенному адресу. Вместо этого вызовите bind с аргументом INADDR_ANY. После того как подключение будет принято, вызов getsockname для клиентского сокета позволяет узнать, к какому адресу он подключился:
socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp')); setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1); bind(SERVER, sockaddr_in($server_port, INADDR_ANY)) or die "Binding: $!\n";
# Цикл принятия подключений while (accept(CLIENT, SERVER)) {
$my_socket_address = getsockname(CLIENT);
($port, $myaddr) = sockaddr_in($ny_socket_address); }
Комментарий
Если функция getpeername (см. рецепт 17.7) возвращает адрес удаленного конца сокета, то функция getsockname возвращает адрес локального конца. При вызове bind с аргументом INADDR_ANY принимаются подключения для всех адресов данного компьютера, поэтому для определения адреса, к которому подключился клиент, можно использовать функцию getsockname.
При использовании модуля IO::Socket::INET программа будет выглядеть так:
$server = 10:'.Socket: :INET->new(LocalPort => $server_port,
Type => SOCK_STREAM,
Proto => 'tcp1,
Listen => 10)
or die "Can't create server socket:
while ($client = $server->accept()) {
$my_socket_address = $client->sockname();
(Sport, Smyaddr) = sockaddr_in($my_socket_address);
# ... }
Если не указать локальный порт при вызове 10: : Socket:: INET->new, привязка сокета будет выполнена для INADDR_ANY.
Если вы хотите, чтобы при прослушивании сервер ограничивался конкретным виртуальным хостом, не используйте INADDR_ANY. Вместо этого следует вызвать bind для конкретного адреса хоста:
use Socket;
Sport = 4269; # Порт
$host = "specific.host.com"; # Виртуальный хост
socket(Server, PF_INET, SOCK_STREAM, getprotobyname("tcp"))
or die "socket: $!"; bind(Server, sockaddr_in($port, inet_aton($host)))
or die "bind: $!"; while ($client_address = accept(Client, Server)) {
> Смотри также-------------------------------------------------------------------------------------------
Описание функции getsockname в perlfunc(l); документация по стандартным модулям Socket и IO::Socket; раздел «Sockets» в perlipc(l).
17.15. Создание сервера-демона
Проблема
Вы хотите, чтобы ваша программа работала в качестве демона.
Решение
Если вы — параноик с правами привилегированного пользователя, для начала вызовите chroot для безопасного каталога:
ch root("/var/daemon")
or die "Couldn't chroot to /var/daemon: $!";
Вызовите fork и завершите родительский процесс.
$pid = fork;
exit if $pid;
die "Couldn't fork: $!" unless defined($pid);
Разорвите связь с управляющим терминалом, с которого был запущен процесс, — при этом процесс перестает входить в группу процессов, к которой он принадлежал.
use POSIX;
POSIX::setsid()
or die "Can't start a new session: $!";
Перехватывайте фатальные сигналы и устанавливайте флаг, означающий, что мы хотим корректно завершиться:
$time_to_die = 0;
sub signal_handler { $time_to_die = 1;
$SIG{INT} = $SIG{TERM} = $SIG{HUP} = \&signal_handler; # Перехватить или игнорировать $SIG{PIPE}
Настоящий код сервера включается в цикл следующего вида:
until ($time_to_die) { # ...
Комментарий
До появления стандарта POSIX у каждой операционной системы были свои средства, с помощью которых процесс говорил системе: «Я работаю в одиночку;
К числу этих функций принадлежит chroot, которая изменяет корневой каталог процесса (/). Например, после вызова chroot /var/daemon при попытке прочитать файл /etc/passwd процесс в действительности прочитает файл /var/ daemon/etc/passwd. Конечно, при вызове функции chroot необходимо скопировать все файлы, с которыми работает процесс, в новый каталог. Например, процессу может потребоваться файл /var/daemon/bin/csh. По соображениям безопасности вызов chroot разрешен только привилегированным пользователям. Он выполняется на серверах FTP при анонимной регистрации. На самом деле становиться демоном необязательно.
Операционная система предполагает, что родитель ожидает смерти потомка. Для нашего процесса-демона это не нужно, поэтому мы разрываем наследственные связи. Для этого программа вызывает fork и exit, чтобы потомок не был связан с процессом, запустившем родителя. Затем потомок закрывает все файловые манипуляторы, полученные от родителя (STDIN, STDERR и STDOUT), и вызывает POSIX setsid, чтобы обеспечить полное отсоединение от родительского терминала.
Все почти готово. Сигналы типа SIGINT не должны немедленно убивать наш процесс (поведение по умолчанию), поэтому мы перехватываем их с помощью %SIG и устанавливаем флаг завершения Далее главная программа работает по принципу: «Пока не убили, что-то делаем».
Сигнал SIGPIPE — особый случай. Получить его нетрудно (достаточно записать что-нибудь в манипулятор, закрытый с другого конца), а по умолчанию он ведет себя довольно сурово (завершает процесс). Вероятно, его желательно либо проигнорировать ($SIG{PIPE) = IGNORE ), либо определить собственный обработчик сигнала и организовать его обработку.
> Смотри также---------------------------------------------------------------------------------------------
Страницы руководства setsid{2) и chroot(l) вашей системы (если есть); описание функции chroot вperlfunc(i).
17.16. Перезапуск сервера по требованию
Проблема
При получении сигнала HUP сервер должен перезапускаться, по аналогии с
inetd или httpd.
Решение
Перехватите сигнал SIGH UP и перезапустите свою программу:
$SELF = /usr/local/libexec/myd , # Моя программа @ARGS = qw(-l /var/log/myd -d), # Аргументы
$SIG{HUP} = \&phoemx,
sub phoenix {
# Закрыть все соединения, убить потомков и
# приготовиться к корректному возрождению
exec($SELF, @ARGS) or die Couldn t restart $'\n
Комментарий
Внешне все выглядит просто («Получил сигнал HUP — перезапустись»), но на самом деле проблем хватает. Вы должны знать имя своей программы, а определить его непросто. Конечно, можно воспользоваться переменной $0 модуля FindBin. Для нормальных программ этого достаточно, но важнейшие системные утилиты должны проявлять большую осторожность, поскольку правильность $0 не гарантирована. Имя программы и аргументы можно жестко закодировать в программе, как это сделано в нашем примере. Однако такое решение не всегда удобно, поэтому имя и аргументы можно читать из внешнего файла (защищая подлинность его содержимого на уровне файловой системы).
Обработчик сигнала обязательно должен устанавливаться после определения SSELF и @ARGS, в противном случае может возникнуть ситуация перехвата — SIGHUP потребует перезапуска, а вы не будете знать, что запускать. Это приведет к гибели вашей программы.
Некоторые серверы при получении SIGHUP не должны перезапускаться — они всего лишь заново читают свой конфигурационный файл:
$CONFIG_FILE = /usr/local/etc/myprog/server_conf pi , $SIG{HUP} = \&read_config sub read_config {
do $CONFIG_FILE, }
Некоторые умные серверы даже автоматически перезагружают свои конфигурационные файлы в случае их обновления. Вам даже не придется ни о чем сигнализировать.
> Смотри также---------------------------------------------------------------------------------------------
Описание функции exec вperlfunc(l); рецепты 8.16—8.17; 16.15.
17.17. Программа: backsniff
Программа backsniff регистрирует попытки подключения к портам. Она использует модуль Sys::Syslog, а ему, в свою очередь, нужна библиотека syslog.ph, которая не обязательно присутствует в вашей системе. Попытка подключения регистрируется с параметрами LOGNOTICE и LOG_DAEMON. Функция getsockname идентифицирует порт, к которому произошло подключение, a getpeername — компьютер, установивший соединение. Функция getservbyport преобразует локальный номер порта (например, 7) в название службы (например, echo ).
May 25 15:50:22 coprolith sniffer: Connection from 207.46.131.141 to 207.46.130.164:echo
В файл inetd.conf включается строка следующего вида:
echo stream tcp nowait nobody /usr/scripts/snfsqrd sniffer
Исходный текст программы приведен в примере 17.7.
Пример 17.7. backsniff
#'/usr/bin/perl -w
# backsniff - регистрация попыток подключения к определенным портам
use Sys -Syslog; use Socket,
# Идентифицировать порт и адрес
Ssockname = getsockname(STDIN)
or die "Couldn't identify myself: $'\n", (Sport, $iaddr) = sockaddr_in($sockname); $my_address = inet_ntoa($iaddr),
# Получить имя службы
Sservice = (getservbyport (Sport, 'tcp'))[O] || $port, tt now identify remote address Ssockname = getpeernarae(STDJN)
or die 'Couldn t identify other end' $'\n , (Sport, Siaddr) = sockaddr_in($sockname); $ex_address = met_ntoa($iaddr);
# Занести информацию в журнал
openlogC sniffer', ' ndelay', 'daemon'),
syslog("notice", "Connection from %s to %s:%s\n", $ex_address,
$my_address, Sservice); closelogQ, exit,
17.18. Программа: fwdport
Предположим, у вас имеется защитный брандмауэр (firewall). Где-то в окружающем мире есть сервер, к которому обращаются внутренние компьютеры, но доступ к серверу разрешен лишь процессам, работающим на брандмауэре. Вы не хотите, чтобы при каждом обращении к внешнему серверу приходилось заново регистрироваться на компьютере брандмауэра.
Например, такая ситуация возникает, когда Интернет-провайдер вашей компании позволяет читать новости при поступлении запроса с брандмауэра, но отвергает все подключения NNTP с остальных адресов. Вы как администратор брандмауэра не хотите, чтобы на нем регистрировались десятки пользователей — лучше разрешить им читать и отправлять новости со своих рабочих станций.
Программа fwdport из примера 17.8 содержит общее решение этой проблемы. Вы можете запустить любое количество экземпляров, по одному для каждого внешнего запроса. Работая на брандмауэре, она общается с обоими мирами. Когда кто-то хочет воспользоваться внешней службой, он связывается с нашим прокси-сервером, который далее действует по его поручению. Для внешней службы подключение устанавливается с брандмауэра и потому является допустимым. Затем программа ответвляет два процесса: первый читает данные с внешнего сервера и передает их внутреннему клиенту, а второй читает данные от внутреннего клиента и передает их внешнему серверу.
Например, командная строка может выглядеть так:
% fwdport -s nntp -I fw.oursite com -r news.bigorg.com
Это означает, что программа выполняет функции сервера NNTP, прослушивая локальные подключения на порте NNTP компьютера fw.oursite.com. При поступлении запроса она связывается с news.bigorg.com (на том же порте) и организует обмен данными между удаленным сервером и локальным клиентом.
Рассмотрим другой пример:
% fwdport -I myname.9191 -r news.bigorg com:nntp
На этот раз мы прослушиваем локальные подключения на порте 9191 хоста myname и связываем клиентов с удаленным сервером news.bigorg.com через порт NNTP.
В некотором смысле fwdport действует и как сервер, и как клиент. Для внешнего сервера программа является клиентом, а для компьютеров за брандмауэром — сервером. Эта программа завершает данную главу, поскольку в ней продемонстрирован практически весь изложенный материал: серверные операции, клиентские операции, удаление зомби, разветвление и управление процессами, а также многое другое.
Пример 17.8. fwdport
#' /usr/bm/perl -w
# fwdport - прокси-сервер для внешних служб
|
use |
strict, |
|
use |
Getopt::Long; |
|
use |
Net;:hostent; |
|
use |
10::Socket; |
|
use |
POSIX ":sys_wait_h"; |
|
my ( |
|
|
%Children, |
|
|
$REMOTE, |
|
|
$LOCAL, |
|
|
$SERVICE, |
|
|
$proxy_server, |
|
|
); |
$ME, |
|
($ME |
= $0) =- s,. <¦/,,; |
# Для обработки параметров
# Именованный интерфейс для информации о хосте
# Для создания серверных и клиентских сокетов
# Для уничтожения зомби
# Хэш порожденных процессов
# Внешнее соединение
# Для внутреннего прослушивания
# Имя службы или номер порта
# Сокет, для которого вызывается accept()
# Базовое имя программы
# Сохранить базовое имя сценария
продолжение
640 Глава 17 • Сокеты
Пример 17.8 (продолжение)check_args(); # Обработать параметры
start_proxy(); # Запустить наш сервер
service_clients(), # Ждать входящих подключений
die "NOT REACHED"; # Сюда попасть невозможно
# Обработать командную строку с применением расширенной версии
# библиотеки getopts
sub check_args {
GetOptions(
'remote=s" => \$REMOTE,
"local=s" => \$LOCAL,
'service=s" => \$SERVICE, ) or die «EOUSAGE,
usage. $0 [ --remote host ] [ --local interface ] [ --service service ] EOUSAGE
die 'Need remote ' unless $REMOTE,
die "Need local or service" unless $LOCAL || SSERVICE,
# Запустить наш сервер sub start_proxy {
my @proxy_server_config = ( Proto => 'tcp', Reuse => 1, Listen => SOMAXCONN, );
push @proxy_server_config, LocalPort => $SERVICE if SSERVICE, push @proxy_server_config, LocalAddr => $LOCAL if $LOCAL, $proxy_server = 10: 'Socket: •INET->new(@proxy_server_config)
or die "can't create proxy server $@>'; print '[Proxy server on ", (SLOCAL || SSERVICE), ' initialized.]\n'
sub service_clients < my (
$local_client, # Клиент, обращающийся к внешней службе
$lc_info, # Имя/порт локального клиента
$remote_server, # Сокет для внешнего соединения
@rs_config, ft Временный массив параметров удаленного сокета
$rs_mfo, # Имя/порт удаленного сервера
Skidpid, # Порожденный процесс для каждого подключения
$SIG{CHLO} = \&REAPER; ft Уничтожить зомби acceptingO;
# Принятое подключение означает, что внутренний клиент
# хочет выйти наружу
while ($local_client = $proxy_server->accept()) { $lc_info = peerinfo($local_client);
set_state("servicing local $lc_info"), printf "[Connect from $lc_mfo]\n';
@rs_config = (
Proto => 'tcp',
PeerAdd г => $REMOTE, ); push(@rs_config, PeerPort => $SERVICE) if SSERVICE,
print "[Connecting to SREMOTE...";
set_state("connecting to SREMOTE"); # См. ниже
$remote_server = 10:.Socket :INET->new(@rs_config)
or die "remote server: $@'; print "done]\n";
$rs_mfo = peerinfo($remote_server); set_state("connected to $rs_info");
Skidpid = fork();
die "Cannot fork" unless defined Skidpid;
if (Skidpid) {
$Children{$kidpid} = time(); # Запомнить время запуска
close $remote_server, # He нужно главному процессу
close $local_client; # Тоже
next; tt Перейти к другому клиенту
# В этой точке программа представляет собой ответвленный
# порожденный процесс, созданный специально для входящего
# клиента, но для упрощения ввода/вывода нам понадобится близнец.
close $proxy_server; # He нужно потомку
Skidpid = fork();
die "Cannot fork" unless defined Skidpid;
ft Теперь каждый близнец сидит на своем месте и переправляет
# строки данных. Видите, как многозадачность упрощает алгоритм9
# Родитель ответвленного процесса, потомок главного процесса
if (Skidpid) <
set_state("$rs_info --> $lc_mfo");
select($local_client); $| = 1,
print while <$remote_server>;
kill('TERM', Skidpid), # Работа закончена,
> # убить близнеца
ft Потомок потомка, внук главного процесса else {
set_state("$rs_info <-- $lc_mfo");
select($remote_server); $| = 1;
print while <$local_client>;
продолжение
642 Глава 17 • Сокеты
Пример 17.8 (продолжение)kill( TERM , getppidO) # Работа закончена,
} # убить близнеца
exit, # Тот, кто еще жив, умирает
} continue { acceptingO,
# Вспомогательная функция для получения строки в формате ХОСТ ПОРТ sub peerinfo {
my $sock = shift,
my Shostmfo = gethostbyaddr($sock->peeraddr),
return spnntf( %s %s ,
$hostinfo->name || $sock->peerhost $sock->peerport),
# Сбросить $0, при этом в некоторых системах ps выдает
# нечто интересное строку, которую мы присвоили $0'
sub set_state { $0 = $МЕ [@_] }
# Вспомогательная функция для вызова set_state
sub accepting {
set_state( accepting proxy for ($REMOTE || SSERVICE))
# Кто-то умер Уничтожать зомби, пока они остаются tf Проверить время их работы sub REAPER { my $child my $start,
while (($child = waitpid(-1,WN0HANG)) > 0) { if ($start = $Children{$child}) { my $runtime = time() - $start, printf Child $child ran %dm%ss\n ,
$runtime / 60 $runtime % 60, delete $Children{$child}, } else {
print Bizarre kid $child exited $9\п ,
# Если бы мне пришлось выбирать между System V и 4 2,
# я бы уволился - Питер Ханиман
$SIG{CHLD} = \&REAPER,
Смотри также
Getopt::Long(3), Net::hostent(3), IO::Socket(3), POSIX(3), глава 16, раздел «Написание двусторонних клиентов» этой главы.
Протоколы Интернета
Так называемый «телефон» обладает слишком
многими недостатками, что не позволяет серьезно
рассматривать его как средство связи. Для нас
это устройство совершенно бесполезно.
Служебная записка Western Union, 1876 г.
Введение
Правильная работа с сокетами — лишь часть программирования сетевых коммуникаций. Даже если вы организовали обмен данными между двумя программами, все равно вам понадобится определенный протокол. С помощью протокола каждая сторона узнает, когда передаются или принимаются данные и кто именно отвечает за данный аспект службы.
Наиболее распространены следующие протоколы Интернета.
Протокол Расшифровка
Описание
NNTP HTTP SMTP РОРЗ
File Transfer Protocol
Remote shell and Remote Copy
Network News Transfer Protocol Hypertext Transfer Protocol Simple Mail Transfer Problem Post Office Protocol
Копирование файлов между удаленными компьютерами Удаленное подключение к компьютеру Удаленная регистрация и копирование файлов
Чтение и отправка новостей Usenet Пересылка документов по Web Отправка почты Чтение почты
Большинство этих модулей принадлежит иерархии Net::. Модуль Net::FTP используется для отправки и приема файлов по FTP; модуль Net::NNTP — для чтения и отправки новостей Usenet; модуль Net::Telnet — для имитации подключения к другому компьютеру; модуль Net::Whois — для получения данных об имени домена; модуль Net::Ping — для проверки связи с компьютером, а модули Net::POP3 и Mail::Mailer — для отправки и получения почты. Протокол CGI рассматривается в главе 19 «Программирование CGI», а протокол HTTP — в главе 20 «Автоматизация в Web».
Большинство этих модулей написал Грэхем Барр, автор модулей IO::Socket, использовавшихся в низкоуровневых сетевых коммуникациях в главе 17 «Соке-ты». Он написал Net::FTP, Net::NNTP, Net::POP3 и Mail::Mailer. Джей Роджерс (Jey Rogers) написал Net::Telnet, а Чип Зальценберг (Chip Salrenberg) — Net::Whois. Благодаря им вам не придется заново изобретать велосипед!
18.1. Простой поиск в DNS
Проблема
Требуется определить IP-адрес хоста или преобразовать IP-адрес в имя. Сетевые серверы решают эту задачу в процессе аутентификации своих клиентов, а клиенты — когда пользователь вводит имя хоста, но для библиотеки сокетов Perl нужен IP-адрес. Более того, многие серверы регистрируют в файлах журналов IP-адреса, но аналитическим программам и людям удобнее работать с именами хостов.
Решение
Для получения всех IP-адресов по имени хоста (например, www.perl.com) воспользуйтесь функцией gethostbyname:
use Socket;
©addresses = gethostbyname($name) or die 'Can't resolve $name: $'\n"; ©addresses = map { met_ntoa($_) } @addresses[4 .. $#addresses],
# ^addresses - список IP-адресов ("208.201 239 48", "208.201.239.48")
Если вам нужен только первый адрес, воспользуйтесь функцией inet_aton: use Socket;
Saddress = inet_ntoa(inet_aton($name));
# Saddress - один IP-адрес ("208.201.239 48")
Для получения имени хоста по строке с IP-адресом (например," 208.201.239.48"), воспользуйтесь следующим фрагментом:
use Socket;
$name = gethostbyaddr(inet_aton($address), AF_INET)
or die "Can't resolve $address: $!\n"; # $name - имя хоста ("www.perl.com")
Комментарий
Наша задача усложняется тем, что функции Perl являются простыми оболочками для системных функций С, поэтому IP-адреса приходится преобразовывать из ASCII-строк ("208. 201. 239.48") в структуры С. Стандартный модуль Socket содержит функцию inet_aton для перехода от ASCII к упакованному числовому формату и функцию inet_ntoa, выполняющую обратное преобразование:
use Socket;
$packed_address = inet_aton("208.146 140 1");
$ascii_address = inet_ntoa($packed_address);
Функция gethostbyname получает строку, содержащую имя хоста (или IP-адрес). В скалярном контексте она возвращает IP-адрес удаленного хоста, который можно передать inet_ntoa (или undef в случае ошибки). В списковом контексте она возвращает список, состоящий по крайней мере из пяти элементов (или пустой список в случае ошибки). Список состоит из следующих элементов.
Индекс Значение
0 
1 Синонимы (строка, разделенная пробелами)
2 Тип адреса (обычно AF_INET)
3 Длина структуры адреса (не имеет значения)
4,5..._____ Структуры адресов__________________
Имени хоста может соответствовать несколько IP-адресов; в частности, это происходит на сильно загруженных Web-серверах, где для снижения загрузки на разных компьютерах размещаются идентичные Web-страницы. В подобных ситуациях сервер DNS, предоставляющий адреса, чередует их, обеспечивая сбалансированную нагрузку на сервер. Если вы хотите выбрать IP-адрес для подключения, просто возьмите первый адрес в списке (а если он не работает, попробуйте остальные адреса):
$packed = gethostbyname($hostname)
or die "Couldn' t resolve address for Shostname: $!\n"; $address = inet_ntoa($packed); print "I will use Saddress as the address for $hostname\n";
Используя имена хостов для разрешения или отказа в обслуживании, будьте осторожны. Любой желающий может настроить свой сервер DNS так, чтобы его компьютер идентифицировался как www.whitehouse.gov, www.yahoo.com или
# $address - проверяемый IP-адрес (например, "128.138.243.20")
use Socket;
$name = gethostbyaddr(inet_aton($address), AF_INET)
or die "Can't look up Saddress : $'\n"; @addr = gethostbyname($name)
or die "Can't look up $name . $'\n"; $found = grep { $address eq met_ntoa($_) } @addr[4..$#addr],
Оказывается, даже такой алгоритм не дает полной уверенности в полученном имени, поскольку существуют разнообразные обходные пути. Даже IP-адрес, из которого вроде бы поступают пакеты, может быть поддельным, и в процессе аутентификации не следует полагаться на сетевой уровень. В действительно важных ситуациях всегда выполняйте аутентификацию сами (с помощью паролей или криптографических методов), поскольку сеть IPv4 не проектировалась для соблюдения безопасности.
Информация о хосте не ограничивается адресами и синонимами. Чтобы полноценно работать с дополнительными данными, воспользуйтесь модулем Net::DNS с CPAN. Программа 18.1 показывает, как получить записи MX (mail exchange) для произвольного хоста.
Пример 18.1. mxhost
#! /usr/bin/perl
# mxhost - поиск записей mx для хоста
use Net.'DNS;
$host = shift,
$res = Net':DNS::Resolver->new();
@mx = mx($res, $host)
or die "Can't find MX records for $host (".$res->errorstring,")\n";
foreach Srecord (@>mx) {
print $record->preference, " ", $record->exchange, "\n"; }
Примерный вывод выглядит так:
% mxhost cnn.com 10 mail.turner.com 30 alfw2.turner.com
Функция inet_aton, как и gethostbyname, получает строку с именем хоста или IP-адресом, однако она возвращает только первый IP-адрес для данного хоста. Чтобы узнать все IP-адреса, приходится писать дополнительный код. Модуль Net::hostent поддерживает соответствующие средства доступа по имени. Пример 18.2 показывает, как это делается.
Пример 18.2. hostaddrs
#!/usr/bin/perl
# hostaddrs - канонизация имени и вывод адресов use Socket; 'use Net::hostent; $name = shift; if ($hent = gethostbyname($name)) {
$name = $hent->name; # Если отличается
$addr_ref = $hent->addr_list;
©addresses = map { inet_ntoa($_) } @$addr_ref; } print "$name => @addresses\n';
Примерный результат выглядит так:
% hostaddrs www.ora.com helio.ora.com => 204.148.40.9
% hostaddrs www.whitehouse.gov
www.whitehouse.gov => 198.137.240.91 198.137.240.92
> Смотри также---------------------------------------------------------------------------------------------
Описание функций gethostbyname и gethostbyaddr в perlfunc(l); документация по модулю Net::DNS с CPAN; документация по стандартным модулям Socket и Net::hostent.
18.2. Клиентские операции FTP
Проблема
Вы хотите подключиться к серверу FTP, чтобы отправить или принять с него файлы. Например, вы решили автоматизировать разовую пересылку многих файлов или автоматически создать зеркальную копию целого раздела сервера FTP.
Решение
Воспользуйтесь модулем Net::FTP с CPAN. use Net::FTP;
$ftp = Net::FTP->new("ftp.host.com") or die "Can't connect: $@\n";
$ftp->login($username, Spassword) or die "Couldn't logm\n";
$ftp->cwd($directory) or die "Couldn't change directory\n";
$ftp->get($filename) or die "Couldn't get $filename\n";
$ftp->put($filename) or die "Couldn't put $filename\n";
Комментарий
Работа с модулем Net:: FTP состоит из трех шагов: подключение к серверу, идентификация и аутентификация и пересылка файлов. Все операции с сервером
Подключение осуществляется конструктором new. В случае ошибки переменной $@ присваивается сообщение об ошибке, a new возвращает undef. Первый аргумент определяет имя хоста сервера FTP и может сопровождаться необязательными параметрами:
$ftp = Net:.FTP->new("ftp.host, com", Timeout => 30, Debug => 1) or die 'Can't connect: $@\n";
Параметр Timeout определяет промежуток времени в секундах, после которого любая операция считается неудачной. Параметр Debug устанавливает уровень отладки (при значении, отличном от нуля, копии всех команд отправляются в STDERR). Строковый параметр Firewall определяет компьютер, являющийся прокси-сервером FTP. Параметр Port задает альтернативный номер порта (по умолчанию используется значение 21, стандартный номер порта FTP). Наконец, если параметр Passive равен true, все пересылки выполняются в пассивном режиме (требование некоторых брандмауэров и прокси-серверов). Параметры Firewall и Passive переопределяют переменные окружения FTP_FIREWALL и FTP_PASSIVE.
Следующим после подключения шагом является аутентификация. Обычно функция login вызывается с тремя аргументами: именем пользователя, паролем и учетной записью (account).
$ftp->logm()
or die 'Couldn't authenticate.\n";
$ftp->login($username)
or die "Still couldn't authenticate.\n",
$ftp->login($username, Spassword)
or die "Couldn't authenticate, even with explicit username and password.\n";
$ftp->login($username, Spassword, Saccount) or die "No dice. It hates me.\n";
Если вызвать login без аргументов, Net::FTP с помощью модуля Net::Netrc определяет параметры хоста, к которому вы подключились. Если данные не найдены, делается попытка анонимной регистрации (пользователь anonymous, пароль username@hostname). Если при имени пользователя anonymous пароль не задан, в качестве пароля передается почтовый адрес пользователя. Дополнительный аргумент (учетная запись) в большинстве систем не используется. При неудачной аутентификации функция login возвращает undef.
После завершения аутентификации стандартные команды FTP выполняются с помощью методов, вызываемых для объекта Net::FTP. Методы get и put принимают и отправляют файлы. Отправка файла выполняется так:
$ftp->put($localfile, $remotefile)
or die "Can't send $localfile. $!\n";
Если второй аргумент отсутствует, имя удаленного файла совпадает с именем локального файла. Передаваемые данные также можно брать из файлового манипулятора (в этом случае имя удаленного файла передается в качестве второго аргумента):
$ftp->put(*STDIN, $remotefile)
or die "Can't send from STDIN: $!\n";
Если пересылка прерывается, удаленный файл не удаляется автоматически. Метод put возвращает удаленное имя файла при успешном завершении или undef в случае ошибки.
Метод get, используемый для приема файлов, возвращает локальное имя файла или undef в случае ошибки:
$ftp->get($remotefile, Slocalfile)
or die 'Can't fetch $remotefile . $'\n",
Метод get тоже может использоваться для приема файла в манипулятор; он возвращает манипулятор (или undef в случае ошибки):
$ftp->get($remotefile, *STD0UT)
or die "Can't fetch Sremotefile: $>\n";
Необязательный третий аргумент get, смещение в удаленном файле, инициирует пересылку с заданного смещения. Принятые байты дописываются в конец локального файла.
Метод type изменяет режим трансляции файла. Если передать ему строку ("А", "I", "E" или "L"), возвращается предыдущий режим трансляции. Методы ascii, binary, ebcdic и byte вызывают type с соответствующей строкой. При возникновении ошибок (например, если сервер FTP не поддерживает EBCDIC) type и вспомогательные методы возвращают undef.
Методы cwd($remotedir) и pwd используются для установки и определения текущего удаленного каталога. Оба метода возвращают true в случае успеха и false в противном случае. При вызове cwd(". ") вызывается метод cdup для перехода в родительский каталог текущего каталога. Вызов cwd без аргументов выполняет переход в корневой каталог.
$ftp->cwd("/pub/perl/CPAN/images/g-rated"); print "I'm in the directory ", $ftp->pwd(), "\n';
Методы mkdir($remotedir) и rmdir($remotedir) создают и, соответственно, удаляют каталоги на удаленном компьютере. Для создания и удаления каталогов на локальном компьютере применяются встроенные функции mkdir и rmdir. Чтобы создать промежуточные каталоги на пути к указанному, передайте mkdir второй аргумент, равный true. Например, чтобы создать каталоги /pub, /pub/gnat и pub/gnat/perl, воспользуйтесь следующим вызовом:
$ftp->mkdir(' /pub/gnat/perl' , 1)
or die 'Can't create /pub/gnat/perl recursively: $t\n";
Методы Is и di г возвращают список содержимого удаленного каталога. Традиционно dir выводит более подробную информацию, чем Is, но в обоих случаях стандартного формата не существует. Большинство серверов FTP выводит результаты команд Is и Is -l, но нельзя гарантировать, что это правило будет соблюдаться всеми серверами. В списковом контексте эти методы возвращают список строк, возвращенных сервером. В скалярном контексте возвращается ссылка на массив.
@lines = $ftp->ls("/pub/gnat/perl")
or die "Can't get a list of files in /pub/gnat/perl: $!"; $ref_to_lines = $ftp->dir(7pub/perl/CPAN/src/latest. tar.gz")
or die "Can't check status of latest.tar.gz: $!\n";
Для корректного завершения работы с FTP используется метод quit: $ftp->quit() or warn "Couldn't quit. Oh well.\n";
Другие методы переименовывают удаленные файлы, меняют владельца и права доступа, проверяют размер удаленных файлов и т. д. За подробностями обращайтесь к документации по модулю Net::FTP.
Если вы хотите организовать зеркальное копирование файлов между компьютерами, воспользуйтесь превосходной программой mirror, написанной на Perl Ли Маклафлином (Lee McLoughlin) {http://sunsite.doc.ic.ac.uk/packages/mirror/)."
t> Смотри также--------------------------------------------------------------------------------------------
Страницы руководства ftp(i) uftpd(8) вашей системы (если есть); документация по модулю Net::FTP с CPAN.
18.3. Отправка почты
Проблема
Ваша программа должна отправлять почту. Некоторые программы следят за системными ресурсами — например, свободным местом на диске — и рассылают сообщения о том, что ресурс достиг опасного предела. Авторы сценариев CGI часто делают так, чтобы при нарушениях работы базы данных программа не сообщала об ошибке пользователю, а отправляла сообщение о проблеме администратору базы данных.
Решение
Воспользуйтесь модулем Mail::Mailer с CPAN: use Mail::Mailer;
Smaller = Mail::Mailer->new(); $mailer->open({ From => $from_address,
To => $to_address,
Subject => $subject,
or die "Can't open: $!\n"; print Smaller $body; $mailer->close();
Кроме того, можно воспользоваться программой sendmail:
open(SENDMAIL, "|/usr/lib/sendmail -01 -t -odq")
or die "Can't fork for sendmail: $'\n"; print SENOMAIL «"EOF"; From: User Originating Mail <me\@host> To: Final Destination <you\@otherhost> Subject: A relevant subject line
Body of the message goes here, in as many lines as you like.
EOF
close(SENDMAIL) or warn "sendmail didn't close nicely";
Комментарий
Существуют три варианта отправки почты из программы. Во-первых, можно воспользоваться внешней программой, которая обычно применяется пользователями для отправки почты — например, Mail или mailx; такие программы называются «пользовательскими почтовыми агентами» (MUA, Mail User Agents). Во-вторых, существуют почтовые программы системного уровня (например, sendmail); они называются «транспортными почтовыми агентами» (МТА, Mail Transport Agents). Наконец, можно подключиться к серверу SMTP (Simple Mail Transfer Protocol). К сожалению, стандартной программы пользовательского уровня не существует, для sendmail не определено стандартного местонахождения, а протокол SMTP довольно сложен. Модуль MaihMailer от CPAN избавляет вас от этих сложностей.
При установке модуль MaihMailer ищет mail, Mail и другие имена, под которыми обычно скрываются программы отправки почты. Кроме того, он просматривает некоторые распространенные каталоги, где может находиться sendmail. При создании объекта MaihMailer вы получаете удобный доступ к этим программам (и почтовым серверам SMTP), не заботясь о структуре аргументов или о возвращаемых ошибках.
Создайте объект MaihMailer конструктором Mail: :Mailer->new. При вызове конструктора без аргументов используется метод отправки почты по умолчанию (вероятно, с помощью внешней программы типа mail). Аргументы new позволяют выбрать альтернативный способ отправки сообщений. Первый аргумент определяет способ отправки ("mail" для пользовательских почтовых агентов UNIX, "sendmail" для программы sendmail и "smtp " для подключения к серверу SMTP). Необязательный второй аргумент определяет путь к программе.
Например, следующая команда приказывает MaihMailer использовать sendmail вместо способа отправки, принятого по умолчанию:
Smaller = Mail::Mailer->new("sendmail");
В следующем примере вместо mail используется почтовая программа /u/gnat/ bin/funkymailer:
Smaller = Mail::Mailer->new("smtp", "mail.myisp.com");
При возникновении ошибки в любой части Mail::Mailer вызывается die. Следовательно, для проверки ошибок следует включить код отправки почты в блок eval, после чего проверить переменную $@:
eval {
Smaller = Mail.:Mailer->new("bogus", "arguments");
tt ... }. if ($@) {
# Неудачный вызов eval
print "Couldn't send mail: $@\n"; } else {
# Успешный вызов eval
print "The authorities have been notified \n'; }
Если конструктор new не понимает переданные аргументы или не имеет метода по умолчанию при отсутствии аргументов, он инициирует исключение. Модуль Mail::Mailer запускает почтовую программу или подключается к серверу SMTP лишь после вызова метода open для заголовков сообщения:
$mailer->open( 'From' => 'Nathan Torkington <gnat@frii.com>', 'To' => Tom Christiansen <tchnst@perl.com>', 'Subject1 => 'The Perl Cookbook' );
Если попытка запустить программу или подключиться к серверу завершилась неудачно, метод open инициирует исключение. После успешного вызова open переменную Smaller можно интерпретировать как файловый манипулятор и вывести в нее основной текст сообщения:
print Smaller «EO_SIG;
Мы когда-нибудь закончим эту книгу?
Жена грозится уйти от меня
Она говорит, что я люблю EMACS больше, чем ее.
Что делать'
Нат EO_SIG
Завершив отправку текста, вызовите функцию close для объекта Mail::Mailer:
close(Smailer) or die "can't close mailer: $!";
Впрочем, с программой sendmail можно общаться и напрямую:
open(SENDMAIL, " |/usr/sbm/sendmail -01 -t -odq")
or die "Can't fork for sendmail: $!\n"; print SENOMAIL «"EOF";
From: Tom Christiansen <tchrist\@perl com> To: Nathan Torkmgton <gnat\@fm com> Subject: Re: The Perl Cookbook
(1) Мы никогда не закончим эту книгу.
(2) Тот, кто работает с EMACS, не заслуживает любви.
(3) Переходи на vi.
Том EOF close(SENDMAIL);
Перед нами тривиальное использование функции open для запуска другой программы (см. рецепт 16.4). Нам приходится указывать полный путь к sendmail, поскольку местонахождение этой программы меняется от компьютера к компьютеру. Обычно она находится в каталоге /usr/lib или /usr/sbin. Флаги, передаваемые sendmail, говорят о том, что программа не должна завершаться при чтении строки, состоящей из одной точки (-ог); что адресат сообщения определяется по данным заголовка (-£); а также о том, что вместо немедленной доставки сообщение должно помещаться в очередь {-odq). Последний параметр важен лишь при отправке больших объемов почты — без него компьютер быстро захлебнется в многочисленных процессах sendmail. Чтобы сообщение доставлялось немедленно (например, во время тестирования или при срочной доставке почты), удалите -odq из командной строки.
Мы выводим функцией print все сообщение — заголовки и основной текст, разделяя их пустой строкой. Не существует специальных служебных символов для вставки новых строк (как в некоторых пользовательских почтовых программах), поэтому весь текст интерпретируется буквально. Sendmail добавляет заголовки Date и Message-ID (которые все равно пришлось бы генерировать вручную).
Некоторые версии Perl (особенно для Windows и Мае) не имеют аналогов sendmail или mail. В таких случаях отправка почты осуществляется через сервер SMTP.
> Смотри также---------------------------------------------------------------------------------------------
Описание функции open в perlfunc(\); рецепты 16.4; 16.10; 16.19; 19.6; определение протокола SMTP в документе RFC 821, а также дополнения в последующих RFC.
18.4. Чтение и отправка новостей Usenet
Проблема
Вы хотите подключиться к серверу новостей Usenet для чтения и отправки новостей. Ваша программа может периодически отправлять материалы, собирать статистику по конференции или идентифицировать новичков, чтобы отправить им приветственное сообщение.
Воспользуйтесь модулем Net::NNTP с CPAN:
use Net::NNTP;
$server = Net::NNTP->new("news.host.dom")
or die "Can't connect to news server: $@\n"; ($narticles, $first, $last, $name) = $server->group( "misc.test" )
or die "Can't select misc.test\n"; $headers = $server->head($first)
or die "Can't get headers from article $first in $name\n"; $bodytext = $server->body($first)
or die "Can't get body from article $first in $name\n"; $article = $server->article($first)
or die "Can't get article $first from $name\n";
$server->postok()
or warn "Server didn't tell me I could post.\n";
$server->post( [ ©lines ] ) or die "Can't post: $'\n";
Комментарий
Usenet представляет собой распределенную систему конференций. Обмен сообщениями между серверами обеспечивает одинаковое содержимое всех находящихся на них конференций. Каждый сервер устанавливает собственный критерий, определяющий максимальный срок хранения сообщений. Клиентские программы подключаются к выделенному серверу (обычно принадлежащему их организации, Интернет-провайдеру или университету), получая возможность читать существующие или отправлять новые сообщения.
Каждое сообщение состоит из набора заголовков и основного текста, разделенных пустой строкой. Сообщения идентифицируются двумя способами: заголовком идентификатора сообщения и номером сообщения в конференции. Идентификатор сообщения хранится внутри самого сообщения. Он заведомо остается уникальным независимо от того, с какого сервера Usenet было прочитано сообщение. Если сообщение ссылается на другие сообщения, оно также использует их идентификаторы. Идентификатор сообщения представляет собой строку вида:
<0401@jpl-devvax.JPL.NASA.GOV>
Также возможна идентификация сообщений по конференции и номеру внутри конференции. Каждый сервер Usenet присваивает своим сообщениям собственные номера, поэтому правильность ссылок гарантирована лишь для того сервера Usenet, с которого они были получены.
Конструктор Net::NNTP подключается к заданному серверу Usenet. Если соединение не удается установить, он возвращает undef и присваивает переменной $@ сообщение об ошибке. Если соединение было успешно установлено, new возвращает новый объект Net::NNTP:
Sserver = Net::NNTP->new("news.mycompany.com')
or die 'Couldn't connect to news.mycompany.com' $@\n";
После установки соединения метод list возвращает список конференций в виде ссылки на хэш, ключи которого соответствуют именам конференций. Ассоциированные значения представляют собой ссылки на массивы, содержащие первый допустимый номер сообщения в конференции, последний допустимый номер сообщения в конференции и строку флагов. Флаги обычно равны "у" (отправка разрешена), но также могут быть равны "т " (модерируемая конференция) или =ИМЯ (данная конференция дублирует конференцию ИМЯ). На сервере могут храниться свыше 17000 конференций, поэтому выборка всего списка требует некоторого времени.
Sgrouplist = $server->list()
or die "Couldn't fetch group list\n";
foreach $group (keys %$grouplist) {
if ($grouplist->{$group}->[2] eq 'y') { # Отправка в $group разрешена
По аналогии с концепцией текущего каталога в FTP, протокол NNTP ( NetNews Transfer Protocol) поддерживает концепцию текущей конференции. Назначение текущей конференции выполняется методом group:
($narticles, $first, $last, $name) = $server->group("comp.lang.perl.misc") or die "Can't select сотр.lang.perl.misc\n";
Метод group возвращает список из четырех элементов: количество сообщений в конференции, номер первого сообщения, номер последнего сообщения и название конференции. Если конференция не существует, возвращается пустой список.
Содержимое сообщений можно получить двумя способами: вызвать метод article с идентификатором сообщения или выбрать конференцию методом group, а затем вызвать article с номером сообщения. В скалярном контексте метод возвращает ссылку на массив строк. В списковом контексте возвращается список строк. При возникновении ошибки article возвращает false:
@>lines = $server->article($message_id)
or die "Can't fetch article $article_number- $!\n";
Для получения заголовка и основного текста сообщения используются соответственно методы head и body. Как и article, они вызываются для идентификатора или номера сообщения и возвращают список строк или ссылку на массив:
@group = $server->group("comp lang.perl.misc")
or die "Can't select group comp lang perl misc\n"; @lines = $server->head($group[1])
or die "Can't get headers from first article in сотр.lang.perl.misc\n";
Метод post отправляет новое сообщение. Он получает список строк или ссылку на массив строк и возвращает true при успешной отправке или false в случае неудачи.
Метод postok позволяет узнать, разрешена ли отправка сообщений на данный сервер Usenet:
unless ($server->postok()) {
warn "You may not post.\n"; >
Полный список методов приведен в man-странице модуля Net::NNTP.
> Смотри также------------------------------------------------------------------------
Документация по модулю Net:: NNTP от CPAN; RFC 977, «Network News Transport Protocol»; страницы руководства trn(l) и innd(8) вашей системы (если есть).
18.5. Чтение почты на серверах РОРЗ
Проблема
Требуется принять почту с сервера РОРЗ. Например, программа может получать данные о непрочитанной почте, перемещать ее с удаленного сервера в локальный почтовый ящик или переключаться между Интернетом и локальной почтовой системой.
Решение
Воспользуйтесь модулем Net::POP3 с CPAN:
$рор = Net::P0P3->new($mail_server)
or die "Can't open connection to $mail_server : $!\n"; $pop->login($username, $password)
or die "Can't authenticate: $!\n"; $messages = $pop->list
or die "Can't get list of undeleted messages: $!\n"; foreach $msgid (keys 9t$messages) {
Smessage = $pop->get($msgid);
unless (defined Smessage) {
warn "Couldn't fetch $msgid from server: $!\n"; next;
>
# Smessage - ссылка на массив строк
$pop->delete($msgid); }
Комментарий
Традиционно в доставке почты участвовали три стороны: МТА (транспортный почтовый агент — системная программа типа sendmail) доставляет почту в накопитель (spool), а затем сообщения читаются с помощью MUA (пользователь-
18.5. Чтение почты на серверах РОРЗ 657
ские почтовые агенты — программы типа mail). Такая схема появилась в те времена, когда почта хранилась на больших серверах, а пользователи читали сообщения на простейших терминалах. По мере развития PC и сетевых средств появилась потребность в MUA (таких, как Pine), которые бы работали на пользовательских компьютерах (а не на том компьютере, где находится накопитель). Протокол POP (Post Office Protocol) обеспечивает эффективное чтение и удаление сообщений во время сеансов TCP/IP.
Модуль Net::POP3 от CPAN обслуживает клиентскую сторону POP. Иначе говоря, он позволяет программе на Perl выполнять функции MUA. Работа с Net::POP3 начинается с создания нового объекта Net::POP3. Конструктору new передается имя сервера РОРЗ:
$рор = Net::P0P3->new( "pop.myisp.com" )
or die "Can't connect to pop.myisp.com: $!\n";
При возникновении ошибок все функции Net::POP3 возвращают undef или пустой список в зависимости от контекста вызова. При этом переменная $! может содержать осмысленное описание ошибки (а может и не содержать).
Кроме того, конструктору new можно передать дополнительные аргументы и определить тайм-аут (в секундах) для сетевых операций:
$рор = Net::P0P3->new( "pop.myisp.com", Timeout => 30 ) or die "Can't connect to pop.myisp.com : $!\n";
Метод login выполняет аутентификацию на сервере РОРЗ. Он получает два аргумента — имя пользователя и пароль, но оба аргумента являются необязательными. Если пропущено имя пользователя, используется текущее имя. Если пропущен пароль, Net::POP3 пытается определить пароль с помощью модуля Net::Netrc:
$pop->login("gnat", "S33kr1T Pa55w0r0")
or die "Hey, my username and password didn't work!\n";
$pop->login( "midget" ) # Искать пароль с помощью Net::Netrc or die "Authentication failed.\n";
$pop->login() # Текущее имя пользователя и Net::Netrc
or die "Authentication failed. Miserably.\n";
При вызове метода login пароль пересылается по сети в виде обычного текста. Это нежелательно, поэтому при наличии модуля MD5 от CPAN можно воспользоваться методом арор. Он полностью идентичен login за исключением того, что пароль пересылается в текстовом виде:
$рор->арор( $username, $password )
or die "Couldn't authenticate: $!\n";
После аутентификации методы list, get и delete используются для работы с накопителем. Метод list выдает список неудаленных сообщений, хранящихся в
%undeleted = $pop->list(),
foreach Smsgnum (keys %undeleted) {
print "Message Smsgnum is $undeleted{$msgnum} bytes long \n"; }
Чтобы принять сообщение, вызовите метод get с нужным номером. Метод возвращает ссылку на массив строк сообщения:
print Retrieving Smsgnum $message = $pop->get($msgnum), if ($message) {
# succeeded
print "\n';
print @$message, # Вывести сообщение
} else {
# failed
print 'failed ($' )\n ',
}
Метод delete помечает сообщение как удаленное. При вызове метода quit, завершающего сеанс РОРЗ, помеченные сообщения удаляются из почтового ящика. Метод reset отменяет все вызовы delete, сделанные во время сеанса. Если сеанс завершается из-за того, что объект Net::POP3 уничтожен при выходе из области действия, метод reset будет вызван автоматически.
Возможно, вы заметили, что мы ничего не сказали об отправке почты. РОРЗ поддерживает только чтение и удаление существующих сообщений. Новые сообщения приходится отправлять с помощью программ типа mail или sendmail или протокола SMTP. Другими словами, рецепт 18.3 все равно пригодится.
Основная задача РОРЗ — подключение почтовых клиентов к почтовым серверам — также выполняется протоколом IMAP. IMAP обладает более широкими возможностями и чаще используется на очень больших узлах.
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулю Net::POP3 с CPAN; RCS 1734, «РОРЗ AUTHentication command»; RFC 1957, «Some Observations on Implementations of the Post Office Protocol».
18.6. Программная имитация сеанса telnet
Проблема
Вы хотите обслуживать подключение telnet в своей программе — регистрироваться на удаленном компьютере, вводить команды и реагировать на них. Такая задача имеет много практических применений — от автоматизации на компьютерах с доступом telnet, но без поддержки сценариев или rsh, до обычной проверки работоспособности демона telnet на другом компьютере.
Решение
Воспользуйтесь модулем Net::Telnet с CPAN:
use Net.'Telnet;
$t = Net..Telnet->new( Timeout => 10,
Prompt => '/%/', Host => $hostname ),
$t->login($username, Spassword);
©files = $t->cmd("ls"),
$t->pnnt("top");
(undef, $process_string) = $t->waitfor('/\d+ processes/'),
$t->close,
Комментарий
Модуль Net::Telnet поддерживает объектно-ориентированный интерфейс к про токолу telnet. Сначала вы устанавливаете соединение методом Net: :Telnet->new, a затем взаимодействуете с удаленным компьютером, вызывая методы полученного объекта.
Метод new вызывается с несколькими параметрами, передаваемыми в хэш-подобной записи (параметр => значение). Мы упомянем лишь некоторые из многих допустимых параметров. Самый важный, Host, определяет компьютер, к которому вы подключаетесь. По умолчанию используется значение localhost. Чтобы использовать порт, отличный от стандартного порта telnet, укажите его в параметре Port. Обработка ошибок выполняется функцией, ссылка на которую передается в параметре Errmode.
Еще один важный параметр — Prompt. При регистрации или выполнении команды модуль Net::Telnet по шаблону Prompt определяет, завершилась ли регистрация или выполнение команды. По умолчанию Prompt совпадает со стандартными приглашениями распространенных командных интерпретаторов:
/[\$%#>] $/
Если на удаленном компьютере используется нестандартное приглашение, вам придется определить собственный шаблон. Не забудьте включить в него символы /.
Параметр Timeout определяет продолжительность (в секундах) тайм-аута при сетевых операциях. По умолчанию тайм-аут равен 10 секундам.
Если в модуле Net::Telnet происходит ошибка или тайм-аут, по умолчанию инициируется исключение. Если не перехватить его, исключение выводит сообщение в STDERR и завершает работу программы. Чтобы изменить это поведение, передайте в параметре Errmode ссылку на подпрограмму. Если вместо ссылки Errmode содержит строку "return", то при возникновении ошибок методы возвращают undef (в скалярном контексте) или пустой список (в списковом контексте); при этом сообщение об ошибке можно получить с помощью метода errmsg:
Itelnet = Net 'Telnet->new( Errmode => sub { main:-log(@_) }, .. );
$telnet->login($username, Spassword)
or die Login failed @>{[ $telnet->errmsg() ]}\n ,
Для запуска программы и получения ее вывода применяется метод cmd. Он получает командную строку и возвращает выходные данные программы. В списковом контексте возвращается список, каждый элемент которого соответствует отдельной строке. В скалярном контексте возвращается одна длинная строка. Перед возвратом метод ожидает выдачи приглашения, определяемого по шаблону Prompt.
Пара методов, print и waitfor, позволяет отделить отправку команды от получения ее выходных данных, как это было сделано в решении. Метод waitfor получает либо набор именованных аргументов, либо одну строку с регулярным выражением Perl:
$telnet->waitfor( /--more--/ )
Параметр Timeout определяет новый тайм-аут, отменяя значение по умолчанию. Параметр Match содержит оператор совпадения (см. выше), a String — искомую строковую константу:
$telnet->waitfor(String => greasy smoke , Timeout => 30)
В скалярном контексте waitfor возвращает true, если шаблон или строка были успешно найдены. В противном случае выполняется действие, определяемое параметром Errmode. В списковом контексте метод возвращает две строки: весь текст до совпадения и совпавший текст.
Смотри также
Документация по модулю Net::Telnet с CPAN; RFC 854-856 и дополнения в последующих RFC.
18.7. Проверка удаленного компьютера
Проблема
Требуется проверить доступность сетевого компьютера. Сетевые и системные программы часто используют для этой цели программу ping.
Решение
Воспользуйтесь стандартным модулем Net::Ping:
use Net Ping,
$p = Net Pmg->new()
or die Can t create new ping object $'\n
print $host is alive if $p->ping($host), $p->close,
Комментарий
Проверить работоспособность компьютера сложнее, чем кажется. Компьютер может реагировать на команду ping даже при отсутствии нормальной фунционально-сти; это не только теоретическая возможность, но, как ни печально, распространенное явление. Лучше рассматривать утилиту ping как средство для проверки доступности компьютера, а не выполнения им своих функций. Чтобы решить последнюю задачу, вы должны попытаться обратиться к его демонам (telnet, FTP, Web, NFS и т. д.).
В форме, показанной в решении, модуль Net::Ping пытается подключиться к эхо-порту UDP (порт 7) на удаленном компьютере, отправить датаграмму и получить эхо-ответ. Компьютер считается недоступным, если не удалось установить соединение, если отправленная датаграмма не была получена или если ответ отличался от исходной датаграммы. Метод ping возвращает t rue, если компьютер доступен, и false в противном случае.
Чтобы использовать другой протокол, достаточно передать его имя при вызове new Допустимыми являются протоколы tcp, udp и icmp (записываются в нижнем регистре). При выборе протокола TCP программа пробует подключиться к эхо-порту TCP (порт 7) удаленного компьютера и возвращает true при успешной установке соединения и false в противном случае (в отличие от UDP пересылка данных не выполняется). При выборе ICMP будет использован протокол ICMP, как в команде ping(8). На компьютерах UNIX протокол ICMP может быть выбран только привилегированным пользователем:
# Использовать ICMP при наличии привилегий и TCP в противном случае $pong = Net Pmg->new( $> ? tcp icmp )
(defined $pong)
or die Couldn t create Net Ping object $'\n ,
if ($pong->ping( kmgkong com )) {
print The giant ape lives1\n } else {
print All hail mighty Gamera, friend of children1\n , }
Ни один из этих способов не является абсолютно надежным. Маршрутизаторы некоторых узлов отфильтровывают протокол ICMP, поэтому Net::Ping сочтет такие компьютеры недоступными даже при возможности подключения по другим протоколам. Многие компьютеры запрещают эхо-сервис TCP и UDP, что приводит к неудачам при опросе через TCP и UDP. Запрет службы или фильтрацию протокола невозможно отличить от неработоспособности компьютера.
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулю Net::Ping; страницы руководства ping(8), tcp{2>), udp(4) и icmp{4) вашей системы (если есть); RFC 792 и 950.
Проблема
Вы хотите узнать, кому принадлежит домен (по аналогии с командой UNIX
whois).
Решение
Воспользуйтесь модулем Net::Whois с CPAN:
use Net Whois,
$domain_obj = Net Whois . Domam->new($domain_name)
or die 'Couldn t get information on $domain_name $'\n',
# Вызвать методы объекта $domain_obj
# для получения имени, тега, адреса и т д
Комментарий
Сервис whois предоставляется службой регистрации доменных имен и предназначается для идентификации владельца имени. Исторически в системах семейства UNIX эти данные получались с помощью программы whois(l), которая возвращала около 15 строк информации, включая имена, адреса и телефоны административных, технических и финансовых контактных лиц домена.
Модуль Net::Whois, как и whois(l), является клиентом службы whois. Он подключается к серверу whois (по умолчанию используется whois.internic.net, главный сервер доменов ".com", ".org.", ".net" и ".edu"). Доступ к данным осуществляется с помощью методов, вызываемых для объекта.
Чтобы получить информацию о домене, создайте объект Net::Whois::Domain. Например, для получения данных о perl.org объект создается так:
$d = Net Whois Domam->new( 'perl org' )
or die 'Can't get information on perl org\n-,
Гарантируется только получение имени домена и тега — уникального идентификатора домена в учетных записях NIC:
print 'The domain is called ", $d->domain, '\n', print "Its tag is ", $d->tag, '\n",
Также могут присутствовать следующие данные: название организации, которой принадлежит домен (например, "The Perl Institute"); адрес компании в виде списка строк (например, ("221В Baker Street", "London")) и страна (например, "United Kingdom" или двухбуквенное сокращение "uk").
print 'Mail for ", $d->name, ' should be sent to \n", print map { "\t$_\n" } $d->address; print '\t", $d->country, "\n",
Кроме информации о самом домене также можно получить сведения о контактных лицах домена. Метод contact возвращает ссылку на хэш, в котором тип контакта (например, "Billing" или "Administrative") ассоциируется с массивом строк.
$contact_hash = $d->contacts; if ($contact_hash) { print "Contacts:\n";
foreach Jtype (sort keys %$contact_hash) { print " $type:\n";
foreach $line (@{$contact_hash->{$type}}) { print ' $line\n",
else {
print "No contact information.\n",
t> Смотри также--------------------------------------------------------------------------------------------
Документация по модулю Net::Whois с CPAN; man-страница whois(8) вашей системы (если есть); RFC 812 и 954.
18.9. Программа: ехрп и vrfy
Программа ехрп напрямую общается с сервером SMTP и проверяет адрес с помощью команд EXPN и VRFY. Она не идеальна, поскольку ее работа зависит от получения достоверной информации с удаленного сервера командами EXPN и VRFY. Программа использует модуль Net::t)NS, если он присутствует, но может работать и без него.
Программа узнает, как она была вызвана, с помощью переменной $0 (имя программы). При запуске под именем ехрп используется команда EXPN; при запуске под именем vrfy используется команда VRFY. Установка команды под двумя разными именами осуществляется с помощью ссылок:
% cat > ехрп
Я1 /usr/bm/perl -w
"D
% In ехрп vrfy
Передайте программе адрес электронной почты, и она сообщит результаты проверки адреса командой EXPN или VRFY. Если у вас установлен модуль Net::DNS, программа проверяет все хосты пересылки почты (mail exchangers), перечисленные в записи DNS данного адреса.
Без Net::DNS результаты выглядят так:
% ехрп gnat@frn.com
Expanding gnat at frii.com (gnatefrii.com):
calisto.frii.com Hello coprolith.frii.com [207.46.130.14],
pleased to meet you <gnat@mail.frii.com>
% ехрп gnat@frii.com
Expanding gnat at mail.frii.net (gnatefrii.com):
deimos.frii.com Hello coprolith.frii.com [207.46.130.14],
pleased to meet you Nathan Torkington <gnatedeimos.frii.com>
Expanding gnat at mx1.frii.net (gnatefrii.com); phobos.frii.com Hello coprolith.frii.com [207.46.130.14],
pleased to meet you <gnat©mail.frii. com>
Expanding gnat at mx2.frii.net (gnatefrii.com): europa.frii.com Hello coprolith.frii.com [207.46.130.14],
pleased to meet you <gnat#mail.frii.com>
Expanding gnat at mx3.frii.net (gnatefrii.com): ns2.winterlan.com Hello coprolith.frii.com [207.46.130.14],
pleased to meet you 550 gnat... User unknown
Исходный текст программы приведен в примере 18.3. Пример 18.3. ехрп
#!/usr/bin/perl -w
# ехрп - расширение адресов через SMTP
use strict;
use 10::Socket;
use Sys::Hostna*me;
my $fetch_mx = 0;
8 Попытаться загрузить модуль, но не огорчаться в случае неудачи
eval {
require Net::DNS;
Net::DNS->import('mx');
$fetch_mx = 1;
my Sselfname = hostname();
die "usage: $0 address\@host ..,\n" unless @ARGV;
# Определить имя программы - "vrfy" или "ехрп".
ray $VERB = ($0 =~ /ve'ri/PfyS/i) ? 'VRFY1 : 'EXPN1 my $multi = @ARGV > 1; my $ remote;
# Перебрать адреса, указанные в командной строке
foreach my $combo (@ARGV) {
my ($name, $host) = split(/\@/, $combo); my ©hosts;
$host ||= 'localhosf;
©hosts = map { $_->exchange } mx($host) if $fetch_mx;
<g>hosts = ($host) unless @hosts;
foreach my $host (@hosts) {
print $VERB eq 'VRFY1 ? "Verify" : "Expand", "ing $name at $host ($combo):";
Sremote = 10::Socket::INET->new( Proto => "tcp", PeerAddr => $host, PeerPort => "smtp(25)",
unless (Sreroote) {
warn "cannot connect to $host\n"; next;
print "\n"; $remote->autoflush(1);
# Использовать сетевые разделители строк CRLF print Sremote "HELO $selfname\015\012"; print $remote "$VERB $name\015\012"; print $remote "quit\O15\O12"; while (<$remote>) {
/"220\b/ U next;
/~221\b/ && last;
s/250\b[\-\s]+//; print;
close(Sremote) or die "can't close socket: $!' print "\n";
Программирование
CGIХорош тот инструмент, который может использоваться для целей, неожиданных для его создателя.
Стивен Джонсон
Введение
Резкие изменения окружающей среды приводят к тому, что некоторые виды лучше других добывают пропитание или избегают хищников. Многие ученые полагают, что миллионы лет назад при столкновении кометы с Землей в атмосферу поднялось огромное облако пыли. За этим последовали радикальные изменения окружающей среды. Некоторые организмы — например, динозавры — не смогли справиться с ними, что привело к их вымиранию. Другие виды (в частности, млекопитающие) нашли новые источники пищи и места обитания и продолжили борьбу за существование.
Подобно тому, как комета изменила среду обитания доисторических животных, развитие Web изменило ситуацию в современных языках программирования и открыло новые горизонты. Хотя некоторые языки так и не прижились в «новом мировом порядке», Perl выдержал испытание. Благодаря своим сильным сторонам — обработке текстов и объединению системных компонентов — Perl легко приспособился к задачам пересылки информации с использованием текстовых протоколов.
Архитектура
В основе Web лежит обычный текст. Web-серверы общаются с броузерами с помощью текстового протокола HTTP (Hypertext Transfer Protocol). Многие пересылаемые документы кодируются специальной разметкой, которая называется HTML (Hypertext Markup Language). Текстовая ориентация внесла немалый вклад в гибкость, широту возможностей и успех Web. Единственным исключением на этом фоне является протокол SSL (Secure Socket Layer) — он шифрует другие протоколы (например, HTTP) в двоичные данные, защищенные от перехвата.
Web- страницы идентифицируются по так называемым URL (Universal Resource Locator). URL выглядят так:
http://www.perl.com/CPAN/
http://www.perl.com:8001/bad/mojo.html
ftp://gatekeeper.dec.com/pub/misc/netlib.tarZ
ftp://anonymous@myplace:gatekeeper.dec.com/pub/misc/netlib.tar.Z
file:///etc/motd
Первая часть (http, ftp, file) называется схемой и определяет способ получения файла. Вторая {://) означает, что далее следует имя хоста, интерпретация которого зависит от схемы. За именем хоста следует путь, идентифицирующий документ. Путь также называется частичным URL.
Web является системой «клиент/сервер». Клиентские броузеры (например, Netscape или Lynx) запрашивают документы (идентифицируемые по частичным URL) у Web-серверов — таких, как Apache. Диалог броузера с сервером определяется протоколом HTTP. В основном сервер просто пересылает содержимое некоторого файла. Однако иногда Web-сервер запускает другую программу для отправки документа, который может представлять собой HTML-текст, графическое изображение или иной тип данных. Диалог сервера с программой определяется протоколом CGI (Common Gateway Interface), а запускаемая сервером программа называется программой CGI или сценарием CGI.
Сервер сообщает программе CGI, какая страница была затребована, какие значения были переданы в HTML-формах, откуда поступил запрос, какие данные использовались при аутентификации и многое другое. Ответ программы CGI состоит из двух частей: заголовка, говорящего «Я передаю документ HTML», «Я передаю изображение формата GIF» или «Я вообще ничего не передаю, обращайся на такую-то страницу», и тела документа (возможно, содержащего данные GIF, обычный текст или код HTML).
Правильно реализовать протокол CGI нелегко, а ошибиться проще простого, поэтому мы рекомендуем использовать превосходный модуль CGI.pm Линкольна Штейна (Lincoln Stein). Модуль содержит удобные функции для обработки информации, полученной от сервера, и подготовки ответов CGI, ожидаемых сервером. Это чрезвычайно полезный модуль был включен в стандартную поставку Perl версии 5.004 вместе с вспомогательными модулями (например, CGI::Carp или CGI::Fast). Использование модуля демонстрируется в рецепте 19.1.
Некоторые Web- серверы содержат встроенный интерпретатор Perl, что позволяет генерировать документы на Perl без запуска нового процесса. Системные издержки на чтение неизменившейся страницы пренебрежимо малы для страниц с редкими обращениями (даже порядка нескольких обращений в секунду). Однако вызовы CGI существенно замедляют компьютер, на котором работает Web-сервер. В рецепте 19.5 показано, как работать с mod_perl, встроенным интерпретатором Perl Web-сервера Apache, чтобы пользоваться преимуществами программ CGI без издержек, связанных с ними.
За кулисами
Программы CGI вызываются каждый раз, когда Web-серверу требуется сгенерировать динамический документ. Необходимо понимать, что программа CGI
Броузер может запросить документ несколькими способами, которые называются методами (не путайте методы HTTP с методами объектно-ориентированного программирования!). Чаще всего встречается метод GET, который обозначает простой запрос документа. Метод HEAD используется в том случае, если броузер хочет получить сведения о документе без фактической загрузки. Метод POST применяется при передаче заполненных форм.
Значения полей форм также могут кодироваться в методах GET и POST. В методе GET значение кодируется прямо в URL, что приводит к появлению уродливых URL следующего вида:
http://mox.per!.com/cgi-bin/program?name=Johann&born=1685
В методе POST значения находятся в другой части запроса HTTP — не той, которую броузер отправляет серверу. Если бы в приведенном выше URL значения полей отсылались методом POST, то пользователь, сервер и сценарий CGI видели бы обычный URL:
http://mox.perl.com/cgi-bin/program
Методы GET и POST также отличаются свойством идемпотентности. Проще говоря, однократный или многократный запрос GET для некоторого URL должен давать одинаковые результаты. Это объясняется тем, что в соответствии со спецификацией протокола HTTP запрос GET может кэшироваться броузером, сервером или промежуточным прокси-сервером. Запросы POST не могут кэшироваться, поскольку каждый запрос считается самостоятельным и независимым от других. Как правило, запросы POST влияют на состояние сервера или зависят от него (обращение или обновление базы данных, отправка почты).
Большинство серверов регистрирует запросы к файлам (ведут журнал обращений) для их последующего анализа Web-мастером. Ошибки в программах CGI тоже по умолчанию не передаются броузеру. Вместо этого они регистрируются в файле (журнал ошибок), а броузер просто получает сообщение «500 Server Error», которое означает, что программа CGI не справилась со своей задачей.
Сообщения об ошибках полезны в процессе отладки любой программы, но особенно полезны они в сценариях CGI. Однако авторы программ CGI не всегда имеют доступ к журналу ошибок или не знают, где он находится. Перенаправление ошибок рассматривается в рецепте 19.2, а исправление — в рецепте 19.3.
В рецепте 19.9 показано, как узнать, что в действительности говорят друг другу броузер с сервером. К сожалению, некоторые броузеры не реализуют спецификацию HTTP в полной мере. Рецепт поможет выяснить, что является причиной возникших трудностей — программа или броузер.
Безопасность
Сценарии CGI позволяют запускать программы на вашем компьютере кому угодно. Конечно, программу выбираете вы, но анонимный пользователь может
Введение 669
передать ей неожиданные значения и обмануть ее, заставляя сделать нечто нехорошее. Безопасности в Web уделяется большое внимание.
Некоторые узлы решают проблему, попросту отказываясь от программ CGI. Там, где без силы и возможностей программ CGI не обойтись, приходится искать средства обезопасить их. В рецепте 19.4 приведен список рекомендаций по написанию безопасных сценариев CGI, а также кратко рассмотрен механизм пометки, защищающий от случайного применения ненадежных данных. В рецепте 19.6 показано, как организовать безопасный запуск других программ из сценария CGI.
HTML и формы
Теги HTML позволяют создавать экранные формы. В этих формах пользователь вводит значения, передаваемые серверу. Формы состоят из элементов (widgets) — например, текстовых полей и флажков. Программы CGI обычно возвращают HTML-код, поэтому в модуле CGI предусмотрены вспомогательные функции создания HTML-кода для чего угодно, от таблиц до элементов форм.
В дополнение к рецепту 19.7 в этой главе также имеется рецепт 19.11. В нем показано, как создать форму, сохраняющую свои значения между вызовами. В рецепте 19.12 продемонстрировано создание одного сценария CGI, который создает и обрабатывает целый набор страниц — например, в системе приема заказов по каталогу.
Ресурсы Web
Разумеется, лучшую информацию о программировании Web можно найти непосредственно в Web. Безопасность Web
http://www.w3.org/Security/Faq/
Общие сведения о Web
http://www.boutell.com/faq/
CGI
http://www.webthing.com/tutorials/cgifaq.html
Спецификация HTTP
http://www.w3.org/pub/WWW/Protocols/HTTP/
Спецификация HTML
http://www.w3.org/TR/REC-html40/ http://www.w3.org/pub/WWW/MarkUp/
Спецификация CGI
http://www.w3.org/CGI/
Безопасность CGI
http://www.go2net.com/people/paulp/cgi-security/safe-cgi.txt
670 Глава 19 • Программирование CGI
19.1. Написание сценария CGIПроблема
Требуется написать сценарий CGI для обработки содержимого HTML-формы. В частности, вы хотите работать со значениями полей формы и выдавать нужные выходные данные.
Решение
Сценарий CGI представляет собой программу, работающую на сервере и запускаемую Web-сервером для построения динамического документа. Он получает кодированную информацию от удаленного клиента (пользовательского броузера) через STDIN и переменные окружения и выводит в STDOUT правильные заголовки и тело запросов HTTP. Стандартный модуль CGI (см. пример 19.1) обеспечивает удобное преобразование ввода и вывода.
Пример 19.1. hiweb
#!/usr/bin/perl -w
И hiweb - загрузить модуль CGI для расшифровки
# данных, полученных от Web-сервера
use strict;
use CGI qw(:standard escapeHTML);
# Получить параметр от формы
my $value = param('PARAM_NAME');
# Вывести документ
print header(), start_html("Howdy there1"),
pfYou typed' ¦', tt(escapeHTML($value))), end_html();
Комментарий
CGI — всего лишь протокол, формальное соглашение между Web-сервером и отдельной программой. Сервер кодирует входные данные клиентской формы, а программа CGI декодирует форму и генерирует выходные данные. В спецификации протокола ничего не сказано о языке, на котором должна быть написана программа. Программы и сценарии, соответствующие протоколу CGI, могут быть написаны в командном интерпретаторе, на С, Rexx, C++, VMS DCL, Smalltalk, Tel, Python и, конечно, на Perl.
Полная спецификация CGI определяет, какие данные хранятся в тех или иных переменных окружения (например, входные параметры форм) и как они кодируются. Теоретически декодирование входных данных в соответствии с протоколом не должно вызывать никаких проблем, но на практике задача оказывается на удивление хитрой. Именно поэтому мы настоятельно рекомендуем использовать превосходный модуль CGI Линкольна Штейна. Вся тяжелая работа по пра-
вильной обработке требований CGI выполнена заранее; вам остается лишь написать содержательную часть программы без нудных сетевых протоколов.
Сценарии CGI вызываются двумя основными способами, которые называются методами, — но не путайте методы HTTP с методами объектов Perl! Метод GET используется для получения документов в ситуациях, когда идентичные запросы должны давать идентичные результаты — например, при поиске в словаре. В методе GET данные формы хранятся внутри URL. Это позволяет сохранить запрос на будущее, но ограничивает общий размер запрашиваемых данных. Метод POST отправляет данные отдельно от запроса. Он не имеет ограничений на размер, но не может сохраняться. Формы, обновляющие информацию на сервере (например, при отправке ответного сообщения или модификации базы данных), должны использовать POST. Клиентские броузеры и промежуточные прокси-серверы могут кэшировать и обновлять результаты запросов GET незаметно для пользователя, но запросы POST не кэшируются. Метод GET надежен лишь для коротких запросов, ограничивающихся чтением информации, тогда как метод POST надежно работает для форм любого размера, а также подходит для обновления и ответов в схемах с обратной связью. По умолчанию модуль CGI использует POST для всех форм.
За небольшими исключениями, связанными с правами доступа к файлам и режимами повышенной интерактивности, сценарии CGI делают практически все то же, что и любая другая программа. Они могут возвращать результаты во многих форматах: обычный текст, документы HTML, звуковые файлы, графика и т. д. в зависимости от заголовка HTTP. Помимо вывода простого текста или HTML-кода, они также могут перенаправлять клиентский броузер в другое место, задавать серверные cookies, требовать аутентификации или сообщать об ошибках.
Модуль CGI поддерживает два интерфейса — процедурный для повседневного использования и объектно-ориентированный для компетентных пользователей с нетривиальными потребностями. Практически все сценарии CGI должны использовать процедурный интерфейс, но, к сожалению, в большей части документации по CGI.pm приведены примеры для исходного объектно-ориентированного подхода. Есди вы хотите использовать упрощенный процедурный интерфейс, то для обеспечения обратной совместимости вам придется явно запросить его с помощью тега : standard. О тегах рассказано в главе 12 «Пакеты, библиотеки и модули».
Чтобы прочитать входные данные пользовательской формы, передайте функции param имя нужного поля. Если на форме имеется поле с именем «favorite», то вызов param( "favorite") вернет его значение. В некоторых элементах форм (например, в списках) пользователь может выбрать несколько значений. В таких случаях param возвращает список значений, который можно присвоить массиву.
Например, следующий сценарий получает значения трех полей формы, последнее из которых может возвращать несколько значений:
use CGI qw(.standard), $who = param( 'Name"), $phone = param('Number'), @picks = param("Choices");
Вот и все, что нужно знать о пользовательском вводе. Делайте с ним, что хотите, а потом генерируйте выходные данные в нужном формате. В этом тоже нет ничего сложного. Помните, что, в отличие от обычных программ, выходные данные сценария CGI должны форматироваться определенным образом: сначала набор заголовков, за ними — пустая строка и лишь потом нормальный вывод.
Как видно из решения, модуль CGI упрощает не только ввод, но и вывод данных. Он содержит функции для генерации заголовков HTTP и HTML-кода. Функция header строит текст заголовка. По умолчанию она генерирует заголовки для документов text/html, но вы можете изменить тип содержимого и передать другие необязательные параметры:
print header( -TYPE => text/plain , -EXPIRES => +3d ),
Модуль CGI. pm также применяется для генерации HTML-кода. Звучит тривиально, но модуль CGI проявляется во всем блеске при создании динамических форм с сохранением состояния (например, страниц, предназначенных для оформления заказов). В модуле CGI даже имеются функции для генерации форм и таблиц.
При выводе элементов формы символы &, <, > и в выходных данных HTML автоматически заменяются своими эквивалентами. В пользовательских выходных данных этого не происходит. Именно поэтому в решении импортируется и используется функция escapeHTML — даже если пользователь введет специальные символы, это не вызовет ошибок форматирования в HTML.
Полный список функций вместе с правилами вызова приведен в документации по модулю CGI.pm, хранящейся в формате POD внутри самого модуля.
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю CGI; http://www.w3.org/CGI/; рецепт 19.7.
19.2. Перенаправление сообщений об ошибках
Проблема
У вас возникли трудности с отслеживанием предупреждений и ошибок вашего сценария, или вывод в STDERR из сценария приводит сервер в замешательство.
Решение
Воспользуйтесь модулем CGI::Carp из стандартной поставки Perl, чтобы все сообщения, направляемые в STDERR, снабжались префиксом — именем приложения и текущей датой. При желании предупреждения и ошибки также можно сохранять в файле или передавать броузеру.
Комментарий
Задача отслеживания сообщений в сценариях CGI пользуется дурной славой. Даже если вам удалось найти на сервере журнал ошибок, вы все равно не сможете определить, когда и от какого сценария поступило то или иное сообщение. Некоторые недружелюбные Web-серверы даже прерывают работу сценария, если он неосторожно выдал в STDERR какие-нибудь данные до генерации заголовка Content-Type — а это означает, что флаг -w может навлечь беду.
На сцене появляется модуль CGI::Carp. Он замещает warn и die, а также функции carp, croak и confess обычного модуля Carp более надежными и содержательными версиями. При этом данные по-прежнему отсылаются в журнал ошибок сервера.
use CGI Carp
warn This is a complaint ,
die But this one is serious ,
В следующем примере использования CGI::Carp ошибки перенаправляются в файл по вашему выбору. Все это происходит в блоке BEGIN, что позволяет перехватывать предупреждения на стадии компиляции:
BEGIN {
use CGI Carp qw(carpout),
open(LOG, >>/var/local/cgi-logs/mycgi-log ) or die Unable to append to mycgi-log $'\n ,
carpout(*l_OG), }
Фатальные ошибки могут даже возвращаться клиентскому броузеру — это удобно при отладке, но может смутить рядового пользователя.
use CGI Carp qw(fatalsToBrowser), die Bad error here ,
Даже если ошибка произойдет до вывода заголовка HTTP, модуль попытается избежать ужасной ошибки 500 Server Error. Нормальные предупреждения по-прежнему направляются в журнал ошибок сервера (или туда, куда вы отправили их функцией carpout) с префиксом из имени приложения и текущего времени.
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю CGI::Carp; описание BEGIN в рецепте 12.3.
19.3. Исправление ошибки 500 Server Error
Проблема
Сценарий CGI выдает ошибку 500 Server Error.
Решение
Воспользуйтесь приведенным ниже списком рекомендаций. Советы ориентированы на аудиторию UNIX, однако общие принципы относятся ко всем системам.
Убедитесь, что сценарий может выполняться Web-сервером. Проверьте владельца и права доступа командой Is -/. Чтобы сценарий мог выполняться сервером, для него должны быть установлены необходимые права чтения и исполнения. Сценарий должен быть доступен для чтения и исполнения для всех пользователей (или по крайней мере для того, под чьим именем сервер выполняет сценарии). Используйте команду chmod 0755 имя-сценария, если сценарий принадлежит вам, или chmod 0555 имя-сценария, если он принадлежит анонимному пользователю Web, а вы работаете как этот или привилегированный пользователь. Бит исполнения также должен быть установлен для всех каталогов, входящих в путь.
Проследите, чтобы сценарий идентифицировался Web-сервером как сценарий. Большинство Web- серверов имеет общий для всей системы каталог cgi-bin, и все файлы данного каталога считаются сценариями. Некоторые серверы идентифицируют сценарий CGI как файл с определенным расширением — например, .cgi или .рсх. Параметры некоторых серверов разрешают доступ только методом GET, а не методом POST, который, вероятно, используется вашей формой. Обращайтесь к документации по Web-серверу, конфигурационным файлам, Web-мастеру и (если ничего не помогает) в службу технической поддержки.
Если вы работаете в UNIX, проверьте, правильно ли задан путь к исполняемому файлу Perl в строке #'. Она должна быть первой в сценарии, перед ней даже не разрешаются пустые строки. Некоторые операционные системы устанавливают смехотворно низкие ограничения на размер этой строки — в таких случаях следует использовать ссылки (допустим, из /home/richh/perl на /opt/instatied/third-party/ software/perl-5.004/bin/perl — взят вымышленный патологический пример).
Если вы работаете в Win32, посмотрите, правильно ли связаны свои сценарии с исполняемым файлом Perl.
Проверьте наличие необходимых прав у сценария
Проверьте пользователя, с правами которого работает сценарий, с помощью простого фрагмента из примера 19.2.
Пример 19.2. webwhoami
#'/usr/bin/perl
tt webwhoami - show web users id
print Content-Type text/plain\n\n',
print Running as , scalar getpwuid($>), \n ,
Сценарий выводит имя пользователя, с правами которого он работает.
Определите ресурсы, к которым обращается сценарий. Составьте список файлов, сетевых соединений, системных функций и т. д., требующих особых привилегий. Затем убедитесь в их доступности для пользователя, с правами которого работает сценарий. Действуют ли дисковые или сетевые квоты? Обеспечивает ли защита файла доступ к нему? Не пытаетесь ли вы получить зашифрованный пароль с помощью getpwent в системе со скрытыми паролями (обычно скрытые пароли доступны только для привилегированного пользователя)?
Для всех файлов, в которые сценарий выполняет запись, установите права доступа 0666, а еще лучше — 0644, если они принадлежат тому пользователю, с чьими правами выполняется сценарий. Если сценарий создает новые файлы или перемещает/удаляет старые, потребуются также права записи и исполнения для каталога с ними.
Не содержит ли сценарий ошибок Perl?
Попытайтесь запустить его в командной строке. Модуль CGI.pm позволяет запускать и отлаживать сценарии в командной строке или из стандартного ввода. В следующем фрагменте "D — вводимый вами признак конца файла:
% perl -we cgi-script # Простая компиляция
% perl -w cgi-script # Параметры из stdin
(offline mode: enter name=value pairs on standard input)
name=joe
number=10
"D
% perl -w cgi-script name=joe number=10 # Запустить с входными
# данными формы % perl -d cgi-script name=joe number=10 # To же в отладчике
# Сценарий с методом POST в csh
% (setenv HTTP_METHOD POST, perl -w cgi-script name=joe number=10)
# Сценарий с методом POST в sh
% HTTP_METHOD=POST perl -w cgi-script name=joe number=10
Проверьте журнал ошибок сервера. Большинство Web-серверов перенаправляет поток STDERR для процессов CGI в файл. Найдите его (попробуйте /usr/local/ etc/httpd/logs/error_log, /usr/local/www/logs/error_log или спросите у администратора) и посмотрите, есть ли в нем предупреждения или сообщения об ошибках.
Не устарела ли ваша версия Perl? Ответ даст команда perl -v. Если у вас не установлена версия 5.004 или выше, вам или вашему администратору следует подумать об обновлении, поскольку 5.003 и более ранние версии не были защищены от переполнения буфера, из-за чего возникали серьезные проблемы безопасности.
Не используете ли вы старые версии библиотек? Выполните команду grep -i version для библиотечного файла (вероятно, находящегося в /usr/lib/perl5/, /usr/ Iocal/lib/perl5/, /usr/lib/perl5/site_perl или похожем каталоге). Для CGI.pm (а фактически — для любого модуля) версию можно узнать и другим способом:
% perl -MCGI -le 'print CGI->VERSION' 2.40
Используете ли вы последнюю версию Web-сервера? Хотя такое происходит редко, но все же в Web-серверах иногда встречаются ошибки, мешающие работе сценариев.
Используете ли вы флаг -w? С этим флагом Perl начинает жаловаться на неинициализированные переменные, чтение из манипулятора, предназначенного только для записи, и т. д.
Используете ли вы директиву use strict? Она заставляет объявлять переменные перед использованием и ограничивать кавычками строки, чтобы избежать возможной путаницы с подпрограммами, и при этом находит множество ошибок.
Проверяете ли вы возвращаемые значения всех системных функций? Многие люди наивно полагают, что любой вызов open, system, rename или unlink всегда проходит успешно. Они возвращают значение, по которому можно проверить результат их работы, — так проверьте!
Находит ли Perl используемые вами библиотеки? Напишите маленький сценарий, который просто выводит содержимое @INC (список каталогов, в которых ищутся модули и библиотеки). Проверьте права доступа к библиотекам (должно быть разрешено чтение для пользователя, с правами которого работает сценарий). Не пытайтесь копировать модули с одного компьютера на другой — многие из них имеют скомпилированные и автоматически загружаемые компоненты, находящиеся за пределами библиотечного каталога Perl. Установите их с нуля.
Выдает ли Perl предупреждения или сообщения об ошибках? Попробуйте использовать CGI::Carp (см. рецепт 19.2), чтобы направить предупреждения и ошибки в броузер или доступный файл.
Соблюдает ли сценарий протокол CGI?
Перед возвращаемым текстом или изображением должен находиться заголовок HTTP. He забывайте о пустой строке между заголовком и телом сообщения. Кроме того, STDOUT в отличие от STDERR не очищается автоматически. Если ваш сценарий направляет в STDERR предупреждения или ошибки, Web-сервер может увидеть их раньше, чем заголовок HTTP, и на некоторых серверах это приводит к ошибке. Чтобы обеспечить автоматическую очистку STDOUT, вставьте в начало сценария следующую команду (после строки #' ):
$1 = 1,
Никогда не пытайтесь декодировать поступающие данные формы, самостоятельно анализируя окружение и стандартный ввод — возникает слишком много возможностей для ошибок. Воспользуйтесь модулем CGI и проводите время за творческим программированием или чтением Usenet, вместо того чтобы возиться с поиском ошибок в доморощенной реализации мудреного протокола.
Справочная информация
Обратитесь к спискам FAQ и другим документам, перечисленным в конце введения этой главы. Возможно, вы допустили какую-нибудь распространенную ошибку для своей системы — прочитайте соответствующий FAQ, и вам не придется краснеть за вопросы типа: «Почему моя машина не ездит без бензина и масла?»
Спросите других. Почти у каждого есть знакомый специалист, к которому можно обратиться за помощью. Вероятно, ответ найдется намного быстрее, чем при обращении в Сеть.
Если ваш вопрос относится к сценариям CGI (модуль CGI, декодирование cookies, получение данных о пользователе и т. д.), пишите в сотр.infosystems. www.authoring.misc.
> Смотри также---------------------------------------------------------------------------------------------
Рецепт 19.2; сведения о буферизации во введении к главе 8 «Содержимое файлов»; CGI FAQ по адресу http://www.webthing.com/tutorials/cgifaq.html.
19.4. Написание безопасных программ CGI
Проблема
Поскольку сценарий CGI позволяет внешнему пользователю запускать программы на недоступном для него компьютере, любая программа CGI представляет потенциальную угрозу для безопасности. Вам хотелось бы свести эту угрозу к минимуму.
Решение
• Воспользуйтесь режимом пометки (флаг -Тв строке #').
• Не снимайте пометку с данных (см. ниже).
• Проверяйте все, в том числе возвращаемые значения всех элементов формы,
даже скрытые элементы и значения, сгенерированные кодом JavaScript.
Многие наивно полагают — раз они приказали JavaScript проверить значе
ния полей формы перед отправкой данных, то значения действительно бу
дут проверены. Ничего подобного! Пользователь может тривиально обой
ти ограничения — запретить JavaScript в своем броузере, загрузить форму и
модифицировать JavaScript или общаться на уровне HTTP без броузера
(см. главу 20 «Автоматизация в Web»).
• Проверяйте значения, возвращаемые системными функциями.
• Помните о возможности перехвата (см. ниже).
• Используйте флаг -w и директиву use strict, чтобы застраховаться от непра
вильных допущений со стороны Perl.
• Никогда не запускайте сценарий со сменой прав, если только это не вызва
но абсолютной необходимостью. Подумайте, не будет ли достаточно сменить
идентификтор группы. Любой ценой избегайте запуска с правами админи
стратора. Если вам приходится использовать setuid или setgid, используйте
командный интерпретатор, если только на вашей машине нельзя безопасно
запускать сценарии Perl с setuid и вы точно знаете, что это такое.
• Всегда шифруйте пароли, номера кредитных карт, номера социального
страхования и все остальное, что обычно не печатается на первых страни
цах местных газет. При работе с такими данными следует использовать бе
зопасный протокол SSL
Многие из этих рекомендаций подходят для любых программ — флаг -хю и проверка значений, возвращаемых системными функциями, пригодятся и в тех ситуациях, когда безопасность не является первоочередной заботой. Флаг -w заставляет Perl выводить предупреждения о сомнительных конструкциях (например, когда неопределенная переменная используется так, словно ей присвоено законное значение, или при попытке записи в манипулятор, доступный только для чтения).
Самая распространенная угроза безопасности ( не считая непредвиденных вызовов командного интерпретатора) кроется в передаче форм. Кто угодно может сохранить исходный текст формы, отредактировать HTML-код и передать измененную форму. Даже если вы уверены, что поле может возвращать только yes или по , его всегда можно отредактировать и заставить возвращать maybe . Даже скрытые поля, имеющие тип HIDDEN, не защищены от вмешательства извне. Если программа на другом конце слепо полагается на значения полей, ее можно заставить удалять файлы, создавать новые учетные записи пользователей, выводить информацию из баз данных паролей или кредитных карт и совершать множество других злонамеренных действий. Вот почему нельзя слепо доверять данным (например, информации о цене товара), хранящимся в скрытых полях при написании приложений CGI для электронных магазинов.
Еще хуже, если сценарий CGI использует значение поля формы как основу для выбора открываемого файла или выполняемой команды. Ложные значения, переданные сценарию, заставят его открывать произвольные файлы. Именно из-за таких ситуаций в Perl появился режим помеченных данных. Если программа выполняет setuid или имеет активный флаг -Т, то любые данные, получаемые ею в виде аргументов, переменных окружения, списков каталогов или файлов, считаются ненадежными и не могут прямо или косвенно воздействовать на внешний мир.
В этом режиме Perl настаивает на том, чтобы переменная пути задавалась заранее, даже если при запуске программы указывается полный путь. Дело в том, что нельзя быть уверенным, что выполняемая команда не вызовет другую программу по относительному имени. Кроме того, вы должны снимать пометку со всех внешних данных.
Например, при выполнении в режиме пометки фрагмента:
#'/usr/bin/perl -T
open(FH > $ARGV[O] ) or die,
Perl выдает следующее предупреждение:
Insecure dependency in open while running with -T switch at ...
Это объясняется тем, что значение $ARGV[O] (поступившее в программу извне) считается не заслуживающим доверия. Единственный способ снять пометку с ненадежных данных — использовать обратные ссылки в регулярных выражениях:
Jfile = $ARGV[O], n $file помечена
unless ($file =" m#"([\w -]+)$#) { # С $1 снята пометка
die filename $file has invalid characters \n ,
}
$file = $1, # С $file снята пометка
Помеченные данные могут поступать из любого источника, находящегося вне
программы, — например, из аргументов или переменных окружения, из результа
тов чтения файловых или каталоговых манипуляторов, команды stat или данных
о локальном контексте. К числу операций, которые считаются ненадежными с по
меченными данными, относятся: system(CTPOKA), exec(CTPOKA), , glob, open в
любом режиме, кроме «только для чтения», unlink, mkdir, rmdir, chown, chmod, umask,
link, symlmk, флаг командной строки -s, kill, require, eval, truncate, loctl,
fcntl, socket, socketpair, bind, connect, chdir, chroot, setgrp, setpriority и syscall
Один из распространенных видов атаки связан с так называемой ситуацией перехвата (race condition). Ситуация перехвата возникает тогда, когда нападающий вмешивается между двумя вашими действиями и вносит какие-то изменения, нарушающие работу программу. Печально известная ситуация перехвата возникала при работе setuid-сценариев в старых ядрах UNIX. Между тем как ядро читало файл и выбирало нужный интерпретатор и чтением файла интерпретатором после setuid злонамеренный чужак мог подставить свой собственный сценарий.
Ситуации перехвата возникают даже во внешне безобидных местах Допустим, у вас одновременно выполняется не одна, а сразу несколько копий следующего кода:
unless (-e Sfilename) { # НЕВЕРНО'
open(FH > Sfilename )
# }
Между проверкой существования файла и его открытием для записи возникает возможность перехвата. Что еще хуже, если файл заменится ссылкой на что-нибудь важное (например, на ваш личный конфигурационный файл), предыдущий фрагмент сотрет этот файл Правильным решением является неразрушающее создание функцией sysopen (см. рецепт 7.1).
Setuid-сценарий CGI работает с другими правами, нежели Web-сервер. Так он получает возможность работать с ресурсами (файлами, скрытыми базами данных паролей и т д ), которые иначе были бы для него недоступны. Это может быть удобно, но может быть и опасно. Из-за недостатков setuid-сценариев хакеры могут получить доступ не только к файлам, доступным для Web-сервера с его низкими привилегиями, но и к файлам, доступным для пользователя, с правами которого работает сценарий. Плохо написанный сценарий, работающий с правами системного администратора, позволит кому угодно изменить пароли, удалить файлы, прочитать данные кредитных карт и совершить иные злодеяния. По этой причине программа всегда должна работать с минимальным возможным уровнем привилегий, как правило — со стандартными для Web-сервера правами nobody.
Наконец, принимайте во внимание физический путь вашего сетевого трафика (возможно, это самая трудная из всех рекомендаций). Передаете ли вы незашифрованные пароли? Не перемещаются ли они по ненадежной сети? Поле формы PASSWORD защищает лишь от тех, кто подглядывает из-за плеча. При работе с паролями всегда используйте SSL. Если вы серьезно думаете о безопасности, беритесь за броузер и программу перехвата пакетов, чтобы узнать, легко ли расшифровать ваш сетевой трафик.
680 Глава 19 • Программирование CGI
О Смотри также---------------------------------------------------------------------------------------------- Perlsec(l); спецификации CGI и HTTP, а также список FAQ по безопасности CGI, упомянутые во введении этой главы; раздел «Avoiding Denial of Service Attacks» в стандартной документации по модулю CGI; рецепт 19.6.
19.5. Повышение эффективности сценариев CGI
Проблема
От частых вызовов вашего сценария CGI снижается производительность сервера. Вы хотите уменьшить нагрузку, связанную с работой сценария.
Решение
Используйте модуль mod_perl Web-сервера Apache и включите в файл httpd.conf следующую секцию:
Alias /perl/ /real/path/to/perl/scripts/
<Location /perl> SetHandler perl- script PerlHandler Apache Registry Options ExecCGI </Location>
PerlModule Apache Registry PerlModule CGI PerlSendHeader On
Комментарий
Модуль mod_perl Web-сервера Apache позволяет писать код Perl, который может выполняться на любой стадии обработки запроса. Вы можете написать свои собственные процедуры регистрации и аутентификации, определить виртуальные хосты и их конфигурацию и написать собственные обработчики для некоторых типов запросов.
Приведенный выше фрагмент сообщает, что URL, начинающиеся с /perl/, в действительности находятся в /real/path/to/perl/scripts и обрабатываются Apache::Registry. В результате они будут выполняться в среде CGI. Строка PerlModule CGI выполняет предварительную загрузку модуля CGI, a PerlSendHandler On позволяет большинству сценариев CGI работать с mod_perl.
/perl/ работает аналогично /cgi-bin/. Чтобы суффикс .perl являлся признаком сценариев CGI mod_perl, подобно тому, как суффикс .cgi является признаком обычных сценариев CGI, включите в конфигурационный файл Apache следующий фрагмент:
<Files * perl> SetHandler perl-script
Options ExecCGI
</Files>
Поскольку интерпретатор Perl, выполняющий сценарий CGI, не выгружается из памяти при завершении сценария (что обычно происходит, когда Web-сервер выполняет сценарий как отдельную программу), не следует полагаться на то, что при запуске программы глобальные переменные имеют неопределенные значения. Флаг -w и use strict проверяют многие недостатки в сценариях такого рода. Существуют и другие потенциальные ловушки — обращайтесь к странице руководства mod_perl_traps.
Не беспокойтесь о том, насколько снизится быстродействие Web-сервера от предварительной загрузки всех сценариев. Все равно когда-нибудь придется загружать их в память; желательно, чтобы это произошло до того, как Apache начнет плодить потомков. В этом случае каждый сценарий будет находиться в памяти в единственном экземпляре, поскольку в любой современной операционной системе потомки используют общие страницы памяти. Иначе говоря, предварительная загрузка только на первый взгляд увеличивает расходы памяти — на самом деле она их уменьшает!
По адресу http://www.perl.com/CPAN-local/modules/by-modules/Netscape/nsapi_ perl-0.24.tar.gz имеется интерфейс к серверу Netscape, который также повышает производительность за счет отказа от порождения новых процессов.
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулям Bundle::Apache, Apache, Apache::Registry от CPAN; http://perl.apache.org/, http://perl apache.org/faqa/, man-страницы mod_perl(3) и cgi_to_mod_perl(l) (если есть).
19.6. Выполнение команд без обращений к командному интерпретатору
Проблема
Пользовательский ввод должен использоваться как часть команды, но вы не хо
тите, чтобы пользователь заставлял командный интерпретатор выполнять другие
команды или обращаться к другим файлам. Если просто вызвать функцию system
или с одним аргументом (командной строкой), то для выполнения может
быть использован командный интерпретатор, а это небезопасно.
Решение
В отличие от одноаргументной версии, списковый вариант функции system надежно защищен от обращений к командному интерпретатору. Если аргументы команды содержат пользовательский ввод от формы, никогда не используйте вызовы вида:
system( command $mput @files ), # НЕНАДЕЖНО
system("command", $input, ©files); # НАДЕЖНЕЕ
Комментарий
Поскольку Perl разрабатывался как «язык-клей», в нем легко запустить другую программу — в некоторых ситуациях даже слишком легко.
Если вы просто пытаетесь выполнить команду оболочки без сохранения ее вывода, вызвать system в многоаргументной версии достаточно просто. Но что делать, если вы используете команду в '... ' или она является аргументом функции open? Возникают серьезные трудности, поскольку эти конструкции в отличие от system не позволяют передавать несколько аргументов. Возможное решение — вручную создавать процессы с помощью fork и exec. Работы прибавится, но, по крайней мере, непредвиденные обращения к командному интерпретатору не будут портить вам настроение.
Обратные апострофы используются в сценариях CGI лишь в том случае, если передаваемые аргументы генерируются внутри самой программы;
chomp($now = 'date');
Но если команда в обратных апострофах содержит пользовательский ввод — например:
©output = 'grep $input ©files'; приходится действовать намного осторожнее.
die "cannot fork: $! " unless defined ($pid = open(SAFE_KID, "|-")); if ($pid == 0) {
exec('grep', $input, (Sfiles) or die "can't exec grep: $!"; } else {
(aoutput = <SAFE_KID>;
close SAFE_KID; # $' содержит информацию состояния
}
Такое решение работает, поскольку exec, как и system, допускает форму вызова, свободную от обращений к командному интерпретатору. При передаче списка интерпретатор не используется, что исключает возможные побочные эффекты.
При выполнении команды функцией open также потребуется немного потрудиться. Начнем с открытия функцией open конвейера для чтения. Вместо ненадежного кода:
open(KID_TO_READ, '$program ©options @args |"); # НЕНАДЕЖНО используется более сложный, но безопасный код:
# Добавить обработку ошибок
die "cannot fork; $!" unless defined($pid = open(KID_TO_READ, "-|"));
if ($pid) { о Родитель while (<KID_TO__READ>) {
# Сделать что-то интересное
19.7. Форматирование списков и таблиц средствами HTML 683
close(KID_TO_READ) or warn "kid exited P";
} else { # Потомок
# Переконфигурировать, затем
exec($program, ©options, @args) or die "can't exec program: $!"; }
Безопасный конвейерный вызов open существует и для записи. Ненадежный вызов:
open(KID_TO_WRITE, "|$program Soptions @args"); ft НЕНАДЕЖНО заменяется более сложным, но безопасным кодом:
$pid = open(KID_TO_WRITE, "|-");
die "cannot fork: $!" unless defmed($pid = open(KID_TO_WRITE, "|-"));
$SIG{ALRM} = sub { die "whoops, $program pipe broke" };
if ($pid) { ff Родитель
for (@data) { print KID_TO_WRITE $_ )
close(KID_TO_WRITE) or warn "kid exited $¦?";
> else { # Потомок
# Переконфигурировать, затем
exec($program, ^options, @args) or die "can't exec program: S1"; >
Там, где комментарий гласит «Переконфигурировать», предпринимаются до полнительные меры безопасности. Вы находитесь в порожденном процессе, и вносимые изменения не распространяются на родителя. Можно изменить переменные окружения, сбросить временный идентификатор пользователя или группы, сменить каталог или маску umask и т. д.
Разумеется, все это не поможет в ситуации, когда вызов system запускает программу с другим идентификатором пользователя. Например, почтовая программа sendma.il является setuid-программой, часто запускаемой из сценариев CGI. Вы должны хорошо понимать риск, связанный с запуском sendtnail или любой другой setuid-программы.
> Смотри также--------------------------------------------------------------------------------------------
Описание функций system, exec и open вperlfunc(l); perkec(l); рецепты 16.1—16.3.
19.7. Форматирование списков и таблиц средствами HTML
Проблема
Требуется сгенерировать несколько списков и таблиц. Нужны вспомогательные функции, которые бы упростили вашу работу.
Модуль CGI содержит вспомогательные функции HTML, которые получают ссылку на массив и автоматически применяются к каждому элементу массива:
print ol( li([ qw(red blue green)]) ); <OL><LI>red</LI> <LI>blue</LI> <LI>green</LIx/OL> @>names = qw(Larry Мое Curly); print ul( li({ -TYPE => "disc" }, \@names) ); <ULXLI TYPE="disc">Larry</LI> <LI TYPE="disc">Moe</LI> <LI TYPE="disc">Curly</LIX/UL>
Комментарий
Свойство дистрибутивности функций CGI.pm, генерирующих HTML-код, заметно упрощает процесс генерации списков и таблиц. При передаче простой строки эти функции просто выдают HTML-код для данной строки. Но при передаче ссылки на массив они применяются ко всем строкам.
print li("alpha");
<LI>alpha</LI> print li( [ "alpha", "omega"] );
<LI>alpha</LI> <LI>omega</LI>
Вспомогательные функции для списков загружаются при использовании тега : standard, но для получения вспомогательных функций для работы с таблицами придется явно запросить :html3. Кроме того, возникает конфликт между тегом <TR>, которому должна соответствовать функция tr(), и встроенным оператором Perl t r///. Следовательно, для построения строк таблицы следует использовать функцию Тг().
Следующий пример генерирует таблицу HTML по хэшу массивов. Ключи хэша содержат заголовки строк, а массивы значений — столбцы.
use CGI qw(-standard :html3);
%hash = (
"Wisconsin" => [ "Superior", "Lake Geneva", "Madison" ],
"Colorado" => [ "Denver", "Fort Collins", "Boulder" ],
"Texas" => [ "Piano", "Austin", "Fort Stockton" ],
"California" => [ "Sebastopol", "Santa Rosa", "Berkeley" ],
$\ = "\n";
print "<TABLE> <CAPTION>Cities I Have Known</CAPTION>" print Tr(th [qw(State Cities)]); for $k (sort keys %hash) {
print Tr(th($k), td( [ sort @{$hash{$k}} ] )); > print "</TABLE>";
Генерируется следующий текст:
<TABLE> <CAPTION>Cities I Have Known</CAPTION> <TRXTH>State</TH> <TH>Cities<AHX/TR> <TR><TH>California</TH> <TD>Berkeley</TD> <TD>Santa Rosa</TD>
<TD>SebastopoK/TD> <AR> <TR><TH>Colorado</TH> <TD>Boulder</TD> <TD>Denver</TD>
<TD>Fort Collins</TD> </TR> <TRXTH>Texas</TH> <TD>Austin</TD> <TD>Fort Stockton</TD>
<TD>Plano</TDx/TR> <TR><TH>Wisconsin</TH> <TD>Lake Geneva</TD> <TD>Madison</TD>
<TD>Superior</TDx/TR> </TABLE>
Те же результаты можно получить всего одной командой print, хотя это несколько сложнее, поскольку вам придется создавать неявный цикл с помощью тар. Следующая команда print выдает результат, идентичный приведенному выше:
print table
caption('Cities I have Known'),
Tr(th [qw(State Cities)]),
map { Tr(th($_), td( [ sort @{$hash{$_}} ] )) } sort keys %hash;
Эти функции особенно удобны при форматировании результатов запроса к базе данных, как показано в примере 19.3 (см. главу 14 «Базы данных»).
Пример 19.3. salcheck
#!/usr/bin/perl
# salcheck - проверка жалованья
use OBI;
use CGI qw(:standard :html3);
$limit = paranC'LIMIT");
print headerO, start_html("Salary Query"), h1("Search"), start_form(),
pC'Enter minimum salary", textfield("LIMIT")), submit(), end_form();
if (defined $limit) {
$dbh = DBI->connect("dbi:nysql:somedb:server.host.dom:3306",
"username", "password")
or die "Connecting: $DBI::errstr"; $sth = $dbh->prepare("SELECT name,salary FROM employees
WHERE salary > $limit")
or die "Preparing: ", $dbh->errstr; $sth->execute
or die "Executing: ", $sth->errstr;
print h1("Results"), "<TABLE BORDER=1>";
продолжение ¦&
while (@row = $sth->fetchrow()) { print Tr( td( \@row ) ),
print '</TABLE>\n'-;
$sth->finish;
$dbh->disconnect;
print end_html();
> Смотри также
Документация по стандартному модулю CGI; рецепт 14.10.
19.8. Перенаправление клиентского броузера
Проблема
Требуется сообщить клиентскому броузеру о том, что страница находится в другом месте.
Решение
Вместо обычного заголовка выведите перенаправление и завершите программу. Не забудьте о дополнительной пустой строке в конце заголовка:
$url = "httpy/www.perl com/CPAN/", print "Location' $url\n\n'; exit;
Комментарий
Иногда программа CGI не генерирует документ сама. Она лишь сообщает клиенту о том, что ему следует получить другой документ. В этом случае заголовок HTTP содержит слово Location, за которым следует новый URL. Обязательно используйте абсолютный, а не относительный URL.
Прямолинейного решения, показанного выше, обычно вполне хватает. Но если модуль CGI уже загружен, воспользуйтесь функцией redirect. В примере 19.4 эта возможность применяется при построении cookie.
Пример 19.4. oreobounce
#'/usr/bin/perl -w
# oreobounce - установить cookie и перенаправить броузер use CGI qw(.cgi);
$oreo = cookie( -NAME => 'filling1,
-VALUE => 'vanilla creme",
-EXPIRES => '+ЗМ', # М - месяц, m - минута
-DOMAIN => '.perl con');
$whither = "http://soraewhere.perl com/nonesuch.html";
print redirect( -URL => Swhither, -COOKIE => $oreo);
Результат выглядит так:
Status: 302 Moved Temporarily
Set-Cookie: filling=vanillaX20cr)!E4me; domain=. perl.com;
expires=Tue, 21-Jul-1998 11:58:55 GMT Date: Tue, 21 Apr 1998 11:55:55 GMT Location: http://somewhere.pe rlcom/nonesuch. html Content-Type: text/html B«blank line here»
В примере 19.5 приведена законченная программа, которая определяет имя клиентского броузера и перенаправляет его на страницу «Файла жаргона» Эрика Реймонда, где говорится о соответствующей операционной системе. Кроме того, в программе хорошо продемонстрирован альтернативный подход к созданию конструкций switch в Perl.
Пример 19.5. os_snipe
Kl/usr/bin/perl
# os_smpe - перенаправить в статью Файла жаргона,
# посвященную текущей операционной системе
$dir = "http://www.wins.uva.nl/%7Emes/jargon";
for ($ENV{HTTP_USER_AGENT}) {
$page = /Mac/ && "m/Macintrash.html"
|| /Wm(dows )?NT/ && "e/evilandrude.html"
|| /Wm|MSIE|WebTV/ && "m/MicroslothWmdows html"
|| /Linux/ && "1/Linux.html"
|| /HP-UX/ && "h/HP-SUX.html"
11 /SunOS/ && "s/ScumOS html"
|| "a/AppendixB.html";
} print "Location: $dir/$page\n\n";
В программе os_snipe использовано динамическое перенаправление, поскольку разные пользователи отсылаются на разные страницы. Если перенаправление всегда ведет к одному месту, разумнее включить статическую строку в конфигурационный файл сервера — это обойдется дешевле, чем запуск сценария CGI для каждого перенаправления.
Сообщить клиентскому броузеру, что вы не собираетесь выдавать никаких данных — далеко не то же самое, что перенаправить его «в никуда»:
use CGI qw(:standard);
print header( -STATUS => "204 No response" );
Status: 204 No response Content-Type: text/html <blank line here>
Например, этот вариант используется в ситуации, когда от пользователя приходит запрос, а вы не хотите, чтобы его страница изменилась или даже просто обновилась.
Выглядит немного глупо — сначала мы указываем тип содержимого, а потом говорим, что содержимого не будет, — но модуль поступает именно так. При ручном кодировании это бы не понадобилось.
s'/bin/sh
cat «EOCAT
Status' 204 No response
EOCAT
> Смотри также--------------------------------------------------------------------------------------------
Документация по стандартному модулю CGI.
19.9. Отладка на уровне HTTP
Проблема
Сценарий CGI странно ведет себя с броузером. Вы подозреваете, что в заголовке HTTP чего-то не хватает. Требуется узнать, что именно броузер посылает серверу в заголовке HTTP.
Решение
Создайте фиктивный Web-сервер (см. пример 19.6) и подключитесь к нему в своем броузере.
Пример 19.6. dummyhttpd
#'/usr/bin/perl -w
# dummyhttpd - запустить демона HTTP и выводить данные,
# получаемые от клиента
use strict;
use HTTP::Daemon, # Требуется LWP-5.32 и выше
my $server = HTTP::Daemon->new(Timeout => 60);
print "Please contact me at' <URL:", $server->url, ">\n",
while (my $client = $server->accept) { CONNECTION'
while (my $answer = $client->get_request) { print $answer->as_stnng;
19.9. Отладка на уровне HTTP 689
$client->autoflush; RESPONSE: while (<STDIN>) {
last RESPONSE if $_ eq ".\n";
last CONNECTION if $_ eq ".An";
print $client $_;
print "\nEOF\n";
print "CLOSE: ", $client->reason, "\n"; $client->close; undef Sclient; >
Комментарий
Трудно уследить за тем, какие версии тех или иных броузеров все еще содержат ошибки. Фиктивная программа-сервер может спасти от многодневных напряженных раздумий, поскольку иногда неправильно работающий броузер посылает серверу неверные данные. На своем опыте нам приходилось видеть, как броузеры теряли cookies, неверно оформляли URL, передавали неверную строку состояния и совершали менее очевидные ошибки.
Фиктивный сервер лучше всего запускать на том же компьютере, что и настоящий. При этом броузер будет отправлять ему все cookies, предназначенные для этого домена. Вместо того чтобы направлять броузер по обычному URL:
http://somewhere.com/cgi-bin/whatever
воспользуйтесь альтернативным портом, указанным в конструкторе new. При использовании альтернативного порта необязательно быть привилегированным пользователем, чтобы запустить сервер.
http://somewhere.com:8989/cgi-bin/whatever
Если вы решите, что клиент ведет себя правильно, и захотите проверить сервер, проще всего воспользоваться программой telnet для непосредственного общения с удаленным сервером.
% telnet www.perl com 80
GET /bogotic HTTP/1.0
<blank line here>
HTTP/1.1 404 File Not Found
Date: Tue, 21 Apr 1998 11:25:43 GMT
Server: Apache/1.2.4
Connection: close
Content-Type: text/html
<HTMLXHEAD>
<TITLE>404 File Not Found<^ITLE>
</HEAD><BODY>
<H1>File Not Found</H1>
The requested URL /bogotic was not found on this server.<P>
</B0DYx/HTML>
% GET -esuSU http://mox.perl.com/perl/bogotic
GET http://language.ре rl.com/bogotio Host: mox.perl.com User-Agent: lwp-request/1.32
GET http://mox.perl.com/perl/bogotic -> 302 Moved Temporarily
GET http://www.perl.com/perl/bogotic -> 302 Moved Temporarily
GET http://language.perl.com/bogotic -> 404 File Not Found
Connection: close
Date: Tue, 21 Apr 1998 11:29:03 GMT
Server: Apache/1.2.4
Content-Type: text/html
Client-Date: Tue, 21 Apr 1998 12:29:01 GMT
Client-Peer: 208.201.239.47:80
Title: Broken perl.com Links
<HTML>
<HEAD><TITLE>An Error Occurred</TITLE></HEAD>
<BODY>
<H1>An Error Occurred</h1>
404 File Not Found
</BOOY>
</HTML>
t> Смотри также-------------------------------------------------------------------------------------------
Документация по стандартному модулю CGI; рецепт 14.10.
19.10. Работа с cookies
Проблема
Вы хотите получить или создать cookie для хранения параметров сеанса или настроек пользователя.
Решение .
В модуле CGI.pm получение существующей cookie выполняется так:
$preference_value = cookieC preference name"); Cookie создаются следующим образом:
$packed_cookie = cookie( -NAME => "preference name",
-VALUE => "whatever you'd like", -EXPIRES => "+2y");
Чтобы сохранить cookie в клиентском броузере, необходимо включить ее в заголовок HTTP (вероятно, с помощью функций header или redirect):
print header(-COOKIE => $packed_cookie),
Комментарий
Cookies используются для хранения информации о клиентском броузере. Если вы работаете с Netscape в UNIX, просмотрите файл -/.netscape/cookies, хотя в нем содержатся не все cookies, а лишь те, которые присутствовали на момент последнего выхода из броузера. Cookies можно рассматривать как пользовательские настройки уровня приложения или как средство упростить обмен данными. Преимущества cookies заключаются в том, что они могут совместно использоваться несколькими разными программами и даже сохраняются между вызовами броузера.
Однако cookies также применяются и для сомнительных штучек типа анализа трафика. Нервные пользователи начинают гадать, кто и зачем собирает их личные данные. Кроме того, cookies привязаны к одному компьютеру. Если вы работаете с броузером у себя дома или в другом офисе, в нем не будет cookies из броузера, находящегося у вас на работе. По этой причине не следует ожидать, что каждый броузер примет cookies, которые вы ему даете. А если этого покажется недостаточно, броузеры могут уничтожать cookies по своему усмотрению. Ниже приведена выдержка из чернового документа «Механизм управления состоянием HTTP» (HTTP State Management Mechanism») по адресу http://portal.research.bell-labs.com/ ~dmk/cookie-2.81-3.1.txt.
«Поскольку пользовательские агенты обладают ограниченным пространством для хранения cookies, они могут удалять старые cookies, чтобы освободить место для новых — например, используя алгоритм удаления по сроку последнего использования в сочетании с ограничением максимального числа cookies, создаваемых каждым сервером.»
Cookies ненадежны, поэтому на них не стоит чрезмерно полагаться. Используйте их для простых транзакций с конкретным состоянием. Избегайте анализа трафика, это может быть принято за вмешательство в личные дела пользователей.
В примере 19. 7 приведена законченная программа, которая запоминает последний выбор пользователя.
Пример 19.7. ic_cookies
#'/usr/bin/perl -w
# ic_cookies - пример сценария CGI с использованием cookie use CGI qw( standard);
use strict;
my Scookname = "favorite ice cream ;
my Sfavorite = param("flavor"),
my Stasty = cookie($cookname) || "mint",
unless ($favonte) {
print header(), start_html('Ice Cookies"), h1("Hello Ice Cream'), hr(), start_form(),
692 Глава 19 • Программирование CGI Пример 19.7 (продолжение)
p("Please select a flavor: ", textfield("flavor",$tasty)),end_form(), hr(); exit;
my $cookie = cookie(
-NAME => $cookname,
-VALUE => Sfavonte,
-EXPIRES => "+2y",
print header(-COOKIE => $cookie),
start_html("Ice Cookies, #2"),
h1("Hello Ice Cream"),
p("You chose as your favorite flavor 'Sfavorite'.");
> Смотри также
Документация по стандартному модулю CGI.
19.11. Создание устойчивых элементов
Проблема
Вы хотите, чтобы по умолчанию в полях формы отображались последние использованные значения. Например, вы хотите создать форму для поисковой системы наподобие AltaVista (http://www.altavista.com), где над результатами отображаются искомые ключевые слова.
Решение
Создайте форму с помощью вспомогательных функций HTML, которые автоматически заносят в поле предыдущее значение:
print textfield("SEARCH"), # Предыдущее значение SEARCH
# используется по умолчанию
Комментарий
В примере 19.8 приведен простой сценарий для получения информации о пользователях, зарегистрированных в настоящее время.
Пример 19.8. who.cgi
#!/usr/bin/perl -wT
# who.cgi - вызвать who(1) для пользователя и отформатировать результат
$ENV{IFS}='';
$ENV{PATH}='/bin:/usr/bin';
use CGI qw(.standard),
U Вывести поисковую форму
print header(), start_htral("Query Users"), h1("Search");
print start_form(), p("Which user'", textfield("WHO")), submitO, end_form();
# Вывести результаты поиска $name = param("WH0"); if ($name) {
print h1("Results");
$html = '';
fl Вызвать who и построить текст ответа fо reach ('who') {
next unless /~$name\s/o, # Только строки, совпадающие с $name
s/&/&/g;
s/</</g;
s/>/>/g;
$html .= $_; >
# Если пользователь не найден, вывести сообщение $html = $html || "$name is not logged in",
print pre($html);
print end_html();
Функция textf leld генерирует HTML-код для текстового поля с именем параметра WHO. После вывода формы мы проверяем, было ли присвоено значение параметру WHO, и если было — ищем в результатах who строки данного пользователя.
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю CGI; рецепты 19.4; 19.7.
19.12. Создание многостраничного сценария CGI
Проблема
Требуется написать сценарий CGI, который бы возвращал броузеру несколько страниц. Допустим, вы хотите написать сценарий CGI для работы с базой данных продуктов. Он должен выводить несколько форм: общий список продуктов, формы для добавления новых и удаления существующих продуктов, для редактирования текущих атрибутов продуктов и т. д. Многостраничный сценарий CGI образует простейший вариант «электронного магазина».
Решение
Сохраните информацию о текущей странице в скрытом поле.
Модуль CGI позволяет легко генерировать устойчивые скрытые поля. Функция hidden возвращает HTML-код скрытого элемента и использует его текущее значение в том случае, если ей передается только имя элемента:
use CGI qw(.standard), print hidden("bacon");
Отображаемая страница («Общий список продуктов», «Список заказанных продуктов», «Подтверждение заказа» и т. д.) выбирается по значению скрытого поля. Мы назовем его . State, чтобы избежать возможных конфликтов с именами других полей. Для перемещения между страницами используются кнопки, которые присваивают . State имя новой страницы. Например, кнопка для перехода к странице «Checkout» создается так:
print submit(-NAME => ".State", -VALUE => "Checkout");
Для удобства можно создать вспомогательную функцию:
sub to_page { return submit( -NAME => ".State", -VALUE => shift ) }
Чтобы выбрать отображаемый код, достаточно проверить параметр . State:
$page = param(".State") || "Default";
Код, генерирующий каждую страницу, размещается в отдельной подпрограмме. Вообще говоря, нужную подпрограмму можно выбирать длинной конструкцией
if. .. elsif. .. elsif:
if ($page eq "Default") {
front_page(); } elsif ($page eq "Checkout") {
checkout(); } else {
no_such_page(); # Если .State ссылается на несуществующую страницу }
Получается некрасивое, громоздкое решение. Вместо этого следует использовать хэш, ассоциирующий имя страницы с подпрограммой. Это еще один из вариантов реализации С-подобной конструкции switch на Perl.
|
%States = ( |
||
|
'Default' |
=> |
\&front_page, |
|
'Shirt' |
=> |
\&shirt, |
|
'Sweater' |
=> |
\&sweater, |
|
'Checkout' |
=> |
\&checkout, |
|
'Card' |
=> |
\&credit_card, |
|
'Order |
=> |
\&order, |
|
'Cancel' |
=> |
\&front_page, |
$States{$page}->(); # Вызвать нужную подпрограмму } else {
no_such_page(), }
На каждой странице найдется несколько устойчивых элементов. Например, страница для заказа футболок должна сохранить количество заказанных товаров, даже если пользователь переходит на страницу для заказа кроссовок. Для этого подпрограмма, генерирующая страницу, вызывается с параметром, который определяет, является ли данная страница активной. Если страница не является активной, возвращаются лишь значения скрытых полей для любых устойчивых данных:
while (($state, $sub) = each %States) <
$sub->( $page eq $state ); }
Оператор сравнения eq возвращает true, если страница является активной, и false в противном случае. Подпрограмма, генерирующая страницу, принимает следующий вид:
sub t_shirt {
my Sactive = shift;
unless (Sactive) {
print hidden('size"), hidden('color"); return,
print p("You want to buy a t-shirt?");
print p("Size ", popup_menu("size", [ qw(XL L M S XS) ])),
print pC Color ", popup_menu("color", [ qw(Black White) ]));
print p( to_page('Shoes"), to_page( Checkout1) ), }
Поскольку все подпрограммы генерируют HTML-код, перед вызовом необходимо вывести заголовок HTTP и начать HTML-документ и форму. Это позволит использовать стандартные колонтитулы для всех страниц, если мы захотим. Следующий фрагмент предполагает, что у нас имеются процедуры standard_header и standard_footer для вывода верхних и нижних колонтитулов страниц:
print header( 'Program Title"), begin_html(), print standard_header(), begin_form(); while (($state, $sub) = each %States) {
$sub->( $page eq $state ), } print standard_footer(), end_form(), end_htnl(),
Кодирование цены в форме будет ошибкой. Вычисляйте цены на основании значений скрытых элементов и как можно чаще проверяйте информацию. Например, сравнение со списком существующих продуктов позволяет отбросить явно неразумные заказы.
В конце главы приведена программа chemiserie — простейшее приложение для обслуживания электронного магазина.
> Смотри также---------------------------------------------------------------------------------------------
Документация по стандартному модулю CGI.
19.13. Сохранение формы в файле или канале
Проблема
Сценарий CGI должен сохранить все содержимое формы в файле или передать его в канал.
Решение
Для сохранения формы воспользуйтесь функцией save_parameters или методом save модуля CGI; их параметром является файловый манипулятор. Сохранение в файле выполняется так:
# Сначала открыть и монопольно заблокировать файл
open(FH, "»/tmp/formlog") or die "can't append to formlog: $!";
flock(FH, 2) or die "can't flock formlog- $!";
# Используется процедурный интерфейс
use CGI qw(-.standard);
save_parameters(*FH); #CGI::save
# Используется объектный интерфейс
use CGI;
$query = CGI->new(); $query->save(*FH);
close(FH) or die "can't close formlog; $'";
Или форма сохраняется в канале — например, соединенном с процессом sendma.il:
use CGI qw(:standard);
open(MAIL, "|/usr/lib/sendmail -ol -t")
or die "can't fork sendmail; $!"; print MAIL «EOF; From; $0 (your cgi script) To: hisname\@hishost.com Subject; mailed form submission
EOF
save_parameters(«MAIL);
close(MAIL) or die "can't close sendmail: $!";
Комментарий
Иногда данные формы сохраняются для последующего использования. Функция save_parameters и метод save модуля CGI.pm записывают параметры формы в открытый манипулятор. Манипулятор может быть связан с открытым файлом (желательно — открытым в режиме дополнения и заблокированным, как в решении) или каналом, другой конец которого подключен к почтовой программе.
Данные сохраняются в файле в виде пар переменная=значение, служебные символы оформляются по правилам URL. Записи разделяются строками, состоящими из единственного символа =. Как правило, чтение осуществляется методом CGI->new с аргументом-манипулятором, что обеспечивает автоматическое восстановление служебных символов (см. ниже).
Если вы хотите перед сохранением включить в запрос дополнительную информацию, вызовите функцию рагат (или метод, если используется объектно-ориентированный интерфейс) с несколькими аргументами и установите нужное значение (или значения) параметра формы. Например, текущее время и состояние окружения сохраняется следующим образом:
param("_timestamp", scalar localtime); param("_environs", %ENV);
После сохранения формы в файле дальнейшая работа с ней ведется через объектно-ориентированный интерфейс.
Чтобы загрузить объект- запрос из файлового манипулятора, вызовите метод new с аргументом-манипулятором. При каждом вызове возвращается законченная форма. При достижении конца файла будет возвращена форма, не имеющая параметров. Следующий фрагмент показывает, как это делается. Он накапливает сумму всех параметров "items requested", но лишь в том случае, если форма поступила не с сайтаperl.com. Напомним, что параметры _environs и _timestamp были добавлены при записи файла.
use CGI;
open(FORMS, "< /tmp/formlog") or die "can't read formlog: $!";
flock(FORMS, 1) or die "can't lock formlog: $!";
while ($query = CGI->new(*FORMS)) {
last unless $query->param(); # Признак конца файла
%his_env = $query->param('_environs');
Scount += $query->param('items requested')
unless $his_env{REMOTE_HOST} =* /("|\.)perl\.com$/ } print "Total orders: $count\n";
Как всегда при создании файлов в сценариях CGI, важную роль играют права доступа и права владельца файла.
> Смотри также — Рецепты 18.3; 19.3.
Сценарий CGI из примера 19.9 предназначен для заказа футболок и свитеров через Web. В нем использованы приемы, описанные в рецепте 19.12. Вывод не отличается особой элегантностью или красотой, но продемонстрировать многостраничную работу в короткой программе слишком сложно, чтобы заботиться об эстетике.
Подпрограммы shi rt и sweater проверяют значения соответствующих элементов формы. Если цвет или размер окажется неправильным, в элемент заносится первое значение из списка допустимых цветов или размеров.
Пример 19.9. chemiserie
#'/usr/bin/perl -w
# chemiserie - простой сценарий CGI для заказа футболок и свитеров
use strict;
use CGI qw(.standard);
use CGI'iCarp qw(fatalsToBrowser);
|
my %States; |
# Хэш состоянии |
- связывает страницы |
|
|
# с функциями |
|||
|
my $Current_Screen; |
# Текущий экран |
||
|
П Хэш страниц и |
функций. |
||
|
%States = ( |
|||
|
'Default' |
=> |
\&front_page, |
|
|
'Shirt' |
=> |
\&shirt, |
|
|
'Sweater' |
=> |
\&sweater, |
|
|
'Checkout' |
=> |
\&checkout, |
|
|
'Card' |
=> |
\&credit_card, |
|
|
'Order' |
=> |
\&order, |
|
|
'Cancel' |
=> |
\&front_page, |
die 'No screen for $Current_Screen" unless $States{$Current_Screen};
# Сгенерировать текущую страницу. standard_header();
while (my($screen_name, Sfunction) = each %States) { $function->($screen_name eq $Current_Screen);
standard_footer(); exit;
#################################
19.14. Программа: chemiserie 699
# Колонтитулы формы, функции меню
sub standard_header {
print header(), start_html(-Title => "Shirts", -BGC0L0R=>"White"); print start_form(); # start_multipart_form() if file upload
sub standard_footer { print end_form(), end_html() }
sub shop_menu {
print p(defaults("Empty My Shopping Cart"), to_page("Snirt"), to_page("Sweater"), to_page("Checkout"));
#################################
# Подпрограммы для каждого экрана
#################################
# Страница по умолчанию,
sub front_page {
my $active = shift; return unless $active;
print "<H1>Hi!</H1>\n";
print " Welcome to our Shirt Shop1 Please make your selection from
print "the menu below.\n";
shop_menu();
# Страница для заказа футболок, sub shirt {
my Sactive = shift;
my ©sizes = qw(XL L M S);
my ©colors = qw(Black White);
my ($size, $color, $count) =
(param("shirt_size"), param("shirt_color"), param("shirt_count"));
# Проверка if ($count) {
$color = $colors[0] unless grep { $_ eq $color > ©colors;
$size = $sizes[0] unless grep { $_ eq $size } ©sizes;
param("shirt_color", $color);
param("shirt_size", $size);
продолжение
700 Глава 19 • Программирование CGI Пример 19.9 (продолжение)
unless ($active) <print hidden( shirt_size ) if $size, print hidden( shirt_color ) if $color, print hidden( shirt_count ) if $count, return,
print M( T-Shirt ),
print p( What a shirt1 This baby is decked out with all the options It comes with full luxury interior, cotton trim, and a collar , to make your eyes water1 Unit price \$33 00 ),
print h2( Options )
print p( How Many9 , textfield( shirt_count )),
print p( Size' , popup_menu( shirt_size , \@sizes ), Color7 , popup_menu( shirt_color , \@colors)),
shop_menu(),
# Страница для заказа свитеров sub sweater {
my $active = shift,
my ©sizes = qw(XL L M),
my ©colors = qw(Chartreuse Puce Lavender),
my ($size, $color, $count) =
(param( sweater_size ), param( sweater_color ), param( sweater_count
# Проверка if ($count) {
$color = $colors[0] unless grep { $_ eq $color } ©colors,
$size = $sizes[0] unless grep { $_ eq $size } ©sizes,
param( sweater_color , Scolor),
param( sweater_size , $size),
unless (Sactive) {
print hidden( sweater_size ) if $size, print hidden( sweater_color ) if $color, print hidden( sweater_count ) if $count, return,
print h1( Sweater ),
print p( Nothing implies pretty elegance more than this fine , sweater Made by peasant workers from black market silk, it slides onto your lean form and cries out Take me, , for I am a god' Unit price \$49 99 ),
print h2( Options ),
print p( How Many? , textfield( sweater_count ))
print p( Size9 , popup_menu( sweater_size , \@sizes)),
print p( Color' , popup_menu( sweater_color , \@colors)),
shop_menu(),
П Страница для подтверждения текущего заказа sub checkout {
my Sactive = shift,
return unless $active
print h1( Order Confirmation ),
print p( You ordered the following ),
print order_text(),
print p( Is this right? Select Card to pay for the items
or Shirt or Sweater to continue shopping ), print p(to_page( Card ),
to_page( Shirt ),
to_page( Sweater )),
# Страница для ввода данных кредитной карты sub credit_card {
my $active = shift,
my @widgets = qw(Name Addressi Address2 City Zip State Phone Card Expiry)
unless ($active) {
print map < hidden($_) } @widgets, return,
print pre(p( Name
p( AddressP(
P( City
P( Zip
p( State
p( Phone
p( Credit Card #
P( Expiry
, textfield( Name )),
textfield( Addressi )),
textfield( Address2 ))
textfield( City )),
textfield( Zip )),
textfield( State )),
textfield( Phone ))
textfield( Card )),
textfield( Expiry ))),
print p( Click on Order to return shopping ),
to order the items Click on Cancel
print p(to_page( Order ), to_page( Cancel )),
продолжение
702 Глава 19 • Программирование CGI Пример 19.9 (продолжение)
# Страница для завершения заказа, sub order {my $active = shift;
unless (Sactive) { return;
й Проверка данных кредитной карты
print h1("Ordered!");
print p('You have ordered the following toppings ');
print order_text(),
print p(defaults("Begin Again"));
# Возвращает HTML-код текущего заказа ("Вы заказали . ") sub order_text { my $html = '';
if (param("shirt_count")) {
$html .= p("You have ordered ', param("shirt_count"), " shirts of size ", param("shirt_size"), " and color ", param("shirt_color"), ".");
}
if (param("sweater_counf )) {
$html = p('You have ordered ', param('sweater_count'), ' sweaters of size ", param("sweater_size'), and color ', param("sweater_color'), '.");
}
$html = p('Nothing! ') unless $html;
$html = p("For a total cost of ', calculate_price());
return $html;
sub calculate_price {
my $shirts = param("shirt_count") || 0, my $sweaters = param('sweater_count") || 0, return sprintf("\$%.2f", $shirts*33 + Ssweaters * 49.99);
sub to_page { submit(-NAME => " State", -VALUE => shift) }
Автоматизация в Web
...Сеть одновременно чувственная и логическая,
элегантная и изобилующая смыслом — это стиль,
это основа литературного искусства.
Роберт Льюис Стивенсон,
«О некоторых технических элементах
стиля в литературе»
Введение
В главе 19 « Программирование CGI» основное внимание уделяется ответам на запросы броузеров и генерации документов с применением CGI. В этой главе программирование для Web рассматривается с другой стороны: вместо того чтобы общаться с броузером, вы сами притворяетесь броузером, генерируете запросы и обрабатываете возвращаемые документы. Для упрощения этого процесса мы будем широко использовать модули, поскольку правильно реализовать низкоуровневые сетевые протоколы и форматы документов непросто. Поручая всю трудную работу модулям, вы концентрируетесь на самом интересном — вашей собственной программе.
Упоминаемые модули находятся по следующему URL:
http://www.perl.com/CPAN/modules/by-category/15_World_Wide_Web_HTML_ HTTPJOGI/
Здесь хранятся модули для вычисления контрольных сумм кредитных карт, взаимодействия с API Netscape или сервера Apache, обработки графических карт (image maps), проверки HTML и работы с MIME. Однако самые большие и важные модули этой главы входят в комплекс модулей libwww-perl, объединяемых общим термином LWP. Ниже описаны лишь некоторые модули, входящие в LWP.
Модули HTTP:: и LWP:: позволяют запрашивать документы с сервера. В частности, модуль LWP::Simple обеспечивает простейший способ получения документов. Однако LWP::Simple не хватает возможности обращаться к отдельным компонентам ответов HTTP. Для работы с ними используются модули HTTP::Request, HTTP::Response и HTTP::UserAgent. Оба набора модулей демонстрируются в рецептах 20.1-20.2 и 20.10.
Имя модуля
Назначение
LWP::Protocol
LWP::Authen::Basic
LWP::MediaTypes
LWP::Debug
LWP::Simple
LWP::UserAgent
HTTP::Headers
HTTP::Message
HTTP::Request
HTTP::Response
HTTP::Daemon
HTTP::Status
HTTP::Date
HTTP-Negotiate
URI::URL
WWW::RobotRules
File:: Listing________
Класс пользовательских агентов WWW
Разработка приложений-роботов
Интерфейс для различных схем протоколов
Обработка ответов 401 и 407
Конфигурация типов MIME (text/html и т. д.)
Отладочный модуль
Простой процедурный интерфейс для часто используемых
функций
Отправка HTTP::Request и возвращение HTTP::Response
Заголовки стилей MIME/RFC822
Сообщение в стиле HTTP
Запрос HTTP
Ответ HTTP
Класс сервера HTTP
Коды статуса HTTP (200 OK и т. д.)
Модуль обработки даты для форматов дат HTTP
Обсуждение содержимого HTTP
URL
Анализ файлов robots.txt
Анализ списков содержимого каталогов
Модули HTML:: находятся в близкой связи с LWP, но не распространяются в составе этого пакета. Они предназначены для анализа HTML-кода. На них основаны рецепты 20.3—20.7, программы htmlsub и hrefsub.
В рецепте 20.12 приведено регулярное выражение для декодирования полей в файлах журналов Web-сервера, а также показано, как интерпретировать эти поля. Мы используем это регулярное выражение с модулем Logfile::Apache в рецепте 20.13, чтобы продемонстрировать два подхода к обобщению данных в журналах Web-серверов.20.1. Выборка URL из сценария Perl
Проблема
Требуется обратиться из сценария по некоторому URL.
Решение
Воспользуйтесь функцией get модуля LWP::Simple от CPAN, входящего в LWP.
use LWP: Simple, $content = get($URL);
Комментарий
Правильный выбор библиотек заметно упрощает работу. Модули LWP идеально подходят для поставленной задачи.
Функция get модуля LWP::Simple в случае ошибки возвращает undef, поэтому ошибки следует проверять так:
use LWP Simple,
unless (defined ($content = get $URL)) {
die could not get $URL\n , }
Однако в этом случае вы не сможете определить причину ошибки. В этой и других нетривиальных ситуациях возможностей LWP::Simple оказывается недостаточно.
В примере 20.1 приведена программа выборки документа по URL Если попытка оказывается неудачной, программа выводит строку с кодом ошибки. В противном случае печатается название документа и количество строк в его содержимом. Мы используем четыре модуля от LWP.
LWP::UserAgent
Модуль создает виртуальный броузер. Объект, полученный при вызове конструктора new, используется для дальнейших запросов. Мы задаем для своего агента имя «Schmozilla/v9.14 Platinum», чтобы Web-мастер мучился от зависти при просмотре журнала.
HTTP:: Request
Модуль создает запрос, но не отправляет его. Мы создаем запрос GET и присваиваем фиктивный URL для запрашивающей страницы.
HTTP:: Response
Тип объекта, возвращаемый при фактическом выполнении запроса пользовательским объектом. Проверяется на предмет ошибок и для получения искомого содержимого.
URI::Heuristic
Занятный маленький модуль использует Netscape-подобные алгоритмы для расширения частичных URL. Например:
Частичный URL Предположение
www.oreilly.com http://www.oreilly.com
ftp.funet.fi ftp://ftp.funet.fi
/etc/passwd________ file:/ctc/passwd_______
Хотя строки в левом столбце не являются правильными URL (их формат не отвечает спецификации URI), Netscape пытается угадать, каким URL они соответствуют. То же самое делают и многие другие броузеры.
Исходный текст программы приведен в примере 20.1.
706 Глава 20 • Автоматизация в Web Пример 20.1. titlebytes
#!/usr/bin/perl -w# titlebytes - определение названия и размера документа
use LWP::UserAgent;
use HTTP::Request;
use HTTP::Response;
use URI::Heuristic;
my $raw_url = shift or die "usage: $0 url\n";
my $url = URI: .'Heuristic: :uf_urlstr($raw_url);
$|=1; # Немедленный вывод следующей строки
printf "%s =>\n\t", $url;
my $ua = LWP::UserAgent->new();
$ua->agent("Schmozilla/v9.14 Platinum");
my $req = HTTP::Request->new(GET => $url);
$req->referer("http://wizard.yellowbrick.oz");
# Чтобы озадачить программы анализа журнала my $response = $ua->request($req); if ($response->is_error()) {
printf " %s\n", $response->status_line; } else {
my $count;
my $bytes;
my $content = $response->content();
Sbytes = length $content;
$count = ($content =" tr/\n/\n/);
printf "%s (%d lines, %d bytes)\n", $response->title(), $count, Sbytes; )
Программа выдает результаты следующего вида:
% titlebytes http://www.tpj.com/ http://www.tpj.com/ =>
The Perl Journal (109 lines, 4530 bytes)
Обратите внимание: вместо правильного английского refer re r используется вариант написания referer. Ошибка была допущена разработчиками стандарта при выборе имени HTTP_REFERER.
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулю LWP::Simple с CPAN и страница руководства Iwpcook(l), прилагаемая к LWP; документация по модулям LWP::UserAgent, HTTP::Request, HTTP-Response и URI::Heuristic; рецепт 20.2.
20.2. Автоматизация подачи формы
Проблема
Вы хотите передать сценарию CGI значения полей формы из своей программы.
Решение
Если значения передаются методом GET, создайте URL и закодируйте форму методом query_form:
use LWP: .'Simple; use URI::URL;
my $url = url('http://www.perl.com/cgi-bin/cpan_mod'); $url->query_form(module => -OB_File', readme => 1); $content = get($url);
Если вы используете метод POST, создайте собственного пользовательского агента и закодируйте содержимое:
use HTTP::Request::Common qw(POST); use LWP: .'UserAgent;
$ua = LWP::UserAgent->new();
my $req = POST 'http://www.perl.com/cgi-bin/cpanjnod',
[ module => "DB_File", readme => 1 ]; Scontent = $ua->request($req)->as_string;
Комментарий
Для простых операций хватает процедурного интерфейса модуля LWP::Simple. Для менее тривиальных ситуаций модуль LWP::UserAgent предоставляет объект виртуального броузера, работа с которым осуществляется посредством вызова методов.
Строка запроса имеет следующий формат:
П0ЛЕ1=ЗНАЧЕНИЕ1ШЛЕ2=ЗНАЧЕНИЕ2&П0ЛЕЗ=ЗНАЧЕНИЕЗ
В запросах GET информация кодируется в запрашиваемом URL:
http://www.site.com/path/to/
script.Cgi?field1=value1&field2=value2&field3=value3
Служебные символы в полях должны быть соответствующим образом преобразованы, поэтому присваивание параметру arg строки "this isn't <EASY> and <FUN>" выглядит так:
http://www. site.com/path/to/
script.cgi?arg=%22this+isn%27t+%3CEASY%3E+%26+%3CFUN%3E%22
Метод query_form, вызываемый для объекта URL, оформляет служебные символы формы за вас. Кроме того, можно вызвать URI: : Escape: :uri_escape или CGI:escape_html по собственной инициативе. В запросах POST строка параметров входит в тело HTML-документа, передаваемого сценарию CGI.
Для передачи данных в запросе GET можно использовать модуль LWP::Simle, однако для запросов POST не существует аналогичного интерфейса LWP::Simple. Вместо этого функция POST модуля HTTP::Request::Common создает правильно отформатированный запрос с оформлением всех служебных символов.
Если запрос должен проходить через прокси-сервер, сконструируйте своего пользовательского агента и прикажите ему использовать прокси:
$ua->proxy(['http', 'ftp'] => 'http://proxy.myorg.com:8081');
t> Смотри также--------------------------------------------------------------------------------------------
Документация по модулям LWP::Simple, LWP::UserAgent, HTTP::Request::Com-mon, URI::Escape и URI::URL с CPAN; рецепт 20.1.
20.3. Извлечение URL
Проблема
Требуется извлечь все URL из HTML-файла.
Решение
Воспользуйтесь модулем HTML::LinkExtor из LWP:
use HTML::LinkExtor;
Sparser = HTML::LinkExtor->new(undef, $base_url); $parser->parse_file($filename); @links = $parser->links; foreach Slinkarray (©links) {
my ©element = @$linkarray;
my $elt_type = shift ©element; # Тип элемента
# Проверить, тот ли это элемент, который нас интересует while (©element) {
# Извлечь следующий атрибут и его значение
my ($attr_name, $attr_value) = splice(@element, 0, 2);
# ... Сделать что-то ...
Комментарий
Модуль HTML::LinkExtor можно использовать двумя способами: либо вызвать links для получения списка всех URL в документе после его полного разбора, либо передать ссылку на функцию в первом аргументе new. Указанная функция будет вызываться для каждого URL, найденного во время разбора документа.
Метод links очищает список ссылок, поэтому для каждого анализируемого документа он вызывается лишь один раз. Метод возвращает ссылку на массив элементов. Каждый элемент сам но себе представляет ссылку на массив, в начале которого находится объект HTML::Element, а далее следует список нар «имя атрибута/значение». Например, для следующего HTML-фрагмента:
<А HREF="http://www.perl.com/">Home page</A>
<IMG SRC="images/big.gif' LOWSRC="images/big-lowres.gif">
возвращается структура данных:
[
[ a, href => "http://www.perl.com/" ],
[ img, src =>"images/big.gif",
lowsrc => "images/big-lowres.gif" ] ]
В следующем фрагменте демонстрируется пример использования $elt_type и $attr_name:
if ($elt_type eq 'a' && $attr_name eq 'href') {
print "ANCHOR: $attr_value\n"
if $attr_value->scheme =" /http|ftp/; > if ($elt_type eq 'img' && $attr_name eq 'src') {
print "IMAGE: $attr_value\n"; }
Программа из примера 20.2 получает в качестве аргументов URL (например, file:///tmp/testing.html или http://www.ora.com/) и выдает в стандартный вывод отсортированный по алфавиту список уникальных ссылок из него.
Пример 20.2. xurl
#!/usr/bin/perl -w
# xurl - получение отсортированного списка ссылок с URL use HTML::LinkExtor; use LWP::Simple;
$base_url = shift;
Sparser = HTML::LinkExtor->new(undef, $base_url);
$parser->parse(get($base_url))->eof;
@links = $parser->links;
foreach Slinkarray (©links) {
my ©element = ©Slinkarray;
my $elt_type = shift ©element;
while (©element) {
my ($attr_name , $attr_value) = splice(@element, 0, 2); $seen{$attr_value}++;
for (sort keys %seen) { print $_, "\n" }
У программы xurl имеется существенный недостаток: если в get или $base_url используется перенаправление, все ссылки будут рассматриваться для исходного, а не для перенаправленного URL. Возможное решение: получите документ с помощью LWP::UserAgent и проанализируйте код ответа, чтобы узнать, произошло ли перенаправление. Определив URL после перенаправления (если он есть), конструируйте объект HTML::LinkExtor.
Примерный результат выглядит так:
%xurl http://www.perl.com/CPAN ftp://ftpeftp.perl.oora/CPAM/CPAM.html
В почте и сообщениях Usenet часто встречаются вида:
<URL:http://www.perl.com>
Это упрощает выборку URL из сообщений:
@URLs = ($message =~ /<URL: (. *">)>/g);
О Смотри также--------------------------------------------------------------------------------------------
Документация по модулям LWP::Simple, HTML::LinkExtor и HTML::Entities; рецепт 20.1.
20.4. Преобразование ASCII в HTML
Проблема
Требуется преобразовать ASCII-текст в HTML.
Решение
Воспользуйтесь простым кодирующим фильтром из примера 20.3. Пример 20.3. text2html
#!/usr/bin/perl -w -pOO
# text2html - простейшее html-кодирование обычного текста
# -р означает, что сценарий применяется для каждой записи.
# -00 означает, что запись представляет собой абзац
use HTML::Entities;
$_ = encode_entities($_, "\200-\377");
if (/~W) {
# Абзацы, начинающиеся с пропусков, заключаются в <PRE>
s{(.*)$} {<PRE>\n$K/PRE>\n}s; # Оставить отступы
} else {
s{"(>.*)} {$1<BR>}gm; й quoted text
s{<URL:(.*?)>} {<A HREF="$1">$K/A>}gs # Внутренние URL(xopoojo)
II
s{(http:\S+)} {<A HREF="$1">$K/A>}gs; # Предполагаемые URL(rvioxo)
s{V(\S+)\*} {<STRONG>$K/STRONG>}g; # «Полужирный*
s{\b_(\S+)\_\b> {<EM>$K/EM>}g; # _Курсив_
s{"} {<P>\n>; # Добавить тег абзаца
Комментарий
Задача преобразования произвольного текста в формат HTML не имеет обше-го решения, поскольку существует много разных, конфликтующих друг с другом способов форматирования обычного текста. Чем больше вам известно о входных данных, тем лучше вы их отформатируете.
Например, если вы знаете, что исходным текстом будет почтовое сообщение, можно добавить следующий блок для форматирования почтовых заголовков:
BEGIN <
print "<TABLE>";
$_ = encode_entities(scalar о);
s/\n\s+/ /g; # Строки продолжения
while ( /"(\S+?:)\s*(.*)$/gm ) { ft Анализ заголовков
print -<TRXTH ALIGN='LEFr>$K/TH><TD>$2</TD></TR>\n"; } print "</TABLE><HR>";
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулю HTML::Entities от CPAN.
20.5. Преобразование HTML в ASCII
Проблема
Требуется преобразовать HTML-файл в отформатированный ASCII-текст.
Решение
Если у вас есть внешняя программа форматирования (например, lynx), воспользуйтесь ей:
$ascii = 'lynx -dump $filename';
Если вы хотите сделать все в своей программе и не беспокоитесь о том, что HTML::TreeBuilder еще не умеет обрабатывать таблицы и фреймы:
use HTML::FormatText; use HTML: -.Parse;
$html = parse_htmlfile($filename);
Sformatter = HTML::FormatText->new(leftmargin => 0, rightmargin => 50);
$ascii = $formatter->format($html);
Комментарий
В обоих примерах предполагается, что HTML-текст находится в файле. Если он хранится в переменной, то для применения lynx необходимо записать его в файл. При работе с HTML::FormatText воспользуйтесь модулем HTML::TreeBuilder:
$html = HTML::TreeBuilder->new(); $html->parse($document);
Sformatter = HTML::FormatText->new(leftmargin => 0, rightrnargin => 50);
Sascii = $formatter->format($html);
Если вы используете Netscape, команда Save As с типом Text отлично справляется с таблицами.
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулям HTML::Parse, HTML::TreeBuilder и HTML'.Format-Text; man-страница 1упх(\) вашей системы; рецепт 20.6.
20.6. Удаление тегов HTML
Проблема
Требуется удалить из строки теги HTML и оставить в ней обычный текст.
Решение
Следующее решение встречается часто, но работает неверно (за исключением простейшего HTML-кода):
($plain_text = $html_text) =" s/<[">]->//gs; «НЕВЕРНО
Правильный, но медленный и более сложный способ связан с применением модуля LWP:
use HTML::Parse;
use HTML::FormatText;
$plain_text = HTML::FormatText->new->format(parse_html($html_text));
Комментарий
Как всегда, поставленную задачу можно решить несколькими способами. Каждое решение пытается соблюдать баланс между скоростью и универсальностью. Для простейшего HTML-кода работает даже самая элементарная командная строка:
% perl -pe "s/<r>]*>//g" ФАЙЛ
Однако это решение не подходит для файлов, в которых теги пересекают границы строк:
<IMG SRC = •¦foo.gif" ALT = "Flurp!">
Поэтому иногда встречается следующее решение:
% perl -0777 -ре "s/<[">]»>//gs" ФАЙЛ
20.6. Удаление тегов HTML 713 или его сценарный эквивалент:
local $/; # Временный режим чтения всего файла$html = <FILE>; $html =~
Но даже этот вариант работает лишь для самого примитивного HTML-кода, не содержащего никаких «изюминок». В частности, он пасует перед следующими примерами допустимого HTML-кода (не говоря о многих других):
<IMG SRC = "foo.gif ALT = "A > B"> <!- <Комментарий> -> <script>if (a<b && a>c)</script> <# Просто данные #>
<! [INCLUDE CDATA [ »»»»»» ]]>
Проблемы возникают и в том случае, если комментарии HTML содержат другие теги:
<!- Раздел закомментирован.
<В>Меня не видно!</В> ->
Единственное надежное решение — использовать алгоритмы анализа HTML-кода из LWP. Эта методика продемонстрирована во втором фрагменте, приведенном в решении.
Чтобы сделать анализ более гибким, субклассируйте HTML::Parser от LWP и записывайте только найденные текстовые элементы:
package MyParser; use HTML::Parser; use HTML::Entities qw(decode_entities);
@ISA = qw(HTML::Parser);
sub text {
my($self, $text) = @_;
print decode_entities($text);
package main; MyParser->new->parse_
Если вас интересуют лишь простые теги, не содержащие вложенных тегов, возможно, вам подойдет другое решение. Следующий пример извлекает название несложного HTML-документа:
($title) = ($htral =~ m#<TITLE>\s*(-*7)\s*</TITLE>#is);
Пример 20.4. htitle
#' /usr/bm/perl
# htitle - Получить название HTML-документа для URL
die usage $0 url \n unless @ARGV, require LWP,
foreach $url (@ARGV) {
$ua = LWP UserAgent->new(),
$res = $ua->request(HTTP Request->new(GET => $url)),
print $url if @ARGV > 1,
if ($res->is_success) {
print $res->title, \n , } else {
print $res->status_line, \n ,
Приведем пример вывода:
% htitle http //www ora com
www.oreilly.com - Welcome to O'Reilly & Associates!
% htitle http //www perl com/ http //www perl com/nullvoid http://www.perl.com/: The www.perl.com Home Page http://www.perl.com/nullvoid: 404 File Not Found
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулям HTML::TreeBuilder, HTML::Parser, HTML:.Entilies и LWPr.UserAgent с CPAN; рецепт 20.5.
20.7. Поиск устаревших ссылок
Проблема
Требуется узнать, содержит ли документ устаревшие ссылки.
Решение
Воспользуйтесь методикой, описанной в рецепте 20.3, для получения всех ссылок и проверьте их существование функцией head модуля LWP::Simple.
Комментарий
Следующая программа является прикладным примером методики извлечения ссылок из HTML-документа. На этот раз мы не ограничиваемся простым выво-
дом ссылок и вызываем для нее функцию head модуля LWP::Simple. Метод HEAD получает метаданные удаленного документа и определяет его статус, не загружая самого документа. Если вызов закончился неудачно, значит, ссылка не работает, и мы выводим соответствующее сообщение.
Поскольку программа использует функцию get из LWP::Simple, она должна получать URL, а не имя файла. Если вы хотите поддерживать обе возможности, воспользуйтесь модулем URI::Heuristic (см. рецепт 20.1).
Пример 20.5. churl
fl'/usr/bin/perl -w # churl - проверка URL
use HTML LinkExtor,
use LWP Simple qw(get head),
$base_url = shift
or die usage $0 <start_url>\n , Sparser = HTML LinkExtor->new(undef, $base_url), $parser->parse(get($base_url)), @links = $parser->links, print $base_url \n , foreach $linkarray (©links) { my ©element = @$linkarray, my $elt_type = shift ©element, while (©element) {
my ($attr_name , $attr_value) = splice(@element, 0, 2), if ($attr_value->scheme =" /\b(ftp|https'>|file)\b/) {
print $attr_value , head($attr_value)? OK BAD , \n ,
Для программы действуют те же ограничения, что и для программы, использующей HTML::LinkExtor, из рецепта 20.3.
О Смотри также--------------------------------------------------------------------------------------------
Документация по модулям HTML::LinkExtor, LWP::Simple, LWP::UserAgent и HTTP::Response с CPAN; рецепт 20.8.
20.8. Поиск свежих ссылок
Проблема
Имеется список URL. Вы хотите узнать, какие из них изменялись позже других.
Решение
Программа из примера 20.6 читает URL из стандартного ввода, упорядочивает их по времени последней модификации и выводит в стандартный вывод с префиксами времени.
716 Глава 20 • Автоматизация в Web
Пример 20.6. surl#!/usr/bin/perl -w
# surl - сортировка URL по времени последней модификации
use LWP::UserAgent; use HTTP::Request; use URI::URL qw(url);
my($url, %Date):
my $ua = LWP::UserAgent->new();
while ( Surl = url(scalar <>) ) { my($req, Sans);
next unless $url->scheme =" /"(file|https?)$/; Sans = $ua->request(HTTP::fiequest->new("HEAD", $url)); if ($ans->is_success) {
$Date{$url} = $ans->last_modified || 0; # unknown } else {
print STDERR "$url: Error [", $ans->code, "] ", $ans->message, "!\n";
foreach Surl ( sort { $Date{$b} <=> $Date{Sa} } keys %Date ) {
printf "%-25s %s\n", $Date{$url} ? (scalar localtime $Date{$url})
: "<NONE SPECIFIED>", Surl;
Комментарий
Сценарий surl больше похож на традиционную программу-фильтр. Он построчно читает URL из стандартного ввода (на самом деле данные читаются из <ARGV>, что по умолчанию совпадает с STDIN при пустом массиве @ARGV). Время последней модификации каждого URL извлекается с помощью запроса HEAD. Время сохраняется в хэше, где ключами являются URL. Затем простейшая сортировка хэша по значению упорядочивает URL по времени. При выводе внутренний формат времени преобразуется в формат localtime.В следующем примере программа xurl из предыдущего рецепта извлекает список URL, после чего выходные данные этой программы передаются на вход surl.
%xurl http://www.perl.com/ | surl | head
|
Mon |
Apr |
20 |
06:16:02 |
1998 |
|
Fri |
Apr |
17 |
13:38:51 |
1998 |
|
Fri |
Mar |
13 |
12:16:47 |
1998 |
|
Sun |
Mar |
8 |
21:01:27 |
1998 |
|
Tue |
Nov |
18 |
13:41:32 |
1997 |
|
Wed |
Oct |
1 |
12:55:13 |
1997 |
|
Sun |
Aug |
17 |
21:43:51 |
1997 |
|
Sun |
Aug |
17 |
21:43:47 |
1997 |
|
Sun |
Aug |
17 |
21:43:46 |
1997 |
|
Sun |
Aug |
17 |
21:43:44 |
1997 |
http://www.oreilly.com/
http://www2.binevolve.com/
http://www.perl.org/ http://www.perl, com/universal/header.map
http://www.songline.com/
http://www.pe rl.com/g raphics/pe rlhome_header.j pg http://www.perl.com/graphics/perl_id_313c.gif http://www.perl.com/graphics/ora_logo.gif http://www.perl.com/graphics/header-nav.gif
Маленькие программы, которые выполняют свою узкую задачу и могут объединяться в более мощные конструкции, — верный признак хорошего программирования. Более того, можно было бы заставить xurl работать с файлами и организовать фактическую выборку содержимого URL в Web другой программой, которая бы передавала свои результаты xurl, churl или surl. Вероятно, эту программу следовало бы назвать gurl, no программа с таким именем уже существует: в комплекс модулей LWP входит программа lwp-request с синонимами HEAD, GET и POST для выполнения этих операций в сценариях командного интерпретатора.
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулям LWP::UserAgent, HTTP::Request и URI::URL с CPAN; рецепт 20.7.
20.9. Создание шаблонов HTML
Проблема
Вы хотите сохранить параметризованный шаблон во внешнем файле, прочитать его в сценарий CGI и подставить собственные переменные вместо заполнителей, находящихся в тексте. Это позволяет отделить программу от статических частей документа.
Решение
Если вы ограничиваетесь заменой ссылок на переменные, используйте функцию
template:
sub template {
my ($filename, $fillings) = @_;
my $text;
local $/; tt Режим поглощающего ввода (undef)
local *F; # Создать локальный манипулятор
open(F, "< $filename") || return;
$text = <F>; # Прочитать весь файл
close(F); # Игнорировать код возврата
tt Заменить конструкции %%...%% значениями из хэша %$fillings
$text =" s{ %%(.*?)%%}
{ exists( $fillings->{$1} ) ? $fillings->{$1}
}gsex; return $text;
В этом случае используемые данные выглядят так:
<!- simple.template для внутренней функции teraplate() -> <HTML><HEADxTITLE>Report for %%username%%</TITLEx/HEAD> <B0DY><H1>Report for %%username%%</H1> %%username%% logged in %%count%% times, for a total of %%total%% minutes.
<<- fancy template for Text Template -> <HTML><HEADxTITLE>Report for {$user}</TITLEx/HEAD> <B0DY><H1>Report for {$user}</H1>
{ lcfirst($user) } logged in {$count} times, for a total of { mt($seconds / 60) } minutes
Комментарий
Параметризованный ввод в сценариях CGI хорош по многим причинам. Отделение программы от данных дает возможность другим людям (например, дизайнерам) изменять код HTML, не трогая программы. Еще лучше то, что две программы могут работать с одним шаблоном, поэтому стилевые изменения шаблона немедленно отразятся на обеих программах.
Предположим, вы сохранили в файле первый шаблон из решения. Ваша программа CGI содержит определение функции template (см. выше) и соответствующим образом задает значения переменных $whats_his_name, $login_count и $minute_used. Шаблон заполняется просто:
%fields = (
username => $whats_his_name,
count => $login_count,
total => $mmute_used, ), print template( /home/httpd/templates/simple template \%fields)
Файл шаблона содержит ключевые слова, окруженные двойными символами % (%%КЛЮЧЕВ0Е-СЛ080%%). Ключевые слова ищутся в хэше %$f lllmgs, ссылка на который передается template в качестве второго аргумента. В примере 20.7 приведен более близкий к реальности пример, использующий базу данных SQL.
Пример 20.7. userrepl
«'/usr/bm/perl -w
# userrepl - вывод данных о продолжительности работы пользователей
# с применением базы данных SQL
use DBI
use CGI qw( standard),
# Функция template() определена в решении (см выше)
$user = param( username ) or die No username ,
$dbh = DBI->connect( dbi mysql connections mysql domain com 3306 ,
connections , seekntpassword ) or die Couldn t connect\n , $sth = $dbh->prepare(« END_OF_SELECT ) or die Couldn t prepare SOL ,
SELECT COUNT(duration),SUM(duration)
FROM logins WHERE username= $user
END_OF_SELECT
if (@row = $sth->fetchrow()) { ($count, $seconds) = @row,
> else {
($count, $seconds) = (0,0),
$sth->fimsh(), $dbh->disconnect,
print header(),
print template( report tpl username => $user, count => $count, total => $total
Если вам потребуется более изощренное и гибкое решение, рассмотрите второй шаблон решения, основанный на модуле Text::Template с С PAN. Содержимое пар фигурных скобок, обнаруженных в файле шаблона, вычисляется как код Perl. Как правило, расширение сводится к простой подстановке переменных:
You owe {$total}но в фигурных скобках также могут находиться полноценные выражения: The average was {$count "> ($total/$count) 0} Возможное применение этого шаблона продемонстрировано в примере 20.8.
Пример 20.8. userrep2
#'/usr/bm/perl -w
# userrep2 - вывод данных о продолжительности работы пользователей
# с применением базы данных SQL
use Text Template,
use DBI,
use CGI qw( standard),
$tmpl = /home/httpd/templates/fancy template ,
Stemplate = Text Template->new(-type => file , -source => $tmpl),
$user = param( username ) or die No username ,
|
Couldn Couldn |
|
db connect\n prepare SQL , |
$sth->execute()
or die Couldn t execute SQL ,
720 Глава 20 • Автоматизация в Web
if (@row = $sth->fetchrow()) { ($count, $total) = @row;} else {
Scount = Stotal = 0;
$sth->finish(); $dbh->disconnect;
print header();
print $template->fill_in();
При более широких возможностях этого подхода возникают определенные проблемы безопасности. Любой, кому разрешена запись в файл шаблона, сможет вставить в него код, выполняемый вашей программой. В рецепте 8.17 рассказано о том, как снизить этот риск.
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулю Text::Template с CPAN; рецепты 8.16; 14.10.
20.10. Зеркальное копирование Web-страниц
Проблема
Вы хотите поддерживать локальную копию Web-страницы.
Решение
Воспользуйтесь функцией mirror модуля LWP::Simple:
use LWP::Simple;
mirror($URL, $local_filename);
Комментарий
Несмотря на тесную связь с функцией get, описанной в рецепте 20.1, функция mirror не выполняет безусловной загрузки файла. В создаваемый ей запрос GET включается заголовок If-Modif ied-Since, чтобы сервер передавал лишь недавно обновленные файлы.
Функция mirror копирует только одну страницу, а не целое дерево. Для копирования набора страниц следует использовать ее в сочетании с рецептом 20.3. Хороший вариант зеркального копирования целого удаленного дерева приведен в программе w3mir, также находящейся на CPAN.
Будьте осторожны! Можно ( и даже просто) написать программу, которая сходит с ума и начинает перекачивать все Web-страницы подряд. Это не только дурной тон, но и бесконечный труд, поскольку некоторые страницы генерируются
динамически. Кроме того, у вас могут возникнуть неприятности с теми, кто не желает, чтобы их страницы загружались en masse.
D> Смотри также------------------------------------------------------------------------------------------
Документация по модулю LWP::Simple с CPAN; спецификация HTTP по адресу http://wzinw.w3.or/pub/WWW/Protocols/HTTP/.
20.11. Создание робота
Проблема
Требуется написать сценарий, который самостоятельно работает в Web (то есть робота). При этом желательно уважать правила работы удаленных узлов.
Решение
Вместо модуля LWP::UserAgent используйте в роботе модуль LWP::RobotUA:
use LWP::RobotUA;
$ua = LWP;:RobotUA->new('websnuffler/0.1', 'me@wherever.com1);
Комментарий
Чтобы жадные роботы не перегружали серверы, на узлах рекомендуется создавать файл с правилами доступа robots.txt. Если ваш сценарий получает лишь один документ, ничего страшного, по при получении множества документов с одного сервера вы легко перекроете пропускную способность узла.
Создавая собственные сценарии для работы в Web, важно помнить о правилах хорошего тона. Во-первых, не следует слишком часто запрашивать документы с одного сервера. Во-вторых, соблюдайте правила, описанные в файле robots.txt.
Самый простой выход заключается в создании агентов с применением модуля LWP::RobotUA вместо LWP::UserAgent. Этот агент автоматически «снижает обороты» при многократных обращениях к одному серверу. Кроме того, он просматривает файл robots.txt каждого узла и проверяет, не пытаетесь ли вы принять файл, размер которого превышает максимально допустимый. В этом случае возвращается ответ вида:
403 (Forbidden) Forbidden by robots.txt
Следующий пример файла robots.txt получен программой GET, входящей в комплекс модулей LWP:
% GET http://www.webtechniques.com/robots.txt User-agent: *
Disallow: /stats
Disallow: /db
Disallow: /logs
Disallow: /store
Disallow: /forms
Disallow: /gifs
Более интересный и содержательный пример находится по адресу http:// www.cnn.com/robots.txt. Этот файл настолько велик, что его даже держат под контролем RCS!
% GET http://www.cnn.com/robots.txt | head
# robots, scram
# $1 d : robots.txt.v 1.2 1998/03/10 18:27:01 mreed Exp $
User-agent: *
Disallow: /
I
User-agent: Mozilla/3.01 (hotwired-test/O.1)
Disallow: /cgi-bin
Disallow: /TRANSCRIPTS
Disallow: /development
> Смотри также---------------------------------------------------------------------------------------------
Документация по модулю LWP::RobotUA(3) с CPAN; описание правил хорошего тона для роботов по адресу http://info.webcrawler.com/mak/projects/robots/ robothtml.
20.12. Анализ файла журнала Web-сервера
Проблема
Вы хотите извлечь из файла журнала Web-сервера лишь интересующую вас информацию.
Решение
Разберите содержимое файла журнала следующим образом:
while (<LOGFILE>) {
my (Sclient, $identuser, Sauthuser, $date, $time, $tz, $method,
$url, $protocol, $status, $bytes) = /~(\S+) (\S+) (\S+) \[(r.]+):(\d+:\d+:\d+) (Г\]]+) "(\S+) (¦•?) (\S+)"
(\S+) (\S+)$/; # ... }
Комментарий
Приведенное выше регулярное выражение разбирает записи формата Common Log Format — неформального стандарта, которого придерживается большинство Web-серверов. Поля имеют следующий смысл:
client
IP-адрес или имя домена для броузера.
identuser
Результаты команды IDENT (RFC 1413), если она использовалась.
authuser
Имя пользователя при аутентификации по схеме «имя/пароль».
date
Дата поступления запроса (01/Маг/1997).
time
Время поступления запроса (12:55:36).
tz
Часовой пояс (-0700).
method
Метод запроса: GET, POST, PUT.
url
Запрашиваемый URL (/-user/index.html).
protocol
HTTP/1.0 или HTTP/1.1.
status
Возвращаемый статус (200 — все в порядке, 500 — ошибка сервера).
bytes
Количество возвращаемых байт (может быть равно "-" для ошибок, перенаправлений и операций, не сопровождаемых пересылкой документа).
В другие форматы также включаются данные о внешней ссылке и агенте. Ценой минимальных изменений можно заставить этот шаблон работать с другим форматом журнала. Обратите внимание: пробелы в URL не оформляются служебными символами. Это означает, что для извлечения URL нельзя использовать \S* — . * заставит регулярное выражение совпасть с целой строкой, а затем возвращаться до тех пор, пока не будет найдено соответствие для остатка шаблона. Мы используем . *? и фиксируем шаблон в конце строки с помощью $, чтобы механизм поиска не устанавливал совпадения и последовательно добавлял символы до тех пор, пока не будет найдено совпадение для всего шаблона.
> Смотри также---------------------------------------------------------------------------------------------
Спецификация CLF по адресу http://www.w3.org/Daemon/User/Config/ Logging.html.
Проблема
Требуется обобщить данные в серверном журнале, но у вас нет специальной программы с возможностью настройки параметров.
Решение
Анализируйте журнал с помощью регулярных выражений или воспользуйтесь модулями Logfile с CPAN.
Комментарий
В примере 20.9 приведен образец генератора отчетов для журнала Apache. Пример 20.9. sumwww
#!/usr/bin/perl -w
# sumwww - обобщение данных об операциях Web-сервера
$lastdate = ""; daily_logs(); summaryO; exit;
й Читать файлы CLF и запоминать обращения с хоста и на URL sub daily_logs { while (о) {
($type, $what) = /"(GET|POST)\s+(\S+?) \S+7 or next;
($host, undef, undef, $datetime) = split;
($bytes) = /\s(\d+)\s*$/ or next;
($date) = ($datetime =~ /\[([":]•)/);
$posts += ($type eq POST);
$home++ if m, / ,;
if ($date ne $lastdate) {
if ($lastdate) { write_report() > else { Slastdate = $date ) }
$count++; $hosts{$host}++; $what{$what}++; Sbytesum += $bytes; } write_report() if $count;
# Ускорить копирование за счет создания синонимов
# глобальных переменных вида «typeglob
sub summary {
Slastdate = "Grand Total"; ¦count = *sumcount;
|
•bytesum = |
•bytesumsum; |
|
•hosts = |
«allhosts; |
|
•posts = |
•allposts; |
|
•what = |
•allwhat; |
|
•home = |
•allhome; |
|
write; |
# Вывести сведения по хостам и URL с применением специального формата sub wnte_report { write;
# add to summary data $]astdate = $date; Ssumcount += $count; Sbytesumsum += $bytesum;|
$aliposts $allhome |
# Сбросить данные за день Sposts = $count = Sbytesum = $home = 0; @allwhat{keys %what} = keys %what; @allhosts{keys %hosts} = keys %hosts; %hosts = %what = ();
format STDOUT_TOP =
©MINI Mil HIIIII"Date", "Hosts',
"Accesses", "Unidocs", "POST", 'Home",
ninni
"Bytes'
$lastdate, scalar(keys %hosts),
Scount, scalar(keys %what),
Sposts, Shome,
(3>>>>>> (3>>>>>>>»»>>
Sbytesum
Пример вывода выглядит так:
Date Hosts Accesses UnidocsPOST
Home
Bytes
|
19/May/1998 |
353 |
6447 |
3074 |
352 |
51 |
16058246 |
|
20/May/1998 |
1938 |
23868 |
4288 |
972 |
350 |
61879643 |
|
21/May/1998 |
1775 |
27872 |
6596 |
1064 |
376 |
64613798 |
|
22/May/1998 |
1680 |
21402 |
4467 |
735 |
285 |
52437374 |
|
23/May/1998 |
1128 |
21260 |
4944 |
592 |
186 |
55623059 |
|
Grand Total |
6050 |
100849 |
10090 |
3715 |
1248 |
250612120 |
Модуль Logfile::Apache с CPAN (см. пример 20.10) позволяет написать аналогичную, но менее специализированную программу. Этот модуль распространяет-
Пример 20.10. aprept
#!/usr/bin/perl -w
# aprept - отчет по журналам Apache
use Logfile::Apache;
$1 = Logfile::Apache->new(
File => '¦-", # STDIN
Group => [ Domain, File ]);
$l->report(Group => Domain, Sort => Records); $l->report(Group => File, List => [Bytes,Records]);
Конструктор new читает файл журнала и строит индексы. В параметре File передается имя файла, а в параметре Group — индексируемые поля. Возможные значения — Date (дата), Hour (время получения запроса), File (запрашиваемый файл), User (имя пользователя, извлеченное из запроса), Host (имя хоста, запросившего документ) и Domain (Host, преобразованный в строку типа "France", "Germany" и т. д.).
Вывод отчета в STDOUT осуществляется методом report. В параметре Group передается используемый индекс, а также дополнительно — способ сортировки (Records — по количеству обращений, Bytes — по количеству переданных байт) и способ дальнейшей группировки данных (по количеству байт или количеству обращений).
Приведем примеры вывода:
Domain
|
US Commercial |
222 |
38.47* |
|||
|
US Educational |
115 |
19.93* |
|||
|
Network |
93 |
16.12* |
|||
|
Unresolved |
54 |
9.36* |
|||
|
Australia |
48 |
8.32* |
|||
|
Canada |
20 |
3.47* |
|||
|
Mexico |
8 |
1.39* |
|||
|
United Kingdom |
6 |
1.04X |
|||
|
File |
Bytes |
Records |
|||
|
/ |
13008 |
0.89* |
6 |
1.04* |
|
|
/cgi-bin/MxScreen |
11870 |
0.81* |
2 |
0.35* |
|
|
/cgi-bin/pickcards |
39431 |
2.70* |
48 |
8.32* |
|
|
/deckmaster |
143793 |
9.83* |
21 |
3.64* |
|
|
/deckmaster/admin |
54447 |
3.72* |
3 |
0.52* |
|
|
t> Смотри также |
