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

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

[BLOCK]
name=param
name2=param2
[INFO]
#коментарий
name4=bla bla bla bla bla bla
name2=va va va vava va va
и т.п
Короче файлы конфигов, с поддержкой коментариев и блоков.

Код:
sub ReadConfig {
my $file=shift;
die "Config not found" unless(-e $file);
my %config=();# хэш для хранения конфигурации
my $key; # ключи хэша
open(CONF,"<",$file) || die "can't open config file: $!";
while(<CONF>) {
chomp;
next if /^#/;
$key=$1 if /^\[(\w+)\]/;
if($key) {
next if /^\[/;# пропускаем строку если идет инициализация блока ([BLOCK])
my($var,$value)=split(/=/,$_);
$config{$key}{$var}=$value;
}
}
return %config;
}

Люди я понимаю может и не в тему но все же не подскажите, я поставил PHP5 + Apache, как можно узнать что все работает?
За ранее спасибо!

Простенькая функция по поиску N наиболее часто встречающихся слов в тексте. Я ее применяю для генерации ключевых слов...


Код:
sub get_keywords {
my ($text,$max_keywords)=@_;

$text=~s/<[^<>]+>//gs;
$text=~s/[\n\r]/ /gs;
$text=~s/\s{2,}/ /gs;
$text=~s/\&[a-z0-9]+\;//igs;

$text=~tr/[A-Z]/[a-z]/;
$text=~tr/[А-Я]/[а-я]/;
$text=~s/[^\sA-Za-zА-Яа-я]//gs;

my (%words,@words,$el,$c)=();

@words=split(/\s/, $text);

for (my $i=0;$i<@words;$i++) {
if (length($words[$i])>4) {
$words{$words[$i]}++;
}
}

@words=();

$c=0;
for ($i=0;$i<$max_keywords;$i++) {
$el=0;
foreach (keys %words) {
if ($el<=$words{$_}) {
$el=$words{$_};
$words[$c]=$_;
}
}
$words{$words[$c]}=0;
$c++;
}

$text=join(' ', @words);

return $text;
(%words,@_,$c,$text,$max_keywords,$i,@words)=();
}

Цитата:

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



Код:
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)=();
}

Не очень грамотная, но в бошку не лезет как ее точнее сделать!
Пример: round(2.84039011, -4) вернет число 2.8404.
Соответственно положительно число округлит до сотен, тысяч и т.д.

Цитата:

все гораздо проще
my $value = sprintf("%.4f", $value);

%.4f не округляет, а обрезает, тоесть из числа 2.84039011 получится 2.8403, а не 2.8404

# perl -e 'printf "%.4f",2.84039011'
2.8404
#

Вроде не было тут
Генерация рандомного набора символов


