Несколько полезных решений для perl

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