к числу самых древних искусств.

Кроме того, кулинария принадлежит к числу самых древних искусств. Неко­торые современные художники полагают, что так называемое эфемерное искусство изобрели совсем недавно, однако кулинария всегда была эфемерным искусством. Мы пытаемся сохранить произведения искусства, продлить их существование, но даже пища, захороненная вместе с фараонами, со временем приходит в негод­ность. Итак, плоды нашего программирования на Perl тоже в чем-то эфемерны. Этот аспект «кухни Perl» часто порицают. Если хотите — называйте его «програм­мированием на скорую руку», но миллиардные обороты в кафе быстрого обслу­живания позволяют надеяться, что быстрая еда может быть качественной (нам хотелось бы в это верить).

Простые вещи должны быть простыми, а сложные... возможными. На один ре­цепт быстрых блюд приходится бесчисленное множество обычных рецептов. Одна из прелестей жизни в Калифорнии — в том, что мне доступна практически любая национальная кухня. Но даже в границах одной культуры У Каждой Задачи Все­гда Найдется Несколько Решений. Как говорят в России, «Сколько поваров, столько и рецептов борща», и я этому верю. Рецепт моей мамы даже обходится без свеклы! И это вполне нормально. Борщ становится неким разделителем культур, а культурное разнообразие интересно, познавательно, полезно и увлека­тельно.

Итак, Том и Нат в этой книге не всегда делают все так, как это бы сделал я. Иногда они даже не могут прийти к единому решению — и это тоже сила, а не сла­бость. Признаюсь, из этой книги я узнал кое-что новое. Более того, наверняка и сейчас я знаю далеко не все (и надеюсь, не узнаю в ближайшее время). Мы часто говорим о культуре Perl так, словно она является чем-то единым, непоколеби­мым, хотя в действительности существует множество здоровых субкультур Perl, не говоря уже о всевозможных сочетаниях суб-субкультур, суперкультур и около­культур, наследующих друг от друга атрибуты и методы.

Итак, поваренная книга не готовит пищу за вас (она этого не умеет) и даже не учит вас готовить (хотя и помогает в этом). Она лишь передает различные куль­турные фрагменты, которые оказались полезными, и, возможно, отфильтровыва­ет другие «культуры», которые выросли в холодильнике по беспечности хозяев. В свою очередь, вы поделитесь этими идеями с другими людьми, пропустите их че­рез собственный опыт и личные вкусы, ваше творческое мышление и дисципли­ну. У вас появятся собственные рецепты, которые вы передадите собственным де­стям. Не удивляйтесь, когда они придумают что-то свое и спросят, что вы об этом думаете. Постарайтесь не корчить недовольную гримасу.



Рекомендую вам эти рецепты. Когда я читал их, у меня не было особых пово­дов для недовольных гримас.

Ларри Уолл июнь 1998 г.

От издательства

Ваши замечания, предложения, вопросы отправляйте по адресу электронной почты comp@piter-press.ги (издательство «Питер», компьютерная редакция).

Мы будем рады узнать ваше мнение!

Подробную информацию о наших книгах вы найдете на Web-сайте издатель­ства http://www.piter-press.ru.

Введение

Бизнесмены осторожно разглядывали докладчика, скепсис на лицах переходил в заинтересованность, и наоборот.



«Ваш рискованный план обещает выгоду, — заключил председатель. — Но он очень дорог и основан на одних предположениях. Наши математики не подтвер­ждают ваших цифр. Почему мы должны доверить вам свои деньги? Что вы знаете такого, чего не знаем мы?»

«Прежде всего, — ответил он, — я знаю, как вертикально поставить яйцо без внешней опоры. А вы?» С этими словами докладчик залез в сумку и осторожно вынул свежее куриное яйцо. Он передал яйцо финансовым магнатам, которые пе­редавали его из рук в руки, пытаясь справиться с несложной задачей. Все попыт­ки оказались тщетными. Раздавались отчаянные возгласы: «Это невозможно! Никому не удастся поставить яйцо вертикально!»

Докладчик взял яйцо у рассерженных бизнесменов и поставил яйцо на дубо­вый стол, прочно удерживая его в руках. После легкого, но уверенного нажатия скорлупа слегка потрескалась. Когда докладчик убрал руку, яйцо осталось на мес­те — слегка продавленное, но определенно устойчивое. «Что здесь невозможно­го?» — спросил он.

«Но это же обычный фокус, — закричали бизнесмены. — Такое может сделать любой!»

«Ваша правда, — последовал ответ. — Но это относится ко всему. Пока вы не знаете решения, задача кажется невозможной. А решение выглядит так просто, что вы не понимаете, почему это раньше не приходило вам в голову. Так позвольте мне показать простое решение, чтобы другие могли легко пойти тем же путем. Вы мне доверяете?»

Скептически настроенные капиталисты убедились, что предприниматель дей­ствительно на что-то способен, и выделили деньги на его проект. Из маленького андалузского порта отправились в море «Нинья», «Пинта» и «Санта Мария». Их вел предприниматель с надбитым яйцом и своими идеями — Христофор Ко­лумб.



За ним последовали многие.

Задачи программирования часто похожи на колумбово яйцо. Пока никто не покажет решения, вы сидите и смотрите, как яйцо (то бишь программа) падает снова и снова, ни на шаг не приближаясь к решению. Это особенно справедливо для таких идиоматических языков, как Perl.

Эта книга не задумывалась как полный справочник по Perl, хотя мы опишем некоторые недокументированные аспекты Perl. Любая поставка Perl содержит свыше 1000 страниц электронной документации. Если их не окажется под рукой, обратитесь к системному администратору.

Итак, эта книга — для тех, кто хочет лучше узнать Perl. Перед вами не справоч­ник и не учебник, хотя книга окажется полезным дополнением к ним. Она пред­назначена для людей, которые изучили основы языка и теперь пытаются связать ингредиенты в готовую программу. На протяжении 20 глав и свыше 300 отдель­ных тем, именуемых «Рецептами», вы найдете тысячи решений для повседнев­ных задач, с которыми сталкиваются как новички, так и опытные программисты.

Мы постарались сделать так, чтобы книга подходила и для последовательного, и для произвольного доступа. Каждый рецепт вполне самостоятелен, по если вам понадобится дополнительная информация, вы найдете в конце рецепта список ссылок. Глава обычно начинается с простых, повседневных рецептов, а книга на­чинается с простых глав. Рецепты, посвященные типам данным и операторам Perl, особенно полезны для новичков. Постепенно мы перейдем к темам и реше­ниям, рассчитанным па более опытных программистов. Но там и сям встречается материал, способный вдохновить даже настоящего знатока Perl.

Главы начинаются с краткого обзора. За введением следует основная суть гла­вы, ее рецепты. В духе лозунга Perl — «Всегда существует несколько решений» — во многих рецептах продемонстрированы разные способы решения той же самой или аналогичной задач. Рецепты простираются от конкретных решений в стиле «коротко, но мило» до углубленных мини-учебников. Там, где приведено несколь­ко вариантов, мы часто объясняем преимущества и недостатки каждого подхода.



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

Каждая глава завершается одной или несколькими законченными программа­ми. Хотя некоторые рецепты уже содержат маленькие программы, эти приложе­ния выделяют основную тему главы; кроме того, в них, как и в любой реальной программе, используются приемы из других глав. Все эти программы полезны, некоторые из них используются ежедневно. Некоторые программы даже помог­ли нам в работе над книгой.

О чем рассказано в этой книге

Первая четверть книги, занимающая более пяти глав, посвящена базовым типам данных Perl. В главе 1 «Строки» рассматриваются такие вопросы, как работа с подстроками, расширение вызовов функций в строках и анализ данных, разде­ленных запятыми. Глава 2 «Числа» описывает некоторые странности представ­ления с плавающей запятой, разделение разрядов запятыми и процесс генерации псевдослучайных чисел. Глава 3 «Дата и время» демонстрирует преобразования между числовыми и строковыми форматами даты и применение таймеров. В гла­ве 4 «Массивы» рассматривается все, что относится к операциям со списками и массивами, в том числе поиск уникальных элементов, эффективная сортировка и случайные перестановки элементов. Глава 5 «Хэши» завершает основы языка и представляет самый полезный тип данных — ассоциативные массивы. В ней по­казано, как обращаться с элементами хэша в порядке вставки, как отсортировать хэш по значению и как хранить несколько ассоциированных значений для одного ключа.

Глава 6 «Поиск по шаблону» занимает больше всего места. Рецепты описыва­ют преобразование универсальных символов командного интерпретатора в шаб­лон, поиск букв и слов, многострочные совпадения, отказ от максимализма при поиске и поиск строк, которые близки к искомым, по не совпадают с ними. Хотя

глава и так получилась самой длинной, она могла бы стать еще длиннее — в каж­дой главе вы найдете примеры использования регулярных выражений. Это часть того, что придает Perl его неповторимость.

Три следующие главы относятся к файловой системе. В главе 7 «Доступ к фай­лам» показано, как открыть файл, заблокировать его для параллельной работы, модифицировать его на месте и сохранить файловый манипулятор в переменной. В главе 8 «Содержимое файлов» обсуждается проблема поиска конца увеличива­ющегося файла, чтение конкретной строки файла и двоичный ввод/вывод с про­извольным доступом. Наконец, в главе 9 «Каталоги» описаны приемы копирова­ния, перемещения и удаления файлов, изменения атрибутов времени файла и рекурсивной обработки всех файлов каталога.

Основное внимание в главах 10-13 уделено тому, как сделать программы бо­лее гибкими и функциональными. Глава 10 «Подпрограммы» содержит рецепты для создания устойчивых локальных переменных, передачи параметров по ссыл­ке, косвенного вызова функций и обработки исключений. Глава 11 «Ссылки и за­писи» посвящена структурам данных; продемонстрированы основные операции со ссылками на данные и функции. Также в ней показано, как создавать аналоги конструкции struct языка С, как сохранять и загружать их из устойчивого хра­нилища. В главе 12 «Пакеты библиотеки и модули», рассматривается деление программы на отдельные файлы; создание переменных и функций, действующих только в границах данного модуля; замена встроенных функций, перехват обра­щений к отсутствующим модулям и использование утилит h2ph и h2xs для исполь­зования кода, написанного на С и C++. Наконец, в главе 13 «Классы, объекты и связи» рассматриваются основные принципы построения объектно-ориентиро­ванных модулей для создания пользовательских типов, обладающих конструкто­рами, деструкторами и возможностями наследования. В других рецептах показаны примеры использования циклических структур данных, перегрузки операторов и связанных типов данных.



Две следующие главы посвящены интерфейсам: первая — интерфейсам к базам данных, вторая — к визуальным устройствам. В главе 14 «Базы данных» описана методика работы с индексированными текстовыми файлами, блокировка файлов DBM и хранение в них информации, а также продемонстрирован интерфейс Perl к базам данных SQL. В главе 15 «Пользовательские интерфейсы» рассматрива­ются такие темы, как очистка экрана, обработка параметров командной строки, посимвольный ввод, перемещение курсора средствами termcap и curses и незави­симое от платформы графическое программирование с применением Tk.

Последняя четверть книги посвящена взаимодействию с другими программами и устройствами. В главе 16 «Управление процессами и межпроцессные взаимодей­ствия» говорится о запуске других программ и получении их вывода, об уничто­жении процессов-зомби, именованных каналах, обработке сигналов и совместно­му использованию переменных работающими процессами. Глава 17 «Сокеты» показывает, как установить потоковое соединение или использовать датаграммы при разработке низкоуровневых сетевых приложений «клиент/сервер». В главе 18 «Протоколы Интернета» рассматриваются протоколы высокого уровня — mail, FTP, Usenet и Telnet. Глава 19 «Программирование CGI» содержит рецепты для обработки Web-форм, перехвата ошибок, повышения безопасности за счет отказа

