* Refactored singleinstance so it is independent of any specific implementation

git-svn-id: trunk@32770 -

packages/fcl-base/examples/sitest.pp

@@ -40,7 +40,7 @@ begin
     WriteLn('Sending response to client.');
     xStringStream := TStringStream.Create('my response');
     try
-      Sender.ServerPostCustomResponse(MsgID, MsgType_Response, xStringStream);
+      (Sender as TAdvancedSingleInstance).ServerPostCustomResponse(MsgID, MsgType_Response, xStringStream);
     finally
       xStringStream.Free;
     end;
@@ -66,9 +66,9 @@ var
 begin
   xApp := TMyCustomApplication.Create(nil);
   try
-    xApp.SingleInstance.Enabled := True;
+    xApp.SingleInstanceEnabled := True;
     xApp.SingleInstance.OnServerReceivedParams := @xApp.ServerReceivedParams;
-    xApp.SingleInstance.OnServerReceivedCustomRequest := @xApp.ServerReceivedCustomRequest;
+    (xApp.SingleInstance as TAdvancedSingleInstance).OnServerReceivedCustomRequest := @xApp.ServerReceivedCustomRequest;
     xApp.Initialize;
     Writeln(xApp.SingleInstance.StartResult);
     xApp.Run;
@@ -79,15 +79,15 @@ begin
       begin
         xStream := TStringStream.Create('hello');
         try
-          xApp.SingleInstance.ClientSendCustomRequest(MsgType_Request_No_Response, xStream);
+          (xApp.SingleInstance as TAdvancedSingleInstance).ClientSendCustomRequest(MsgType_Request_No_Response, xStream);
         finally
           xStream.Free;
         end;
         xStream := TStringStream.Create('I want a response');
         try
-          xApp.SingleInstance.ClientSendCustomRequest(MsgType_Request_With_Response, xStream);
+          (xApp.SingleInstance as TAdvancedSingleInstance).ClientSendCustomRequest(MsgType_Request_With_Response, xStream);
           xStream.Size := 0;
-          if xApp.SingleInstance.ClientPeekCustomResponse(xStream, xMsgType) then
+          if (xApp.SingleInstance as TAdvancedSingleInstance).ClientPeekCustomResponse(xStream, xMsgType) then
             WriteLn('Response: ', xStream.DataString)
           else
             WriteLn('Error: no response');

packages/fcl-base/src/advancedipc.pp

@@ -30,7 +30,7 @@ uses
   {$IFDEF UNIX}
   baseunix,
   {$endif}
-  sysutils, Classes;
+  sysutils, Classes, singleinstance;
 
 const
   HEADER_VERSION = 2;
@@ -168,6 +168,43 @@ 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.';
@@ -772,8 +809,284 @@ 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);

packages/fcl-base/src/custapp.pp

@@ -25,16 +25,15 @@ Type
   TExceptionEvent = Procedure (Sender : TObject; E : Exception) Of Object;
   TEventLogTypes = Set of TEventType;
 
-  TCustomApplication = Class;
-  TCustomSingleInstance = Class;
-
   { TCustomApplication }
 
   TCustomApplication = Class(TComponent)
   Private
     FEventLogFilter: TEventLogTypes;
     FOnException: TExceptionEvent;
-    FSingleInstance: TCustomSingleInstance;
+    FSingleInstance: TBaseSingleInstance;
+    FSingleInstanceClass: TBaseSingleInstanceClass; // set before FSingleInstance is created
+    FSingleInstanceEnabled: Boolean; // set before Initialize is called
     FTerminated : Boolean;
     FHelpFile,
     FTitle : String;
@@ -44,6 +43,9 @@ Type
     function GetEnvironmentVar(VarName : String): String;
     function GetExeName: string;
     Function GetLocation : String;
+    function GetSingleInstance: TBaseSingleInstance;
+    procedure SetSingleInstanceClass(
+      const ASingleInstanceClass: TBaseSingleInstanceClass);
     function GetTitle: string;
   Protected
     function GetOptionAtIndex(AIndex: Integer; IsLong: Boolean): String;
@@ -96,15 +98,9 @@ Type
     Property CaseSensitiveOptions : Boolean Read FCaseSensitiveOptions Write FCaseSensitiveOptions;
     Property StopOnException : Boolean Read FStopOnException Write FStopOnException;
     Property EventLogFilter : TEventLogTypes Read FEventLogFilter Write FEventLogFilter;
