logo

Thursday 23rd of February 2012

Статистика сайта


Сегодня сайт посетило:7
Вчера:110
За этот месяц:2283
За этот год:5653
Всего:50656

PDF Печать E-mail
Автор: Mariya Sokunova   
18.11.2010 17:36

Создание пакетов и модулей на Perl

Пакеты создаются с помощью ключевого слова package. Пакет верхнего уровня или первоначальный текущий пакет - это "main". Если в программе встречается слово package, то это значит что начинается новый текущий пакет. Текущий пакет определяет таблицу имен для поиска переменных, функций и т.д.
Пример создания пакетов:

#!/usr/bin/perl -w
{
    package Array;
    $name = "Array";
}
{
    package String;
    $name = "String";
}

print " package Array name = $Array::name\n package String name = $String::name \n";

Пакеты позволяют разделять глобальное пространство имен.
Модуль реализуется просто как пакет, определенный в отдельном файле с тем же именем и .pm в конце. Т.е. модули это те же пакеты, только каждый в своем файле.

Подключение модулей

Модули могут подключаться с помощью директив do, use и require. Для поключения модуля он должен находиться либо в той же папке что и использующая его программа, либо в папке указанной в массиве @INC:

perl -V

При подключении модуля с помощью директивы do он в этой точке встраивается в выполняемую программу. Т.е. код модуля будет встраиваться каждый раз без учета был ли он уже подключен где либо ранее. К примеру, создадим модуль используюущий Sorting.pm :

#!/usr/bin/perl -w
package ExtendedSorting;
do 'Sorting.pm';
sub Hello{
    @array=qw( 1 2 3 4 5 );
    Sorting::print_array(\@array);
    print "ExtendedSorting sub Hello\n";
}

Создадим программу, в которой хотим использовать и функции модуля Sorting.pm и модуля ExtendedSorting.pm. Подключим оба модуля с помощью директивы do:

#!/usr/bin/perl -w
do 'ExtendedSorting.pm';
do 'Sorting.pm';
@array = qw( 1 2 3 4 5);
Sorting::print_array(\@array);
ExtendedSorting::Hello();

Использование директивы do для подключения модулей, может приводить к повторному подключению кода в программу при её запуске. Если вы включите вывод предупреждений (как в программе выше), то увидете соответствующее предупреждение:

Subroutine sort_array redefined at Sorting.pm line 5.
Subroutine print_array redefined at Sorting.pm line 9.

Для того чтобы избавиться от ошибки с повторным подключением модулей можно использовать директиву require. Если изменить код описанный выше и заменить везде do на require. То предупреждения исчезнут.

Так как с помощью директив do и require модули подключаются на этапе выполнения, то основной их проблемой является, то что нужно подключать модуль перед его использованием. Т.е. при использовании следующего кода perl выдаст ошибку:

# cat do.pl
#!/usr/bin/perl -w
#Попробуем подключить модуль в конце
#require 'ExtendedSorting.pm';
require 'Sorting.pm';
@array = qw( 1 2 3 4 5);
Sorting::print_array(\@array);
ExtendedSorting::Hello();

require 'ExtendedSorting.pm';

При компиляции ошибки нет. А при выполнении perl выдает ошибку, что библиотека не найдена:

# perl -c do.pl
do.pl syntax OK
# ./do.pl
Undefined subroutine &ExtendedSorting::Hello called at ./do.pl line 7.

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

#!/usr/bin/perl -w
#Решаем проблему повторного подключения
use Sorting;
@array = qw( 1 2 3 4 5);
Sorting::print_array(\@array);
ExtendedSorting::Hello();
#Решаем проблему использования функций модуля до его подключения
use ExtendedSorting;

При использовании директивы use немножко меняется синтаксис. В конце имени модуля .pm указывать не нужно. Плюс сам модуль всегда должен возвращать значение true. Поэтому нам необходимо переписать и подключаемый модуль ExtendedSorting.pm и в конце добавить одну строку 1;

#!/usr/bin/perl -w
package ExtendedSorting;
use Sorting;

sub Hello{
    @array=qw( 1 2 3 4 5 );
    Sorting::print_array(\@array);
    print "ExtendedSorting sub Hello\n";
}
1;

В принципе следующие два примера работают аналогично :

....
#Используем use
use ExtendedSorting;
....
#Используем require
BEGIN {
    require 'ExtendedSorting.pm';
}

Так как BEGIN это самый первый блок который выполняется программой, вне зависимости его местоположения в коде. Но лучше все-таки использовать директиву use так как она реализует еще одну удобную функциональность - импорт функций из модуля. Об этом будет рассказано ниже. Т.е. при использовании use в блоке BEGIN на этапе компиляции происходит :

BEGIN {
    require 'ExtendedSorting.pm';
    ExtendedSorting->import;
}

Если Ваши модули лежат не в стандартных папках указанных в @INC и не в тойже директории, что и вызываемая их программа, то Вы можете использовать директиву use lib. При использовании этой директивы Вы указываете компилятору, где искать ( откуда подключать) необходимые модули. К примеру,

#!/usr/bin/perl -w
#Теперь модули можно расположить в данной папке
use lib '/home/perl';
use ExtendedSorting;
use Sorting;
@array = qw( 1 2 3 4 5);
Sorting::print_array(\@array);
ExtendedSorting::Hello();

Дополнить массив @INC можно указав переменную PERL5LIB в профиле пользователя.

Экспортирование функций модуля

Для того, чтобы обращаться к функции пакета не по полному пути, к примеру, Sorting::sort_array(), а только по имени желаемой функции sort_array(), необходимо произвести экспортирование. Делается это с помощью стандартного модуля Exporter.
Сначала Вам нужно произвести наследование от этого класса:

use base Exporter;

Затем указать какие функции модуля Вы хотите экспортировать ( с помощью глобального массива @EXPORT):

our @EXPORT = qw(sort_array print_array);

Теперь при использовании пакета Sorting.pm указывать полный путь до используемой функции не надо.
Пример пакета с экспортированием:

#!/usr/bin/perl -w
package Sorting;
use base Exporter;
our @EXPORT=qw(sort_array print_array);
sub sort_array {
    $ref_array = shift;
    @{$ref_array} = sort{ $a <=> $b } @{$ref_array};
}
sub print_array{
    $ref_array = shift;
    for $item (@{$ref_array}){
        print $item,"\n";
    }
}
1;

Использование функций напрямую в программе main.pl:

#!/usr/bin/perl -w
use Sorting;
@array = qw(1 23 56 6 12);
#array isn't sorted
print_array(\@array);
#a sorting of the array
sort_array(\@array);
#array is sorted
print_array(\@array);

Как было описано выше use Sorting; преобразуется на этапе компиляции в блок:

BEGIN {
    require Sorting;
    Sorting->import;
}

Если модуль ничего не экспортирует ( функции import нет), то ничего не происходит. А в нашем примере модуль Exporter имеет функцию import и делает всю работу за нас.
Обновлено 18.11.2010 17:46
 
Локальные и глобальные переменные PDF Печать E-mail
Автор: Mariya Sokunova   
15.10.2010 17:17

Отличия переменных с лексической областью видимости от глобальных переменных

Данную статью я писала больше для себя. Поэтому, если кто-то почерпнет для себя что-нибудь полезное, я буду только рада.
Конечно, вы скажите зачем вообще нужна эта статья , если без применения директивы use strict можно спокойно пользоваться переменными $var , не указывая точно к какому типу они относятся. Но в этом случае все переменные, определенные как $var, будут видны из любой точки Вашей программы т.е. будут являться глобальными. Вообщем статью писала для себя, так что начнем.

my - совершенно закрытые переменные

