Асинхронная работа с COM-портом в Perl

Tags:

Понадобилось мне тут поработать с 3d принтером из Perl. Принтер подключается к компьютеру через USB-COM переходник и прикидывается обычным COM портом со всеми вытекающими способами работы.

Для работы с ком-портом в Perl есть отличный модуль - Device::SerialPort. А для асинхронности используем классический AnyEvent. Ну и долго сказка сказывается, да быстро код пишется - пример кода:

#!/usr/bin/env perl

use v5.20;
use strict;

use AnyEvent;
use AnyEvent::Handle;

use Device::SerialPort;

my $cv = AE::cv;

# Базовые параметры подключения к порту
my $device_port = '/dev/ttyUSB0';
my $port_speed  = 115200;

say "Connecting.. [$device_port] [$port_speed]";
my $port = Device::SerialPort->new($device_port);
$port->baudrate($port_speed); #Устанавливаем скорость соединения

# Чуть более продвинутые настройки
$port->handshake("none"); #Не используем handshake иначе подключение будет устанавливаться только в момент перезагрузки принтера

# Режим коммуникации 8N1
$port->databits(8);
$port->parity("none");
$port->stopbits(1);

$port->stty_echo(0); # Выключаем эхо
$port->error_msg('ON'); # Включаем выдачу ошибок от порта

# Получаем чистый хэндлер порта и с ним создаем объект AE::Handle
my $fh = $port->{'HANDLE'};

my $handle;
$handle = AnyEvent::Handle->new(
fh       => $fh,
on_error => sub {
    my ( $handle, $fatal, $message ) = @_;
    $handle->destroy;
    undef $handle;
    say STDERR "$fatal : $message\n";
},
on_read => sub {
    my $printer_handle = shift;
    $handle->push_read(
        line => sub {
            my ( $printer_handle, $line ) = @_;
            say sprintf( "Reply: [%s]", $line );
        }
    );
}
);

# Отправляем команду принтеру
$port->write("M105\n");

$cv->recv;

После запуска (если все параметры указаны верно) получим такой вывод:

Connecting.. [/dev/ttyUSB0] [115200]
Reply: [ok T:26.6 /0.0 @:0]

Подключение к принтеру и передача данных в обе стороны прошли успешно!

Важный нюанс!

Хэндлер порта полученный тут my $fh = $port->{'HANDLE'}; однонаправленный на чтение! Если попытаться туда что-то записать силами AE то получим ошибку. Писать надо напрямую в объект порта, что и происходит в предпоследней строке.

Отправляем емейл из Perl с авторизацией и html

Tags:

Отправляем письмо в html с авторизацией из Perl.

use strict;
use Net::SMTP;
use Authen::SASL; #нужен для авторизации

use utf8;
use Encode;
use MIME::Base64


  my $message = "<html><body>Тестовое письмо</body></html>";

# авторизационные данные
my $smtp_host = 'smtp.server.address';
my $smtp_user = 'user_name';
my $smtp_pass = 'password';


my $debug = 1; # рассматриваем процесс подключения в деталях

# mail properties
my $mail_from = 'user@example.com';
my $mail_to = 'recipient@example.com';
my $mail_subject = 'Тестовое письмо';

# Выставляем заголовки. Сюда можно добавить еще всякого при необходимости
my $mail_headers = "From: $mail_from\n".
"To: $mail_to\n".
"Subject: ".encode('MIME-Header',$mail_subject)."\n".
"MIME-Version: 1.0\n".
"Content-type: text/html; charset=UTF-8\n".
"Content-Transfer-Encoding: base64\n\n";

my $mail_body = $message;

# Отправляем письмо
my $smtp = Net::SMTP->new($smtp_host, Debug => $debug) or die "cannot connect to server";
$smtp->auth($smtp_user,$smtp_pass) or die "could not authenticate";
$smtp->mail($mail_from);
$smtp->to($mail_to);
$smtp->data();
$smtp->datasend($mail_headers);
$smtp->datasend(encode_base64(encode('UTF-8', $mail_body)));
$smtp->dataend();
$smtp->quit;

При необходимости можно добавить файлы, PGP подписи и так далее.

State переменные в Perl

Tags:

В Perl существует особый тип переменных под названием state.

В доке про них написано:

state declares a lexically scoped variable, just like my. However, those variables will never be reinitialized ...

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

sub count {
  state $count = 0;
  $count++;
}

Однако, есть нюанс - фраза will never be reinitialized означает что переменная действительно никогда не будет переинициализирована пока существует родительский скрипт. И это дает нам вот такую замечательную граблю на которую можно ненароком наступить:

Объявляем пакет:

package MyTestState;

use strict;
use feature 'state';

sub new {
  bless {}, shift;
}

sub count {
  state $count = 0;
  $count++;
}

1;

И саму программу:

use lib 'lib';
use v5.18;
use MyTestState;

my $mystate =  MyTestState->new();

for (0..10) {
  my $counter = $mystate->count();
  say "Counter [$counter]";
}

Вывод ожидаем:

Counter [0]
Counter [1]
Counter [2]
...
Counter [10]

А теперь добавляем такой код:

undef $mystate;

say "next object!=======";

my $mystate1 = MyTestState->new();
for (0..10) {
  my $counter = $mystate1->count();
  say "Counter [$counter]";

}

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

Counter [0]
Counter [1]
Counter [2]
...
Counter [10]
next object!
Counter [11]
Counter [12]
Counter [13]
...
Counter [20]
Counter [21]

Так что слово newer в документации действительно значит "никогда пока жив инстанс интерпретатора запустивший скрипт".

DBD::Pg install

Tags:

Markdown content goes here.

Если при установке DBD::Pg через CPAN у вас начинают спрашивать какие-то странные слова про номер версии и расположение директорий Postgresql - проверьте что у вас установлен пакет postgresql-server-dev-X.X (postgresql-server-dev-all).

После его установки проблема магическим (на самом деле нет) образом исчезает.

Получение методов пакета

Tags:

Для получения методов пакета Foo::Bar делаем:

print Dumper(\%Foo::Bar::);

Для проверки существования метода:

if (Foo::Bar::.$method_name) {
    #some stuff
}

Для получения методов текущего пакета:

print Dumper(\%main::)

Но если подключены дополнительные библиотеки - в выводе будут методы всех подключенных библиотек.

Подробнее в документации

Яндекс.Метрика