-    Property SingleInstance: TCustomSingleInstance read FSingleInstance;
-  end;
-
-  TCustomSingleInstance = class(TBaseSingleInstance)
-  private
-    FEnabled: Boolean;
-  public
-    //you must set Enabled before CustomApplication.Initialize
-    property Enabled: Boolean read FEnabled write FEnabled;
+    Property SingleInstance: TBaseSingleInstance read GetSingleInstance;
+    Property SingleInstanceClass: TBaseSingleInstanceClass read FSingleInstanceClass write SetSingleInstanceClass;
+    Property SingleInstanceEnabled: Boolean read FSingleInstanceEnabled write FSingleInstanceEnabled;
   end;
 
 var CustomApplication : TCustomApplication = nil;
@@ -235,6 +231,17 @@ begin
   Result:=ParamStr(Index);
 end;
 
+function TCustomApplication.GetSingleInstance: TBaseSingleInstance;
+begin
+  if FSingleInstance = nil then
+    begin
+    if FSingleInstanceClass=Nil then
+      Raise ESingleInstance.Create('No single instance provider class set! Include a single-instance class unit such as advsingleinstance');
+    FSingleInstance := FSingleInstanceClass.Create(Self);
+    end;
+  Result := FSingleInstance;
+end;
+
 procedure TCustomApplication.SetTitle(const AValue: string);
 begin
   FTitle:=AValue;
@@ -247,8 +254,9 @@ end;
 
 procedure TCustomApplication.DoRun;
 begin
-  if FSingleInstance.IsServer then
-    FSingleInstance.ServerCheckMessages;
+  if Assigned(FSingleInstance) then
+    if FSingleInstance.IsServer then
+      FSingleInstance.ServerCheckMessages;
 
   // Override in descendent classes.
 end;
@@ -283,7 +291,7 @@ begin
   FOptionChar:='-';
   FCaseSensitiveOptions:=True;
   FStopOnException:=False;
-  FSingleInstance := TCustomSingleInstance.Create(Self);
+  FSingleInstanceClass := DefaultSingleInstanceClass;
 end;
 
 destructor TCustomApplication.Destroy;
@@ -310,12 +318,12 @@ end;
 procedure TCustomApplication.Initialize;
 begin
   FTerminated:=False;
-  if FSingleInstance.Enabled then
+  if FSingleInstanceEnabled then
   begin
-    case FSingleInstance.Start of
+    case SingleInstance.Start of
       siClient:
       begin
-        FSingleInstance.ClientPostParams;
+        SingleInstance.ClientPostParams;
         FTerminated:=True;
       end;
       siNotResponding:
@@ -336,6 +344,13 @@ begin
   Until FTerminated;
 end;
 
+procedure TCustomApplication.SetSingleInstanceClass(
+  const ASingleInstanceClass: TBaseSingleInstanceClass);
+begin
+  Assert((FSingleInstance = nil) and (ASingleInstanceClass <> nil));
+  FSingleInstanceClass := ASingleInstanceClass;
+end;
+
 procedure TCustomApplication.ShowException(E: Exception);
 
 begin

packages/fcl-base/src/singleinstance.pp

@@ -19,7 +19,7 @@ unit singleinstance;
 interface
 
 uses
-  SysUtils, Classes, advancedipc;
+  SysUtils, Classes;
 
 type
 
@@ -29,187 +29,58 @@ type
   //siClient: There is another instance running. This instance is used as client.
   //siNotResponding: There is another instance running but it doesn't respond.
   TSingleInstanceStart = (siServer, siClient, siNotResponding);
-  TSingleInstanceParams = procedure(Sender: TBaseSingleInstance; Params: TStringList) of object;
-  TSingleInstanceReceivedCustomMessage = procedure(Sender: TBaseSingleInstance; MsgID: Integer; MsgType: TMessageType; MsgData: TStream) of object;
+  TSingleInstanceParamsEvent = procedure(Sender: TBaseSingleInstance; Params: TStringList) of object;
   TBaseSingleInstance = class(TComponent)
   private
-    FGlobal: Boolean;
-    FID: string;
-    FServer: TIPCServer;
-    FClient: TIPCClient;
     FStartResult: TSingleInstanceStart;
     FTimeOutMessages: Integer;
     FTimeOutWaitForInstances: Integer;