от обращений к командному интерпретатору, использования cookies, обслужива­ния электронных магазинов и сохранения форм в файлах или каналах. В послед­ней главе книги «Автоматизация в Web» описана неинтерактивная работа в Web. В числе рецептов — выборка URL, автоматизация подачи форм в сценариях, из­влечение URL из Web-страниц, удаление тегов HTML, поиск свежих или уста­ревших ссылок и обработка серверных файлов журналов.

Платформы

Книга создавалась на основе Perl 5.004_04, что означает старшую версию 5, млад­шую 004 и исправления уровня 4. Большинство программ и примеров было про­тестировано в BSD, Linux и SunOS, но это не значит, что они будут работать только в этих системах. Perl проектировался как язык, независимый от платформы. Если вы ограничиваетесь базовыми операциями с переменными, шаблонами, подпрог­раммами и высокоуровневым вводом/выводом, ваша программа должна одина­ково работать везде, где работает Perl, то есть практически везде. Первые две тре­ти книги посвящены именно такому общему программированию.



Изначально Perl задумывался как высокоуровневый кросс-платформенный язык системного программирования. Хотя с того времени Perl вышел далеко за пределы исходного предназначения, он продолжает широко использоваться в си­стемном программировании в родных системах семейства UNIX и на других платформах. Для обеспечения максимальной переносимости основное внимание уделялось открытым системам, соответствующим стандарту POSIX (Portable Operating System Interface), — к их числу принадлежат практически все разновид­ности UNIX и множество других операционных систем. Большинство рецептов будет работать в любой POSIX-системе без каких-либо изменений (или с мини­мальными изменениями).

Perl может использоваться для системного программирования даже в систе­мах, не соответствующих стандарту POSIX. Для этого вам понадобятся специа­лизированные модули для этих систем, однако в этой книге они не рассматрива­ются. Это объясняется тем, что такие программы не переносимы, — и, честно говоря, еще и тем, что в распоряжении авторов таких систем нет. Информация о специализированных модулях приведена в документации, прилагаемой к вашей версии Perl.

Не беспокойтесь — большинство рецептов, связанных с системным програм­мированием, работает и в системах, не соответствующих стандарту POSIX (осо­бенно рецепты, относящиеся к базам данных, сетевым средствам и работе в Web). Используемые в этих областях модули маскируют различия между платформа­ми. Исключение составляют в первую очередь немногочисленные рецепты и про­граммы, основанные на многозадачных конструкциях, и в первую очередь — на мощной функции fork, стандартной в семействе POSIX и редко реализуемой в других системах.

Во многих операциях со структурированными файлами используется удобная база данных /etc/passwd. При чтении текстовых файлов используется /etc/motd, а там, где была нужна внешняя программа с выходными данными, — who(l). Эти файлы были выбраны лишь для демонстрации общих принципов, действующих независимо от того, присутствуют эти файлы в вашей системе или нет.

Условные обозначения, использованные в книге

Условные обозначения в программах

Мы твердо верим, что каждая нетривиальная программа на Perl должна содержать флаг командной строки -w и директиву use strict. Практически все наши про­граммы начинаются так:

«'/usr/bin/perl  -w use strict,

В книге приведено множество примеров. Большинство из них представляет со­бой фрагменты кода. Некоторые примеры являются полноценными программа­ми, их нетрудно узнать по начальной строке #'.

Однако некоторые примеры должны вводиться в приглашении командной строки. Приглашение обозначается символом %:

% perl -e 'print Hello, world \ ' Hello, world.

Подобный стиль характерен для стандартных командных строк UNIX. Прави­ла определения строк и универсальные символы в других системах могут быть другими. Например, большинство стандартных командных интерпретаторов в DOS и VMS требует, чтобы для группировки аргументов с пробелами или универ­сальными символами использовались кавычки вместо апострофов. Внесите соот­ветствующие исправления.

Шрифтовое выделение

В книге использованы следующие условные обозначения: Курсив

Выделение имен файлов, названий команд п URL, а также новых терминов (там, где они впервые встречаются в тексте).

Жирный шрифт

Параметры командной строки.

Моноширинный  шрифт

Имена функций и методов, а также их аргументы. В примерах обозначает не­посредственно вводимый текст, а в тексте книги — элементы программного кода.

Моноширинный    полужирный    шрифт Выходные данные в примерах. Документация

Самая свежая и полная документация по Perl распространяется вместе с Perl. В печатном виде эта объемистая антология займет свыше 1000 страниц и внесет заметный вклад в глобальную вырубку лесов. К счастью, распечатывать ее не нужно, поскольку вся документация находится в удобном электронном виде с возможностями поиска.

Говоря о «страницах руководства» в этой книге, мы имеем в виду набор элект­ронных документов. Название чисто условное; для их чтения необязательно ис­пользовать программу man, традиционную для UNIX. Также подойдет команда perldoc, распространяемая с Perl. Страницы руководства даже могут устанавли­ваться в виде HTML-страниц, особенно в системах, не принадлежащих к семей­ству UNIX. Если вам известно местонахождение электронной документации, вы сможете искать в ней информацию с помощью утилиты grep\ HTML-версия элек­тронной документации также имеется в Web по адресу http://www.perl.com/CPAN/ doc/manual.html/.



Когда мы ссылаемся на документацию, не относящуюся к Perl (например, «См. страницу руководства Ш(2) вашей системы»), речь идет о странице kill из раздела 2 руководства «UNIX Programmer's Manual» (системные функции). Для систем, не входящих в семейство UNIX, эта документация недоступна, но в этом нет ничего страшного, поскольку вам все равно не удастся ей воспользоваться. Если вам действительно понадобится документация по системной или библиотеч­ной функции, многие организации размещают свои man-страницы в Web, и про­стейший поиск вида +crypt(3) +manual в AltaVista даст желаемые результаты.

Благодарности

Эта книга появилась на свет лишь благодаря множеству людей, компетентных и некомпетентных, стоявших за спинами авторов. Во главе этого легиона стоит наш редактор, Линда Май (Linda Mui), с кнутом в одной руке и пряником в дру­гой. Она была бесподобна.

Ларри Уолл как автор Perl был нашим судьей в высшей инстанции. Он следил за тем, чтобы мы не документировали то, что он собирался изменить, и помогал в выборе формулировок и стиля. Если временами в этой книге вам послышится го­лос Ларрп, вероятно, вы не ошиблись.

Глория, жена Ларри — литературный критик. Как ни поразительно, она прочи­тала каждое слово в этой книге... и одобрила большинство из них. Вместе с Ше-рон Хоикипс (Sharon Hopkins), поэтессой Perl по призванию, она помогла спра­виться с нашей патологической склонностью к предложениям, которые можно было бы умеренно описать как нечто среднее между невообразимо сложным и безнадежно запутанными. В результате наши невразумительные высказывания стали понятны даже тем, чьим родным языком не был ассемблер PDP-11 или сред­невековый испанский.

Трое самых усердных рецензентов, Марк-Джейсон Доминус (Mark-Jason Domi-nus), Джон Оруэнт (Jon Orwant) и Эбигейл (Abigail), трудились вместе с нами практически все время работы над книгой. Их суровые стандарты, ужасающий интеллект и практический опыт программирования па Perl принесли бесценную помощь. Дуг Эдварде (Doug Edwards) педантично протестировал каждый фраг­мент кода в семи начальных главах книги и нашел неочевидные частные случаи, о которых никто далее не подумал. В числе других ведущих рецензентов были Энди Догерти (Andy Dougherty), Энди Орам (Andy Oram), Брепт Халси (Brent Halsey), Брайан Баас (Bryan Buus), Джайсл Aac (Gisle Aas), Грэхем Барр (Graham Barr), Джефф Хемер (Jeff Haemer), Джеффри Фридл (Jeffrey Fried!), Линкольн Стеин (Lincoln Stein), Марк Мильке (Mark Mielke), Мартин Бреч (Martin Brech), Мат-тиас Неерахер (Matthias Neeracher), Майк Сток (Mike Stok), Нат Патвардхап (Nate Patwardhan), Пол Грасси (Paul Grassie), Питер Прпммер (Peter Prymmcr), Рафаэль Манфреди (Raphael Manfredi) и Род Уитбп (Rod Whitby).



И это далеко не все. Многие бескорыстные личности поделились с нами своими техническими познаниями. Некоторые из них прочитали целые главы и состави­ли формальные рецензии; другие давали содержательные ответы на короткие технические вопросы там, где мы выходили за рамки своей компетенции. Кое-кто даже присылал нам программы. Приведем лишь частичный список тех, кто был нам полезен: Аарон Харш (Aaron Harsh), Али Райл (Ali Rayl), Аллигатор Декарт (Alligator Descartes), Эндрю Хыом (Andrew Hume), Эндрю Стребков (Andrew Strebkov), Энди Уордли (Andy Wardley), Эштон МакЭндрюс (Ashton MacAndrews), Бен Герцфилд (Ben Gertzfield), Бенджамин Хольцмаи (Benjamin Holzman), Брэд Хыоджес (Brad Hughes), Чейм Френкель (Cheim Frenkel), Чарльз Бейли (Charles Bailey), Крис Нандор (Chris Nandor), Клинтон Вопг (Clinton Wong), Дэн Клейн (Dan Klein), Дэн Сугальски (Dan Sugalski), Дэниел Грисинджер (Daniel Grisinger), Деннис Тейлор (Dennis Taylor), Дуг МакИчерн (Doug MacEachern), Дуглас Дэвен-

порт (Douglas Davenport), Дрю Экхардт (Drew Eckhardt), Дилан Нортрап (Dylan Northrup), Эрик Эйзенхарт (Eric Eisenhart), Грег Бэкон (Greg Bacon), Гурусами Са-рати (Gurusamy Sarathy), Генри Спенсер (Henry Spencer), Джейсон Стюарт (Jason Stewart), Джоэл Нобл (Joel Noble), Джонатан Коэн (Jonathan Cohen), Джонатан Скотт Дафф (Jonatathan Scott Duff), Джош Пуринтон (Josh Purinton), Джулиан Андерсон (Julian Anderson), Кейт Уинстейн (Keith Winstein), Кен Лунд (Ken Lunde), Кирби Хьюджес (Kirby Hughes), Ларри Рослер (Larry Rosier), Лес Петере (Les Peters), Марк Хесс (Mark Hess), Марк Джеймс (Mark James), Мартин Бреч (Martin Brech), Мэри Кутски (Mary Koutski), Майкл Паркер (Michael Parker), Ник Инг-Симмонс (Nick Ing-Simmons), Пол Маркесе (Paul Marquess), Питер Коллинсон (Peter Collinson), Питер Озел (Peter Osel), Фил Бошамп (Phil Beauchamp), Пирс Коули (Piers Cawley), Рэндал Шварц (Randal Schwartz), Рич Рауэнзан (Rich Rauenzahn), Ричард Аллан (Richard Allan), Рокко Капуто (Rocco Caputo), Роде­рик Шертлер (Roderick Schertler), Роланд Уокер (Roland Walker), Ронан Уэйд (Ronan Waide), Стивен Лиди (Stephen Lidie), Стивен Owens (Stephen Owens), Салливан Бек (Sullivan Beck), Тим Бунс (Tim Bunce), Тодд Миллер (Todd Miller), Трои Денкингер (Troy Denkinger) и Вилли Гримм (Willy Grimm).



