paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-15 13:19:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Denis Kozlov to fix threaded server

Browse Source 
git-svn-id: trunk@36916 -
This commit is contained in:
michael 2017-08-15 09:55:18 +00:00
parent a9819b3289
commit 1fa863721f
6 changed files with 745 additions and 282 deletions

2
.gitattributes vendored
View File

@ -2676,6 +2676,8 @@ packages/fcl-process/examples/ipcserver.lpi svneol=native#text/plain
packages/fcl-process/examples/ipcserver.pp svneol=native#text/plain
packages/fcl-process/examples/simpleipcserver.lpi svneol=native#text/plain
packages/fcl-process/examples/simpleipcserver.lpr svneol=native#text/plain
packages/fcl-process/examples/threadedipc.lpi svneol=native#text/plain
packages/fcl-process/examples/threadedipc.lpr svneol=native#text/plain
packages/fcl-process/examples/waitonexit.pp svneol=native#text/pascal
packages/fcl-process/fpmake.pp svneol=native#text/plain
packages/fcl-process/src/amicommon/pipes.inc svneol=native#text/plain

67
packages/fcl-process/examples/threadedipc.lpi Normal file
View File

@ -0,0 +1,67 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="10"/>
<PathDelim Value="\"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="threadedipc"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="threadedipc.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="threadedipc"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<UseExternalDbgSyms Value="True"/>
</Debugging>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

111
packages/fcl-process/examples/threadedipc.lpr Normal file
View File

@ -0,0 +1,111 @@
program ThreadedIPC;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}cthreads,{$ENDIF}
SysUtils, Classes, Math, FGL, SimpleIPC;
const
ServerUniqueID = '39693DC0-BD8B-4AAD-9D9B-387D37CD59FD';
ServerTimeout = 5000;
ClientDelayMin = 500;
ClientDelayMax = 3000;
ClientCount = 10;
var
ServerThreaded: Boolean = True;
type
TServerMessageHandler = class
public
procedure HandleMessage(Sender: TObject);
procedure HandleMessageQueued(Sender: TObject);
end;
procedure TServerMessageHandler.HandleMessage(Sender: TObject);
begin
WriteLn(TSimpleIPCServer(Sender).StringMessage);
end;
procedure TServerMessageHandler.HandleMessageQueued(Sender: TObject);
begin
TSimpleIPCServer(Sender).ReadMessage;
end;
procedure ServerWorker;
var
Server: TSimpleIPCServer;
MessageHandler: TServerMessageHandler;
begin
WriteLn(Format('Starting server #%x', [GetThreadID]));
MessageHandler := TServerMessageHandler.Create;
Server := TSimpleIPCServer.Create(nil);
try
Server.ServerID := ServerUniqueID;
Server.Global := True;
Server.OnMessage := @MessageHandler.HandleMessage;
Server.OnMessageQueued := @MessageHandler.HandleMessageQueued;
Server.StartServer(ServerThreaded);
if ServerThreaded then
Sleep(ServerTimeout)
else
while Server.PeekMessage(ServerTimeout, True) do ;
except on E: Exception do
WriteLn('Server error: ' + E.Message);
end;
Server.Free;
MessageHandler.Free;
WriteLn(Format('Finished server #%x', [GetThreadID]));
end;
procedure ClientWorker;
var
Client: TSimpleIPCClient;
Message: String;
begin
WriteLn(Format('Starting client #%x', [GetThreadID]));
Client := TSimpleIPCClient.Create(nil);
try
Client.ServerID := ServerUniqueID;
while not Client.ServerRunning do
Sleep(100);
Client.Active := True;
Sleep(RandomRange(ClientDelayMin, ClientDelayMax));
Message := Format('Hello from client #%x', [GetThreadID]);
Client.SendStringMessage(Message);
except on E: Exception do
WriteLn('Client error: ' + E.Message);
end;
Client.Free;
WriteLn(Format('Finished client #%x', [GetThreadID]));
end;
type
TThreadList = specialize TFPGObjectList<TThread>;
var
I: Integer;
Thread: TThread;
Threads: TThreadList;
begin
Randomize;
WriteLn('Threaded server: ' + BoolToStr(ServerThreaded, 'YES', 'NO'));
Threads := TThreadList.Create(True);
try
Threads.Add(TThread.CreateAnonymousThread(@ServerWorker));
for I := 1 to ClientCount do
Threads.Add(TThread.CreateAnonymousThread(@ClientWorker));
for Thread in Threads do
begin
Thread.FreeOnTerminate := False;
Thread.Start;
end;
for Thread in Threads do
Thread.WaitFor;
finally
Threads.Free;
end;
end.

18
packages/fcl-process/src/amicommon/simpleipc.inc
View File

@ -234,6 +234,7 @@ Procedure TAmigaServerComm.ReadMessage;
var
Temp: PByte;
MsgType: TMessageType;
Msg: TIPCServerMsg;
begin
if Assigned(MsgBody) then
begin
@ -241,11 +242,18 @@ begin
Inc(Temp, SizeOf(Exec.TMessage));
MsgType := 0;
Move(Temp^, MsgType, SizeOf(TMessageType));
Inc(Temp, SizeOf(TMessageType));
Owner.FMsgType := MsgType;
Owner.FMsgData.Size := 0;
Owner.FMsgData.Seek(0, soFrombeginning);
Owner.FMsgData.WriteBuffer(temp^, MsgBody^.mn_Length);
Inc(Temp, SizeOf(TMessageType));
Msg := TIPCServerMsg.Create;
try
Msg.MsgType := MsgType;
Msg.Stream.WriteBuffer(Temp^, MsgBody^.mn_Length);
except
FreeAndNil(Msg);
raise;
end;
PushMessage(Msg);
System.FreeMem(MsgBody);
MsgBody := nil;
end;

803
packages/fcl-process/src/simpleipc.pp
View File

File diff suppressed because it is too large Load Diff

26
packages/fcl-process/src/unix/simpleipc.inc
View File

@ -131,8 +131,6 @@ Type
Private
FFileName: String;
FStream: TFileStream;
Protected
Procedure DoReadMessage; virtual;
Public
Constructor Create(AOWner : TSimpleIPCServer); override;
Procedure StartServer; override;
@ -144,15 +142,6 @@ Type
Property Stream : TFileStream Read FStream;
end;
procedure TPipeServerComm.DoReadMessage;
Var
Hdr : TMsgHeader;
begin
FStream.ReadBuffer(Hdr,SizeOf(Hdr));
PushMessage(Hdr,FStream);
end;
constructor TPipeServerComm.Create(AOWner: TSimpleIPCServer);
begin
@ -187,25 +176,20 @@ begin
end;
function TPipeServerComm.PeekMessage(TimeOut: Integer): Boolean;
Var
FDS : TFDSet;
begin
fpfd_zero(FDS);
fpfd_set(FStream.Handle,FDS);
Result:=False;
While fpSelect(FStream.Handle+1,@FDS,Nil,Nil,TimeOut)>0 do
begin
DoReadMessage;
Result:=True;
end;
Result := fpSelect(FStream.Handle+1,@FDS,Nil,Nil,TimeOut)>0;
end;
procedure TPipeServerComm.ReadMessage;
Var
Hdr : TMsgHeader;
begin
DoReadMessage;
FStream.ReadBuffer(Hdr,SizeOf(Hdr));
PushMessage(Hdr,FStream);
end;