Объявления с лексической областью видимости действуют только от точки, где находится объявление, и до конца самой внутренней из охватывающих областей видимости (блока , файла или eval). С помощью my создаются именно такие переменные - переменные с лексической областью видимости.
Пример 1:

#!/usr/bin/perl -w
use strict;
my $private=5;
{
    #Здесь видим внутреннюю переменную
    my $private = 10;
    print "Private = $private \n";
}
#Здесь видим наружную переменную
print "Private = $private \n";

Результат:

Private = 10
Private = 5

Пример 2:

{
    my $hello = "hello";
}
print $hello;

Результат:
При компиляции будет выдана ошибка
Global symbol "$hello" requires explicit package name
Это означает, что в пакете main:: данная переменная не объявлена, а другого пакета с этой переменной Вы не указали.

our - глобальные переменные

Повторные объявления our не имеют смысла вложенности. Каждое вложенное my создает новую переменную, как в примере 1. Каждое вложенное local создает новое значение, как в примере 5. Всякий раз, когда используется our, речь идет о той же самой глобальной переменной без учета вложенности.
Пример 3:

#Здесь значение глобальной переменной равно 5 
our $global_var=5;
{
    #Здесь изменяем значение ТОЙ ЖЕ САМОЙ переменной на 10
    our $global_var = 10;
}
#Теперь значение глобальной переменной равно 10
print "Global var = $global_var \n";

Пример 4:

{
    package Utils;
    our $sum;
    #С глобальными переменными можно работать и внутри методов
    sub create_sum{
        $sum = int(rand(5)) + 1;
    }
    sub printing_sum{
        print $sum,"\n";
    }
}
#Создаем random значение переменной sum 
Utils::create_sum;
#Выводим это значение
Utils::printing_sum;

local - позволяют давать временные значения для глобальных переменных

Вот пример для использования local для "подмены" значения глобальной переменной.
Пример 5:

{
    package Man;
    our $name = "Greg";
    our $years = 25;
    my $weight = 80;
}
#Выдаст 25
print $Man::years,"\n";
#Выдаст ошибку "Use of uninitialized value $Man::weight"
print $Man::weight,"\n";
#Выдаст исходное имя Greg
print $Man::name,"\n";
sub func{
    #Выдаст текущее число лет
    print "our var = ", $Man::years, "\n";
    local $Man::name = "James";
    #Выдаст временное значение имени James
    print "local var = ",$Man::name, "\n";
    #Увеличиваем значение глобальной переменной
    foreach (1, 2, 3, 4) {
        $Man::years+= 1;
    }
}
func;
func;
#Теперь число лет 33
print $Man::years,"\n";
#Значение глобальной переменной name Greg
print $Man::name,"\n";

Также определение переменной, как local позволяет использовать это значение не только в текущем блоке, но и во всех вызванных из данного блока подпрограммах.
Пример 6:

#!/usr/bin/perl -w
use strict;
#Даем значения глобальным переменным
our $x=10;
our $y=10;
sub Display{
        print "x = $x y=$y \n";
}
sub Create{
        my $x=15;
        local $y=20;
        print "x = $x y=$y \n";
        Display();
}
Create();

Результат :

x = 15 y=20
x = 10 y=20

no strict 'refs' - разрешить использование "нежестких"(символических) ссылок

Отключение директивы strcit 'refs' позволет получить значение переменной, не по ссылке на неё, а лишь по имени, хранящемуся в другой переменной.
Пример 7:

#!/usr/bin/perl -w
use strict;
#Даем значения глобальным переменным
our $x=10;
our $y="x";
{
    #Снимаем ограничение жестких ссылок
    no strict 'refs';
    #Выводим значение переменной х по её имени, записанному в переменную y
    print ${$y}, "\n";

}
#Здесь можно получить значение переменной х, только через "реальную" (жесткую) ссылку 
$y=\$x;
print ${$y}, "\n";

Аналогичным образом можно подставлять не только имена переменных, но и имена классов , пакетов и т.д.
 
Рассылка и получение писем PDF Печать E-mail
Автор: Mariya Sokunova   
15.06.2010 14:50

Рассылка и получение почты по протоколам SMTP и IMAP на perl.

В данной статье описывается, как отправить почту через smtp сервер gmail, а также как скачать почту с imap сервера gmail.

Отправка почты через SMTP сервер

Для передачи почты с помощью сервера smtp.gmail.com можно использовать модуль perl Net::SMTP::SSL. Этот модуль поддерживает SSL - протокол безопасности передачи данных. SSL необходим для сервера smtp.gmail.com.

Если Вы имеете ящик на gmail, то используя приведенный ниже скрипт сможете отправлять почту кому захотите через smtp сервер gmail.

Опишем основные функции модуля Net::SMTP::SSL :
Net::SMTP::SSL->new() Создает новый объект - клиент , который присоединяется к smtp серверу на указанном порту.
auth() SASL аутентификация клиента с указанными логином и паролем.
mail() Инициируем отправку сообщения.
data() Начало передачи данных.
datasend() Непосредственно отправка данных.
dataend() Конец передачи данных удаленному серверу.
Пример использования описанных функций:

### Создаем соединение с удаленным сервером, включаем отладку (Debug)
$smtp = Net::SMTP::SSL->new('smtp.gmail.com',
                             Port => 465,
                             Debug => 0));
### Аутентифицируемся на сервере - указываем свой логин пароль
$smtp->auth('user@gmail.com', 'password');
### Создаем письмо - указываем свой ящик                             
$smtp->mail('user@gmail.com'. "\n");
### Указываем кому направляется письмо, например, user@yandex.ru
$smtp->to('user@yandex.ru' . "\n");
### Непосредственно передача джанных 
$smtp->data();
$smtp->datasend("From: " . 'user@gmail.com' . "\n");
....
$smtp->dataend();
### Закрываем сокет соединения с сервером
$smtp->quit;

Получение почты с IMAP сервера

Для того чтобы иметь возможность скачивать почту (или просто лазить по ней и т.д.) с IMAP сервера gmail надо поправить настройки. Необходимо зайти на свой ящик gmail.com (с которого вы собираетесь скачивать \ проверять почту) перейти в Настройки, далее перейти на вкладку Пересылка и POP\IMAP и внизу Доступ по протоколу IMAP выбрать Включить IMAP.

При получении почты через imap сервер необходимо также, как и smtp, создавать безопасное соединение. Для создания безопасного соединения с сервером будем использовавть модуль IO::Socket::SSL , а для работы непосредственно с почтой через сервер IMAP будем использовать модуль Mail::IMAPClient.
С помощью модуля Mail::IMAPClient, можно скачивать входящую почту, почту которая лежит в папке отправленных писем, можно узнать сколько писем лежит в той или иной папке, можно удалять не нужные письма из папок и т.д.

Опишем основные функции модуля Mail::IMAPClient:
Mail::IMAPClient->new() Создается клиентское подключение к серверу imap и сразу проверяется логин пароль для аутентификации.
xlist_folders() Позволяет отобразить имена папок на почтовом ящике в локали пользователя и соответствующие каждой папке ключи, такие каr Inbox, Sent и т.д. Эти значения разбирает Mail::IMAPClient и их удобнее всего использовать для перехода по пакам.
select() Переходит на указанную папку(переставляет указатель). Все остальные операции, такие как число сообщений , поиск сообщений будут происходить в данной папке. message_count() Получаем количество сообщений в текущей или указанной папке.
search() Позволяет в текущей папке отобрать сообщения удовлетворяющие заданному критерию. "ALL" - отобрать все сообщения, "UNSEEN" - отобрать только не прочитанные сообщения.
Пример использования описанных функций:

### Создаем безопасное соединение с IMAP сервером
$socket = IO::Socket::SSL->new(PeerAddr => 'imap.gmail.com',
                               PeerPort => 993);
