mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-19 23:39:31 +02:00
* Refactored singleinstance so it is independent of any specific implementation
git-svn-id: trunk@32770 -
This commit is contained in:
michael
parent
2451f7596b
commit
a2985a5572
@ -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');
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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);
|
||||
|
||||
Var
|
||||
DefaultSingleInstanceClass : TBaseSingleInstanceClass = Nil;
|
||||
|
||||
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;
|
||||
|
||||
{ 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;
|
||||
|
||||
{ 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;
|
||||
Procedure TBaseSingleInstance.SetStartResult(AValue : TSingleInstanceStart);
|
||||
|
||||
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.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.
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user