Browse Source

--- Merging r33697 into '.':
G packages/fcl-process/src/unix/simpleipc.inc
--- Recording mergeinfo for merge of r33697 into '.':
G .

# revisions: 33697

git-svn-id: branches/fixes_3_0@33818 -

marco 9 years ago
parent
commit
0455973fe4

+ 5 - 0
.gitattributes

@@ -1985,6 +1985,7 @@ packages/fcl-base/examples/txmlreg.pp svneol=native#text/plain
 packages/fcl-base/examples/xmldump.pp svneol=native#text/plain
 packages/fcl-base/fpmake.pp svneol=native#text/plain
 packages/fcl-base/src/advancedipc.pp svneol=native#text/plain
+packages/fcl-base/src/advancedsingleinstance.pas svneol=native#text/plain
 packages/fcl-base/src/ascii85.pp svneol=native#text/plain
 packages/fcl-base/src/avl_tree.pp svneol=native#text/plain
 packages/fcl-base/src/base64.pp svneol=native#text/plain
@@ -2569,6 +2570,8 @@ packages/fcl-pdf/utils/ttfdump.lpr svneol=native#text/plain
 packages/fcl-process/Makefile svneol=native#text/plain
 packages/fcl-process/Makefile.fpc svneol=native#text/plain
 packages/fcl-process/Makefile.fpc.fpcmake svneol=native#text/plain
+packages/fcl-process/examples/checkipcserver.lpi svneol=native#text/plain
+packages/fcl-process/examples/checkipcserver.lpr svneol=native#text/plain
 packages/fcl-process/examples/demoproject.ico -text
 packages/fcl-process/examples/demoproject.lpi svneol=native#text/plain
 packages/fcl-process/examples/demoproject.pp svneol=native#text/plain
@@ -2580,6 +2583,8 @@ packages/fcl-process/examples/ipcclient.lpi svneol=native#text/plain
 packages/fcl-process/examples/ipcclient.pp svneol=native#text/plain
 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/fpmake.pp svneol=native#text/plain
 packages/fcl-process/src/amicommon/pipes.inc svneol=native#text/plain
 packages/fcl-process/src/amicommon/process.inc svneol=native#text/plain

+ 2 - 0
packages/fcl-base/fpmake.pp

@@ -124,6 +124,8 @@ begin
       end;
     T:=P.Targets.addUnit('advancedipc.pp');
       T.ResourceStrings:=true;
+    T:=P.Targets.addUnit('advancedsingleinstance.pp');
+      T.ResourceStrings:=true;	  
     // Additional sources
     P.Sources.AddSrcFiles('src/win/fclel.*', P.Directory);
     // Install windows resources

+ 0 - 313
packages/fcl-base/src/advancedipc.pp

@@ -168,43 +168,6 @@ type
 
   EICPException = class(Exception);
 
-  TSingleInstanceReceivedCustomMessage = procedure(Sender: TBaseSingleInstance; MsgID: Integer; MsgType: Integer; MsgData: TStream) of object;
-
-  TAdvancedSingleInstance = class(TBaseSingleInstance)
-  private
-    FGlobal: Boolean;
-    FID: string;
-    FServer: TIPCServer;
-    FClient: TIPCClient;
-    FOnServerReceivedCustomRequest: TSingleInstanceReceivedCustomMessage;
-    function GetIsClient: Boolean; override;
-    function GetIsServer: Boolean; override;
-    function GetStartResult: TSingleInstanceStart; override;
-    procedure SetGlobal(const aGlobal: Boolean);
-    procedure SetID(const aID: string);
-  protected
-    procedure DoServerReceivedCustomRequest(const aMsgID: Integer; const aMsgType: Integer; const aStream: TStream);
-  public
-    constructor Create(aOwner: TComponent); override;
-  public
-    function Start: TSingleInstanceStart; override;
-    procedure Stop; override;
-
-    procedure ServerCheckMessages; override;
-    procedure ClientPostParams; override;
-  public
-    function ClientPostCustomRequest(const aMsgType: Integer; const aStream: TStream): Integer;
-    function ClientSendCustomRequest(const aMsgType: Integer; const aStream: TStream): Boolean; overload;
-    function ClientSendCustomRequest(const aMsgType: Integer; const aStream: TStream; out outRequestID: Integer): Boolean; overload;
-    procedure ServerPostCustomResponse(const aRequestID: Integer; const aMsgType: Integer; const aStream: TStream);
-    function ClientPeekCustomResponse(const aStream: TStream; out outMsgType: Integer): Boolean;
-  public
-    property ID: string read FID write SetID;
-    property Global: Boolean read FGlobal write SetGlobal;
-
-    property OnServerReceivedCustomRequest: TSingleInstanceReceivedCustomMessage read FOnServerReceivedCustomRequest write FOnServerReceivedCustomRequest;
-  end;
-
 resourcestring
   SErrInvalidServerID = 'Invalid server ID "%s". Please use only alphanumerical characters and underlines.';
   SErrSetGlobalActive = 'You cannot change the global property when the server is active.';
@@ -809,284 +772,8 @@ begin
   FActive := False;
 end;
 
