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

CheRt

Цитата:

Реализация всплывающих сообщений(тема с последним ответом становится первой в списке) для форума на файловой системе; данный учаток находится в функции сохранения ответа. В $_[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;
}

Лишние тормоза.


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


Код: if ($header[$i]=~m/$num/i) {
$tmp=$i;
last;
}

может я и не заметил и это уже написано здесь, но подскажите плиз как мне осуществить перекодировку из utf-8 в win-1251, (скрипт создает страницу html с данными передаваемыми из формы прописывание charset не помогает символы все равно в utf а переключать кодировку каждый раз....)

novij
вот тут есть соответствие.. http://forum.ru-board.com/topic.cgi?forum=31&topic=0633&start=20#10 отсюда и пляши.. просто tr\\\

novij
http://www.google.ru/search?hl=ru&q=perl+utf-8+to+win-1251&btnG=%D0%9F%D0%BE%D0%B8%D1%81%D0%BA+%D0%B2+Google&lr=

batva, вот мы и развели флуд, хоть и не хотели, ну да ладно, если хочешь - прочти удали, в твоем примере есть 1 минус(я про внутренние таги): он не учитывает пробелы, а ведь любой браузер, разбирая таги, проверочку делает, а тут получается сработка только в случае отсутствия пробелов - бага!
----------
batva, забьем на пробелы(кстати циклы я задавал, только потому, что не знаю всех флагов поиска и замены, поэтому спасибки за науку ).