-    FOnServerReceivedCustomRequest: TSingleInstanceReceivedCustomMessage;
-    FOnServerReceivedParams: TSingleInstanceParams;
-    function GetIsClient: Boolean;
-    function GetIsServer: Boolean;
-    function GetStartResult: TSingleInstanceStart;
-    procedure SetGlobal(const aGlobal: Boolean);
-    procedure SetID(const aID: string);
+    FOnServerReceivedParams: TSingleInstanceParamsEvent;
+  Protected  
+    function GetIsClient: Boolean; virtual; abstract;
+    function GetIsServer: Boolean; virtual; abstract;
+    function GetStartResult: TSingleInstanceStart; virtual;
     procedure DoServerReceivedParams(const aParamsDelimitedText: string);
-    procedure DoServerReceivedCustomRequest(const aMsgID: Integer; const aMsgType: TMessageType; const aStream: TStream);
-  protected
-    //call Start when you want to start single instance checking
-    function Start: TSingleInstanceStart;
-    //stop single instance server or client
-    procedure Stop;
-
-    procedure ServerCheckMessages;
-    procedure ClientPostParams;
+    Procedure SetStartResult(AValue : TSingleInstanceStart); 
   public
     constructor Create(aOwner: TComponent); override;
     destructor Destroy; override;
   public
-    function ClientPostCustomRequest(const aMsgType: TMessageType; const aStream: TStream): Integer;
-    function ClientSendCustomRequest(const aMsgType: TMessageType; const aStream: TStream): Boolean; overload;
-    function ClientSendCustomRequest(const aMsgType: TMessageType; const aStream: TStream; out outRequestID: Integer): Boolean; overload;
-    procedure ServerPostCustomResponse(const aRequestID: Integer; const aMsgType: TMessageType; const aStream: TStream);
-    function ClientPeekCustomResponse(const aStream: TStream; out outMsgType: TMessageType): Boolean;
+    //call Start when you want to start single instance checking
+    function Start: TSingleInstanceStart; virtual; abstract;
+    //stop single instance server or client
+    procedure Stop; virtual; abstract;
+
+    //check and handle pending messages on server
+    procedure ServerCheckMessages; virtual; abstract;
+    //post cmd parameters from client to server
+    procedure ClientPostParams; virtual; abstract;
   public
-    property ID: string read FID write SetID;
-    property Global: Boolean read FGlobal write SetGlobal;
     property TimeOutMessages: Integer read FTimeOutMessages write FTimeOutMessages;
     property TimeOutWaitForInstances: Integer read FTimeOutWaitForInstances write FTimeOutWaitForInstances;
-    property OnServerReceivedParams: TSingleInstanceParams read FOnServerReceivedParams write FOnServerReceivedParams;
-    property OnServerReceivedCustomRequest: TSingleInstanceReceivedCustomMessage read FOnServerReceivedCustomRequest write FOnServerReceivedCustomRequest;
+    property OnServerReceivedParams: TSingleInstanceParamsEvent read FOnServerReceivedParams write FOnServerReceivedParams;
   public
     property StartResult: TSingleInstanceStart read GetStartResult;
     property IsServer: Boolean read GetIsServer;
     property IsClient: Boolean read GetIsClient;
   end;
-
-  TSingleInstance = class(TBaseSingleInstance)
-  public
-    function Start: TSingleInstanceStart;
-    procedure Stop;
-
-    procedure ServerCheckMessages;
-    procedure ClientPostParams;
-  end;
+  TBaseSingleInstanceClass = class of TBaseSingleInstance;
 
   ESingleInstance = class(Exception);
 
-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.';
+Var
+  DefaultSingleInstanceClass : TBaseSingleInstanceClass = Nil;
 
-Const
-  MSGTYPE_CHECK = -1;
-  MSGTYPE_CHECKRESPONSE = -2;
-  MSGTYPE_PARAMS = -3;
-  MSGTYPE_WAITFORINSTANCES = -4;
-
-{ TSingleInstance }
-
-procedure TSingleInstance.ClientPostParams;
-begin
-  inherited ClientPostParams;
-end;
-
-procedure TSingleInstance.ServerCheckMessages;
-begin
-  inherited ServerCheckMessages;
-end;
-
-function TSingleInstance.Start: TSingleInstanceStart;
-begin
-  Result := inherited Start;
-end;
-
-procedure TSingleInstance.Stop;
-begin
-  inherited Stop;
-end;
+implementation
 
 { TBaseSingleInstance }
 