Нельзя не упомянуть и сам Perl, без которого эта книга никогда не была бы написана. Мы написали на Perl множество мелких утилит, помогавших нам в ра­боте над книгой. Они преобразовывали наш текст из формата pod в формат troff для отображения и проверки и в формат FrameMaker на стадии подготовки к печати. Другая программа Perl проверяла синтаксис в каждом фрагменте кода, встречающемся в книге. С помощью Tk-расширения Perl была написана графи­ческая утилита для перемещения между рецептами посредством перетаскивания мышью. Кроме того, мы также написали бесчисленное множество мелких утилит для других целей. Назовем лишь некоторые из них — поиск блокировок RCS, по­иск повторяющихся слов и некоторых разновидностей грамматических ошибок, управление почтовыми папками с сообщениями от рецензентов, построение пред­метного указателя и содержания, поиск текста с пересечением границы строки или ограниченного определенным разделом и т. д. Некоторые из этих утилит опи­саны в книге.

Том

Прежде всего благодарю Ларри и Глорию за то, что они пожертвовали частью своего отпуска в Европе для работы над книгой, а также моих друзей и семью — Брайана, Шерон, Бреита, Тодда и Дрю — за то, что они терпели меня в течение двух последних лет и выдержали бесчисленные проверки ошибок.

Хочу поблагодарить Натана за то, что он выдержал свои еженедельные поезд­ки, мою пикантную вегетарианскую кухню, а также за то, что он упрямо исследо­вал темы, которых я старался избегать.

Благодарю наших безвестных титанов, Денниса, Линуса, Кирка, Эрика и Рича, которые тратили время на мои глупые вопросы об операционной системе и troff. Они проделали громадную работу, без которой эта книга никогда бы не была на­писана.

Также благодарю моих учителей, которые доблестно отправлялись в опас­ные места типа Нью-Джерси и преподавали Perl. Благодарю Тима О'Рейли (Tim O'Reilly) и Фрэнка Уиллисона (Frank Willison): во-первых, за то, что они подда-

лись на уговоры и согласились опубликовать эту книгу, и во-вторых — за то, что они ставили на первое место качество, а не скорость работы. Также благодарю Лин­ду, нашего ошеломляюще честного редактора, за то, что ей удалось совершить не­вероятное — соблюсти сроки издания.



Благодарю свою мать, Мэри, за то, что она оторвалась от работы по восстанов­лению прерий и преподавания информатики и биологии и помогла нормально организовать мою деловую и домашнюю жизнь в течение времени, достаточного для написания этой книги.

Наконец, хочу поблагодарить Иоганна Себастьяна Баха, который был для меня бесконечным источником поэзии и вдохновения, лекарством для ума и тела. От­ныне при виде этой книги я всегда буду вспоминать звуки музыки, навечно запе­чатленные в моей памяти.

Нат

Без любви и терпения своей семьи я ничего не достиг бы в этой жизни. Спасибо вам! От своих друзей — Жюля, Эми, Раджа, Майка, Кефа, Сая, Роберта, Эвана, Понди, Марка и Энди — я узнал много нового. Я глубоко благодарен своим кол­легам в Сети, от которых я получал ценные технические советы и где познако­мился со своей женой (впрочем, относительно нее никаких советов мне не дава­ли). Также благодарю свою фирму, Front Range Internet, за интересную работу, с которой мне не хотелось бы уходить.

Том был великолепным соавтором. Без него эта книга была бы отвратительной, тупой и короткой. Напоследок хочу поблагодарить Дженни. Мы были женаты около года, когда я принял предложение насчет книги, и с тех пор практически не виделись. Никто так не порадуется окончанию этой работы, как она.

Строки

..И открыл легкомысленно уста свои, и безрассудно расточает слова.

Книга Иова, 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}

|| $ENV{LOGNAME}

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

Функция ord возвращает числа от 0 до 255. Этот диапазон соответствует типу данных unsigned char языка С.

О Смотри также--------------------------------------------------------------------------------------------

Описание функций 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 st net    ref s', потому что она запрещает символическое разы­менование.

Приведем пример:

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"

$big = "Vmittle";                   #   'bo peep' -> "BO PEEP"

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).

1.10. Интерполяция функций и выражений в строках

Проблема

Требуется интерполировать вызов функции или выражение, содержащиеся в строке. По сравнению с интерполяцией простых скалярных переменных это по­зволит конструировать более сложные шаблоны.

Решение

Выражение можно разбить на отдельные фрагменты и произвести конкатенацию:

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. с

EVER_ON_AND_ON

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 символов. Перед

списком строк функции wrap передаются два аргумента: один определяет отступ первой строки абзаца, а второй — отступы всех последующих строк

Пример 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) — в этом случае вы вообще избегаете взаимодействия с интерпретатором.