-Resourcestring
-  SErrSetSingleInstanceIDStarted = 'You cannot change the single instance ID when it''s been started.';
-  SErrSetSingleInstanceGlobalStarted = 'You cannot change the single instance global property when it''s been started.';
-  SErrStartSingleInstanceStarted = 'You cannot start single instance when it''s been already started.';
-  SErrSingleInstanceStartResultNotAvailable = 'Single instance hasn''t been started yet.';
-  SErrSingleInstanceNotClient = 'Current instance is not a client.';
-  SErrSingleInstanceNotServer = 'Current instance is not a server.';
-
-Const
-  MSGTYPE_CHECK = -1;
-  MSGTYPE_CHECKRESPONSE = -2;
-  MSGTYPE_PARAMS = -3;
-  MSGTYPE_WAITFORINSTANCES = -4;
-
-{ TAdvancedSingleInstance }
-
-constructor TAdvancedSingleInstance.Create(aOwner: TComponent);
-var
-  xID: RawByteString;
-  I: Integer;
-begin
-  inherited Create(aOwner);
-
-  xID := 'SI_'+ExtractFileName(ParamStr(0));
-  for I := 1 to Length(xID) do
-    case xID[I] of
-      'a'..'z', 'A'..'Z', '0'..'9', '_': begin end;
-    else
-      xID[I] := '_';
-    end;
-  ID := xID;
-end;
-
-function TAdvancedSingleInstance.ClientPeekCustomResponse(
-  const aStream: TStream; out outMsgType: Integer): Boolean;
-begin
-  if not Assigned(FClient) then
-    raise ESingleInstance.Create(SErrSingleInstanceNotClient);
-
-  Result := FClient.PeekResponse(aStream, outMsgType, TimeOutMessages);
-end;
-
-function TAdvancedSingleInstance.ClientPostCustomRequest(
-  const aMsgType: Integer; const aStream: TStream): Integer;
-begin
-  if not Assigned(FClient) then
-    raise ESingleInstance.Create(SErrSingleInstanceNotClient);
-
-  Result := FClient.PostRequest(aMsgType, aStream);
-end;
-
-procedure TAdvancedSingleInstance.ClientPostParams;
-var
-  xSL: TStringList;
-  xStringStream: TStringStream;
-  I: Integer;
-begin
-  if not Assigned(FClient) then
-    raise ESingleInstance.Create(SErrSingleInstanceNotClient);
-
-  xSL := TStringList.Create;
-  try
-    for I := 0 to ParamCount do
-      xSL.Add(ParamStr(I));
-
-    xStringStream := TStringStream.Create(xSL.DelimitedText);
-    try
-      xStringStream.Position := 0;
-      FClient.PostRequest(MSGTYPE_PARAMS, xStringStream);
-    finally
-      xStringStream.Free;
-    end;
-  finally
-    xSL.Free;
-  end;
-end;
-
-function TAdvancedSingleInstance.ClientSendCustomRequest(
-  const aMsgType: Integer; const aStream: TStream): Boolean;
-begin
-  if not Assigned(FClient) then
-    raise ESingleInstance.Create(SErrSingleInstanceNotClient);
-
-  Result := FClient.SendRequest(aMsgType, aStream, TimeOutMessages);
-end;
-
-function TAdvancedSingleInstance.ClientSendCustomRequest(
-  const aMsgType: Integer; const aStream: TStream; out
-  outRequestID: Integer): Boolean;
-begin
-  if not Assigned(FClient) then
-    raise ESingleInstance.Create(SErrSingleInstanceNotClient);
-
-  Result := FClient.SendRequest(aMsgType, aStream, TimeOutMessages, outRequestID);
-end;
-
-procedure TAdvancedSingleInstance.DoServerReceivedCustomRequest(
-  const aMsgID: Integer; const aMsgType: Integer; const aStream: TStream);
-begin
-  if Assigned(FOnServerReceivedCustomRequest) then
-    FOnServerReceivedCustomRequest(Self, aMsgID, aMsgType, aStream);
-end;
-
-function TAdvancedSingleInstance.GetIsClient: Boolean;
-begin
-  Result := Assigned(FClient);
-end;
-
-function TAdvancedSingleInstance.GetIsServer: Boolean;
-begin
-  Result := Assigned(FServer);
-end;
-
-function TAdvancedSingleInstance.GetStartResult: TSingleInstanceStart;
-begin
-  if not(Assigned(FServer) or Assigned(FClient)) then
-    raise ESingleInstance.Create(SErrSingleInstanceStartResultNotAvailable);
-
-  Result := inherited GetStartResult;
-end;
-
-procedure TAdvancedSingleInstance.ServerCheckMessages;
-var
-  xMsgID: Integer;
-  xMsgType: Integer;
-  xStream: TStream;
-  xStringStream: TStringStream;
-begin
-  if not Assigned(FServer) then
-    raise ESingleInstance.Create(SErrSingleInstanceNotServer);
-
-  if not FServer.PeekRequest(xMsgID, xMsgType) then
-    Exit;
-
-  case xMsgType of
-    MSGTYPE_CHECK:
-    begin
-      FServer.DeleteRequest(xMsgID);
-      FServer.PostResponse(xMsgID, MSGTYPE_CHECKRESPONSE, nil);
-    end;
-    MSGTYPE_PARAMS:
-    begin
-      xStringStream := TStringStream.Create('');
-      try
-        FServer.ReadRequest(xMsgID, xStringStream);
-        DoServerReceivedParams(xStringStream.DataString);
-      finally
-        xStringStream.Free;
-      end;
-    end;
-    MSGTYPE_WAITFORINSTANCES:
-      FServer.DeleteRequest(xMsgID);
-  else
-    xStream := TMemoryStream.Create;
-    try
-      FServer.ReadRequest(xMsgID, xStream);
-      DoServerReceivedCustomRequest(xMsgID, xMsgType, xStream);
-    finally
-      xStream.Free;
-    end;
-  end;
-end;
-
-procedure TAdvancedSingleInstance.ServerPostCustomResponse(
-  const aRequestID: Integer; const aMsgType: Integer;
-  const aStream: TStream);
-begin
-  if not Assigned(FServer) then
-    raise ESingleInstance.Create(SErrSingleInstanceNotServer);
-
-  FServer.PostResponse(aRequestID, aMsgType, aStream);
-end;
-
-procedure TAdvancedSingleInstance.SetGlobal(const aGlobal: Boolean);
-begin
-  if FGlobal = aGlobal then Exit;
-  if Assigned(FServer) or Assigned(FClient) then
-    raise ESingleInstance.Create(SErrSetSingleInstanceGlobalStarted);
-  FGlobal := aGlobal;
-end;
-
-procedure TAdvancedSingleInstance.SetID(const aID: string);
-begin
-  if FID = aID then Exit;
-  if Assigned(FServer) or Assigned(FClient) then
-    raise ESingleInstance.Create(SErrSetSingleInstanceIDStarted);
-  FID := aID;
-end;
-
-function TAdvancedSingleInstance.Start: TSingleInstanceStart;
-  {$IFNDEF MSWINDOWS}
-  procedure UnixWorkaround(var bServerStarted: Boolean);
-  var
-    xWaitRequestID, xLastCount, xNewCount: Integer;
-    xClient: TIPCClient;
-  begin
-    //file locking workaround for UNIX systems -> the server can be started twice if 2 processes are started in parallel
-    //wait some time to see other clients
-    FServer.StopServer(False);
-    xClient := TIPCClient.Create(Self);
-    try
-      xClient.ServerID := FID;
-      xClient.Global := FGlobal;
-      xWaitRequestID := xClient.PostRequest(MSGTYPE_WAITFORINSTANCES, nil);
-      xLastCount := -1;
-      xNewCount := FServer.GetPendingRequestCount;
-      while xLastCount <> xNewCount do
-      begin
-        xLastCount := xNewCount;
-        Sleep(TimeOutWaitForInstances);
-        xNewCount := FServer.GetPendingRequestCount;
-      end;
-    finally
-      FreeAndNil(xClient);
-    end;
-
-    //find highest client that will be the server
-    if FServer.FindHighestPendingRequestId = xWaitRequestID then
-    begin
-      bServerStarted := FServer.StartServer(False);
-    end else
-    begin
-      //something went wrong, there are not-deleted waiting requests
-      //use random sleep as workaround and try to restart the server
-      Randomize;
-      Sleep(Random(($3F+PtrInt(GetProcessID)) and $3F));//limit to $3F (63)
-      bServerStarted := FServer.StartServer(False) and (FServer.GetPendingRequestCount > 0);
-    end;
-  end;
-  {$ENDIF}
-var
-  xStream: TStream;
-  xMsgType: Integer;
-  xServerStarted: Boolean;
-begin
-  if Assigned(FServer) or Assigned(FClient) then
-    raise ESingleInstance.Create(SErrStartSingleInstanceStarted);
-
-  FServer := TIPCServer.Create(Self);
-  FServer.ServerID := FID;
-  FServer.Global := FGlobal;
-  xServerStarted := FServer.StartServer(False);
-  if xServerStarted then
-  begin//this is single instance -> be server
-    Result := siServer;
-    {$IFNDEF MSWINDOWS}
-    UnixWorkaround(xServerStarted);
-    {$ENDIF}
-  end;
-  if not xServerStarted then
-  begin//instance found -> be client
-    FreeAndNil(FServer);
-    FClient := TIPCClient.Create(Self);
-    FClient.ServerID := FID;
-    FClient.Global := FGlobal;
-    FClient.PostRequest(MSGTYPE_CHECK, nil);
-    xStream := TMemoryStream.Create;
-    try
-      if FClient.PeekResponse(xStream, xMsgType, TimeOutMessages) then
-        Result := siClient
-      else
-        Result := siNotResponding;
-    finally
-      xStream.Free;
-    end;
-  end;
-  SetStartResult(Result);
-end;
-
-procedure TAdvancedSingleInstance.Stop;
-begin
-  FreeAndNil(FServer);
-  FreeAndNil(FClient);
-end;
-
 initialization
   InitCriticalSection(CreateUniqueRequestCritSec);
-  DefaultSingleInstanceClass:=TAdvancedSingleInstance;
 
 finalization
   DoneCriticalsection(CreateUniqueRequestCritSec);

+ 350 - 0
packages/fcl-base/src/advancedsingleinstance.pas