Код: $body =~ s/(\[color=)([A-Za-z]+|[#\dA-F]+)\](.+?)(\[\/color])/<font color=\"$2\">$3<\/font>/isg;

CheRt
Эх..
Ты ничего не понял.
Ну причем тут пробелы.

Я для этого и написал слово "пример", чтобы показать именно пример, как вместо твоего кода

Код:
while(){
blabla
}
while(){blabla}

Цитата:

еще 1 заметка, а ты уверен, что раздельная замена([color=bla_bla] и [/color]) не будет работать быстрее?!

Уверен, что не будет.

Возьми и проверь.

И еще в плане безопасности.
Почему нужно именно попарно теги обрабатывать.

Незакрытые теги, или лишние закрывающие могут вызвать очень большие проблемы.

Как подсчитать количество одинаковых элементов в массиве.

my @a = ('dog','cat','dog','slon','dog','cat');
$h{$_}+=1 foreach @a;
@k = keys %h;
print "$_ : $h{$_}" foreach (@k);

Очитстка переменной, заимствовано из ikonboard

Код:
sub clean {
my $Tmp = shift;
return '' unless defined $Tmp;
$Tmp =~ s|&|&amp;|g;
$Tmp =~ s|<!--|&#60;&#33;--|g; $Tmp =~ s|-->|--&#62;|g;
$Tmp =~ s|<script|&#60;script|ig;
$Tmp =~ s|>|&gt;|g;
$Tmp =~ s|<|&lt;|g;
$Tmp =~ s|"|&quot;|g;
$Tmp =~ s!^\s+!!;
$Tmp =~ s!\s+$!!;
$Tmp =~ s| | &nbsp;|g;
$Tmp =~ s!\|!&#124;!g;
$Tmp =~ s|\n|<br>|g;
$Tmp =~ s|\$|&#036;|g;
$Tmp =~ s|\r||g;
$Tmp =~ s|\_\_(.+?)\_\_||g;
$Tmp =~ s|\\|&#92;|g;
$Tmp =~ s|!|&#33;|g;
$Tmp =~ s|\'|&#39;|g;
return $Tmp;
}

Мониторинг времени работы скрипта:

Код: package Lib::Time;

use Time::HiRes qw( gettimeofday );

sub new
{
my $self = {};
$obref = bless $self;
$self->{create} = Time();
$self->{time} = 0;
return $obref;
}

sub start
{
my $self = shift;
my $name = shift || 'main';
$self->{$name}->{comment} = shift or '';
$self->{$name}->{start} = gettimeofday();
$self->{$name}->{count} ? ($self->{$name}->{count} += 1) : ($self->{$name}->{count} = 1);
return 0;
}

sub stop
{
my $self = shift;
my $name = shift || 'main';
$self->{$name}->{stop} = gettimeofday();
$self->{$name}->{time} += ($self->{$name}->{stop} - $self->{$name}->{start});
return $self->{$name}->{time};
}

sub get
{
my $self = shift;
my $name = shift || 'main';
return $self->{$name};
}

sub get_time
{
my $self = shift;
my $name = shift || 'main';
return sprintf("%.1f",$self->{$name}->{time}*1000);
}

sub get_count
{
my $self = shift;
my $name = shift || 'main';
return $self->{$name}->{count};
}

sub get_comment
{
my $self = shift;
my $name = shift || 'main';
return $self->{$name}->{comment};
}



############################################################
END {}

1;

Вот еще парочка полезных от меня:

Проверка ИНН

Код:
sub CheckINN {
my $inn = shift @_;
my @mno = (3, 7, 2, 4, 10, 3, 5, 9, 4, 6, 8);
my $cnt=0;
my $newinn;
return 0 if(length($inn)!=10 and length($inn)!=12);
if(length($inn) == 10 ) {
@mno=splice(@mno,2,9);
for(0..8) { $cnt+=substr($inn,$_,1)*$mno[$_]; }
$newinn = substr($inn,0,9).(($cnt%11)%10);
} else {
my $cnt1=0;
for(0..10) { $cnt1+=substr($inn,$_,1)*$mno[$_]; }
@mno=splice(@mno,1,10);
for(0..9) { $cnt+=substr($inn,$_,1)*$mno[$_]; }
$newinn = substr($inn,0,10).(($cnt%11)%10).(($cnt1%11)%10);
}
# print "INN: $inn NEWINN: $newinn ";
return ($inn eq $newinn);
}

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

а вы пробовали так:

print propis(100023),"\n";

пишет:

Use of uninitialized value in concatenation (.) or string at prop.pl line 45.
ТЫСЯЧ ДВАДЦАТЬ ТРИ РУБЛЯ 00 КОПЕЕК

Доработочки требует функция

print my $text=propis (13224),"\n";

print my $text=propis (13224),"\n"; - по вашему это важно???
дело в числе. при поступлении которого получается -> Use of uninitialized value in concatenation (.) or string at prop.pl line 45.

cr4k3r
Точно глюк!

Надо после строки
$yy[9]="ДЕВЯНОСТО";
добавить
$yy[10]="СТО";

Ага! Теперь норма. Полезная функция - особенно для бухгалтерии )

Ф-ция аналог CGI::param
Немного не дооптимизированная, но тем не менее:

Код:
sub get_params {
local ($i,$buf,@data);
local $maxsize=1024*8;

if (length($ENV{'CONTENT_LENGTH'})<=$maxsize) {
read(STDIN,$buf,$ENV{'CONTENT_LENGTH'});

@data=split(/&/,$buf);
foreach $i (0 .. $#data) {
@_=split(/=/,$data[$i]);
$_[0]=~s/%(..)/pack("c",hex($1))/ge;
$_[1]=~s/%(..)/pack("c",hex($1))/ge;
$param{$_[0]}=$_[1];
}
}

$buf=$ENV{'QUERY_STRING'};

@data=split(/&/,$buf);
foreach $i (0 .. $#data) {
@_=split(/=/,$data[$i]);
$_[0]=~s/%(..)/pack("c",hex($1))/ge;
$_[1]=~s/%(..)/pack("c",hex($1))/ge;
$param{$_[0]}=$_[1];
}

($i,@data,$buf,$maxsize,@_)=();
}

Народ, подскажите, как из одного массива выбрать в другой определенное количество случайных значений и чтоб они не повторялись, а то у меня получилась не очень красивая и тормознутая конструкция:

Код:

# @s - исходный массив, @f - массив выбраных значений

my (@f);
$s=@s; # запоминаем размер массива
$end = 10; # нужное количество значений
$end = ($s < $end)?$s:$end; # проверяем если в исходном массиве меньше элементов чем надо, то устанавливаем $end в количество исходных элементов

srand(time());

for (1..$end) {
REPEAT:
$rnd = int (rand $s);
foreach (@f) {
if ($s[$rnd] == $_) {goto REPEAT}
}
push @f,$s[$rnd];
}

use List::Util 'shuffle';
my @f = (shuffle @s)[1..$end];

## Если до этого мести переменная $var не задана, то ей присвоится 'default'
$var = $var || 'default';

Извините, тема еще жива? Нашел здесь много интересного и решил внести свой посильный вклад в общее дело:
сортировка числового массива из файла
./msr.pl --gen 1000 - создаёт in.txt с 1000 рандомных значений
./msr.pl сортирует in.txt в out.txt

Код: #!/usr/bin/perl

#~ Generation!
if ($ARGV[0]=~/--gen/i) {
open(OUT,">in.txt");
if (($ARGV[1]<10) or ($ARGV[1]>1_000_000)) {$ln=50_000} else {$ln=$ARGV[1]};
for (0..$ln) {
$z=int(rand(65535));
print OUT "$z\n";}
close (OUT);
} else {

#~ Else.. No generation - sort!
open (IN,"$ARGV[0]") or open (IN,"in.txt");
open (OUT,">$ARGV[1]") or open (OUT,">out.txt");
while (<IN>) {
chomp;
$arr[$i]=$_;
$i++;
}

@arr=sort { $a <=> $b } (@arr);
foreach (@arr) {
print OUT "$_\n";
}
}

Я тут новенький, да и вообще PHP начал заниматься не давно (хотя и это преувеличение)...прошу мне подсказать, каким образом при нажатии на кнопку инфа перемещаеться из одной <textarea> в другую....за ранее огромное спасибо....nick_galoch@mail.ru

Аплоад картинок, также легко становится аплоадом других файлв в бинарном режиме...

Код:
#!/usr/bin/perl
use CGI qw/param/;
$upload_dir='../../fimg';

if (param('action') eq 'upload') {
($check,$filename,$size)=upload();
&showform;
} else {
&showform;
}

sub showform {
print "Content-type:text/html;Charset:windows-1251\n\n";
print <<HTML;
<form method="post" action="$ENV{'SCRIPT_NAME'}" enctype="multipart/form-data">
<input type="hidden" name="action" value="upload">
<input type="file" name="filename"> <input type="submit">
</form>
HTML

if (defined $check) {
print "Успешность операции: $check<br>\nИмя файла: $filename<br>\nРазмер(ошибка, если операция не успешна): $size\n";
}
}

sub upload {
local $buffer;
local $check=1;
local $errmes='';
local $file=param('filename');
local $filename=$file;
local $size=0;

$filename=~s/^.*\\//igs;
$filename=~s/\|//gs;
if (!$filename) {$errmes="Невозможное имя файла!"; $check=0;}
if ($filename!~/(\.jpg)|(\.gif)|(\.png)|(\.bmp)|(\.tif)|(\.tiff)/i) {$errmes='Неизвестный формат!'; $check=0;}
if (-e "$upload_dir/$filename") {$errmes="Файл '$filename' уже существует!"; $check=0;}
if ($check==1) {
binmode($file);
open(IF, ">$upload_dir/$filename") or die $!;
binmode IF;
while (read($file,$buffer,1024)) {print IF $buffer; $size++;}
close(IF);
chmod 0744, "$upload_dir/$filename";
$size.='кб';
}
if ($check==1) {return ($check,$filename,$size);} else {return ($check,$filename,$errmes);}
}

Шаблонизатор Excel.
Суть: имеются два файла:
1) пустой (незаполненный) файл Excel (xls) - шаблон (форма) для последующего заполнения.
2) текстовый файл данных в виде:
<ячейка>=<значение>
(например):
A1=Отчет по товарам
A2=товар1
B2=123.56
A3=товар2
B3=10.00
и т.д.
При запуске скрипта формируется новый XLS-файл с заполненными ячейками.
Запуск: perl txt2xls имя_шаблона_xls имя_файла_данных имя результир.файла_xls

