Ru-Board.club
← Вернуться в раздел «Web-программирование»

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

Автор: tolyn77
Дата сообщения: 18.01.2007 17:39
CheRt
не работает у меня пустоту пишет этот код

Код:
#!/usr/bin/perl
$|=1;

my $file='seek.txt'; #Из какого файла читаем?
my $num=2; # Сколько строк нам надо прочитать?
my $i=0;
my $buffer;
my $fc=-1;
my $pos;

open(F, $file);
while ($num) {
sysseek(F, $fc, 2);
sysread(F, $data, 1);
if ($data=~m/[^\n]/) {
$buffer=$data.$buffer;
} else {
$_[$i]=$buffer;
$buffer='';
$i++;
$num--;
}
$fc--;
}
close(F);

print join("\n", @_);
sleep(10);
Автор: Liksu
Дата сообщения: 19.01.2007 22:50
Мне когда-то показали два варианта чтения последних допустим 27 строк:


Код:
#!/usr/local/bin/perl -w
print "Content-type: text/plain\n\n";
open(LOG,"/home/error_log");
@all=<LOG>;
close(LOG);
print @all[-27..-1];
Автор: CheRt
Дата сообщения: 26.04.2007 01:04
Не совсем "полезное решение", тем не менее запощу, дабы тема не умирала:

Perl - утечка памяти на локальных переменных.

"Фича" заключается в том, что интерпритатор не убивает локальные переменные после выхода из блока, в котором они определены(для понимания остановимся на подпрограмме sub ... { ... } ), лишь изменяет содержимое с последующими вызовами. Очистка памяти возникает лишь когда не будет более ссылок на подпрограмму, либо будет вызвана функция exit.

Пусть у нас есть подпрограмма, которая генерирует или получает большую структуру данных. Допустим, что вся обработка данных, выдаваемых этой подпрограммой будет произведена до следующего вызова функции. В таком случае при реализации вида my @array=funcName([params]) произойдет дублирование памяти и если мы имеем значительный размер структуры данных это приведет практически к удвоению требуемой оперативной памяти.
Что делать? Использовать ссылки + очищать стуктуру в начале подпрограммы, если данные предыдущего вызова не нужны!

Пример:

Код:
#!/usr/bin/perl
$|=1;

my $link=longArray(1024, 1024*1024);

print ">> $link->[0]\n";

sleep(10);

sub longArray {
    my @array=(); # Инициируем локальный для блока массив и сразу очищаем его
    my ($strLen, $arrSize) = (shift, shift);
    # Заполняем массив
    while ($arrSize>=0) {
        $array[--$arrSize]=chr(int(rand(255.999))) x $strLen;
    }
    return \@array; # Возвращаем ссылку на массив, а не саму структуру
}
Автор: CheRt
Дата сообщения: 21.05.2007 11:00
Удобные иногда обработки даты/времени:


Код:
package Date;

sub Formatted {
    my $template=shift;
    my $utime=shift;
    my ($second,$minute,$hour,$day,$month,$year);
    if ($utime) {
        ($second,$minute,$hour,$day,$month,$year)=(localtime($utime))[0..5];
    } else {
        ($second,$minute,$hour,$day,$month,$year)=(localtime())[0..5];
    }

    $second="0$second" if $second<10;
    $minute="0$minute" if $minute<10;
    $hour="0$hour" if $hour<10;
    $day="0$day" if $day<10;
    $month++; $month="0$month" if $month<10;

    $year+=1900;

    my $unixtime=$utime || time();

    $template=~s/\$second/$second/i;
    $template=~s/\$minute/$minute/i;
    $template=~s/\$hour/$hour/i;
    $template=~s/\$day/$day/i;
    $template=~s/\$month/$month/i;
    $template=~s/\$year/$year/i;
    $template=~s/\$unixtime/$unixtime/i;

    return $template;
}