-function TBaseSingleInstance.ClientPeekCustomResponse(const aStream: TStream; out
-  outMsgType: TMessageType): Boolean;
-begin
-  if not Assigned(FClient) then
-    raise ESingleInstance.Create(SErrSingleInstanceNotClient);
-
-  Result := FClient.PeekResponse(aStream, outMsgType, FTimeOutMessages);
-end;
-
-function TBaseSingleInstance.ClientPostCustomRequest(const aMsgType: TMessageType;
-  const aStream: TStream): Integer;
-begin
-  if not Assigned(FClient) then
-    raise ESingleInstance.Create(SErrSingleInstanceNotClient);
-
-  Result := FClient.PostRequest(aMsgType, aStream);
-end;
-
-procedure TBaseSingleInstance.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 TBaseSingleInstance.ClientSendCustomRequest(
-  const aMsgType: TMessageType; const aStream: TStream): Boolean;
-begin
-  if not Assigned(FClient) then
-    raise ESingleInstance.Create(SErrSingleInstanceNotClient);
-
-  Result := FClient.SendRequest(aMsgType, aStream, FTimeOutMessages);
-end;
-
-function TBaseSingleInstance.ClientSendCustomRequest(const aMsgType: TMessageType;
-  const aStream: TStream; out outRequestID: Integer): Boolean;
-begin
-  if not Assigned(FClient) then
-    raise ESingleInstance.Create(SErrSingleInstanceNotClient);
-
-  Result := FClient.SendRequest(aMsgType, aStream, FTimeOutMessages, outRequestID);
-end;
-
 constructor TBaseSingleInstance.Create(aOwner: TComponent);
-var
-  xID: RawByteString;
-  I: Integer;
 begin
   inherited Create(aOwner);
 
   FTimeOutMessages := 1000;
   FTimeOutWaitForInstances := 100;
-
-  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;
 
 destructor TBaseSingleInstance.Destroy;
@@ -219,13 +90,6 @@ begin
   inherited Destroy;
 end;
 
-procedure TBaseSingleInstance.DoServerReceivedCustomRequest(
-  const aMsgID: Integer; const aMsgType: TMessageType; const aStream: TStream);
-begin
-  if Assigned(FOnServerReceivedCustomRequest) then
-    FOnServerReceivedCustomRequest(Self, aMsgID, aMsgType, aStream);
-end;
-
 procedure TBaseSingleInstance.DoServerReceivedParams(
   const aParamsDelimitedText: string);
 var
@@ -243,177 +107,16 @@ begin
   end;
 end;
 
-function TBaseSingleInstance.GetIsClient: Boolean;
-begin
-  Result := Assigned(FClient);
-end;
-
-function TBaseSingleInstance.GetIsServer: Boolean;
-begin
-  Result := Assigned(FServer);
-end;
-
 function TBaseSingleInstance.GetStartResult: TSingleInstanceStart;
 begin
-  if not(Assigned(FServer) or Assigned(FClient)) then
-    raise ESingleInstance.Create(SErrSingleInstanceStartResultNotAvailable);
-
   Result := FStartResult;
 end;
 
-procedure TBaseSingleInstance.ServerCheckMessages;
-var
-  xMsgID: Integer;
-  xMsgType: TMessageType;
-  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 TBaseSingleInstance.ServerPostCustomResponse(
-  const aRequestID: Integer; const aMsgType: TMessageType;
-  const aStream: TStream);
-begin
-  if not Assigned(FServer) then
-    raise ESingleInstance.Create(SErrSingleInstanceNotServer);
-
-  FServer.PostResponse(aRequestID, aMsgType, aStream);
-end;
-
-procedure TBaseSingleInstance.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 TBaseSingleInstance.SetStartResult(AValue : TSingleInstanceStart);
 
-procedure TBaseSingleInstance.SetID(const aID: string);
 begin
-  if FID = aID then Exit;
-  if Assigned(FServer) or Assigned(FClient) then
-    raise ESingleInstance.Create(SErrSetSingleInstanceIDStarted);
-  FID := aID;
-end;
-
-procedure TBaseSingleInstance.Stop;
-begin
-  FreeAndNil(FServer);
-  FreeAndNil(FClient);
-end;
-
-function TBaseSingleInstance.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(FTimeOutWaitForInstances);
-        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(GetCurrentThreadId)) and $3F));//limit to $3F (63)
-      bServerStarted := FServer.StartServer(False) and (FServer.GetPendingRequestCount > 0);
-    end;
-  end;
-  {$ENDIF}
-var
-  xStream: TStream;
-  xMsgType: TMessageType;
-  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, FTimeOutMessages) then
-        Result := siClient
-      else
-        Result := siNotResponding;
-    finally
-      xStream.Free;
-    end;
-  end;
-  FStartResult := Result;
-end;
+  FStartResult:=AValue;
+end;   
 
 end.