From f7cab410c58a27a32f217654c490cd64c46f6dc3 Mon Sep 17 00:00:00 2001 From: michael Date: Wed, 11 Nov 2015 16:26:19 +0000 Subject: [PATCH] * Single instance functionality by Ondrej Pokorny git-svn-id: trunk@32287 - --- .gitattributes | 2 + packages/fcl-base/examples/sitest.pp | 104 ++++++ packages/fcl-base/fpmake.pp | 6 +- packages/fcl-base/src/custapp.pp | 37 ++- packages/fcl-base/src/singleinstance.pp | 419 ++++++++++++++++++++++++ 5 files changed, 563 insertions(+), 5 deletions(-) create mode 100644 packages/fcl-base/examples/sitest.pp create mode 100644 packages/fcl-base/src/singleinstance.pp diff --git a/.gitattributes b/.gitattributes index 77402d5c80..40c7d4f56f 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1966,6 +1966,7 @@ packages/fcl-base/examples/showver.pp svneol=native#text/plain packages/fcl-base/examples/showver.rc -text packages/fcl-base/examples/showver.res -text packages/fcl-base/examples/simple.xml -text +packages/fcl-base/examples/sitest.pp svneol=native#text/plain packages/fcl-base/examples/sockcli.pp svneol=native#text/plain packages/fcl-base/examples/socksvr.pp svneol=native#text/plain packages/fcl-base/examples/sstream.pp svneol=native#text/plain @@ -2045,6 +2046,7 @@ packages/fcl-base/src/pooledmm.pp svneol=native#text/plain packages/fcl-base/src/rtfdata.inc svneol=native#text/plain packages/fcl-base/src/rtfpars.pp svneol=native#text/plain packages/fcl-base/src/rttiutils.pp svneol=native#text/plain +packages/fcl-base/src/singleinstance.pp svneol=native#text/plain packages/fcl-base/src/streamcoll.pp svneol=native#text/plain packages/fcl-base/src/streamex.pp svneol=native#text/plain packages/fcl-base/src/streamio.pp svneol=native#text/plain diff --git a/packages/fcl-base/examples/sitest.pp b/packages/fcl-base/examples/sitest.pp new file mode 100644 index 0000000000..ca71dc63db --- /dev/null +++ b/packages/fcl-base/examples/sitest.pp @@ -0,0 +1,104 @@ +program SITest; + +{$mode objfpc} +{$h+} + +uses + Classes, + CustApp, advancedipc, singleinstance; + +type + TMyCustomApplication = class(TCustomApplication) + private + procedure ServerReceivedParams(Sender: TBaseSingleInstance; aParams: TStringList); + procedure ServerReceivedCustomRequest(Sender: TBaseSingleInstance; {%H-}MsgID: Integer; aMsgType: TMessageType; MsgData: TStream); + end; + +const + MsgType_Request_No_Response = 1; + MsgType_Request_With_Response = 2; + MsgType_Response = 3; + +{ TMyCustomApplication } + +procedure TMyCustomApplication.ServerReceivedCustomRequest( + Sender: TBaseSingleInstance; MsgID: Integer; aMsgType: TMessageType; + MsgData: TStream); +var + xData: string; + xStringStream: TStringStream; +begin + MsgData.Position := 0; + SetLength(xData, MsgData.Size div SizeOf(Char)); + if MsgData.Size > 0 then + MsgData.ReadBuffer(xData[1], MsgData.Size); + + WriteLn('Request: ', xData); + + if aMsgType = MsgType_Request_With_Response then + begin + WriteLn('Sending response to client.'); + xStringStream := TStringStream.Create('my response'); + try + Sender.ServerPostCustomResponse(MsgID, MsgType_Response, xStringStream); + finally + xStringStream.Free; + end; + end; +end; + +procedure TMyCustomApplication.ServerReceivedParams(Sender: TBaseSingleInstance; + aParams: TStringList); +var + I: Integer; +begin + Writeln('-----'); + Writeln('Params:'); + for I := 0 to aParams.Count-1 do + Writeln(aParams[I]); + Writeln('-----'); +end; + +var + xApp: TMyCustomApplication; + xStream: TStringStream; + xMsgType: TMessageType; +begin + xApp := TMyCustomApplication.Create(nil); + try + xApp.SingleInstance.Enabled := True; + xApp.SingleInstance.OnServerReceivedParams := @xApp.ServerReceivedParams; + xApp.SingleInstance.OnServerReceivedCustomRequest := @xApp.ServerReceivedCustomRequest; + xApp.Initialize; + Writeln(xApp.SingleInstance.StartResult); + xApp.Run; + + case xApp.SingleInstance.StartResult of + siNotResponding: ReadLn; + siClient: + begin + xStream := TStringStream.Create('hello'); + try + xApp.SingleInstance.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); + xStream.Size := 0; + if xApp.SingleInstance.ClientPeekCustomResponse(xStream, xMsgType) then + WriteLn('Response: ', xStream.DataString) + else + WriteLn('Error: no response'); + finally + xStream.Free; + end; + ReadLn; + end; + end; + finally + xApp.Free; + end; +end. + diff --git a/packages/fcl-base/fpmake.pp b/packages/fcl-base/fpmake.pp index fc8166a6b1..cc34fe8c1b 100644 --- a/packages/fcl-base/fpmake.pp +++ b/packages/fcl-base/fpmake.pp @@ -52,8 +52,12 @@ begin T.ResourceStrings:=true; T:=P.Targets.AddUnit('contnrs.pp'); T.ResourceStrings:=true; - T:=P.Targets.AddUnit('custapp.pp'); + T:=P.Targets.AddUnit('singleinstance.pp'); T.ResourceStrings:=true; + T:=P.Targets.AddUnit('custapp.pp'); + T.ResourceStrings:=true; + with T.Dependencies do + AddUnit('singleinstance'); T:=P.Targets.AddUnit('eventlog.pp'); T.ResourceStrings:=true; with T.Dependencies do diff --git a/packages/fcl-base/src/custapp.pp b/packages/fcl-base/src/custapp.pp index 2100e5bc23..4f9664a145 100644 --- a/packages/fcl-base/src/custapp.pp +++ b/packages/fcl-base/src/custapp.pp @@ -18,18 +18,22 @@ unit CustApp; Interface -uses SysUtils,Classes; +uses SysUtils,Classes,singleinstance; 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; FTerminated : Boolean; FHelpFile, FTitle : String; @@ -86,6 +90,15 @@ 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; end; var CustomApplication : TCustomApplication = nil; @@ -228,7 +241,10 @@ end; procedure TCustomApplication.DoRun; begin - // Do nothing. Override in descendent classes. + if FSingleInstance.IsServer then + FSingleInstance.ServerCheckMessages; + + // Override in descendent classes. end; procedure TCustomApplication.DoLog(EventType: TEventType; const Msg: String); @@ -250,6 +266,7 @@ begin FOptionChar:='-'; FCaseSensitiveOptions:=True; FStopOnException:=False; + FSingleInstance := TCustomSingleInstance.Create(Self); end; destructor TCustomApplication.Destroy; @@ -276,6 +293,18 @@ end; procedure TCustomApplication.Initialize; begin FTerminated:=False; + if FSingleInstance.Enabled then + begin + case FSingleInstance.Start of + siClient: + begin + FSingleInstance.ClientPostParams; + FTerminated:=True; + end; + siNotResponding: + FTerminated:=True; + end; + end; end; procedure TCustomApplication.Run; @@ -442,11 +471,11 @@ Var end; Procedure AddToResult(Const Msg : string); - + begin If (Result<>'') then Result:=Result+sLineBreak; - Result:=Result+Msg; + Result:=Result+Msg; end; begin diff --git a/packages/fcl-base/src/singleinstance.pp b/packages/fcl-base/src/singleinstance.pp new file mode 100644 index 0000000000..adb4429733 --- /dev/null +++ b/packages/fcl-base/src/singleinstance.pp @@ -0,0 +1,419 @@ +unit singleinstance; + +{ + This file is part of the Free Component Library (FCL) + Copyright (c) 2015 by Ondrej Pokorny + + 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. + + **********************************************************************} + +{$mode objfpc} +{$H+} + +interface + +uses + SysUtils, Classes, advancedipc; + +type + + TBaseSingleInstance = class; + + //siServer: No other instance is running. The server is started. + //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; + 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); + 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; + 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; + 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; + 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; + + 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.'; + +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; +begin + Stop; + + 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 + xSL: TStringList; +begin + if not Assigned(FOnServerReceivedParams) then + Exit; + + xSL := TStringList.Create; + try + xSL.DelimitedText := aParamsDelimitedText; + FOnServerReceivedParams(Self, xSL); + finally + xSL.Free; + 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.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; + +end. +