@@ -0,0 +1,350 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2015 by Ondrej Pokorny
+
+    Unit implementing Single Instance functionality.
+
+    The order of message processing is not deterministic (if there are more
+    pending messages, the server won't process them in the order they have
+    been sent to the server.
+    SendRequest and PostRequest+PeekResponse sequences from 1 client are
+    blocking and processed in correct order.
+
+    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.
+
+ **********************************************************************}
+
+unit AdvancedSingleInstance;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, AdvancedIPC, singleinstance;
+
+type
+
+  TSingleInstanceReceivedCustomMessage = procedure(Sender: TBaseSingleInstance; MsgID: Integer; MsgType: Integer; MsgData: TStream) of object;
+
+  TAdvancedSingleInstance = class(TBaseSingleInstance)
+  private
+    FGlobal: Boolean;
+    FID: string;
+    FServer: TIPCServer;
+    FClient: TIPCClient;
+    FOnServerReceivedCustomRequest: TSingleInstanceReceivedCustomMessage;
+    procedure SetGlobal(const aGlobal: Boolean);
+    procedure SetID(const aID: string);
+  protected
+    procedure DoServerReceivedCustomRequest(const aMsgID: Integer; const aMsgType: Integer; const aStream: TStream);
+    function GetIsClient: Boolean; override;
+    function GetIsServer: Boolean; override;
+    function GetStartResult: TSingleInstanceStart; override;
+  public
+    constructor Create(aOwner: TComponent); override;
+  public
+    function Start: TSingleInstanceStart; override;
+    procedure Stop; override;
+    procedure ServerCheckMessages; override;
+    procedure ClientPostParams; override;
+  public
+    function ClientPostCustomRequest(const aMsgType: Integer; const aStream: TStream): Integer;
+    function ClientSendCustomRequest(const aMsgType: Integer; const aStream: TStream): Boolean; overload;
+    function ClientSendCustomRequest(const aMsgType: Integer; const aStream: TStream; out outRequestID: Integer): Boolean; overload;
+    procedure ServerPostCustomResponse(const aRequestID: Integer; const aMsgType: Integer; const aStream: TStream);
+    function ClientPeekCustomResponse(const aStream: TStream; out outMsgType: Integer): Boolean;
+  public
+    property ID: string read FID write SetID;
+    property Global: Boolean read FGlobal write SetGlobal;
+
+    property OnServerReceivedCustomRequest: TSingleInstanceReceivedCustomMessage read FOnServerReceivedCustomRequest write FOnServerReceivedCustomRequest;
+  end;
+
+implementation
+
+Resourcestring
+  SErrSetSingleInstanceIDStarted = 'You cannot change the single instance ID when it''s been started.';
+  SErrSetSingleInstanceGlobalStarted = 'You cannot change the single instance global property when it''s been started.';
+  SErrStartSingleInstanceStarted = 'You cannot start single instance when it''s been already started.';
+  SErrSingleInstanceStartResultNotAvailable = 'Single instance hasn''t been started yet.';
+  SErrSingleInstanceNotClient = 'Current instance is not a client.';
+  SErrSingleInstanceNotServer = 'Current instance is not a server.';
+
+Const
+  MSGTYPE_CHECK = -1;
+  MSGTYPE_CHECKRESPONSE = -2;
+  MSGTYPE_PARAMS = -3;
+  MSGTYPE_WAITFORINSTANCES = -4;
+
+{ TAdvancedSingleInstance }
+
+constructor TAdvancedSingleInstance.Create(aOwner: TComponent);
+var
+  xID: RawByteString;
+  I: Integer;
+begin
+  inherited Create(aOwner);
+
+  xID := 'SI_'+ExtractFileName(ParamStr(0));
+  for I := 1 to Length(xID) do
+    case xID[I] of
+      'a'..'z', 'A'..'Z', '0'..'9', '_': begin end;
+    else
+      xID[I] := '_';
+    end;
+  ID := xID;
+end;
+
+function TAdvancedSingleInstance.ClientPeekCustomResponse(
+  const aStream: TStream; out outMsgType: Integer): Boolean;
+begin
+  if not Assigned(FClient) then
+    raise ESingleInstance.Create(SErrSingleInstanceNotClient);
+
+  Result := FClient.PeekResponse(aStream, outMsgType, TimeOutMessages);
+end;
+
+function TAdvancedSingleInstance.ClientPostCustomRequest(
+  const aMsgType: Integer; const aStream: TStream): Integer;
+begin
+  if not Assigned(FClient) then
+    raise ESingleInstance.Create(SErrSingleInstanceNotClient);
+
+  Result := FClient.PostRequest(aMsgType, aStream);
+end;
+
+procedure TAdvancedSingleInstance.ClientPostParams;
+var
+  xSL: TStringList;
+  xStringStream: TStringStream;
+  I: Integer;
+begin
+  if not Assigned(FClient) then
+    raise ESingleInstance.Create(SErrSingleInstanceNotClient);
+
+  xSL := TStringList.Create;
+  try
+    for I := 0 to ParamCount do
+      xSL.Add(ParamStr(I));
+
+    xStringStream := TStringStream.Create(xSL.DelimitedText);
+    try
+      xStringStream.Position := 0;
+      FClient.PostRequest(MSGTYPE_PARAMS, xStringStream);
+    finally
+      xStringStream.Free;
+    end;
+  finally
+    xSL.Free;
+  end;
+end;
+
+function TAdvancedSingleInstance.ClientSendCustomRequest(
+  const aMsgType: Integer; const aStream: TStream): Boolean;
+begin
+  if not Assigned(FClient) then
+    raise ESingleInstance.Create(SErrSingleInstanceNotClient);
+
+  Result := FClient.SendRequest(aMsgType, aStream, TimeOutMessages);
+end;
+
+function TAdvancedSingleInstance.ClientSendCustomRequest(
+  const aMsgType: Integer; const aStream: TStream; out
+  outRequestID: Integer): Boolean;
+begin
+  if not Assigned(FClient) then
+    raise ESingleInstance.Create(SErrSingleInstanceNotClient);
+
+  Result := FClient.SendRequest(aMsgType, aStream, TimeOutMessages, outRequestID);
+end;
+
+procedure TAdvancedSingleInstance.DoServerReceivedCustomRequest(
+  const aMsgID: Integer; const aMsgType: Integer; const aStream: TStream);
+begin
+  if Assigned(FOnServerReceivedCustomRequest) then
+    FOnServerReceivedCustomRequest(Self, aMsgID, aMsgType, aStream);
+end;
+
+function TAdvancedSingleInstance.GetIsClient: Boolean;
+begin
+  Result := Assigned(FClient);
+end;
+
+function TAdvancedSingleInstance.GetIsServer: Boolean;
+begin
+  Result := Assigned(FServer);
+end;
+
+function TAdvancedSingleInstance.GetStartResult: TSingleInstanceStart;
+begin
+  if not(Assigned(FServer) or Assigned(FClient)) then
+    raise ESingleInstance.Create(SErrSingleInstanceStartResultNotAvailable);
+
+  Result := inherited GetStartResult;
+end;
+
+procedure TAdvancedSingleInstance.ServerCheckMessages;
+var
+  xMsgID: Integer;
+  xMsgType: Integer;
+  xStream: TStream;
+  xStringStream: TStringStream;
+begin
+  if not Assigned(FServer) then
+    raise ESingleInstance.Create(SErrSingleInstanceNotServer);
+
+  if not FServer.PeekRequest(xMsgID, xMsgType) then
+    Exit;
+
+  case xMsgType of
+    MSGTYPE_CHECK:
+    begin
+      FServer.DeleteRequest(xMsgID);
+      FServer.PostResponse(xMsgID, MSGTYPE_CHECKRESPONSE, nil);
+    end;
+    MSGTYPE_PARAMS:
+    begin
+      xStringStream := TStringStream.Create('');
+      try
+        FServer.ReadRequest(xMsgID, xStringStream);
+        DoServerReceivedParams(xStringStream.DataString);
+      finally
+        xStringStream.Free;
+      end;
+    end;
+    MSGTYPE_WAITFORINSTANCES:
+      FServer.DeleteRequest(xMsgID);
+  else
+    xStream := TMemoryStream.Create;
+    try
+      FServer.ReadRequest(xMsgID, xStream);
+      DoServerReceivedCustomRequest(xMsgID, xMsgType, xStream);
+    finally
+      xStream.Free;
+    end;
+  end;
+end;
+
+procedure TAdvancedSingleInstance.ServerPostCustomResponse(
+  const aRequestID: Integer; const aMsgType: Integer;
+  const aStream: TStream);
+begin
+  if not Assigned(FServer) then
+    raise ESingleInstance.Create(SErrSingleInstanceNotServer);
+
+  FServer.PostResponse(aRequestID, aMsgType, aStream);
+end;
+
+procedure TAdvancedSingleInstance.SetGlobal(const aGlobal: Boolean);
+begin
+  if FGlobal = aGlobal then Exit;
+  if Assigned(FServer) or Assigned(FClient) then
+    raise ESingleInstance.Create(SErrSetSingleInstanceGlobalStarted);
+  FGlobal := aGlobal;
+end;
+
+procedure TAdvancedSingleInstance.SetID(const aID: string);
+begin
+  if FID = aID then Exit;
+  if Assigned(FServer) or Assigned(FClient) then
+    raise ESingleInstance.Create(SErrSetSingleInstanceIDStarted);
+  FID := aID;
+end;
+
+function TAdvancedSingleInstance.Start: TSingleInstanceStart;
+  {$IFNDEF MSWINDOWS}
+  procedure UnixWorkaround(var bServerStarted: Boolean);
+  var
+    xWaitRequestID, xLastCount, xNewCount: Integer;
+    xClient: TIPCClient;
+  begin
+    //file locking workaround for UNIX systems -> the server can be started twice if 2 processes are started in parallel
+    //wait some time to see other clients
+    FServer.StopServer(False);
+    xClient := TIPCClient.Create(Self);
+    try
+      xClient.ServerID := FID;
+      xClient.Global := FGlobal;
+      xWaitRequestID := xClient.PostRequest(MSGTYPE_WAITFORINSTANCES, nil);
+      xLastCount := -1;
+      xNewCount := FServer.GetPendingRequestCount;
+      while xLastCount <> xNewCount do
+      begin
+        xLastCount := xNewCount;
+        Sleep(TimeOutWaitForInstances);
+        xNewCount := FServer.GetPendingRequestCount;
+      end;
+    finally
+      FreeAndNil(xClient);
+    end;
+
+    //find highest client that will be the server
+    if FServer.FindHighestPendingRequestId = xWaitRequestID then
+    begin
+      bServerStarted := FServer.StartServer(False);
+    end else
+    begin
+      //something went wrong, there are not-deleted waiting requests
+      //use random sleep as workaround and try to restart the server
+      Randomize;
+      Sleep(Random(($3F+PtrInt(GetProcessID)) and $3F));//limit to $3F (63)
+      bServerStarted := FServer.StartServer(False) and (FServer.GetPendingRequestCount > 0);
+    end;
+  end;
+  {$ENDIF}
+var
+  xStream: TStream;
+  xMsgType: Integer;
+  xServerStarted: Boolean;
+begin
+  if Assigned(FServer) or Assigned(FClient) then
+    raise ESingleInstance.Create(SErrStartSingleInstanceStarted);
+
+  FServer := TIPCServer.Create(Self);
+  FServer.ServerID := FID;
+  FServer.Global := FGlobal;
+  xServerStarted := FServer.StartServer(False);
+  if xServerStarted then
+  begin//this is single instance -> be server
+    Result := siServer;
+    {$IFNDEF MSWINDOWS}
+    UnixWorkaround(xServerStarted);
+    {$ENDIF}
+  end;
+  if not xServerStarted then
+  begin//instance found -> be client
+    FreeAndNil(FServer);
+    FClient := TIPCClient.Create(Self);
+    FClient.ServerID := FID;
+    FClient.Global := FGlobal;
+    FClient.PostRequest(MSGTYPE_CHECK, nil);
+    xStream := TMemoryStream.Create;
+    try
+      if FClient.PeekResponse(xStream, xMsgType, TimeOutMessages) then
+        Result := siClient
+      else
+        Result := siNotResponding;
+    finally
+      xStream.Free;
+    end;
+  end;
+  SetStartResult(Result);
+end;
+
+procedure TAdvancedSingleInstance.Stop;
+begin
+  FreeAndNil(FServer);
+  FreeAndNil(FClient);
+end;
+
+initialization
+  DefaultSingleInstanceClass:=TAdvancedSingleInstance;
+
+end.
+