$string = q(Mom said,   "Don't do that."), Sstnng =~ s/([

Две обратные косые черты в секции заменителя были использованы потому, что эта секция интерпретируется по правилам для строк в кавычках. Следовательно, чтобы получить одну обратную косую черту, приходится писать две. Приведем аналогичный пример для 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. Конечно, такой индекс не будет уникальным.

use Text::Soundex; use  User::pweht;

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

Программа из примера 1. 4 представляет собой фильтр, который заменяет все встречающиеся в тексте слова из первого столбца соответствующими элементами второго столбца.

При вызове без файловых аргументов программа выполняет функции просто­го фильтра. Если в командной строке передаются имена файлов, то в них помеща­ются результаты, а прежние версии сохраняются в файлах с расширениями *.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

Небольшое предупреждение: программа работает быстро, но не в тех случаях, когда количество замен измеряется сотнями. Чем больше секция DATA, тем боль­ше времени потребуется. Несколько десятков замен не вызовут существенного за­медления. Более того, для малого количества замен эта версия работает быстрее следующей. Но если запустить программу с несколькими сотнями замен, она нач­нет заметно отставать.

В примере 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.

В частности, нам хотелось бы иметь возможность обращаться с полноценными запросами к выводу программы или файлу журнала. Допустим, вы спрашиваете у ps: «Покажи мне все непривилегированные процессы размером больше 10Кб» или «Какие команды работают на псевдоконсолях?»

Программа 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

PPID PRI  NI  SIZE  RSS WCHAN    STA TTY TIME COMMAND

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*";

продолжение ¦&

Пример 1.6 (продолжение)

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

47

_ END FLAGS 100 140 100100 100140

I  I  I

STA TTY TIME COMMAND

UID О О 101

PID 1 187 428

PPID PRI

N1  SIZE   RSS WCHAN

0 1 1

О  0   760  432 do.select  S  ?  0:02 init О  0   784  452 do_select  S  ?  0: 02 syslogd О  0  1436  944 do.exit    S   1 0:00 /bin/ login

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

0  0  2964 2360 idetape_rea S  p2 0:06 trn 0  0  1412  926 setup_frame T  p3 0:00 ssh -C www

О 26560 26554 101 19058  9562

0  0  1076  572 setup_frame T  p2 0:00 less 0  0  1396  900 setup_frame T  p1 0:02 nvi / tmp/a В программе psgrep объединены многие приемы, представленные в книге. Об удалении начальных и конечных пропусков рассказано в рецепте 1.14. Преобра­зование позиций разреза в формат unpack для извлечения полей с фиксированным положением рассматривается в рецепте 1.1. Поиску регулярных выражений в строках посвящена вся глава 6. Многострочный текст, передаваемый die, представляет собой встроенный до­кумент (см. рецепты 1.10 и 1.11). Присваивание ©fields{©fieldnames} заносит сра­зу несколько величин в хэш %f ields. Хэши рассматриваются в рецептах 4.7 и 5.10. Входные данные программы-примера, расположенные под_ END       , описаны в рецепте 7.6. На стадии разработки для тестирования использовались «консерви­рованные» данные, полученные через файловый манипулятор DATA. Когда програм­ма заработала, мы перевели ее на получение данных из присоединенной команды ps, однако исходные данные были оставлены для будущего переноса на другие плат­формы и сопровождения. Конвейерный запуск других программ рассматривает-

ся в главе 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. Чтобы перенести ее в другую систему, посмотрите, в каких столб-

цах начинаются заголовки. Такой подход не ограничивается спецификой ps или системы UNIX. Это общая методика фильтрации входных записей с использова­нием выражений Perl, которая легко адаптируется для другой структуры записи. Поля могут быть выстроены в столбцы, разделены запятыми или заключены в скобки.

После небольшого изменения в функциях отбора программа даже подойдет для работы с пользовательской базой данных. Если у вас имеется массив записей (см. рецепт 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.

А если трудностей с целыми числами окажется недостаточно, числа с плаваю­щей запятой преподнесут целый букет новых проблем. Во внутреннем представ­лении дробные числа хранятся в формате с плавающей запятой. Они представ­ляют вещественные числа лишь приближенно, с ограниченной точностью. Для представления бесконечного множества вещественных чисел используется конеч­ное пространство, обычно состоящее из 64 бит или около того. Потеря точности неизбежна.

Числа, прочитанные из файла или встретившиеся в программе в виде литера­лов, преобразуются из десятичного представления (например, 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);

my $str = shift,

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

$а = 0.255

$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
> Смотри также----

Описание функций sprintf и int в perlfunc(l); описание функций floor и ceil в документации по стандартному модулю POSIX. Методика использо­вания sprintf для округления представлена в рецепте 2.2.

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

2.5. Действия с последовательностями целых чисел

Проблема

Требуется выполнить некоторую операцию со всеми целыми между 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.

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;

return %dist;

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

my Sradians = deg2rad($degrees), my $result= sin($radians),

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

В модуле Math:: Complex для вычисления логарифмов по произвольному осно­ванию существует функция logn(), поэтому вы можете написать:

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 недоступна или вы не хотите привлекать ее для столь тривиальной задачи, матрицы всегда можно перемножить вручную:

# mmult() и другие процедуры определены выше

$х = [

[ 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 "It took %d hour%s\n", $time, $time == 1 ? "" : "s";

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-разрядные) числа означают огромные интервалы.

В скалярном контексте localtime и gmtime возвращают дату и время, отформа­тированные в виде ASCII-строки:

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.

3.2. Преобразование полного времени в секунды с начала эпохи

Проблема

Требуется преобразовать дату/время, выраженные отдельными значениями дня, ме­сяца, юда и т. д. в количество секунд с начала эпохи.



Решение

Воспользуйтесь функцией 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.

3.7. Анализ даты и времени в строках

Проблема

Спецификация даты или времени читается в произвольном формате, однако ее требуется преобразовать в отдельные компоненты (год, месяц и т. д.).

Решение

Если дата уже представлена в виде числа пли имеет жесткий, легко анализируе­мый формат, воспользуйтесь регулярным выражением (и, возможно, хэшем, свя­зывающим названия месяцев с номерами) для извлечения отдельных значений дня, месяца и года. Затем преобразуйте их в секунды с начала эпохи с помощью функций 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-бодного терминала:

while (о) {

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'),

print "I have ", @array, " marbles \n'; print "I have @array marbles\n", I have redyellowgreen marbles. I have red yellow green marbles.

На самом деле вам нужна строка "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',

^people = qw(Crosby Stills Nash Young), what_about_that_array(),

Результат:

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),      й      .  предупредить о нарушении

Возможны и более сложные варианты. Команда last прерывает цикл, next пере­ходит к следующему элементу, a redo возвращается к первой команде внутри блока. Фактически вы говорите: «Нет смысла продолжать, это не то, что мне нужно» (next), «Я нашел то, что искал, и проверять остальные элементы незачем» (last) или «Я тут кое-что изменил, так что проверки и вычисления лучше выполнить заново» (redo).



Переменная, которой последовательно присваиваются все элементы списка, называется переменной цикла или итератором. Если итератор не указан, исполь­зуется глобальная переменная $_. Она используется по умолчанию во многих строковых, списковых и файловых функциях 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, не отсортирован в алфавитном или числовом порядке и не сохраняет поря­док вставки.

Ниже показано, как обрабатывать данные по мере ввода. Мы используем who' для получения сведений о текущем списке пользователей, а перед обновлением хэша извлекаем из каждой строки имя пользователя:

#  Построить список зарегистрированных пользователей с удалением дубликатов
%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 ),

splice(©members,   -2,   2,    А ,     Banana print    @members\n  ,

Результат выглядит так:

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 ,

Если нас интересует лишь значение индекса, можно сократить программу — достаточно вспомнить, что при неудачном поиске $i будет содержать недопусти­мый индекс. В основном экономится объем кода, а не время выполнения, посколь­ку затраты на присваивание невелики по сравнению с затратами на проверку элементов списка. Однако проверка условия if ($i < ©ARRAY) выглядит не­сколько туманно по сравнению с очевндной проверкой defined из приведенного выше решения.

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, читайте ее снизу вверх:

©strings: в конце указываются сортируемые данные. В данном случае это мас­сив, но как вы вскоре убедитесь, это может быть вызов подпрограммы или даже команда в обратных апострофах. Подходит все, что возвращает список для после­дующей сортировки.

тар: нижний вызов тар строит временный список анонимных массивов. Спи­сок содержит пары из предварительно вычисленного поля (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.

4.17. Случайная перестановка элементов массива

Проблема

Требуется случайным образом переставить элементы массива. Наиболее оче­видное применение — тасование колоды в карточной игре, однако аналогичная задача возникает в любой ситуации, где элементы массива обрабатываются в произвольном порядке.

Решение

Каждый элемент массива меняется местом с другим, случайно выбранным эле­ментом:

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 •	- вывод	данных по	столбцам

use strict,

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

Соответственно, выполнение операции для всех возможных перестановок за­нимает много времени. Сложность факториальных алгоритмов превышает коли­чество частиц во Вселенной даже для относительно небольших входных значе­ний. Факториал 500 больше, чем десять в тысячной степени!

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) {

продолжение

Пример 4.4 (продолжение)

}

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 хэш является встроенным ти­пом данных. Благодаря применению хэшей многие сложные алгоритмы сводятся к простой выборке значений. Кроме того, хэши предоставляют быстрые и удоб­ные средства для построения индексов и таблиц просмотра. Если для простой скалярной переменной применяется идентификатор типа $, а для массива — @, то для хэшей используется идентификатор %.

Префикс % относится лишь к ссылкам на хэш в целом. Значение ключа пред­ставляет собой скалярную величину, поэтому для него используется символ $ (по

аналогии с тем, как для ссылок на отдельный элемент массива используется пре­фикс $). Следовательно, отношение «начальник Ната» должно записываться в виде $boss{"Nat"}.

В обычных массивах используются числовые индексы, но индексы хэшей все­гда являются строковыми. Ассоциированные значения могут быть произвольны­ми скалярными величинами, в том числе ссылками. Используя ссылки в качестве ассоциированных значений, можно создавать хэши для хранения не только строк и чисел, но и массивов, других хэшей или объектов (вернее, ссылок на массивы, хэшп или объекты).

Хэши могут инициализироваться с помощью списков, содержащих пары «ключ/ значение»:

%аде = ( "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}).

Во внутренних алгоритмах хэширования Perl перестановки строки попадают на одну и ту же позицию Если в ключах хэша многократно встречаются переста­новки одной строки (скажем, spare и craps ), быстродействие хэша заметно падает На практике это происходит редко

> Смотри также---------------------------------------------------------------------------------------------

Раздел «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 $_

Замена неправильной строки следующим вызовом exists позволяет пропускать нулевые и несуществующие файлы:

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  "In insertion order,   the foods are'\n"; foreach $food  (keys %food_color)   { print '     $food\n";

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.

5.8. Инвертирование хэша

Проблема

Хэш связывает ключ с ассоциированным значением. У вас имеется хэш и значе­ние, для которого требуется определить ключ.

Решение

Воспользуйтесь функцией 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 для построения списка ключей, а затем отсорти­руйте их в нужном порядке:

# %hash - сортируемый хэш

@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 $substanceref (\%food_color,   \%dnnk_color  )  { while (($k,   $v) = each %substanceref)  { $substance_color{$k}  = $v,

Если в объединяемых хэшах присутствуют одинаковые ключи, можно вставить код для обработки дубликатов:

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}

Результат values %includes представляет собой анонимный массив, посколь­ку один файл может включать (и часто включает) сразу несколько других фай­лов. Мы используем тар для построения большого списка всех включенных фай­лов и удаляем дубликаты с помощью хэша.



> Смотри также---------------------------------------------------------------------------------------------

Рецепт 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 через du. Это позволяет вызвать dutree любым из приведенных ниже способов, а может быть, и иначе — если ваша вер­сия du поддерживает другие параметры.

% 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  {

продолжение

Пример 5.3 (продолжение)

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), },
}                                                      продолжение

Пример 5.4 (продолжение)

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). Подобные механизмы поиска гарантируют возврат не самого длинного общего совпадения, а лишь самого длинного левого совпаде-

ния. Можно считать, что жадность Perl проявляется лишь слева направо, а не в глобальном контексте.



Но дело не обязательно обстоит именно так. В следующем примере использу­ется 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 точка совпадает с \п — в обычных условиях этого не происходит. Кроме того, при поиске игнорируется значение устаревшей переменной $*. Модификатор /т приводит к тому, что " и $ совпадают в позициях до и после   \п   соответственно Он полезен в режиме

поглощения файлов, о котором говорится во введении к главе 8 «Содержимое файлов» и рецепте 6.6.

При наличии модификатора /е правая часть выполняется как программный код, и затем полученное значение используется в качестве заменяющей строки. Например, подстановка 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   Чтобы

повысить точность идентификации слов в строке, можно указать то, что окружа­ет слово. Как правило, указываются метасимволы границ1, а не пропусков:

/\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

Задача поиска последнего совпадения также встречается довольно часто Про­стейшее решение — пропустить все начало строки Например, после / *\b(\w+)\s+ f ish\b/ переменная $1 будет содержать слово, предшествующее последнему экземп­ляру   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();

Переменная $in_header будет истинной, начиная с первой входной строки и заканчивая пустой строкой, отделяющей заголовок от основного текста, — на­пример, в почтовых сообщениях, новостях Usenet и даже в заголовках HTTP (те­оретически строки в заголовках HTTP должны завершаться комбинацией CR/ LF, но на практике серверы относятся к их формату весьма либерально). Пере­менная $in_body становится истинной в момент обнаружения первой пустой строки и до конца файла. Поскольку интервальные операторы не перепроверяют начальное условие, остальные пустые строки (например, между абзацами) игно­рируются.

Рассмотрим пример. Следующий фрагмент читает файлы с почтовыми сооб­щениями и выводит адреса, найденные в заголовках. Каждый адрес выводится один раз. Заголовок начинается строкой "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).

6.9. Работа с универсальными символами командных интерпретаторов

Проблема

Вы хотите, чтобы вместо регулярных выражений 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.



Применяя модификатор /о, автор сценария гарантирует, что значения интер­полируемых в шаблоне переменных остаются неизменными, а если они все же

изменятся, Perl будет использовать прежние значения. Получив такие гарантии, Perl интерполирует переменную и компилирует шаблон лишь при первом поис­ке. Но если интерполированная переменная изменится, Perl этого не заметит. Применение модификатора к изменяющимся переменным даст неверный ре­зультат.

Модификатор /о в шаблонах без интерполированных переменных не дает ни­какого выигрыша в скорости. Кроме того, он бесполезен в ситуации, когда у вас имеется неизвестное количество регулярных выражений и строка должна пооче­редно сравниваться со всеми шаблонами Не поможет он и тогда, когда интерпо­лируемая переменная является аргументом функции, поскольку при каждом вы­зове функции ей присваивается новое значение.

В примере 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,	}

Как видите, получается что-то вроде строковых констант, вычисляемых eval. В текст включен весь цикл вместе с поиском по шаблону, что ускоряет работу программы.

Самое неприятное в таком решении — то, что правильно записать все строки и служебные символы довольно трудно. Функция 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

позаботится о символах национальных алфавитов — конечно, при наличии ра­зумной спецификации LC_CTYPE и системной поддержки.

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.

6.14. Поиск от последнего совпадения

Проблема

Требуется возобновить поиск с того места, где было найдено последнее совпаде­ние.

Такая возможность пригодится при многократном извлечении фрагментов дан­ных из стрЪки.

Решение

Воспользуйтесь комбинацией модификатора /д, метасимвола \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".

Предположим, шаблон содержит максимальный квантификатор. При поиске подстроки, которая может встречаться переменное число раз (например, 0 и бо­лее раз для * или 1 и более раз для +), механизм поиска всегда предпочитает «и более». Следовательно, шаблон /foo *bar/ совпадает от первого "foo" до последне­го "bar", а не до следующего bar", как можно ожидать. Чтобы при поиске пред­почтение отдавалось минимальным, а не максимальным совпадениям, поставьте после квантификатора вопросительный знак. Таким образом, *9, как и *, соответ­ствует 0 и более повторений, но при этом выбирается совпадение минимальной, а не максимальной длины.



#  Максимальный поиск                               •*

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.

Поскольку для первого о* ищется максимальное совпадение, х растет до мак­симума. Замена одного или нескольких квантификаторов * на *9, + или +? дает другие решения:

(( о    х 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, который не совпадает или содержит несколько логически связанных шаблонов. Такая задача нередко возникает в про­граммах, читающих шаблоны из конфигурационных файлов.

Проблема с OR решается просто благодаря символу альтернативного выбо­ра |. Однако AND и OR потребуют особого кодирования.



В случае с 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

5:19pm    6days    0.43s    0.43s -tcsh 7:58am    3days  23.44s    0.44s -tcsh 2:01pm 13:36m    0.30s    0.30s -tcsh

Посмотрим, как поставленная задача решается с помощью приведенной выше программы 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+$//;

next unless $_;

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

# Глобальные переменные

продолжение

Пример 6.14 (продолжение)

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  «EOF
usage: $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;

продолжение

Пример 6.14 (продолжение)

##############

&{$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 из предыдущего примера. Манипулятор — это сим­волическое имя, которое представляет файл в операциях чтения/записи. Файло-

вые манипуляторы не являются переменными. В их именах отсутствуют префик­сы $, @ или %, однако они наряду с функциями и переменными попадают в сим­вольную таблицу Perl. По этой причине не всегда удается сохранить файловый манипулятор в переменной или передать его функции. Приходится использовать префикс *, который является признаком тип-глоба — базовой единицы символь­ной таблицы Perl:

$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 и

syscall, возвращающих -1). Системное сообщение или код ошибки хранится в переменной $1 и часто используется в die или сообщениях warn.

Для чтения записей в 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. Права доступа задаются в восьмеричной системе и учитыва-

ют текущее значение маски доступа (задаваемой функцией umask) процесса. В мас­ке доступа сброшенные биты соответствуют запрещенным правам. Например, если маска равна 027 (группа не может записывать; прочие не могут читать, за­писывать или выполнять), то вызов sysopen с параметром 066 создает файл с пра­вами 0640 (0666&-027 = 0640).



Если у вас возникнут затруднения с масками доступа, воспользуйтесь про­ стым советом: передавайте значение 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 вместо того, чтобы стереть пре­жнее содержимое.

Самое простое решение — воспользоваться функцией sysopen, у которой режим и имя файла передаются в разных аргументах:

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.

Манипулятор LOG не несет полезной информации, поскольку вы не знаете, с каким файлом он был связан. Если файловый манипулятор косвенно передается через имя файла, предупреждения и сообщения об ошибках Perl становятся более содержательными:

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.

7.6. Хранение данных в тексте программы

Проблема

Некоторые данные должны распространяться вместе с программой и интерпрети­роваться как файл, но при этом они не должны находиться в отдельном файле.

Решение

Лексемы_ 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))  {

warn "Can't open $ARGV:  $!\n";

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.

7.8. Непосредственная модификация файла с применением временной копии

Проблема

Требуется обновить содержимое файла на месте. При этом допускается примене­ние временного файла.

Решение

Прочитайте данные из исходного файла, запишите изменения во временный файл и затем переименуйте временный файл в исходный:

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 $_;

Обратите внимание: функция rename работает лишь в пределах одного каталога, поэтому временный файл должен находиться в одном каталоге с модифицируемым.

Программист-перестраховщик непременно заблокирует файл на время обнов­ления.

£> Смотри также-------------------------------------------------------------------------------------------

Рецепты 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!

print;
}
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{\).

7.10. Непосредственная модификация файла без применения временного файла

Проблема

Требуется вставить, удалить или изменить одну или несколько строк файла. При этом вы не хотите (или не можете) создавать временный файл.



Решение

Откройте файл в режиме обновления ("+<"), прочитайте все его содержимое в массив строк, внесите необходимые изменения в массиве, после чего перезапи­шите файл и выполните усечение до текущей позиции.

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) {       # Проверить версию Perl

my $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, вы тем самым разрешаете командную буферизацию.

На ввод она не влияет (небуферизованный ввод рассматривается в рецептах 15.6 и 15.8). Если $ | присваивается false, будет использоваться стандартная буфериза­ция stdio. Отличия продемонстрированы в примере 7.6.

Пример 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;

Snfound = select($rout=$rm,   undef,   undef,   0); if (Snfound)  {

# На одном или нескольких манипуляторах имеются входные данные

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

$flags  |= O_NONBLOCK; fcntl(HANDLE,   F_SETFL,   Sflags)

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). Если вам удастся что-нибудь прочитать, вы узнае­те, столько байтов ожидало чтения, а если не удастся — значит, и читать нечего.

> Смотри также---------------------------------------------------------------------------------------------

Рецепт 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"; }

либо локализовать тип-глоб и использовать файловый манипулятор напрямую:

sub accept_fh  {

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

Подход, при котором print и pnntf интерпретируются как вызовы методов объекта, не работает для оператора о, поскольку это настоящий оператор, а не вызов функции с аргументом без запятых. Если тип-глобы сохранены в структу­ре, как это было сделано выше, то для чтения записей можно воспользоваться встроенной функцией readlme, работающей аналогично <>:

$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 "<&", ">&" и "+<&" решают эту задачу соответственно для чтения, за­писи и обновления. Режимы со знаком равенства ("<&=", ">&=" и "+<&=") работа­ют с дескрипторами более экономно, при этом почти всегда делается именно то,

что нужно. Дело в том, что они используют лишь функцию f dopen уровня С без системной функции dup2.

Если у вас установлена версия 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).

Вы получаете один файловый дескриптор с двумя буферами, доступ к которым осу­ществляется через два манипулятора. Закрытие одного манипулятора закрыва­ет дескрипторы синонимов, но не манипуляторы — если вы попытаетесь вызвать print для манипулятора с закрытым синонимом, Perl не выдаст предупреждения "print on closed filehandle", даже если вызов print закончится неудачей. Ко­роче говоря, попытки работать с файлом через оба манипулятора тоже наверняка приведут к катастрофе. Такая методика используется только для открытия фай­лового дескриптора по известному числовому значению (см. рецепт 7.19).

> Смотри также---------------------------------------------------------------------------------------------

Страница руководства 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 на базе стандартной библиотеки ввода/вывода С.

Что нельзя сделать с неструктурированным файлом? Поскольку вставка и удаление байтов возможны лишь в конце файла, вы не сможете вставить или уда­лить записи, а также изменить их длину. Исключение составляет последняя за­пись, которая удаляется простым усечением файла до конца предыдущей записи. В остальных случаях приходится использовать временный файл или копию фай­ла в памяти. Если вам приходится часто заниматься этим, вместо обычных фай­лов лучше подойдет база данных (см. главу 14 «Базы данных»).

Самый распространенный тип файлов — текстовые файлы, а самый распро­страненный тип операций с ними — построчное чтение и запись. Для чтения строк используется оператор о (или его внутренняя реализация, 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";

Для каждого файлового манипулятора отслеживается текущая позиция в файле. Операции чтения/записи выполняются именно в этой позиции, если при открытии не был указан флаг O_APPEND (см рецепт 7.1). Чтобы узнать текущую позицию файлового манипулятора, воспользуйтесь функцией tell, а чтобы за­дать ее — функцией seek. Поскольку стандартная библиотека ввода/вывода стремится сохранить иллюзию того, что \п является разделителем строк, вы не сможете обеспечить переносимый вызов seek для смещений, вычисляемых посредством подсчета символов. Вместо этого seek следует вызывать только для смещений, возвращаемых tell:

$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)

Вы хотите обработать текст, игнорируя внутренние разрывы строк. В приведен­ном примере первая запись занимает две строки, вторая — три строки и т. д.

Алгоритм работает следующим образом. Цикл while читает строки, которые могут быть, а могут и не быть полными записями, — они могут заканчиваться сим­волом \ (и переводом строки). Оператор подстановки s/// пытается удалить \ в конце строки. Если подстановка заканчивается неудачей, значит, мы нашли стро­ку без \. В противном случае мы читаем следующую запись, приписываем ее к накапливаемой переменной $line и возвращаемся к началу цикла while с помощью redo. Затем выполняется команда chomp.

У файлов такого формата имеется одна распространенная проблема — невиди­мые пробелы между \ и концом строки. Менее строгий вариант подстановки вы­глядит так:

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» или

«Nino». Помните об этом при выборе шаблона. В двух последних примерах вам придется включить в программу директиву use locale и использовать метасим­вол \w в текущем локальном контексте.



> Смотри также---------------------------------------------------------------------------------------------

Описание функции 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 обеспечива-

ет вызов reverse в списковом контексте, что, в свою очередь, обеспечивает спис­ковый контекст для оператора <FILE>. В списковом контексте о возвращает спи­сок всех строк файла.

Показанные решения легко распространяются на чтение абзацев, достаточно изменить значение $/:

# Внешний блок обеспечивает существование временной локальной копии $/ {

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).

8.6. Выбор случайной строки из файла

Проблема

Требуется прочитать из файла случайную строку.

Решение

Воспользуйтесь функцией 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);

Классическое применение функции split — извлечение данных, разделенных пропусками:



©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", как при выводе на терминал.

Но при чтении строк в таких системах происходят еще более странные вещи. Файл содержит "bad news\cM\cJ" — строку, состоящую из 10 байт. При чтении ваша программа не получит ничего, кроме "bad news\n", где "\п" — виртуальный символ перевода строки, то есть "\cJ". Следовательно, от него можно избавить­ся одним вызовом chop или chomp. Однако при этом приходится обманывать бед­ную программу и внушать ей, что из файла было прочитано всего 9 байт. Если про­читать 10 таких строк, она будет полагать, что из файла было прочитано 90 байт, хотя в действительности смещение будет равно 100. Из-за этого для определения текущей позиции всегда следует использовать функцию tell. Простой подсчет прочитанных байтов не подходит.

Такое наследие старой файловой системы СР/М, в которой хранились лишь сведения о количестве блоков, но не о размере файлов, бесит программистов уже несколько десятилетий, и конца-края этому не видно. Ведь 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. $' ';

read(FH SBUFFER, $RECSIZE) == SRECSIZE

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)