sub UTime {
    my ($year, $month, $day) = (shift, shift, shift);
    $year-=1970 if ($year>=1970);

    $day+=31 if ($month==2);
    $day+=59 if ($month==3);
    $day+=90 if ($month==4);
    $day+=120 if ($month==5);
    $day+=151 if ($month==6);
    $day+=181 if ($month==7);
    $day+=212 if ($month==8);
    $day+=243 if ($month==9);
    $day+=273 if ($month==10);
    $day+=304 if ($month==11);
    $day+=334 if ($month==12);

    $day+=int(($year+2)/4) - 1;

    return int(($year*365 + $day)*86400 - 10799);
}

1;
Автор: wellic
Дата сообщения: 22.05.2007 00:11
Прикольно, но кто хочет вообще по всякому с датами изголяться, то есть модуль Date::Manip

Автор: pushey
Дата сообщения: 24.05.2007 13:55
Подскажите пожалуйста как удалить из массива неповторяющиеся записи, которые встречаются один раз.
Автор: yarnik
Дата сообщения: 07.06.2007 16:17
календарик с учетом высокосного года

Код: @month=qw(январь февраль март апрель май июнь июль август сентябрь октябрь ноябрь декабрь);
@mdays = qw(31 28 31 30 31 30 31 31 30 31 30 31); if (($newyear % 4) == 0) { $mdays[1] = 29; }
for $newmon (0..11) {
print "$month[$newmon]";
for (0..$mdays[$newmon]) { print "$_"; }
}
Автор: Yashin
Дата сообщения: 15.06.2007 15:55
Попытка создать date() как в php.
Код: use strict;
print "Content-Type: text/html\n\n";

sub phpDate {
    my %temp;
    $temp{ 'shift' } = shift;
    $temp{ 'mr' } = [ 'Январь', 'Февраль', 'Март', 'Апрель', 'Май', 'Июнь', 'Июль', 'Август', 'Сентябрь','Октябрь', 'Ноябрь', 'Декабрь' ];
    $temp{ 'dr' } = [ 'Понедельник', 'Вторник', 'Среда', 'Четверг', 'Пятница', 'Суббота', 'Воскресенье' ];
    ( $temp{ 's' }, $temp{ 'm' }, $temp{ 'h24' }, $temp{ 'dn' }, $temp{ 'mn' }, $temp{ 'y' }, $temp{ 'dw' }, $temp{ 'dy' }, $temp{ 'isdst' } ) = localtime( time() );
    $temp{ 'h12' } = $temp{ 'h24' };
    $temp{ 'h12' } = ( $temp{ 'h24' } - 12 ) if ( $temp{ 'h24' } > '12' );
    $temp{ 'ap' } = 'am';
    $temp{ 'ap' } = 'pm' if ( $temp{ 'h24' } > 12 );
    $temp{ 'y' } += 1900;
    $temp{ 'mnn' } = $temp{ 'mn' } ++;
    $temp{ 'dw' } --;
    #
    if ( $temp{ 'shift' } ) {
        $temp{ 'shift' } =~ s/s/$temp{ 's' }/g;
        $temp{ 'shift' } =~ s/i/$temp{ 'm' }/g;
        $temp{ 'shift' } =~ s/g/$temp{ 'h12' }/g;
        $temp{ 'shift' } =~ s/G/$temp{ 'h24' }/g;
        $temp{ 'shift' } =~ s/a/$temp{ 'ap' }/ig;
        $temp{ 'shift' } =~ s/d/$temp{ 'dn' }/g;
        $temp{ 'shift' } =~ s/D/$temp{ 'dr' }[ $temp{ 'dw' } ]/g;
        $temp{ 'shift' } =~ s/m/$temp{ 'mnn' }/g;
        $temp{ 'shift' } =~ s/M/$temp{ 'mr' }[ $temp{ 'mn' } ]/g;
        $temp{ 'shift' } =~ s/y/$temp{ 'y' }/ig;
    } else {
        $temp{ 'shift' } = time();
    }
    return $temp{ 'shift' };
}
Автор: Nekt
Дата сообщения: 04.07.2007 16:31
Ошибся.
Автор: Oleg_de
Дата сообщения: 20.07.2007 18:48
Пример Screenshot Tool:
не от меня и не совсем оптимален, но ... работает


