Code: Alles auswählen
uses {Synapse}
type
TOnReceived=procedure(aValue:String) of object;
{ TTCPServer }
TTCPServer=class(TThread)
private
FServerThreadList : TThreadList;
FServerSocket : TTCPBlockSocket;
FPort : string;
FMaxThreads : integer;
procedure ShutDownThreads;
public
constructor Create;
destructor Destroy;
procedure Execute; override;
procedure StopSock;
end;
{ TTCPServerThread }
TTCPServerThread=class(TThread)
private
FSocket : TTCPBlockSocket;
FSocketNum : integer;
FThreadList : TThreadList;
public
destructor Destroy; override;
procedure Execute; override;
property SocketNumber: integer read FSocketNum write FSocketNum;
property ThreadList: TThreadList read FThreadList write FThreadList;
property Socket : TTCPBlockSocket read FSocket;
end;
{ TTCPClient }
TTCPClient=class(TThread)
private
FSocket : TTCPBlockSocket;
FDataOut : string;
FDataIn : string;
FOnReceived : TOnReceived;
procedure SyncMethod;
public
constructor Create(aIP,aPort:string);
destructor Destroy; override;
procedure Execute; override;
property Send:string read FDataOut write FDataOut;
property OnReceive:TOnReceived read FOnReceived write FOnReceived;
end;
{ TTCPServer }
constructor TTCPServer.Create;
begin
inherited Create(true);
FPort:='1234';
FMaxThreads:=4;
FServerThreadList:=TThreadList.Create;
FServerThreadList.Duplicates:=dupAccept;
FServerSocket:=TTCPBlockSocket.Create;
FServerSocket.EnableReuse(true);
FreeOnTerminate:=true;
Resume;
end;
destructor TTCPServer.Destroy;
begin
if assigned(FServerSocket) then
begin
FServerSocket.CloseSocket;
FServerSocket.Free;
end;
FServerThreadList.UnlockList;
FServerThreadList.Free;
inherited;
end;
procedure TTCPServer.ShutDownThreads;
var i : integer;
begin
with FServerThreadList.LockList do
try
for i:=0 to Count-1 do
with TTCPServerThread(Items[i]) do
begin
StopSock;
Terminate;
ThreadList:=nil;
end;
finally
FServerThreadList.UnlockList;
end;
end;
procedure TTCPServer.Execute;
var FServerThread : TTCPServerThread;
NumThreads : integer;
begin
if assigned(FServerSocket) then
begin
FServerSocket.Bind('0.0.0.0', FPort);
if FServerSocket.LastError=0 then
begin
FServerSocket.Listen;
while not Terminated do
begin
if FServerSocket.CanRead(1000) then
begin
try
NumThreads:=FServerThreadList.LockList.Count;
finally
FServerThreadList.UnlockList;
end;
if NumThreads<FMaxThreads then
begin
try
FServerThread:=TTCPServerThread.Create(true);
FServerThread.FreeOnTerminate:=true;
FServerThread.ThreadList:=FServerThreadList;
FServerThread.SocketNumber:=FServerSocket.Accept;
FServerThreadList.Add(FServerThread);
FServerThread.Resume;
except
if assigned(FServerThread) then FServerThread.Terminate;
end;
end;
end;
end;//Terminated
end else Terminate;//FSocket.LastError<>0
end;
if assigned(FServerSocket) then FServerSocket.StopFlag:=true;
ShutDownThreads;
end;
procedure TTCPServer.StopSock;
begin
if FServerSocket<>nil then
begin
FServerSocket.StopFlag := true;
FServerSocket.AbortSocket;
end;
end;
{ TTCPServerThread }
destructor TTCPServerThread.Destroy;
begin
if FThreadList<>nil then FThreadList.Remove(self);
inherited;
end;
procedure TTCPServerThread.Execute;
var i:integer;
s:string;
begin
FSocket:=TTCPBlockSocket.Create;
try
FSocket.Socket:=FSocketNum;
FSocket.SendString('connected: '+inttostr(FSocketNum)+CRLF);
while not Terminated do
begin
s:=FSocket.RecvString(10000);
if s<>'' then
begin
with FThreadList.LockList do
try
for i:=0 to Count-1 do
TTCPServerThread(Items[i]).Socket.SendString(s+CRLF);
finally
FThreadList.UnlockList;
end;
s:='';
end;
if not (FSocket.LastError in [0,110]) then Terminate; //110=WSAETIMEDOUT
end;
finally
FSocket.CloseSocket;
FreeAndNil(FSocket);
end;
end;
{ TTCPClient }
procedure TTCPClient.SyncMethod;
begin
if assigned(FOnReceived) then FOnReceived(FDataIn);
end;
constructor TTCPClient.Create(aIP, aPort: string);
begin
inherited Create(true);
FreeOnTerminate:=true;
FSocket:=TTCPBlockSocket.Create;
FSocket.Connect(aIP,aPort);
Resume;
end;
destructor TTCPClient.Destroy;
begin
if assigned(FSocket) then
begin
FSocket.CloseSocket;
FreeAndNil(FSocket);
end;
inherited Destroy;
end;
procedure TTCPClient.Execute;
begin
while not Terminated do
begin
if FDataOut<>'' then
begin
FSocket.SendString(FDataOut+CRLF);
FDataOut:='';
end;
FDataIn:=FSocket.RecvString(100);
if FDataIn<>'' then
begin
Synchronize(@SyncMethod);
FDataIn:='';
end;
if not (FSocket.LastError in [0,110]) then Terminate; //110=WSAETIMEDOUT
end;
end;Code: Alles auswählen
TCPServer:=TTCPServer.Create;
TCPClient:=TTCPClient.Create('127.0.0.1','1234');
TCPClient.Send:='Test';
Wenn ich meine Funktion mit {$ifdef legacysocket} kapsle, dann meckert der Compiler. Ergo ist der Schalter für mein Projekt gesetzt. Die richtige Frage ist also: Wie bekomme ich den Switch in Lazarus rein?
Verein
Links
Suche