продолжение ¦&

Пример 8.5 (продолжение)

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	ч

Вычисленная двоичная структура (в нашем примере — s x2 i A12 А2 х2 1 А8 А16 1 ) передается pack с пустым списком полей для определения размера за­писи. Не забудьте проверить код возврата read при чтении записи, чтобы убе­диться в том, что вы получили запрошенное количество байт.

Если записи представляют собой текстовые строки, используйте шаблон рас­паковки   а   или   А .

Записи фиксированной длины хороши тем, что n-я запись начинается в фай­ле со смещения SIZE*(n-1), где SIZE — размер одной записи. Пример приведен в программе с построением индекса из рецепта 8.8.

> Смотри также---------------------------------------------------------------------------------------------

Описание функций unpack, pack и read в perlfunc(l), рецепт 1.1.

8.16. Чтение конфигурационных файлов

Проблема

Вы хотите, чтобы пользователи вашей программы могли изменить ее поведение с помощью конфигурационного файла.



Решение

Организуйте обработку файла в тривиальном формате ПЕРЕМЕННАЯ=ЗНАЧЕНИЕ, созда­ вая для каждого параметра элемент хэша «ключ/значение»:

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, способным воздействовать на вы­зывающую сторону.

Если столь четкое разграничение видимости переменных нежелательно, вы можете заставить код конфигурационного файла выполняться в вашей лексичес­кой области действия. Имея под рукой программу cat или ее эквивалент, можно написать доморощенный аналог do:

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 Если другие имеют право записи

return 0 unless -d _;     it He-каталоги недостоверны

# но каталоги с битом запрета (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 — игнорировать прерывания,



-а — дописывать данные в конец выходных файлов,

-и — выполнять небуферизованный вывод,

-п — отменить копирование выходных данных в стандартный вывод.

Поскольку в программе используется «волшебная» функция open, вместо фай­лов можно передавать каналы:

% 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, операционная система читает индексный узел /, находит в его блоках данных информацию o/usr, читает индексный узел /usr, находит в его блоках данных информацию о /usr/bin, читает индексный узел /usr/bin, находит в его блоках данных информацию о /usr/bin/vi, читает индексный узел /usr/bin/vi, после чего читает данные из блока данных.

Имена, хранящиеся в каталогах, не являются полными. Файл /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 и для откры­того файла, но дисковое пространство будет освобождено лишь после его закры­тия последним процессом.

Ссылки делятся на два типа. Тип, описанный выше (два элемента каталога, в которых указан один номер индексного узла), называется прямой (или жесткой)

ссылкой (hard link). Операционная система не может отличить первый элемент каталога, соответствующий файлу (созданный при создании файла), от всех по­следующих ссылок на него. Со ссылками другого типа — символическими ссылка­ми — дело обстоит совершенно иначе. Символические ссылки представляют со­бой файлы особого типа: в блоке данных хранится имя файла, на который указывает ссылка. Символические ссылки имеют особое значение mode, отличающее их от обычных файлов. При вызове open для символической ссылки операционная сис­тема открывает файл, имя которого указано в блоке данных.



Резюме

