Автор:
Дмитрий Кувшинов
Оригинал: genphys.phys.msu.su
Убедительная просьба, перед тем, как что-то
запускать, нужно убедиться, что
скрипт не вытрет половину жесткого диска на сервере.
1. Функции
3. Модули
4. Подпрограммы
5. Операторы
6. Отладка программ
7.
8. Базы данных
9. Сокеты
Подсчет определенных файлов во всех вложенных
директориях
В данном случае почтовая программа типа Netscape или www.mail.ru при
прочтении письма делает файл видимым, т.е. картинка видна сразу. Прочитав
документацию на content-type для определенного типа файла, можно ту-же саму
картинку выгружать, скажем в photoshop. Поискав в www.google.com название
контент-тайпа, скажем, файла в формате excel, можно по одному нажатию на
файл запускать соответствующее расширению файла приложение. Приведенная ниже
подпрограмма высылает данные из базы пользователю в формтае excel так, что
при нажатии на приаттаченный файл, помимо картинки, запускается microsoft
excel:
Допустим у Вас есть 100000 картинок, ну или около того. Все они различного
размера, могут быть и 1000х1000 и 200х234. Необходимо получить маленьких
100000 картинок, высотой 60 пикселов
и соответствующей шириной. Это можно сделать при помощи модуля use Image::Magick Скачиваем модуль PerlMagick-*.*.*.tar.gz
. Проделываем стандартную распаковку модуля:
Циклом while(<$tumb/*.*>){to do} просматриваем
содержимое директории с картинками. При помощи модуля Image::Size устанавливаем размеры исходной картинки. В
переменной $vis=60; определяем высоту маленькой
картинки на выходе. Строчкой my ($w, $h) =
imgsize($_); берем реальные размеры картинки и, чтобы ширина картинки
была пропорциональна высоте(ведь не известно, картинки какого размера лежат
в директории), строчкой my $t=int($w/($h/$vis)) if $h/$vis
!= 0; масштабируем ширину. Логика проста, берем реальный размер
картинки, делим на $vis, получаем коэффициент
пропорциональности между размерами, т.е. допустим картинка, исходная, больше
маленькой например в 2,34567 раз. Далее делим на этот коэффициент ширину
картинки и получаем уменьшенную копию картинки высотой в $vis пикселов и соответствующей этой высоте ширине(как
это автоматически делает, т.е. сохраняет пропорции, photoshop любой версии), далее
берем целую часть от этогй высоты функцией int, условие if
$h/$vis != 0 исключает деление на 0. Итак, в переменной $t содержится ширина картинки, вызываем функцию Resize, которй передаем два параметра, ширину и высоту и
на выходе имеем маленькую картинку mini_pic.gif с
названием отличным от большой pic.gif. Условие
$_="aaa.gif" unless /\.(gif|jpg|jpeg|png)/i;
предназначено для того, чтобы выделить из директории с файлами только файлы
картинок. Скрипт просто перезаписывает
одну и ту-же картинку. Хотя можно было бы и пропускать шаг цикла while. Собственно вот и все.
Далее можно написать скрипт, выводящий маленькие картинки из директории,
пользуясь тем-же
модулем Image::Size, нужно только
Преположим Вы владеете сайтом, на который сваливается информация
в формате *.doc. Много информации. Даже, быть может,
структурированной. Необходимо эту информацию перевести в "божеский" вид,
т.е. выцепить из таких файлов текст. Скачиваем следующие модули:
Unicode-Map
Устанавливаем их. Мне пришлось убрать строку N1099 при установке Startup.
Ну, это вылилось в отсутствие мануала по одному из многочисленных методов
этого модуля, ибо эта строчка находилась
в самом конце моудля, где обычно находятся описания и комментарии.
Далее берем файл, удовлетворяющий описанным выше условиям и
пишем скрипт(предварительно прочитав man lhalw):
Собственно модуль так-же умеет записывать информацию о записи в mp3. файл,
а как это сделать читайте в man MP3::Info
Т.е. следите за обновлениями www.cpan.org
Программа, позволяющая полностью управлять статическим и, если того
захотеть, динамическим наполнением сайта. Или писать вызовы обращений к базе
данных прямо в тексте html-страницы.
Для её запуска необходимы Apache и mod_perl.
В httpd.conf нужно дописать то, о чем написано в
man HTML::Mason. После этого Ваш сайт(вне
зависимости от его размера) ну, если не становится ручным пони, то уж точно
чем нибудь типа уральского тяжеловоза. Все описания и другие оставшиеся
слова можно прочитать на сайте http://www.masonhq.com/. Сначала HTML-Mason, потом
mod_perl, далее
некоторая возня с service httpd restart на предмет "в httpd.conf нужно
дописать то, о чем написано в man HTML::Mason, ну,
примерно то, что нужно
написать". Потом создать директорию /path/to/dir/for/mason.
После её создания пишем
простой test.html:
Например обращение к базе данных на серверной стороне:
Примеры работы, http://www.pereplet.ru, литературный журнал, где каждое
высказывание в дискуссии по определенному произведению прицепляется к
определенному произведению html. И практически на
одном mason'е написан научный сервер http://www.nature.ru
Когда конфигурируют sendmail, в файле /etc/mail/access содержатся
правила для доставки почты, смысл которых заключается в том, что
можно отправлять почту только с определенных айпиадресов, прописанных в файле /etc/mail/access.
Что не очень удобно, если обладатель почтового ящика довольно часто перемещается по миру и из-за этих
правил не может отправлять почту через свой адрес. Для преодоления данной трудности существуют
два патча: SMTP AUTH и
pop before smtp. Ни одну
из них поставить не удалось, и пришлось поступить следующим образом: идем на сайт
pop before smtp
for Postfix, скачиваем тамошний модуль, распаковываем его и находим в распакованном файл popa3d-0.4.patch(там и для других демонов батчи есть, см. README). Согласно написанному правим сишные исходники демона popa3d, компилируем демон, получаем бинарник и перезаписываем его в /usr/sbin/popa3d. В результате в логах при pop3-аутентификации добавляется ip-адрес снявшего почту. Итого имеем имя и адрес снимающего почту. Дальше нужно написать некую программу, которая умеет смотреть, что добавляется в лог-файл, извлекать оттуда имя и ip-адрес и запысывать ip в /etc/mail/access:
Соответственно можно подправить sendmail.cf на предмет
подсказки пользователю, что он должен сделать, чтобы отправить почту:
Логин телнетом на 25-й порт sendmail'а для открытого релея(при закрытом ругнется и напишет relaing denyed и разорвет соединение):
Преположим есть веб-сервер, на котором пользователям нужно
завести домашние директории. В конфигурационном файле httpd.conf они должны иметь
в /home/user/ директорию public_html, тогда стандартным образом пользовательские директории могут вызываться примерно так: http://www.server.su/~user/
Нужно сделать так, чтобы пользователи могли исполнять
скрипты и программы в своих директориях. Заводим в
директории /home/user/public_html директорию cgi-bin. В httpd.conf
пишем
и после этого service restart httpd и пользователи могут исполнять и вызывать свои скрипты по адресу http://www.server.su/~user/ex/test.pl
Найти максимальное число с максимальным вложением единичек.
Решение, если убрать точки, будет максимальным числом.
Его и надо выделить:
Как это работает: конструкця @{[ тут
действия со списками ]} возвращает массив элементов, из
которого можно выделить нужный по номеру элемента массива
@{[blah-blah]}[0]. В переменной $_
содержится искомая "строка" из цифр, поэтому её можно разбивать по переводу
каретки: split m%\n%. После
split m%\n% для grep{s!\.!!g}
возвращается список, который из каждого элемента списка вырезает символ
точки(экранированный символ, т.к. символ точки в regex
означает любой символ). Дальше возвращается список чисел без точки,
которые сортируются при помощи sort {$a <=> $b}.
Скобки {$a <=> $b}
нужны для того, чтобы была произведена числовая, а не символьная сортировка.
Т.е. в случае print join "\n" => sort {$a <=> $b} grep{s!\.!!g} @blah-blah функция sort вернет такой список, где максимальным будет число, содержащее в начале себя тройку как максимальное число, т.е. критическим будет "старший бит":
далее при помощи reverse оборачивается
возвращаемый sort список и берется нулевой элемент массива,
состоящий из числа(в данном случае) 2111(что как число
2111 в целом больше, чем 311). Этот нулевой элемент затем режется по символу ноль(или по пустому символу, ведь между цифрой 2 и 1 не стоит ничего, вот по этому то ничего и режется): split m!! => @{[blah-blah]}[0]. Обычно в конструкции split ставятся два косых слеша split //, $string; эти два косых слеша есть не что иное как поиск по подстановке m//. А при указании буквы m в регулярном выражении слеши можно заменять любыми символами, например split mЫЫ. Далее при обычном синтаксисе ставится запятая, эту запятую можно заменить на стрелочку => без потери функциональности. Итого имеем split m!! => @{[blah-blah]}[0], т.е. массив, который нужно вывести в прежнем виде, т.е. .2.1.1.1, чего и делаем: print ".", join "." => split m!! => @{[blah-blah]}[0]
Другое более короткое решение той-же задачи от Artem Chuprina(from fido7.ru.perl):
Во первых нужно извлечь ключи из хешей и затем выбирать
уникальные элементы из массива:
ъБДБЮБ, УДЕМБФШ РПЙУЛПЧЙЛ ЮФПВЩ УПТФЙТПЧБМ ТЕЪХМШФБФЩ РП ТЕМЕЧБОФОПУФЙ,
ЙМЙ, ЮФП ФП-ЦЕ УБНПЕ, ПГЕОЙЧБМ РПИПЦЕУФШ, УФЕРЕОШ ПДЙОБЛПЧПУФЙ УМПЧ.
ьФХ ЪБДБЮХ ВПМЕЕ НЕОЕЕ ТЕБМЙЪХЕФ РТЙЧЕДЕООЩК ОЙЦЕ УЛТЙРФ:
ЕУФШ ЛБЛПК-ФП ФЕЛУФ Ч РЕТЕНЕООБИ $b,$o,$tw,$tb, ЪБЗПОСЕФУС ЧУЕ Ч НБУУЙЧ. дМС
ПФМБДЛЙ РЙЫЕФУС РПДРТПЗТБННБ rrand(), ЛПФПТБС РЕТЕУФБЧМСЕФ УМХЮБОЩН ПВТБЪПН
ЬМЕНЕОФЩ НБУУЙЧБ. дБМЕЕ ЙДЕФ ГЙЛМ, РПДУЮЙФЩЧБАЭЙК ЮБУФПФЩ ПДЙОБЛПЧЩИ УМПЧ Ч
РЕТЕНЕООЩИ Й ЪБОПУСЭЙК ЬФЙ ЮБУФПФЩ Ч ИЕЫ ИЕЫЕК. ч ИЕЫЕ ИЕЫЕК 1(Ф.Л.
ОХХНЕТБГЙС ЬМЕНЕОФПЧ НБУУЙЧБ ВЩМБ УМХЮБОЩК ПВТБЪПН ЙЪНЕОЕОБ, ФП ХДПВОП
ПВТБЭБФШУС ЮЕТЕЪ ОПНЕТ НБУУЙЧБ) УПДЕТЦБФУС РТЕДРПМПЦЙН ДМС РЕТЕНЕООПК $b ФБЛЙЕ ДБООЩЕ:
Ф.Е. УМПЧП БЖТЙЛБ РП ЮБУФПФЕ ХРПФТЕВМЕОЙС Ч ФТЙ ТБЪБ ВПМШЫЕ Ч ЖБКМЕ, ЮФП
ДБЕФ ЕНХ ВПМШЫЙЕ ЫБОУЩ ЧЩМЕЪФЙ Ч УРЙУПЛ РЕТЩИ ТЕЪХМШФБФПЧ. дБМЕЕ УМЕДХАФ
УМПЧБ ВХДЕФ Й ЪБЧФТБ, ЛПФПТЩЕ ФБЛ-ЦЕ ЙЗТБАФ ОЕНБМПЧБЦОХА ТПМШ Ч РПДОСФЙЙ
УУЩМЛЙ ОБЧЕТИ ЙЪ ТЕЪХМШФБФПЧ РПЙУЛПЧПЗП ЪБРТПУБ. дБМЕЕ Ч ГЙЛМЕ ПВЯСЧМСЕФУС
ИЕЫ(ЪБДБЮБ ВЩМБ УДЕМБФШ, Б ОЕ РБНСФШ УЬЛПОПНЙФШ), ЛПФПТЩК ВХДЕФ ЧЩЧПДЙФШ
ТЕЪХМШФБФЩ ЪБРТПУБ.
дБМЕЕ ЙДЕФ ГЙЛМ:
ЪБРТБЫЙЧБЕН ЮЙУМЕООПЕ ОБЪЧБОЙЕ ИЕЫБ Ч РЕТЕНЕООХА $r, УЮЙФЩЧБЕН У Её РПНПЭША
ИЕЫЙ ИЕЫЕК. ъДЕУШ ЖХОЛГЙЕК exists ТЕБМЙЪПЧБО РПЙУЛ ПВЭЙИ ЛМАЮЕК Ч ДЧХИ
ИЕЫБИ: Ч ИЕЫЕ, РПУФХРБАЭЕН ОБ ЧЧПД, Й ФЕЛХЭЕН РП ЫБЗХ ГЙЛМБ ИЕЫЕ ИЕЫЕК.
еУМЙ ЙОЖПТНБГЙС УПДЕТЦЙФУС Ч ОБЮБМШОПН ЧФПТПН ИЕЫЕ %vr, ФП ЪБРТБЫЙЧБЕН Её
$vr{$r}. уФТПЮЛБ $u++ ПФЧЕЮБЕФ ЪБ ЛПМЙЮЕУФЧП ЧИПЦДЕОЙК ЧУЕИ УМПЧ, ЪБДБООЩИ Ч
ЪБРТПУЕ, Ч ЙУЛПНХА УФТПЛХ(ЖБКМ). дПРХУФЙН ОБ ЧИПДЕ ЖТБЪБ "ВХДЕФ БЖТЙЛБ
ЪБЧФТБ", ЕУМЙ ИПФС ВЩ ПДОП УМПЧП ЙЪ ЬФПК ЖТБЪЩ УПЧРБМП УП УМПЧПН Ч ПЮЕТЕДОПК
УФТПЛЕ(ЧЕДШ ЙЪОБЮБМШОП УФТПЛБ ВЩМБ РПВЙФБ ОБ ЮБУФПФОЩК ИЕЫ) ФП МПЛБМШОБС РЕТЕНЕООБС
$u
ХЧЕМЙЮЙФ УЧПЕ ЪОБЮЕОЙЕ ОБ ЕДЙОЙЮЛХ. еУМЙ ДЧБ УМПЧБ Ч УФТПЛЕ Й Ч ЪБРТПУЕ
ПДЙОБЛПЧЩ, ФП $u=2, ЕУМЙ ФТЙ - $u=3 Й ФБЛ ДБМЕЕ, УМПЧ Ч ЪБРТПУЕ НПЦЕФ ВЩФШ МАВПЕ
ЛПМЙЮЕУФЧП. дБМЕЕ ЙДЕФ УФТПЮЛБ
ЛПФПТБС ЪБОПУЙФ ЮБУФПФЩ УМПЧ(3,1,1 ЛБЛ ВЩМП ЧЩЫЕ Ч РТЙНЕТЕ) Ч ФЕЛХЭЕК
УФТПЛЕ. дБМШЫЕ ЙДЕФ УБНБ exists Й РПУМЕ ОЕё ТБЪВЙТБЕНУС У ЧЕУПН
РПЧФПТСАЭЙИУС УМПЧ Й ЧЕУПН РПМОЩИ УПЧРБДЕОЙК. ф.Е. ДПМЦОП ВЩФШ ФБЛ, ЮФПВЩ
РПМОПЕ УПЧРБДЕОЙЕ ЖТБЪЩ ЙНЕМП ВПМШЫЕЕ ЪОБЮЕОЙЕ, ОЕЦЕМЙ ЮЕН ОЕРПМОПЕ
УПЧРБДЕОЙЕ + РБТБ РПЧФПТПЧ. оП ЖХОЛГЙС ЖЕДЕФ УЕВС РП ИЙФТПНХ, ДПРХУФЙН,
ЕУМЙ ОХЦОП ОБКФЙ УРЕГЙБМЙЪЙТПЧБООХА ЙОЖПТНБГЙА ФЙРБ "иЕЫ ИЕЫЕК ИЕЫЕК ИЕЫЕК
ИЕЫЕК НБУУЙЧПЧ", ФП ЧЕУ РПЧФПТЕОЙК УМПЧ ВХДЕФ ВПМШЫЕ, Ф.Е. ЧЛМБД ЮМЕОБ
$ee[0]-1(ТБЪОЙГБ Ч ЕДЙОЙГБИ ОБ УМХЮБК ОЕРТЕДОБНЕТЕООПЗП РПЧФПТБ) ВПМШЫЕ, ЮЕН
$u. ч ФП-ЦЕ
Данную программу можно приспособить, например, для отправки SMS-сообщений
через www.mts.ru/sms или иные странички.
В случае биллайна нужно позвонить по определенному телефону, после чего
на sms.beemail.ru будет выделен e-mail адрес, через который можно отпавлять
почту через sms. Но биллайн не разрешает отправку пересылаемых
сообщений(которые содержат Forward, т.е. нужно писать скрипт через
procmailrc или smrsh, который бы перенаправлял сообщения на sms.beemail.ru).
Так-же mts поддерживает отправку на sms простых картинок, но нужно с ними
предварительно договариватся о формате.
Перво-наперво надо навести порядок в понятиях. Шестнадцатеричных
чисел не существует, существует шестнадцатеричное представление
чисел. Так шестнадцатеричное представление числа "десять" есть A,
двоичное представление числа "десять" - 1010 и т.д.
Скалярные переменные в Перл могут хранить как числа так и их
строковые представления (они также могут хранить и другие
значения, например "числа с плавающей точкой", но нас они
пока не интересуют). Преобразования между числами и их
строкыми представлениями в десятичной системе в Перл прозрачны,
т.е. выполняются автоматически, остальные варианты преобразований
необходимо осуществлять явно. Например:
напечатают строку "10" (число из $x_dec будет преобразовано
в десятичное представление автоматически). А
запишут в переменные $y и $z число "одиннадцать" поскольку
строка из $x_10 будет автоматически преобразована в
число из
его десятичного представления. Остальные часто используемые
преобразования:
А судя по приведенному Вами примеру, Вам
нужно записать в файл
байт (октет) со значением XX, где XX задан в виде строки с его
шестнадцатеричным представлением.
Если значение задано в виде числа или его десятичном представлении,
достаточно просто:
by Andrey Sapozhnikov from fido7.ru.perl
По адресу http://search.cpan.org/recent
можно найти ежедневные обновления архива модулей CPAN. Кадый день добавляется(или обновляется) в среднем 20
модулей(из них около 10 новых). Например недавно вышла очередная версия
модуля для доступа к
локальным ресурсам при помощи smb-client Filesys::SmbClientParser
Quantum::Entanglement позволяет моделировать программирование квантового компьютера (Slashdot | Quantum Programming with Perl). Сделаем предположение, что состояние переменной определяется двумя возможными числами 1 и 0(т.н. кубит). Если таких переменных много, то они могут находиться в кластерном("запутанном") состоянии (entangled state), т.е. когда изменение одной из переменных ведет за собой мгновенное изменение всех других. Конечно, обычный компьютер производит вычисления последовательно(и изменение одной переменной не ведет за собой изменения остальных), но данный модуль, тем не менее, прозволяет проводить некоторые эксперименты над такими состояниями.
В модуле Quantum::Entanglement определена функция entangled(), которая на входе имеет значения пар амплитуд и чисел, и на выходе имеет скаляр из суперпозиции этих состояний. Например
Теперь нужно определить, что происходит, когда мы наблюдаем нашу переменную и что подразумевается под наблюдением. В широком смысле определение "что-то, что показывает значение переменной" является правильным. Можно довольно многими видами сравнения определить "содержание" переменной, даже операторы типа eq или <= могут сообщить о некоторых свойствах переменной. Каким образом определить, что переменная $die является измеренной? Попадание значения переменной $die в какое-то конкретное число(состояние) из чисел 1 .. 6 определяется возможностью этому числу выпасть при разыгрывании, например, игровой кости. Поскольку игральная кость выпадет в любом случае какой-то своей гранью, то результатом будет число и в идеальном варианте на каждую одну шестую от общего времени всех бросаний кости она будет иметь какой-то номер. Но при этом все остальные состояния уничтожатся. Т.е. в процессе полета кости переменная $die существует($die - равновероятность выпадения одного из 6 номеров), а как только кость на столе успокоилась, то переменной $die, определенной в смысле функции entangle уже не существует, существует только лишь какое-то конкретное е╦ значение. При этом пядь шестых игроков хмуро расплачивается с одним счастливчиком. Это собирающее всех игроков вместе состояние и называется либо запутанным(entangled), либо кластерным, либо странным. Рассмотрим программу:
Напишем пример реализации умножения чисел:
Что делает этот скрипт, т.к. состояния слинкованы(т.е. изменяя одно изменим все остальные), то их произведение будет связанным произведением комбинации из этих чисел. Т.к. $answer является всевозможными комбинациями из произведений первых двух матриц @inputsA и @inputsB, то фактически получается, что написав строчку my $answer = $inputsA * $inputsB; определили пространство произведений этих комбинаций(т.е. сразу задали всю таблицу умножения).
Далее происходит определение режима наибольшего благоприятствования $Quantum::Entanglement::conform = 1; и само сравнение, уничтожающее сначала неопределенность $inputsA(т.е. при вводе из консоли первого конкретного числа от таблицы умножения остается фактически один столбец с умножением одного числа на все оставшиеся) и, далее воодя второе число, устраняется неопределенность $inputsB(который имеет разброс 1 .. 10). Т.е. изначально заданная система становится конкретизированной, из 100 возможных результатов получается одно.
При распаковке Quantum-Entanglement.*.tar.gz в директории demo/ лежит файл shor.pl, реализующий алгоритм Шора для разложения числа на два множителя. В той-же директории лежит файл root_not.pl, который умеет строить противоположные к начальному entangle(a,c,b,d) состояния.
Всякий раз, когда связанные переменные находятся в таком взаимодействии или при вычислениях, результаты(ведь граней у вышеописанного кубика 6, а значит и 6 возможностей) будут в такой-же степени связаны друг с другом. Если числа могут быть коэффициентами таких состояний(например вероятность выпадения одного номера в 2 раза больше чем другого), то вполне логично предположить, что этими коэффициентами могут быть и комплексные числа. Только вместо обычного значения этого числа нужно использовать квадрат его модуля(например |1+2i|**2 == 5 == |1-2i|**2).
Более подробно умножение комплексных чисел описано тут.
Quantum::Superpositions
(перевод из соответствующего мана)В стандартной интерпретации квантовой механики частицы существуют как функция вероятности. Например, частица, которая могла бы наблюдаться в состоянии A, B, или C, может рассматриваться в таком некотором псевдосостоянии, где она присутствует одновременно во всех трех состояниях. Считается, что такая частица находится в состоянии суперпозиции. Исследования состояния суперпозиции уже довольно давно известны(см. Наука и жизнь - Квантовые компьютеры, Квантовая суперпозиция макроскопических состояний, Квантовый компьютер, для тех кто еще не понял) и их целью является разработка надежных квантовых блоков памяти, в которых единичный бит(1 или 0) может являться свойством квантуемой частицы(qubit). Т.к. частица может быть физически введена в состояние суперпозиции в определенных условиях, то она может сохранять биты, являющиеся одновременно как 0 так и 1. Определенные процессы, основанные на взаимодействиях одного или более кубитов(элементарных носителей информации) используются чтобы создавать квантовые логические затворы. Такие затворы могут, в свою очередь, использоваться для логичеких операциях на кубитах, позволяя проводить параллельные вычисления. Но математика для таких вычислений очень сложна. Описываемый модуль Quantum::Superpositions предлагает другой подход, основанный на суперпозиции полных скалярных произведений.
В модуле Quantum::Superpositions существуют два оператора any и all. Каждый из этих операторов берет спиоск значений(состояний) и помещает их в одну скалярную переменную. any и all опреаторы устанавливают два различных вида суперпозиции, any делает суперпозицию дизъюнктивной, которая(умозрительно конечно) может выводить состояние в любое из возможных согласно требованию алгоритма.
Оператор all создает коньюктивную суперпозицию, которая является всегда в каждом из е╦ состояний одновременно.
Суперпозиции - скалярные значения и, следовательно, могут участвовать в арифметических и логических операциях точно так же, как и любой другой тип скаляра. Но, когда операция применяется к суперпозиции, то она применяется параллельно к каждому из состояний, образовывающих ту или иную комбинацию.
Например, если состояния 1, 2, и 3 умножены на 2:
то результатом такого умножения будет соответственно столь же связанные состояния 2, 4, и 6. Если такое состояние проверить на равенство 4-м:
то тогда сравнение так-же возвращает суперпозицию из двух вариантов "истина" и "ложь", т.к. равенство истинно для одного из состояний и ложно для двух других. Естественно, что значение, которое равновероятно(может быть либо истиной либо ложью) - бесполезно, но оно становится полезным, если добавить некоторый механизм, который определяет приоритет из этих значений.
Дизъюнктивная суперпозиция истинна, если любое из е╦ состояний истинно, принимая во внимание при этом, что коньюктивная суперпозиция истинна только в том случае, если все е╦ состояния истинны. То есть предыдущий пример напечатает fore, в котором начиная с if состояние эквивалентно:
т.е. если любой из 2,4 или 6 равен 4, то условие истинно и блок выполняется. С другой стороны, если есть инструкция
то условие неверно, так как не истинно, что все 2, 4, и 6 равны 4. Операции также возможны между двумя суперпозициями:
В этом примере строка "no alcohol" выведется потому, что суперпозиция, произведеная умножением - декартово следствие соответствующих состояний двух операндов all(5,6,10,12,15,18). Так как все эти результирующие состояния меньше чем 21, то состояние является истинным. Напротив, строка "no entry" не выведется потому, что не все состояния, получаемые в результате операции all(1,2,3)*any(5,6) меньше чем 18. Можно заметить, что тип первого операнда определяет тип результата операции, следовательно третья строка "under-age" напечатана потому, что умножение дизъюнктивой суперпозиции на коньюнктивную суперпозицию дает результат, который является дизъюнктивым: any(5,6,10,12,15,18). Условие if спрашивает, является ли любое из этих значений меньше чем 18, что и является истиной.
Составные суперпозиции могут быть любым видом скалярного значения - числом, строкой или ссылкой:
Более интересно, когда индивидуальные состояния - скалярные значения и суперпозиция так-же является скалярным значением, т.е. суперпозиция может состоять из состояний, являющихся такими-же суперпозициями.
Операции, вовлекающие такую составную суперпозицию работают рекурсивно и в параллельном из каждых ее уникальных состояний и тогда реконструируют результат. Например:
Условие any(@features) eq $ideal истинно, если входные характеристики соответствуют любой из трех добавленных коньюктивных суперпозиций. Т.е. если характеристики все вместе приравниваются к кажомой из "tall", "rich" и "handsome", или ко всем из "smart", "Australian" и "rich".
Иногда необходимо определить список состояний, из которых состоит данная суперпозиция. Фактически, сами по себе это не состояния, но значения к которым могут свертываться состояния - eigenstates, являющиеся полезными. В смысле программирования это набор значений @ev для данной суперпозиции $s такой как
Этот список обеспечивается оператором `eigenstates', который может обратится к любой суперпозиции
Примеры, показанные выше имеют ту-же самую мета-семантику для обеих арифметических и булевых операций, а именно, что бинарный оператор применяется к декартовым состояниям из двух операций, независимо от того, является ли операция арифметической или логической. Таким образом сравнение двух супрпозиций дает суперпозицию 1's и 0's, давая возможность сравнить любые состояния между собой из двух суперпозиций. Недостаток применения метасемантической арифметики к логическим операциям состоит в том, что может быть потеряна полезная информация. Действительно, есть состояния, которые ответственны за успешное сравнение. Например, возможно определить, является ли любой номер в массиве @newnums меньшим, чем все номера в массиве @oldnums
Но это не очень хорошо в том смысле, что нельзя увидеть, какой элемент(-ы) @newnum сделал условие истинным. Но, однако, возможно определить различную мета-сематнику для логических операций между суперпозициями; один также сохраняет интуитивную логику сравнений и ограничивает доступ к состоянию, которое вызвало истинность сравнения. Ключ должен отклоняться от арифметического представления суперпозиционного сравнения(а именно, что сравненная суперпозиция уступает суперпозиции сравниваемых комбинаций состояний) Вместо этого, различные операторы сравнения переопределены так, чтобы они формировали суперпозицию тех eigenstates левого операнда, которые заставляют операцию быть истинными. Другими словами старая мета-сематника накладывает результат каждого парралельного сравнения, в то время как новая мета-семантика левого операнда каждого параллельного сравнения выпонляется. Например под первоначальной семантикой сравнения
Успешность сравнения(результата) больше не определена значениями конечных состояний, но определена числом состояний конечной суперпозиции. Модуль Quantum::Superpositions обрабатывает логические операции и булевы преобразования именно этим способом. Под этой мета-семантикой возможно проверять сравнение и также определять, какой eigenstates левого операнда был ответственнен за успешное сравнение:
Таким образом, эта семантика обеспечивает механизм проведения параллельного исследования минимумов и максимумов:
Эти определения также весьма интуитивны, почти декларативны: минимум - любое значение, которое является "меньше или равным" чем все другие значения; максимум - любое значение, которое является "большим чем или равным" ко всем из них.
Строковая оценка суперпозиций
Преобразование суперпозиции в строковое представление производит строку, которая кодируется самым простым набором eigenstates эквивалентов первоначальной суперпозиции. Если есть только один eigenstate строчность этого состояния может быть представлено в строковом представлении. Это устраняет явное применение оператора eigenstates, когда возможно только единственное состояние. Например
Во всех других случаях суперпозиции - преобразуются в формате: "all(eigenstates)" или "any(eigenstates)".
Числовая оценка суперпозиций
Обеспечение неявного преобразования в числа(для ситуаций, где суперпозиции используются как операнды в арифметике или как индексы массива) бывает более лучшим, чем строковое представление, до тех пор, пока нет никакого механизма для фиксирования полного состояния суперпозиции в единственном не добавленном номере. Снова, если суперпозиция имеет единственный eigenstate, то преобразование него выполняется стандартным образом. Например, чтобы вывести значение в элементе массива с самым маленьким индексом в наборе индексов @i:
Суперпозиции как аргументы подпрограмм
Когда суперпозиция применяется, как аргумент подпрограммы, эта подпрограмма применяет свое действие параллельно к каждому состоянию суперпозиции и переизмененные резльтаты так-же формируют аналогичный тип суперпозиции. Например, учитывая:
тут $r1 содержит дизъюнктивную суперпозицию any(1,2,3), $r2 содержит конюнктивную суперпозицию all(1,64,729) и $r3 содержит конъюнктивную суперпозицию `any(1,4,9,16,64,81,729)'. поскольку встроенные функции sqrt и pow не знают о суперпозициях, моудль обеспечивает им механизм для информирования их относительно того, какие аргументы должны быть переделаны, чтобы образовать суперпозицию. Если вызывать use Quantum::Superpositions со списком аргументов, то список определяет, какие параметры должны быть добавлены, чтобы сохранилось состояние суперпозиции. Унарные функции и подпрограммы могут быть квантованы как-то так:
Для двойных функций и использования подпрограмм:
Примеры, исследование простых чисел:
Программирования со скалярными суперпозициями возможно является лучшей заменой, которая привлечет к себе противников квантового исчисления: оно может оперировать с простыми числами. Здесь, например, 0(1) - проверка на простоту чиле, основанная на обычном делении:
Подпрограмма берет аргумент $n и считает(парралельно) его модуль относительно каждого целого числа между 2 и sqrt($n). Происходит коньюнктивная суперпозиция модуля который в тот момент сравнивается с нулем. Такое сравнение будет истинно только в том случае, если весь модуль - не нулевой, что является критерием числа, чтобы быть простым. Так как is_prime берет скалярный параметр, то он так-же может являться суперпозицией. В качестве примера можно привести не меняющийся со временем фильтр, определяющий, является ли число частью пары из двух простых чисел:
Множества и их пересечения:
Операции со множествами особенно просты для исполнения, если применять superimposable(нет в словаре такого слова) скаляры. Например, учитывая список значений @elems, представив его элементы как элементы множетсва, переменная $v является элементом этого множества, если:
обратите внимение, что такой тип определений эквивалентен определению eigenstate. Та эквивалентность может использоваться, чтобы вычислять пересечения множества. Учитывая две дизъюнктивные суперпозиции $s1=any
(@elems1) и $s2=any (@elems2) представляя два множества, переменные, составляющие пересечения этих двух наборов должны быть eigenstates <$s1> и $s2. Следовательно:
Этот результат может быть апроксимирован для параллельного применения к обычным элементам произвольного числа массивов:
Факторизация
Разложение на числе на множители так-же очень просто, если использовать суперпозиции.
Коэффициенты целого числа N - все частные q от
N/n(для всех положительных целых чисел n <
N), которые так-же являются итегралом. Положительный номер q - floor(q)==q. Следовательно факторизовать число можно можно как-то так:
Обработка запросов
Суперпозиции могут так-же применяться для поиска строки в массиве строк. Например, чтобы определить, появляется ли данная строка $target в массиве строк @db:
Определить, какая из строк базы данных содержат $target:
Сравнение происходит гораздо быстрее, чем это умеет делать база данных, чтобы найти единственную строчку в любой из набора в базе.
Или в каждой одновременно
Принимаются корректровки к переводу и примеры.
Алгоритм, позволяющий получать простые числа, отличается по быстродействию
от приведенного ниже алгоритма с применением Quantum::Superpositions:
Существует некоторый класс проблем, которые требуют автоматической проверки
наличия удаленного сервиса, слушающего определенный порт. Например,
необходимо
узнать, когда будет запущен сервис на удаленной машине, или, например, когда
будет
запущен некий внутренний сервис. Или, в случае неустойчивой связи(удаленный
сервер
через мобильный телефон по GPRS в деревне, на котором необходимо
поддерживать непрерывную связь), нужно
отслеживать наличие соединения и по его исчезновению информировать
находящихся поблизости людей о том, что связи нет(с случае когда сотовй
телефон не умеет сам находясь, на crontab'е, восстанавливать соединение).
Задача сводится к написанию программы, умеющей автоматически опрашивать
удаленный порт и при наличии соединения редиректить информацию, посылаемую
на этот порт на другие определенные порты в зависимости от заголовка.
Аналогичное решение ssh - тунеллирование.
Предположим есть некоторая запускаемая каждое утро программа, обслуживающая
некоторое хитрое устройство(например мониторинг скорости водостока или
химический анализ речной воды на нескольких участках реки, до и после
сточного коллектора того или иного предприятия) в далекой сельской
глубинке(где и не пахло связью), с которым необходимо работать
одновременно нескольким городским пользователям.
Если программа, обслуживающая устройство, пишет данные в сокет, открываемый
ею без указания опции SO_REUSEADDR, то после каждого соединения
приходится ждать некоторе время, пока *nix разблокирует сокет для дальнейшей
работы после предыдущего соединения. Это замедляет работу и чтобы
обойти это препятствие необходимо сделать редиректор, обходящий блокировку
сокета. Приведенная ниже программа является промежуточной между
программой, управляющей неким устройством(типа описанных выше) и клиентскими
приложениями.
Схема работы:
В случае отсутствия соединения в системе постоянно висит процесс(запускаемый
например как service redirect start или ./redirect.pl &),
умеющий плодить дочерний процесс, опрашивающий удаленный хост. В случае
неудачного соединения процесс завершается и порождается заново например
через каждые
2 секунды. В случае соединения клиент логинится на удаленный сервер и плодит
пул процессов-серверов(для ускоренной обработки соединений), к которым далее
могут подсоединяться многочисленные клиенты.
Итак, базовый процесс подсоединился к удаленному клиенту, породил дочерние
процессы и готов к работе. Между исходным устройством и подсоединяющимися
клиентами возможен обмен данными и задача сводится к обмену данными между
разными процессами в памяти *nix-машины.
Для этого необхожимо открыть канал между процессами. Если обмен данными
невелик, то можно обойтись одной общей переменной на несколько процессов
и изменять её содержимое и соответственно отслеживать её состояние. Можно
поступить и по иному, открыть каналы в виде дескрипторов и контролировать
таким образом чтение и запись.
В принципе данные решения и идеи без особых затрат и при надлежащем умении
позволяют организовать и поддерживать целые сегменты сети без
дорогостоящей прокладки оптоволоконных кабелей или дорогостоящих спутниковых
приемников при условии полного отсутствия телефонных линий.
Какова цена этого мероприятия? 0.30$/Mb - GPRS BeeLine и 0.15$/Mb GPRS MTS
Прокладка же оптоволоконного кабеля и последующая разводка стоит около
20000$, примерно такая-же стоимость и у спутниковой тарелки. Конечно, иногда
проложить телефонный кабель дешевле, но это зависит от конкретных условий...
А построенная на такого типа серверах-клиентах распределенная мониторинговая
система обходится на порядки дешевле. И, к тому-же, без значительных изменений,
кроссплатформенна, так как данный скриптовый язык работает на многих типах
операционных систем.
В принципе, если написать обработчик входящих писем и отправку почтовых сообщений
через sms.beeline.ru на мобильный телефон, можно через сотовый
телефон посредством получения и отправки sms-сообщений осуществлять
мониторинг и администрирование удаленного сервера(соответственно отпадает
необходимость в сотовом notebooks).
Допустим файл текстовый примерно такой:
Из файла выбираются все слова на букву "в" и их позиция в файле, т.е. допустим "водка" стоит в файле на сотом байте. Функция seek позволяет перемещаться не читая файл, что долго, а сразу к нужному байту. Есть файл-хеш(массивов) "буква => цифры", позиций в файле: "все слова на букву "в" находятся там-то и там-то".
т.е. слова на букву "в" стоят в файле на 10 байте, 20000 байте и т.д. И так по всем буквам. Это была первая буква "в" слове, дальше еще один хеш построить, по сторой букве, т.е. есть слова на букву "в" а среди этих влов есть позиции слов с "ва" "вб" "вв" "вг" "вд" "ве" и т.д. и скажем такое разбиение документа глубиной в слове до пятой или шестой буквы. Юзер ввел в форму слово "водка", программа ищет начала позиции всех слов начинающихся на букву "в", получает(если гигабайт текста) ссылки на 30 мегабайт слов, начинающихся на букву "в". Вторая буква в слове водка это "о". Т.е. поиск уже происходит в этих 30 мегах по букве "о"(выборка 30 мегов делим на 33, получаем на втором шаге мегабайт из изначального гигабайта, если считать что слова размещены в файле(файлах) равновероятно, т.е. слов на букву "а" столько же сколько и на букву "б", "д", "е" и т.д.), третья буква в слове водка "д". но, поиск уже происходит по тому мегабайту, который получился отсеиванием первых двух букв. Делим мегабайт на 33 буквы, получаем 30 килобайт слов, содержащих три буквы "вод". Далее по индукции доходим до последней буквы "а" в слове "водка".
Итого, чтоб не перебирать весь гиг информации, надо seek'ом перебрать за 5 приемов 30 мегабайт+1 мегабайт+30 килобайт+1 килобайт+30 байт+1 байт. Ну и соответственно так-же устроен поиск если не с начала буквы, т.е. полное индексирование, слово "подводный" например, где "вод" стоит в середине слова. и так этой тройкой бегать во всему слову, вариантов Cn
k=n!/(n-k)!k!, где k - три буквы "вод" а n - девять букв слова "подводный".
Есть очень большой двоичный файл, который пронизан связами(чтобы удобно было ходить seek'у по ним). Его можно открывать и сдвигать байты, чтобы дописать нужный файл(который изменил пользователь на сервере). Т.е. отследить нитку для слова(или, что то-же самое, для целой странички). Ведь сначала будут выстраиваться параллельные связи и только в конце, если слово более 6-8 букв, будут разветвления в этой структуре. По идее, можно добится того, что редактировать файлы можно будет непосредственно в этом двоичном файле. Т.е. набираешь cd req(или cat /var/log/error.log | more или tail -f /var/log/error.log) и ты уже не в юниксовой файловой системе, а в этом файле, в котором стоит обработчик, такая-же консоль. А интерпретатор команд создает видимость, что ты сидишь в обычной директории и ворочаешь обычными файлами....
Что это дает? Довольно большую скорость доступа к очень большим текстовым архивам без применения базы данных, которая, как правило, держит индекс в памяти.
Поиск по маске слов.
Когда двое людей говорят о море, то сначало не ясно, о чем дальше пойдет речь, о рыбе, о кораблях, или о красивом вечернем прибое, а может и о отпуске. Далее из контекста разговора как правило в течении минуты можно разобратья о чем речь. Т.е. люди используют ассоциации и находят общий образный язык. Человеческий образ допустим море это отпуск. Однозначно ассоциируется с тем, какие круизы, какие корабли, какие гостинницы, пляж из гальки или из песка. Организованный отдых или дикарем. Вобщем при упоминании моря в таком контексте роджаются совершенно однозначные мысли.
Или например в другом контексте. То-же самое море может ассоциироваться с красивым горным пейзажем, с какими-то воспоминаниями. Что упрется в поиск фотографий, к примеру, или, если постарше, то к исторической информации об этих местах.
Итак, ассоциация это набор понятий, все более и более сужающийся по мере продолжительности раговора. Собственно люди иногда и расходятся, когда не находят общего языка, так-же и с поисковиками, выдает не то, что нужно.
Изначально было широкое понятие море, которое включало в себя понятие отдыха, рыбы, интересных съемок Ива Кусто или арктических путешествий Нансена с Амундсеном, а может быть и путешествие Кука. Далее информация разделилась на покатегории, по человеческим ассоциаиям. Допустим море интеренсо как место отдыха, остальные гигабайты отсеялись. Место отдыха однозначно ассоциируется с красивыми видами, прогулками на катерах, ну и с поиском жилья.
Т.е. человек невольно определяет круг вопросов, которые ему нужно решить, чтобы провести отпуск. Фактически, на простом разговорном языке мы уже произвели отсев нужной информации. И это не было релевантностью, которая есть максимальное число слов в данном документе.
Как сделать так, чтобы поисковая система сама отсеивала нужную информацию. Т.е. выдавала то, что необходимо. В первые минуты разговора между двумя людьми происходит знакомство их интересов, которые в подавляющем большинстве и определяют дальнейшие отношения. В первые минуты работы с поисковой системой происходит точно такое-же знакомство. Поисковик выдает резултьтаты. Нет того, что нужно, значит ухожу на другой поисковик. Предположим слово море выдает несколько ссылок: отдых, исследования океана, знаменитые путешествия(Моби Дик) и т.д.
Пользователь выбирает себе нужную категорию(как составить такие тематические категории автоматичекси, чуть ниже, это и есть поиск по маске слов), далее переходит на еще один вложенный уровень категорий, а в конечном итоге он интересуется путешествием Ниньи.
Вышел с первого уровня на второй, где стоят ссылки: Тихий океан. Гречекие корабли, мифический остров Атлантида, Индийский океан, морские сражения(и все это отсортировано по алфавиту скажем) и т.д. Появилась структура запроса, начиная от знакомства с основной тематикой диалога. Эту структуру можно генерировать автоматически.
Допустим словосочетакие "Альберт Эйнштейн" однозначно ассоциируется с атомной бомбой, теорией относительности и скажем с преобразованиями лоренца, как конечный запрос. При вводе словосочетания "Альберт Эйнштейн" сразу выводится тематический рубрикатор в алфавитном порядке. Поиск анализирует разные документы на предмет совпадений разных слов. И чем больше документы походят друг на друга, тем ближе к одной тематике результаты, т.е. больший шанс попасть в данную категорию и в данную букву при кортировке по алфавиту. Чем больше различаются данные слова, тем больший шанс попасть в другую ссылку, другую букву. Т.е. происходит поиск не конкретного слова, а идет анализ результатов, оценивается степень их совпадения между собой. И чем больше процентов "похожести" слов по тематике, тем больше вероятность соотнести эти
докуметы между собой. Т.е. идет своеобразное выстраивание документов по тематике, используя одинаковые слова, а слова тянут за собой ассоциации. Т.е. не один запрос, как сказал пользователь, а на самом деле внутри машины может произойти 100000 сравнений документов между собой, никакая база данных не потянет такой одновременный поиск. Иными словами при действиями с этими масками слов просиходит уже не сравнение конкрентых слов, а сравнени понятий, выражаемых этими словами. Ну а чем еще можно выразить какое-то отношение, помимо слов.
Структура этого дерева может быть реализована на хешах хешей, хешей массивов, массивов хешей, а быть может и хеши slice. Или взаимные комбинации, может быть хеши хешей размерности N.
10. Использование бибилотек
11. Низкоуровневое программирование железа, микроконтроллеры и т.д.
12. Применение логики квантовых компьютеров
Perl - полезности
Если есть что сказать, пишите по e-mail.
И еще, все я наверное напишу не скоро, что-то
посканировал, но в процессе написания вижу, что проще свое написать, чем
править отсканированное, да и себе полезней. Сканированное постепенно
убиваю, на данный момент около 70% текста написано собственноручно. Данный
текст можно копировать и видоизменять по собственному усмотрению. На весь
написанноый мной текст(за исключением сосканированного ранее ради полноты картины) распространяется лиценция
GPL.
Работа со временем
Скорость работы программы можно определить, используя команду time:
bash-2.05$ time ./time.pl
real 0m0.613s
user 0m0.487s
sys 0m0.074s
bash-2.05$
Ниже приведено несколько примеров программ, выводящих текущее время.
&time($time);
print "$time\n";
sub time{
$time = sprintf("%02d/%02d/%02d b %02d:%02d:%02d", $tm->hour,$tm->min, $tm->sec, $tm->mday, $tm->mon+1, $tm->year+1900);
return $time;
}
Еще один способ:
#!/usr/bin/perl
my ($wday,$mday,$mon,$year,$time) =
(split(" ",gmtime(time+10800)))[0,2,1,4,3];
print "$wday, $mday $mon $year $time GMT\n";
print (split("\s",gmtime(time+10800)))->[0,2,1,4,3];
print "\n";
Тест для Григорианского календаря на високосность:
year % 4 == 0 && (year % 100 != 0 || year % 400 == 0)
Время можно вывести и вот так:
@d=split(/[ ]+/, scalar localtime);
печатает:
$d[0]=='Wed'
$d[1]=='Jun'
$d[2]=='5'
$d[3]=='14:59:35'
$d[4]=='2002'
Еще и так:
&Date($time);
print "$time\n";
sub Date {
($Second, $Minute, $Hour, $DayOfMonth, $Month, $Year, $Weekday,
$DayOfYear, $IsDST) = localtime(time);
$RealYear = $Year + 1900;
$Month++;
if($Month < 10) {$Month = "0" . $Month}
if($DayOfMonth < 10) {$DayOfMonth = "0" . $DayOfMonth}
if($Hour < 10) {$Hour = "0" . $Hour}
if($Minute < 10) {$Minute = "0" . $Minute}
if($Second < 10) {$Second = "0" . $Second}
$date = "$DayOfMonth-$Month-$RealYear";
$approval_date = "$RealYear|$Month|$DayOfMonth";
$time = "$Hour:$Minute:$Second";
}
И так:
#!/usr/bin/perl
use POSIX qw();
my $time = POSIX::strftime "%H:%M:%S", localtime time;
print "$time\n";
Если возникла необходимость локализовать время в соответствии с часовым поясом, то
#!/usr/bin/perl
use POSIX qw();
my $time = POSIX::strftime "%H:%M:%S", localtime(time+3*3600);
print "$time\n";
Спасибо: S.Nitsulenko, Vladimir Podgorny, Artem Chuprina, Dmitry Koteroff (from fido7.ru.perl
Простой анализатор логов на хеше хешей массивов
#!/usr/bin/perl
open F, "</var/log/rambler.access.log" or die "can't open: $!\n"; @mass=<F>; close F;
for $gr(grep{!$m{$_}++} map{/S?E?T (.*?) / if /usr/ or m!/~user/!} @mass){
for $line(@mass){
($ip, $n, $m, $data, $k, $method, $url, $protocol, $status, $size, $from, $brouser) =
split /\s/ => $line;
push @{$hash{$gr}{$ip}}, $size if $line=~m!$gr!;
}
}
for $a(sort keys %hash){ my ($u, $j);
print "file $a: \n\t";
for $key(sort keys %{$hash{$a}}){ $j++;
print " '$key' \t => [ ";
print 1+$#{$hash{$a}{$key}};
my $i;
for(@{$hash{$a}{$key}}){$i+=$_}
print " $i";
$u+=$#{$hash{$a}{$key}}+1;
print " ]\n\t";
}
print " dlya $a hitov $u, hostov $j\n";
print "\t\n";
}
эта программа сплитит каждую строчку лог-файла по разделютелю пробел.
Если написать обработчик логов, т.е. программу, которая анализирует, по чему
можно сплитить лог, то все здорово. А вообще по хорошему, необходимо,
чтобы при установке программы она сама запрашивала, какие логи за что
ответственны и как их анализировать. Главный принцип работы -
структурирование по ip-адресу, строится хеш для страницы, потом хеш для
адреса, и массив каждому ключу этого хеша вес скачанной информации.
Рамерность массива - число запросов данного ip к данному файлу. сумма
элементов
for(@{$hash{$a}{$key}}){$i+=$_} - полный рамер
величины
информации, выкачанной пользователем.
При помощи небольших изменений(тут нужно знать схему построения хеша хешей
массивов) можно
выделять и сортировать любую информацию по любым броузерам или охвату
территории.
Соотвественно условие map{/S?E?T (.*?) / if /usr/ or
m!/~user/!} говорит о том,
что нужно сплитить. Изменим программу допустим как-то так:
#!/usr/bin/perl
use CGI 'param';
$dir1=param('d1');
$dir2=param('d2');
open F, "</var/log/rambler.access.log" or die "can't open: $!\n"; @mass=<F>; close F;
for $gr(grep{!$m{$_}++} map{/S?E?T (.*?) / if /$dir1/ or m!$dir2!} @mass){
for $line(@mass){
($ip, $n, $m, $data, $k, $method, $url, $protocol, $status, $size, $from, $brouser) =
split /\s/ => $line;
push @{$hash{$gr}{$ip}}, $size if $line=~m!$gr!;
}
}
for $a(sort keys %hash){ my ($u, $j);
print "file $a: \n\t";
for $key(sort keys %{$hash{$a}}){ $j++;
print " '$key' \t => [ ";
print 1+$#{$hash{$a}{$key}};
my $i;
for(@{$hash{$a}{$key}}){$i+=$_}
print " $i";
$u+=$#{$hash{$a}{$key}}+1;
print " ]\n\t";
}
print " dlya $a hitov $u, hostov $j\n";
print "\t\n";
}
Вводя команду вида bash2-05$ log.pl d1=www
d2=/~user/
получим данные о числе заходов пользователя на данную страницу и статистику
по файлам. Не знаю, как насчет других анализаторов логов, но этот намного
легковесней и состоит из пары десятков строк. Но, он имеет очень большой
минус,
он весь логфайл держит в памяти, т.к. для полной статистики по логфайлу
необходимо анализировать весь лог. Введя условия в
map{/S?E?T (.*?) / if /usr/ or m!/~user/!}, можно
ограничить
выборку конкретной директорией. Хотя впрочем это не настолько трудная
задача, можно читать каждую дирректорию по отдельности.
В любом случае при анализе логов происходит полное чтение логфайла, в
предложенном варианте
программы чтение однократное, но и машину повесить может. Но, вобщем, это
решабельно...
Стирание символа перевода каретки
Более сложная задача, убрать все неправильные символы перевода
каретки ^M, которые, допустим, появляются при передаче файлов far'ом на свой
сайт:
#!/usr/bin/perl -w
use strict;
use File::Find;
find( \&wanted, '/var/www/html/allsitecopy' );
sub wanted {
return if /^\.\.?$/ and not /\.html?$/i and not -f;
local $/;
open F, "< $File::Find::name" or do {
warn "Cannot read from $File::Find::name: $!";
return;
};
binmode F;
my $mass = <F>;
close F;
$mass =~ tr/\cM//d;
open F, "> $File::Find::name" or do {
warn "Cannot write to $File::Find::name: $!";
return;
};
binmode F;
print F $mass;
close F;
print "$File::Find::name all ok!\n";
}
Не рекомендую запускать подобные программы, не разобравшись, правильно
ли оно закрывает открытые файлы. Это все конечно очень здорово, что это
можно
cделать, но все-таки голову на плечах нужно иметь, сначала попробовать
на маленькой поддиректории, убедится, что все ок и только после этого
что то делать программой с серьезными данными.
Пример использования модуля File::Find для
рекурсивного(вход во все поддиректории) просмотра
или подсчета числа html или shtml или htm файлов(эти три вида файлов
определяеются реглярным выражением s?html?):
#!/usr/bin/perl -w
use File::Find;
find \&wanted, '/var/www/html';
sub wanted {print $count++, "\t$File::Find::name all ok!\n" if /s?html?/i}
Всего 4 строчки против в среднем 10-20... удобно,быстро, и, главное,
лениво.
Get image size
Предположим необходимо узнать размер картинок, чтобы выставить их размеры во
вновь генерируемом html. Для этого нужно взять
модуль Image-Size-*.*.tar.gz установить его, затем man Image::Size и для какой-то картинки получим размер с
помошью несложного скрипта:
#!/usr/bin/perl
use Image::Size;
($x, $y) = imgsize("/var/www/html/images/mnu_item.gif");
print "$x x $y\n";
[root@www devel]# ./image.pl
15 x 15
[root@www devel]#
Mail with attachement
Приведенная программа позволяет отправить открытку с веб странички.
Подпрограмма &vibor() читает директорию с
картинками в формате jpg (можно и в других форматах). Далее перед формой
происходит вывод самих картинок, которые находятся в определенной
директории. Около каждой картинки ставится чекбокс, отмечая который
выбирается нравящаяся картинка. Так-же предусмотрена проверка на заполнение
всех полей в форме. Есть один минус, такая программа полностью открывает
relay, но в принципе все аналогичные программы так и работают. Если сделать
постраничный вывод картинок из директории, то можно отправлять картинки из
галереи, содержащей 1000 фотографий или рисунков.
#!/usr/bin/perl -w
print "content-type:text/html\n\n";
use lib '/usr/local/etc/httpd/cgi-bin/photo/MIME-Lite-2.117/lib';
use Mime::Lite;
use CGI 'param';
$dir="/usr/local/etc/httpd/htdocs/otkritki";
$url="http://www.server.ru/otkritki";
$emls = param('emls');
$cont = param('cont');
$email = param('email');
$name = param('name');
$subject = param('subject');
$body = param('body');
$img = param('img');
$pic=$dir."/".$img;
open F, "<begin"; @mass1=<F>; close F;
open F, "<end"; @mass2=<F>; close F;
print @mass1;
if($cont eq 'mail'){
if($email ne '' &&
$img ne '' &&
$emls ne '' &&
$name ne '' &&
$subject ne '' &&
$body ne ''){
&sent();
}
unless($email ne '' &&
$img ne '' &&
$emls ne '' &&
$name ne '' &&
$subject ne '' &&
$body ne ''){
print qq~<p><center><b>Не заполнено одно из полей формы,
либо не выбрана картинка!!</b></center>~;
&form()
}
}
else{&form()}
sub sent{
$msg = MIME::Lite->new(
From =>qq{"$name" <$email>},
To =>$emls,
Subject =>$subject,
Type =>'multipart/mixed'
);
$msg->attach(Type =>'text',
Data => qq{$body}
);
$msg->attach(Type =>'image/jpeg',
Path =>$pic,
Filename=>'new_year.jpg',
);
$msg->attach(Type =>'text',
Data => qq{ Vasha otkritka! }
);
$msg->send;
print qq{<center><b>Ваше сообщение отправлено!</b></center>};
&form();
}
sub form{
print "<form action=http://www.server.ru/cgi/photo/letter.pl method=post>\n";
&vibor();
print "<a name=up></a>";
print qq~<center><b>Выберите фотографию из списка и отправьте
<a href=#post>открытку</a></b></center>
<table CELLSPACING=10 CELLPADDING=10>\n~;
foreach $file(@files){ $i++;
my $big=$file;
$big=~s!mini_!!g;
print qq~<td><a href=$url/$big target=_new><img
src=$url/$file border=0></a></td><td
valign=bottom><input type=radio name=img
value=$big></td></tr>\n~ if $i%2 == 0;
print qq~<tr><td><a href=$url/$big target=_new><img
src=$url/$file border=0></a></td><td
valign=bottom><input type=radio name=img value=$big
></td>\n~ if $i%2 != 0;
}
print qq~</table><a
name=post></a><b><center><a
href=#up>наверх</a></center></b><br>
<BR><b>Введите адрес получателя:</b><br>
<input type=text name=emls size=46 value=$emls><BR>
<b>Введите Ваш адрес:</b>
<br>
<input type=text name=email size=46 value=$email><br>
<B>Ваше имя: </B><BR>
<input type=text name=name size=46 value=$name><br>
<B>Заголовок письма:</B><BR>
<input type=text name=subject size=46 value=$subject><br>
<B>Текст письма:</B><BR>
<textarea name=body rows=8 cols=50>$body</textarea><br>
<input type=submit value="Отправить!">
<input type=hidden name=cont value=mail>
<input type=reset value="очистить.">
</form>
~;
}
sub vibor{
opendir(DIR,$dir) or (warn "Cannot open $dir: $!" and next);
rewinddir(DIR);
@files=grep {!(/^\./) && /mini_/io && -f "$dir/$_"} readdir(DIR);
closedir (DIR);
return @files;
}
print @mass2;
Пример работы этого скрипта смотрите здесь.
do{
my $msg = MIME::Lite->new(
From =>qq{"Young scientist"},
To =>$email,
Subject =>qq{"Ваши данные"},
Type =>'multipart/mixed'
);
$msg->attach(Type =>'text',
Data => qq{"$data"}
);
$msg->attach(Type => 'image/jpeg',
Path => '/usr/local/photo/head.jpg',
Filename =>'head.jpg'
);
$msg->attach(Type => 'application/x-msexcel',
Path => "$dir/users/$login/mydata.xls",
Filename =>'mydata.xls'
);
$msg->send;
print qq{<center><b>На Ваш адрес отправлено сообщение с Вашими данными!</b></center>};
} if grep{/^$login\t(.*)\t(.*?)\n/} @tmp;
Содание маленьких картинок для галереи.
gunzip -c PerlMagick-5.39.tar.gz | tar -xvf -
затем устанавливаем его
cd PerlMagick
perl Makefile.PL
make
make test
make install
И пишем следующий скрипт:
#!/usr/bin/perl -w
use lib '/usr/local/etc/httpd/bin/devel/IS';
use Image::Size;
use Image::Magick;
my $tumb="/usr/local/etc/httpd/images";
my $dir="/usr/local/etc/httpd/devel/pics";
my $vis=60; #высота картинки
while(<$tumb/*.*>){
$_="aaa.gif" unless /\.(gif|jpg|jpeg|png)/i;
$uu=$_;
$uu=~s!.*/!!;
print "$uu\t=>\tmini_$uu\n";
my($image, $x);
$image = Image::Magick->new;
my ($w, $h) = imgsize($_);
my $t=int($w/($h/$vis)) if $h/$vis != 0;
$x = $image->Read($_);
warn "$x" if "$x";
$x = $image->Resize(geometry=>'100x100"+1"00"+1"00', width=>$t, height=>$vis);
warn "$x" if "$x";
$_=~s!.*/!!;
$x = $image->Write("$dir/mini_$_");
warn "$x" if "$x";
}
Чтение файлов в формате *.doc для Word 6 и Word
7(doc2txt or doc2html).
Startup
OLE-Storage
#!/usr/bin/perl
print qx[lhalw --to_stdout Label.doc]
А можно и просто из командной строки
[root@www OLE-Storage-0.386]# lhalw --to_stdout Label.doc
Кому: "ФАМИЛИЯ" "ИМЯ" "ОТЧЕСТВО"
------------------------------ ОБРАТНЫЙ АДРЕС ------------------------------
WWW.RBC.RU, отдел "Новости экономики".
[root@www OLE-Storage-0.386]#
А вообще, старайтесь сохранять файлы в формате *.rtf, ибо Microsoft Office
страдает поддержкой форматов
Извлечение и запись информации в *.mp3
Считать информацию, хранящуюся в *.mp3
файле, можно при помощи модуля
MP3::Info.
Нехитрая програмка, вытаскивающая данные о той или иной записи:
#!/usr/bin/perl
my $file="/root/test.mp3";
use MP3::Info;
my $tag = get_mp3tag($file);
my $info = get_mp3info($file);
print "$_\t=>\t$info->{$_}\n" for sort keys %$info;
print "$_\t=>\t$tag->{$_}\n" for sort keys %$tag
Программа выдаст примерно следующее:
[root@www MP3-Info-1.00]# ./u.pl
BITRATE => 160
COPYRIGHT => 0
FRAMES => 93498
FRAME_LENGTH => 49
FREQUENCY => 44.1
LAYER => 3
MM => 3
MODE => 0
MS => 72.0499999999902
PADDING => 0
SECS => 229.07205
SIZE => 4581441
SS => 49
STEREO => 1
TIME => 03:49
VBR => 0
VERSION => 1
ALBUM => Ist der Ruf erst ruiniert...
ARTIST => Tic Tac Toe
COMMENT => http://www.delit.net
GENRE => Rock
TITLE => Lдstern
TRACKNUM => 32
YEAR => 2000
[root@www MP3-Info-1.00]#
Обращаться к хешам, которые возвращаются функциями, можно как и при работе с
perl -e 'print "$k\t=>\t$v\n"
while(($k, $v)=each %ENV)'
use Tie::IxHash;
tie(%myhash, Tie::IxHash);
for ($i=0; $i<20; $i++) {
$myhash{$i} = 2*$i;
}
@keys = keys %myhash;
# @keys = (0,1,2,3,...)
from Daily Perl FAQ
Использование Spreadsheet::WriteExcel
Задача, есть результаты школьных олимпиад. Нужно разослать результаты по
школам. Исходные данные
лежат в файле в виде:
2#МОК#Федяков#Андрей#9#М#ГОР#ВОРОНЕЖ#УЛ ШЕНДРИКОВА 7#394086#0732 317825#0#0#0#0#0#0#0#0#0#0#0#0
2#МОК#Амшеникова#Наталия#8#М##ВОРОНЕЖ#УЛ ШЕНДРИКОВА 7#394086#0732 317821#0#0#0#2#0#3#5#0#3#5#0#18
2#УЧЕБНО ВОСПИТАТЕЛЬНЫЙ КОМПЛЕКС#Протасов#Виталий#8#М#ГОР#ВОРОНЕЖ#УЛ ГЕРОЕВ СИБИРЯКОВ 5#394051#80732 335836#7#0#7#0#7#0#2#0#7#7#0#37
1#МУНИЦИПАЛЬНЫЙ ЛИЦЕЙ#Головин#Алексей#8#М#ГОР#ВОРОНЕЖ#УЛ ЛИЗЮКОВА 81#394088#0732 137587#7#7#7#7#7#6#7#7#7#7#0#69
0#ЯЗ ГИМНАЗИЯ ИМ А В КОЛЬЦОВА#Корж#Дмитрий#11#Б##ВОРОНЕЖ# ВОЛОДАРСКОГО 41#394000#0732 552759#3#8#6#8#7#4#6#0#0#0#0#42
0#ЯЗ ГИМНАЗИЯ ИМ А В КОЛЬЦОВА#Ладная#Екатерина#11#Б##ВОРОНЕЖ# ВОЛОДАРСКОГО 41#394000#0732 552759#4#5#4#7#6#3#3#0#0#0#0#32
0#ЯЗ ГИМНАЗИЯ ИМ А В КОЛЬЦОВА#Кузнецова#Наталья#11#Б##ВОРОНЕЖ# ВОЛОДАРСКОГО 41#394000#0732 552759#4#5#4#6#6#4#3#0#0#0#0#32
0#ЯЗ ГИМНАЗИЯ ИМ А В КОЛЬЦОВА#Де-Жорж#Инна#11#Б##ВОРОНЕЖ# ВОЛОДАРСКОГО 41#394000#0732 552759#4#5#4#6#6#4#3#0#0#0#0#32
0#ЯЗ ГИМНАЗИЯ ИМ А В КОЛЬЦОВА#Загонова#Виктория#11#Б##ВОРОНЕЖ# ВОЛОДАРСКОГО 41#394000#0732 552759#4#5#4#8#5#1#3#0#0#0#0#30
0#ГИМНАЗИЯ ИМ А В КОЛЬЦОВА#Гудков#Илья#11#Б#ГОР#ВОРОНЕЖ#УЛ ВОЛОДАРСКОГО 41#394000#0732 552759#4#4#4#6#3#2#3#0#0#0#0#26
2#МОК#Вдовина#Вера#11#Б##ВОРОНЕЖ#УЛ ШЕНДРИКОВА 7#394086#80732 317825#2#6#5#5#2#2#2#0#0#0#0#24
72#ШКОЛА#Холявка#Марина#11#Б##ВОРОНЕЖ# ЮЖНОМОРАВСКАЯ 18#394062#0732 331084#5#6#8#7#9#6#9#0#0#0#0#50
4#СРЕДНЯЯ ШКОЛА#Лукина#Дарья#11#Б#ГОР#ВОРОНЕЖ#БУЛЬВАР ПИОНЕРОВ 14#394038#0732 336762#3#6#6#2#3#3#2#0#0#0#0#25
4#СРЕДНЯЯ ШКОЛА#Кварацхелия#Кристина#11#Б#ГОР#ВОРОНЕЖ#БУЛЬВАР ПИОНЕРОВ 14#394038#0732 336730#3#5#6#3#3#3#0#0#0#0#0#23
...
и т.д.
Сначала это, правда, был файл *.dbf, но его при помощи программы
#!/usr/bin/perl
qx[dbfdump --fs="\x18" --rs="\x19" olimp.dbf >one.txt];
сделали текстовым, потом perl -i -n -p -e 's!\x18!#!;
s!\x19!\n!;' one.txt получили исходный.
Нужно сделать рассылку по школам, т.е. отсортировать по городам, по
названиям школ
и в каждую поместить по пользователю. Выходные данные должны быть в формате
excel,
т.к. для каждого конверта нужны полный адрес школы и список результатов
каждого учащегося.
Причем, excel позволяет отдавать на печать файлы
постранично, т.е. для каждой школы отдельная
страничка и потом удобно все это раскладывать по конвертам, т.е. нужно в
файле excel поставить
разрывы страниц. Данную задачу реализует следующий скрипт:
#!/usr/bin/perl
use Spreadsheet::WriteExcel;
open F, "<one.txt"; @mass=<F>; close F;
@res1=grep{s!^(.*?#.*?#)(.*?#.*?#.*?#.*?#)(.*?#.*?#)!$3$1$2!} @mass;
@res = grep{!$_{$_}++}
map{/^(.*?#.*?#).*?#.*?#/} @res1;
for $gr(@res){
for $line(@res1){push @{$hash{$gr}{$1}}, $2
if $line=~m!$gr(.*?#.*?#)(.*)$!}
}
my $workbook = Spreadsheet::WriteExcel->new("olimp2.xls");
my $sheet = $workbook->addworksheet("all children");
my $format = $workbook->addformat();
$format ->set_text_wrap();
$format->set_bold();
$format->set_size(11);
$format->set_color('blue');
$format->set_align('center');
$sheet->set_column(1, 3, 70);
$sheet->set_row(0,30);
$sheet->activate();
print "end build hash\n";
print "write file...\n";
for $a(sort keys %hash){
$m=$a; $m=~s!#! !ig;
for $key(sort keys %{$hash{$a}}){
$pb++;
$u=$key; $u=~s!#! !ig; $i++;
my $from = join " " => @{[split /#/ => ${$hash{$a}{$key}}[0]]}[4..6];
$sheet->write($i, 0, "$m $u $from", $format) if $pb >= 2000;
for my $test(sort @{$hash{$a}{$key}}){ $i++; $h++;
my $name = join " " => @{[split /#/ => $test]}[0 .. 3];
my $nums = join " " => @{[split /#/ => $test]}[7 .. 18];
$sheet->write($i, 0, "$name $nums") if $pb >= 2000;
}
print "$pb\n" if $pb % 1000 == 0;
$sheet->set_h_pagebreaks($i+1) if $pb >= 2000;
}
}
print "$m $u $from\n";
print "$h - done\n";
Разберем его работу. Скрипт использует хеши хешей массивов. Строчка
@res1=grep{s!^(.*?#.*?#)(.*?#.*?#.*?#.*?#)(.*?#.*?#)!$3$1$2!}
@mass;
заполняет массив будущими ключи хеша по названию города и улицы, т.к. в
городе Саратов
вполне может встретится воронежская или ленинградская улица, что смешает
результаты.
Строчка @res = grep{!$_{$_}++} map{/^(.*?#.*?#).*?#.*?#/}
@res1; убирает
повторяющиеся элементы для вложенного хеша, т.е. выделяет названия адресов
школ.
Цикл
for $gr(@res){
for $line(@res1){push @{$hash{$gr}{$1}}, $2
if $line=~m!$gr(.*?#.*?#)(.*)$!}
}
заполняет хеш хешей массивов. Далее требуется чтение man
Spreadsheet::WriteExcel
и начинаем вывод их хеша и запись файла excel.
Строчка
my $from = join " " => @{[split /#/ =>
${$hash{$a}{$key}}[0]]}[4..6];
расшифровывается как взять нулевой элемент массива ${$hash{$a}{$key}}, потом
разрезать его по строчкам в массив по разделителю #: [split /#/ => ${$hash{$a}{$key}}[0]].
Далее взять от массива срез, превратить его в строку, которая будет являться
адресом. Одно "но", excel
не позволяет ставить более 1000 pagebreaks для
каждого открытого файла, и поэтому приходится
придумывать различные условия, вроде постраничного вывода. Т.к. надо было
сделать быстро, то дабы не писать постраничный вывод обошелся условием
if $pb >= 1000 ... etc....
Mason - онлайновый парсер статических файлов на perl
<HTML>
<HEAD>
<TITLE>Yo! Wazzup!!!!
% my $noun = 'World';
% my $date = qx[date];
Hello <% $noun %>!
Today is <% $date %>
% my $ua = $r->header_in('User-Agent');
% if ($ua =~ /msie/i) {
Welcome, Internet Explorer users
...
% } elsif ($ua =~ /mozilla/i) {
Welcome, Netscape users
...
% }
</TITLE></HEAD>
<BODY BGCOLOR="#FFFFFF">
<H1>Yo! Wazzup!!!!</H1>
<& index.file &>
</BODY>
</HTML>
строчка, в которой содержится сам код, должна начинаться с символа %:% my $noun = 'World';
Если не хочется кадый раз ставить символ процента, то код можно поставить в
между тегами
<%perl>
... to do...
</%perl>
Аналогично директивам SSI из html странички можно вызывать и файлы(в том
числе и текстовые, например если создается библиотека).
<& index.html &>
Можно так-же делать включения скриптов вида
%# <& /include/all_newsheads.msn &>
Хотя так-же спокойно можно включать скрипты командой qx[lalalala]
<html>
<head><title><% $headline %></title></head>
<body>
<h2><% $headline %></h2>
By <% $author %>, <% $date %><p>
<% $body %>
</body></html>
<%init>
# Fetch article from database
my $dbh = DBI::connect ...;
my $sth = $dbh->prepare("select * from articles where id = ?");
$sth->execute($article_id);
my ($headline,$date,$author,$body) = $sth->fetchrow_array;
# Massage the fields
$headline = uc($headline);
my ($year,$month,$day) = split('-',$date);
$date = "$month/$day";
</%init>
<%args>
$article_id
</%args>
Фактически блок <%init> эквивалентен блоку
<%perl>. При таком введении наиболее читаемые
компоненты (особенно для непрограммистов) содержат HTML в одном непрерывном блоке наверху, с простыми
заменами для динамических элементов, и никаких отвлекающих и запутывающих
блоков кода на perl.
Программа, позволяющая скачивать и сохранять файлы с удаленного сервера
#!/usr/bin/perl
use strict;
use LWP::Simple;
my $url="http://www.server.ru/mp3/";
my $dir="/path/to/your/mp3/dir";
grep {getfile("$url$1.mp3")
if m!<A HREF="(.*?)\.mp3">!i}
split /\n/ => get $url;
sub getfile{
print "$_[0]\t=\tbegin...\n";
print @{[head $_[0]]}[1],"\n";
my $res = LWP::UserAgent->new->request(new HTTP::Request GET=> $_[0]);
$_[0]=~s!.*/!!;
if ($res->is_success) {
open (ABC, ">$dir/$_[0]") or die "Can't create $dir/$_[0]: $!";
binmode(ABC);
print ABC $res->content; close ABC or die $!;
} else {
print $res->status_line;
}
return 1;
}
конструкция
grep {getfile("$url$1.mp3")
if m!<A HREF="(.*?)\.mp3">!i}
split /\n/ => get $url;
берет листинг директории(например без индексного файла) get $url, сплитит его по
переводу каретки, возвращает массив, который в цикле перебирается и если
есть линк
на *.mp3, то подпрограмме передается адрес файла $url$1.mp3.
В строке print @{[head $_[0]]}[1],"\n"; берется
head, возвращающий массив и из
него вытаскивается второй элемент, который является размером файла и затем
pop before smtp для popa3d(другие демоны pop-аутентификации можно дописать,
о чем здесь ниже)
#!/usr/bin/perl -wT
use strict;
use File::Tail;
use Fcntl ':flock';
use Date::Parse;
my $l = '/var/log/messages'; #путь до логфайла
my $file="/etc/mail/access"; #путь до файла с relay'ями на ip
my (@q, $fi, $ip);
my $relay = 60;#время открытого релея после popa3d-аутентификации для ip, снявшего почту
&tail();
while (1){
m&^(.*\d+:\d+:\d+).*\[(.*?)\]$& if $_=$fi->read; #get ip and name
my $time = str2time($1) + $relay or next; $ip=$2; #таймер
next if $time < time;
open A, ">>$file" or die "can't open: $!"; flock A, 2;
print "\tВремя для $ip пошло(всего $relay секунд), relay открыт\n";
print A "$2\t\tRELAY\n";
close A; &makemap(); #закрываем и делаем ребилд для /etc/mail/access.db
push @q, $time;
while(1){
do{ my @file;
open B, "<$file" or die "can't open: $!"; flock B, 1;
do{ push @file, $_ unless m%^$ip%} while (<B>); #не нужны ip, у которых кончилось время
close B;
print "\tВремя для $ip закончилось, relay закрыт\n";
open C, ">$file" or die "can't open: $!";
flock C, 1;
print C join "" => grep{!m&^$ip(\t)\1+RELAY$&} @file;
close C; &proverka();
&makemap(); #закрываем и делаем ребилд для /etc/mail/access.db
last
} if $q[0] < time; sleep 1
} $#q=-1;
}
sub makemap{qx[makemap hash /etc/mail/access</etc/mail/access]}
sub tail{
return $fi = File::Tail->new(
name => $l,
maxinterval => 1,
adjustafter => 1000000000,
interval => 4,
tail => 0)
}
sub proverka{
open D, "<$file" or die "can't open: $!"; flock D, 1;
my @debug=<D>; close D;
open E, ">$file" or die "can't open: $!"; flock E, 1;
print E join "" => grep{!m/Authentication passed/} @debug;
close E;
}
Вобщем берется модуль File::Tail со спана и натравливается на логфайл. Соответственно
по нему читаются маны и т.д. В чем прелесть, можно написать shell-script(взял из
init-redhat-alex из pop before smtp
для почтовика Postfix) и сделать приведенный скрипт демоном, который по добавлению в логфайл открывает на 30 секунд RELAY для того,
кто перед этим снял почту, используя стандартные методы аутентификацииPOP3. можно релей открывать на 15 секунд... но, вобщем, вроде-бы защиту от спамеров оно гарантирует. Ниже методы проверки адреса на relay.
Ну а на сервере, через который происходит отправка почты, выглядит это примерно так(результат отправки почты при помощи
написанных на perl pop и smtp клиентов, см. ниже):
[root@tv pop-before-smtp-1.28]# /root/pop-before-smtp-1.28/contrib/init-redhat-alex start
Запуск pop-before-smtp: [ OK ]
[root@tv pop-before-smtp-1.28]#
Время для 194.218.214.122 пошло(всего 60 секунд), relay открыт
Время для 194.218.214.122 закончилось, relay закрыт.
Можно сделать так, чтобы эти сообщения писались в то-же /var/log/message. Программа очень нехитрая, написана на несложном языке, соответственно модификации для остальных видов демонов приветствуются.
# check client name: first: did it resolve?
R$* $: < $&{client_resolve} >
R<TEMP> $#error $@ 4.7.1 $: "450 Relaying temporarily denied. Cannot resolve PTR record for " $&{client_addr}
R<FORGED> $#error $@ 5.7.1 $: "550 Relaying denied. IP name possibly forged " $&{client_name}
R<FAIL> $#error $@ 5.7.1 $: "550 Relaying denied. IP name lookup failed, please, get your mail for check relay" $&{client_name}
R$* $: <?> $&{client_name}
Теперь пытаемся отправить почту из Нью-Йорка например через www.online.ru
и получаем ответ(исходник smtp.pl см. ниже):
[root@www devel]# ./smtp.pl
SMTP RCPT command failed:
5.7.1 <user@last.my.server.ru>... Relaying denied. IP name lookup
failed, please, get your mail for check relay[194.218.214.122]
at ./smtp.pl line 18
[root@www devel]#
[root@tv /root]# telnet tv 25
Trying 212.142.230.135...
Connected to tv.server.ru (212.142.230.135).
Escape character is '^]'.
220 tv.server.ru ESMTP Sendmail 8.11.2/8.11.2; Sun, 24 Mar 2002 02:10:00 +0300
mail from:<test@tv.server.ru>
250 2.1.0 <test@tv.server.ru>... Sender ok
rcpt to:<user@last.my.server.ru>
250 2.1.5 <user@last.my.server.ru>... Recipient ok
data
354 Enter mail, end with "." on a line by itself
dfg
.
250 2.0.0 g2NNANt15274 Message accepted for delivery
Pop-3 клиент на perl:
#!/usr/bin/perl
use Net::POP3;
$p=Net::POP3->new("tv.server.ru")
or die "cant open connection to server: $!\n";
$p->login("test","rusalka") or die "Cant authentificate: $!\n";
$m=$p->list or die "cant get list of undeleted mesg: $!\n";
foreach $list(keys %$m){
$msg=$p -> get($list);
print "@$msg\n";
}
И smtp клиент:
#!/usr/bin/perl
$to = 'user@last.my.server.ru';
$from = 'test@tv.server.ru';
use MIME::Lite;
$msg = MIME::Lite->new(
To =>$to,
From =>$from,
Subject =>'Helloooooo, nurse!',
Type =>'multipart/mixed'
);
$msg->attach(Type =>'text',
Data => qq{test}
);
MIME::Lite->send('smtp', "tv.server.ru", Timeout=>60);
$msg->send;
Вобщем все, но лучше бы протестировать открывающий релей скрипт, потому, что мог допустить какую-то ошибку.
Использование регулярных выражений в apache
ScriptAliasMatch ^/~(.*)/ex/(.*) "/home/$1/public_html/cgi-bin/$2"
Работа со списками
.3
.3.1
.3.1.1
.2
.2.1
.2.1.1
.2.1.1.1
.1
#!/usr/bin/perl -w
$_=qq~.3
.3.1
.3.1.1
.2
.2.1
.2.1.1
.2.1.1.1
.1
~;
print ".", join "." => split m!! =>
@{[reverse sort {$a <=> $b} grep{s!\.!!g} split m%\n%]}[0];
print "\n";
1
2
21
211
2111
3
31
311
perl -lne 'if (/(\d+)/ && ($1 > $num || ($1 == $num && length($_) >
length($res)))) { $num = $1; $res = $_ }; END { print $res }' test.dat
Backup прав доступа на файлы и директории[only for unix like
systems]
Программа, восстанавливающая пермишны на файлы например в случае
непреднамеренного использования команды chmod -R 777
*.* из корневой директории(или в аналогичных ситуациях). В
комментариях разъяснена работа программы:
#!/usr/bin/perl -w
use strict;
use File::Find;
my ($test, $dir, $db, $pwd, $tmp);
$db="/home/user/cgi/xxx.dat";
###################
#program section #
###################
&exc(); #read exceptions
unlink $db if !-z $db and $ARGV[0] eq 'r';
#стираем файл старой базы при команде r в случае если он ненулевого размера
find \&read => "$dir" if $ARGV[0] eq 'r';
#начать сканировать поддиректории если с командной строки пришло r
rewrite() if $ARGV[0] eq 'w';
#начать восстанавливать права на файлы, если с командной строки пришло w
##################
#subroutines #
##################
sub read {#чтение прав
$test=sprintf "%04o" => (stat($File::Find::name))[2] & 07777;
#получить права на файл ли директорию
&readchmod("$File::Find::name\t$test\n");
#вызов подпрограммы для записи базы
}
sub readchmod{#запись прав
open F, ">>$db" or die "Can't open $db: $!";
print F $_[0];
print "$_[0]"; #смотрим, что записывается
close F;
}
sub rewrite{#перезапись прав
open F, "<$db" or die "Can't open $db: $!";
while(
Если нашли a lot of bugs - пишите.
Как найти уникальные ключи в двух хешах?
%seen = ();
for $element (keys(%foo), keys(%bar)) {
$seen{$element}++;
}
@uniq = keys %seen;
или так:
@uniq = keys %{{%foo,%bar}};
если необходимо использовать минимальный размер памяти:
%seen = ();
while (defined ($key = each %foo)) {
$seen{$key}++;
}
while (defined ($key = each %bar)) {
$seen{$key}++;
}
@uniq = keys %seen;
для того, чтобы выбрать повторения из массива можно воспользоваться строчкой:
@uniq=grep{!$hash{$_}++} @mass;
для того, чтобы убрать строки в массиве, содержащие какие-то произвольные одинаковые данные, можно немного модифицировать приведенную строчку:
@uniq=grep{!$hash{$1}++ if m&$name\001($value)\001$other\n&} @mass;
РПЙУЛ РП УФЕРЕОЙ УПЧРБДЕОЙК УМПЧ Ч РТЕДМПЦЕОЙСИ
#!/usr/bin/perl -w
use locale;
%oo=("ВХДЕФ"=>1, "БЖТЙЛБ"=>1, "ЪБЧФТБ"=>1);
$b="БЖТЙЛБ БЖТЙЛБ ВХДЕФ БЖТЙЛБ ЪБЧФТБ";
$o="БЖТЙЛБ ВХДЕФ ЧЮЕТБ ЪБЮЕН ЮФП-ФП";
$tw="БЖТЙЛБ ОЕВХДЕФ ЧЮЕТБ ВХДЕФ ЪБЧФТБ";
$tb="БМСУЛБ БМСУЛБ ВХДЕФ ВХДЕФ ВХДЕФ УЕЗПДОС";
@m=($b, $o, $tb, $tw); rrand(\@m);
print join "\n", @m,"\n";
for $i(0 .. $#m){
$h{$i}{$1}++ while $m[$i]=~m!((\w[\w-]*){4,30})!g;
$vr{$i}=$m[$i];
}
for $r(keys %h){print "\n";
my (@ee, $u, $trr);
for $n(keys %{$h{$r}}){
do{
$t = join " " => $vr{$r};
$u+=1;
push @ee => $h{$r}{$n};
} if exists $oo{$n};
}
print "$t ",$u + $ee[0]-1,"\n";
}
sub rrand{
my $m = shift; my $i;
for($i=@$m; --$i;){
my $j = int rand($i+1);
net if $i==$j;
@$m[$i,$j] = @$m[$j,$i]
}
}
$b = "БЖТЙЛБ БЖТЙЛБ ВХДЕФ БЖТЙЛБ ЪБЧФТБ";
$h{1}=(
"БЖТЙЛБ" => 3,
"ВХДЕФ" => 1,
"ЪБЧФТБ" => 1
);
for $r(keys %h){print "\n";
my (@ee, $u, $trr);
for $n(keys %{$h{$r}}){
do{
$t = join " " => $vr{$r};
$u++;
push @ee => $h{$r}{$n};
} if exists $oo{$n};
}
print "$t ",$u + $ee[0]-1,"\n";
}
push @ee => $h{$r}{$n};
Заполнение и отправка данных из скрипта формы на удаленном сервере
<form action="http://www.server.ru/cgi-bin/gbook.pl" method=post>
<input type=text name=name size=20><br>
<input type=text name=descr size=20><br>
<input type=submit value="Submit"><br>
<input type=reset value="clear">
</form>
нужно написать следующий скрипт(соответствующие значения полей name и descr
указаны в квадратных скобках):
#!/usr/bin/perl -w
use HTTP::Request::Common qw(POST);
use LWP::UserAgent;
$ua = LWP::UserAgent->new();
my $req = POST 'http://www.server.su/cgi-bin/gbook.pl',
[ name => 'lalala',
descr => 'aaa'];
print $content = $ua->request($req)->as_string;
Если в форме полей больше, чем в приведенном примере, то их нужно просто перечислить в квадратных
скобочках через запятую, причем после поледнего поля запятую ставить не
нужно:
my $req = POST 'http://www.server.su/cgi-bin/gbook.pl',
[ name => 'lalala',
email => 'user\@host.ru',
text => qx{
bla-bla-bla
alalalalal hahahaha test
s privetom,
Vasya
}
descr => 'aaa'];
Если необходимо подгрузить помимо текста еще и картинку(картинки), то нужно указать
Content_Type => 'form-data':
#!/usr/bin/perl -w
$test = "http://www.server.ru/add.html";
$file = "test.gif";
use HTTP::Request::Common qw(POST);
use LWP::UserAgent;
use CGI qw(header -no_debug);
my $req = POST $test,
Content_Type => 'form-data',
Content => [
user => 'vasya',
password => '123456',
image => [$file],
href => 'aaaaaaaaaaaa',
profile => '13',
ratio => '333333',
alt => 'Hot News!',
];
my $res = LWP::UserAgent->new->request($req);
print header, $res->is_success ? $res->content : $res->status_line;
print $req->as_string;
если необходимо подгружать одновременно несколько картинок(любое число), без текста, то
это описано тут
или слегка модифицировав POST-запрос:
my $req = POST $test,
Content_Type => 'form-data',
Content => [
user => 'vasya',
password => '123456',
image1 => [$file1],
image2 => [$file2],
image3 => [$file3],
image4 => [$file4],
href => 'aaaaaaaaaaaa',
profile => '13',
ratio => '333333',
alt => 'Hot News!',
];
Вобщем такими методами можно отправлять картинки и/или сообщения через интернет
на различные доски объявлений и подобные типы сервисов
без участия человека. Так-же неплохо бы
найти и прочитать в интернете последнюю версию
LWP FAQ by fido7.ru.cgi.perl by Paul Kulchenko (paulclinger@yahoo.com)
Выводим даты при помощи модуля Calendar::Simple
#!/usr/bin/perl -w
use strict;
use Calendar::Simple;
my @months = qw(January February March April May June July August
September October November December);
my $mon = shift || (localtime)[4] + 1;
my $yr = shift || ((localtime)[5] + 1900);
my @month = calendar($mon, $yr);
print "\n$months[$mon -1] $yr\n\n";
print "Su Mo Tu We Th Fr Sa\n";
foreach (@month) {
print map { $_ ? sprintf "%2d ", $_ : ' ' } @$_;
print "\n";
}
на выводе имеем:
** Joe's Own Editor v2.8 ** Copyright (C) 1995 Joseph H. Allen **
File /root/raznoe/Calendar-Simple-1.06/aa.pl not changed so no update needed.
[root@www /root]# /root/raznoe/Calendar-Simple-1.06/aa.pl
August 2002
Su Mo Tu We Th Fr Sa
1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30 31
[root@www /root]#
Работа с двоичными числами
> нужное число я вычисляю, то как его потом записать как шестнад. число?
$x_dec = 10; # Переменная $x_dec содержит число "десять"
$x_10 = "10"; # Переменная $x_10 содержит строку с десятичным
# представлением числа "десять"
В данном случае эти переменные практически идентичны. Т.е.
print $x_dec;
print $x_10;
$y = $x_dec + 1;
$z = $x_10 + 1;
$a_hex = sprintf('%X', 10); # Число в строку с его шестнадцатеричным
# представлением
$a_hex = sprintf('%X', "10"); # строку с десятичным представлением можно
# точно так же преобразовать в строку с
# десятичным...
$a = 0xA; # Шестнадцатеричные представления чисел можно
# использовать в константах. В $a будет
# число "десять"
$a = hex("A"); # Строку с шестнадцатеричным
# представлением числа - в число
$x = "7F";
$code = hex($x);
print FILE ord($code);
print FILE ord($x);
Ежедневные обновления CPAN
Использование квантовой логики в программировании
$die = entangle( 1=>1, 1=>2, 1=>3, 1=>4, 1=>5, 1=>6);
создает суперпозицию состояний 1 .. 6. В дальнейшем $die является равновероятным для каждого состояния до тех пор, пока мы не попытаемся определить, какое-же из этих состояний содержит переменная $die.
#!/usr/bin/perl -w
use strict;
use Quantum::Entanglement qw(:DEFAULT);
my $foo = entangle(1=>2,1=>3,1=>5,1=>7);
# |2> +|3> + |5> +|7>
print '$foo is greater than four' if ($foo > 4);
данная программа равновероятно(с увеличеним числа е╦ запусков до бесконечности конечно) проводит сравнения либо с |2> + |3> либо с |5> +7>:
[root@tv demo]# perl -c rr.pl
rr.pl syntax OK
[root@tv demo]# chmod 755 rr.pl
[root@tv demo]# ./rr.pl
$foo is greater than four[root@tv demo]# ./rr.pl
[root@tv demo]# ./rr.pl
[root@tv demo]# ./rr.pl
[root@tv demo]# ./rr.pl
$foo is greater than four[root@tv demo]# ./rr.pl
[root@tv demo]# ./rr.pl
$foo is greater than four[root@tv demo]# ./rr.pl
$foo is greater than four[root@tv demo]# ./rr.pl
$foo is greater than four[root@tv demo]# ./rr.pl
$foo is greater than four[root@tv demo]# ./rr.pl
[root@tv demo]# ./rr.pl
[root@tv demo]#
Если переменная $Quantum::Entanglement::conform имеет значение true: $Quantum::Entanglement::conform = 1; то предпочтительным будет вывод $foo is greater than four, т.е. более положительный ответ:
#!/usr/bin/perl -w
use strict;
use Quantum::Entanglement qw(:DEFAULT);
my $foo = entangle(1,2,1,3,1,5,1,7);
# |2> +|3> + |5> +|7>
$Quantum::Entanglement::conform = 1;
print '$foo is greater than four' if ($foo > 4);
File rr.pl saved
File rr.pl not changed so no update needed.
[root@tv demo]# ./rr.pl
$foo is greater than four[root@tv demo]# ./rr.pl
$foo is greater than four[root@tv demo]# ./rr.pl
$foo is greater than four[root@tv demo]# ./rr.pl
$foo is greater than four[root@tv demo]# ./rr.pl
$foo is greater than four[root@tv demo]# ./rr.pl
$foo is greater than four[root@tv demo]# ./rr.pl
$foo is greater than four[root@tv demo]#
#!/usr/bin/perl -w
use Quantum::Entanglement qw(:DEFAULT);
# зададим два массива независимых чисел
my @inputsA = (1,1,1,2,1,3,1,4,1,5,1,6,1,7,1,8,1,9,1,10);
my @inputsB = (1,1,1,2,1,3,1,4,1,5,1,6,1,7,1,8,1,9,1,10);
#слинкуем их, т.е. запутаем, сделаем зависимыми
my $inputsA = entangle( @inputsA );
my $inputsB = entangle( @inputsB );
# и теперь перемножим эти зависимые состояния чисел
my $answer = $inputsA * $inputsB;
# запомним основное исходное состояние, чтобы вызвать его снова, если потребуется
my $state = save_state($inputsA, $inputsB, $answer);
# выставим режим наибольшего благоприятствования, более положительный ответ
$Quantum::Entanglement::conform = 1;
print "введите два числа между 1 и 10 для перемножения\n";
while (<>) {
last unless /(\d+)[^\d]*(\d+)/;
1 if $inputsA == $1; # угу, действительно равно, но в пустом контексте
1 if $inputsB == $2;
print "\n$1 * $2 = $answer\n";
($inputsA, $inputsB, $answer) = $state->restore_state; # восстановим исходное состояние!
}
на выводе получим:
** Joe's Own Editor v2.9.5 ** Copyright (C) 2001 **
File calc_cache.pl not changed so no update needed.
[root@tv demo]# ./calc_cache.pl
введите два числа между 1 и 10 для перемножения
1 2
1 * 2 = 2
3 4
3 * 4 = 12
9 9
9 * 9 = 81
q
[root@tv demo]#
$result = any(1,2,3) * 2;
if ($result == 4) { print "fore!" }
if (any(2,4,6) == 4)...
if (all(2,4,6) == 4)...
if (all(1,2,3)*any(5,6) < 21)
{ print "no alcohol"; }
if (all(1,2,3)*any(5,6) < 18)
{ print "no entry"; }
if (any(1,2,3)*all(5,6) < 18)
{ print "under-age" }
$wanted = any("Mr","Ms").any(@names);
if ($name eq $wanted) { print "Reward!"; }
$okay = all(\&check1,\&check2);
die unless $okay->();
my $large =
all( BigNum->new($centillion),
BigNum->new($googol),
BigNum->new($SkewesNum)
);
@huge = grep {$_ > $large} @nums;
$ideal = any( all("tall", "rich", "handsome"),
all("rich", "old"),
all("smart","Australian","rich")
);
while (@features = get_description) {
if (any(@features) eq $ideal) {
print "True love";
}
}
`any(@ev) == $s' or `any(@ev) eq $s'
print "The factor was: ",
eigenstates($factor);
print "Don't use any of:",
eigenstates($badpasswds);
if (any(@newnums) < @all(oldnums)) {
print "New minimum detected";
}
all(7,8,9) <= any(5,6,7) #A
all(5,6,7) <= any(7,8,9) #B
any(6,7,8) <= all(7,8,9) #C
уступили бы:
all(0,0,1,0,0,0,0,0,0) #A (false)
all(1,1,1,1,1,1,1,1,1) #B (true)
any(1,1,1,1,1,1,0,1,1) #C (true)
под новой семантикой они уступили бы:
all(7) #A (false)
all(5,6,7) #B (true)
any(6,7) #C (true)
$newmins = any(@newnums) < all(@oldnums);
if ($newmins) {
print "New minima found:", eigenstates($newmins);
}
sub min {
eigenstates( any(@_) <= all(@_) )
}
sub max {
eigenstates( any(@_) >= all(@_) )
print "lexicographically first: ",
any(@words) le all(@words);
print "The smallest element is: ",
$array[any(@i)<=all(@i)];
$n1 = any(1,4,9);
$r1 = sqrt($n1);
$n2 = all(1,4,9);
$r2 = pow($n2,3);
$r3 = pow($n1,$r1);
sub incr { $_[0]+1 }
sub numeric { $_[0]+0 eq $_[0] }
use Quantum::Superpositions
UNARY => ["CORE::int", "main::incr"],
UNARY_LOGICAL => ["main::numeric"];
sub max { $_[0] < $_[1] ? $_[1] : $_[0] }
sub same { my $failed; $IG{__WARN__}=sub{$failed=1};
return $_[0] eq $_[1] || $_[0]==$_[1] && !$failed;
}
use Quantum::Superpositions
BINARY => ['main::max', 'CORE::index'],
BINARY_LOGICAL => ['main::same'];
sub is_prime {
my ($n) = @_;
return $n % all(2..sqrt($n)+1) != 0
}
sub has_twin {
my ($n) = @_;
return is_prime($n) && is_prime($n+any(+2,-2);
}
$v == any(@elems)
@intersection = eigenstates(all($s1, $s2));
@common = eigenstates( all( any(@list1),
any(@list2),
any(@list3),
any(@list4),
)
);
sub factors {
my ($n) = @_;
my $q = $n / any(2..$n-1);
return eigenstates(floor($q)==$q);
}
use Quantum::Superpositions BINARY => ["CORE::index"];
$found = index(any(@db), $target) >= 0;
sub contains_str {
if (index($dbstr, $target) >= 0) {
return $dbstr;
}
}
$found = contains_str(any(@db), $target);
@matches = eigenstates $found;
sub contains_targ {
if (index($dbstr, $target) >= 0) {
return $target;
}
}
$found = contains_targ($string, any(@targets));
@matches = eigenstates $found;
$found = contains_targ($string, all(@targets));
@matches = eigenstates $found;
~30 sekund for my server p100, 32 ram, red hat linux7.1, perl 5.0.6), пишем программу:
#!/usr/bin/perl -sw
use Quantum::Superpositions;
sub is_prime { return $_[0]==2 || $_[0] % all(2..sqrt($_[0])+1) != 0 }
do{print "$_ - простое число\n" if is_prime($_)} for map {2*$_+1} 1..1000;
на выводе имеем нечто вроде:
** Joe's Own Editor v2.9.5 ** Copyright (C) 2001 **
File demo_Primes.pl not changed so no update needed.
[root@tv demo]# ./demo_Primes.pl
3 - простое число
5 - простое число
7 - простое число
11 - простое число
13 - простое число
17 - простое число
19 - простое число
23 - простое число
29 - простое число
31 - простое число
37 - простое число
41 - простое число
43 - простое число
47 - простое число
53 - простое число
59 - простое число
61 - простое число
67 - простое число
71 - простое число
73 - простое число
79 - простое число
83 - простое число
89 - простое число
97 - простое число
101 - простое число
103 - простое число
107 - простое число
109 - простое число
[root@tv demo]#
Или нужно получить все сомножители какого-то числа:
#!/usr/bin/perl -w
use Quantum::Superpositions UNARY => ['CORE::int'];
sub factors {eigenstates (int($_[0] / any(2..$_[0]-1)) == ($_[0] / any(2..$_[0]-1)))}
print int($_), "\n factors: ", join(",", factors($_)), "\n" while (<>);
На выводе имеем:
[root@tv demo]# ./factors.pl
8
8
factors: 2,4
121
121
factors: 11
56
56
factors: 7,8,14,2,4,28
78
78
factors: 13,39,2,3,26,6
[root@tv demo]#
Алгоритм Эратосфена
$N = 1000000;
@L = (1) x $N;
$L[0] = 0; $L[1] = 0;
$start = 2;
$t0 = time;
while($start<$N) {
if($L[$start]==0) { $start++; next; }
for($i=$start*2;$i<$N;$i+=$start) { $L[$i] = 0; }
$start++;
}
print "time: ".(time-$t0)."\n";
for($i=0;$i<$N;$i++) {
print $i." " if($L[$i]==1);
}
Программа написана David A. Mzareulyan from http://www.scientific.ru
Регулярное выражение для выделения чисел в математической
записи
#!/usr/bin/perl
$_=qq~
1234
34 -4567
3456
-0.35e-0,2
56grf45
-.034 E20
-.034 e2,01 -,045 e-,23
-,034 e201 3e-.20
-,045 e-,23 e-0.88
4 E-0.20
22
E-21
-0.2 w 4 3
345
2 ^-,3
~;
$a='[+-]?\d*[,.]?\d+';print"$_\n"for/$a\s?[e^]$a|$a|[+-]?e$a/ig
Соответственно идея в том, чтобы сократить число символов
в строчке, заменяя их на содержимое переменной $a. цикл
for идет пока
выполняется регулярное выражение(т.к. оно возвращает список значений
$_ в силу
наличия квантификатора g), читающее переменную $_
Чтение и запись в com-порт
Возможножность писать в компорт сильно зависит(в программном смысле) от
того, под какой операционной системой запущена программа. Если это *nix,
то компорт доступен как файл в директории /dev(железные устройства в
unix-like системах подобны файлам, которые можно читать и производить в них
запись), в других системах имя устройства отличаются.
This depends on which operating system your program is running on.
In the case of Unix, the serial ports will be accessible through
files in /dev; on other systems, the devices names will doubtless
differ. Several problem areas common to all device interaction are
the following
lockfiles
Your system may use lockfiles to control multiple access. Make
sure you follow the correct protocol. Unpredictable behaviour
can result from multiple processes reading from one device.
open mode
If you expect to use both read and write operations on the
device, you'll have to open it for update (see the section on
"open" in the perlfunc manpage for details). You may wish to
open it without running the risk of blocking by using sysopen()
and RDWR|O_NDELAY|O_NOCTTY' from the Fcntl module (part of
the standard perl distribution). See the section on "sysopen"
in the perlfunc manpage for more on this approach.
end of line
Some devices will be expecting a "\r" at the end of each line
rather than a "\n". In some ports of perl, "\r" and "\n" are
different from their usual (Unix) ASCII values of "\012" and
"\015". You may have to give the numeric values you want
directly, using octal ("\015"), hex ("0x0D"), or as a control-
character specification ("\cM").
print DEV "atv1\012"; # wrong, for some devices
print DEV "atv1\015"; # right, for some devices
Even though with normal text files, a "\n" will do the trick,
there is still no unified scheme for terminating a line that is
portable between Unix, DOS/Win, and Macintosh, except to
terminate *ALL* line ends with "\015\012", and strip what you
don't need from the output. This applies especially to socket
I/O and autoflushing, discussed next.
flushing output
If you expect characters to get to your device when you print()
them, you'll want to autoflush that filehandle. You can use
select() and the $|' variable to control autoflushing (see the
section on "$|" in the perlvar manpage and the "select" entry
in the perlfunc manpage):
$oldh = select(DEV);
$| = 1;
select($oldh);
You'll also see code that does this without a temporary
variable, as in
select((select(DEV), $| = 1)[0]);
Or if you don't mind pulling in a few thousand lines of code
just because you're afraid of a little $| variable:
use IO::Handle;
DEV->autoflush(1);
As mentioned in the previous item, this still doesn't work when
using socket I/O between Unix and Macintosh. You'll need to
hardcode your line terminators, in that case.
non-blocking input
If you are doing a blocking read() or sysread(), you'll have to
arrange for an alarm handler to provide a timeout (see the
"alarm" entry in the perlfunc manpage). If you have a non-
blocking open, you'll likely have a non-blocking read, which
means you may have to use a 4-arg select() to determine whether
I/O is ready on that device (see the section on "select" in the
perlfunc manpage.
While trying to read from his caller-id box, the notorious Jamie
Zawinski
сайт, посвященный
программированию на perl.
Соединение типа точка-точка
устройство <-> описываемое здесь промежуточное клиент-серверное приложение <-> клиенты
#!/usr/bin/perl -w
use strict;
use IO::Socket;
use IO::Handle;
use Socket;
use Symbol;
use POSIX;
use Net::hostent;
# порт, на котором висит программа, управляющая устройством
my $port=6001;
# хост
my $host="127.0.0.1";
# число плодящихся серверов
my $PREFORK="1";
# число подключаемых клиентов
my $MAX_CLIENTS_PER_CHILD="1";
# хеш потомков
my %children=();
# численность порожденных потомков
my $children=0;
my $f="/.2/mnt/work/control.txt";
# начальное заполнение пула серверов
make_new_child() for(1 .. $PREFORK);
# обработчик сигнала CHLD, убивающиего потомка
$SIG{CHLD}=\&REAPER;
# обработчик события, убивающего всю программу(остановка сервера)
$SIG{INT}=\&HUNTSMAN;
# поддерживаем численность потомков
while(1){
sleep;
for(my $i=$children; $i<$PREFORK; $i++){
make_new_child()
}
}
sub make_new_child{
my($pid, $sigset, $kidpid, $server, $client);
$sigset=POSIX::SigSet->new(SIGINT);
sigprocmask(SIG_BLOCK, $sigset) or die "can't block SIGINT for fork: $!\n";
die "fork: $!" unless defined do{$pid = fork};
if($pid){
# базовый родительский процесс, содержимое этого условия никогда не
# будет видно из дочернего процесса
sigprocmask(SIG_UNBLOCK, $sigset)
or die "can't unblock SIGINT for fork: $!\n";
# заполняем хеш номерами дочерних процессов
$children{$pid}=1;
# увеличивам число процессов, обрабатывающих подключение
$children++;
return;
} else {
# порожденный дочерний процесс, содержимое этого процесса никогда не
# будет видно в базовом процессе
# переопределяем событие SIGINT чтобы избежять появления зомби
$SIG{INT} = 'DEFAULT';
$SIG{CHLD}='IGNORE';
sigprocmask(SIG_UNBLOCK, $sigset)
or die "can't unblock SIGINT for fork: $!\n";
# плодим клиентов, соединяющихся с
# исходной программой
for(my $i=0; $i<$MAX_CLIENTS_PER_CHILD; $i++){
sleep 2;
# открываем двусторонний сокет между процессами
# парент пишет в CHILD, который читается в порожденном процессе
# Дочерний процесс пишет в PARENT, который читается в родительском процессе
socketpair(CHILD, PARENT, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
or die "socketpair: $!";
# отключаем буверизацию у обоих
CHILD->autoflush(1);
PARENT->autoflush(1);
# соединяемся с исходной программой, в случае отказа
# в соединении(это значит что удаленная мониторинговая или иная
# программа не работает), дочерний процесс умирает,
# и скрипт заново порождает новый процесс в цикле while(1){ ... }
my $handle = IO::Socket::INET->new( Proto => 'tcp',
PeerAddr => $host,
PeerPort => $port)
or die "can't connect to port $port on $host: $!";
print STDERR "[Connected to $host:$port]\n";
die "can't fork: $!" unless defined do{$kidpid = fork()};
# в случае соединения клиента с базовой программой
# делимся на два процесса, между котороыми окрываем двухсторонний сокет
if ($kidpid) {
my ($byte, $tmp);
# выходим из парента, так как в паренте нужено писать только в чайлд
close PARENT;
# побайтовое чтение из сокета, в данном случае удаленная программа на
# внешние команды возвращает либо слово ok, либо error
while(sysread($handle, $byte, 1) eq 1){
$tmp.=$byte;
do{print CHILD "$tmp\n"; $tmp='' } if $tmp eq 'ok';
do{print CHILD $tmp,"\n"; $tmp=''} if $tmp eq 'error';
}
close CHILD;
# при завершении подпроцесса убиваем сервер и избегаем появления зомби
kill "TERM" => $kidpid;
waitpid($kidpid,0);
} else {
# выходим из парента, так как в паренте нужно писать только в чайлд
close CHILD;
# создаем сервер, транслирующий ответы базовой программы клиентам
# и передающий команды клиентов исходной программе
$server = IO::Socket::INET->new( LocalPort => 2003,
Type => SOCK_STREAM,
Proto => 'tcp',
Reuse => 1,
Listen => 10);
die "making socket: $@" unless $server;
# слушаем, что пишет в ответ сервер
while($client=$server->accept()){
# отключаем буферизацию
$client->autoflush(1);
my ($line, $line1);
# если есть данные от клиента
while (defined ($line = <$client>)){
# то пишем их в клиента, работающего с внешним устройством
print $handle $line;
# в случае ответа внешнего устройства через CHILD передаем ответ клиенту
chomp($line1=<PARENT>);
# пишем пользователю ответ из парента через межпроцессный сокет чайлд/парент
# ответ устройства, соответственно ok или error, зависимости от того,
# прошла ли команда или нет
print $client "$line1\n";
}
close $client;
# закрываем соединение в случае конца работы пользователя
}
# выходим из двусотроннего сокета со стороны чайлда, который писал в
# дексриптор PARENT
close PARENT;
}
# выходим из цикла порождающих пул процессов программ дабы не переполнить
# систему процессами, которые начнут без exit ветвится пока истинно while (1){}
} exit;
}
}
# убиваем всех чайлдов сразу, в случае например, перезапуска компьютера
sub HUNTSMAN{
local($SIG{CHLD})='IGNORE';
kill 'INT' => keys %children;
exit;
}
# убиваем конкретного чайлда, в случае неработоспособности устройства,
# с котороым надо коннектится клиентам... далее по смыслу перезапус через 2 секунды
sub REAPER{
$SIG{CHLD}=\&REAPER;
my $pid = wait;
$children--;
delete $children{$pid};
}
Синтакс расцвечен при помощи программы Code2HTML
Системы хранения и быстрого извлечения данных
Есть сервер с большим количеством текстовых файлов, например очень посещаемая www_board.
begin.file
вода
огонь воздух
сила тока, юзер, килограмм, метр, квантовые флуктуации, водка и пр.
end.file
"в" 10 20000 30000 40000 50000 60000
Примеры
Объявление двумерного массива
#!/usr/bin/perl -w
use strict;
my @table;
my $i;
my $j;
for $i (0..10) {
for $j (0..10) {
$table[$i][$j] = $i * $j;
}
}
#вывести:
for ($i = 0; $i < @table; $i++){
for($j =0; $j < @{$table[$i]}; $j++){
print "$i : $j : ", $table[$i][$j], "\n";
}
}
#можно и так:
for $i (0..$#table) {
for $j (0..$#{$table[$i]}) {
print "$i : $j : " . $table[$i][$j] . "\n";
}
}
Razmer fajla v kilobajtah:
$file = "files.zip";
$size=(stat("$Dir/$file"))[7];
print $size;
from: http://www.talk.ru/article.html?ID=13823783&page=1 открывает и читает из выбранной дирретории все файлы:
while(<$dir/journal/*.*>){
push(@files, $_);
}
типа sed. уничтожает ненавистный символ ^M, получающийся иногда при копировании
с виндовой машины на юниксовую машину.
Может с успехом заменить любой нужный к замене символ во всех файлах текущей дирректории
perl -i -n -p -e 's/\cM//isgm' *.html
from: сам написал #!/usr/bin/perl
qx[dbfdump --fs="\x18" --rs="\x19" pdffile.dbf >pdffile.txt];
преобразовать базу в текстовый файл. rs - конец строки, fs разделитель поля в строке
from: посоветовали unpack('a8000a*', $tpls[8]) - делит переменную на массив, состоящий из 8 килобайтов.
while ($tpls[8]){
($s,$tpls[8])=unpack('a8000a*', $tpls[8]);
push @arr, $s;
}
from: подсказали #!/usr/bin/perl -w
use POSIX qw(locale_h);
use DBI;
my $dbh = DBI->connect("dbi:XBase:SEJ_STR.DBF")
|| die "Can't connect: $DBI::errstr";
my $sth = $dbh->prepare( q{
SELECT name, phone
FROM mytelbook
}) || die "Can't prepare statement: $DBI::errstr";
my $rc = $sth->execute
|| die "Can't execute statement: $DBI::errstr";
print "Query will return $sth->{NUM_OF_FIELDS} fields.\n\n";
print "Field names: @{ $sth->{NAME} }\n";
while (($name, $phone) = $sth->fetchrow_array) {
print "$name: $phone\n";
}
# check for problems which may have terminated the fetch early
die $sth->errstr if $sth->err;
$dbh->disconnect;
from: из мана How can I get the unique keys from two hashes?
First you extract the keys from the hashes into arrays, and then
solve the uniquifying the array problem described above. For
example:
%seen = ();
for $element (keys(%foo), keys(%bar)) {
$seen{$element}++;
}
@uniq = keys %seen;
Or more succinctly:
@uniq = keys %{{%foo,%bar}};
Or if you really want to save space:
%seen = ();
while (defined ($key = each %foo)) {
$seen{$key}++;
}
while (defined ($key = each %bar)) {
$seen{$key}++;
}
@uniq = keys %seen;
from: perl mailer @matches = grep(/\^$field\^\|.*$search.*?\|/,@data); поиск в массиве нужных слов.
from: http://www.talk.ru/article.html?ID=14062178&page=1 undef $/;
@records = split /your_pattern/,
from: perl mailer  FORM ACTION="mailto:SuvorovAV@mail.ru" ENCTYPE=text/plain ФБЛ НПЦОП ПФРТБЧЙФШ НЩМП ЙЪ ЖПТНЩ ВЕЪ ЧУСЛЙИ УЛТЙРФПЧ
from: http://partizan-team.chat.ru/ 
while(1) {
system("cat FILE | grep "criteria" | mail -s subject your@address.ru 1> /dev/null 2> /dev/null");
sleep(as much as you want:));
}
так надо посылать письма без кронтаба.
from: http://www.rt.mipt.ru/board Как перл-программу запустить в "фоновом" режиме ./prog.pl 2>&1 >log &
from: http://www.rt.mipt.ru/board tr/bla1-bla1/bla2-bla2/ for var1, var2, var3;
from: fido7.ru.perl как написать выражение, чтоб из строки типа /home/www/vasia/file.html выделить только имя файла:
s|.*/||
from: http://www.machaon.ru/digest/www_board/messages/21777.html выцепление емейлов с www.job.ru
#!/usr/bin/perl -wT
$url0="http://www.job.ru/cgi/list1.cgi?GR_NUM=";
$url1="%31&TOPICID=9&EDUC=2&TP=&Gr=&SEX=&AGEMIN=23&AGEMAX=&MONEY=200
&CDT=";
$url2="&LDAY=99&ADDR=%ED%CF%D3%CB%D7%C1&KWORD=&KW_TP=AND";
use LWP::Simple;
foreach($i=1; $i<=57; $i++){
$plus.="%31%2B";
$test=$url0.$plus.$url1.$url2,"\n";
print join "\n", grep{s/(.*) ([\w+\-\.]+\@[\w\-\.]+\.\w{2,3})(.*)/$2/ig} split
/\n/, get "$test";
print "$i\n";
}
from: сам написал use Socket; #загрузить inet_addr
s{ #
( #Сохранить имя хоста в $1
(?: #Группирующие скобки
(?! [-_] ) #ни подчеркивание, ни дефис
[\w-] + #кусок имени хоста
\. #и точка домена
)+ #повторить несколько раз
[A-Za-z] #следующий символ - буква
[\w-]+ #домен верхнего уровня
) #конец записи $1
}{ #Заменить следующим
"$1" . #исходн часть + пробел
(($addr = gethostbyname($1)) #Если имеется адрес
? "[" . inet_ntoa($addr). "]"#отформатировать
: "[???]" #иначе пометить как сомнительный
)
}gex
from: с книжки 
from:
 sub koi2win {
my $str = shift;
$str =~ tr[\xE1\xE2\xF7\xE7\xE4\xE5\xF6\xFA\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF2\xF3\xF4\xF5\xE6\xE8\xE3\xFE\xFB\xFD\xFF\xF9\xF8\xFC\xE0\xF1\xC1\xC2\xD7\xC7\xC4\xC5\xD6\xDA\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD2\xD3\xD4\xD5\xC6\xC8\xC3\xDE\xDB\xDD\xDF\xD9\xD8\xDC\xC0\xD1\xB3\xA3][\xC0-\xFF\xA8\xB8];
return $str;
}
from: из сети sub win2koi {
my $str = shift;
$str =~ tr[\xC0-\xFF\xA8\xB8][\xE1\xE2\xF7\xE7\xE4\xE5\xF6\xFA\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF2\xF3\xF4\xF5\xE6\xE8\xE3\xFE\xFB\xFD\xFF\xF9\xF8\xFC\xE0\xF1\xC1\xC2\xD7\xC7\xC4\xC5\xD6\xDA\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD2\xD3\xD4\xD5\xC6\xC8\xC3\xDE\xDB\xDD\xDF\xD9\xD8\xDC\xC0\xD1\xB3\xA3];
return $str;
}
from: из сети Vivesti vremya
&time($time);
...
sub time{
$time = sprintf("%02d/%02d/%02d b %02d:%02d:%02d", $tm->hour,$tm->min, $tm->sec, $tm->mday, $tm->mon+1, $tm->year+1900);
return $time;
}
from: сам написал to-ge samoe no odnoj korotkoj strochkoy
#!/usr/bin/perl
my ($wday,$mday,$mon,$year,$time) =
(split(" ",gmtime(time+10800)))[0,2,1,4,3];
print "$wday, $mday $mon $year $time GMT\n";
print (split("\s",gmtime(time+10800)))->[0,2,1,4,3];
print "\n";
from: sam napisal 
from:
 17.29 2000-й год будет високосным? (год %4 ==0) - правильный тест на
високосный год?
О: Да и нет соответственно. Вот полной тест для Григорианского
календаря:
year % 4 == 0 && (year % 100 != 0 || year % 400 == 0)
from: какой-то вебсайт 
from:
 @d=split(/[ ]+/, scalar localtime);
оНКСВХЛ:
$d[0]=='Wed'
$d[1]=='Jun'
$d[2]=='5'
$d[3]=='14:59:35'
$d[4]=='2002'
from: dffddf 
from:
 
from:
 
from:
 
from:
 
from:
 
from:
 
from:
 
from:
 
from:
 
from:
 
from:
 
from:
 
...
from:
сам
 
...
from:
сам
 
nu huynya vihodt
<--