Код: sub GenerateID {
my ($PwdMax) = (@_);
$PwdMax = 20 if ($PwdMax < 1);
my @digit = qw(A B C D E F G H J K L M N P Q R S T U V W Y Z a b c d e f g h j k l m n p q r s t u v w y z 0 1 2 3 4 5 6 7 8 9);
my $RandomPwd;
for(1..$PwdMax){$RandomPwd .= $digit[int(rand($#digit))];}
return ($RandomPwd);
}

склонение слова по отношению к числительному.


Код:
sub declension
{
my $int = shift;
my $expressions = shift;

my $count = $int % 100;
if ($count >= 5 && $count <= 20) {
$result = $$expressions[2];
} else {
$count = $count % 10;
if ($count == 1) {
$result = $$expressions[0];
} elsif ($count >= 2 && $count <= 4) {
$result = $$expressions[1];
} else {
$result = $$expressions[2];
}
}
return $result;
}

Вот дернул у себя несколько функций для работы с DBI
Пользуюсь регулярно.


Код:
# $db must be defined as DBI object
###################
sub multiSQL{
    my $sql=shift;
    my @str=split(/\n/,$sql);
    chomp @str;
    foreach(@str){
        s/^#.*//;
        s/;(\W)*$/ \n/;
    }
    my $SQL=join(" ",@str);
    @str=split(/\n/,$SQL);
    foreach (@str){
        $db->do($_);
        &Error;
    }
}
######################
sub GetSQLCount{
    my $sql=shift;
    $sql =~ s/\blimit\b.*$//i;
    $sql=~s/select\b.*?\bfrom/SELECT count(*) AS count FROM/i;
    my $out=$db->prepare($sql);
    $out->execute(@_);
    &Error($sql);
    my $hr = $out->fetchrow_hashref;    
    return $hr->{count};
}
###################
sub select_one_db{
    my $sql=shift;
    my @args=@_;
    my $out=$db->prepare($sql);
    $out->execute(@args);
    &Error($sql);
    return $out->fetchrow_hashref;
}
###################
sub insert_db{
    my $table=shift;
    my $h_ref=shift;
    my $funk_ref=shift;
    $sql="SHOW columns FROM $table";
    my $out=$db->prepare($sql);
    $out->execute();
    my %defaults;
    while (my @output=@{$out->fetchrow_arrayref}){
        $defaults{$output[0]}=$output[4];
    }
    my %col=%{$h_ref};
    my @args, @cols;
    @args=();
    @cols=();
    foreach (sort {$a cmp $b} keys %col){
        if ($col{$_} eq ''){
            $col{$_}=$defaults{$_};
        }
        push (@cols,"`$_`");
        unless($funk_ref->{$_}){
            push (@args,$db->quote($col{$_}));
        }else{
            push (@args,$col{$_});
        }

    }
    my $last=GetLastInsert($table);

    my $sql="INSERT INTO $table (".join(" , ",@cols).") VALUES (".join(" , ",@args).") ";
    if($db->do($sql)){
        return $db->{'mysql_insertid'};
    }else{
        &Error($sql);
        return 0;
    }



}
###################
sub update_db{
    my $table=shift;
    my $h_ref=shift;
    my $w_ref=shift;
    $sql="SHOW columns FROM $table";
    my $out=$db->prepare($sql);
    $out->execute();
    my %defaults;
    while (my @output=@{$out->fetchrow_arrayref}){
        $defaults{$output[0]}=$output[4];
    }
    my %col=%{$h_ref};
    my %where=%{$w_ref};
    my @set,@where;
    @set=();
    @where=();
    foreach (sort {$a cmp $b} keys %col){
        #set default
        if ($col{$_} eq ''){
            $col{$_}=$defaults{$_};
        }
        push (@set,"`$_`=".$db->quote($col{$_}));
    }
    foreach (sort {$a cmp $b} keys %where){
        push (@where,"`$_`=".$db->quote($where{$_}));
    }
    my $sql="UPDATE $table SET ".join(" , ",@set)." WHERE ".join(" AND ",@where);
    my $res=$db->do($sql);
    &Error($sql);
    return $res;
}
###############################
sub Error{
    my $sql=shift;
#    print $q->header if $DBI::err;
    die "SQL error: \n $sql \n : ERROR: $DBI::err - $DBI::errstr" if $DBI::err;
}
###################
sub GetLastInsert{
    my %stolbs;
    my $sql="show table status like ?";
    my $out=$db->prepare($sql);
    $out->execute($_[0]);
    &Error($sql);
    %stolbs=%{$out->fetchrow_hashref};
    my %newst;
    map{$newst{lc($_)}=$stolbs{$_}}keys %stolbs;
    return $newst{auto_increment};
}
#################

#################
sub IsTableExists{
    my $table=shift;
    my $sql="show table status like ?";
    my $out=$db->prepare($sql);
    my %stolbs;
    $out->execute($table);
    return 1 if $out->rows;
    return 0;
}

sub IsColumnExists{
    my $table=shift;
    my $column=shift;
    my %info=ColumnsInfo($table);
    return exists $info{$column};
}
sub ColumnsInfo{
    #Field Type Null Key Default Extra Privileges
    my $table=shift;
    my $sql="SHOW COLUMNS FROM `$table`";
    my $out=$db->prepare($sql);
    $out->execute();
    &Error($sql);
    my %info;
    while(my $output=$out->fetchrow_hashref){
        my $field=$output->{Field};
        delete($output->{Field});
        $info{$field}=$output;
    }
    return %info;
}
sub IsIndexExists{
    my $table=shift;
    my $index=shift;
    my %info=IndexInfo($table);
    if(exists($info{$index})){
        return 1;
    }else{
        return 0;
    }
}
sub IndexInfo{
    my $table=shift;
    my $sql="SHOW INDEX FROM `$table`";
    my $out=$db->prepare($sql);
    $out->execute();
    &Error($sql);
    my %info;
    while(my $output=$out->fetchrow_hashref){
        $info{$output->{Key_name}}{$output->{Column_name}}=1;
    }
    return %info;
}

kuff
Ничего либа. А можно практические примеры использования различных функций?

kuff
Либа действительно ничего, вот только заточена она похоже под MySQL. Под ораклом не проканает, ибо синтаксис немного другой. Но задумка хорошая.

Цитата:

Ничего либа. А можно практические примеры использования различных функций?

вот пример использования
1)
$dmp= #Засовываешь сюда майскуэльный дамп - восстановит базу
multiSQL($dmp);
2) GetSQLCount
очень полезная функция к примеру есть запрос
"SELECT * FROM users WHERE country=10"
функция преобразует запрос в SELECT count(*) as count FROM users WHERE country=10
и вернет количество записей. Просто избавился от гемороя двойного запроса.
my $count_users=GetSQLCount("SELECT * FROM users WHERE country=10");
3) select_one_db
если тебе нужно получить строку таблицы по айдишке и ты знаешь что эта айдишка уникальная. Возвращает ссылку на хеш, с ключами аналогичными колонкам в запросе
my $user=select_one_db("SELECT * from user where pk_user=?",123);
$user- ссылка на хеш с колонками таблицы user
4) insert_db
вставляет запись пример
my $new_id=insert_db("user",{name=>$name, email=>$email})
возвращает ключ вставленной записи
Трабла - невозможно засунуть функцию - так не прокатит: {name=>$name, email=>$email,regdate=>"NOW()"}
5) update_db
аналогична инсерту, только апдейтит данные - третий аргумен ссылка на хеш который подставится в WHERE. Ниче не возвращает
insert_db("user",{name=>$name, email=>$email},{id=234});
6) Error - скрипт дохнет если была ошибка. не красиво но эффективно отлавливать ошибки. Съекономил целых три строчки кода.
7) GetLastInsert возвращает айдишку последней записи которая была вставлена в базу. использую ее в insert_db