+ 60 - 0
packages/fcl-process/examples/checkipcserver.lpi

@@ -0,0 +1,60 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="IPC Client"/>
+      <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="checkipcserver.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <Target>
+      <Filename Value="checkipcserver"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <OtherUnitFiles Value="../units/$(TargetCPU)-$(TargetOS)"/>
+      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

+ 55 - 0
packages/fcl-process/examples/checkipcserver.lpr

@@ -0,0 +1,55 @@
+program checkipcserver;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Classes, SysUtils, CustApp, simpleipc
+  { you can add units after this };
+
+type
+
+  { TSimpleIPCClientApp }
+
+  TSimpleIPCClientApp = class(TCustomApplication)
+  protected
+    procedure DoRun; override;
+  public
+    constructor Create(TheOwner: TComponent); override;
+  end;
+
+{ TSimpleIPCClientApp }
+
+procedure TSimpleIPCClientApp.DoRun;
+var
+  IPCClient: TSimpleIPCClient;
+begin
+  IPCClient := TSimpleIPCClient.Create(nil);
+  IPCClient.ServerID:= 'ipc_test_crash';
+
+  if IPCClient.ServerRunning then
+    WriteLn('Server is runnning')
+  else
+    WriteLn('Server is NOT runnning');
+
+  IPCClient.Destroy;
+  Terminate;
+end;
+
+constructor TSimpleIPCClientApp.Create(TheOwner: TComponent);
+begin
+  inherited Create(TheOwner);
+  StopOnException:=True;
+end;
+
+var
+  Application: TSimpleIPCClientApp;
+begin
+  Application:=TSimpleIPCClientApp.Create(nil);
+  Application.Title:='IPC Client';
+  Application.Run;
+  Application.Free;
+end.
+

+ 19 - 3
packages/fcl-process/examples/ipcclient.pp

@@ -2,16 +2,32 @@
 {$h+}
 program ipcclient;
 
-uses simpleipc;
+uses sysutils,simpleipc;
+
+Var
+  I,Count : Integer;
+  DoStop : Boolean;
 
 begin
+  Count:=1;
   With TSimpleIPCClient.Create(Nil) do
     try
       ServerID:='ipcserver';
       If (ParamCount>0) then
-        ServerInstance:=Paramstr(1);
+        begin
+        DoStop:=(ParamStr(1)='-s') or (paramstr(1)='--stop');
+        if DoStop then
+          ServerInstance:=Paramstr(2)
+        else  
+          ServerInstance:=Paramstr(1);
+        if (Not DoStop) and (ParamCount>1) then
+          Count:=StrToIntDef(ParamStr(2),1);  
+        end;  
       Active:=True;
-      SendStringMessage('Testmessage from client');
+      if DoStop then
+        SendStringMessage('stop')
+      else  for I:=1 to Count do
+        SendStringMessage(Format('Testmessage %d from client',[i]));
       Active:=False;
     finally
       Free;

+ 3 - 1
packages/fcl-process/examples/ipcserver.lpi

@@ -6,7 +6,6 @@
       <Flags>
         <MainUnitHasCreateFormStatements Value="False"/>
         <MainUnitHasTitleStatement Value="False"/>
-        <UseDefaultCompilerOptions Value="True"/>
       </Flags>
       <SessionStorage Value="InProjectDir"/>
       <MainUnit Value="0"/>
