Готовые решения :: Perl

:: Готовые решения, возможно здесь уже есть ответ на ваш воп

Подписка на тему | Сообщить другу | Версия для печати

Bolt

Дата Четверг, 01 Апреля 2004, 14:33 |

ВОвебовец

Группа: Moderator
Сообщений: 914

Статус: Offline

# если в строке есть урл то возвращает html гиперссылку на него

CODE

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 гиперссылку на него

CODE

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

# Проверка почтового адреса на стоп символы

CODE

sub mailstop {
my $stopmail=shift;
# есть стоп символы (1) !!!
if ($stopmail=~ tr/\/\\\+=~;<>*|`&$!#()[]{}:'" //) {return 1} else {return 0}
}

# удаление символов перевода каретки для WinNT&Unix кодировок

CODE

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

# Перекодировщик win <-> koi <-> iso <-> dos
# $str=encoder($str,"win","dos");
# $str=encoder($str,"dos","uc");
# $str=encoder($str,"dos","lc");

CODE

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

источник: http://pvdlab.net/
# полный путь до скрипта (нужно для вставки пути в формы):

CODE

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

##Пролинковка (расставление ссылок): /еще один вариант/

CODE

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

#Замена тегов

CODE

sub htmlEncode {
my $text = shift;

$text =~ s!&!&!g;
$text =~ s!>!>!g;
$text =~ s!<!<!g;
$text =~ s!\"!"!g;

return $text;
}

#Квотим HTML:

CODE

sub unHTML {
my $text = shift;
my %ENT=('<'=>'lt','>'=>'gt','"'=>'quot');
$text =~ s!([<>"])!&$ENT{$1};!g;
$text =~ s||-->|g;
$text =~ s|<script>|<script>|ig;
$text =~ s| |  |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;
}

#... и обратная процедура:

CODE

sub doHTML {
my $text = shift;

$text =~ s/@/\@|g;
$text =~ s/'/'/g;
$text =~ s/\</</g;
$text =~ s/\>/>/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/"/"/g;
$text =~ s/&/&/g;

return $text;
}

Добавлено:
#Сортировка строк по полям, разделенным символом.
#Например, хочу отсортировать строки, разделенные на поля запятой,

CODE

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->($_)],
@_;
}

#Примеры:
#сначала по второму полю по числам, затем по первому полю по алфавиту в порядке убывания.
#@sorted = fieldsort ':', ['2n', -1], @data;
# по 2-му затем по 1-му полю, по алфавиту, разделены пробелами
#@sorted = fieldsort [2, 1], @data;
# по 1-му полю по числам в порядке убывания, затем по 3-му полю
# по алфавиту и по 2-му по числам, поля разделены '+'
#@sorted = fieldsort '+', ['-1n', 3, 2], @data;

--------------------

Хорошо там, где нас нет... И там это хорошо понимают.

Профиль · PM · Цитировать

Bolt

Дата Четверг, 05 Августа 2004, 11:35 |

ВОвебовец

Группа: Moderator
Сообщений: 914

Статус: Offline

функция определения страны по домену в адресе + хэш кодов ответов сервера

CODE

sub Get_Domain {
my($input)=@_;
%CountryCodes = (
'ad','Andorra',
'ae','United Arab Emirates',
'af','Afghanistan',
'ag','Antigua and Barbuda',
'ai','Anguilla',
'al','Albania',
'am','Armenia',
'an','Netherlands Antilles',
'ao','Angola',
'aq','Antarctica',
'ar','Argentina',
'as','American Samoa',
'at','Austria',
'au','Australia',
'aw','Aruba',
'az','Azerbaijan',
'ba','Bosnia and Herzegovina',
'bb','Barbados',
'bd','Bangladesh',
'be','Belgium',
'bf','Burkina Faso',
'bg','Bulgaria',
'bh','Bahrain',
'bi','Burundi',
'bj','Benin',
'bm','Bermuda',
'bn','Brunei Darussalam',
'bo','Bolivia',
'br','Brazil',
'bs','Bahamas',
'bt','Bhutan',
'bv','Bouvet Island',
'bw','Botswana',
'by','Belarus',
'bz','Belize',
'ca','Canada',
'cc','Cocos (Keeling) Islands',
'cf','Central African Republic',
'cg','Congo',
'ch','Switzerland',
'ci','Cote DIvoire (Ivory Coast)',
'ck','Cook Islands',
'cl','Chile',
'cm','Cameroon',
'cn','China',
'co','Colombia',
'cr','Costa Rica',
'cs','Czechoslovakia (Former)',
'cu','Cuba',
'cv','Cape Verde',
'cx','Christmas Island',
'cy','Cyprus',
'cz','Czech Republic',
'de','Germany',
'dj','Djibouti',
'dk','Denmark',
'dm','Dominica',
'do','Dominican Republic',
'dz','Algeria',
'ec','Ecuador',
'ee','Estonia',
'eg','Egypt',
'eh','Western Sahara',
'er','Eritrea',
'es','Spain',
'et','Ethiopia',
'fi','Finland',
'fj','Fiji',
'fk','Falkland Islands (Malvinas)',
'fm','Micronesia',
'fo','Faroe Islands',
'fr','France',
'fx','France (Metropolitan)',
'ga','Gabon',
'gb','Great Britain (UK)',
'gd','Grenada',
'ge','Georgia',
'gf','French Guiana',
'gh','Ghana',
'gi','Gibraltar',
'gl','Greenland',
'gm','Gambia',
'gn','Guinea',
'gp','Guadeloupe',
'gq','Equatorial Guinea',
'gr','Greece',
'gs','S. Georgia and S. Sandwich Islands',
'gt','Guatemala',
'gu','Guam',
'gw','Guinea-Bissau',
'gy','Guyana',
'hk','Hong Kong',
'hm','Heard and McDonald Islands',
'hn','Honduras',
'hr','Croatia (Hrvatska)',
'ht','Haiti',
'hu','Hungary',
'id','Indonesia',
'ie','Ireland',
'il','Israel',
'in','India',
'io','British Indian Ocean Territory',
'iq','Iraq',
'ir','Iran',
'is','Iceland',
'it','Italy',
'jm','Jamaica',
'jo','Jordan',
'jp','Japan',
'ke','Kenya',
'kg','Kyrgyzstan',
'kh','Cambodia',
'ki','Kiribati',
'km','Comoros',
'kn','Saint Kitts and Nevis',
'kp','North Korea',
'kr','South Korea',
'kw','Kuwait',
'ky','Cayman Islands',
'kz','Kazakhstan',
'la','Laos',
'lb','Lebanon',
'lc','Saint Lucia',
'li','Liechtenstein',
'lk','Sri Lanka',
'lr','Liberia',
'ls','Lesotho',
'lt','Lithuania',
'lu','Luxembourg',
'lv','Latvia',
'ly','Libya',
'ma','Morocco',
'mc','Monaco',
'md','Moldova',
'mg','Madagascar',
'mh','Marshall Islands',
'mk','Macedonia',
'ml','Mali',
'mm','Myanmar',
'mn','Mongolia',
'mo','Macau',
'mp','Northern Mariana Islands',
'mq','Martinique',
'mr','Mauritania',
'ms','Montserrat',
'mt','Malta',
'mu','Mauritius',
'mv','Maldives',
'mw','Malawi',
'mx','Mexico',
'my','Malaysia',
'mz','Mozambique',
'na','Namibia',
'nc','New Caledonia',
'ne','Niger',
'nf','Norfolk Island',
'ng','Nigeria',
'ni','Nicaragua',
'nl','Netherlands',
'no','Norway',
'np','Nepal',
'nr','Nauru',
'nt','Neutral Zone',
'nu','Niue',
'nz','New Zealand (Aotearoa)',
'om','Oman',
'pa','Panama',
'pe','Peru',
'pf','French Polynesia',
'pg','Papua New Guinea',
'ph','Philippines',
'pk','Pakistan',
'pl','Poland',
'pm','St. Pierre and Miquelon',
'pn','Pitcairn',
'pr','Puerto Rico',
'pt','Portugal',
'pw','Palau',
'py','Paraguay',
'qa','Qatar',
're','Reunion',
'ro','Romania',
'ru','Russian Federation',
'rw','Rwanda',
'sa','Saudi Arabia',
'sb','Solomon Islands',
'sc','Seychelles',
'sd','Sudan',
'se','Sweden',
'sg','Singapore',
'sh','St. Helena',
'si','Slovenia',
'sj','Svalbard and Jan Mayen Islands',
'sk','Slovak Republic',
'sl','Sierra Leone',
'sm','San Marino',
'sn','Senegal',
'so','Somalia',
'sr','Suriname',
'st','Sao Tome and Principe',
'su','USSR (Former)',
'sv','El Salvador',
'sy','Syria',
'sz','Swaziland',
'tc','Turks and Caicos Islands',
'td','Chad',
'tf','French Southern Territories',
'tg','Togo',
'th','Thailand',
'tj','Tajikistan',
'tk','Tokelau',
'tm','Turkmenistan',
'tn','Tunisia',
'to','Tonga',
'tp','East Timor',
'tr','Turkey',
'tt','Trinidad and Tobago',
'tv','Tuvalu',
'tw','Taiwan',
'tz','Tanzania',
'ua','Ukraine',
'ug','Uganda',
'uk','United Kingdom',
'um','US Minor Outlying Islands',
'us','United States',
'uy','Uruguay',
'uz','Uzbekistan',
'va','Vatican City State (Holy See)',
'vc','Saint Vincent and the Grenadines',
've','Venezuela',
'vg','Virgin Islands (British)',
'vi','Virgin Islands (US)',
'vn','Viet Nam',
'vu','Vanuatu',
'wf','Wallis and Futuna Islands',
'ws','Samoa',
'ye','Yemen',
'yt','Mayotte',
'yu','Yugoslavia',
'za','South Africa',
'zm','Zambia',
'zr','Zaire',
'zw','Zimbabwe',
'com','US Commercial',
'edu','US Educational',
'gov','US Government',
'int','International',
'mil','US Military',
'net','Network',
'org','Non-Profit Organization',
'arpa','Old-Style Arpanet',
'nato','NATO Field',
'xxx','Unresolved Domain',
'ooo','Non-Standard Domain'
);

%RespCodes = (
'100','Code 100 Continue',
'101','Code 101 Switching Protocols',
'200','Code 200 OK',
'201','Code 201 Created',
'202','Code 202 Accepted',
'203','Code 203 Non-Authoritative Information',
'204','Code 204 No Content',
'205','Code 205 Reset Content',
'206','Code 206 Partial Content',
'300','Code 300 Multiple Choices',
'301','Code 301 Moved Permanently',
'302','Code 302 Moved Temporarily',
'303','Code 303 See Other',
'304','Code 304 Not Modified',
'305','Code 305 Use Proxy',
'400','Code 400 Bad Request',
'401','Code 401 Unauthorized',
'402','Code 402 Payment Required',
'403','Code 403 Forbidden',
'404','Code 404 Not Found',
'405','Code 405 Method Not Allowed',
'406','Code 406 Not Acceptable',
'407','Code 407 Proxy Authentication Required',
'408','Code 408 Request Time-Out',
'409','Code 409 Conflict',
'410','Code 410 Gone',
'411','Code 411 Length Required',
'412','Code 412 Precondition Failed',
'413','Code 413 Request Entity Too Large',
'414','Code 414 Request-URI Too Large',
'415','Code 415 Unsupported Media Type',
'500','Code 500 Internal Server Error',
'501','Code 501 Not Implemented',
'502','Code 502 Bad Gateway',
'503','Code 503 Service Unavailable',
'504','Code 504 Gateway Time-Out',
'505','Code 505 HTTP Version Not Supported'
);
($country)=($input=~m#\.(\w+)$#o);
$country=~tr/A-Z/a-z/; $country=~s/\d//g;
$country="xxx" if ($country eq "");
unless ($CountryCodes{$country}) { $country = "ooo"; }
$from=$CountryCodes{"$country"} if(exists($CountryCodes{"$country"}));
return $from;

}

--------------------

Хорошо там, где нас нет... И там это хорошо понимают.

Профиль · PM · Цитировать

KASРER

Дата Суббота, 01 Ноября 2008, 23:09 |

ВОспитанник

Группа: Members
Сообщений: 49

Статус: Offline

На мой взгляд функцию смены кодировки можно зделать проще!

# Перекодировщик win <-> koi <-> iso <-> dos <-> mac
# $str=encoder($str,'win','dos');

CODE

sub encoder($$$){
my ($enstring,$cfrom,$cto)=@_;
my %codefunk=(
win=>'\xc0-\xff\xa8\xb8',
dos=>'\x80-\x9f\xa0-\xaf\xe0-\xef\xf0\xf1',
iso=>'\xb0-\xdf\xe0-\xef\xa1\xf1',
mac=>'\x80-\x9f\xe0-\xfe\xdf\xdd\xde',
koi=>'\xe1\xe2\xf7\xe7\xe4\xe5\xf6\xfa\xe9-\xef\xf0\xf2-\xf5\xe6\xe8\xe3\xfe\xfb\xfd\xff\xf9\xf8\xfc\xe0\xf1\xc1\xc2\xd7\xc7\xc4\xc5\xd6\xda\xc9-\xcf\xd0\xd2-\xd5\xc6\xc8\xc3\xde\xdb\xdd\xdf\xd9\xd8\xdc\xc0\xd1\xb3\xa3'
);
if(exists($codefunk{$cfrom}) && exists($codefunk{$cto})){eval "\$enstring=~y/$codefunk{$cfrom}/$codefunk{$cto}/;"}
return $enstring;
}