### Соединяемся и атунетифицируемся на сервере
$client = Mail::IMAPClient->new(Socket   => $socket,
                                User     => $username,
                                Password => $password);
### Переходим на папку с входящими письмами
$client->select("Inbox");
### Получаем число сообщений в папке входящих писем
$msgcount = $client->message_count("Inbox");
### Получаем все письма
@msgs = $client->search("ALL");
### Сохраняем отобранные письма в файл
$client->message_to_file("/home/perl/inbox_msg.txt");
### Заканчиваем соединение с сервером
$client->logout();
### Закрываем сокет
$socket->close();

Описание работы программы рассылки и скачивания писем

Программа реализована в виде модуля MailClient.pm, который удобно использовать из других скриптов. Модуль реализован с двумя экспортными функциями send_mail - для отправки почты и imap_email - для скачивания почты из папки Inbox (входящая почта). В функцию send_mail необходимо передавать 5 значений: адрес получателя, тема письма, текст письма, ваш gmail адрес и пароль соответственно. В функцию imap_email передаются 2 входных значения - это ваш gmail адрес и пароль.
К примеру, расположим модуль MailClient.pm в папке /home/mymodules. Для того чтобы модуль MailClient.pm можно было подключать во всех программа perl, а не только из программ находящихся в той же папке , что и сам модуль , нам необходимо добавить в файл /etc/profile строку:
export PERL5LIB=/home/mymodules
Далее выполнить команду:
# source /etc/profile
Таким образом модуль станет доступным для подключения для всех пользователей. Либо если прописать эту же строку только в файле /root/.bash_profile - то модуль станет доступным только пользователю root.

Текст программы с комментариями

Модуль MailClient.pm - для рассылки и скачивания писем gmail

#!/usr/bin/perl -w
################################################
# Sokunova Mariya                              #
# Пакет реализующий отправку и получение писем #
################################################
package MailClient;
### Модуль для отправки писем через SMTP сервер
use Net::SMTP::SSL;
### Модуль для создания сокета с IMAP сервером
use IO::Socket::SSL;
### Модуль для работы с IMAP сервером - для получения почты
use Mail::IMAPClient;
### Модуль для определения внешнего интерфейса нашего модуля
use Exporter;
### Наш пакет is a пакет Exporter ( у него есть функция import)
@ISA = ('Exporter');
### Создание синонимов для функций пакета ( не надо писать MailClient::send_mail )
@EXPORT = qw(send_mail imap_email);
### Функция по рассылке почты через smtp.gmail.com 
sub send_mail {
  ### Входные переменные функции
  my $to = $_[0];
  my $subject = $_[1];	
  my $body = $_[2];

  my $from = $_[3];
  my $password = $_[4];
	
  my $smtp;
  ### Конструктор для объекта клиента соединяющегося по протоколу SMTP
  ### Использовать Debug => 1 для отладки
  ### Используем SSL протокол для установки безопасного соединения
  if (not $smtp = Net::SMTP::SSL->new('smtp.gmail.com',
                                      Port => 465,
                                      Debug => 0)) 
  {
    die "Could not connect to server\n";
  }
  ### Проверка смог ли клиент аутентифицироваться с указанными параметрами
  $smtp->auth($from, $password)   || die "Authentication failed!\n";
  ### Начало почтовой транзакции
  $smtp->mail($from . "\n");
  my @recepients = split(/,/, $to);
  foreach my $recp (@recepients) {
    $smtp->to($recp . "\n");
  }
  ### Начало передачи данных
  $smtp->data();
  ### Отправка данных удаленному серверу
  $smtp->datasend("From: " . $from . "\n");
  $smtp->datasend("To: " . $to . "\n");
  $smtp->datasend("Subject: " . $subject . "\n");
  $smtp->datasend("\n");
  $smtp->datasend($body . "\n");
  ### Конец отправки данных удаленному серверу
  $smtp->dataend();
  ### Отправка команды QUIT удаленному серверу и закрытие сокет соединения
  $smtp->quit;
}
### Функция по получению почты с imap.gmail.com
sub imap_email {
  ### Входные переменные функции
  my $username = $_[0];
  my $password = $_[1];
  ### Открываем сокет с безопасным соединением с IMAP сервером
  my $socket = IO::Socket::SSL->new(
                                    PeerAddr => 'imap.gmail.com',
                                    PeerPort => 993,
                                    )
  or die "socket(): $@";
  eval {
    ### Создаем новый клиент для подключения к IMAP серверу
    ### Последовательно вызываются методы connect login
    my $client = Mail::IMAPClient->new(
                                       Socket   => $socket,
                                       User     => $username,
                                       Password => $password,
                                      )
    or die "new(): $@";


    ###  Если login метод прошел успешно статус становится Authenticated
    if ($client->IsAuthenticated()) {
      print "Authentication is OK\n";
    }
    else {
      die "Authentication is not correct\n";
    }
    ### Получение имен папок вне зависимости от локали Inbox Sent ...
    my $xlist = $client->xlist_folders;
    foreach my $key (keys %$xlist) {
      print "$key $xlist->{$key} \n";
    }
    ### Выбираем папку с входящими письмами и статус становится Selected
    $client->select("Inbox") or die "Could not select: $@\n";
    ### Получить число сообщений в папке входящие 
    ### Аналогично записи $client->message_count - для текущей выбранной папки
    my $msgcount = $client->message_count("Inbox");
    print "MSG COUNt = $msgcount \n";
    ### Вызов команды SEARCH IMAP с указанными аргументами
    my @msgs = $client->search("ALL");
    ### Сохраняем все найденные email  в файл
    $client->message_to_file("/home/gmail_emails/$username",@msgs) 
    or die "Could not message_to_file: $@\n";
    ### Вызывам команду LOGOUT IMAP. После этой команды сервер заканчивает соединение,
    ### а клиент переходит в состояние Unconnected 
    $client->logout();
  };
  ### Закрываем сокет в любом случае 
  if($@){
    ### Закрываем сокет при неудачной закачке писем	
    $socket->close();
    die "$@ \n";
  }
  else {
    ### Закрываем сокет при удачной закачке писем
    $socket->close();
  }
}
1;

Скрипт send.pl - пример подключения и использования данного модуля

#!/usr/bin/perl -w
use MailClient;

eval {
  ### Посылаем парочку сообщений
  send_mail('toYandexFriend@yandex.ru', 'MySubject', 'MyBody','myTestGmail@gmail.com','mypassword');
  send_mail('toGmailFriend@gmail.com', 'MySubject', 'MyBody','myTestGmail@gmail.com','mypassword');
};
if($@){ 
  ### Если рассылка не удалась
  print "Bad send!\n";
  print $@;
}
else{ 
  ### Если рассылка прошла успешно
  print "Good send!\n";
}
eval { 
  ### Получаем письма с нашего ящика
  imap_email('myTestGmail@gmail.com','mypassword');
};
if($@){ 
  ### Если получить письма не удалось
  print "imap_email Bad!\n";
  print $@;
}
else { 
  ### Получение входящих писем удалась - они сохранились в файл с именем нашего ящика
  print "imap_email Good!\n";
}

Исходный текст модуля: MailClient.pm
Пример программы использующей данный модуль: send.pl
 
Парсер XML PDF Печать E-mail
Автор: Mariya Sokunova   
26.02.2010 18:08

Парсер XML на языке Perl с записью выходного XML файла

Из данной статьи Вы узнаете, как распарсить XML файл, а также создать свой XML файл с необходимой структурой.

Анализатор XML файлов

Отбор необходимых узлов в дереве XML идет при помощи модулей XML::DOM, XML::DOM::Parser и XML::DOM::XPath.
Главное, чем оперируют данные модули это Node – узел. Он может содержать в себе еще узлы, может содержать строку данных, может содержать не строковые (бинарные данные), может быть пустым ( к примеру, <defect></defect>) и т.д.

