Асинхронные компоненты в Lazarus

Вопросы программирования и использования среды Lazarus.

Модератор: Модераторы

Re: Асинхронные компоненты в Lazarus

Сообщение olegy123 » 16.06.2017 07:58:31

Код: Выделить всё
unit tstcpcustom;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils
{$IFDEF WIN32}, WinSock2{$ENDIF}
  , Sockets;

type

  { TTSTcpCustom }

  TTSTcpCustom = class (TThread)
  protected
    FSock:longint;
    FAddress: TSockAddr;
    FLastError:longint;
    procedure SetNonBlockSocket;
    function GetLastError:longint;
  public
    property LastError:longint read GetLastError;
  end;

  { TTSTcpClientCustom }

  TTSTcpClientCustom = class (TTSTcpCustom)
  private
  protected
    procedure Close;
  public
    constructor Create(Socket:longint;addr:TSockAddr);
    destructor Destroy; override;
    function CheckReadBufLen(buf:Pointer;len:Integer):Integer;
  end;

  { TTSTcpClientCustom }

  TTSTcpClientCustom = class (TTSTcpCustom)
  private
  protected
    procedure Close;
  public
    constructor Create(Socket:longint;addr:TSockAddr);
    destructor Destroy; override;
    function CheckReadBufLen(buf:Pointer;len:Integer):Integer;
  end;


  { TTSTcpServerCustom }

  TTSTcpServerCustom = class (TTSTcpCustom)
  private
    FDelayExecute:Integer;
    function Resolve(Host: string): LongInt;
  protected
    function getAddrStr(addr:TSockAddr):String;
    procedure Execute; override;
    procedure InitClient(Socket:longint;addr:TSockAddr);dynamic;abstract;
  public
    constructor Create(const AHost: String; APort: Word);
    constructor Create(const AHost: String; APort: Word; delay:Integer);overload;
    function Bind:Boolean;
    procedure Stop;
  end;

implementation
uses LCLProc;
{ TTSTcpCustom }

procedure TTSTcpCustom.SetNonBlockSocket;
var
  Arg: Integer;
begin
  {$IFDEF UNIX}
  Arg := fpFcntl(FSock, F_GETFL);
  if Arg >= 0 then
  begin
    Arg := Arg or O_NONBLOCK;
    fpFcntl(FSock, F_SETFL, arg);
  end;
  {$ENDIF}
  {$IFDEF WIN32}
  Arg := 1; // 1 = nonblocking, 0 = blocking
  ioctlsocket(FSock, Integer(FIONBIO), @Arg);
  {$ENDIF}
end;

function TTSTcpCustom.GetLastError: longint;
begin
  Result:=socketerror;
end;


{ TTSTcpServerCustom }

function TTSTcpServerCustom.Resolve(Host: string): LongInt;
begin
  Result := LongInt(strtonetaddr(Host));
end;

function TTSTcpServerCustom.getAddrStr(addr: TSockAddr): String;
begin
  Result:=NetAddrToStr(addr.sin_addr);
end;

procedure TTSTcpServerCustom.Execute;
Var l,client_socket : longint;
  addr:TSockAddr;
  reuse_addr: Integer;
begin
  l:=SizeOf(addr);
  reuse_addr:= 1;
  SetNonBlockSocket;
  if fplisten(FSock, {SOMAXCONN)}100) <>SOCKET_ERROR then
    while (not Terminated) do begin
      client_socket:=Sockets.fpAccept(FSock,@addr,@L);
      if client_socket>-1 then begin
        fpsetsockopt(client_socket, SOL_SOCKET, SO_REUSEADDR or SO_LINGER, PAnsiChar(@reuse_addr), sizeof(reuse_addr));
        InitClient(client_socket,addr);
      end;
      Sleep(FDelayExecute);
    end;
  closesocket(FSock);
end;

constructor TTSTcpServerCustom.Create(const AHost: String; APort: Word);
begin
  Create(AHost,APort,1);
end;

constructor TTSTcpServerCustom.Create(const AHost: String; APort: Word;
  delay: Integer);