Это основные функции. Дальше просто проверка на существования таблиц, колонок индексов. Возвращает true если результат проверки положительный.
есть еще ColumnsInfo но тут по исходному коду можно разобраться что она делает - просто возвращает инфу о таблице. Иногда использую если нужно проверить тип
sub is_days_tynyint{
my %info=ColumnsInfo("user");
return($info{days}->{Type}=~/tinyint/i)
}

Да, еще бы прокомментированные параметры в подпрограммах - выще было бы проф . А вообще - симпатишно.

Подскажите пожалуйста как сделать на форуме php скрытый текст
[HIDE=1]Что для этого нужно[/HIDE]

Код:

#!/usr/bin/perl -w
#простейший генератор паролей.

use strict;
my $len=11, undef my $pass;

for (1..$len)
    {
    $pass.= join '', (0..9, 'A'..'Z', 'a'..'z')[rand 64]
    }
    
print $pass; # вот и сам пароль

Такая мини-библиотечка записи логов:

Код:
# Errors logging library. Write logs into file.
# Using: $result=LogError('Error message');
# Don't set $! to 'Error message', script will make it self.
# Template variables:
# %year% - year,
# %month% - month,
# %year_day% - day of year,
# %month_day% - day of month,
# %week_day% - day of week,
# %hour% - hour,
# %minute% - minute,
# %second% - second,
# %message_text% - text of 'Error message',
# %standart_error_output% - perl error variable ($!),
# %eol% - new line (\n).

$ErrorLog_File='./ErrorLog.dat';
$ErrorLog_Semathor='./ErrorLog.sem';
$ErrorLog_Template='[%year%/%month%/%month_day%, yd=%year_day%, wd=%week_day%, %hour%:%minute%:%second%] %message_text%; $! Returned: %standart_error_output% %eol%';
$ErrorLog_Result=1;

sub LogError {
my $text=shift;

&LogError_LockSemathor;
open(ELF, ">>$ErrorLog_File") || ($ErrorLog_Result=0);
print ELF LogError_MakeOutput($text);
close(ELF);
&LogError_UnlockSemathor;

return $ErrorLog_Result;
undef $text;
}