Имена файлов хранятся в каталогах отдельно от размера, атрибутов защиты и прочих метаданных, хранящихся в индексном узле.

Функция 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	$'

Sblksize = (stat IN)[11]  jj   16384,                    # Желательный размер блока?

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.

9.4. Распознавание двух имен одного файла

Проблема

Требуется узнать, соответствуют ли два имени файла из списка одному и тому же файлу на диске (благодаря жестким и символическим ссылкам два имени могут ссылаться на один файл). Такая информация поможет предотвратить модифи­кацию файла, с которым вы уже работаете.

Решение

Создайте хэш, кэшируемый по номеру устройства и индексного узла для уже встречавшихся файлов. В качестве значений хэша используются имена файлов:

%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";

closedir(BIN);

Мы проверяем $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);

То же самое можно сделать и с помощью модуля DirHandle-

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] }	#	Числовая сортировка	имен
	#	Каталоги
_ ] }	#	Сформировать (имя,	путь)
	й	Только числа
	#	Все файлы

@dirs = map    { $_->[1] }

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 ,

Переменные $saved_size и $ saved_name используются для хранения имени и размера самого большого файла. Если мы находим файл, размер которого пре­вышает размер самого большого из просмотренного до настоящего момента, сохраненное имя и размер заменяются новыми значениями. После завершения работы find выводится имя и размер самого большого файла в весьма подроб­ном виде. Вероятно, более практичная программа ограничится выводом имени файла, его размера или и того и другого. На этот раз мы воспользовались име­нованной функцией вместо анонимной, поскольку она получилась относительно большой.

Программу нетрудно изменить так, чтобы она находила файл, который изме­нялся последним:

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, гарантирующую перебор всех внутренних файлов перед посещением самого каталога. Именно этот вариант поведения использован нами для удаления каталога вместе с содержимым.

У нас есть две функции, rmdir и unlink. Функция unlink удаляет только фай­лы, a rmdir — только пустые каталоги. Мы должны использовать 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

512 Fri May 29 10:42:41 1998

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) {

продолжение &

Пример 9.7 (продолжение)

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(),

$him = whowasiO,

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 undef,undef $uid)   =  stat($filename)

Также можно создать срез и включить в него лишь интересующие вас значения:

($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 в некоторых ситуациях возвращают строку

"О but true" (для удобства эта волшебная строка была изъята из бесчисленных предупреждений об ошибках преобразования флага -w). Появляется возмож­ность использовать конструкции следующего вида:

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.

10.13. Сохранение глобальных значений

Проблема

Требуется временно сохранить значение глобальной переменной.

Решение

Воспользуйтесь оператором 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 манипулирует значениями

глобальных, а не локальных переменных, директива use st net ни к чему хороше­му не приведет.

Оператор 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

Если значение, присваиваемое тип-глобу, представляет собой не ссылку, а дру­гой тип-глоб, то замена распространяется на все типы с данным именем. Полное присваивание тип-глоба относится к скалярным величинам, массивам, хэшам, функциям, файловым манипуляторам, манипуляторам каталогов и форматам. Следовательно, присваивание *Тор = «Bottom сделает переменную $Тор текуще­го пакета синонимом для $Bottom, @Тор — для @Bottom, %Тор — для %Bottom и &Тор — для &Bottom. Замена распространяется даже на соответствующие манипуляторы файлов и каталогов и форматы! Вероятно, это окажется лишним.



Присваивание тип-глобов в сочетании с замыканиями позволяет легко и удоб­ но дублировать функции. Представьте, что вам понадобилась функция для гене­рации 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'>

Функции кажутся независимыми, однако фактически код был откомпилиро­ван лишь один раз. Подобная методика экономит время компиляции и память. Для создания полноценного замыкания все переменные анонимной подпрограм­мы должны быть лексическими. Именно поэтому переменная цикла объявляется с ключевым словом ту.

Перед вами одна из немногочисленных ситуаций, в которых создание прото­типа для замыкания оправдано. Если вам захочется форсировать скалярный кон­текст для аргументов этих функций (вероятно, не лучшая идея), ее можно запи­сать в следующем виде:

.$name = sub ($) { '^FONT COLOR='$name'>$_[0]</F0NT>" };

Однако прототип проверяется во время компиляции, поэтому приведенное выше присваивание произойдет слишком поздно и никакой пользы не принесет. Следовательно, весь цикл с присваиваниями следует включить в 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.

Методика с присваиваниями тип-глобов из рецепта 10.14 быстрее и удобнее. Быстрее — поскольку вам не приходится запускать копию и заниматься подста­новками. Удобнее — поскольку вы сможете делать следующее:

{

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, поэтому используется вторая часть | |, в которой номера со­общений сравниваются в порядке их исходного следования.

Если функции sort передается список (0,1,2,3), после сортировки будет полу­чена некоторая перестановка — например, (2,1,3,0). Мы перебираем элемен­ты списка в цикле f о г и выводим каждое сообщение.

В примере 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.

Приведенный выше пример с $$sref можно переписать в виде:

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

print  $a[4][23][53]; ARRAY(0x81e2494) print $a[4][23]; ARRAY(0x81e0748) print $a[4]; ARRAY(0x822cd40)

В следующей таблице перечислены способы создания ссылок для именован­
ных и анонимных скалярных величин, массивов, хэшей и функций. Анонимные
тип-глобы выглядят слишком страшно и практически никогда не используются.
Вместо них следует применять 10: :Handle->new().
Ссылка на                             Именованный субъект             Анонимный субъект

Скалярная величина	\$scalar
Массив	\@array
Хэш	\%hash
Функция	\&function

\do{my $anon}
{ СПИСОК }
{ СПИСОК }
_______________________________________________________________ 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{$key} помещает­ся ссылка на массив, содержащий значения $кеу. Все стандартные операции с хэшами (вставка, удаление, перебор и проверка существования) могут комбини­роваться с операциями массивов (push, splice и foreach).

Присвоение ключу нескольких значений осуществляется следующим об­разом:

$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,

0

1

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.

Каждый вызов timestamp генерирует и возвращает новую функцию. Функция timestamp создает лексическую переменную $start_time, которая содержит теку­щее время (в секундах с начала эпохи). При каждом вызове замыкания оно воз­вращает количество прошедших секунд, которое определяется вычитанием на­чального времени из текущего.

> Смотри также---------------------------------------------------------------------------------------------

Описание замыканий в 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

Комментарий

В следующих примерах предполагается, что @аггау — простой массив, содержа­щий ссылки на скаляры (не путайте массив ссылок со ссылкой на массив). При косвенных обращениях к данным необходимы фигурные скобки.

($а,  $b,   $c,   $d) = (1  ..  4);                    # Инициализировать

©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",

$d->{NEXT}->(); # 21

$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, а затем инициализировать и использовать его следующим образом:



#  Сохранить запись

$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  "$key  $record->{$key}\n'; }

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'

Модуль Data::Dumper, доступный на CPAN, предоставляет более гибкое реше­ние. Входящая в него функция Dumper получает список ссылок и возвращает стро­ку с выводимой (и пригодной для eval) формой этих ссылок.

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:

pre_order($root); print "\n"; in_order($root); print "\n"; post_order($root); print "\n";

# Запрашивать до получения 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 является объявлением, обрабатываемым на стадии компиляции. Оно устанавливает префикс пакета по умолчанию для неполных глобальных идентификаторов, по аналогии с тем, как chdir устанавливает пре­фикс каталога по умолчанию для относительных путей. Влияние package распро­страняется до конца текущей области действия (блока в фигурных скобках, фай­ла или eval) или до ближайшей команды package в той же области действия (см. следующий фрагмент). Все программы выполняются в пакете mam, пока коман­дой package в них не будет выбран другой пакет.

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.

До настоящего времени мы рассматривали лишь традиционные модули, кото­рые экспортируют свой интерфейс, предоставляя вызывающей стороне прямой доступ к некоторым подпрограммам и переменным. К этой категории относится

большинство модулей. Но некоторые задачи — и некоторые программисты — свя­зываются с хитроумными модулями, содержащими объекты. Объектно-ориенти­рованный модуль редко использует механизм импортирования/экспортирования. Вместо этого он предоставляет объектно-ориентированный интерфейс с конструк­торами, деструкторами, методами, наследованием и перегрузкой операторов. Дан­ная тема рассматривается в главе 13.

Пользуйтесь готовыми решениями

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

Массив содержит список функций и переменных, экспортируемых в про­странство имен вызывающей стороны, чтобы в дальнейшем к ним можно было

обращаться без уточнения имени пакета. Обычно используется список в фор­ме qw():

(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

для переменной. Команда добавляет расширение .рт и преобразует : : в раздели­тель каталогов вашей операционной системы — в каноническом варианте / (как в URL), но в некоторых системах используются \, : и даже .  .

Если вы хотите последовательно попытаться загрузить несколько модулей и остановиться на первом работающем, поступите так:

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. Первая функция пере­ставляет слова строки в обратном порядке, а вторая изменяет определение гра­ницы слова.

# Flipper, pm package Flipper; use strict;

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 $@;

Такой подход работает лишь в том случае, если переменная $Ппе является гло­бальной. Для лексических переменных он не годится. Обходное решение — сде­лать так, чтобы функция runit принимала ссылку на функцию:

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:  $!";

Первая часть кода, не входящая в объявления функций, выполняется во время загрузки модуля. Для этого от пользователя модуля не потребуется никаких спе­циальных действий. Впрочем, для кого-нибудь это может оказаться неприятным сюрпризом, поскольку при недоступности журнала die вызовет сбой при выпол­нении use или require.

Блоки 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. Этот вари­ант удобен для простых командных строк и потому может использоваться на уров­не отдельных команд (например, при вызове простой однострочной программы из сценария командного интерпретатора).

Подобную методику не следует использовать в строках #!. Во-первых, редак­тировать каждую программу в системе скучно. Во-вторых, в некоторых старых

операционных системах имеются ошибки, связанные с ограничением длины этой строки (обычно 32 символа, включая #! ). В этом случае очень длинный путь (на­пример, #/opt/languages/free/extrabits/perl) приведет к появлению таинствен­ной ошибки "Command not found". Perl пытается заново просканировать строку, но этот механизм недостаточно надежен и полагаться на него не стоит.



Нередко самое удачное решение заключается в использовании переменной ок­ружения 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. Следовательно, нам потребуется

дополнительный подкаталог Astronomy, в котором будет размещаться каталог Orbits. Приведем первую и, вероятно, самую важную строку Orbits.pm:

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, которая возвра­щает целое количество секунд, другой, возвращающей вещественное число. Для

этого можно создать модуль FineTime с необязательным экспортированием функ­ции 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.

12.13. Косвенные ссылки на пакеты

Проблема

Требуется сослаться на переменную или функцию в пакете, имена которых неизве­стны до момента выполнения программы, однако синтаксис 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);

eval  "sub ${packname}::log$i  {  log(shift) / $logN  }"; die if $@; >

По крайней мере в данном случае это не нужно. Следующий фрагмент делает то же самое, но вместо того, чтобы компилировать новую функцию 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 sys/syscall.h

Однако многие заголовочные файлы включают другие заголовочные файлы; иными словами, придется преобразовать Их все:

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

Make автоматически преобразует файл FineTimexs в FineTime.c и общую биб­лиотеку, которая на большинстве платформ будет называться FineTvmejso. Преобра­зование выполняется утилитой xsubpp, описанной в ее собственной странице руко­водства nperlxstut(l). Xsubpp автоматически вызывается в процессе построения.

Кроме хороших познаний в С, вы также должны разбираться в интерфейсе 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 обнаруживает строку, начинаю­щуюся со знака = (там, где ожидается новая команда), он игнорирует весь текст до строки, начинающейся с =cut, после чего продолжает анализировать код. Это по­зволяет смешивать в программах или файлах модулей Perl код и документацию. Поскольку формат 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;

@ISA      = qw(Exporter);

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

12.19. Программа: поиск версий и описаний установленных модулей

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!,       # Сортировка данных по каждому каталогу
);

продолжение ё>

Пример 12.3 (продолжение)

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

# Вычислить имя модуля по файлу и каталогу sub modname {

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;

продолжение

Пример 12.3 (продолжение)

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() в качестве вто­рого аргумента.

В рецепте 13. 1 также рассматриваются функции, возвращающие приведенные ссылки. Конструкторы не обязаны быть методами класса. Также встречаются ме­тоды объектов, возвращающие новые объекты (см. рецепт 13.6).

Деструктором называется функция, которая выполняется при уничтожении субъекта, соответствующего данному объекту, в процессе сборки мусора. В отли­чие от конструкторов имена деструкторов жестко фиксируются. Методу-дест­руктору должно быть присвоено имя 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{\).                        ,         ,

13.9. Создание класса с поддержкой наследования

Проблема

Вы не уверены в том, правильно ли вы спроектировали свой класс и может ли он использоваться в наследовании.

Решение

Воспользуйтесь «проверкой пустого субкласса».

Комментарий

Допустим, вы реализовали класс 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 полностью воспроизводилось в Emp­loyee.

Создание подобных пустых классов называется «проверкой пустого субклас­са»; иначе говоря, мы создаем производный класс, который не делает ничего, кро­ме наследования от базового. Если базовый класс спроектирован нормально, то производный класс в точности воспроизведет его поведение. Это означает, что при простой замене имени класса все остальное будет работать:

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.

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 будет проверять, присутствует ли в хэше запрашиваемое поле.

package Person;

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). Поскольку объект является всего лишь высокоуровневым представлением обычного машинного адреса, во многих ситу­ациях требуется определить собственный критерий того, что следует понимать под равенством двух объектов.

Даже для нечисловых классов особенно часто перегружаются два оператора: сравнения и строковой интерполяции. Допускается перегрузка как оператора <=>, так и стр, хотя преобладает второй вариант. После того как для объекта будет

определен оператор <=>, вы также сможете использовать операторы ==, ! =, <, <=, > и >= для сравнения объектов. Если отношения порядка нежелательны, огра­ничьтесь перегрузкой ==. Аналогично, перегруженная версия стр используется в It, gt и других строковых сравнениях лишь при отсутствии их явной перегрузки.

Оператор строковой интерполяции обозначается странным именем "" (две ка­вычки). Он вызывается каждый раз, когда происходит строковое преобразова­ние — например, внутри кавычек или апострофов или при вызове функции 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	=>	\&divide,
<=>¦	=>	\&spaceship,
	=>	\&as_string,
•o+-	=>	\&as_number;

sub add {

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.

Выполняемый код

¦$s = Ю

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, не­сколько отличающиеся друг от друга).

Пример 13.5. Tie::AppendHash

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!!" ];

while ( my($k, $v) = each %tab ) {

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	Нет	Нет
Произвольный порядок байтов	Нет	Нет	Нет	Да
Порядок сортировки, определяемый	Нет	Нет	Нет	Да
пользователем
Поиск по неполному ключу	Нет	Нет	Нет	Да

1   Применение кода с общей лицензией GPL в программах должно удовлетворять некоторым условиям.
За дополнительной информацией обращайтесь на 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    По умолчанию, но может переопределяться (с потерей совместимости для старых файлов).

NDBM присутствует в большинстве систем семейства BSD. GTDBM представ­ляет собой GNU-реализацию DBM. SDBM входит в поставку XII и в стандарт­ную поставку Perl. DB означает библиотеку Berkeley DB. Хотя остальные биб­лиотеки фактически реализуют заново исходную библиотеку DB, код Berkeley DB позволяет работать с тремя разными типами баз данных и старается устра­нить многие недостатки, присущие другим реализациям (затраты дискового про­странства, скорость и размер).

Строка «Размер кода» относится к размеру откомпилированной библиотеки, а строка «Использование диска» — к размеру создаваемых ей файлов баз данных. Размер блока определяет максимальный размер ключа или значения в базе. Стро­ка «Произвольный порядок байтов» говорит о том, использует ли система баз данных аппаратный порядок следования байтов или создает переносимые файлы. Сортировка в пользовательском порядке позволяет сообщить библиотеке, в ка­ком порядке должны возвращаться списки ключей, а поиск по неполному ключу позволяет выполнять приблизительный поиск в базе.

Большинство программистов 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

14.1. Создание и использование DBM-файла

Проблема

Вы хотите создать, заполнить, просмотреть или удалить значения из базы дан­ных 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).

14.3. Преобразование DBM-файлов

Проблема

У вас имеется файл в одном формате 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.

14.6. Сортировка больших DBM-файлов

Проблема

Необходимо обработать большой объем данных, которые должны передаваться в 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 вместо имени файла undef, DB_File создаст файл в каталоге /top, а затем немедленно уничтожит его, созда­вая анонимную базу данных:

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

Обратите внимание: для перебора массива @lines вместо foreach $item (@lines)  {  }

следует использовать либо

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' ];

# Сравниваемые имена

$name1  = "Tom Christiansen"; $name2 = "Tom Boutell";

$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

Новые версии MLDBM позволяют выбрать не только модуль для работы с базами данных (мы рекомендуем DB_File), но и модуль сериализации (реко­мендуем Storable). В более ранних версиях сериализация ограничивалась модулем Data::Dumper, который работает медленнее Storable. Для использования DB_File со Storable применяется следующая команда:

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.

Простые команды SQL (не возвращающие записи данных) могут выполняться методом do манипулятора базы данных. При этом возвращается логическая исти­на или ложь. Для команд SQL, возвращающих записи данных (например, SELECT), необходимо сначала вызвать метод prepare манипулятора базы данных, чтобы создать манипулятор команды. Далее запрос выполняется методом execute, вы­званным для манипулятора команды, а записи извлекаются методами выборки fetchrow_array или fetchrow_hashref (возвращает ссылку на хэш, в котором имя поля ассоциируется со значением).

После завершения работы с базой не забудьте отключиться от нее методом 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):

$sth = $dbh->prepare("SELECT * FROM users WHERE uid < 50"); $sth->execute;

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'

Если вы не хотите, чтобы внутренняя дата была преобразована в формат local-time, используйте параметр -epoch:

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

if (  $opt_regexp  )   {

$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";

продолжение

Пример 14.8 (продолжение)

} 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). Программы с графическим ин­терфейсом работают не только с отдельными символами, но и с отдельными пикселями. В графических интерфейсах часто используется метафора окна — программа создает окна, отображаемые на пользовательском устройстве вывода.

