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

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

Мне когда-то показали два варианта чтения последних допустим 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];

Не совсем "полезное решение", тем не менее запощу, дабы тема не умирала:

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; # Возвращаем ссылку на массив, а не саму структуру
}

Удобные иногда обработки даты/времени:


Код:
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;

Прикольно, но кто хочет вообще по всякому с датами изголяться, то есть модуль Date::Manip

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

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

Код: @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 "$_"; }
}

Попытка создать 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' };
}

Ошибся.

Пример 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;

Понадобилось тут в готовые .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;
}

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

Цитата:

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

@arr_words = split(/s+/,join(' ',@arr_sentence));

kronic
граница слова: \b
пример: /Вася\b/ - найдёт Вася, но не Вася|нь

wellic
что то не правильно работает

Сорри не досмотрел


Код: @arr_words = split(/\s+/,join(' ',@arr_sentence));

может не совсем полезное решение, но все же

Цитата:

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

fantome
Об этом знают все нормальные программисты на perl

Скрипт начинается так:
[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]

Цитата:

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

Посмотрите здесь:
http://cpan.org/modules/index.html

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

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

can1060
arreke
Вам что, по отдельному предупреждению надо выписать?
Еще раз, для тех, кто плохо понимает русский язык - тут НЕ задают вопросов!


Цитата:

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

потому что не пользуемся фильтром
мусолили не раз уже
Как добавить модуль в Perl

подскажите можно как нибудь сделать обратный порядок 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";
}
}
}

если я тебя правильно понял, попробуй вот так,


Код:
opendir(DIR, $dirName) || return print_error("can't opendir $dirName: $!");
my @files = grep { !/^\./ } readdir(DIR);
closedir DIR;
@files .= reverse;

Цитата:

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

Код:
@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 "$_"; }
}

вот тут есть некоторое количество разных решений - http://anonym.to/?http://forum.dklab.ru/perl/advises/

Выкладываю набросок логирования "для ленивых", просто как идею, кого заинтересует, тот поймет


Код:
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;

Хотите воспользоватся функцией quote Модуля DBI не соединяясь с Базой
например, составить SQL каталог из текстового файла, воспользуйтесть функцией так:

$string= DBD::_::db::quote(undef,$string);

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