Основные методы данных модулей это :
getElementsByTagName() – возвращает список нодов с заданным именем, например можно передавать "record-id" и вернеться указатель на массив из найденных узлов с таим именем.
findnodes() - по переданной строке возвращает массив из Nodes, например можно передать более длинную строку "defect/record-id". Если указать в передаваемой строке в начале 2 слеша, например, "//record-id", то поиск узлов с заданным именем будет происходить не вглубь дерева (вниз от текущего), а с самого начала с корневого элемента.
getFirstChild()->getData() – для заданного узла вернет значение, например для <record-id>22</record-id> это значение 22.
getAttributeNode() – возвращает узел-атрибут текущего узла, с именем, которое ему было передано в качестве аргумента.

Пример 1: Узел attachment имеет несколько атрибутов:
<attachment name="sps5.PNG" size="17582" create-date="20100202"/> Если в переменной $node хранится ссылка на узел attachement, то с помощью следующего кода :
my $href = $node->getAttributeNode ("create-date");
my $date =$href->getValue;
В переменную $date запишется значение 20100202.

Пример 2: На основании xml файла перебрать все узлы с именем defect:

<TestTrackData>
<defect>
	<record-id>22</record-id>
</defect>
<defect>
	<record-id>23</record-id>
<defect>
	<record-id>24</record-id>
</defect>
</TestTrackData>

Пример кода, который найдет и переберет все узлы defect:

my $dom_parser = new XML::DOM::Parser;
#Указываем файл для распарсивания
my $doc = $dom_parser->parsefile ("file.xml");
#Получить рутовый(корневой) узел
my $root = $doc->getDocumentElement();
#Вниз от корневого узла найти все узлы с именем defect
my $defects = $doc->getElementsByTagName("defect");
#Работаем с узлами defect
for(my $i=0;  $i < $defects->getLength;$i++){
    my $defect = $defects->item($i);
    …
  }

Создание XML файла заданной структуры

Для создания своих XML документов необходимо подключить модуль XML::Writer.

Основные методы данного модуля:
startTag() – создает узел с именем, переданным в качестве переменной. Функция startTag() обязательно должна заканчиваться endTag(), представляйте это себе как открывающуюся и закрывающуюся скобки.
endTag() – создает закрывающий узел, для текущего узла, к примеру </defect>, можно вызывать без переменной просто $node->endTag() можно для себя, чтобы знать какой блок (узел ) закрываешь указывать имя этого узла $node->endTag("defect").
dataElement() – сразу создает и открывающий и закрывающий блоки, и в качестве переменной можно передать значение элемента.

Пример 1: Создание узла XML документа первым способом
$node->startTag("record-id");
$node->characters("15");
$node->endTag();
 Создаст узел:
<record-id>15</record-id>

Пример 2: Создание узла XML документа вторым способом
$node->dataElement("record-id","15");
Создаст точно такой же узел в xml документе:
<record-id>15</record-id>

Пример 3: Создание узла с аттрибутом
$node->dataElement("record-id","15", 'name' => "Record1");
Такой код создаст узел с атрибутом name и значением Record1:
<record-id name="Record1">15</record-id>

Если Вам нужно, какие-то не строковые данные (например jpeg файл) вставить в xml файл, то для этого нужно использовать специальную функцию:
raw() – в которую нужно передать поток перекодированных в бинарный формат данных. Т.е. сам файл сначала подготовить с помощью функции encode_base64 (модуль MIME::Base64). Как делается вставка не строковых данных в xml файл описывается в функциях парсера create_node_attachment и encode_file .

Пример 4: Создание XML-объявления и вставка типа для XML документа
my $writer = new XML::Writer(OUTPUT => "new.xml", UNSAFE =>1);
$writer->xmlDecl('UTF-8','yes');
$writer->doctype('bugzilla',undef,'bugzilla.dtd');
…
Создает в xml файле следующие строки
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<!DOCTYPE bugzilla SYSTEM "bugzilla.dtd">
<bugzilla version="3.4.2" urlbase="http://localhost/TestTrack/"
maintainer="bugzilla@xxxxx.ru" exporter="sokunova@xxxxx.ru">

Примечание: метод doctype($name, [ $publicID, $systemID]) может вызываться либо от одного либо от трех переменных сразу. Если Вам как в примере выше параметр PUBLIC не нужен, то заменяете его значением undef.

Описание работы XML парсера

Ниже представлен код программы, которая читает и анализирует XML формат базы TestTrack и переводит его в необходимый для Bugzilla 3.4.2 формат XML файл. Если происходит перевод из одного формата в другой, как в данном примере, то необходимо сначала составить таблицу, какой узел какому будет соответствовать. В данном примере все узлы <defect> заменяются на <bug>, <defect-number> на <bug_id> и т.д. Если каких-то полей не хватает, то создаются со значениями по-умолчанию (например нулевые), а также некоторые значения приводятся к нужному формату.

Текст программы с комментариями

#!/usr/bin/perl -w
#######################################
## Sokunova Mariya 
#07.02.2010
#
# XML Parser and Creator Bugzilla's xml
#
#######################################
use strict;
use XML::Writer;
use IO::File;
use MIME::Base64 qw(encode_base64);
use XML::DOM;
use XML::DOM::XPath;
use Data::Dumper;
use File::MMagic::XS;
use Getopt::Compact;

