Наши проекты:
Журнал · Discuz!ML · Wiki · DRKB · Помощь проекту |
||
ПРАВИЛА | FAQ | Помощь | Поиск | Участники | Календарь | Избранное | RSS |
[3.17.154.171] |
|
Сообщ.
#1
,
|
|
|
Аннотация.
1. Поиск. Всегда пользуйтесь поиском. 2. Материалов по языку Perl, модулям и особенностям работы в той или иной среде очень и очень много в сети. FAQ. Q: Перл. Где взять? A: http://www.perl.com/ Windows: http://strawberryperl.com/ http://www.activestate.com/activeperl UNIX/Linux: В распространенных системах уже есть в минимальной поставке. Если не установлен, то ставим из репозитария (UNIX FreeBSD: cd /usr/ports/lang/perl5.8; make; make install clean). Q: Что почитать? A: http://www.perl.com/pub/q/documentation http://bookwebmaster.narod.ru/perl.html Q: Где взять модули/библиотеки? A: http://search.cpan.org/ Q: Как подключиться к MySQL? A: Использовать DBI. A: Библиотечка и пример: mysql.pm use DBI; $sql_user=$ENV{SQL_USER}; $sql_password=$ENV{SQL_PASSWD}; $sql_base=$ENV{SQL_BASE}; $sql_host=$ENV{SQL_HOST}; if (! $sql_user) { $sql_user="USERNAME"; } if (! $sql_password) { $sql_password="PASSWORD"; } if (! $sql_base) { $sql_base="DATABASE_NAME"; } if (! $sql_host) { $sql_host="HOST"; } if ($debug) { print "User:$sql_user\nPassword:$sql_password\n"; } sub connect { my($u,$p)=@_; $sql_user=$u if $u; $sql_password=$p if $p; if ($debug) { print "User:$sql_user\nPassword:$sql_password\n"; } $dbh = DBI->connect("DBI:mysql:$sql_base;host=$sql_host", $sql_user, $sql_password); $dbh->{RaiseError} = 1; } sub disconnect { $dbh->disconnect; } 1; Пример кода: sample.pl use DBI; require 'mysql.pm'; $sth=$dbh->prepare("SELECT * FROM SomeTable WHERE SomeData = 'test'"); $sth->execute || die $DBD::errstr; while(($a,$b)=$sth->fetchrow) { print $a; } Q: Как отдать HTML? A: Если не через библиотеки (CGI::WebOut, к примеру), то так: #!/usr/bin/perl -w print "Content-type: text/html\n\n"; print "Some tezt"; Q: А через CGI:WebOut? A: Код: #!/usr/bin/perl -w use CGI::WebOut; print "Некоторый текст"; Q: А вот дайте пример работы с телнетом? A: Простой пример. #!/usr/bin/perl use Net::Telnet $conn = new Net::Telnet (Timeout => 10,'); $conn->open("some.host.org"); $conn->login($username); $conn->password($passwd); @somedata = $conn->cmd("do something"); print @somedata; A: А вот пример большой и деревянный. Суть такова: есть количество управляемых свичей, нужно с них собирать конфигурационные файлы. Берем TFTP сервер, Perl и два модуля (Net::Telnet & File::Copy). Так же есть файлик hosts.txt Его вид такой: 12.23.45.54 dlink 24.21.23.54 dlink_simple Суть такова: айпи адрес и... "тип устройства" =) Файлик обрабатывается подпрограммой parse(); В этой подпрограмме указывается какое содержимое переменной $cmd нужно сказать свичу что бы он отдал конфиг на TFTP. А! Есть еще момент. В старой и доброй традиции юниксового TFTPD нужно что бы файлик, который мы передаем на сервер, уже был на этом сервере. Т.е. подпрограмма tftp_create() как раз и создает такой файлик нулевого размера. #!/usr/bin/perl ########################################## ## ## ololo ## (C) Ilya Vasilyev, 2010 ## nadz.goldman@gmail.com ## ########################################## ########################################## use Net::Telnet; use File::Copy; $cmd; $host; $type; $conn; # айпи тфтп сервера $tftp_ip = "12.2.2.3"; # логин+пароль свича $username = "bak"; $passwd = "bak"; # директория тфтп-сервера, в которую кидаются/из которой берутся файлы, прилетевшие на тфтп $tftp_path = "/tftp"; # рабочая директория скрипта $main_path = "/home/bak/ololo"; # так у меня выглядит дата $date = `/bin/date "+%Y-%m-%d"`; # это для винды #$date = `date /T`; # так выглядит имя файла конфигурации, прилетевшего со свича $filename = $host."-".$date; #################################################################################### # вызов подпрограммы для распарсивания файла с хостами parse(); # выполнение бэкапа execute(); # перенос в директорию бэкапа mov_bak(); # подпрограмма переноса sub mov_bak() { # обрезаем фигню всякую chomp( $date ); # создаем директорию на текущую дату для бэкапа system( "mkdir -p ".$main_path."/bak/".$date ); # двигаем туда прилетевшие к нам конфиги system( "mv ".$tftp_path."/*_".$date." ".$main_path."/bak/".$date ); # скидываем в файл список пустых файлов - это те свичи, до которых мы либо не достучались, либо с них ничего не прилетело system( "find ".$main_path."/bak/ -empty -exec ls {} \\; > ".$main_path."/NOT_BACKUP.txt " ); } sub put_conf() { # на будущее =)) # here I put new conf to switch } # подпрограмма соединения со свичом по телнету sub connect_() { my $temp; $temp = length( $host ); # если вдруг переменная $host оказалась пуста, значит какой-то ахтунг произошел и скрипт умирает if( $temp == 0 ){ die "No ip address ( func::connect_ ) !\n Exiting...\n"; } # опции соединения $conn = new Net::Telnet( Timeout => 5 , Errmode => 'return' , Dump_Log => 'DUMP.LOG' ); $conn->open( Host=>$host ); # допиливаю вывод ошибок $msg = $conn -> errmsg; $prev = $conn -> errmsg( @msgs ); foreach $prev( @msgs ){ print "$prev\n"; } # создание дампов $dump = $conn -> dump_log; $dump = $conn -> dump_log( $dump ); $dump = $conn -> dump_log( $main_path.'/dump/DUMP.LOG' ); # ожидаем строки UserName/PassWord и дождавшись, скидываем туда логин и пароль # Можно и вот так: $conn -> waitfor( '/username[: ]*$/i' ); , но эт потом... # Просто потому что некоторые свичи пишут login или сразу password $conn -> waitfor( '/ame[: ]*$/' ); $conn -> print( $username ); $conn -> waitfor( '/ord[: ]*$/' ); $conn -> print( $passwd ); } # дисконнектимся sub disconnect() { $conn -> print( "logout" ); $conn -> close; undef( $conn ); copy( $main_path.'/dumps/DUMP.LOG', $main_path.'/dumps/DUMP.LOG-'.$host ); } # собственно здесь мы и забираем конфиг sub get_conf() { my $temp; $temp = length( $host ); # если вдруг переменная $host оказалась пуста, значит какой-то ахтунг произошел и скрипт умирает if( $temp == 0 ){ die "No ip address ( func::get_conf ) !\n Exiting...\n"; } # создаем файлик в директории тфтп сервера tftp_create(); # говорим свичу команду на отправку конфига $conn -> print( $cmd ); # ждем - иногда свичи тупят, если сразу отвалится, то глупости будут sleep( 15 ); } # подпрограмма создания файла в каталоге тфтп sub tftp_create { my $temp; $temp = length( $host ); # если вдруг переменная $host оказалась пуста, значит какой-то ахтунг произошел и скрипт умирает if( $temp == 0 ){ die "No ip address ( func::tftp_create ) !\n Exiting...\n"; } # создаем файл system( "touch $tftp_path"."/"."$filename" ); # устанавливаем права system( "chmod 0666 $tftp_path"."/"."$filename" ); # ждем... sleep( 2 ); } # подпрограмма выполнения sub execute { my $i; # ищем файлик со свичами цисок if( -f $main_path."/cisco.txt" ) { open( cs , "< ".$main_path."/cisco.txt" ) or print "While executing, can not open cisco.txt"; while( defined( $i = )) { print( "Yeeehaaa!!! It is CISCO!! =)) \n\n" ); } close( cs ); } # ищем файлик с длинками if( -f $main_path."/dlink.txt" ) { open( dl , "< ".$main_path."/dlink.txt" ) or print "While executing, can not open dlink.txt"; while( defined( $i = )) { chomp( $i ); $host = $i; $filename = $host."_".$date; # ВОТ эта команда будет сказана свичю после соедиенения и атворизации $cmd = "upload cfg_toTFTP $tftp_ip $filename"; # для дебага =) #print( "Host: $host\nfile: $filename cmd: $cmd" ); # соеденились connect_(); # забрали get_conf(); # ушли disconnect(); } close( dl ); } # А! Вот эта штука... Потому что длинки разные, то и набор команд у них разный. # сейчас как раз пилю что бы этой ереси с кучей файлов не было if( -f $main_path."/dlink_simple.txt" ) { open( dl_simple , "< ".$main_path."/dlink_simple.txt" ) or print "While executing, can not open dlink_simple.txt"; # upload configuration while( defined( $i = )) { chomp( $i ); $host = $i; $filename = $host."_".$date; $cmd = "upload configuration $tftp_ip $filename"; #print( "Host: $host\nfile: $filename cmd: $cmd" ); connect_(); get_conf(); disconnect(); } close( dl_simple ); } return(); } # подпрограмма парсинга sub parse { my $i; open( cs , "+> ".$main_path."/cisco.txt" ) or print( "Can not open cisco.txt\n" ); open( dl , "+> ".$main_path."/dlink.txt" ) or print( "Can not open dlink.txt\n" ); open( dl_simple , "+> ".$main_path."/dlink_simple.txt" ) or print( "Can not open dlink_simple.txt\n" ); open( err_txt , "+> ".$main_path."/error.txt" ) or print( "Can not open error.txt\n" ); open( fh , "< ".$main_path."/hosts.txt" ) or die "Can not open hosts.txt!\n"; flock( fh , 2 ) or die "Can not flock hosts.txt!\n"; while( defined( $i = )) { ( $host, $type ) = split( / /, $i ); if( $type =~ /cisco/i ) { #print "host = $host ... type = $type"; print cs "$host\n"; } elsif( $type =~ /^dlink$/i ) { #print "host = $host ... type = $type"; print dl "$host\n"; } elsif( $type =~ /^dlink_simple$/i ) { print dl_simple "$host\n"; } else { print err_txt "$host $type\n"; } } close( fh ); close( cs ); close( dl ); close( err_txt ); close( dl_simple ); return(); } Q: Привык программировать на языке Pascal/Object Pascal/C/другое. Никак не могу понять как писать функции в Перле A: Очень просто. В Перле нет четкого объявления функции. Есть подпрограммы. sub mySomeSub { # Здесь тело подпрограммы } Q: А как же переменные передать в подпрограмму?! A: Очень просто. sub mySumm { my ( $someVar1 , $someVar2 ) = @_; return ( $someVar1 + $someVar2 ); } @_ - массив, в котором содержатся аргументы, переданные подпрограмме. Количество переданных аргументов посчитать вот так: $f = scalar( @_ ); Соответственно, работать с такой подпрограммой вот так: $myVar = mySumm( 10, 50 ); На выходе получим 60. Q: А можно пример TCP-сервера и его клиента? A: Используя сокеты: Клиент: use Socket; socket(TO_SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp')); $internet_addr = inet_aton( $remote_host ) or die "Не могу сделать резолв хоста $remote_host в ip: $!\n"; $paddr = sockaddr_in( $remote_port , $internet_addr ); connect(TO_SERVER, $paddr) or die "Не могу соеденится с $remote_host:$remote_port : $!\n"; # Организуем работу с сервером. print TO_SERVER "HALO, SERVER!\n"; close(TO_SERVER); Сервер: use Socket; socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp')); setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1); $my_addr = sockaddr_in($server_port, INADDR_ANY); bind(SERVER, $my_addr) or die "Не могу использовать порт $server_port : $!\n"; listen(SERVER, SOMAXCONN) or die "Не могу слушать порт: $server_port : $!\n"; while (accept(CLIENT, SERVER)) { print "Halo, my dear client!\n"; } close(SERVER); Q: А что у нас с метапрограммированием в Перле? A: Да все не так просто. Ожидается в 6 версии Перла, но вот в соседнем топике отвечал на этот вопрос, решил и сюда добавить. Красочный пример. Очень советую поглядеть ссылки из комментариев. Сам Перл 6 пока что официально не признан, но есть. Смотреть здесь: http://www.perl6.org/ #!/usr/bin/env perl6 # see: # * http://transfixedbutnotdead.com/2010/01/13/anyone_for_metaprogramming/ # * http://transfixedbutnotdead.com/2010/01/14/anyone-for-perl-6-metaprogramming/ # * http://fingernailsinoatmeal.com/post/292301859/metaprogramming-ruby-vs-javascript # below runs on Rakudo (31-Oct-2009). use v6; class Ninja { has Str $.name is rw; } my Ninja $drew .= new( name => 'Drew' ); my Ninja $adam .= new( name => 'Adam' ); ########################################################### # Reopen Ninja class ("is also" does the biz) # and add 'battle_cry' method # augment class Ninja {} class Ninja is also { method battle_cry { say $.name ~ ' says zing!!!'; } } $drew.battle_cry; # => Drew says zing!!! $adam.battle_cry; # => Adam says zing!!! ########################################################### # add 'throw_star' method to $drew object by creating # and applying ("does") role to it (Singleton method) role ThrowStar { method throw_star { say "throwing star" } } $drew does ThrowStar; $drew.throw_star; # => throwing a star ########################################################### # call method dynamically $drew.'battle_cry'; # => Drew says zing!!! ########################################################### # add "colour" method closing over $colour_name (ie. closure): my $colour_name = 'black'; class Ninja is also { method colour { say "{$.name}'s colour is $colour_name" } } $drew.colour; # => Drew's colour is black $adam.colour; # => Adam's colour is black ########################################################### # "defining a method dynamically on an instance that closes # over local scope and accesses the instance’s state" # # Opps - Class method slipped in while working it out. # $drew.^add_method() does a singleton method.. nice! my $sword_symbol = '********'; $drew.^add_method( 'swing', method ( Str $sound_effect ) { say "$.name: $sword_symbol $sound_effect"; } ); $drew.swing( 'slash!!' ); А вообще это нафиг никому не надо. Ни было, ни есть. |
Сообщ.
#2
,
|
|
|
Q: Покажите что-нибудь по работе с потоками.
A: Очень понравился простейший пример, опубликованный на Хабрахабре. Вот перепост: Perl и GUI. Работа с потоками Я затрону весьма наболевшую тему, Perl + GUI + потоки. Наболевшую, потому что попытка заставить работать ваше приложение с потоками может закончиться неудачей. Программа «виснет», «сегфолитится», Вы обратитесь к документации, увидете там, что библиотека не thread-safe. Потраченное время было коту под хвост? Хинт: создать потоки до вызова Tkx::MainLoop, так как MainLoop() запускает свой цикл событий и блокирует выполнение кода. Было бы все так просто! Переписали Вы код с этим условием, а она все равно виснет… Что же делать? Выход есть. Нужно использовать модель Boss/Workers (Начальник и Работники) и очереди сообщений (Queue). Цель: написать приложение с GUI и использовать многопоточность. Давайте, рассмотрим задачу «на пальцах», представим все в виде абстрактной модели. Есть склад. Вы приходите к начальнику (boss), — Привет, соберите мне вот этот списочек… — Окей, сейчас раскидаю задание по частям, работники (workers) все сделают. Кладовщики задания берут из стопки (причем берут по порядку их поступления). Подобную очередь реализует пакет Thread::Queue. Мы будем использовать несколько методов — enqueue — положить задание — dequeue, dequeue_nb — взять задание Разница между dequeue и dequeue_nb в том, что последний неблокирующийся. Другими словами, когда мы вызываем dequeue, мы ждем пока задание не появится, и только тогда его получаем. А во втором случае, если задания нет — то возвращается undef. while( defined( my $item = $queue->dequeue() ) ) { # выполняем какие-либо действия. } Кладовщики собрали весь необходимый товар, теперь его заберет грузчик, и Вам принесет. … Теперь приступим к реализации (упрощенный вариант). Task -> Tk -> Boss -> Worker -> Result Прикреплённый файл1.png (27,49 Кбайт, скачиваний: 1186) #!/usr/bin/perl use strict; use Tkx; # тулкит use threads; # работа с потоками use Thread::Queue; # реализует очередь # создаем очереди my $queue_tk = Thread::Queue->new(); # получаем задания из Tk my $queue_job = Thread::Queue->new(); # отправляем работникам my $queue_box = Thread::Queue->new(); # результаты # босс sub thread_boss { my $self = threads->self(); my $tid = $self->tid(); while( defined( my $item = $queue_tk->dequeue() ) ) { print STDERR "Boss($tid) has received the task from Tk: $item\n"; # отправляем задание на обработку работнику $queue_job->enqueue( $item ); } $queue_job->enqueue( undef ); } # работник(и) sub thread_worker { my $self = threads->self(); my $tid = $self->tid(); while( defined( my $job = $queue_job->dequeue() ) ) { print STDERR "Worker($tid) has received task from Boss: $job\n"; # выполняем какую-нибудь работу... print STDERR "Worker($tid) has finished the task\n"; # скидываем все в одну коробку ;) $queue_box->enqueue( "processed: $job" ); } $queue_box->enqueue( undef ); } # создаем потоки my $boss = threads->new( \&thread_boss ); my $worker = threads->new( \&thread_worker ); # Создаем UI my $main_window = Tkx::widget->new( '.' ); my $frame = $main_window->new_ttk__frame( -padding => q/10 10 10 10/ ); $frame->g_grid(); my $label = $frame->new_ttk__label( -text => 'waiting' ); $label->g_grid( -row => 0, -column => 0, -columnspan => 2 ); # поле для ввода my $entry_data = 'enter data here'; my $entry = $frame->new_ttk__entry( -textvariable => \$entry_data ); my $button = $frame->new_ttk__button( -text => 'Send to Boss', -command => sub { $queue_tk->enqueue( $entry_data ); }, ); $entry->g_grid( -row => 1, -column => 0 ); $button->g_grid( -row => 1, -column => 1 ); # обработчик события WM_DELETE_WINDOW sub on_destroy { my $mw = shift; # отсылаем очереди undef, что завершит потоки $queue_tk->enqueue( undef ); $queue_box->enqueue( 'finish' ); # Destroy # или Tkx::destroy( '.' ) $mw->g_destroy(); } $main_window->g_wm_protocol( 'WM_DELETE_WINDOW', [\&on_destroy, $main_window] ); # обрабатываем результат sub monitor { my $status_lbl = shift; my $result = $queue_box->dequeue_nb; if( $result ne 'finish' ) { if( defined $result ) { $label->configure( -text => "job completed: ".scalar(localtime)); } Tkx::after( 1000, [\&monitor, $label]); } } # запускаем мониторинг Tkx::after( 100, [\&monitor, $label] ); # открепляем потоки # иначе при завершении программы, у нас будут предупреждения # Perl exited with active threads: # 2 running and unjoined # 0 finished and unjoined # 0 running and detached $boss->detach(); $worker->detach(); Tkx::MainLoop(); |