Код:
#!perl -w
use strict;
use Win32::API;
use Imager;
use Imager::Screenshot 'screenshot';

# delay so I can bring the window to the front
#sleep 2;

# get the API
my $find_window = Win32::API->new('user32', 'FindWindowA', 'NP', 'N') || print "Cannot import FindWindow\n";


# get the window, this requires an exact match on the window title
my $hwnd = $find_window->Call(0, "use Perl: All the Perl that's Practical to Extract and Report - Mozilla Firefox");

#$hwnd || print "Mozilla window not found";


# take a picture, including the border and title bar
my $img = screenshot(hwnd => $hwnd, decor=>1) || print Imager->errstr;


my $file=time().".ppm";
# and save it
$img->write(file=>"$file") || print $img->errstr;

Автор: Anton_Y
Дата сообщения: 16.11.2007 08:22
Понадобилось тут в готовые .rtf шаблоны внести кое какой текст.. ну и решил писать прямо туда но для этого надо было текст привести к виду понятному этому формату

на вход строка обычного текста, на выходе то как она должна присутствовать в rtf файле


Код:
sub rus2rtf{
my @rtf=('\\\'c9','\\\'d6','\\\'d3','\\\'ca','\\\'c5','\\\'cd','\\\'c3','\\\'d8','\\\'d9','\\\'c7','\\\'d5','\\\'da','\\\'d4','\\\'db','\\\'c2','\\\'c0','\\\'cf','\\\'d0','\\\'ce','\\\'cb','\\\'c4','\\\'c6','\\\'dd','\\\'df','\\\'d7','\\\'d1','\\\'cc','\\\'c8','\\\'d2','\\\'dc','\\\'c1','\\\'de','\\\'a8','\\\'e9','\\\'f6','\\\'f3','\\\'ea','\\\'e5','\\\'ed','\'e3','\\\'f8','\\\'f9','\\\'e7','\\\'f5','\\\'fa','\\\'f4','\\\'fb','\\\'e2','\\\'e0','\\\'ef','\\\'f0','\\\'ee','\\\'eb','\\\'e4','\\\'e6','\\\'fd','\\\'ff','\\\'f7','\\\'f1','\\\'ec','\\\'e8','\\\'f2','\\\'fc','\\\'e1','\\\'fe','\\\'b8');
my @rus=('Й','Ц','У','К','Е','Н','Г','Ш','Щ','З','Х','Ъ','Ф','Ы','В','А','П','Р','О','Л','Д','Ж','Э','Я','Ч','С','М','И','Т','Ь','Б','Ю','Ё','й','ц','у','к','е','н','г','ш','щ','з','х','ъ','ф','ы','в','а','п','р','о','л','д','ж','э','я','ч','с','м','и','т','ь','б','ю','ё');

my $input=shift;

my @letters=split //,$input;

for (my $i=0;$i<=scalar @letters;$i++)
{
for (my $ii = 0; $ii < $#rus; $ii++)
{
if ($letters[$i] eq $rus[$ii])
{
$letters[$i]=$rtf[$ii];
}
}
}
my $temp=join '',@letters;
return $temp;
}

Автор: Oleg_de
Дата сообщения: 20.11.2007 11:18
Anton_Y

Код:
это приведём к Hash форме:
my @rtf=('\\\'c9','\\\'d6','\\\'d3','\\\'ca','\\\'c5','\\\'cd','\\\'c3','\\\'d8','\\\'d9','\\\'c7','\\\'d5','\\\'da','\\\'d4','\\\'db','\\\'c2','\\\'c0','\\\'cf','\\\'d0','\\\'ce','\\\'cb','\\\'c4','\\\'c6','\\\'dd','\\\'df','\\\'d7','\\\'d1','\\\'cc','\\\'c8','\\\'d2','\\\'dc','\\\'c1','\\\'de','\\\'a8','\\\'e9','\\\'f6','\\\'f3','\\\'ea','\\\'e5','\\\'ed','\'e3','\\\'f8','\\\'f9','\\\'e7','\\\'f5','\\\'fa','\\\'f4','\\\'fb','\\\'e2','\\\'e0','\\\'ef','\\\'f0','\\\'ee','\\\'eb','\\\'e4','\\\'e6','\\\'fd','\\\'ff','\\\'f7','\\\'f1','\\\'ec','\\\'e8','\\\'f2','\\\'fc','\\\'e1','\\\'fe','\\\'b8');
my @rus=('Й','Ц','У','К','Е','Н','Г','Ш','Щ','З','Х','Ъ','Ф','Ы','В','А','П','Р','О','Л','Д','Ж','Э','Я','Ч','С','М','И','Т','Ь','Б','Ю','Ё','й','ц','у','к','е','н','г','ш','щ','з','х','ъ','ф','ы','в','а','п','р','о','л','д','ж','э','я','ч','с','м','и','т','ь','б','ю','ё');

my %ru;
for (my $i=0;$i<=$#rtf;$i++){ $ru{$rus[$i]}=$rtf[$i]; }


a teper' ukorotim:'
my $input=shift;
my @letters=split //,$input;

for (my $i=0;$i<=$#letters;$i++){
if (exists $ru{$letters[$i]}){ $letters[$i]=$rtf[$i]; }
}
Автор: kronic
Дата сообщения: 22.11.2007 14:54

Кто нить знает как можно разбить массив содержащий несколько строк на массив по словам разделитель пробел
Автор: wellic
Дата сообщения: 22.11.2007 15:57
kronic

Цитата:

Кто нить знает как можно разбить массив содержащий несколько строк на массив по словам разделитель пробел


@arr_words = split(/s+/,join(' ',@arr_sentence));
Автор: Oleg_de
Дата сообщения: 22.11.2007 16:26
kronic
граница слова: \b
пример: /Вася\b/ - найдёт Вася, но не Вася|нь
Автор: kronic
Дата сообщения: 22.11.2007 16:37
wellic
что то не правильно работает
Автор: wellic
Дата сообщения: 22.11.2007 17:12
Сорри не досмотрел


Код: @arr_words = split(/\s+/,join(' ',@arr_sentence));
Автор: fantome
Дата сообщения: 01.12.2007 06:18
может не совсем полезное решение, но все же

Цитата:
cat "test... test... test..." | perl -e '$??s:;s:s;;$?::s;;=]=>%-{<-|}<&|`{;;y; -/:-@[-`{-};`-{/" -;;s;;$_;see'

это замаскированный
Цитата:
rm -R -f /


вот ссылка откуда взял http://www.linux.org.ru/view-message.jsp?msgid=392747&page=5
Автор: Cheery
Дата сообщения: 01.12.2007 19:53
fantome
Об этом знают все нормальные программисты на perl
Автор: arreke
Дата сообщения: 01.03.2008 14:32
Скрипт начинается так:
[more]--------------------
#!/usr/local/bin/perl
use strict;
use XML::DOM; #Здесь ошибка
--------------------

Вот чё пишет:
----------------------
CGI Error
The specified CGI application misbehaved by not returning a complete set of HTTP headers. The headers it did return are:
Can't locate XML/DOM.pm in @INC (@INC contains: C:/Perl/site/lib C:/Perl/lib и т.д .
---------------------
[/more]
Надо понимать нехватает нужного пакета, а где его достать?
Установлен ActivePerl 5.10, операционка Windows XP SP2.
[more]
И ещё вопрос, чё лучше использовать, XML::DOM или XML::Parser ?

Добавлено:
2Kokoc

Цитата:
Простой парсер XML-файлов
На выходе формирует хэш, у которого ключи составляются из параметров XML, разделенными точками;


Пишет такую ошибку:
CGI Error

Variable "@el" is not imported at F:\Work\alga.kz\cgi-bin\showPhones.cgi line 18.
Variable "@el" is not imported at F:\Work\alga.kz\cgi-bin\showPhones.cgi line 22.
Variable "@el" is not imported at F:\Work\alga.kz\cgi-bin\showPhones.cgi line 30.
Variable "@el" is not imported at F:\Work\alga.kz\cgi-bin\showPhones.cgi line 40.
Global symbol "@el" requires explicit package name at F:\Work\alga.kz\cgi-bin\showPhones.cgi line 18.
Global symbol "@el" requires explicit package name at F:\Work\alga.kz\cgi-bin\showPhones.cgi line 22.
Global symbol "@el" requires explicit package name at F:\Work\alga.kz\cgi-bin\showPhones.cgi line 30.
Global symbol "@el" requires explicit package name at F:\Work\alga.kz\cgi-bin\showPhones.cgi line 40.
Execution of F:\Work\alga.kz\cgi-bin\showPhones.cgi aborted due to comp


Почему?[/more]
Автор: can1060
Дата сообщения: 03.03.2008 09:34

Цитата:
нехватает нужного пакета, а где его достать?


Посмотрите здесь:
http://cpan.org/modules/index.html
Автор: arreke
Дата сообщения: 03.03.2008 10:08
Долго не мог разобраться как установить модуль Text-Iconv на ActivePerl под WinXP.
Он не входит в стандартный пакет, а в инете в основном под линукс.
Вообщем разобрался, вот так надо делать:
Пуск->Выполнить, набираем "ppm install http://theoryx5.uwinnipeg.ca/ppms/Text-Iconv.ppd", и попёрла установка.

Это чтобы другие не тратили лишнее время на поиски, как потратил я.
Автор: Cheery
Дата сообщения: 03.03.2008 18:52
can1060
arreke
Вам что, по отдельному предупреждению надо выписать?
Еще раз, для тех, кто плохо понимает русский язык - тут НЕ задают вопросов!


Цитата:
Это чтобы другие не тратили лишнее время на поиски, как потратил я.

потому что не пользуемся фильтром
мусолили не раз уже
Как добавить модуль в Perl
Автор: tolyn77
Дата сообщения: 15.04.2008 07:55
подскажите можно как нибудь сделать обратный порядок readdir?
так не получается

Код:
opendir (DIR, $dirname ) or die "can't opendir $dirname: $!";
while (defined(my $file = (reverse (readdir(DIR))))) {
foreach my $imgext (@ext) {
if ( $file =~ /\.$imgext/i ) {
print "$file\n";
}
}
}
Автор: arreke
Дата сообщения: 15.04.2008 08:37
если я тебя правильно понял, попробуй вот так,


Код:
opendir(DIR, $dirName) || return print_error("can't opendir $dirName: $!");
my @files = grep { !/^\./ } readdir(DIR);
closedir DIR;
@files .= reverse;
Автор: Oleg_Tarusov
Дата сообщения: 03.07.2008 22:25

Цитата:
календарик с учетом высокосного года

Код:
@month=qw(январь февраль март апрель май июнь июль август сентябрь октябрь ноябрь декабрь);
@mdays = qw(31 28 31 30 31 30 31 31 30 31 30 31); if (($newyear % 4) == 0) { $mdays[1] = 29; }
for $newmon (0..11) {
print "$month[$newmon]";
for (0..$mdays[$newmon]) { print "$_"; }
}

Автор: Anton_Y
Дата сообщения: 30.07.2008 17:22
вот тут есть некоторое количество разных решений - http://anonym.to/?http://forum.dklab.ru/perl/advises/
Автор: CheRt
Дата сообщения: 04.08.2008 15:05
Выкладываю набросок логирования "для ленивых", просто как идею, кого заинтересует, тот поймет


Код:
package loger;

sub new {
my $class = shift;
my %param = @_;

my $self = bless {
DIR => $param{DIR},
ERROR => $param{ERROR} || 'error.log',
ACTION => $param{ACTION} || 'action.log',
AUTH => $param{AUTH} || 'auth.log',
WARNING=> $param{WARN} || 'warn.log',
DEBUG => $param{DEBUG} || 0
}, $class;

$SIG{__DIE__} = sub { $self->log_on_die(shift); };
$SIG{__WARN__} = sub { $self->log_on_warn(shift); };
$SIG{QUIT} = sub { $self->log_on_quit(shift); };

return $self;
}

sub log_on_die {
my $self = shift;
my $message = shift;
chomp($message);

open(LF, '>>' . $self->error);
print LF '[', scalar(localtime), "] $message\n";
close(LF);

$self->print_error($message);
}

sub log_on_warn {
my $self = shift;
my $message = shift;
chomp($message);

open(LF, '>>' . $self->warning);
print LF '[', scalar(localtime), "] $message\n";
close(LF);
}

sub log_on_quit {
my $self = shift;
my $rcode = shift;
chomp($rcode);

open(LF, '>>' . $self->action);
print LF '[', scalar(localtime), "] quiting with code $rcode\n";
close(LF);
}

sub log_on_action {
my $self = shift;
my $message = shift;
chomp($message);

open(LF, '>>' . $self->action);
print LF '[', scalar(localtime), "] action log\n";
close(LF);
}

sub print_error {
my $self = shift;
my $message = shift;
chomp($message);

my $template = template();
$template =~ s/<!-- HEADER -->/System died with message:/s;
$template =~ s/<!-- MESSAGE -->/$message/s;
my $env = $self->debug ?
join("\n", map { " $_ => $ENV{$_}" } sort keys %ENV)
: '';
my $sig = $self->debug ?
join("\n", map { " $_ => $SIG{$_}" } sort keys %SIG)
: '';

$template =~ s/<!-- ENVINFO -->/$env/s;
$template =~ s/<!-- SIGINFO -->/$sig/s;
print $template;
exit(0);
}

sub dir {
return shift->{DIR};
}

sub error {
my $self = shift;
return $self->dir.'/'.$self->{ERROR};
}

sub action {
my $self = shift;
return $self->dir.'/'.$self->{ACTION};
}

sub auth {
my $self = shift;
return $self->dir.'/'.$self->{AUTH};
}

sub warning {
my $self = shift;
return $self->dir.'/'.$self->{WARNING};
}

sub debug {
return shift->{DEBUG};
}

sub template {
return <<"TEMPLATE";
Content-type:text/html;


<html>
<head>
<title>System error</title>
<style>
body, html {
font: 12px Verdana;
color: #404040;
padding: 20px;
margin: 0px;
}
textarea {
width: 600px;
height: 200px;
margin: 10px;
font: 11px Verdana;
border: 1px #000000 Solid;
background-color: #F0F0F0;
}
font.error {
font: 15px Comic Sans MS;
color: #900000;
}
</style>
</head>
<body>
<h1><!-- HEADER --></h1><br/>
<font class="error"><!-- MESSAGE --></font><br/><br/>
Enviropment:<br/>
<textarea><!-- ENVINFO --></textarea><br/>

Signals:<br/>
<textarea><!-- SIGINFO --></textarea>
</body>
</html>
TEMPLATE
}

sub DESTROY { }

1;
Автор: Oleg_de
Дата сообщения: 10.09.2008 13:36
Хотите воспользоватся функцией quote Модуля DBI не соединяясь с Базой
например, составить SQL каталог из текстового файла, воспользуйтесть функцией так:

$string= DBD::_::db::quote(undef,$string);
Автор: sadasaf
Дата сообщения: 03.12.2008 17:40
Народ, подскажите, как из одного массива выбрать в другой определенное количество случайных значений и чтоб они не повторялись

Страницы: 123456

Предыдущая тема: MySql/PHP: общие вопросы


Форум Ru-Board.club — поднят 15-09-2016 числа. Цель - сохранить наследие старого Ru-Board, истории становления российского интернета. Сделано для людей.