### Функция создающая XML узел to_node с данными 
### взятыми из узла from_node
sub create_node{
  my( $defect, $writer,$from_node,$to_node) =@_;
  my @testnodes = $defect->findnodes( $from_node);

  my $node = $testnodes[0];
  my $str =$node->getFirstChild()->getData();
  $writer->dataElement($to_node,$str);
}
### Функция создания XML узлов с преобразованием 
### времени (creation_ts , delta_ts ...)
sub create_node_time{
  my( $defect, $writer,$from_node,$to_node) =@_;
  my @testnodes = $defect->findnodes( $from_node);

  my $node = $testnodes[0];
  ### Прочитали дату в формате "12.02.2010 10:29"
  my $str =$node->getFirstChild()->getData();
  my $Y = substr($str, 6, 4);
  my $m = substr($str, 3, 2);
  my $d = substr($str, 0, 2);
  ### Записали дату в формате "2010-02-12 10:29:28"
  my $formatdate= "$Y-$m-$d 10:29:28";
  $writer->dataElement($to_node,$formatdate);
}
### Функция, которая создает XML узел со значением
### переданным ей в качестве переменной value
sub create_node_value{
  my($writer,$name_node,$value) = @_;
  $writer->dataElement($name_node, $value);
}
### Функция для создания XML узла product с данными из узла from_node
sub create_node_product{
  my($defect, $writer,$from_node,$to_node) = @_;
  ### Хэш соответствия значений 
  ### TesTrack component (исходный XML) => Bugzilla product (XML на выходе)
  my %products = ("\x{41f}\x{440}\x{43e}\x{434}\x{443}\x{43a}\x{442} 1"=>"СПб - Продукт 1",
                  "\x{41f}\x{440}\x{43e}\x{434}\x{443}\x{43a}\x{442} 2"=>"СПб - Продукт 2",
                  "\x{41f}\x{440}\x{43e}\x{434}\x{443}\x{43a}\x{442} 3"=>"СПб - Продукт 3");

  my @testnodes = $defect->findnodes( $from_node);
  my $node = $testnodes[0];
  my $str =$node->getFirstChild()->getData();
  $str =~ s/(\s*)(.*)(\s*)/$2/;
  ### Можно воспользоваться функцией Dumper и модулем Data::Dumper,
  ### если вдруг на вид две строки равны, а равенство не срабатывает
  #print Dumper($str);
  my $node_text = $products{$str};
  $writer->dataElement($to_node,$node_text);
}
###Функция создания XML узла version с данными из узла from_node
sub create_node_version{
  my($defect, $writer,$from_node,$to_node) = @_;
  ### Хэш соответствия значений TestTrack product => Bugzilla version 
  my %versions = ("\x{412}\x{435}\x{440}\x{441}\x{438}\x{44f} 1" => "V1",
                  "\x{412}\x{435}\x{440}\x{441}\x{438}\x{44f} 2" => "V2",
                  "\x{412}\x{435}\x{440}\x{441}\x{438}\x{44f} 3" => "V3");

  my @testnodes = $defect->findnodes( $from_node);
  my $node = $testnodes[0];
  my $str =$node->getFirstChild()->getData();
  $str =~ s/(\s*)(.*)(\s*)/$2/;
  #print Dumper($str);
  my $node_text = $versions{$str};
  $writer->dataElement($to_node,$node_text);
}
### Функция создания XML узла bug_status из узла from_node 
sub create_node_status{
  my($defect, $writer,$from_node,$to_node) = @_;
  ### Хэш соответствия значений TestTrack defect-status => Bugzilla bug_status
  my %bug_status = ("Open" => "NEW",
                    "Open (Verify Failed)" => "NEW",
                    "Open (Re-Opened)" => "NEW",
                    "Fixed" => "RESOLVED",
                    "Closed" => "CLOSED",
                    "Closed (Fixed)" => "CLOSED",
                    "Closed (Verified)" => "CLOSED");

  my @testnodes = $defect->findnodes( $from_node);
  my $node = $testnodes[0];
  ### Получение статуса ошибки
  my $str =$node->getFirstChild()->getData();
  $str =~ s/(\s*)(.*)(\s*)/$2/;
  ### Преобразование в нужный для Bugzilla статус ошибки
  my $node_text = $bug_status{$str};
  $writer->dataElement($to_node,$node_text);
  ### Если ошибка исправлена, то еще одно поле добавляем
  if (($node_text eq "RESOLVED")||($node_text eq "CLOSED")) { 
     $writer->dataElement("resolution","FIXED");
  }

}
### Функция создания XML узла priority из узла from_node
sub create_node_priority{
  my($defect, $writer,$from_node,$to_node) = @_;
  my @testnodes = $defect->findnodes( $from_node);
  my $node = $testnodes[0];
  my $str =''.$node->getFirstChild()->getData();
  $str =~ s/(\s*)(.*)(\s*)/$2/;
  my $node_text ="";
  ### Заменяем считанное значение эквивалентным для Bugzilla
  if( ($str eq '1') || ($str eq '2')) { $node_text = "В дистрибутив";}
  elsif ($str eq '3') { $node_text = "Срочно";}
  else  { $node_text = "Несрочно";}

  $writer->dataElement($to_node,$node_text);
}

### Вспомогательная функция получения  полного имени и email по фамилии 
sub getname_email_users {
  ### Аргумент - фамилия
  my $user =$_[0];

  my %users=("Sokunova" => ["Сокунова М.А.", 'sokunova@xxxxx.ru'],
             "Ivanov" =>["Иванов Ю.Л.", 'ivanov@xxxxx.ru'],
             "Petrov" => ["Петров И.И.", 'petrov@xxxxx.ru']);

  my $name = $users{$user}[0];
  my $email = $users{$user}[1];
  ### Возвращаем полноем имя и email
  return($name, $email);
}
### Функция создания  XML узла reporter из узла from_node
sub create_node_reporter{
  my($defect, $writer,$from_node,$to_node) = @_;
  my @testnodes = $defect->findnodes( $from_node);
  my $node = $testnodes[0];
  ### Считали фамилию
  my $str =$node->getFirstChild()->getData();
  $str =~ s/(\s*)(.*?)(\s*)/$2/;
  ### Получаем массив из полного имени и email
  my @name_email = &getname_email_users($str);
  ### Создаем узел, в котором значение - полное имя, а аттрибут - email
  $writer->dataElement($to_node,$name_email[1], 'name' => $name_email[0]);
}
### Функция создания XML узла qa_contact по фамилии from_str
sub create_node_qacontact{
  my($defect, $writer,$from_str,$to_node) = @_;
  my @name_email = &getname_email_users($from_str);
  $writer->dataElement($to_node,$name_email[1], 'name' => $name_email[0]);
}
### Функция создания  XML узла assigned_to из узла from_node
sub create_node_assignedto{
  my($defect, $writer,$from_node,$to_node) = @_;
  ### Получить список фамилий на кого назначен баг
  my @testnodes = $defect->findnodes( $from_node);
  ### Если баг ни на кого не назначен - назначить на дефолтного тестера
  if ($#testnodes < 0) {
    my $str ="Sokunova";
    my @name_email = &getname_email_users($str);

    $writer->dataElement($to_node,$name_email[1], 'name' => $name_email[0]);
  }
  ### Если баг хоть на кого-то назначен
  else
  { 
    my $node = $testnodes[0];
    my $str =$node->getFirstChild()->getData();
    $str =~ s/(\s*)(.*?)(\s*)/$2/;
    my @name_email = &getname_email_users($str);
    #### Создаем узел assigned_to  с данным  полученными по первой фамилии назначенного 
    $writer->dataElement($to_node,$name_email[1], 'name' => $name_email[0]);
    #### Удаляем первый элемент из массива
    shift(@testnodes);
    ### Остальных делаем подписанными на этот баг - создаем узлы сс
    foreach my $node_cc (@testnodes) {
	  $str = $node_cc->getFirstChild()->getData();
	  $str =~ s/(\s*)(.*?)(\s*)/$2/;
	  @name_email = &getname_email_users($str);
	  	
	  $writer->dataElement('cc',$name_email[1]);

    }
  }
}

### Функция создания  XML узла long_desc из узла from_node
sub create_node_longdesc_first{
  my($defect, $writer,$from_node,$to_node) = @_;
  $writer->startTag($to_node, 'isprivate'=>'0');
  ### Определяем значение вложенного узла /found-by/last-name
  my @testnodes =$defect->findnodes( $from_node.'/found-by/last-name');
  my $node = $testnodes[0];
  my $str =$node->getFirstChild()->getData();
  $str =~ s/(\s*)(.*?)(\s*)/$2/;
  my @name_email = &getname_email_users($str);
  ### Создаем узел who с полученным значением 
  $writer->dataElement('who',$name_email[1], 'name' => $name_email[0]);
  ### Определяем значение вложенного узла /date-found
  @testnodes =$defect->findnodes( $from_node.'/date-found');
  $node = $testnodes[0];
  $str =$node->getFirstChild()->getData();
  ### Создаем узел bug_when с полученным значением 
  $writer->dataElement('bug_when',$str);
  ### Определяем значение вложенного узла /description
  @testnodes =$defect->findnodes( $from_node.'/description');
  $node = $testnodes[0];
  $str =$node->getFirstChild()->getData();
  ### Создаем узел thetext с полученным значением 
  $writer->dataElement('thetext',$str);
  $writer->endTag();
}

