[fpc-devel] Inconsistent use of Timeout in SimpleIPC
Denis Kozlov
dezlov at gmail.com
Thu Dec 10 18:02:47 CET 2015
I have rewritten SimpleIPC implementation for Windows.
Summary of changes:
1. Using SetTimer + GetMessage method for handling PeekMessage.
2. Store all received incoming messages in a message queue (per IPC
server instance).
3. Implemented message queue (PeekMessage receives messages,
ReadMessage picks from the queue)
4. Implemented optional message queue limit and overflow handling
(more on that below).
5. Timeout<-1 is forced to -1; Documented meaning of various Timeout
values in comments.
6. Minor refactoring and code formatting changes.
All these changes currently affect only the Windows implementation.
The main IPC interface has not changed. This allows to fix all major
issues on Windows and test the new concept of buffering/queueing IPC
messages.
A new global type was introduced:
> TIPCMessageOverflowAction = (ipcmoaNone, ipcmoaDiscardOld, ipcmoaDiscardNew, ipcmoaError);
Added two global variables which configure message queue limit and
overflow handling (affect newly created IPC servers):
> DefaultIPCMessageOverflowAction: TIPCMessageOverflowAction = ipcmoaNone;
> DefaultIPCMessageQueueLimit: Integer = 0;
Currently these are used only in Windows implementation, but they need
to be in the interface section to allow unit testing and perhaps later
reuse on other platforms.
The second part is a comprehensive test suite for Windows
implementation of SimpleIPC. Tests spawn client mode instances as
needed for proper testing of IPC. Tests check handling of messages,
processing delays, synchronicity and message queue overflow actions.
Read comments for each test routine for additional information. All
timing based checks are very relaxed and can be controlled by
IPC_BASETIME constant (a base line time per message in milliseconds),
which can be increased for really-really slow machines. Simply compile
and run. Exception is raised if any errors occur.
Other platforms will fail most tests due to not implemented featured,
such as message queue and overflow handling. Perhaps it could be added
to FPC test suite for Windows platform only, but I'm not sure how
suitable it is due to complexity of multiple processes and timing
checks.
I also tested separately for compatibility with Lazarus message loop
by using PeekMessage(0, True) in Application.OnIdle, it works
perfectly.
Attached files (full copies included for convenience; patches against
FPC trunk revision 32628 from 10 Dec 2015):
1) testipc.pas/testipc.out.txt - tests for SimpleIPC and example output.
2) simpleipc.pp/simpleipc.pp.patch - patch and a full copy of main
SimpleIPC unit.
3) simpleipc.inc/simpleipc.inc.patch - patch and a full copy of
Windows include file (not Windows CE).
Next steps:
1) If everyone is happy - commit SimpleIPC changes (should I create a
bug report in mantis?).
2) I can merge "wince" with "win" implementation since it is identical
except for wide types/winapi, but won't be able to test on Windows CE.
3) See if implementations on other platforms can use/benefit from
message queue and overflow handling.
How's that sound?
Denis
-------------- next part --------------
[Test A]
RunClientProcessAsynchronously(1, 0)
Client PID: 00002DB8
Server.PeekMessage(2000, False)
Client #00002DB8 sending message #1/1
Elapsed time: 0.010 seconds
Message: Hello #1/1 from PID #00002DB8 at 15:22:49.798
RunClientProcessAsynchronously(1, 0)
Client #00002DB8 message sent #1/1
Client PID: 00008454
Server.PeekMessage(2000, False)
Client #00008454 sending message #1/1
Client #00008454 message sent #1/1
Elapsed time: 0.010 seconds
Message: Hello #1/1 from PID #00008454 at 15:22:49.808
RunClientProcessAsynchronously(1, 0)
Client PID: 00008AE4
Server.PeekMessage(2000, False)
Client #00008AE4 sending message #1/1
Client #00008AE4 message sent #1/1
Elapsed time: 0.000 seconds
Message: Hello #1/1 from PID #00008AE4 at 15:22:49.818
RunClientProcessAsynchronously(1, 0)
Client PID: 000059D4
Server.PeekMessage(2000, False)
Client #000059D4 sending message #1/1
Client #000059D4 message sent #1/1
Elapsed time: 0.000 seconds
Message: Hello #1/1 from PID #000059D4 at 15:22:49.838
RunClientProcessAsynchronously(1, 0)
Client PID: 0000649C
Server.PeekMessage(2000, False)
Client #0000649C sending message #1/1
Elapsed time: 0.010 seconds
Message: Hello #1/1 from PID #0000649C at 15:22:49.858
Server.PeekMessage(2000, False)
Client #0000649C message sent #1/1
Elapsed time: 2.018 seconds
[Test B]
RunClientProcessAsynchronously(5, 0)
Client PID: 00007FD8
Continusly peeking messages on server...
Client #00007FD8 sending message #1/5
Client #00007FD8 message sent #1/5
Client #00007FD8 sending message #2/5
Client #00007FD8 message sent #2/5
Client #00007FD8 sending message #3/5
Client #00007FD8 message sent #3/5
Client #00007FD8 sending message #4/5
Client #00007FD8 message sent #4/5
Client #00007FD8 sending message #5/5
Client #00007FD8 message sent #5/5
Server.PeekMessage(0, True)
Message: Hello #3/5 from PID #00007FD8 at 15:22:52.086
Server.PeekMessage(0, True)
Message: Hello #4/5 from PID #00007FD8 at 15:22:52.186
Server.PeekMessage(0, True)
Message: Hello #5/5 from PID #00007FD8 at 15:22:52.286
Server.PeekMessage(0, True)
Elapsed time: 0.000 seconds
[Test C]
RunClientProcessAsynchronously(5, 0)
Client PID: 0000407C
Continusly peeking messages on server...
Client #0000407C sending message #1/5
Client #0000407C message sent #1/5
Client #0000407C sending message #2/5
Client #0000407C message sent #2/5
Client #0000407C sending message #3/5
Client #0000407C message sent #3/5
Client #0000407C sending message #4/5
Client #0000407C message sent #4/5
Client #0000407C sending message #5/5
Client #0000407C message sent #5/5
Server.PeekMessage(0, True)
Message: Hello #1/5 from PID #0000407C at 15:22:53.996
Server.PeekMessage(0, True)
Message: Hello #2/5 from PID #0000407C at 15:22:54.096
Server.PeekMessage(0, True)
Message: Hello #3/5 from PID #0000407C at 15:22:54.196
Server.PeekMessage(0, True)
Elapsed time: 0.000 seconds
[Test D]
RunClientProcessAsynchronously(1, 0)
Client PID: 00005C44
Client #00005C44 sending message #1/1
Server.PeekMessage(0, False)
Client #00005C44 message sent #1/1
RunClientProcessAsynchronously(1, 0)
Client PID: 00006164
Client #00006164 sending message #1/1
Server.PeekMessage(0, False)
Client #00006164 message sent #1/1
RunClientProcessAsynchronously(1, 0)
Client PID: 000089A4
Client #000089A4 sending message #1/1
Server.PeekMessage(0, False)
Client #000089A4 message sent #1/1
RunClientProcessAsynchronously(1, 0)
Client PID: 00003F78
Client #00003F78 sending message #1/1
Server.PeekMessage(0, False)
Captured exception: Message queue overflow (limit 3)
Expected error on overflow
Client #00003F78 message sent #1/1
Server.PeekMessage(0, False)
[Test E]
RunClientProcessAsynchronously(5, 100)
Client PID: 00008348
RunClientProcessAsynchronously(5, 100)
Client PID: 000024E4
Continusly peeking messages on server...
Client #00008348 sending message #1/5
Client #000024E4 sending message #1/5
Client #00008348 message sent #1/5
Client #00008348 sending message #2/5
Client #000024E4 message sent #1/5
Client #00008348 message sent #2/5
Client #000024E4 sending message #2/5
Client #00008348 sending message #3/5
Client #000024E4 message sent #2/5
Client #00008348 message sent #3/5
Client #00008348 sending message #4/5
Client #000024E4 sending message #3/5
Client #000024E4 message sent #3/5
Client #00008348 message sent #4/5
Client #000024E4 sending message #4/5
Client #00008348 sending message #5/5
Client #00008348 message sent #5/5
Client #000024E4 message sent #4/5
Client #000024E4 sending message #5/5
Client #000024E4 message sent #5/5
Server.PeekMessage(0, True)
Message: Hello #1/5 from PID #00008348 at 15:23:06.243
Server.PeekMessage(0, True)
Message: Hello #1/5 from PID #000024E4 at 15:23:06.253
Server.PeekMessage(0, True)
Message: Hello #2/5 from PID #00008348 at 15:23:06.353
Server.PeekMessage(0, True)
Message: Hello #2/5 from PID #000024E4 at 15:23:06.453
Server.PeekMessage(0, True)
Message: Hello #3/5 from PID #00008348 at 15:23:06.453
Server.PeekMessage(0, True)
Message: Hello #4/5 from PID #00008348 at 15:23:06.653
Server.PeekMessage(0, True)
Message: Hello #3/5 from PID #000024E4 at 15:23:06.653
Server.PeekMessage(0, True)
Message: Hello #5/5 from PID #00008348 at 15:23:06.853
Server.PeekMessage(0, True)
Message: Hello #4/5 from PID #000024E4 at 15:23:06.853
Server.PeekMessage(0, True)
Message: Hello #5/5 from PID #000024E4 at 15:23:07.053
Server.PeekMessage(0, True)
Server.PeekMessage(0, True)
Server.PeekMessage(0, True)
Server.PeekMessage(0, True)
Server.PeekMessage(0, True)
Total number of messages received: 10
[Test F]
RunClientProcessAsynchronously(5, 0)
Client PID: 000085F4
Continusly peeking messages on server...
Client #000085F4 sending message #1/5
Message: Hello #1/5 from PID #000085F4 at 15:23:09.163
Client #000085F4 message sent #1/5
Client #000085F4 sending message #2/5
Message: Hello #2/5 from PID #000085F4 at 15:23:09.263
Client #000085F4 message sent #2/5
Client #000085F4 sending message #3/5
Message: Hello #3/5 from PID #000085F4 at 15:23:09.363
Client #000085F4 message sent #3/5
Client #000085F4 sending message #4/5
Message: Hello #4/5 from PID #000085F4 at 15:23:09.463
Client #000085F4 message sent #4/5
Client #000085F4 sending message #5/5
Message: Hello #5/5 from PID #000085F4 at 15:23:09.563
Client #000085F4 message sent #5/5
Total number of messages received via event callback: 5
[Finish]
Tests completed successfully!
-------------- next part --------------
A non-text attachment was scrubbed...
Name: testipc.pas
Type: application/octet-stream
Size: 18749 bytes
Desc: not available
URL: <http://lists.freepascal.org/pipermail/fpc-devel/attachments/20151210/e7a72692/attachment.obj>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: simpleipc.pp.patch
Type: application/octet-stream
Size: 3846 bytes
Desc: not available
URL: <http://lists.freepascal.org/pipermail/fpc-devel/attachments/20151210/e7a72692/attachment-0001.obj>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: simpleipc.inc.patch
Type: application/octet-stream
Size: 16397 bytes
Desc: not available
URL: <http://lists.freepascal.org/pipermail/fpc-devel/attachments/20151210/e7a72692/attachment-0002.obj>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: simpleipc.pp
Type: application/octet-stream
Size: 13460 bytes
Desc: not available
URL: <http://lists.freepascal.org/pipermail/fpc-devel/attachments/20151210/e7a72692/attachment-0003.obj>
-------------- next part --------------
{
This file is part of the Free Component library.
Copyright (c) 2005 by Michael Van Canneyt, member of
the Free Pascal development team
Windows implementation of one-way IPC between 2 processes
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
uses Windows,messages,contnrs;
const
MsgWndClassName: PChar = 'FPCMsgWindowCls';
resourcestring
SErrFailedToRegisterWindowClass = 'Failed to register message window class';
SErrFailedToCreateWindow = 'Failed to create message window %s';
SErrMessageQueueOverflow = 'Message queue overflow (limit %s)';
var
MsgWindowClass: TWndClassA = (
style: 0;
lpfnWndProc: nil;
cbClsExtra: 0;
cbWndExtra: 0;
hInstance: 0;
hIcon: 0;
hCursor: 0;
hbrBackground: 0;
lpszMenuName: nil;
lpszClassName: nil);
type
TWinMsgServerMsg = class
strict private
FStream: TStream;
FMsgType: TMessageType;
public
constructor Create;
destructor Destroy; override;
property Stream: TStream read FStream;
property MsgType: TMessageType read FMsgType write FMsgType;
end;
TWinMsgServerMsgQueue = class
strict private
FList: TFPObjectList;
FMaxCount: Integer;
FMaxAction: TIPCMessageOverflowAction;
function GetCount: Integer;
procedure DeleteAndFree(Index: Integer);
function PrepareToPush: Boolean;
public
constructor Create;
destructor Destroy; override;
procedure Clear;
procedure Push(AItem: TWinMsgServerMsg);
function Pop: TWinMsgServerMsg;
property Count: Integer read GetCount;
property MaxCount: Integer read FMaxCount write FMaxCount;
property MaxAction: TIPCMessageOverflowAction read FMaxAction write FMaxAction;
end;
TWinMsgServerComm = Class(TIPCServerComm)
strict private
FHWND : HWND;
FWindowName : String;
FWndProcException: Boolean;
FWndProcExceptionMsg: String;
FMsgQueue: TWinMsgServerMsgQueue;
function AllocateHWnd(const aWindowName : String) : HWND;
procedure ProcessMessages;
procedure ProcessMessagesWait(TimeOut: Integer);
procedure HandlePostedMessage(const Msg: TMsg); inline;
function HaveQueuedMessages: Boolean; inline;
function CountQueuedMessages: Integer; inline;
procedure CheckWndProcException; inline;
private
procedure ReadMsgData(var Msg: TMsg);
function TryReadMsgData(var Msg: TMsg; out Error: String): Boolean;
procedure SetWndProcException(const ErrorMsg: String); inline;
public
constructor Create(AOwner : TSimpleIPCServer); override;
destructor Destroy; override;
Procedure StartServer; override;
Procedure StopServer; override;
Function PeekMessage(TimeOut : Integer) : Boolean; override;
Procedure ReadMessage ; override;
Function GetInstanceID : String;override;
Property WindowName : String Read FWindowName;
end;
{ ---------------------------------------------------------------------
TWinMsgServerMsg / TWinMsgServerMsgQueue
---------------------------------------------------------------------}
constructor TWinMsgServerMsg.Create;
begin
FMsgType := 0;
FStream := TMemoryStream.Create;
end;
destructor TWinMsgServerMsg.Destroy;
begin
FStream.Free;
end;
constructor TWinMsgServerMsgQueue.Create;
begin
FMaxCount := DefaultIPCMessageQueueLimit;
FMaxAction := DefaultIPCMessageOverflowAction;
FList := TFPObjectList.Create(False); // FreeObjects = False!
end;
destructor TWinMsgServerMsgQueue.Destroy;
begin
Clear;
FList.Free;
end;
procedure TWinMsgServerMsgQueue.Clear;
begin
while FList.Count > 0 do
DeleteAndFree(FList.Count - 1);
end;
procedure TWinMsgServerMsgQueue.DeleteAndFree(Index: Integer);
begin
FList[Index].Free; // Free objects manually!
FList.Delete(Index);
end;
function TWinMsgServerMsgQueue.GetCount: Integer;
begin
Result := FList.Count;
end;
function TWinMsgServerMsgQueue.PrepareToPush: Boolean;
begin
Result := True;
case FMaxAction of
ipcmoaDiscardOld:
begin
while (FList.Count >= FMaxCount) do
DeleteAndFree(FList.Count - 1);
end;
ipcmoaDiscardNew:
begin
Result := (FList.Count < FMaxCount);
end;
ipcmoaError:
begin
if (FList.Count >= FMaxCount) then
// Caller is expected to catch this exception, so not using Owner.DoError()
raise EIPCError.CreateFmt(SErrMessageQueueOverflow, [IntToStr(FMaxCount)]);
end;
end;
end;
procedure TWinMsgServerMsgQueue.Push(AItem: TWinMsgServerMsg);
begin
if PrepareToPush then
FList.Insert(0, AItem);
end;
function TWinMsgServerMsgQueue.Pop: TWinMsgServerMsg;
var
Index: Integer;
begin
Index := FList.Count - 1;
if Index >= 0 then
begin
// Caller is responsible for freeing the object.
Result := TWinMsgServerMsg(FList[Index]);
FList.Delete(Index);
end
else
Result := nil;
end;
{ ---------------------------------------------------------------------
MsgWndProc
---------------------------------------------------------------------}
function MsgWndProc(Window: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
Var
Server: TWinMsgServerComm;
Msg: TMsg;
MsgError: String;
begin
Result:=0;
if (uMsg=WM_COPYDATA) then
begin
// Post WM_USER to wake up GetMessage call.
PostMessage(Window, WM_USER, 0, 0);
// Read message data and add to message queue.
Server:=TWinMsgServerComm(GetWindowLongPtr(Window,GWL_USERDATA));
if Assigned(Server) then
begin
Msg.Message:=uMsg;
Msg.wParam:=wParam;
Msg.lParam:=lParam;
// Exceptions thrown inside WindowProc may not propagate back
// to the caller in some circumstances (according to MSDN),
// so capture it and raise it outside of WindowProc!
if Server.TryReadMsgData(Msg, MsgError) then
Result:=1 // True
else
begin
Result:=0; // False
Server.SetWndProcException(MsgError);
end;
end;
end
else
begin
Result:=DefWindowProc(Window,uMsg,wParam,lParam);
end;
end;
{ ---------------------------------------------------------------------
TWinMsgServerComm
---------------------------------------------------------------------}
function TWinMsgServerComm.AllocateHWnd(const aWindowName: String): HWND;
var
cls: TWndClassA;
isreg : Boolean;
begin
Pointer(MsgWindowClass.lpfnWndProc):=@MsgWndProc;
MsgWindowClass.hInstance := HInstance;
MsgWindowClass.lpszClassName:=MsgWndClassName;
isreg:=GetClassInfoA(HInstance,MsgWndClassName,cls);
if not isreg then
if (Windows.RegisterClassA(MsgWindowClass)=0) then
Owner.DoError(SErrFailedToRegisterWindowClass,[]);
Result:=CreateWindowExA(WS_EX_TOOLWINDOW, MsgWndClassName,
PChar(aWindowName), WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
if (Result=0) then
Owner.DoError(SErrFailedToCreateWindow,[aWindowName]);
SetWindowLongPtr(Result,GWL_USERDATA,PtrInt(Self));
end;
constructor TWinMsgServerComm.Create(AOwner: TSimpleIPCServer);
begin
inherited Create(AOwner);
FWindowName := Owner.ServerID;
If not Owner.Global then
FWindowName := FWindowName+'_'+InstanceID;
FWndProcException := False;
FWndProcExceptionMsg := '';
FMsgQueue := TWinMsgServerMsgQueue.Create;
end;
destructor TWinMsgServerComm.Destroy;
begin
StopServer;
FMsgQueue.Free;
inherited;
end;
procedure TWinMsgServerComm.StartServer;
begin
StopServer;
FHWND := AllocateHWND(FWindowName);
end;
procedure TWinMsgServerComm.StopServer;
begin
FMsgQueue.Clear;
if FHWND <> 0 then
begin
DestroyWindow(FHWND);
FHWND := 0;
end;
end;
procedure TWinMsgServerComm.SetWndProcException(const ErrorMsg: String); inline;
begin
FWndProcException := True;
FWndProcExceptionMsg := ErrorMsg;
end;
procedure TWinMsgServerComm.CheckWndProcException; inline;
var
Msg: String;
begin
if FWndProcException then
begin
Msg := FWndProcExceptionMsg;
FWndProcException := False;
FWndProcExceptionMsg := '';
Owner.DoError(Msg, []);
end;
end;
function TWinMsgServerComm.HaveQueuedMessages: Boolean; inline;
begin
Result := (FMsgQueue.Count > 0);
end;
function TWinMsgServerComm.CountQueuedMessages: Integer; inline;
begin
Result := FMsgQueue.Count;
end;
procedure TWinMsgServerComm.HandlePostedMessage(const Msg: TMsg); inline;
begin
if Msg.message <> WM_USER then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end
end;
procedure TWinMsgServerComm.ProcessMessages;
var
Msg: TMsg;
begin
// Windows.PeekMessage dispatches incoming sent messages by directly
// calling associated WindowProc, and then checks the thread message queue
// for posted messages and retrieves a message if any available.
// Note: WM_COPYDATA is a sent message, not posted, so it will be processed
// directly via WindowProc inside of Windows.PeekMessage call.
while Windows.PeekMessage(Msg, FHWND, 0, 0, PM_REMOVE) do
begin
// Empty the message queue by processing all posted messages.
HandlePostedMessage(Msg);
end;
end;
procedure TWinMsgServerComm.ProcessMessagesWait(TimeOut: Integer);
var
Msg: TMsg;
TimerID: UINT_PTR;
GetMessageReturn: BOOL;
begin
// Not allowed to wait.
if TimeOut = 0 then
Exit;
// Setup a timer to post WM_TIMER to wake up GetMessage call.
if TimeOut > 0 then
TimerID := SetTimer(FHWND, 0, TimeOut, nil)
else
TimerID := 0;
// Wait until a message arrives.
try
// We either need to wait infinitely or we have a timer.
if (TimeOut < 0) or (TimerID <> 0) then
begin
// Windows.GetMessage dispatches incoming sent messages until a posted
// message is available for retrieval. Note: WM_COPYDATA will not actually
// wake up Windows.GetMessage, so we must post a dummy message when
// we receive WM_COPYDATA inside of WindowProc.
GetMessageReturn := GetMessage(Msg, FHWND, 0, 0);
case LongInt(GetMessageReturn) of
-1, 0: ;
else HandlePostedMessage(Msg);
end;
end;
finally
// Destroy timer.
if TimerID <> 0 then
KillTimer(FHWND, TimerID);
end;
end;
function TWinMsgServerComm.PeekMessage(TimeOut: Integer): Boolean;
begin
// Process incoming messages.
ProcessMessages;
// Do we have queued messages?
Result := HaveQueuedMessages;
// Wait for incoming messages.
if (not Result) and (TimeOut <> 0) then
begin
ProcessMessagesWait(TimeOut);
Result := HaveQueuedMessages;
end;
// Check for exception raised inside WindowProc.
CheckWndProcException;
end;
procedure TWinMsgServerComm.ReadMsgData(var Msg: TMsg);
var
CDS: PCopyDataStruct;
MsgItem: TWinMsgServerMsg;
begin
CDS := PCopyDataStruct(Msg.lParam);
MsgItem := TWinMsgServerMsg.Create;
try
MsgItem.MsgType := CDS^.dwData;
MsgItem.Stream.WriteBuffer(CDS^.lpData^,CDS^.cbData);
except
FreeAndNil(MsgItem);
// Caller is expected to catch this exception, so not using Owner.DoError()
raise;
end;
FMsgQueue.Push(MsgItem);
end;
function TWinMsgServerComm.TryReadMsgData(var Msg: TMsg; out Error: String): Boolean;
begin
Result := True;
try
ReadMsgData(Msg);
except on E: Exception do
begin
Result := False;
Error := E.Message;
end;
end;
end;
procedure TWinMsgServerComm.ReadMessage;
var
MsgItem: TWinMsgServerMsg;
begin
MsgItem := FMsgQueue.Pop;
if Assigned(MsgItem) then
try
// Load message from the queue into the owner's message data.
MsgItem.Stream.Position := 0;
Owner.FMsgData.Size := 0;
Owner.FMsgType := MsgItem.MsgType;
Owner.FMsgData.CopyFrom(MsgItem.Stream, MsgItem.Stream.Size);
finally
// We are responsible for freeing the message from the queue.
MsgItem.Free;
end;
end;
function TWinMsgServerComm.GetInstanceID: String;
begin
Result:=IntToStr(HInstance);
end;
{ ---------------------------------------------------------------------
TWinMsgClientComm
---------------------------------------------------------------------}
Type
TWinMsgClientComm = Class(TIPCClientComm)
Private
FWindowName: String;
FHWND : HWND;
function FindServerWindow: HWND;
Public
Constructor Create(AOWner : TSimpleIPCClient); override;
Procedure Connect; override;
Procedure Disconnect; override;
Procedure SendMessage(MsgType : TMessageType; Stream : TStream); override;
Function ServerRunning : Boolean; override;
Property WindowName : String Read FWindowName;
end;
constructor TWinMsgClientComm.Create(AOWner: TSimpleIPCClient);
begin
inherited Create(AOWner);
FWindowName:=Owner.ServerID;
If (Owner.ServerInstance<>'') then
FWindowName:=FWindowName+'_'+Owner.ServerInstance;
end;
function TWinMsgClientComm.FindServerWindow: HWND;
begin
Result := FindWindowA(MsgWndClassName,PChar(FWindowName));
end;
procedure TWinMsgClientComm.Connect;
begin
FHWND:=FindServerWindow;
If (FHWND=0) then
Owner.DoError(SErrServerNotActive,[Owner.ServerID]);
end;
procedure TWinMsgClientComm.Disconnect;
begin
FHWND:=0;
end;
procedure TWinMsgClientComm.SendMessage(MsgType: TMessageType; Stream: TStream);
var
CDS : TCopyDataStruct;
Data,FMemstr : TMemorySTream;
begin
if Stream is TMemoryStream then
begin
Data:=TMemoryStream(Stream);
FMemStr:=nil;
end
else
begin
FMemStr:=TMemoryStream.Create;
Data:=FMemstr;
end;
try
if Assigned(FMemStr) then
begin
FMemStr.CopyFrom(Stream,0);
FMemStr.Seek(0,soFromBeginning);
end;
CDS.dwData:=MsgType;
CDS.lpData:=Data.Memory;
CDS.cbData:=Data.Size;
Windows.SendMessage(FHWND,WM_COPYDATA,0,PtrInt(@CDS));
finally
FreeAndNil(FMemStr);
end;
end;
function TWinMsgClientComm.ServerRunning: Boolean;
begin
Result:=FindServerWindow<>0;
end;
{ ---------------------------------------------------------------------
Set TSimpleIPCClient / TSimpleIPCServer defaults.
---------------------------------------------------------------------}
Function TSimpleIPCServer.CommClass : TIPCServerCommClass;
begin
if (DefaultIPCServerClass<>Nil) then
Result:=DefaultIPCServerClass
else
Result:=TWinMsgServerComm;
end;
Function TSimpleIPCClient.CommClass : TIPCClientCommClass;
begin
if (DefaultIPCClientClass<>Nil) then
Result:=DefaultIPCClientClass
else
Result:=TWinMsgClientComm;
end;
More information about the fpc-devel
mailing list