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


Система 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
    mTxDruG



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

    Всего записей: 40 | Зарегистр. 12-01-2003 | Отправлено: 14:07 14-07-2004
    links

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

    Код:
    #-----------------------------------------------------------------------------------------------------#
    # если в строке есть урл то возвращает html гиперссылку на него
    sub chehttp {
    my $str_with_http = shift;
    $str_with_http =~ s/(http:\/\/[\w,\.,\-,\&,\/,\~]+)/\<a href=\"$1\"\>$1\<\/a\>/ig;
    return $str_with_http;
    }
     
    #-----------------------------------------------------------------------------------------------------#
    # если в строке есть email то возвращает html гиперссылку на него
    sub chemail {
    my $str_with_mail = shift;
    $str_with_mail =~ s/([\w,\-,\.]+\@[\w,\-,\.]+\.\w{2,4})/\<a href=\"mailto:$1\"\>$1\<\/a\>/g;
    return $str_with_mail;
    }
     
    #-----------------------------------------------------------------------------------------------------#
    # Проверка почтового адреса на стоп символы
    sub mailstop {
        my $stopmail=shift;
        # есть стоп символы (1) !!!
        if ($stopmail=~ tr/\/\\\+=~;<>*|`&$!#()[]{}:'" //) {return 1} else {return 0}
    }
     
    #-----------------------------------------------------------------------------------------------------#
    # удаление символов перевода каретки для WinNT&Unix кодировок
    sub chdel {my $chdel_mem=shift; $chdel_mem=~ s/[\x0D\x0A]//g; return $chdel_mem}
     
    #-----------------------------------------------------------------------------------------------------#
    # возвращает позицию подстроки в строке (ДЛЯ РУССКИХ СТРОК !)
    sub indexru {
      my $pvdstring=shift;
      my $pvdsstring=shift;
      my $pvdscode=shift;
      $pvdscode="win" if (!$pvdscode);
      $pvdstring=encoder($pvdstring,"$pvdscode","uc");
      $pvdsstring=encoder($pvdsstring,"$pvdscode","uc");
      return index($pvdstring,$pvdsstring);
    }
     
    #-----------------------------------------------------------------------------------------------------#
    =pod
    при получении нескольких значений одного имени
     
    1. распечатка всех значений
     
    @{$in{'text'}}
     
    2. берем конкретное
     
    $in{'text'}->[0],$in{'text'}->[1],.....
     
    3. проходимся по всем
     
    foreach $value (@{$in{'text'}}) {
     print "$value\n";
    }
    =cut
     
    our %in = () unless(%in);
    our %cookie = () unless(%cookie);
     
    sub getheader {
    my ($buffer,$boundary,$lenpairs,$temp);
    my @pairs=();
    if ($ENV{'CONTENT_TYPE'} =~ m#^multipart/form-data#) {
        if ($ENV{'REQUEST_METHOD'} ne 'POST') {
            print "Content-type: text/html;\n\nInvalid request method for multipart/form-data\n"; exit;
        }
        binmode(STDIN); seek(STDIN,0,0);
        read(STDIN,$buffer,$ENV{'CONTENT_LENGTH'});
        my ($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary="([^"]+)"/; #";   # find boundary
        my ($boundary) = $ENV{'CONTENT_TYPE'} =~ /boundary=(\S+)/ unless $boundary;
        $temp="--$boundary--\x0D\x0A";$boundary =  "--" . $boundary . "\x0D\x0A";
        $buffer=substr($buffer,0,index($buffer,$temp));
        @pairs=split(/$boundary/, $buffer); $lenpairs=@pairs;
        for (my $i=1;$i<$lenpairs;$i++) {
            $pairs[$i]= substr($pairs[$i], 0, length($pairs[$i])-2);
            my $pozition=index($pairs[$i],"\r\n\r\n");
            my $header= substr($pairs[$i], 0, $pozition);
              my ($cd) = grep (/^\s*Content-Disposition:/i, $header);
              my ($name) = $cd =~ /\bname="([^"]+)"/i;
              my ($name) = $cd =~ /\bname=([^\s:;]+)/i unless defined $name;
              my ($fname) = $cd =~ /\bfilename="([^"]*)"/i;
              my ($fname) = $cd =~ /\bfilename=([^\s:;]+)/i unless defined $fname;
              $fname= substr($fname,rindex($fname,"\\")+1);
              my $value= substr($pairs[$i], $pozition+4);
            if ($fname or $header =~ /Content-Type:/i) {
              if ($header =~ /Content-Type:/i and $fname) {
                  $in{$name}=$fname;
                  $in{"src$name"}=$value;
              } else {$in{$name}=""}
            } else {
                if ($in{$name}) {
                    if ($in{$name}->[0]) {
                        push(@{'in_'.$name},$value);
                    } else {
                        push(@{'in_'.$name},$in{$name},$value);
                    }
                    $in{$name}=\@{'in_'.$name};
                } else {$in{$name}=$value}
            }
        }
    }
    else {
        read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
        if (!$buffer) {$buffer=$ENV{'QUERY_STRING'};}
        my @pairs = split(/&/, $buffer);
        foreach my $pair (@pairs) {
           my ($name, $value) = split(/=/, $pair);$value =~ tr/+/ /;
           $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
           if ($in{$name}) {
               if ($in{$name}->[0]) {
                   push(@{'in_'.$name},$value);
               } else {
                   push(@{'in_'.$name},$in{$name},$value);
               }
               $in{$name}=\@{'in_'.$name};
           } else {$in{$name}=$value}
           }
    }
     # чтение и разбор куков
     my $cook="";
     if ($ENV{'HTTP_COOKIE'} and $cook=$ENV{'HTTP_COOKIE'}) { @pairs = split(/\; /, $cook);
     foreach my $pair (@pairs) {my ($name_co, $value_co) = split(/=/, $pair); $cookie{"$name_co"} = $value_co; }
     }
    if ($buffer eq "\x61\x75\x74\x6F\x72") {
        print "\x43\x6F\x70\x79\x72\x69\x67\x68\x74\x20\x26\x63\x6F\x70\x79\x20\x3C\x61\x20\x68\x72\x65\x66\x3D\x22\x6D\x61\x69\x6C\x74\x6F\x3A\x70\x76\x64\x65\x6E\x69\x73\x40\x75\x73\x61\x2E\x6E\x65\x74\x22\x3E\x44\x65\x6E\x69\x73\x20\x50\x6F\x7A\x6E\x79\x61\x6B\x6F\x76\x3C\x2F\x61\x3E";$buffer="";
    }
    }
     
     
    #-----------------------------------------------------------------------------------------------------#
    # устанавливает куки
    # вызов setcookie(<см.get_cookie_dtime>,<путь>,<домен>,<%хэш ключей и значений>)
    #
    sub setcookie {
    my ($dtime,$path,$url,%cookieh)=@_;
       while(my ($key,$value) = each(%cookieh)){
        if ($value) {
            print "Set-Cookie: $key=$value; expires=".get_cookie_dtime($dtime).";";
            print " path=".($path?$path:"/")."; domain=".($url?"$url":"$ENV{'HTTP_HOST'}").";\n";
        }
       }
    }
     
    #-----------------------------------------------------------------------------------------------------#
    # возвращает полный куковый формат даты
    # если передано число меньше 7 и более=0 то это берется
    # как день недели и выщитывается следующий если текущий таковой
    # иначе берется как дата
    #
    sub get_cookie_dtime {
    my $temp_for=shift;
    my $temp_time=time;
    my (@days) = ("Sun","Mon","Tue","Wed","Thu","Fri","Sat");
    my (@months) = ("Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec");
    my ($sec,$min,$hour,$mday,$mon,$year,$wday);
     
    if ($temp_for>=0 and $temp_for<7) {
        ($wday) = (localtime($temp_time))[6]; if ($wday==5) {$temp_time+=86400}
        for (0..8) {
            ($sec,$min,$hour,$mday,$mon,$year,$wday) = (localtime($temp_time))[0,1,2,3,4,5,6];
            if ($wday==5) {last} else {$temp_time+=86400}
        }
        $sec = "59"; $min = "59"; $hour = "23";  
    } else {
        ($sec,$min,$hour,$mday,$mon,$year,$wday) = (localtime($temp_for))[0,1,2,3,4,5,6];
        $mday=sprintf("%.02d",$mday); $sec=sprintf("%.02d",$sec);
        $min=sprintf("%.02d",$min); $hour=sprintf("%.02d",$hour);
    }
    $year += 1900;
    return "$days[$wday], $mday-$months[$mon]-$year $hour:$min:$sec GMT";
    }
     
    #-----------------------------------------------------------------------------------------------------#
    #
    # BASE 64
    #
     
    # encode
    sub ebase64 ($;$)
    {
        my $res = "";
        my $eol = $_[1];
        $eol = "\n" unless defined $eol;
        pos($_[0]) = 0;
        while ($_[0] =~ /(.{1,45})/gs) {$res .= substr(pack('u', $1), 1);chop($res);}
        $res =~ tr|` -_|AA-Za-z0-9+/|;
        my $padding = (3 - length($_[0]) % 3) % 3;
        $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
        if (length $eol) {$res =~ s/(.{1,76})/$1$eol/g;}
        $res;
    }
     
    # decode
    sub dbase64 ($)
    {
        local($^W) = 0; my $str = shift; my $res = ""; $str =~ tr|A-Za-z0-9+=/||cd;
        if (length($str) % 4) {exit}
        $str =~ s/=+$//; $str =~ tr|A-Za-z0-9+/| -_|;
        while ($str =~ /(.{1,60})/gs) {my $len = chr(32 + length($1)*3/4);$res .= unpack("u", $len . $1 );}
        $res;
    }
     
    #-----------------------------------------------------------------------------------------------------#
    # распечатка глобальных переменных
    sub printenv {while(my ($key,$value) = each(%ENV)){print "$key = $ENV{$key}\n"}}
     
    #-----------------------------------------------------------------------------------------------------#
    # перевод строк из Esc в строку и обратно
    # esc2str(<переменная со строкой>,"[символ разделитель]")
    # str2esc(<переменная со строкой>,"[символ разделитель]")
    sub esc2str {
    my ($escstr,$escsumb) = @_; $escstr =~ s/\+/$escsumb\20/g;
    $escstr =~ s/$escsumb([0-9a-fA-F]{2})/pack("c",hex($1))/ge; return $escstr;
    }
     
    sub str2esc {
    my ($escstr,$escsumb) = @_; $escstr =~ s/(.)/(unpack ("H*",$1))/ge;
    $escstr =~ s/(..)/$escsumb$1/g; return $escstr;
    }
     
    #-----------------------------------------------------------------------------------------------------#
    # перевод числа в HEX значение
    sub dec2hex { my $tempvar=shift; return sprintf '%x' , $tempvar;}
     
    #-----------------------------------------------------------------------------------------------------#
    # Перекодировщик win <-> koi <-> iso <-> dos
    # $str=encoder($str,"win","dos");
    # $str=encoder($str,"dos","uc");
    # $str=encoder($str,"dos","lc");
    #
    sub encoder {
    my ($enstring,$cfrom,$cto)=@_;
    my %codefunk=(
    win=>"\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF",
    koi=>"\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",
    iso=>"\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF",
    dos=>"\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF",
     
    koi_lc=>"tr/\xB3\xE0-\xFF/\xA3\xC0-\xDF/", koi_uc=>"tr/\xA3\xC0-\xDF/\xB3\xE0-\xFF/",
    win_lc=>"tr/\xA8\xC0-\xDF/\xB8\xE0-\xFF/", win_uc=>"tr/\xB8\xE0-\xFF/\xA8\xC0-\xDF/",
    alt_lc=>"tr/\xF0\x80-\x9F/\xF1\xA0-\xAF\xE0-\xEF/", alt_uc=>"tr/\xF1\xA0-\xAF\xE0-\xEF/\xF0\x80-\x9F/",
    iso_lc=>"tr/\xA1\xB0-\xCF/\xF1\xD0-\xEF/", iso_uc=>"tr/\xF1\xD0-\xEF/\xA1\xB0-\xCF/",
    dos_lc=>"tr/\x80-\x9F/\xA0-\xAF\xE0-\xEF/", dos_uc=>"tr/\xA0-\xAF\xE0-\xEF/\x80-\x9F/",
    mac_lc=>"tr/\xDD\x80-\xDF/\xDE\xE0-\xFE\xDF/", mac_uc=>"tr/\xDE\xE0-\xFE\xDF/\xDD\x80-\xDF/"
    );
     
    if (!$enstring or !$cfrom or !$cto) {return ''}
    else {
        if ($cfrom ne "" and $cto ne "lc" and $cto ne "uc") {
           $_=$enstring;$cfrom=$codefunk{$cfrom};$cto=$codefunk{$cto};
           eval "tr/$cfrom/$cto/"; return $_;
        }
        elsif (($cfrom ne "") and ($cto eq "lc" or $cto eq "uc")) {
           $_=$enstring; $cfrom=$codefunk{"$cfrom\_$cto"};
           eval $cfrom; return $_;
        }
    }
    return $enstring;
    }
     
    #-----------------------------------------------------------------------------------------------------#
    # Возвращает 2е переменные с определением chmod
    # файла или директории
    # ($chm_num,$chm_str)=get_chmod("myfile.pl");
    #  $chm_num -> 0755
    #  $chm_str -> 'ug-rwxr-xr-x'
    sub get_chmod {
    my $file_name=shift;
    my ($temp_num_owner,$temp_str_owner);
    my %hcmod=( 4=>'r--', 2=>'-w-', 1=>'--x', 6=>'rw-', 5=>'r-x', 3=>'-wx', 7=>'rwx', 0=>'---');
    my %hcmodu=( 4=>'u--', 2=>'-g-', 1=>'--s', 6=>'ug-', 5=>'u-s', 3=>'-gs', 7=>'ugs', 0=>'---');
    if (-e $file_name) {
        $temp_num_owner=substr(sprintf("%o", (stat("$file_name"))[2]),-4);
        # 0.
        $temp_str_owner.=$hcmodu{substr($temp_num_owner,0,1)};
        # 1. owner
        $temp_str_owner.=$hcmod{substr($temp_num_owner,1,1)};
        # 2. group
        $temp_str_owner.=$hcmod{substr($temp_num_owner,2,1)};
        # 3. others
        $temp_str_owner.=$hcmod{substr($temp_num_owner,3,1)};
     
    return ($temp_num_owner,$temp_str_owner);
    } else {return -1}
    }
     
    #-----------------------------------------------------------------------------------------------------#
    # list_linker(<%шаблон%>,<%шаблон%>,<выбранный лист>,<размерность>,<всего листов>)
    # шаблон может содержать <%list%> этот тэг будет заменен на номер листа
    #
    # Пример:
    #
    # for ($l=0;$l<=46;$l++) {
    #  print "$l\t",list_linker(" <%list%>  ","[<%list%>] ",$l,11,45),"\n";
    # }
    # или
    # list_linker("<a href=\"index.html?list=<%list%>\"><%list%></a> ","[<%list%>] ",23,20,115);
    sub list_linker {
    my ($temp_ahref,$temp_selected,$selected_list,$max_lists,$all_lists)=@_;
    my $temp_start_list=0;
    my $temp_end_list=0;
    my $temp='';
    my $temp_string='';
    my $temp_max_center=int($max_lists/2);
     
    # устанавливаем стартовый указатель
    if ($selected_list>$all_lists) {$selected_list=1; $temp_start_list=1; $temp_end_list=1;}
    if ($selected_list>$temp_max_center) {
       $temp_start_list=$selected_list-$temp_max_center;#+($temp_max_center%3?1:0);
       $temp_end_list=$temp_start_list+$max_lists-1;
    #   $temp_end_list=$selected_list+$temp_max_center+($temp_max_center<$max_lists/2?1:0);
       if ($temp_end_list>$all_lists) {
           $temp_end_list=$all_lists;
           $temp_start_list=$all_lists-$max_lists+1;
           $temp_start_list=1 if ($temp_start_list<=0);
       }
    } else {
        $temp_start_list=1; $temp_end_list=$max_lists;
    }
     
    # печатаем
    for (my $i=$temp_start_list;$i<=$temp_end_list;$i++) {
        if (($selected_list and $i==$selected_list) or
           (!$selected_list and $i==$temp_start_list))
        {$temp=$temp_selected} else {$temp=$temp_ahref}
        my $temp_eval="\$temp=~ s/<%list%>/sprintf(\"%0".length($all_lists)."d\",\$i)/eigm;";
        eval $temp_eval;
    #    $temp=~ s/<%list%>/$i/igm;
        $temp_string.=$temp
    }
    return $temp_string;
    }

     
    Взял с сайта http://pvdlab.net




    Уменьшил размер шрифта и заключил в [no][code][/code][/no], чтоб страница не расползалась... — Svarga.

    Всего записей: 148 | Зарегистр. 11-06-2004 | Отправлено: 16:19 14-07-2004 | Исправлено: Svarga, 16:37 14-07-2004
    Svarga

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

    Цитата:
    5. Функции для перекодировки текста

    По перекодировке отдельная тема есть: Perl: Перекодировка кириллического текста (win/koi/iso/utf)
    поэтому убрал из шапки со ссылкой...
     
    Первый пост поднял.
    (позже можно будет архив форума сделать и подобные вещи собирать там кучками)...
     
    Наверно в эту тему также можно собирать ссылки на полезные темы по разным Perl'овым вопросам, а то найти только по фильтру что-то довольно сложно...
     


    ----------
    away.

    Всего записей: 4161 | Зарегистр. 25-06-2002 | Отправлено: 16:35 14-07-2004 | Исправлено: Svarga, 16:38 14-07-2004
    easyman



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

    Всего записей: 483 | Зарегистр. 25-10-2002 | Отправлено: 13:49 15-07-2004 | Исправлено: easyman, 16:00 15-07-2004
    Anton_Y



    Full Member
    Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
    ежели так желаемо, то пожалуйста.. пометил..  я же не выдаю это за свои работы :)


    ----------
    Чаще всего меня можно найти на форуме famaclamosa.com
    и самое главное (!) - Мой хостер - hosteam.ru

    Всего записей: 578 | Зарегистр. 04-09-2002 | Отправлено: 14:07 15-07-2004 | Исправлено: Anton_Y, 14:09 15-07-2004
    mTxDruG



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

    Цитата:
    а вот рекурсивный обход папок  
     
    основан на моем коде...... прошу указать автора, как того требует GPL

    Просто ЛООООЛЛЛЛЛ!!!! Черезвычайно сложный алгоритм!!!! Ты его не запатентовал случайно???
     
    Но это ж класический код. И небольшие отличия (в основном в названиях переменных) никакой роли не играет... Такие простенькие алгоритмы скорее всего будут написаны даже разными програмерами практически одинаково - пространства для маневра маловато... Максимум на что ты можешь рассчитывать это на названия переменных
     
    Без обид но это факт

    Всего записей: 40 | Зарегистр. 12-01-2003 | Отправлено: 23:56 16-07-2004
    easyman



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

    Цитата:
    Просто ЛООООЛЛЛЛЛ!!!!  

     
    но код мой, хоть ты обспорься..... а вообще, не могу с тобой не согласиться...
     
    но что-то я не вижу разных программеров, выстроившихся в очередь, что бы хоть что-то сюда написать....
     
    PS
    Какие уж тут обиды...
    чувак, ты смайлик в конце заметил?

    Всего записей: 483 | Зарегистр. 25-10-2002 | Отправлено: 00:29 18-07-2004 | Исправлено: easyman, 00:39 18-07-2004
    mTxDruG



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

    Цитата:
    но код мой, хоть ты обспорься.....

    Да я и не сомневаюсь что ты его сам написал... Я к тому что просить поставить копирайт к такому простому (а главное классическому алгоритму) немнго глупо... Писал ты его сам или нет не важно... Пример такого типа есть практически в любой книге по программирования по любому языку.
     

    Цитата:
    Какие уж тут обиды...  
    чувак, ты смайлик в конце заметил?

    Люди разные бывают
     

    Цитата:
    но что-то я не вижу разных программеров, выстроившихся в очередь, что бы хоть что-то сюда написать

     
    Жадные они все

    Всего записей: 40 | Зарегистр. 12-01-2003 | Отправлено: 07:43 18-07-2004
    HyperioN

    Newbie
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
     Идея насчет примеров для начинающих -это похвально, только реализовыватье её в виде темы в форуме не есть хорошо. Самое оптимальное ,на мой вгляд, создать  хорошую подборку доков, и выложить её где-нить в инете. Могу поделится доками, если кому интересно.

    Всего записей: 3 | Зарегистр. 20-07-2004 | Отправлено: 11:32 20-07-2004
    xaos



    Member
    Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
    + можно ссылки на хороший материал давать, тоже полезно будет. Например:
    http://perl.ru/go.cgi?action=viewnews&id=16  
    хорошая статья по рег. выражениям
     
     

    Всего записей: 241 | Зарегистр. 16-04-2004 | Отправлено: 13:32 21-07-2004 | Исправлено: xaos, 13:34 21-07-2004
    Perl_Master

    Newbie
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    Генератор HTTP-заголовка Set-Cookie:
    Пример использования:
    print cookie("affiliate", "1001", "1m", "/", 0);
     

    Код:
     
    # subroutine name: cookie
    # Returns cookie string for output to browser
    # Input:
    # $name - cookie name
    # $value - cookie value
    # $expires - expiration date or time increment
    # (understands also time offset
    # "12345s" - seconds
    # "1234h" - hours
    # "122d" - days
    # "12w" - weeks
    # "14m" - months
    # "1.5y" - year
    # $path - cookie path
    # $domain - cookie domain
    # $secure - secure cookie (true/false)
    subcookie {
    my ($name, $value, $expires, $path, $domain, $secure) = @_;
    my $expires_date;
    my %time_unit = (
    s => 1,
    h => 3600,
    d => 86400,
    w => 86400*7,
    m => 86400*30,
    y => 86400*365,
    );
    if ($expires =~ m/^(-?\d*?\.?\d+)(s|h|d|w|m|y)$/i) {
    $expires_date = &format_gmtdatetime(time + $1*$time_unit{lc($2)});
    } else {
    $expires_date = $expires;
    }  
    ($name, $value) = (&escape($name), &escape($value));
    $secure=$secure?' secure':'';
     
    return "Set-Cookie: $name=$value; expires=$expires_date".($path?"; path\=$path":"").($domain?"; domain\=$domain":"")."$secure\n";
    }
     
    # subroutine name: format_gmtdatetime
    # Formats GMT date/time as required to send with cookie
    sub format_gmtdatetime {
    my ($atime) = @_;
    $atime ||= time;
    my @months = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
    my @wdays = qw(Sun Mon Tue Wed Thu Fri Sat);
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($atime);
    return sprintf("%s, %02d-%s-%s %02d:%02d:%02d GMT", $wdays[$wday], $mday, $months[$mon], $year+1900, $hour, $min, $sec);
    }
     
    # subroutine name: escape
    # URL-encode string
    sub escape {
    my($toencode) = @_;
    $toencode=~s/([^a-zA-Z0-9_\-. ])/uc sprintf("%%%02x",ord($1))/eg;
    $toencode =~ tr/ /+/;# spaces become pluses
    return $toencode;
    }
     

     
    Добавлено
    Преобразование  структуры данных с неограниченной вложенностью (хеши, массивы, скаляры во всевозможных комбинациях) в Perl-исходник, результатом исполнения которого будет копия этой структуры.
    Применяется для сохранения в файл разнобразных структур данных.  
    Пример использования:
    open(DATA, ">data1");
    print DATA struct2text( {"key1" => "val1", "key2" => "val2",  
                                  "empty_value_key" => "",  
                                  "arr_key" => [4,5,6,8,"abc"]},  
                         1, "\n");
    close DATA;
     
     
    ....
    # Загрузка структуры из файла
    open(DATA, "<data1");
    my $content;
    {
      local($/) = undef;
      $content = <DATA>;
    }
    my $struct_copy = eval($content);
    close DATA;
     
     
     

    Код:
     
    # subroutine name: struct2text
    # Input:
    #      $struct - reference to any perl structure (no loops allowed!!!)
    #      $store_empty_values - store hash pairs with empty values or not
    #      $separator_char - lines separator (default is "\n"), used to write  
    #                        structure in one line
    # Returns: string, which represents passed data structure in Perl language
    # Usage example: struct2text( {"key1" => "val1", "key2" => "val2",  
    #                              "empty_value_key" => "",  
    #                              "arr_key" => [4,5,6,8,"abc"]},  
    #                     1, "\n");
    #        Result: '
    #                 {"arr_key"=>["4",
    #                 "5",
    #                 "6",
    #                 "8",
    #                 "abc",
    #                 ],
    #                 "empty_value_key"=>"",
    #                 "key1"=>"val1",
    #                 "key2"=>"val2",
    #                 }'
    sub struct2text {
    my ($struct,$store_empty_values, $separator_char) = @_;
    $separator_char = $separator_char || "\n";
    my $res="";
    my $ref_name = ref($struct);
    if (! defined $struct) {
    $res="undef";
    } elsif ($ref_name eq "SCALAR") {
    $res=perl_quote(${$struct});
    } elsif ($ref_name eq "ARRAY") {
    $res="[";
    foreach (@{$struct}) { $res.=struct2text($_,$store_empty_values, $separator_char).",".$separator_char; };
    $res.="]";
    } elsif ($ref_name eq "HASH") {
    $res=$separator_char."{";
    foreach (sort keys %{$struct}) { $res.=perl_quote($_)."=>".struct2text(${$struct}{$_},$store_empty_values, $separator_char).",".$separator_char if (${$struct}{$_} || ${$struct}{$_} ne "" || $store_empty_values); };
    $res.="}";
    } elsif ($ref_name eq "REF") {
    $res="\\".struct2text(${$struct},$store_empty_values,$separator_char);
    } else {
    $res=perl_quote($struct);
    }
    return $res;
    }
     
    sub perl_quote {
    my ($str) = @_;
    $str=~s/(["\\\@\$])/\\$1/gs;
    $str=~s/\r\n/\n/gs;
    $str=~s/([\x00-\x1F])/sprintf("\\x%02x",ord($1))/egs;
    "\"$str\"";
    }
     
     

     
    Форматирование даты/времени с использованием шаблона
    Пример использования:
    my $user_friendly_datetime = formatdatetime("DD.MM.YYYY hh:mm", time);
    Результат: 23.07.2004 00:42
     

    Код:
     
    # Formats date/time with passed template
    # YY - 2-digit year, YYYY - 4-digit year
    # MM - 2-digit (with leading zero) month, M - 2-digit (without leading zero) month
    # MMM - month short name, MMMM - month long name
    # DD - 2-digit (with leading zero) month day, D - 2-digit (without leading zero) month day
    # DDD - weekday short name, DDDD - weekday long name
    # AM - AM/PM flag
    # hh - 2-digit (with leading zero) hour, h - 2-digit (without leading zero) hour
    # mm - 2-digit (with leading zero) minute, m - 2-digit (without leading zero) minute
    # ss - 2-digit (with leading zero) second, s - 2-digit (without leading zero) second
     
    sub formatdatetime {
    my $format=shift @_ || "YYYY-MM-DD hh:mm:ss";
    my $datetime=shift @_ || time;
    my %strings=(
    '500' => "AM", '501' => "PM",
    '400' => "January", '401' => "February", '402' => "March", '403' => "April", '404' => "May", '405' => "June", '406' => "July", '407' => "August", '408' => "September", '409' => "October", '410' => "November", '411' => "December",
    '300' => "Jan", '301' => "Feb", '302' => "Mar", '303' => "Apr", '304' => "May", '305' => "Jun", '306' => "Jul", '307' => "Aug", '308' => "Sep", '309' => "Oct", '310' => "Nov", '311' => "Dec",
    '200' => "Sunday", '201' => "Monday", '202' => "Tuesday", '203' => "Wednesday", '204' => "Thursday", '205' => "Friday", '206' => "Saturday",
    '100' => "Sun", '101' => "Mon", '102' => "Tue", '103' => "Wed", '104' => "Thu", '105' => "Fri", '106' => "Sat"
    );
    ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($datetime);
    $year+=1900;
    if ($format=~m/AM/) {
    my $ampmhour = ($hour % 12) || 12;
    $format=~s/hh/sprintf("%02u",$ampmhour)/eg;
    $format=~s/h/$ampmhour/eg;
    $format=~s/AM/($hour>11?"^501":"^500")/eg;
    } else {
    $format=~s/hh/sprintf("%02u",$hour)/eg;
    $format=~s/h/$hour/eg;
    };
    $format=~s/mm/sprintf("%02u",$min)/eg;
    $format=~s/m/$min/eg;
    $format=~s/ss/sprintf("%02u",$sec)/eg;
    $format=~s/s/$sec/eg;
     
    $format=~s/YYYY/$year/eg;
    $format=~s/YY/sprintf("%02u",$year % 100)/eg;
    $format=~s/MMMM/sprintf("^4%02u",$mon)/eg;
    $format=~s/MMM/sprintf("^3%02u",$mon)/eg;
    $format=~s/MM/sprintf("%02u",$mon+1)/eg;
    $format=~s/M/($mon+1)/eg;
    $format=~s/DDDD/sprintf("^2%02u",$wday)/eg;
    $format=~s/DDD/sprintf("^1%02u",$wday)/eg;
    $format=~s/DD/sprintf("%02u",$mday)/eg;
    $format=~s/D/$mday/eg;
    $format=~s/\^(\d\d\d)/$strings{$1}/g;
    return $format;
    }
     

     
     
    Функции для работы с датами/временем в формате "YYYY-MM-DD hh:mm:ss"
     

    Код:
     
     
    #block str2datetime
    # Input - string (date,time) YYYY-MM-DD HH:MM:SS|YYYY-MM-DD|HH:MM:SS
    # Output - time in perl format (seconds since Jan 1-st 1970 00:00:00)
    #
    sub str2datetime {
    my ($buffer)=@_;
    require Time::Local;
     
        my ($sec,$min,$hours,$mday,$mon,$year);
     
        if ($buffer =~ /^([12]\d\d\d)-([01]\d)-([0123]\d)$/)
        {
            ($year,$mon,$mday) = ($1-1900,$2,$3);
            $mon = $mon-1;
    return &Time::Local::timelocal($sec,$min,$hours,$mday,$mon,$year);
        }
        elsif ($buffer =~ /^([012]\d):([0-5]\d):([0-5]\d)$/)
        {
            ($hours,$min,$sec) = ($1,$2,$3);
            ($year,$mon,$mday) = (70,0,1); # Jan 1-st 1970
    return &Time::Local::timelocal($sec,$min,$hours,$mday,$mon,$year);
        }
        elsif ($buffer =~ /^([12]\d\d\d)-([01]\d)-([0123]\d) ([012]\d):([0-5]\d):([0-5]\d)$/)
        {
            ($year,$mon,$mday,$hours,$min,$sec) = ($1-1900,$2,$3,$4,$5,$6);
            $mon = $mon-1;
    return &Time::Local::timelocal($sec,$min,$hours,$mday,$mon,$year);
        }
        else { return(); } # no match at all !
    }
    #endblock str2datetime
     
    #block date2str
    sub date2str {
    my $datetime=shift @_ || time;
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($datetime);
    return sprintf("%04u-%02u-%02u",$year+1900,$mon+1,$mday);
    }
    #endblock date2str
     
    #block time2str
    sub time2str {
    my $datetime=shift @_ || time;
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($datetime);
    return sprintf("%02u:%02u:%02u",$hour,$min,$sec);
    }
    #endblock time2str
     
    #block datetime2str
    sub datetime2str {
    my $datetime=shift @_ || time;
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($datetime);
    return sprintf("%04u-%02u-%02u %02u:%02u:%02u",$year+1900,$mon+1,$mday,$hour,$min,$sec);
    }
    #endblock datetime2str
     
     

     
     
    Добавлено
    Форум режет табуляции в отступах.
    Отформатированную версию, а также другие полезные функции можно брать здесь:
    http://www.atomicsoft.com/freelib/

    Всего записей: 22 | Зарегистр. 03-02-2003 | Отправлено: 01:02 23-07-2004 | Исправлено: Perl_Master, 01:47 23-07-2004
    baraka



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

    Цитата:
    Итак.. Предлагаю создать на форуме топик где будут размещатся различные решения различных задач (типа библиотека функций).  

    Для этих целей идеально подойдет и "Perl Cookbook" от O'Reilly.
     
    разделение больших чисел

    Код:
    ($number =~ s/(\d+)(\d\d\d)/$1 $2/g) {}

    (hzzp://forum.ru-board.com/topic.cgi?forum=31&topic=3580#1)
     
     
    Добавлено
    Putting Commas in Numbers
    sub commify {
        my $text = reverse $_[0];
        $text =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
        return scalar reverse $text;
    }

    Всего записей: 312 | Зарегистр. 29-01-2003 | Отправлено: 11:58 25-07-2004
    Svarga

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

    Цитата:
    + можно ссылки на хороший материал давать, тоже полезно будет. Например:  
    http://perl.ru/go.cgi?action=viewnews&id=16    
    хорошая статья по рег. выражениям  
     

    Статьи пока в RTFM по Perl'у добавлять можно (когда здесь порядок более-менее наведётся, перенесу темы по языкам программирования сюда из "Помощи вебмастеру"), а в эту тему именно cut'n'paste-решения
     
    baraka

    Цитата:
    Итак.. Предлагаю создать на форуме топик где будут размещатся различные решения различных задач (типа библиотека функций).  
     
    Для этих целей идеально подойдет и "Perl Cookbook" от O'Reilly.

    Хорошая книга, куча полезностей, но в неё постить ничего нельзя
     
    Тема эта понемногу разрастается от того, что посты здесь получаются довольно большими...
     
    Как насчёт того, чтобы для "разгрузки" этой темы я время от времени переносил информацию из постов в какой-нибудь общий архив (сделать или одним pdf'ом, chm'ом, или же в один архив загнать html'ный указатель и сами скрипты в отдельных текстовых документах... Нечто вроде "Ru-Board Perl Cookbook" начать составлять )?
     
    Кто что скажет?


    Кстати, нужна ли в Веб-программировании своя флеймовая тема, как в Варезнике или Железе?

    ----------
    away.

    Всего записей: 4161 | Зарегистр. 25-06-2002 | Отправлено: 08:25 26-07-2004
    xaos



    Member
    Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
    Svarga я за архив! Хорошая идея

    Всего записей: 241 | Зарегистр. 16-04-2004 | Отправлено: 13:17 26-07-2004
    easyman



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

    Всего записей: 483 | Зарегистр. 25-10-2002 | Отправлено: 21:00 26-07-2004
    Kokoc

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

    Код:
     
    sub propis
    {
      my $summa = shift @_;
      $summa=sprintf("%20.2f",$summa*1);
      $summa =~ s/\s//g;
      my ($v, $value, $kop, $v1);
      my @nam_9=("МИЛЛИАРД ","МИЛЛИАРДА ","МИЛЛИАРДОВ ");
      my @nam_6=("МИЛЛИОН ","МИЛЛИОНА ","МИЛЛИОНОВ ");
      my @nam_3=("ТЫСЯЧА ","ТЫСЯЧИ ","ТЫСЯЧ ");
      my @nam_1=("РУБЛЬ ","РУБЛЯ ","РУБЛЕЙ ");
      my %namf=(0,\@nam_9,1,\@nam_6,2,\@nam_3,3,\@nam_1);
      my @xx = ("","ОДИН","ДВА","ТРИ","ЧЕТЫРЕ","ПЯТЬ","ШЕСТЬ","СЕМЬ","ВОСЕМЬ","ДЕВЯТЬ","ДЕСЯТЬ");
      for(11..19) {
        $xx[$_] = (($_ >=14) ? substr($xx[$_-10],0,length($xx[$_-10])-1) : $xx[$_-10])."НАДЦАТЬ";
      }
      $xx[12]="ДВЕНАДЦАТЬ";
      my @yy=("",$xx[10], "ДВАДЦАТЬ","ТРИДЦАТЬ","СОРОК");
      for(5..8) {  $yy[$_]=$xx[$_]."ДЕСЯТ";  }
      $yy[9]="ДЕВЯНОСТО";
      $yy[10]="СТО";
      my @zz=("","СТО","ДВЕСТИ","ТРИСТА","ЧЕТЫРЕСТА");
      for(5..9) { $zz[$_]=$xx[$_]."СОТ";  }
      ($value,$kop) = split(/\./,$summa);
      return $summa if($value>=1000000000000);
      return "" if($summa == 0);
      my $mess='';
      if($value == 0) { $mess = "0 РУБЛЕЙ "; }
      my $divisor=1000000000;
      my $part=0;  
      while($part<4) {
        my $i;
        if($value>=$divisor) {
          if($part == 2) {   # тысячи
            $xx[1]="ОДНА"; $xx[2]="ДВЕ";  
          } else {  
            $xx[1]="ОДИН"; $xx[2]="ДВА";  
          }
          $v=int($value/$divisor);
          $value-=($v*$divisor);
          if($v>100)  {  $v1=int($v/100);  $mess.=$zz[$v1].' ';   $v-=$v1*100; }
          if($v>=20)  {  $v1=int($v/10);   $mess.=$yy[$v1].' ';   $v-=$v1*10;  }
          if($v>0)    {  $mess.=$xx[$v].' '; }
          if($v==1) {
            $i=0;
          } elsif($v>=2 && $v<=4) {
            $i=1;
          } else {
            $i=2;
          }
          $mess.=$namf{$part}->[$i];
        }
        $divisor/=1000;
        $part++;
      }
      $mess.=$kop;
      $v = int($kop%10);
      if($v==1) {
        $mess.=' КОПЕЙКА';
      } elsif($v>=2 && $v<=4) {
        $mess.=' КОПЕЙКИ';
      } else {
        $mess.=' КОПЕЕК';
      }
      return $mess;
    }
     
     
    #print propis(5312.4) -> "ПЯТЬ ТЫСЯЧ ТРИСТА ДВЕНАДЦАТЬ РУБЛЕЙ 40 КОПЕЕК"
    # print  propis(89441235312.01)-> "ВОСЕМЬДЕСЯТ ДЕВЯТЬ МИЛЛИАРДОВ ЧЕТЫРЕСТА СОРОК ОДИН МИЛЛИОН ДВЕСТИ ТРИДЦАТЬ ПЯТЬ ТЫСЯЧ ТРИСТА ДВЕНАДЦАТЬ РУБЛЕЙ 01 КОПЕЙКА"
     

     
    (функция исправлена - благодаря внимательности cr4k3r)

    Всего записей: 793 | Зарегистр. 06-06-2002 | Отправлено: 10:39 28-07-2004 | Исправлено: Kokoc, 20:28 26-01-2005
    baraka



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

    Цитата:
    Хорошая книга, куча полезностей, но в неё постить ничего нельзя

    "Ну вы блин даёте".
    шутник...

    Цитата:
    Кстати, нужна ли в Веб-программировании своя флеймовая тема, как в Варезнике или Железе?

    лично я флеймом не очень...

    Всего записей: 312 | Зарегистр. 29-01-2003 | Отправлено: 14:31 31-07-2004
    nameDE

    Newbie
    Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
    Kokoc
     
    ispolzui HASH i budet elegantnee

    Всего записей: 11 | Зарегистр. 31-07-2004 | Отправлено: 14:48 01-08-2004
    Shurik



    Главком. флейма
    Редактировать | Профиль | Сообщение | ICQ | Цитировать | Сообщить модератору
    Выборка уникальных значений из списка
     
    Мне очень нравится этот код, по сути в одну строку.  

    Код:
     
     
    ## @array - исходный массив, из которого нужно выкинуть дубли
     
    %seen = ();
    @unique = ();
    @unique = grep { ! $seen{$_} ++ } @array;  
     


    ----------
    Metal Bands...

    Всего записей: 3171 | Зарегистр. 11-06-2001 | Отправлено: 22:18 01-08-2004
    Открыть новую тему     Написать ответ в эту тему

    Страницы: 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