begin
  inherited Create(true);
  FDelayExecute:=delay;
  FAddress.sin_family := AF_INET;
  FAddress.sin_port := htons(Word(APort));
  LongInt(FAddress.sin_addr) := htonl(Resolve(AHost));
  Priority:=tpLower;
end;

function TTSTcpServerCustom.Bind: Boolean;
var
  l:tsocklen;
begin
  l:=SizeOf(FAddress);
  Result:=False;
  FSock:=fpsocket(PF_INET, SOCK_STREAM, IPPROTO_IP);
  if FSock<>SOCKET_ERROR then begin
     Result:=fpbind(FSock,@FAddress,l)=0;
  end
end;


procedure TTSTcpServerCustom.Stop;
begin

end;

{ TTSTcpClientCustom }

function TTSTcpClientCustom.CheckReadBufLen(buf:Pointer;len: Integer): Integer;
begin
  Result:=fprecv(FSock, buf, len, MSG_PEEK);
end;

procedure TTSTcpClientCustom.Close;
begin
  if FSock<>SOCKET_ERROR then begin
    closesocket(FSock);
    FSock:=SOCKET_ERROR;
  end;
end;

constructor TTSTcpClientCustom.Create(Socket:longint;addr:TSockAddr);
begin
  inherited Create(true);
  FSock:=Socket;
  Priority:=tpLowest;
  FreeOnTerminate:=true;
  FAddress:=addr;
end;

destructor TTSTcpClientCustom.Destroy;
begin
  Close;
  inherited Destroy;
end;

end.



Добавлено спустя 10 минут 33 секунды:
Код: Выделить всё
  TTSTcpClient= class (TTSTcpClientCustom)
  public
    function Read(const m:Pointer;size:Integer):Integer;
    function Read(const m:Pointer;size:Integer;timemax:integer):Integer;overload;
    function ReadTerminated(const m:Pointer;size:Integer;terminatebyte:Byte):Integer;
    function ReadTerminated(const m:Pointer;size:Integer;terminatebyte:Byte;
                                  timemax:integer):Integer;
    function Write(const m:Pointer;size:Integer):Boolean;
    procedure SendString(s:string);
  end;

  TTSTcpClientClass = class of TTSTcpClient;



....

function TTSTcpClient.Read(const m: Pointer; size: Integer): Integer;
begin
  Result:=fprecv(FSock, m, size, 0);
end;

function TTSTcpClient.Read(const m: Pointer; size: Integer; timemax:integer): Integer;
var
  t:TDateTime;
  i,count:Integer;
begin
  Result:=-1;
  if timemax>0 then t:=IncSecond(Now,timemax)
  else t:=IncDay(Now);
  repeat
    i := CheckReadBufLen(m,size);
    if i>=size then begin
      Result:=Read(m,size);
    end;
    Sleep(10);
  until Terminated or (Result>=0) or ({(socketerror=0) and }(i=0)) or (i>=size) or (t<Now);
  if i=0 then Result:=0;
end;

function TTSTcpClient.ReadTerminated(const m: Pointer; size: Integer; terminatebyte: Byte
  ): Integer;
var
  i,_size:Integer;
begin
  Result:=-1;
  repeat
    i := CheckReadBufLen(m,size);
    if i>0 then
      _size:=IndexByte(m,size,terminatebyte);
      if _size>-1 then begin
         Result:=Read(m,_size);
      end;
    Sleep(10);
  until Terminated or (Result>=0) or ((socketerror=0) and (i=0)) or (i>size);
end;

function TTSTcpClient.ReadTerminated(const m: Pointer; size: Integer;
  terminatebyte: Byte; timemax: integer): Integer;
var
  i:Integer;
  t:TDateTime;
begin
  Result:=-1;
  if timemax>0 then t:=IncSecond(Now,timemax);
  repeat
    i := CheckReadBufLen(m,size);
    if IndexByte(m,i,terminatebyte)>-1 then begin
      Result:=Read(m,i);
    end;
    Sleep(10);
  until Terminated or (Result>=0) or ((socketerror=0) and (i=0)) or (i>=size)
        or (t<Now);
end;

function TTSTcpClient.Write(const m: Pointer; size: Integer): Boolean;
var
  i:Integer;