sub LogError_MakeOutput {
my $text=shift;
my ($sec,$min,$hour,$month_day,$mon,$year,$week_day,$year_day)=LogError_MakeTime();

$_=$ErrorLog_Template;
    s/%year%/$year/igs;
    s/%month%/$mon/igs;
    s/%year_day%/$year_day/igs;
    s/%month_day%/$month_day/igs;
    s/%week_day%/$week_day/igs;
    s/%hour%/$hour/igs;
    s/%minute%/$min/igs;
    s/%second%/$sec/igs;
    s/%message_text%/$text/igs;
    s/%standart_error_output%/$!/igs;
    s/%eol%/\n/igs;

return $_;
($sec,$min,$hour,$month_day,$mon,$year,$week_day,$year_day,$text,$_)=-1;
}

sub LogError_MakeTime {
my ($sec,$min,$hour,$month_day,$mon,$year,$week_day,$year_day)=(localtime(time))[0..7];

if ($sec<10) {
$sec="0$sec";
}

if ($min<10) {
$min="0$min";
}

if ($hour<10) {
$hour="0$hour";
}

$year_day++;
$mon++;
$year+=1900;

return ($sec,$min,$hour,$month_day,$mon,$year,$week_day,$year_day);

($sec,$min,$hour,$month_day,$mon,$year,$week_day,$year_day)=-1;
}

sub LogError_LockSemathor {
open(LESEM, ">$ErrorLog_Semathor") || ($ErrorLog_Result=0);
flock(LESEM,2);
}

sub LogError_UnlockSemathor {
close(LESEM);
}

Всем привет.
Помагите плиз я установил Дэнвер све нармально и хочуустанвоить форум закинул паку upload куда надо потом в браузере пишу пути где находится файл инстал.php и окрывается окно Выбора програмы хотя Дэнвер поддержывает php почему так?

Всем хай-)
Помагите плиз...а установил форум IPB захожу на него

Ребята написал модуль для проверки CY Яндекса...
http://search.cpan.org/~kostya/WWW-Yandex-CY-1.00/lib/WWW/Yandex/CY.pm


В будущем ищите новые версии search.cpan.org запрос CY

Простейший Crawler:


Код:
#!/usr/bin/perl
$|=1;
use LWP;
use LWP::UserAgent;
my $sc_agent='Строка юзер-агента';
my $dbf='Файл, куда линки сохраним';

my $fts='pl|html|htm|php|phtml|shtml|asp|php3|php4|php5'; #типы файлов, которые остаются, после очистки мусора(картинок и т.д.)