### Функция создания XML узла long_desc
### из узла from_node  (обработка узлов комментариев)
sub create_node_longdesc_comments{
  my($defect, $writer,$from_node,$to_node) = @_;
  ### Найти все узлы - комментарии
  my $defect_events = $defect->getElementsByTagName( $from_node);
  ### Перебираем все узлы - комментарии
  for(my $i=0;  $i < $defect_events->getLength;$i++){
    my $node = $defect_events->item($i);	
    $writer->startTag($to_node, 'isprivate'=>'0');
    my @sub_nodes = $node->findnodes('event-author/last-name');
    my $sub_node = $sub_nodes[0];
    my $str;
    ### Если Автора нет - присвоить имя дефолтного тестера
    unless((defined($sub_node->getFirstChild())))
    {
      $str= "Sokunova";
    }
    ### Если значение с фамилией автора есть - то счтитать значение
    else
    {
      $str =$sub_node->getFirstChild()->getData();
    }
    $str =~ s/(\s*)(.*?)(\s*)/$2/;
    my @name_email = &getname_email_users($str);
    ### Создать узел who c нужным значением
    $writer->dataElement('who',$name_email[1], 'name' => $name_email[0]);
    
    @sub_nodes = $node->findnodes('event-date');
    $sub_node = $sub_nodes[0];
    $str =$sub_node->getFirstChild()->getData();
    my $Y = substr($str, 6);
    my $m = substr($str, 3, 2);
    my $d = substr($str, 0, 2);
    my $formatdate= "$Y-$m-$d 10:29:28";
    $writer->dataElement('bug_when',$formatdate);
    
    ### Ищем узел комментариев
    @sub_nodes =$node->findnodes('notes');
 
    ### Если комментариев не внесли(например, просто переназначили баг),
    ### то создаем пустой узел thetext
    if($#sub_nodes <0 ) {
	   $writer->startTag('thetext');
	   $writer->endTag('thetext');
    }
    ### Иначе считываем значение и записываем в узел thetext
    else
    {
	   $sub_node =$sub_nodes[0];
	
	   $str=$sub_node->getFirstChild()->getData();
	   $writer->dataElement('thetext',$str);
    }
    ### Заканчиваем крупный узел long_desc
    $writer->endTag();
  }

}
### Функция создания XML узла attachment из узла from_node
sub create_node_attachment {
  my($defect, $writer,$from_node,$to_node) = @_;
  my $defect_attachs = $defect->getElementsByTagName($from_node);
  my $n=$defect_attachs->getLength;
  ### Перебираем все узлы так как к одной ошибке 
  ### может быть прикреплено несколько файлов
  for (my $i =0; $i < $defect_attachs->getLength; $i++) {
    my $node = $defect_attachs->item($i);
    ### Создаем корневой узел с нужными аттрибутами
    $writer->startTag('attachment','isobsolete'=>'0','ispatch'=>'0','isprivate'=>'0');
    ### Создаем первый внутренний узел
    $writer->dataElement('attachid','2');
    ### Получаем данные из узла-аттрибута create-date
    my $href = $node->getAttributeNode ("create-date");
    my $date =$href->getValue;

    my $Y = substr($date, 0, 4);
    my $m = substr($date, 4, 2);
    my $d = substr($date, 6);
    my $formatdate= "$Y-$m-$d 10:29"; 
    ### Создаем узел date с нужным значением
    $writer->dataElement('date',$formatdate);
    $href = $node->getAttributeNode ("name");
    $writer->dataElement('desc',$href->getValue);
    $writer->dataElement('filename',$href->getValue);
    $href = $node->getAttributeNode("filespec");
    my $filename = $href->getValue;

    my $magic = File::MMagic::XS->new();
    ### Получаем тип файла (text/plain text/html ...)
    my $mime = $magic->get_mime($filename);
    ### Записываем это у узел	
    $writer->dataElement('type',$mime);
    $href = $node->getAttributeNode ("sizebytes");
    $writer->dataElement('size',$href->getValue);
    $writer->dataElement('attacher','sokunova@xxxxx.ru');
    $writer->startTag('data','encoding' => 'base64');
    ### Делаем перекодировку данных файла в строку base64 
    my $encode_str = &encode_file($filename);
    ### Кладем полученную строку в значение узла data
    $writer->raw($encode_str);
    $writer->endTag('data');
    ### Закрываем корневой узел attachment
    $writer->endTag('attachment');
	
  }

}

### Функция создания из файла  base64 строки
sub encode_file {
  my $filename = $_[0];
  open(DAT, $filename) or die "$!";
  ### Открытие файла в бинарном формате
  binmode(DAT);
  my $buff;
  my $str='';
  while(read(DAT  , $buff, 60*57)){
    $str =$str. encode_base64($buff);
  }

  close(DAT);
  return $str;
}

### Функция для создания корректной структуры 
### XML файла Bugzilla из другого багтрэкера 
sub bugzilla_structure {
  my( $defect, $writer) =@_;
  ### Создание узла <bug_id>
  &create_node($defect,$writer,'defect-number','bug_id'); 
  ### Создание узла <creation_ts>
  &create_node_time($defect, $writer, 'date-created', 'creation_ts');
  ### Создание узла <short_desc>
  &create_node($defect, $writer, 'summary', 'short_desc');
  ### Создание узла <delta_ts>
  &create_node_time($defect,$writer, 'date-last-modified','delta_ts');
  ### Создание узла <reporter_accessible>
  &create_node_value($writer, 'reporter_accessible', '1');
  ### Создание узла <cclist_accessible>
  &create_node_value($writer, 'cclist_accessible', '1');
  ### Создание узла <classification_id>
  &create_node_value($writer, 'classification_id', '5');
  ### Создание узла <classification>
  &create_node_value($writer, 'classification', 'СПб');
  ### Создание узла <product>
  &create_node_product($defect,$writer,'component','product');
  ### Создание узла <component>
  &create_node_value($writer, 'component','Интерфейс пользователя');
  ### Создание узла <version>
  &create_node_version($defect,$writer,'product', 'version');
  ### Создание узла <rep_platform>
  &create_node_value($writer, 'rep_platform', 'Intel 32');
  ### Создание узла <op_sys>
  &create_node_value($writer, 'op_sys', 'Windows XP');
  ### Создание узла <bug_status>
  &create_node_status($defect,$writer,'defect-status','bug_status');
  ### Создание узла <priority>
  &create_node_priority($defect,$writer,'priority','priority');
  ### Создание узла <bug_severity>
  &create_node_value($writer, 'bug_severity','Ошибка');
  ### Создание узла <target_milestone>
  &create_node_value($writer, 'target_milestone','---');
  ### Создание узла <everconfirmed>
  &create_node_value($writer, 'everconfirmed','1');
  ### Создание узла <reporter>
  &create_node_reporter($defect,$writer, 'entered-by/last-name','reporter');
  ### Создание узла <assigned_to> and <cc>
  &create_node_assignedto($defect,$writer,'currently-assigned-to/last-name','assigned_to');
  ### Создание узла <estimated_time>
  &create_node_value($writer, 'estimated_time', '0.00');
  ### Создание узла <remaining_time>
  &create_node_value($writer, 'remaining_time', '0.00');
  ### Создание узла <actual_time>
  &create_node_value($writer, 'actual_time', '0.00');
  ### Создание узла <qa_contact>
  &create_node_qacontact($defect, $writer, 'Sokunova', 'qa_contact');
  ### Создание узла <group>
  &create_node_value($writer, 'group', 'Доступ - Продукты СПб');
  ### Создание узла <long_desc>
  &create_node_longdesc_first($defect,$writer,'reported-by-record','long_desc');
  ### Создание узлов <long_desc> из излов комментариев
  &create_node_longdesc_comments($defect,$writer,'defect-event','long_desc');
  ### Создание узла <attachment>
  &create_node_attachment($defect,$writer, 'attachment', 'attachment');

}

### Функция перебирает все узлы defect и замена их на узлы  bug 
sub parse_xml{
  my $doc = $_[0];
  my $writer = $_[1];
  ### Парсинг всех узлов defect
  my $defects = $doc->getElementsByTagName("defect");
  for(my $i=0;  $i < $defects->getLength;$i++){
    my $defect = $defects->item($i);
    ### Создание узлов  <bug> для всех узлов <defect> 
    $writer->startTag('bug');
    ### Создание всех необходимых узлов 
    &bugzilla_structure($defect,$writer);
    $writer->endTag('bug');	
  }
}

