Re: [fpc-devel] Inconsistent use of Timeout in SimpleIPC

Denis Kozlov Fri, 11 Dec 2015 02:30:08 -0800

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

[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!

testipc.pas
Description: Binary data

simpleipc.pp.patch
Description: Binary data

simpleipc.inc.patch
Description: Binary data

simpleipc.pp
Description: Binary data

{
    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;

_______________________________________________
fpc-devel maillist  -  fpc-devel@lists.freepascal.org
http://lists.freepascal.org/cgi-bin/mailman/listinfo/fpc-devel

Re: [fpc-devel] Inconsistent use of Timeout in SimpleIPC

Reply via email to