my $temp;
my @url;
my $base_url='http://forum.ru-board.com'; #Откуда начнем "бегать"
unless ($base_url=~m/[\\\/][^\\\/\.]+$/) {$base_url=~s/[\\\/]$//g;}
$url[0]=$base_url;
my $i=0;

my $linkpos;

print "Crawler started[$base_url], working...\n";

my $j=0;
while ($i<5) { #$i<количество опрошенных страниц
$linkpos=$url[$i];
unless ($url[$i] eq '') {
    print $url[$i],"\n";
    $data=grabpage($url[$i], $sc_agent);
    $data=~s/[\r\n]+//g;
    while ($data=~m/(<a [^>]+>)/is) {
     $temp=$1; $data=~s/<a [^>]+>//is;
     $temp=~m/<a [^>]*href=['"]?([^<>'"]*)['"]?[^>]*>/is; $temp=$1;
     $temp=~s/[^a-z0-9^\.\\\/\?_\-:\+=&\%\$]+//ig;
     unless ($temp=~m/^[a-z]+:/i || $temp eq '') {
        $temp=make_full($linkpos,$temp);
         #Fixing / || \ pairs
        if ($temp=~m/^https?:\/{2}/i) {
         $temp=~s/([^:])[\\\/]{2,}/$1\//g;
        } else {
         $temp=~s/[\\\/]{2,}/\//g;
        }
         $url[$j]=$temp; #print " - $temp\n"; Разблокировать для отладки
        $j++;
     }
    }
    @url=clear_links(@url);
    @url=clean_pairs(@url);
    select(undef,undef,undef,0.01); #Ожидание между запросами страниц, дабы не перегружать машину и канал, можно убрать
}
$i++;
}

open(DF, ">$dbf");
foreach (@url) {
print DF "$_\n";
}
close(DF);

sleep(10);


sub make_full {
my $linkpos=shift;
my $link=shift;
if ($link=~m/^https?:\/{2}/i) {
return $link;
} else {
$linkpos=~s/\?[^\?]+$//;
$linkpos=~s/[\/\\][^\/\\]+\.($fts)//i;

$link=~s/^\.[\\\/]//g;
$link=~s/^[\\\/][^\\\/]+[\\\/]//g;

while ($link=~m/\.{2}[\\\/]/) {
$linkpos=~s/[\\\/][^\\\/]+[\\\/]?$//;
$link=~s/\.{2}[\\\/]//;
}

return "$linkpos/$link";
}
}

sub clean_pairs {
my %cleaned;

foreach (@_) {
$cleaned{$_}++;
}

my $i=0;
@_=();

foreach (keys %cleaned) {
$_[$i]=$_;
$i++;
}

return @_;
}

sub clear_links {
my @url=@_;
my (@temp,$j,$temp);

$j=0;
for (my $i=0;$i<@url;$i++) {
$url[$i]=~m/\.([a-z0-9]+)(\?|$)/i;
$temp=$1;
if ($fts=~m/(^|\|)$temp(\||$)/i) {
$temp[$j]=$url[$i]; $j++;
}
}

return @temp;
}

sub grabpage {
my $url=shift;
my $uagent=shift;
$uagent=~s/[^a-z0-9\.\s\/\\\?\*_\+\-]+//igs;
unless($uagent) {$uagent="NOMIA req-mod/0.1.3";}

$ua=LWP::UserAgent->new;
$ua->agent($uagent);

my $req = HTTP::Request->new(GET=>$url);
$req->content_type('text/html');

my $res = $ua->request($req);

if ($res->is_success) {
return $res->content;
} else {
return 0;
}

undef $url; undef $req; undef $uagent;
}
1;

Когда-то, где-то, нашел скрипт который хэш
{ 'a.b.c' => 'text', ... }

в

{ a => {
b => {
c => 'text'
}
}
}

#---------------------------------------------------------------------------------------------------
# flat_to_nested(\%data)
#
#---------------------------------------------------------------------------------------------------
sub flat_to_nested {
my $h = shift;
my %r;

foreach my $key ( keys(%$h) ) {
my($topKey, $lastKey, $new);
my $value = $h->{$key};
$topKey = $key;

while ( $topKey ne "" ) {
if ( $topKey =~ /(.*)\.(.*)/ ) {
$topKey = $1;
$lastKey = $2;
} else {
$lastKey = $topKey;
$topKey = "";
}

if ( defined($r{$topKey}) ) {
if ( ref $r{$topKey} eq "ARRAY" ) {
$r{$topKey}->[$lastKey] = $value;
} elsif ( ref $r{$topKey} eq "HASH" ) {
$r{$topKey}->{$lastKey} = $value;
}

last;
}

if ( $lastKey =~ /^\d+$/ ) {
$new = [];
$new->[$lastKey] = $value;
} else {
$new = {};
$new->{$lastKey} = $value;
}

$r{$topKey} = $new;
$value = $new;

}
}
return $r{""};
}

Простой парсер XML-файлов
На выходе формирует хэш, у которого ключи составляются из параметров XML, разделенными точками; текстовые строки перекодируются в CP1251 (хотя можно выбросить функцию utf2wn и использовать UTF-8)

Код:
use strict;
use XML::Parser

our @el=(); # компоненты ключей хэша
our %doc= (); # собственно данные

my $parser = new XML::Parser(Style=>'Tree');
$parser->setHandlers(Start => \&start_handler, End => \&end_handler, Char => &char_handler);
$parser->parsefile('test.xml');
# Тут все закончивается. Начинаются процедуры обработки

sub start_handler
{
my $expat = shift;
my $element = shift;
my $e;
push(@el,$element);
while (@_) {
my $attr = shift;
my $val = shift;
$e=join(".",@el).'.'.$attr;
$doc{$e} = utf2win($val);
}
}

sub char_handler {
my($expat, $data) = @_;
return if $data =~ /^\s+$/;
my $e=join(".",@el);
$doc{$e}.=utf2win($data);
}

# Конец обработки тэга.
# Внутри процедуры мы получаем ассоциативный массив,
# в котором можем анализировать $element (т.е. </element>)
# и если закрывается то, что надо - обрабатываем %
sub end_handler {
my($expat, $element) = @_;
pop @el;
# проверяем значение элемента и обрабатываем хэш
}

Шаблоны для веб-типографики

Скрипт последовательно перебирает имеющиеся шаблоны поиска, и для каждого из них пытается найти в строке все совпадения. В случае успеха совпавшая часть строки заменяется по правилу, указанному в шаблоне замены. Ниже подробно разобрана работа каждой пары шаблонов. Описания следуют в порядке увеличения сложности; этот порядок не совпадает с последовательностью шаблонов в реальном скрипте. При изменении таблицы правил следует учитывать, что исходная строка подвергается обработке в соответствии со всеми шаблонами, поэтому необходимо следить за тем, чтобы последующие правила не искажали действие предыдущих.

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

Для правильной работы регулярных выражений необходимо установить русскую локаль:


Код: use POSIX;
POSIX::setlocale (&POSIX::LC_ALL, "ru");
use locale;

О разборке текстовых файлов в кодировке DOS в Active Perl (Windows)

Чтобы использовать кодировку CP866 в регулярных выражениях, функциях lc(), uc() и пр., добавьте в начало файла:


Код:
use locale;
use POSIX qw(locale_h);
setlocale(LC_ALL,"Russian_Russia.866");

Определение айпи пользователя:


Цитата:

function getIP()
{
    if (getenv("HTTP_CLIENT_IP")) $ip = getenv("HTTP_CLIENT_IP");
    else if(getenv("HTTP_X_FORWARDED_FOR")) $ip = getenv("HTTP_X_FORWARDED_FOR");
    else if(getenv("REMOTE_ADDR")) $ip = getenv("REMOTE_ADDR");
    else $ip = "UNKNOWN";
    return $ip;
}

$ip = getIP();

Так будет немного "перловее"

Код:
sub getIP()
{
if ($ENV{'HTTP_CLIENT_IP'}) $ip=$ENV{'HTTP_CLIENT_IP'};
elsif($ENV{'HTTP_X_FORWARDED_FOR'}) $ip=$ENV{'HTTP_X_FORWARDED_FOR'};
elsif($ENV{'REMOTE_ADDR'}) $ip=$ENV{'REMOTE_ADDR'};
else $ip = 'UNKNOWN';
return $ip;
}

$ip = getIP();

Или так:

Код:
$ip='UNKNOWN';
map { $ip=$ENV{$_} if $ENV{$_}; } (HTTP_CLIENT_IP','HTTP_X_FORWARDED_FOR','REMOTE_ADDR');

Или так:


Цитата:

sub getip {
return($ENV{'HTTP_CLIENT_IP'} || $ENV{'HTTP_X_FORWARDED_FOR'} || $ENV{'REMOTE_ADDR'} || 'UNKNOWN');
}

Простая, но временами полезная при дебагинге и оптимизации вещь:

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

print "Content-type:text/plain;\n\n";
foreach (sort keys %ENV) {
if (length($_)>=16) {
print "$_\t=\t$ENV{$_}\n";
} elsif (length($_)<16 && length($_)>8) {
print "$_\t\t=\t$ENV{$_}\n";
} else {
print "$_\t\t\t=\t$ENV{$_}\n";
}
}

Читаем файл с конца(не слишком быстрое, но иногда нужное решение):


Код:
#!/usr/bin/perl
############
# Использование функции:
# @array=ioFileReadBottomLines('имя_файла', число_строк);
############
$|=1;

print join("\n", ioFileReadBottomLines($0, 34));
sleep(10);

sub ioFileReadBottomLines {
    my $file = shift;
    my $lines = abs(int(shift)) || 20;
    
    my $fc = 0;
    my ($string, @res);

    open(my $tfh, '<', $file)
        || die("Can't tail $file: $!\n");
    while ($lines)
    {
        sysseek($tfh, --$fc, 2);
        sysread($tfh, my $buffer, 1);
        if ( $buffer =~ m/[^\n]/ )
        { # Формируем строку, пока не наткнулись на перенос
            $string = $buffer.$string;
        } else
        { # Записываем очередную строку
            $string =~ s/\r//;
            unshift(@res, $string);
            $string = '';
            $lines--;
        }
    }
    close($tfh);

    return @res;