Окна заполняются элементами (widgets) — например, полосами прокрутки или кнопками. Netscape Navigator, как и ваш менеджер окон, обладает полноцен­ным графическим интерфейсом. Perl позволяет работать со многими инстру­ментальными пакетами GUI, однако мы ограничимся пакетом Тк, поскольку он является самым распространенным и переносимым. См. рецепты 15.14, 15.15 и 15.19.

Не путайте пользовательский интерфейс программы со средой, в которой она работает. Среда определяет тип запускаемых программ. Скажем, при регистрации на терминале с полноэкранным вводом/выводом вы сможете работать с консоль­ными приложениями, но не с графическими программами. Давайте кратко рас­смотрим различные среды.

Некоторые из них позволяют работать лишь с программами, обладающими чисто консольным интерфейсом. Упрощенный интерфейс позволяет объединять их в качестве многократно используемых компонентов больших сценариев; такое объединение открывает чрезвычайно широкие возможности. Консольные про­граммы прекрасно подходят для автоматизации работы, поскольку они не зави­сят от клавиатуры или экрана. Они используют лишь 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 будет храниться в пе-

ременной $opt_D. Параметры, анализируемые с помощью getopt, не являются логи­ческими (то есть имеют конкретное значение).

Модуль 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;

close TTY,

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")  } чтобы при завершении программы цвета были гарантированно сброшены.

Атрибуты, распространяющиеся на несколько строк текста, могут привести в замешательство некоторые программы или устройства. Если у вас возникнут за­труднения, либо вручную установите атрибуты в начале каждой строки, либо исполь­зуйте colored, предварительно присвоив переменной $Term:: ANSIColor:: EACHLINE разделитель строк:

$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();

$termios->getattr,

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;

@ISA = qw(Exporter),

@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.

15.12. Управление экраном

Проблема

Вы хотите выделять символы повышенной интенсивностью, перехватывать нажа­тия специальных клавиш или выводить полноэкранные меню, но не желаете беспокоиться о том, на каком устройстве вывода работает пользователь.

Решение

Воспользуйтесь модулем 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 возвращает список из пяти элементов. Первый элемент определяет номер совпавшей строки или шаблона (идентично возвраща­емому значению в скалярном контексте). Второй элемент — строка с описанием причины возврата из expect. При отсутствии ошибок второй аргумент равен undef. Возможные варианты ошибок: "1: TIMEOUT", "2: EOF', "3: spawn id(...) died" и "4: . " (смысл этих сообщений описан в Expect(3)). Третий элемент в возвра­щаемом списке expect равен совпавшей строке. Четвертый элемент — текст до совпадения, а пятый — текст после совпадения.

Передача данных программе, находящейся под управлением 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 =>      \&register)  ->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";

}

продолжение &

Пример 15.7 (продолжение)

}, >

й Команды вашей программы $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) (если есть).

15.17. Удаление окна сеанса DOS в Perl/Tk для Windows

Проблема

Вы написали программу для 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));

продолжение

Пример 15.9 (продолжение)