@@ -29,6 +28,7 @@
     <RunParams>
       <local>
         <FormatVersion Value="1"/>
+        <CommandLineParams Value="-t"/>
       </local>
     </RunParams>
     <Units Count="1">
@@ -44,6 +44,8 @@
       <Filename Value="ipcserver"/>
     </Target>
     <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <OtherUnitFiles Value="../units/$(TargetCPU)-$(TargetOS)"/>
       <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
     </SearchPaths>
   </CompilerOptions>

+ 55 - 7
packages/fcl-process/examples/ipcserver.pp

@@ -5,31 +5,79 @@ program ipcserver;
 {$APPTYPE CONSOLE}
 
 uses
+  {$ifdef unix}cthreads,{$endif}
   SysUtils,
+  Classes,
   simpleipc;
 
+Type
+  TApp = Class(TObject)  
+    Srv : TSimpleIPCServer;
+    DoStop : Boolean;
+    Procedure MessageQueued(Sender : TObject);
+    procedure Run;
+    Procedure PrintMessage;
+  end;
+
+Procedure TApp.PrintMessage;
+
+Var
+  S : String;
+ 
+begin
+  S:=Srv.StringMessage;
+  Writeln('Received message : ',S);
+  DoStop:=DoStop or (S='stop');
+end;
+
+Procedure TApp.MessageQueued(Sender : TObject);
+
+begin
+  Srv.ReadMessage;
+  PrintMessage;
+end;
+
+
+Procedure TApp.Run;
+  
 Var
-  Srv : TSimpleIPCServer;
   S : String;
+  Threaded : Boolean;
 
 begin
   Srv:=TSimpleIPCServer.Create(Nil);
   Try
+    S:= ParamStr(1);
+    Threaded:=(S='-t') or (S='--threaded');
     Srv.ServerID:='ipcserver';
     Srv.Global:=True;
-    Srv.StartServer;
-    Writeln('Server started. Listening for messages');
+    if Threaded then
+      Srv.OnMessageQueued:=@MessageQueued;
+    Srv.StartServer(Threaded);
+    
+    Writeln('Server started. Listening for messages. Send "stop" message to stop server.');
     Repeat
-      If Srv.PeekMessage(1,True) then
+      If Threaded then
         begin
-        S:=Srv.StringMessage;
-        Writeln('Received message : ',S);
+        Sleep(10);
+        CheckSynchronize;
         end
+      else if Srv.PeekMessage(10,True) then
+        PrintMessage
       else
         Sleep(10);
-    Until CompareText(S,'stop')=0;
+    Until DoStop;
   Finally
     Srv.Free;
   end;
+end;
+
+begin
+  With TApp.Create do
+    try
+      Run
+    finally
+      Free;
+    end;    
 end.
 

+ 59 - 0
packages/fcl-process/examples/simpleipcserver.lpi

@@ -0,0 +1,59 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="IPC Server"/>
+      <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="simpleipcserver.lpr"/>
+        <IsPartOfProject Value="True"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <Target>
+      <Filename Value="simpleipcserver"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

+ 81 - 0
packages/fcl-process/examples/simpleipcserver.lpr

@@ -0,0 +1,81 @@
+program simpleipcserver;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}
+  BaseUnix,
+  {$ENDIF}
+  {$IFDEF windows}
+  Windows,
+  {$ENDIF}
+  Classes, SysUtils, CustApp, simpleipc, Crt;
+
+type
+
+  { TSimpleIPCServerApp }
+
+  TSimpleIPCServerApp = class(TCustomApplication)
+  protected
+    procedure DoRun; override;
+  public
+    constructor Create(TheOwner: TComponent); override;
+  end;
+
+{ TSimpleIPCServerApp }
+
+procedure TSimpleIPCServerApp.DoRun;
+var
+  IPCServer: TSimpleIPCServer;
+  Key: Char;
+  NullObj: TObject;
+begin
+  IPCServer := TSimpleIPCServer.Create(nil);
+  IPCServer.ServerID:='ipc_test_crash';
+  IPCServer.Global:=True;
+  IPCServer.StartServer;
+  NullObj := nil;
+
+  WriteLn('Server started');
+  WriteLn('  Press e to finish with an exception');
+  WriteLn('  Press t to terminate through OS api - ', {$IFDEF UNIX}'Kill'{$ELSE}'TerminateProcess'{$ENDIF});
+  WriteLn('  Press any other key to finish normally');
+  Key := ReadKey;
+
+  case Key of
+    'e':
+      begin
+        NullObj.AfterConstruction;
+      end;
+    't':
+      begin
+        {$ifdef unix}
+        FpKill(FpGetpid, 9);
+        {$endif}
+        {$ifdef windows}
+        TerminateProcess(GetCurrentProcess, 0);
+        {$endif}
+      end;
+  end;
+
+  IPCServer.Active:=False;
+  WriteLn('Server stopped');
+  IPCServer.Destroy;
+  Terminate;
+end;
+
+constructor TSimpleIPCServerApp.Create(TheOwner: TComponent);
+begin
+  inherited Create(TheOwner);
+  StopOnException:=True;
+end;
+
+var
+  Application: TSimpleIPCServerApp;
+begin
+  Application:=TSimpleIPCServerApp.Create(nil);
+  Application.Title:='IPC Server';
+  Application.Run;
+  Application.Free;
+end.
+

+ 4 - 10
packages/fcl-process/src/os2/simpleipc.inc

@@ -164,19 +164,13 @@ end;
 
 
 procedure TPipeServerComm.ReadMessage;
+
 var
   Hdr: TMsgHeader;
+  
 begin
-  FStream.ReadBuffer (Hdr, SizeOf (Hdr));
-  Owner.FMsgType := Hdr.MsgType;
-  if Hdr.MsgLen > 0 then
-    begin
-      Owner.FMsgData.Size:=0;
-      Owner.FMsgData.Seek (0, soFromBeginning);
-      Owner.FMsgData.CopyFrom (FStream, Hdr.MsgLen);
-    end
-  else
-    Owner.FMsgData.Size := 0;
+  FStream.ReadBuffer(Hdr,SizeOf(Hdr));
+  PushMessage(Hdr,FStream);
 end;
 
 function TPipeServerComm.GetInstanceID: string;

+ 359 - 27
packages/fcl-process/src/simpleipc.pp

@@ -20,11 +20,12 @@ unit simpleipc;
 interface
 
 uses
-  Classes, SysUtils;
+  Contnrs, Classes, SysUtils;
 
 Const
   MsgVersion = 1;
-  
+  DefaultThreadTimeOut = 50;
+
   //Message types
   mtUnknown = 0;
   mtString = 1;
@@ -33,7 +34,6 @@ type
   TIPCMessageOverflowAction = (ipcmoaNone, ipcmoaDiscardOld, ipcmoaDiscardNew, ipcmoaError);
 
 var
-  // Currently implemented only for Windows platform!
   DefaultIPCMessageOverflowAction: TIPCMessageOverflowAction = ipcmoaNone;
   DefaultIPCMessageQueueLimit: Integer = 0;
 
@@ -49,6 +49,36 @@ Type
   TSimpleIPCServer = class;
   TSimpleIPCClient = class;
 
+  TIPCServerMsg = 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;
+
+  TIPCServerMsgQueue = 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: TIPCServerMsg);
+    function Pop: TIPCServerMsg;
+    property Count: Integer read GetCount;
+    property MaxCount: Integer read FMaxCount write FMaxCount;
+    property MaxAction: TIPCMessageOverflowAction read FMaxAction write FMaxAction;
+  end;
+
   { TIPCServerComm }
   
   TIPCServerComm = Class(TObject)
@@ -57,14 +87,16 @@ Type
   Protected  
     Function  GetInstanceID : String; virtual; abstract;
     Procedure DoError(const Msg : String; const Args : Array of const);
