Всякие приятности

sub chehttp {
my $str_with_http = shift;
$str_with_http =~ s/(http:\/\/[\w,\.,\-,\&,\/,\~]+)/\<a href=\"$1\"\>$1\<\/a\>/ig;
return $str_with_http;
}

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}
}

sub chdel {my $chdel_mem=shift; $chdel_mem=~ s/[\x0D\x0A]//g; return $chdel_mem}

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;
}

$ScrHost=$ENV{'HTTP_HOST'};
$ScrName=$ENV{'SCRIPT_NAME'};
($ScrName, $ScrName1) = split(/\?/, $ScrName);
$ScrFullPath="$ScrHost$ScrName";
$ScrFullPatha=substr($ScrFullPath, 0, 7);
$ScrFullPatha=~tr/a-z/A-Z/;
if ($ScrFullPatha ne 'HTTP://'){$ScrFullPath="http://$ScrFullPath";}

sub proLinker{
my $text = shift;
$text =~ s~([^\w\"\=\[\]]|[\A\n\b])\\*(\w+://[^<>\s\n\"\]\[]+)~$1<a href="$2" target="_blank">$2</a>~isg;
$text =~ s~([^\"\=\[\]/\:]|[\A\n\b])\\*(www\.[^<>\s\n\]\[]+)~$1<a href="http://$2" target="_blank">$2</a>~isg;
$text =~ s~([^\f\"\=\[\]]|[\A\n\b])\\*(\f+://[^<>\s\n\"\]\[]+)~$1<a href="$2" target="_blank">$2</a>~isg;
$text =~ s~([^\"\=\[\]/\:]|[\A\n\b])\\*(ftp\.[^<>\s\n\]\[]+)~$1<a href="ftp://$2" target="_blank">$2</a>~isg;
$text =~ s~(\S+?)\@(\S+)~<a href="mailto:$1\@$2">$1\@$2</a>~isg;
return $text;
}

sub htmlEncode {
my $text = shift;

$text =~ s!&!&amp;!g;
$text =~ s!>!&gt;!g;
$text =~ s!<!&lt;!g;
$text =~ s!\"!&quot;!g;

return $text;
}

sub unHTML {
my $text = shift;
my %ENT=('<'=>'lt','>'=>'gt','"'=>'quot');
$text =~ s!([<>"])!&$ENT{$1};!g;
$text =~ s|<!--|<!--|g;
$text =~ s|-->|-->|g;
$text =~ s|<script>|<script>|ig;
$text =~ s|  | &nbsp;|g;
$text =~ s|^\$+$|&#36|g;
$text =~ s|\@|@|g;
$text =~ s!\|!|!g;
$text =~ s|\{|{|g;
$text =~ s|\}|}|g;
$text =~ s|\\,|,|g;
$text =~ s|\~|~|g;
$text =~ s|'|'|g;
$text =~ s|\n|<br>|g;
$text =~ s|\s+$||g;
$text =~ s|\$|&#36|g;
$text =~ s|\r||g;
$text =~ s!\\!\!g;

return $text;
}

sub doHTML {
my $text = shift;

$text =~ s/@/\@|g;
$text =~ s/'/'/g;
$text =~ s/\&lt;/</g;
$text =~ s/\&gt;/>/g;
$text =~ s!&#36!\$!g;
$text =~ s/|/\|/g;
$text =~ s/+/\+/g;
$text =~ s/*/\*/g;
$text =~ s/)/\)/g;
$text =~ s/(/\(/g;
$text =~ s/,/,/g;
$text =~ s/}/\}/g;
$text =~ s/{/\{/g;
$text =~ s/\/\\/g;
$text =~ s/&quot;/"/g;
$text =~ s/&amp;/&/g;

return $text;
}

sub fieldsort {
           my ($sep, $cols);
           if (ref $_[0]) {
               $sep = '\\s+'
           } else {
               $sep = shift;
           }
           unless (ref($cols = shift) eq 'ARRAY') {
               die "fieldsort columns must be in anon array";
           }
           my (@sortcode, @col);
           my $col = 1;
           for (@$cols) {
               my ($a, $b) = /^-/ ? qw(b a) : qw(a b);
               my $op = /n$/ ? '<=>' : 'cmp';
               push @col, (/(\d+)/)[0] - 1;
               push @sortcode, "\$${a}->[$col] $op \$${b}->[$col]";
               $col++;
           }
           my $sortfunc = eval "sub { " . join (" or ", @sortcode) . " } ";
           my $splitfunc = eval 'sub { (split /$sep/o, $_)[@col] } ';
           return
               map $_->[0],
               sort { $sortfunc->() }
               map [$_, $splitfunc->($_)],
               @_;
       }