begin
  i:=fpsend(FSock,m,size,0);
  Result:=socketerror=0;
end;

procedure TTSTcpClient.SendString(s: string);
begin
   Write(@s[1],Length(s));
end;



И у клиента определить протокол:
Код: Выделить всё
  TTSTcpClientMyProtocol= class (TTSTcpClient)
  protected
   procedure Execute; override;
  end.



Добавлено спустя 7 минут 26 секунд:
осталось только
Код: Выделить всё
  TTSTcpServer = class (TTSTcpServerCustom)
  private
  protected
    procedure InitClient(Socket:longint;addr:TSockAddr);override;
  end;
...

procedure TTSTcpServer.InitClient(Socket:longint;addr:TSockAddr);
var
  client:TTSTcpClient;
begin
//  client:=FTSTcpClientClass.Create(Socket,addr);
client:=TTSTcpClientMyProtocol.Create(Socket,addr);

end;
olegy123
долгожитель
 
Сообщения: 1643
Зарегистрирован: 25.02.2016 12:10:20

Re: Асинхронные компоненты в Lazarus

Сообщение serbod » 17.06.2017 21:41:25

https://github.com/serbod/dataport

Готовые асинхронные компоненты для Delphi/Lazarus. Есть и сокеты, и ком-порты, и не только. Пользоваться очень легко.
Аватара пользователя
serbod
постоялец
 
Сообщения: 449
Зарегистрирован: 16.09.2016 11:03:02
Откуда: Минск

Re: Асинхронные компоненты в Lazarus

Сообщение debi12345 » 19.06.2017 00:18:33

Пользоваться очень легко.

Как JS-скими "deferred/promise" ? Можно создавать и комбинировать последовательные чэйны и параллельные джойны ?
Аватара пользователя
debi12345
долгожитель
 
Сообщения: 5752
Зарегистрирован: 10.05.2006 23:41:15
Откуда: Ташкент (Узбекистан)

Re: Асинхронные компоненты в Lazarus

Сообщение serbod » 19.06.2017 14:25:01

debi12345 писал(а):Как JS-скими "deferred/promise" ? Можно создавать и комбинировать последовательные чэйны и параллельные джойны ?

Проще. Можно по таймеру читать, а можно по событию OnDataAppear. Стыковаться с другими компонентами можно и нужно. Вот только параллельная стыковка не реализована. Но если будет спрос - сделаю.
Аватара пользователя
serbod
постоялец
 
Сообщения: 449
Зарегистрирован: 16.09.2016 11:03:02
Откуда: Минск

Re: Асинхронные компоненты в Lazarus

Сообщение olegy123 » 19.06.2017 21:36:07

debi12345 писал(а):Как JS-скими "deferred/promise" ?
что это такое?

Добавлено спустя 9 минут 14 секунд:
serbod писал(а):Готовые асинхронные компоненты для Delphi/Lazarus. Есть и сокеты, и ком-порты, и не только. Пользоваться очень легко.

докачивать надо Ararat Synapse.
Я не стал использовать Synapse - некоторые вещи надо делать напрямую со сокетом.
olegy123
долгожитель
 
Сообщения: 1643
Зарегистрирован: 25.02.2016 12:10:20

Re: Асинхронные компоненты в Lazarus

Сообщение debi12345 » 20.06.2017 09:55:49

что это такое?

"Асинхроное действие(событие)+его функция-обработчик" как объект, который может комбинироваться с другими такими же объектами по принципу параллельности и/или очередности выполнения - отрабатывать в заданном (синхронном) порядке по мере (асинхронного) поступления событий, или дождаться завершения обработчиков всей параллельной (не зависящем от прядка поступления событий) группы. Также эти объекты умеют передавать друг другу результаты своего выполнения -то есть не нужно использовать потенциально опасные (в асинхронном мире) глобальные переменные. В вэбе таким образом пишут правильные (без угрозы лочек и рэйсов) AJAX-сайты. Нечто в духе:
Код: Выделить всё
promise.join([
  parallelFunc1(..),
...
  parallelFuncN(..)
]).then(function(err,data){
  if (err) {...}
  else {
  .. = data;
  }
}).then(..)