-    Procedure SetMsgType(AMsgType: TMessageType); 
-    Function MsgData : TStream;
+    Procedure PushMessage(Const Hdr : TMsgHeader; AStream : TStream);
+    Procedure PushMessage(Msg : TIPCServerMsg);
   Public
     Constructor Create(AOwner : TSimpleIPCServer); virtual;
     Property Owner : TSimpleIPCServer read FOwner;
     Procedure StartServer; virtual; Abstract;
     Procedure StopServer;virtual; Abstract;
+    // May push messages on the queue
     Function  PeekMessage(TimeOut : Integer) : Boolean;virtual; Abstract;
+    // Must put message on the queue.
     Procedure ReadMessage ;virtual; Abstract;
     Property InstanceID : String read GetInstanceID;
   end;
@@ -93,24 +125,46 @@ Type
 
   { TSimpleIPCServer }
 
+  TMessageQueueEvent = Procedure(Sender : TObject; Msg : TIPCServerMsg) of object;
+
   TSimpleIPCServer = Class(TSimpleIPC)
-  private
+  protected
+  Private
+    FOnMessageError: TMessageQueueEvent;
+    FOnMessageQueued: TNotifyEvent;
+    FQueue : TIPCServerMsgQueue;
     FGlobal: Boolean;
     FOnMessage: TNotifyEvent;
     FMsgType: TMessageType;
     FMsgData : TStream;
+    FThreadTimeOut: Integer;
+    FThread : TThread;
+    FLock : TRTLCriticalSection;
+    FErrMsg : TIPCServerMsg;
+    procedure DoMessageQueued;
+    procedure DoMessageError;
     function GetInstanceID: String;
+    function GetMaxAction: TIPCMessageOverflowAction;
+    function GetMaxQueue: Integer;
     function GetStringMessage: String;
     procedure SetGlobal(const AValue: Boolean);
+    procedure SetMaxAction(AValue: TIPCMessageOverflowAction);
+    procedure SetMaxQueue(AValue: Integer);
   Protected
     FIPCComm: TIPCServerComm;
+    procedure StartThread; virtual;
+    procedure StopThread; virtual;
     Function CommClass : TIPCServerCommClass; virtual;
+    Procedure PushMessage(Msg : TIPCServerMsg); virtual;
+    function PopMessage: Boolean; virtual;
     Procedure Activate; override;
     Procedure Deactivate; override;
+    Property Queue : TIPCServerMsgQueue Read FQueue;
+    Property Thread : TThread Read FThread;
   Public
     Constructor Create(AOwner : TComponent); override;
     Destructor Destroy; override;
-    Procedure StartServer;
+    Procedure StartServer(Threaded : Boolean = False);
     Procedure StopServer;
     Function PeekMessage(TimeOut : Integer; DoReadMessage : Boolean): Boolean;
     Procedure ReadMessage;
@@ -120,8 +174,18 @@ Type
     Property  MsgData : TStream Read FMsgData;
     Property  InstanceID : String Read GetInstanceID;
   Published
+    Property ThreadTimeOut : Integer Read FThreadTimeOut Write FThreadTimeOut;
     Property Global : Boolean Read FGlobal Write SetGlobal;
+    // Called during ReadMessage
     Property OnMessage : TNotifyEvent Read FOnMessage Write FOnMessage;
+    // Called when a message is pushed on the queue.
+    Property OnMessageQueued : TNotifyEvent Read FOnMessageQueued Write FOnMessageQueued;
+    // Called when the queue overflows and  MaxAction = ipcmoaError.
+    Property OnMessageError : TMessageQueueEvent Read FOnMessageError Write FOnMessageError;
+    // Maximum number of messages to keep in the queue
+    property MaxQueue: Integer read GetMaxQueue write SetMaxQueue;
+    // What to do when the queue overflows
+    property MaxAction: TIPCMessageOverflowAction read GetMaxAction write SetMaxAction;
   end;
 
 
@@ -194,6 +258,103 @@ implementation
 
 {$i simpleipc.inc}
 
+Resourcestring
+  SErrMessageQueueOverflow = 'Message queue overflow (limit %s)';
+
+{ ---------------------------------------------------------------------
+    TIPCServerMsg
+  ---------------------------------------------------------------------}
+
+
+constructor TIPCServerMsg.Create;
+begin
+  FMsgType := 0;
+  FStream := TMemoryStream.Create;
+end;
+
+destructor TIPCServerMsg.Destroy;
+begin
+  FStream.Free;
+end;
+
+{ ---------------------------------------------------------------------
+    TIPCServerMsgQueue
+  ---------------------------------------------------------------------}
+
+constructor TIPCServerMsgQueue.Create;
+begin
+  FMaxCount := DefaultIPCMessageQueueLimit;
+  FMaxAction := DefaultIPCMessageOverflowAction;
+  FList := TFPObjectList.Create(False); // FreeObjects = False!
+end;
+
+destructor TIPCServerMsgQueue.Destroy;
+begin
+  Clear;
+  FList.Free;
+end;
+
+procedure TIPCServerMsgQueue.Clear;
+begin
+  while FList.Count > 0 do
+    DeleteAndFree(FList.Count - 1);
+end;
+
+procedure TIPCServerMsgQueue.DeleteAndFree(Index: Integer);
+begin
+  FList[Index].Free; // Free objects manually!
+  FList.Delete(Index);
+end;
+
+function TIPCServerMsgQueue.GetCount: Integer;
+begin
+  Result := FList.Count;
+end;
+
+function TIPCServerMsgQueue.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 TIPCServerMsgQueue.Push(AItem: TIPCServerMsg);
+begin
+  if PrepareToPush then
+    FList.Insert(0, AItem);
+end;
+
+function TIPCServerMsgQueue.Pop: TIPCServerMsg;
+var
+  Index: Integer;
+begin
+  Index := FList.Count - 1;
+  if Index >= 0 then
+  begin
+    // Caller is responsible for freeing the object.
+    Result := TIPCServerMsg(FList[Index]);
+    FList.Delete(Index);
+  end
+  else
+    Result := nil;
+end;
+
+
 { ---------------------------------------------------------------------
     TIPCServerComm
   ---------------------------------------------------------------------}
@@ -203,22 +364,33 @@ begin
   FOwner:=AOWner;
 end;
 
-Procedure TIPCServerComm.DoError(const Msg : String; const Args : Array of const);
+procedure TIPCServerComm.DoError(const Msg: String; const Args: array of const);
 
 begin
   FOwner.DoError(Msg,Args);
-end;  
+end;
 
-Function TIPCServerComm.MsgData : TStream;
+procedure TIPCServerComm.PushMessage(const Hdr: TMsgHeader; AStream: TStream);
+
+Var
+  M : TIPCServerMsg;
 
 begin
-  Result:=FOwner.FMsgData;
+  M:=TIPCServerMsg.Create;
+  try
+    M.MsgType:=Hdr.MsgType;
+    if Hdr.MsgLen>0 then
+      M.Stream.CopyFrom(AStream,Hdr.MsgLen);
+  except
+    M.Free;
+    Raise;
+  end;
+  PushMessage(M);
 end;
 
-Procedure TIPCServerComm.SetMsgType(AMsgType: TMessageType); 
-
+procedure TIPCServerComm.PushMessage(Msg: TIPCServerMsg);
 begin
