На главную
ПРАВИЛА FAQ Помощь Участники Календарь Избранное DigiMania RSS
msm.ru
! Внимательно изучите правила раздела перед созданием темы
0. ПРИЛАГАЙТЕ СВОИ СКРИПТЫ.
1. Прежде чем создать топик, используйте поиск. Возможно это уже обсуждалось.
2. В топике указывайте ОС, режим работы скрипта (CLI|CGI). Очень желателен вывод лог-файлов и того места, куда у вас назначен вывод данных (STDOUT|STDERR)
3. Помните: вы знаете что вы хотите, а форумчане - нет. Поэтому следуйте простому правилу: грамотный развернутый вопрос - грамотный развернутый ответ.
Модераторы: JoeUser, ANDLL
  
    > FAQ, Дополняем, правим.
      Аннотация.

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

      ExpandedWrap disabled
        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, к примеру), то так:

      ExpandedWrap disabled
        #!/usr/bin/perl -w
        print "Content-type: text/html\n\n";
        print "Some tezt";



      Q: А через CGI:WebOut?

      A: Код:

      ExpandedWrap disabled
        #!/usr/bin/perl -w
        use CGI::WebOut;
        print "Некоторый текст";



      Q: А вот дайте пример работы с телнетом?

      A: Простой пример.


      ExpandedWrap disabled
        #!/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
      Его вид такой:
      ExpandedWrap disabled
        12.23.45.54 dlink
        24.21.23.54 dlink_simple

      Суть такова: айпи адрес и... "тип устройства" =)
      Файлик обрабатывается подпрограммой parse();
      В этой подпрограмме указывается какое содержимое переменной $cmd нужно сказать свичу что бы он отдал конфиг на TFTP.
      А! Есть еще момент.
      В старой и доброй традиции юниксового TFTPD нужно что бы файлик, который мы передаем на сервер, уже был на этом сервере.
      Т.е. подпрограмма tftp_create() как раз и создает такой файлик нулевого размера.

      ExpandedWrap disabled
        #!/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: Очень просто.
      В Перле нет четкого объявления функции. Есть подпрограммы.
      ExpandedWrap disabled
        sub mySomeSub {
        # Здесь тело подпрограммы
        }



      Q: А как же переменные передать в подпрограмму?!

      A: Очень просто.
      ExpandedWrap disabled
        sub mySumm {
            my ( $someVar1 , $someVar2 ) = @_;
            return ( $someVar1 + $someVar2 );
        }

      @_ - массив, в котором содержатся аргументы, переданные подпрограмме.

      Количество переданных аргументов посчитать вот так:
      ExpandedWrap disabled
        $f = scalar( @_ );


      Соответственно, работать с такой подпрограммой вот так:

      ExpandedWrap disabled
        $myVar = mySumm( 10, 50 );


      На выходе получим 60.



      Q: А можно пример TCP-сервера и его клиента?

      A: Используя сокеты:

      Клиент:
      ExpandedWrap disabled
        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);



      Сервер:
      ExpandedWrap disabled
        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/

      ExpandedWrap disabled
        #!/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!!' );



      А вообще это нафиг никому не надо. Ни было, ни есть.
      Сообщение отредактировано: Nadz Goldman -
        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.
        ExpandedWrap disabled
          while( defined( my $item = $queue->dequeue() ) ) {
            # выполняем какие-либо действия.
          }




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


        Теперь приступим к реализации (упрощенный вариант).

        Task -> Tk -> Boss -> Worker -> Result

        Прикреплённый файлПрикреплённый файл1.png (27,49 Кбайт, скачиваний: 537)

        ExpandedWrap disabled
          #!/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();

        0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
        0 пользователей:


        Рейтинг@Mail.ru
        [ Script Execution time: 0,1271 ]   [ 19 queries used ]   [ Generated: 18.10.19, 21:42 GMT ]