###Стартовая функция анализатора XML, создаем объявление в
###новом XML документе
sub print_xml{
  my ($output, $testrakxml) =@_;
  my $dom_parser = new XML::DOM::Parser;
  my $doc = $dom_parser->parsefile ($testrakxml);
  my $root = $doc->getDocumentElement();

  my $writer = new XML::Writer(OUTPUT => $output, UNSAFE =>1);
  ###Включаем XML-объявление
  $writer->xmlDecl('UTF-8','yes');

  ###Добавление типа документа 
  $writer->doctype('bugzilla',undef,'bugzilla.dtd');
  $writer->startTag('bugzilla', 'version' => '3.4.2',  
                    'urlbase' => 'http://localhost/TestTrack/',
                    'maintainer' => 'bugzilla@xxxxx.ru', 
                    'exporter' => 'sokunova@xxxxx.ru');
  ###Парсинг исходного документа с записью с данных в выходной 
  ###документ
  &parse_xml($doc, $writer);
 
  $writer->endTag();
  ###Закрытие XML-документа
  $writer->end;
}

###Задаем параметры программы и переменные командной строки
my $keys = new Getopt::Compact
        (name => 'parser XML program',
         version => '1.1',
         struct=>
                [
                  [[qw(i input_xml)],qq(XML file for parsing - TestTrack format),'=s'],
                  [[qw(o output_xml)],qq(XML file will be saved in bugzilla format),'=s'],
                ]
        );
my $opts = $keys->opts;
###Если не задан входной XML файл для распарсивания или выходной
###для сохранения, то выходим
if (!defined($$opts{input_xml}) || !defined($$opts{output_xml})) {
  print "Enter xml for parsing and xml for save \n";
  exit 0;

}
print " INPUT = $$opts{input_xml} OUTPUT = $$opts{output_xml} \n";
my $output = new IO::File(">$$opts{output_xml}");
my $testrakxml= $$opts{input_xml};
###Вызываем функцию анализатора
&print_xml($output, $testrakxml);

Исходный текст программы: parser.pl
Пример тестового входного XML файла: test_xml.xml
Дополнительно рекомендую прочесть книгу «Perl & XML. Библиотека программиста» Э. Рэй, Дж. Макинтош.
Обновлено 16.03.2010 17:45
 
Программа демон слушающий tcp сокет PDF Печать E-mail
Автор: Mariya Sokunova   
17.01.2010 13:17

Сервер-демон на языке perl прослушивающий tcp сокет

После прочтения данной статьи Вы узнаете, как создавать серверы-демоны, что такое Интернет сокеты, процессы-зомби и сигналы.

Демоны

Для начала необходимо отличать понятия обычного процесса, процесса – демона и системного процесса. Все сразу видно по таблице процессов. Запустите команду :

# ps aux
USER PID %CPU %MEM VSZ RSS TTY STAT START TIME COMMAND
root 1 0.1 0.1 2060 620 ? Ss 08:27 0:00 init [5]
root 2 0.0 0.0 0 0 ? S< 08:27 0:00 [migration/0]
root 5222 0.0 0.2 4532 1412 pts/1 Ss 08:30 0:00 -bash
root 5274 0.0 0.1 4244 928 pts/1 R+ 08:33 0:00 ps aux

Системные процессы - те у которых TTY = ? и VSZ = 0
Демоны – те у которых TTY = ? и VSZ ≠ 0
Пользовательские процессы – те у которых TTY = pts/1(к примеру) и VSZ ≠ 0

Если при запуске Вашей программы Вы не добились TTY = ? и VSZ ≠ 0, то Ваш процесс не является демоном.
Процессы демоны обычно запускаются при загрузке системы и завершаются при завершении работы системы.

Для создания демона необходимы следующие действия - сначала завершить родительский процесс:

$pid = fork();
exit() if $pid;

Затем разорвать связь с управляющим терминалом и создать связь с новым терминалом при помощи команды:

POSIX::setsid();

Сокеты

Описанный в данной статье сервер будет поддерживать Интернет сокет, поэтому дадим определения сокетам.
Сокеты являются "конечными пунктами" в процессе обмена данными.
Обмен данными через сокеты может осуществляться на одном компьютере или через Интернет.
Существуют два самых распространенных типа сокетов: потоковые и датаграмные. Потоковые сокеты обеспечивают двусторонние, последовательные и надежные коммуникации; они похожи на каналы (pipes). Датаграммные сокеты не обеспечивают последовательную, надежную доставку, но они гарантируют, что в процессе чтения сохранятся границы сообщений. (Описание сокетов взято из книги "PERL: Библиотека программиста" Т. Кристиансен, Н. Торкингтон)
Сокеты также делятся по областям(domain): сокеты Интернета и сокеты UNIX. Интернет сокет содержит в себе две составляющие: хост (IP-адрес в определенном формате) и номер порта. UNIX сокеты представляют собой файлы (пример сокета Unix применяется в сервере mysqld socket=/var/lib/mysql/mysql.sock ).

Для создания Интернет сокета на сервере с портом 23 необходима следующая команда:

$server = new IO::Socket::INET(LocalPort => 23,
                                  TYPE => SOCK_STREAM,
                                  Reuse => 1,
                                  Listen => 10);

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

Серверы с ветвлением

Для обслуживания запросов от нескольких клиентов необходим сервер с ветвлением. Для этого при каждом входящем подключении от клиента необходимо делать копию родительского процесса (сервера) и "обслуживать" клиента непосредственно ответвленным (скопированным, дочерним) процессом. Делается это при помощи команды fork. Функция fork создает клон текущего процесса. В родительский процесс она возвращает $pid порожденного процесса, а в дочернем процессе возвращаемое значение равно нулю.
Поэтому для того чтобы создать самый простой сервер с ветвлением необходимо сделать следующее:

while($client = $server->accept()) {
    defined(my $child_pid=fork()) or die "Can't fork new child $!";
    ###Родительский процесс идет в конец ###
    ###и ждет следующего подключения ###
    next if $child_pid;
    ###Дочернему процессу копия сокета не нужна ###
    if($child_pid == 0) {
    close($server);
    }
    ###Здесь идет обработка клиентского запроса, ###
    ###выполнение всех необходимых команд ### 
    ....
    exit;### В конце завершаем порожденный процесс ###
    }
continue {
    close($client); ### Не нужно родительскому процессу ### 
}

Процессы-зомби

В сервере с ветвлением при завершении порождаемого процесса (exit) и не завершении родителя появляются процессы-зомби. Процесс-зомби - дочерний процесс в Unix системе, завершивший свое выполнение, но еще присутствующий в таблице процессов. Зомби можно узнать в списке процессов (выводимых утилитой ps) по флагу «Z» в колонке STAT.
Если родительский процесс игнорирует обработчик $SIG{CHLD}, то зомби остаются до завершения родителя. Необходимо добавить функцию отслеживания сигнала $SIG{CHLD} :

sub REAPER {
    while ((my $waitedpid = waitpid(-1,WNOHANG)) > 0) { }
    $SIG{CHLD} = \&REAPER;
}

И перед разветвлением вызвать обработчик

$SIG{CHLD} = \&REAPER;
defined(my $child_pid=fork()) or die "Can't fork new child $!";

Тогда наши наши уже не нужные отработавшие процессы будут корректно завершаться.

Сигналы

%SIG - это хэш ссылок на обработчики сигналов ( ссылки на функции).
Сигнал $SIG{INT} обычно возникает при нажатии Ctrl+C и требует, чтобы процесс завершил свою работу.
Сигнал $SIG{TERM} посылается командой kill при отсутствии явно заданного имени сигнала.
К примеру для обработки сигналов $SIG{INT} и $SIG{TERM} можно написать следующую функцию:

sub signal_handler{
    $time_to_die = 1;
    close($server);
}
$SIG{INT}= $SIG{TERM} = \&signal_handler;

Также сервер должен обрабатывать сигнал HUP - который посылается процессу при при разрыве связи (hang-up) на управляющем терминале, либо когда программа должна перезапуститься или заново перечитать свою конфигурацию. В нашем случае когда сервер должен перечитать список разрешенных команд.
Напишем обработчик сигнала HUP следующим образом:

$SIG{HUP} = \&rereading_config;
sub rereading_config{
    @def_commands=();
    open(FILECONF,$conf_name) or die "Can't open config file \n";
    while(<FILECONF>){
        chomp;
        push(@def_commands, $_);
    }
    close(FILECONF);
}

Вызвать сигнал HUP для процесса сервера можно так:

kill -s HUP номер процесса

Краткое описание работы telnet сервера-демона

Наш сервер будет работать на 23 порту (слушать 23 порт). Он будет обрабатывать все входящие соединения на этом порту. Если пользователь будет посылать команду, указанную в конфигурационном файле, то сервер будет выполнять её, если же команда будет не из разрешенного списка, то сервер будет её пропускать и переходить к следующей команде. Для того чтобы обновить список разрешенных команд, необходимо серверу послать сигнал HUP.

Пример работы

Запускаем демона на сервере:
[root@server ~]# ./simple-telnetd.pl

Проверяем, что 23 порт прослушивается и ожидает соединения с клиентом:
[root@server ~]# netstat -an|grep LISTEN
tcp 0 0 0.0.0.0:23 0.0.0.0:* LISTEN

Теперь с машины клиента соединяемся по telnet на серевер и вводим команды, которые указаны во входных настройках (/etc/simple-telnetd.conf):

[root@client ~]# telnet 192.168.254.40
Trying 192.168.254.40...
Connected to localhost (192.168.254.40).
Escape character is '^]'.
Command :uname -a
Linux redhat2 2.6.18-92.el5 #1 SMP Tue Apr 29 13:16:12 EDT 2008 i686 i686 i386 GNU/Linux
Command :uname
Linux
Command :who
root pts/1 2010-01-11 08:30 (192.168.254.1)
Command :

Видим, что программа реагирует корректно. Если ввести не корректную команду, то будет предложено ввести следующую команду.
Если в это время на сервере вывести список установленных соединений, то увидим соединение с клиентом:

[root@server ~]# netstat -an|grep EST
tcp 0 0 192.168.254.40:23 192.168.254.30:49598 ESTABLISHED

Если в это время на клиенте вывести список установленных соединений, то увидим соединение с сервером:

[root@client ~]# netstat -an|grep EST
tcp 0 0 192.168.254.30:49598 192.168.254.40:23 ESTABLISHED

После выхода клиентом из клиентской программы telnet соединение на обоих концах разорвется. Если вызывать клиентскую программу telnet несколько раз, то будут образовываться сразу несколько соединений с сервером, это реализуется с помощью распараллеливания процессов ( копирования самого себя с помощью fork).

Текст программы с комментариями

#!/usr/bin/perl -w
####################
#Sokunova Mariya 
#01.12.2009
#Simple Telnetd 
####################
###Подключение всех необходимых модулей###
use strict;
use POSIX;
use POSIX ":sys_wait_h";
use IO::Socket;
use IO::Handle;

###Создаем процесс-демон###
my $pid= fork();
exit() if $pid;
die "Couldn't fork: $! " unless defined($pid);
###Создаем связь с новым терминалом###
POSIX::setsid() or die "Can't start a new session $!";
###Переменная - бесконечное время жизни сервера###
my $time_to_die =0;
###Переменная - интернет-сокет или сервер###
my $server;
###Функция обработчик  сигналов INT и TERM###
###Она срабатывает перед этими сигналами###
sub signal_handler{
    $time_to_die = 1;
    close($server);
}
$SIG{INT}= $SIG{TERM} = \&signal_handler;
###Файл конфигурации с набором команд, которые обрабатывает наш сервер###
my $conf_name="/etc/simple-telnetd.conf";
###Массив где хранится список этих команд ###
my @def_commands;
###Функция обработчик сигнала HUP перечитывает конфигурационный файл###
###и обновляет массив @def_commands###
$SIG{HUP} = \&rereading_config;
sub rereading_config{
    @def_commands=();
    open(FILECONF,$conf_name) or die "Can't open config file \n";
    while(<FILECONF>){
        chomp;
        push(@def_commands, $_);
    }
    close(FILECONF);
}

###Функция обработчик сигнала  CHLD - для уборки процессов зомби ###
sub REAPER {
    while ((my $waitedpid = waitpid(-1,WNOHANG)) > 0) { }
    $SIG{CHLD} = \&REAPER;
}

###Заполняем массив разрешенных команд при старте сервера###
rereading_config();
###Создаем интернет сокет на порту 23###
my $server_port=23;
$server= new IO::Socket::INET(LocalPort => $server_port,
                                  TYPE => SOCK_STREAM,
                                  Reuse => 1,
                                  Listen => 10)
or die "Couldn't be a tcp server on port $server_port: $@\n";
###Сервер работает до бесконечности пока его не вырубит Term ###
 until($time_to_die){

    my $client;
    ###Обрабатываем входящие подключения
    while($client = $server->accept()){
        ###Включаем обработку зомби###
        $SIG{CHLD} = \&REAPER;
        ###Тот который постучался, отделяем в отдельный процесс###
        defined(my $child_pid=fork()) or die "Can't fork new child $!";
        ###Родительский процесс идет в конец и ждет следующего подключения###
        next if $child_pid;
        ###Дочернему процессу копия сокета не нужна, её закрываем###
        if($child_pid == 0) {
            close($server);
        }
        ###Очистка буфера###
        $client->autoflush(1);
        my $is_def_command=0;
        print $client "Command :";

        ###Считываем комады от клиента построчно###
        while(<$client>){
            ###Если строка пустая переходим в конец блока###
            next unless /\S/;
            ###Запоминаем полную введенную строку, к примеру df -h ###
            my $full_enter_str = $_;
            chomp($full_enter_str);
            ###Переменная – имя команды, к примеру df###
            my $enter_command="";
            ###Переменная – набор параметров, к примеру -h### 
            my $enter_params="";
            ###Разбиваем введенную строку на имя команды и параметры###
            ###########################################################
            if($full_enter_str =~ /(\w+)(\s+)(.*)(\s*)/){
                $enter_command = $1;
                $enter_params = $3;
            }
            elsif($full_enter_str =~ /(\w+)/){
                $enter_command = $1;
                $enter_params = "";
            }
            else {
                $enter_command = "";
                $enter_params = "";
            }

            ###Сравнение имени команды с набором разрешенных команд ###
            ###Просматриваем разрешенные команды в конфигурационном файле ###
            foreach (@def_commands) {
                if($enter_command eq $_) { $is_def_command=1;}
            }


            ###Если команда разрешена — выполняем её###
            ###########################################
            if($is_def_command){
                my @lines = qx($enter_command $enter_params);
                foreach (@lines){
                    print $client $_;
                }
            }

        }
        continue {
            print $client "Command :";
            $is_def_command=0;

        }
    exit;
    }
    continue {
        close($client);
    }

}

Исходный текст программы: simple-telnetd.pl

Пример входных настроек: simple-telnetd.conf

ЗЫ хороший мануал perldoc perlipc
Обновлено 15.10.2010 17:22
 
Еще статьи...
« ПерваяПредыдущая12СледующаяПоследняя »

Страница 1 из 2

При использовании материалов сайта ссылка на сайт с указанием авторов обязательна.
Designed by Joomla. Powered by Mikhail Shpatserman & Mariya Sokunova © 2009-2011