Forum Rules Здесь помогают писать скрипты

Готовые скрипты искать и обсуждать в этом форуме

 Координатор: Phoinix, Bolt
 
Ответить · Новая тема · Новый опрос

 :: Готовые решения, возможно здесь уже есть ответ на ваш воп
Bolt
Дата Четверг, 01 Апреля 2004, 14:33  | 


ВОвебовец
Group Icon
Группа: 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!&!&amp;!g;
$text =~ s!>!&gt;!g;
$text =~ s!<!&lt;!g;
$text =~ s!\"!&quot;!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|-->|-->|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;
}

#... и обратная процедура:
CODE
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;
}

Добавлено:
#Сортировка строк по полям, разделенным символом.
#Например, хочу отсортировать строки, разделенные на поля запятой,
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;


--------------------
Хорошо там, где нас нет... И там это хорошо понимают.
^
Bolt
Дата Четверг, 05 Августа 2004, 11:35  | 


ВОвебовец
Group Icon
Группа: 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;
   
   }


--------------------
Хорошо там, где нас нет... И там это хорошо понимают.
^
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;
}
^
 Быстрый Ответ
Введите ваше имя
Расширенный режим
Нормальный режим
Открытых тэгов:     Закрыть все тэги
Смайлики
smilie  smilie  smilie  smilie  smilie 
smilie  smilie  smilie  smilie  smilie 
smilie  smilie  smilie  smilie  smilie 
smilie  smilie  smilie  smilie  smilie 
smilie  smilie  smilie  smilie  smilie 
smilie         
Показать всё

Помощь по кодам форума ] [ Проверить длину сообщения ] [ Транслит из Латиницы в Кириллицу ]
 Включить подпись?
 Включить смайлики?
 Включить уведомление на e-mail при ответах?
 
0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Perl | Следующая тема »

Опции темы Ответить · Новая тема · Новый опрос

 



Rating@Mail.ru LiveInternet