Код: Выделить всё
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;