-  Fowner.FMsgType:=AMsgType;
+  FOwner.PushMessage(Msg);
 end;
 
 { ---------------------------------------------------------------------
@@ -314,11 +486,14 @@ begin
   FActive:=False;
   FBusy:=False;
   FMsgData:=TStringStream.Create('');
+  FQueue:=TIPCServerMsgQueue.Create;
+  FThreadTimeOut:=DefaultThreadTimeOut;
 end;
 
 destructor TSimpleIPCServer.Destroy;
 begin
   Active:=False;
+  FreeAndNil(FQueue);
   FreeAndNil(FMsgData);
   inherited Destroy;
 end;
@@ -332,11 +507,31 @@ begin
     end;
 end;
 
+procedure TSimpleIPCServer.SetMaxAction(AValue: TIPCMessageOverflowAction);
+begin
+  FQueue.MaxAction:=AValue;
+end;
+
+procedure TSimpleIPCServer.SetMaxQueue(AValue: Integer);
+begin
+  FQueue.MaxCount:=AValue;
+end;
+
 function TSimpleIPCServer.GetInstanceID: String;
 begin
   Result:=FIPCComm.InstanceID;
 end;
 
+function TSimpleIPCServer.GetMaxAction: TIPCMessageOverflowAction;
+begin
+  Result:=FQueue.MaxAction;
+end;
+
+function TSimpleIPCServer.GetMaxQueue: Integer;
+begin
+  Result:=FQueue.MaxCount;
+end;
+
 
 function TSimpleIPCServer.GetStringMessage: String;
 begin
@@ -344,7 +539,7 @@ begin
 end;
 
 
-procedure TSimpleIPCServer.StartServer;
+procedure TSimpleIPCServer.StartServer(Threaded : Boolean = False);
 begin
   if Not Assigned(FIPCComm) then
     begin
@@ -354,47 +549,135 @@ begin
     FIPCComm.StartServer;
     end;
   FActive:=True;
+  If Threaded then
+    StartThread;
+end;
+
+Type
+
+  { TServerThread }
+
+  TServerThread = Class(TThread)
+  private
+    FServer: TSimpleIPCServer;
+    FThreadTimeout: Integer;
+  Public
+    Constructor Create(AServer : TSimpleIPCServer; ATimeout : integer);
+    procedure Execute; override;
+    Property Server : TSimpleIPCServer Read FServer;
+    Property ThreadTimeout : Integer Read FThreadTimeout;
+  end;
+
+{ TServerThread }
+
+constructor TServerThread.Create(AServer: TSimpleIPCServer; ATimeout: integer);
+begin
+  FServer:=AServer;
+  FThreadTimeout:=ATimeOut;
+  Inherited Create(False);
+end;
+
+procedure TServerThread.Execute;
+begin
+  While Not Terminated do
+    FServer.PeekMessage(ThreadTimeout,False);
+end;
+
+procedure TSimpleIPCServer.StartThread;
+
+begin
+  InitCriticalSection(FLock);
+  FThread:=TServerThread.Create(Self,ThreadTimeOut);
+end;
+
+procedure TSimpleIPCServer.StopThread;
+
+begin
+  if Assigned(FThread) then
+    begin
+    FThread.Terminate;
+    FThread.WaitFor;
+    FreeAndNil(FThread);
+    DoneCriticalSection(FLock);
+    end;
 end;
 
 procedure TSimpleIPCServer.StopServer;
 begin
+  StopThread;
   If Assigned(FIPCComm) then
     begin
     FIPCComm.StopServer;
     FreeAndNil(FIPCComm);
     end;
+  FQueue.Clear;
   FActive:=False;
 end;
 
 // TimeOut values:
-//   >  0  -- number of milliseconds to wait
+//   >  0  -- Number of milliseconds to wait
 //   =  0  -- return immediately
 //   = -1  -- wait infinitely
 //   < -1  -- wait infinitely (force to -1)
 function TSimpleIPCServer.PeekMessage(TimeOut: Integer; DoReadMessage: Boolean): Boolean;
 begin
   CheckActive;
-  if TimeOut < -1 then
-    TimeOut := -1;
-  FBusy:=True;
-  Try
-    Result:=FIPCComm.PeekMessage(Timeout);
-  Finally
-    FBusy:=False;
-  end;
+  Result:=Queue.Count>0;
+  If Not Result then
+    begin
+    if TimeOut < -1 then
+      TimeOut := -1;
+    FBusy:=True;
+    Try
+      Result:=FIPCComm.PeekMessage(Timeout);
+    Finally
+      FBusy:=False;
+    end;
+    end;
   If Result then
     If DoReadMessage then
       Readmessage;
 end;
 
+function TSimpleIPCServer.PopMessage: Boolean;
+
+var
+  MsgItem: TIPCServerMsg;
+  DoLock : Boolean;
+
+begin
+  DoLock:=Assigned(FThread);
+  if DoLock then
+    EnterCriticalsection(Flock);
+  try
+    MsgItem:=FQueue.Pop;
+  finally
+    LeaveCriticalsection(FLock);
+  end;
+  Result:=Assigned(MsgItem);
+  if Result then
+    try
+      FMsgType := MsgItem.MsgType;
+      MsgItem.Stream.Position := 0;
+      FMsgData.Size := 0;
+      FMsgData.CopyFrom(MsgItem.Stream, MsgItem.Stream.Size);
+    finally
+      MsgItem.Free;
+    end;
+end;
+
 procedure TSimpleIPCServer.ReadMessage;
+
 begin
   CheckActive;
   FBusy:=True;
   Try
-    FIPCComm.ReadMessage;
-    If Assigned(FOnMessage) then
-      FOnMessage(Self);
+    if (FQueue.Count=0) then
+      // Readmessage pushes a message to the queue
+      FIPCComm.ReadMessage;
+    if PopMessage then
+      If Assigned(FOnMessage) then
+        FOnMessage(Self);
   Finally
     FBusy:=False;
   end;
@@ -416,6 +699,55 @@ begin
 end;
 
 
+procedure TSimpleIPCServer.DoMessageQueued;
+
+begin
+  if Assigned(FOnMessageQueued) then
+    FOnMessageQueued(Self);
+end;
+
+procedure TSimpleIPCServer.DoMessageError;
+begin
+  try
+    if Assigned(FOnMessageQueued) then
+      FOnMessageError(Self,FErrMsg);
+  finally
+    FreeAndNil(FErrMsg)
+  end;
+end;
+
+procedure TSimpleIPCServer.PushMessage(Msg: TIPCServerMsg);
+
+Var
+  DoLock : Boolean;
+
+begin
+  try
+    DoLock:=Assigned(FThread);
+    If DoLock then
+      EnterCriticalsection(FLock);
+    try
+      Queue.Push(Msg);
+    finally
+      If DoLock then
+        LeaveCriticalsection(FLock);
+    end;
+    if DoLock then
+      TThread.Synchronize(FThread,@DoMessageQueued)
+    else
+      DoMessageQueued;
+  except
+    On E : Exception do
+      FErrMsg:=Msg;
+  end;
+  if Assigned(FErrMsg) then
+    if DoLock then
+      TThread.Synchronize(FThread,@DoMessageError)
+    else
+      DoMessageQueued;
+
+end;
+
 
 
 { ---------------------------------------------------------------------

+ 27 - 81
packages/fcl-process/src/unix/simpleipc.inc

@@ -26,10 +26,6 @@ uses sysutils, classes, simpleipc, baseunix;
 uses baseunix;
 {$endif}
 
-{$DEFINE OSNEEDIPCINITDONE}
-
-
-
 
 ResourceString
   SErrFailedToCreatePipe = 'Failed to create named pipe: %s';
@@ -58,57 +54,6 @@ Type
 implementation
 {$endif}
 
-Var
-  SocketFiles : TStringList;
-
-Procedure IPCInit;
-
-begin
-end;
-
-Procedure IPCDone;
-
-Var
-  I : integer;
-  
-begin
-  if Assigned(SocketFiles) then
-    try
-      For I:=0 to SocketFiles.Count-1 do
-        DeleteFile(SocketFiles[i]);
-    finally  
-      FreeAndNil(SocketFiles);  
-    end;  
-end;
-
-
-Procedure RegisterSocketFile(Const AFileName : String);
-
-begin
-  If Not Assigned(SocketFiles) then
-    begin
-    SocketFiles:=TStringList.Create;
-    SocketFiles.Sorted:=True;
-    end;
-  SocketFiles.Add(AFileName);  
-end;
-
-Procedure UnRegisterSocketFile(Const AFileName : String);
-
-Var
-  I : Integer;
-begin
-  If Assigned(SocketFiles) then
-    begin
-    I:=SocketFiles.IndexOf(AFileName);  
-    If (I<>-1) then
-      SocketFiles.Delete(I);
-    If (SocketFiles.Count=0) then
-      FreeAndNil(SocketFiles);
-    end;
-end;
-
-
 constructor TPipeClientComm.Create(AOWner: TSimpleIPCClient);
 begin
   inherited Create(AOWner);
@@ -140,7 +85,6 @@ procedure TPipeClientComm.SendMessage(MsgType : TMessagetype; AStream: TStream);
 
 Var
   Hdr : TMsgHeader;
-  P,L,Count : Integer;
 
 begin
   Hdr.Version:=MsgVersion;
@@ -180,10 +124,15 @@ end;
   ---------------------------------------------------------------------}
 
 Type
+
+  { TPipeServerComm }
+
   TPipeServerComm = Class(TIPCServerComm)
   Private
     FFileName: String;
     FStream: TFileStream;
+  Protected
+    Procedure DoReadMessage; virtual;
   Public
     Constructor Create(AOWner : TSimpleIPCServer); override;
     Procedure StartServer; override;
@@ -195,6 +144,16 @@ 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
   inherited Create(AOWner);
@@ -218,12 +177,10 @@ begin
     If (fpmkFifo(FFileName,438)<>0) then
       DoError(SErrFailedToCreatePipe,[FFileName]);
   FStream:=TFileStream.Create(FFileName,fmOpenReadWrite+fmShareDenyNone,Rights[Owner.Global]);
-  RegisterSocketFile(FFileName);
 end;
 
 procedure TPipeServerComm.StopServer;
 begin
-  UnregisterSocketFile(FFileName);
   FreeAndNil(FStream);
   if Not DeleteFile(FFileName) then
     DoError(SErrFailedtoRemovePipe,[FFileName]);
@@ -237,40 +194,33 @@ Var
 begin
   fpfd_zero(FDS);
   fpfd_set(FStream.Handle,FDS);
-  Result:=fpSelect(FStream.Handle+1,@FDS,Nil,Nil,TimeOut)>0;
+  Result:=False;
+  While fpSelect(FStream.Handle+1,@FDS,Nil,Nil,TimeOut)>0 do
+    begin
+    DoReadMessage;
+    Result:=True;
+    end;
 end;
 
 procedure TPipeServerComm.ReadMessage;
 
-Var
-  L,P,Count : Integer;
-  Hdr : TMsgHeader;
-  M : TStream;
 begin
-  FStream.ReadBuffer(Hdr,SizeOf(Hdr));
-  SetMsgType(Hdr.MsgType);
-  Count:=Hdr.MsgLen;
-  M:=MsgData;
-  if count > 0 then
-    begin
-    M.Size:=0;
-    M.Seek(0,soFrombeginning);
-    M.CopyFrom(FStream,Count);
-    end
-  else
-    M.Size := 0;
+  DoReadMessage;
 end;
 
+
 function TPipeServerComm.GetInstanceID: String;
 begin
   Result:=IntToStr(fpGetPID);
 end;
 
+
 { ---------------------------------------------------------------------
     Set TSimpleIPCClient / TSimpleIPCServer defaults.
   ---------------------------------------------------------------------}
+
 {$ifndef ipcunit}
-Function TSimpleIPCServer.CommClass : TIPCServerCommClass;
+function TSimpleIPCServer.CommClass: TIPCServerCommClass;
 
 begin
   if (DefaultIPCServerClass<>Nil) then
@@ -288,10 +238,6 @@ begin
 end;
 
 {$else ipcunit}
-initialization
-  IPCInit;
-  
-Finalization
-  IPCDone;  
+
 end.
 {$endif}

+ 11 - 147
packages/fcl-process/src/winall/simpleipc.inc

@@ -14,7 +14,7 @@
 
  **********************************************************************}
 
