» Perl: Полезные решения

Итак.. Предлагаю создать на форуме топик где будут размещатся различные решения различных задач (типа библиотека функций).
Размещать рекомендуется с описанием (что этот код делае), с описанием переменных (желательно use strict)
p.s. размещать не обязательно свои исходники..
мой скомный вклад.. (что сумел вспомнить:) )

исключение из массива повторяющихся записей (аналог distinct в sql) [more]
Код:
my @new_list; # массив куда будут помещены "отфильтованные" значения
my @list; #исходный массив
my %seen; #хеш для работы
@new_list = grep {$_ && !$seen{$_}++} @list;

Неплохая идея... новички действительно должны ее оченить

Еще пару


Код: #-----------------------------------------------------------------------------------------------------#
# если в строке есть урл то возвращает 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;
}

Anton_Y

Цитата:

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

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

Первый пост поднял.
(позже можно будет архив форума сделать и подобные вещи собирать там кучками)...

Наверно в эту тему также можно собирать ссылки на полезные темы по разным Perl'овым вопросам, а то найти только по фильтру что-то довольно сложно...

а вот рекурсивный обход папок

основан на моем коде...... прошу указать автора, как того требует GPL

ежели так желаемо, то пожалуйста.. пометил.. я же не выдаю это за свои работы :)

Цитата:

а вот рекурсивный обход папок

основан на моем коде...... прошу указать автора, как того требует GPL

Просто ЛООООЛЛЛЛЛ!!!! Черезвычайно сложный алгоритм!!!! Ты его не запатентовал случайно???

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

Без обид но это факт

Цитата:

Просто ЛООООЛЛЛЛЛ!!!!

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

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

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

Цитата:

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

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


Цитата:

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

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


Цитата:

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

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

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

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

Генератор 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 Cookbook" от O'Reilly.

разделение больших чисел

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

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" начать составлять )?

Кто что скажет?

---

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

Svarga я за архив! Хорошая идея

Svarga
Еще бы неплохо, чтобы те кто попробовал эти решения, говорили..... а работают они или нет.

Вот от меня:
Сумма прописью

Код:
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 КОПЕЙКА"

Svarga

Цитата:

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

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

Цитата:

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

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

Kokoc

ispolzui HASH i budet elegantnee

Выборка уникальных значений из списка

Мне очень нравится этот код, по сути в одну строку.

Код:

## @array - исходный массив, из которого нужно выкинуть дубли

%seen = ();
@unique = ();
@unique = grep { ! $seen{$_} ++ } @array;

Shurik
PerlCookbook
4.6. Extracting Unique Elements from a List
hzzp://iis1.cps.unizar.es/Oreilly/perl/cookbook/ch04_07.htm
Если кто не слыщал про эту книгу то welcome сюда:
hzzp://iis1.cps.unizar.es/Oreilly/perl/cookbook/index.htm

Всем привет!

Есть вот такое чудо на свете http://pleac.sourceforge.net/
Перловый раздел, соответственно, вот он http://pleac.sourceforge.net/pleac_perl/index.html
То есть, это весь код примеров из Перл Кукбук. Правда, я полагаю, что это максимум 2-я редакция книги. По аналогии в этом проекте пытаются и для других языков сделать такой же сборник рецептов.

Полезные Perl модули
hzzp://opennet.ru/prog/sml/95.shtml

Извиняюсь, а тема еще жива? Или энтузиазм иссяк?

ни чё не иссякло, достаем из ларца.....


экономично разбираем конфиги в стиле ini, примерно следующего вида:


Код:
[bla]
aaa=nnn
bbb=bbb

[view]
fff=not
ggg=333


[tmpl]
ttt=<<TMPL
<p>
[##ggg##]

Любая разметка html, xml, etc.
</p>
TMPL>>

eee=5

[easy]
er=9

Кому интересно, ещё скрипты: hzzp://script.woweb.ru/index.htm/c/4

Товарищи! Активнее!

Вывод шаблона с заменой переменных


Код: print ShowTemplate("полный путь к файлу");


sub ShowTemplate {

my ($fname, $ErrMsg,$Handy) = @_;
my ($tmp, $data);
if ($handy=='1')
{ $tmp = $fname; }
else
{ open (F,"$fname") or return "(not found [$fname])";
$tmp=$/; undef $/; $data=<F>; $/=$tmp;
close(F); }

#А здесь начинаем менять переменные

$data =~ s/\$a1/Привет/g;
$data =~ s/\$a2/с/g;
$data =~ s/\$a3/большого/g;
$data =~ s/\$a4/бодуна/g;

return $data;
}

Реализация всплывающих сообщений(тема с последним ответом становится первой в списке) для форума на файловой системе; данный учаток находится в функции сохранения ответа. В $_[0] передается номер темы(id файла):

Код:
subj_up($sid);

sub subj_up {
$subj_num=$_[0];
#Открываем файл-список тем и кидаем содержимое в массив
open(MN, "$head_file") or die "Cant open header file!";
@header=<MN>;
close(MN);

#Перебираем полученный массив и если находим в нем соотв. тему,
#кидаем ее номер в переменную $tmp
$num="subj=$subj_num";
for ($i=0; $i<@header; $i++) {
if ($header[$i]=~m/$num/i) {
$tmp=$i;
}
}

#Делаем блокировку по семафору(ф-ции lock и unlock думаю нет смысла приводить)
#Открываем файл-список на запись, печатаем туда элемент массива с номером $tmp
#По циклу кидаем все остальные элементы, не забыв пропустить $header[$tmp]
#Закрываем файл и отлочиваем семафор - усе в порядке
&lock;
open(MN, ">$head_file");
print MN $header[$tmp];
for ($i=0; $i<@header; $i++) {
if ($i!=$tmp) {
print MN $header[$i];
}
}
close(MN);
&unlock;
}

Делаем в форуме(чате) встроенные таги, покажу на примере тага смены цвета сообщения:

Код:
while ($body=~m/\[c\s*=\s*(#{0,1}[a-z0-9]{0,12})\s*\]/igc) {
$setcolor=$1;
$body=~s/\[c\s*=\s*(#{0,1}[a-z0-9]{0,12})\s*\]/<font color=\"$setcolor\">/i;
}
while ($body=~s/\[\/c\]/<\/font>/i) {}

CheRt

Цитата:

$body=~m/\[c\s*=\s*(#{0,1}[a-z0-9]{0,12})\s*\]/igc

тогда лучше
(#?[a-f0-9]{0,6}|[a-zA-Z]+)
Потому как цвета можно и словами указывать: black, aquamarine, azure и т.д.