Последний раз редактировалось debi12345 20.06.2017 10:07:40, всего редактировалось 1 раз.
Аватара пользователя
debi12345
долгожитель
 
Сообщения: 5752
Зарегистрирован: 10.05.2006 23:41:15
Откуда: Ташкент (Узбекистан)

Re: Асинхронные компоненты в Lazarus

Сообщение MysticCoder » 20.06.2017 09:56:22

shade писал(а):Если кто-то вспомнит что есть какой-то готовый компонент, то скажите


lNet же - https://lnet.wordpress.com/
MysticCoder
постоялец
 
Сообщения: 154
Зарегистрирован: 14.09.2013 00:20:28

Re: Асинхронные компоненты в Lazarus

Сообщение vitaly_l » 20.06.2017 10:22:16

serbod писал(а):https://github.com/serbod/dataport

Раз он основан на Synapse - значит он поддерживает HTTPS - верно? (в коде увидел только HTTP)
Аватара пользователя
vitaly_l
долгожитель
 
Сообщения: 3333
Зарегистрирован: 31.01.2012 16:41:41

Re: Асинхронные компоненты в Lazarus

Сообщение serbod » 20.06.2017 10:39:48

olegy123 писал(а):докачивать надо Ararat Synapse.
Я не стал использовать Synapse - некоторые вещи надо делать напрямую со сокетом.

Synapse и есть голый сокет с удобным и надежным интерфейсом. Кроссплатформенный, что весьма немаловажно. Если нужна максимальная производительность на тысячах одновременных подключениях - то лучше взять lnet, но он требует понимания основ и местами глючный.

Если нужны "некоторые вещи", то это в маны/MSDN + много времени на отладку. Но я сомневаюсь, что вам нужно получать "сырые" пакеты из NDIS или строить свой стек бинарных протоколов. Поэтому пользуйтесь Synapse, он вам много времени и нервов сбережет.
Аватара пользователя
serbod
постоялец
 
Сообщения: 449
Зарегистрирован: 16.09.2016 11:03:02
Откуда: Минск

Re: Асинхронные компоненты в Lazarus

Сообщение shyub » 20.06.2017 10:51:22

Компонент Cportlaz v1.0.0 работает в синхронном и асинхронном режимах, причём создаёт свой поток https://sourceforge.net/projects/cportlaz/. Есть Help.
shyub
постоялец
 
Сообщения: 112
Зарегистрирован: 25.11.2014 23:15:19

Re: Асинхронные компоненты в Lazarus

Сообщение serbod » 20.06.2017 10:59:41

vitaly_l писал(а):Раз он основан на Synapse - значит он поддерживает HTTPS - верно? (в коде увидел только HTTP)

Нет, но можно адаптировать.

DataPort не рассчитан на полноценную работу с вебом, поддержка HTTP сделана для особых случаев, когда TCP неприменим (из-за файрвола) и нужно передавать-получать поток данных через классический HTTP 1.1 без извращений вроде websockets.

Добавлено спустя 10 минут 34 секунды:
shyub писал(а):Компонент Cportlaz v1.0.0

Только под Windows. Очень мощный инструмент, для профессионалов, так же как Indy. Для новичком слишком сложный и коварный. Можно легко наделать ошибок, и потом постоянно испытывать проблемы, когда вроде бы все работает, но глючит.
Аватара пользователя
serbod
постоялец
 
Сообщения: 449
Зарегистрирован: 16.09.2016 11:03:02
Откуда: Минск

Re: Асинхронные компоненты в Lazarus

Сообщение wadman » 22.06.2017 17:54:02

http://www.webdelphi.ru/2013/12/kniga-o ... -0-sokety/ там описание и пример
Синапс в том числе умеет и с ком-портами работать.
wadman
постоялец
 
Сообщения: 122
Зарегистрирован: 18.10.2016 15:54:28

Пред.

Вернуться в Lazarus

Кто сейчас на конференции

Сейчас этот форум просматривают: Google Adsense [Bot] и гости: 33

Рейтинг@Mail.ru