-uses Windows,messages,contnrs;
+uses Windows,messages;
 
 const
   MsgWndClassName: WideString = 'FPCMsgWindowCls';
@@ -22,7 +22,6 @@ const
 resourcestring
   SErrFailedToRegisterWindowClass = 'Failed to register message window class';
   SErrFailedToCreateWindow = 'Failed to create message window %s';
-  SErrMessageQueueOverflow = 'Message queue overflow (limit %s)';
 
 var
   MsgWindowClass: TWndClassW = (
@@ -38,43 +37,12 @@ var
     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: WideString) : HWND;
     procedure ProcessMessages;
     procedure ProcessMessagesWait(TimeOut: Integer);
@@ -97,95 +65,6 @@ type
     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
   ---------------------------------------------------------------------}
@@ -257,13 +136,11 @@ begin
     FWindowName := FWindowName+'_'+InstanceID;
   FWndProcException := False;
   FWndProcExceptionMsg := '';
-  FMsgQueue := TWinMsgServerMsgQueue.Create;
 end;
 
 destructor TWinMsgServerComm.Destroy;
 begin
   StopServer;
-  FMsgQueue.Free;
   inherited;
 end;
 
@@ -275,7 +152,6 @@ end;
 
 procedure TWinMsgServerComm.StopServer;
 begin
-  FMsgQueue.Clear;
   if FHWND <> 0 then
   begin
     DestroyWindow(FHWND);
@@ -304,12 +180,12 @@ end;
 
 function TWinMsgServerComm.HaveQueuedMessages: Boolean; inline;
 begin
-  Result := (FMsgQueue.Count > 0);
+  Result := (Owner.Queue.Count > 0);
 end;
 
 function TWinMsgServerComm.CountQueuedMessages: Integer; inline;
 begin
-  Result := FMsgQueue.Count;
+  Result := Owner.Queue.Count;
 end;
 
 procedure TWinMsgServerComm.HandlePostedMessage(const Msg: TMsg); inline;
@@ -397,10 +273,11 @@ end;
 procedure TWinMsgServerComm.ReadMsgData(var Msg: TMsg);
 var
   CDS: PCopyDataStruct;
-  MsgItem: TWinMsgServerMsg;
+  MsgItem: TIPCServerMsg;
+
 begin
   CDS := PCopyDataStruct(Msg.lParam);
-  MsgItem := TWinMsgServerMsg.Create;
+  MsgItem := TIPCServerMsg.Create;
   try
     MsgItem.MsgType := CDS^.dwData;
     MsgItem.Stream.WriteBuffer(CDS^.lpData^,CDS^.cbData);
@@ -409,7 +286,7 @@ begin
     // Caller is expected to catch this exception, so not using Owner.DoError()
     raise;
   end;
-  FMsgQueue.Push(MsgItem);
+  PushMessage(MsgItem);
 end;
 
 function TWinMsgServerComm.TryReadMsgData(var Msg: TMsg; out Error: String): Boolean;
@@ -426,21 +303,8 @@ begin
 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;
+  // Do nothing, PeekMessages has pushed messages to the queue.
 end;
 
 function TWinMsgServerComm.GetInstanceID: String;
@@ -451,7 +315,7 @@ end;
 { ---------------------------------------------------------------------
     TWinMsgClientComm
   ---------------------------------------------------------------------}
-  
+
 Type
   TWinMsgClientComm = Class(TIPCClientComm)
   Private
@@ -544,7 +408,7 @@ Function TSimpleIPCServer.CommClass : TIPCServerCommClass;
 begin
   if (DefaultIPCServerClass<>Nil) then
     Result:=DefaultIPCServerClass
-  else  
+  else
     Result:=TWinMsgServerComm;
 end;
 
@@ -553,7 +417,7 @@ Function TSimpleIPCClient.CommClass : TIPCClientCommClass;
 begin
   if (DefaultIPCClientClass<>Nil) then
     Result:=DefaultIPCClientClass
-  else  
+  else
     Result:=TWinMsgClientComm;
 end;