# Рисовать линии на экране, пока пользователь й не нажмет 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);

} else {

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';         # Прикинуться другим интерпретатором

В следующем примере настоящее имя программы передается в виде косвен-ногообъекта {'/home/tchrist/scnpts/expn1}. Фиктивное имя 'vrfy' передает­ся в виде первого настоящего аргумента функции, и программа увидит его в пе­ременной $0.

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	Чтение

Сохранение STDOUT с игнорированием STDERR:

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');

Первая команда направляет и STDOUT и STDERR во временный файл. Вто­рая команда направляет в файл только STDOUT, a STDERR будет выводиться там, где раньше выводился STDOUT. Непонятно? Снова рассмотрим аналогию с переменными и присваиваниями. Фрагмент

#  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, "| программа аргументы |")    # НЕВЕРНО

Большая часть трудностей связана с буферизацией. Поскольку в общем случае нельзя заставить другую программу использовать небуферизованный вывод, нет

гарантии, что операции чтения не будут блокироваться. Если блокировка ввода устанавливается одновременно с тем, как другой процесс заблокируется в ожида­нии вывода, возникает состояние взаимной блокировки (deadlock). Процессы входят в клинч, пока кто-нибудь не убьет их или не перезагрузит компьютер.

Если вы можете управлять буферизацией другого процесса (потому что вы сами написали программу и знаете, как она работает), возможно, вам поможет модуль 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{\).

16.9. Управление потоками ввода, вывода и ошибок другой программы

Проблема

Вы хотите полностью управлять потоками ввода, вывода и ошибок запускаемой команды.

Решение

Аккуратно воспользуйтесь стандартным модулем 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, чтобы решить, из какого доступного для чтения манипулятора следует прочитать байт. Однако ваша программа становит­ся медленной и громоздкой, к тому же при этом не решается классическая пробле-

ма взаимной блокировки о реп 2, при которой каждая программа ждет поступле­ния данных от другой стороны:

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,   "|-"))  {

# Выполнить родительский код,   передающий данные потомку

} else {

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   или   [ - .

При подобном применении open, когда родитель хочет передать данные потом­ку, он использует нечто похожее на пример 16.5.

Пример 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";

К счастью, стандарт POSIX также требует, чтобы значение PIPE_BUF было не менее 512 байт. Следовательно, остается лишь позаботиться о том, чтобы клиен­ты не пытались передавать более 512 байт за раз.

Но что если вам понадобилось зарегистрировать более 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 - совместный доступ к общим переменным в разветвлениях

use  IPC    Shareable,

$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

или приостанавливается по Ctrl+Z, соответствующие сигналы отправляются все­му заданию, которое может состоять из нескольких процессов.

Функция 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. Временное переопределение обработчика сигнала

Проблема

Вы хотите установить обработчик сигнала, действующий только на время выпол­нения конкретной подпрограммы. Например, ваша подпрограмма перехватывает

сигнал SIGINT, но за ее пределами SIGINT должен обрабатываться обычными средствами.

Решение

Используйте 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 в обработчиках — вдруг система на что-ни­будь обидится? Практический подход — вы говорите: «Кто не рискует, тот не выигрывает», — и делаете в обработчике все, что заблагорассудится.

Сигналы были реализованы во многих операционных системах, причем не всегда одинаково. Отличия в реализации сигналов чаще всего проявляются в двух ситуациях: когда сигнал происходит во время активности обработчика {на­дежность) и когда сигнал прерывает блокирующий вызов системной функции типа read или accept {перезапуск).



Первоначальная реализация сигналов была ненадежной. Это означало, что во время работы обработчика при других поступлениях сигнала происходило неко­торое стандартное действие (обычно аварийное завершение программы). Новые системы решают эту проблему (конечно, каждая — в своем, слегка особом стиле), позволяя подавлять другие экземпляры сигналов с данным номером до заверше­ния обработчика. Если 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

-echoprt -altwerase -noflsh -tostop -flusho pendin -nokerninfo -extproc iflags:   -istrip   icrnl   -inlcr   -ignor   ixon   -ixoff   ixany   imaxbel   -ignbrk

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, чтобы убедиться, что процесс действительно умер, а не был остановлен:

use POSIX qw( signal_h    errno_h),

$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.

16.21. Тайм-аут

Проблема

Вы хотите гарантировать, что продолжительность некоторой операции не превы­шает заданный промежуток времени. Допустим, вы проводите архивацию фай­ловой системы и хотите прервать ее, если она затянется более чем на час. Или вы хотите, чтобы через час произошло некоторое событие.

Решение

Чтобы прервать затянувшуюся операцию, используйте обработчик 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

продолжение &

Пример 16.12 (продолжение)

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');

продолжение &

Пример 16.12 (продолжение)

($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-серверы стали распространенным явлением, поэтому многие поставщики увеличивают это значение. Максималь-

ный размер очереди для вашей системы хранится в константе SOMAXCONN мо­дуля Socket.

Функции 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),

работают и для потоковых сокетов, однако для датаграммных сокетов необходи­мы системные функции send и recv, работающие с целыми записями.

При программировании сокетов очень важно помнить о буферизации. Хотя буферизация и была спроектирована для повышения быстродействия, она может повлиять на интерактивное поведение некоторых программ. Если при вводе дан­ных с помощью о будет обнаружен разделитель записей, программа может по­пытаться прочитать из сокета больше данных, чем доступно в данный момент. И 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.

17.4. Создание клиента UDP



Проблема

Вы хотите обмениваться сообщениями с другим процессом, используя 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. $! ';

продолжение •£>¦

Пример 17.1 (продолжение)

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)

продолжение &

Пример 17.3 (продолжение)

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.

17.7. Идентификация другого конца сокета

Проблема

Имеется сокет. Вы хотите идентифицировать компьютер, находящийся на другом конце.



Решение

Если вас интересует только 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;                   # Корректно завершиться

> 

продолжение

Пример 17.5 (продолжение)

п Создать потомков, 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);

продолжение

Пример 17.6 (продолжение)

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 для клиентского сокета позволяет узнать, к какому адресу он подключился:

use Socket;

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 у каждой операционной системы были свои средства, с помощью которых процесс говорил системе: «Я работаю в одиночку;

пожалуйста, не мешайте мне». Появление 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 г.

Введение

Правильная работа с сокетами — лишь часть программирования сетевых ком­муникаций. Даже если вы организовали обмен данными между двумя програм­мами, все равно вам понадобится определенный протокол. С помощью протокола каждая сторона узнает, когда передаются или принимаются данные и кто именно отвечает за данный аспект службы.

Наиболее распространены следующие протоколы Интернета.

Протокол      Расшифровка

Описание

telnet rsh и гср

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 Отправка почты Чтение почты

К счастью, на CPAN имеются модули для всех протоколов. Большинство мо­дулей реализует клиентскую, а не серверную сторону протокола. Следовательно, программа сможет использовать эти модули для отправки почты, но не для вы­полнения функций почтового сервера, к которому подключаются другие клиен­ты. Она может читать и отправлять новости, но не являться сервером новостей для других клиентов; обмениваться файлами с сервером FTP, но не быть серве­ром FTP; и т. д.



Большинство этих модулей принадлежит иерархии 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 или

this.is.not.funny. Нельзя сказать, действительно ли ему принадлежит то имя, на которое он претендует, пока вы не вызовете gethostbyname и не проверите исход­ный адрес по адресному списку для данного имени.

# $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 состоит из трех шагов: подключение к серверу, иден­тификация и аутентификация и пересылка файлов. Все операции с сервером

FTP реализуются методами объекта Net::FTP. При возникновении ошибки ме­тоды возвращают undef в скалярном контексте и пустой список в списковом контексте.

Подключение осуществляется конструктором 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";

Если функция mkdir вызывается успешно, возвращается полный путь к только что созданному каталогу. При неудаче mkdir возвращает undef.

Методы 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("mail",   "/u/gnat/bir>/funkymailer"); Подключение к серверу SMTP mail.myisp.com выполняется так:

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 в случае неудачи.

$server->post(@message) or die "Can't post\n";

Метод postok позволяет узнать, разрешена ли отправка сообщений на данный сервер Usenet:

unless ($server->postok())  {

warn "You may not post.\n"; >



Полный список методов приведен в man-странице модуля Net::NNTP.

> Смотри также------------------------------------------------------------------------

Документация по модулю Net:: NNTP от CPAN; RFC 977, «Network News Trans­port 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(@_) },  .. );

Метод login передает имя пользователя и пароль на другой компьютер Успеш­ное завершение регистрации определяется по шаблону Prompt; если хост не выдал приглашения, происходит тайм-аут:

$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.

18.8. Применение whois для получения данных от InterNIC

Проблема

Вы хотите узнать, кому принадлежит домен (по аналогии с командой 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>

При установленном модуле Net::DNS получен следующий результат:

% ехрп 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

не работает постоянно с обращениями к ее различным частям со стороны броу­зера. При каждом запросе частичного URL, соответствующего программе, запус­кается ее новая копия. Программа генерирует страницу для данного запроса и завершается.

Броузер может запросить документ несколькими способами, которые называ­ются методами (не путайте методы 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");

При вызове без аргументов param возвращает список допустимых парамет­ров формы в списковом контексте или количество параметров формы в скаляр­ном контексте.

Вот и все, что нужно знать о пользовательском вводе. Делайте с ним, что хоти­те, а потом генерируйте выходные данные в нужном формате. В этом тоже нет ничего сложного. Помните, что, в отличие от обычных программ, выходные дан­ные сценария 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 начинает жаловаться на неини­циализированные переменные, чтение из манипулятора, предназначенного толь­ко для записи, и т. д.

Используете ли вы флаг -7? Если Perl жалуется на небезопасные действия, возможно, вы допустили какие-то неверные предположения относительно вход­ных данных и рабочей среды вашего сценария. Обеспечьте чистоту данных, и вы сможете спокойно спать по ночам, а заодно и получите рабочий сценарий (мече­ные данные и их последствия для программ рассматриваются в рецепте 19.4 и на странице руководства perlsec; в списке FAQ по безопасности CGI описаны конк­ретные проблемы, которых следует избегать).

Используете ли вы директиву 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

PerlHandler Apache   Registry

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

продолжение ¦&

Пример 19.3 (продолжение)

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>

Если в вашей системе установлены модули LWP, вы сможете использовать си­ноним GET для программы Iwprequest. При этом будут отслеживаться все цепоч­ки перенаправлений, что может пролить свет на вашу проблему. Например:

% 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/&/&amp;/g;

s/</&lt;/g;

s/>/&gt;/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,

if  ($States{$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(),

Кодирование цены в форме будет ошибкой. Вычисляйте цены на основании значений скрытых элементов и как можно чаще проверяйте информацию. На­пример, сравнение со списком существующих продуктов позволяет отбросить явно неразумные заказы.

Скрытые данные обладают большими возможностями, чем cookies, поскольку вы не можете твердо рассчитывать на поддержку cookies или на то, что броузер согласится принять их. Более полная информация приведена в рецепте 19.10.

В конце главы приведена программа 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.

19.14. Программа: chemiserie

Сценарий 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,

$Current_Screen = param(".State") || "Default1;

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(    Address

P(

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::RobotUA

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');

Это означает, что запросы HTTP и FTP для данного пользовательского аген­та должны маршрутизироваться через прокси на порте 8081 по адресу proxy. myorg.com.

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

http://language.perl.com/misc/CPAN.cgi http://language.perl.com/misc/cpan_module http: //language.perl.com/misc/getcpan http://language.perl.com/index.html http://language.perl.com/gifs/lcb.xbm

В почте и сообщениях 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:

use HTML::TreeBuilder; use  HTML::FormatText;

$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 показано более полное решение, в котором HTML-код об­рабатывается с использованием LWP.

Пример 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://electriolichen.com/linux/srom.html

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.

Для расширения полноценных выражений используйте модуль Text::Teraplate с CPAN, если вы можете гарантировать защиту данных от постороннего вмеша­тельства. Файл данных для Text::Template выглядит так:

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

$dbh = DBI->connect( dbi mysql connections mysql domain com 3306 ,

db connect\n  prepare SQL ,

connections ,    secret passwd )         or die $sth = $dbh->prepare(« END_OF_SELECT ) or die SELECT COUNT(duration),SUM(duration) FROM logins WHERE username= $user END_OF_SELECT

$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

Disallow: /wais-src Disallow: /scripts Disallow:   /config

Более интересный и содержательный пример находится по адресу 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.

20.13. Обработка серверных журналов

Проблема

Требуется обобщить данные в серверном журнале, но у вас нет специальной про­граммы с возможностью настройки параметров.

Решение

Анализируйте журнал с помощью регулярных выражений или воспользуйтесь мо­дулями 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

 += $posts;  += $home;

# Сбросить данные за день 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 Unidocs

 POST

 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) позволяет написать анало­гичную, но менее специализированную программу. Этот модуль распространяет-

ся вместе с другими модулями Logfile в единой поставке Logfile (на момент напи­сания книги — Logfik-0.115.tar.gz).

Пример 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> Смотри также

Содержание раздела

---

---