Код:
use strict;
use Cwd;
use Win32::OLE;

my $out_dir = cwd().'/';
$out_dir =~ s/\//\\/g;
my ($xls_file, $mim_file, $out_file, $line, $cell_no, $value);
my ($workbook, $woksheet, $ex);
my $help = "ЗАПУСК: txt2xls <файл-шаблон XLS> <файл данных> <результ.XLS>\n\n".
"Файл отчета должен иметь структуру:\n".
" A1=значение\n".
"где A1-ячейка, 'значение' - значение этой ячейки.\n";
my %cells = ();
($xls_file, $mim_file, $out_file) = @ARGV;
if (!(-f $xls_file) || !(-f $mim_file)) {
print "ОШИБКА: Файл(ы) не найдены\n"; print $help; exit 0;
}
open(IN,$mim_file) || die $!;
while(<IN>) {
if($_ !~ /^[\#|\;]/) {
chomp;
($cell_no, $value) = split(/=/,$_);
$cell_no =~ s/\s//g;
$value =~ s/^\s//g;
$cells{$cell_no} = $value;
}
}
close IN;
# Открываем Excel (выдрано из доки к Win32::OLE)
eval {$ex = Win32::OLE->GetActiveObject('Excel.Application')};
die "Excel not installed" if $@;
unless (defined $ex) {
$ex = Win32::OLE->new('Excel.Application', sub {$_[0]->Quit;})
or die "Oops, cannot start Excel";
}
$workbook = $ex->Workbooks->Open($out_dir.$xls_file);
my $worksheet = $workbook->Worksheets(1);
foreach $cell_no (sort keys %cells) {
$worksheet->Range($cell_no)->{Value} = $cells{$cell_no};
}
$workbook->SaveAs($out_dir.$out_file);
undef $workbook;
$ex->Quit;
undef $ex;

вот мой маленький код по пингу списка хостов из обыкновенного txt
я новичек, т.ч. не судите строго и скажу сразу что пользовался O'Reilly - Perl Cookbook

Цитата:

#!/usr/bin/perl
$file="servers.txt";
open (FILE, $file) || die "oops servers.txt" ;
@hosts=<FILE>;
close (FILE);
open (DEST, ">>logs.txt") || die "oops logs.txt" ;
foreach $host (@hosts) {
@result=`ping $host`;
print DEST @result;
}
close (DEST);

а вот так можно просто проверять есть ли хост онлайн

Цитата:

#!/usr/bin/perl
use Net::Ping::External qw(ping);

my @hosts = qw(192.168.0.1, 192.168.0.2, 192.168.3);
my $num_alive = 0;
foreach (@hosts) {
$alive = ping(hostname => $_, count => 5, size => 1024, timeout => 3);
print "$_ is alive!\n" if $alive;
print "$alive\n" if $alive;
$num_alive++;
}
print "$num_alive hosts are alive.\n";

Vodomer

Цитата:

а вот так можно просто проверять есть ли хост онлайн

маленькая поправка.
Если хост не отвечает на пинг, это еще не значит, что он оффлайн.

В качестве примера try ping ru-board.com

Как правильно решается вопрос с проверками на использование спецсимволов и пр. - в общем, чтобы не взломали? Приведите куски кода.
В каких случаях нужно делать проверку, а в каких нет?

Вот мой небольшой вклад ввиде библиотеки, с помощью которой програмить сайты будет значительно легкче и удобнее, покрайней мере я сейчас уже все делаю с помощью нее.

В данный момент библиотека содержит 19 часто используемых мною функций, некоторые из них:
- обработчик хтмл шаблонов с возможностью вызова из шаблоны функцпий ядра и вставки перл скриптов в стиле пхп (одна из CMS его уже использует)
- чтение обычных и multipart форм
- чтение куков
- обработка и вывод ошибок
- ведение Log'а
- вывод времени по шаблону
- работа с SQL
- обработка текста
- время генерации страниц и т.п.
- вывод на экран
и др.
Все функции взаимосвязаны между собой и имеют свои настройки.

Все разрабатывал и писал один я, но от чужой помощи неоткажусь, поэтому пишите свои предложения и замечания, буду рад.

Прошу любить и жаловать: http://newhit.fatal.ru/MyAPI.zip

p.s. Т.к. я библиотеку писал для личных целей, то справки пока нету, а сейчас лень писать, но если каму интересно то напишу и примеров с использованием подкину.

Добавлено:
Самая простая гостевуха с использованием библиотеки(незабудьте скачать саму библиотеку):
http://newhit.fatal.ru/guest.zip - использует SQL
http://newhit.fatal.ru/guest2.zip - неиспользует SQL
http://newhit.fatal.ru/guest3.zip - это самый интересный пример, очень наглядно показывает возможности обработчика шаблонов

Пришлось тут возиться с прикладной математикой, а получать по десятку знаков после запятой неприятно, так что ф-ция округления до степени десятки:

Код:
sub round {
my ($value,$power)=@_;

my $tmp;
$value=int($value*(10**-($power-1)));
$tmp=$value;
@_=split(//, $tmp);

$tmp=@_;
if ($_[$tmp-1]>=5) {
$value=int($value/10)+1;
} else {
$value=int($value/10);
}
$value=$value/(10**-$power);
return $value;
(@_,$_,$value,$power)=();
}

Простейший пример создания мусора из двух слов(как правило логина и пароля). На практике в нагрузочных системах такой идиотизм лучше не применять - ресурсов жрет многовато, да и не слишком грамотный. Но для примера и для простеньких скриптов вполне. Для особых извращенцев(из тех кто учится) могу посоветовать переделать с вноски в мусор айпи на скажем некое сгенерированное при входе число, которое будет кидаться в кукису.

Применять примерно так, зашли 1 раз в скрипт(или какой-то отдельный модель входа), залогинились, получили строку и давай ко всему лепить, а потом делаем compare используя соотв. логин, пасс.


Код:
sub mkhash {
my ($firstword,$secondword)=@_;

my $remip=$ENV{'REMOTE_ADDR'};
my @remip=split(//, $remip);

my @left=split(//, $firstword);
my @right=split(//, $secondword);

my $str='';

my $exp=2.718281828;

for (my $i=0;$i<@left;$i++) {
$str.=int($exp**(ord($left[$i])+ord($right[$i])+ord($remip[$i])));
}

$str=~s/[^0-9]//gs;

return $str;
($str,$firstword,$secondword,@left,@right,$i,$exp,$remip,@remip)=();
}