[fpc-devel] simpleipc issues
Ondrej Pokorny
lazarus at kluug.net
Wed Sep 30 18:50:04 CEST 2015
On 29.09.2015 22:47, Michael Van Canneyt wrote:
> Let's first see how Ondrej does it.
See the patch attached. A simple demo program is attached as well
(SITest.lpr).
advancedipc.pp: refactoring MsgID -> RequestID and some smaller issues
solved. API hasn't changed.
singleinstance.pp: class implementing single instance.
custapp.pp: added singleinstance property. Set Enabled to True (before
CustomApplication.Initialize) and it does everything for you. You can
also set more properties like ID and Global.
You can talk to the server single instance after Application.Initialize
if you want to (see SITest.lpr).
+ I am now travelling so I have only MS Windows to check. There is a
workaround for UNIX to solve the filelock problem. The problem is that
if you execute more files from the explorer, the instances are started
at the same time so there could be problems with creating the file lock
(double file locks can occur). The clue is that you wait for other
instances to start (timeout 100ms) and then use the highest instance as
server. If there are some pending wait-requests (if the program
collapsed or something like that) there is a random sleep to decide what
instance should be the server. This approach is very bullet-proof, as my
tests showed (the random sleep is not needed in normal situations).
+ A small issue is that checking for new messages in
CustomApplication.DoRun too often uses a lot of CPU power. The check
should be made only about every 50ms (then the CPU needed is at ~0%). I
don't know how to do it the best way, because eg. using GetTickCount
needs also a lot of CPU. I don't know how it behaves with TApplication
(maybe there is no such problem).
+ I had a problem with random numbers (I checked windows implementation
only). If randomize is executed from 2 different processes at exactly
same moment, it returns the same randseed (GetTickCount). This is a big
problem with processors with multithreading. In this case you can have
exactly same random sequences for 2 different threads/processes. I
suggest to include GetCurrentThreadID into randomize somehow.
Something like:
procedure randomize;
begin
randseed:=Integer(Int64(GetTickCount)+GetCurrentThreadID);
end;
Addition is maybe not the best operation, but you should get the idea.
I solved this problem by adding GetCurrentThreadID to the random result,
so advancedipc is not affected by this problem any more.
+ Juha, I will upload a new patch for Lazarus IDEInstances. Probably
nothing changed, but just to be sure.
Ondrej
-------------- next part --------------
Index: packages/fcl-base/src/advancedipc.pp
===================================================================
--- packages/fcl-base/src/advancedipc.pp (revision 31890)
+++ packages/fcl-base/src/advancedipc.pp (working copy)
@@ -60,13 +60,14 @@
FMessageVersion: Integer;
protected
class function ServerIDToFileName(const aServerID: string; const aGlobal: Boolean): string;
- function GetResponseFileName(const aMsgID: Integer): string;
+ function GetResponseFileName(const aRequestID: Integer): string;
function GetResponseFileName(const aRequestFileName: string): string;
- function GetPeekedRequestFileName(const aMsgID: Integer): string;
+ function GetPeekedRequestFileName(const aRequestID: Integer): string;
function GetPeekedRequestFileName(const aRequestFileName: string): string;
function GetRequestPrefix: string;
- function GetRequestFileName(const aMsgID: Integer): string;
- function RequestFileNameToMsgID(const aFileName: string): Integer;
+ function GetRequestFileName(const aRequestID: Integer): string;
+ function RequestFileNameToID(const aFileName: string): Integer;
+ function RequestExists(const aRequestFileName: string): Boolean;
function GetUniqueRequest(out outFileName: string): Integer;
procedure SetServerID(const aServerID: string); virtual;
@@ -122,19 +123,19 @@
public
//peek request and read the message into a stream
function PeekRequest(const aStream: TStream; out outMsgType: TMessageType): Boolean; overload;
- function PeekRequest(const aStream: TStream; out outMsgID: Integer; out outMsgType: TMessageType): Boolean; overload;
- function PeekRequest(const aStream: TStream; out outMsgID: Integer; out outMsgType: TMessageType; const aTimeOut: Integer): Boolean; overload;
+ function PeekRequest(const aStream: TStream; out outRequestID: Integer; out outMsgType: TMessageType): Boolean; overload;
+ function PeekRequest(const aStream: TStream; out outRequestID: Integer; out outMsgType: TMessageType; const aTimeOut: Integer): Boolean; overload;
//only peek request, you have to read/delete the request manually with ReadRequest/DeleteRequest
function PeekRequest(out outMsgType: TMessageType): Boolean; overload;
- function PeekRequest(out outMsgID: Integer; out outMsgType: TMessageType): Boolean; overload;
- function PeekRequest(out outMsgID: Integer; out outMsgType: TMessageType; const aTimeOut: Integer): Boolean; overload;
+ function PeekRequest(out outRequestID: Integer; out outMsgType: TMessageType): Boolean; overload;
+ function PeekRequest(out outRequestID: Integer; out outMsgType: TMessageType; const aTimeOut: Integer): Boolean; overload;
//read a peeked request (that hasn't been read yet)
- function ReadRequest(const aMsgID: Integer; const aStream: TStream): Boolean;
+ function ReadRequest(const aRequestID: Integer; const aStream: TStream): Boolean;
//delete a peeked request (that hasn't been read yet)
- procedure DeleteRequest(const aMsgID: Integer);
+ procedure DeleteRequest(const aRequestID: Integer);
//post response to a request
- procedure PostResponse(const aMsgID: Integer; const aMsgType: TMessageType; const aStream: TStream);
+ procedure PostResponse(const aRequestID: Integer; const aMsgType: TMessageType; const aStream: TStream);
//find the highest request ID from all pending requests
function FindHighestPendingRequestId: Integer;
@@ -217,11 +218,20 @@
begin
Randomize;
repeat
- Result := Random(High(Integer));
+ //if Randomize/Random is started from 2 processes at exactly same moment, it returns the same number! -> prevent duplicates by adding GetCurrentThreadId
+ Result := Integer(Int64(Random(High(Integer)))+GetCurrentThreadId);
outFileName := GetRequestFileName(Result);
- until not FileExists(outFileName);
+ until not RequestExists(outFileName);
end;
+function TIPCBase.RequestExists(const aRequestFileName: string): Boolean;
+begin
+ Result :=
+ (FileExists(aRequestFileName) or
+ FileExists(GetResponseFileName(aRequestFileName)) or
+ FileExists(GetPeekedRequestFileName(aRequestFileName)));
+end;
+
class function TIPCBase.ServerRunning(const aServerID: string;
const aGlobal: Boolean): Boolean;
var
@@ -271,8 +281,8 @@
xStream := TFileStream.Create(aFileName, fmCreate or fmShareExclusive, GLOBAL_RIGHTS);
try
xStream.WriteBuffer(xHeader, SizeOf(xHeader));
- if Assigned(aStream) then
- xStream.CopyFrom(aStream, 0);
+ if Assigned(aStream) and (aStream.Size-aStream.Position > 0) then
+ xStream.CopyFrom(aStream, aStream.Size-aStream.Position);
xStream.Position := 0;//unlocking
xHeader.FileLock := 0;
@@ -282,7 +292,7 @@
end;
end;
-function TIPCBase.RequestFileNameToMsgID(const aFileName: string): Integer;
+function TIPCBase.RequestFileNameToID(const aFileName: string): Integer;
begin
//the function prevents all responses/temp files to be handled
//only valid response files are returned
@@ -309,9 +319,9 @@
FindClose(xRec);
end;
-function TIPCBase.GetPeekedRequestFileName(const aMsgID: Integer): string;
+function TIPCBase.GetPeekedRequestFileName(const aRequestID: Integer): string;
begin
- Result := GetPeekedRequestFileName(GetRequestFileName(aMsgID));
+ Result := GetPeekedRequestFileName(GetRequestFileName(aRequestID));
end;
function TIPCBase.GetPeekedRequestFileName(const aRequestFileName: string
@@ -320,9 +330,9 @@
Result := aRequestFileName+'-t';
end;
-function TIPCBase.GetRequestFileName(const aMsgID: Integer): string;
+function TIPCBase.GetRequestFileName(const aRequestID: Integer): string;
begin
- Result := GetRequestPrefix+IntToHex(aMsgID, 8);
+ Result := GetRequestPrefix+IntToHex(aRequestID, 8);
end;
function TIPCBase.GetRequestPrefix: string;
@@ -330,9 +340,9 @@
Result := FFileName+'-';
end;
-function TIPCBase.GetResponseFileName(const aMsgID: Integer): string;
+function TIPCBase.GetResponseFileName(const aRequestID: Integer): string;
begin
- Result := GetResponseFileName(GetRequestFileName(aMsgID));
+ Result := GetResponseFileName(GetRequestFileName(aRequestID));
end;
function TIPCBase.GetResponseFileName(const aRequestFileName: string): string;
@@ -378,7 +388,8 @@
xFileResponse := GetResponseFileName(FLastMsgFileName);
if CanReadMessage(xFileResponse, xStream, outMsgType, xMsgLen) then
begin
- aStream.CopyFrom(xStream, xMsgLen);
+ if xMsgLen > 0 then
+ aStream.CopyFrom(xStream, xMsgLen);
xStream.Free;
aStream.Position := 0;
DeleteFile(xFileResponse);
@@ -456,9 +467,9 @@
FindClose(xRec);
end;
-procedure TIPCServer.DeleteRequest(const aMsgID: Integer);
+procedure TIPCServer.DeleteRequest(const aRequestID: Integer);
begin
- DeleteFile(GetPeekedRequestFileName(aMsgID));
+ DeleteFile(GetPeekedRequestFileName(aRequestID));
end;
constructor TIPCServer.Create(aOwner: TComponent);
@@ -470,7 +481,7 @@
destructor TIPCServer.Destroy;
begin
- if FActive then
+ if Active then
StopServer;
inherited Destroy;
@@ -490,7 +501,7 @@
if FindFirst(GetRequestPrefix+'*', faAnyFile, xRec) = 0 then
begin
repeat
- Result := RequestFileNameToMsgID(xRec.Name);
+ Result := RequestFileNameToID(xRec.Name);
if Result >= 0 then
begin
outFileName := GetRequestFileName(Result);
@@ -505,7 +516,7 @@
function TIPCServer.FindHighestPendingRequestId: Integer;
var
xRec: TRawByteSearchRec;
- xMsgID, xHighestId: LongInt;
+ xRequestID, xHighestId: LongInt;
begin
xHighestId := -1;
Result := -1;
@@ -512,11 +523,11 @@
if FindFirst(GetRequestPrefix+'*', faAnyFile, xRec) = 0 then
begin
repeat
- xMsgID := RequestFileNameToMsgID(xRec.Name);
- if xMsgID > xHighestId then
+ xRequestID := RequestFileNameToID(xRec.Name);
+ if xRequestID > xHighestId then
begin
- xHighestId := xMsgID;
- Result := xMsgID;
+ xHighestId := xRequestID;
+ Result := xRequestID;
end;
until FindNext(xRec) <> 0;
end;
@@ -531,7 +542,7 @@
if FindFirst(GetRequestPrefix+'*', faAnyFile, xRec) = 0 then
begin
repeat
- if RequestFileNameToMsgID(xRec.Name) >= 0 then
+ if RequestFileNameToID(xRec.Name) >= 0 then
Inc(Result);
until FindNext(xRec) <> 0;
end;
@@ -538,7 +549,7 @@
FindClose(xRec);
end;
-function TIPCServer.PeekRequest(out outMsgID: Integer; out
+function TIPCServer.PeekRequest(out outRequestID: Integer; out
outMsgType: TMessageType): Boolean;
var
xStream: TStream;
@@ -547,8 +558,8 @@
begin
outMsgType := -1;
xMsgFileName := '';
- outMsgID := FindFirstRequest(xMsgFileName, xStream, outMsgType, xMsgLen);
- Result := outMsgID >= 0;
+ outRequestID := FindFirstRequest(xMsgFileName, xStream, outMsgType, xMsgLen);
+ Result := outRequestID >= 0;
if Result then
begin
xStream.Free;
@@ -556,7 +567,7 @@
end;
end;
-function TIPCServer.PeekRequest(out outMsgID: Integer; out
+function TIPCServer.PeekRequest(out outRequestID: Integer; out
outMsgType: TMessageType; const aTimeOut: Integer): Boolean;
var
xStart: QWord;
@@ -564,7 +575,7 @@
Result := False;
xStart := GetTickCount64;
repeat
- if PeekRequest(outMsgID, outMsgType) then
+ if PeekRequest(outRequestID, outMsgType) then
Exit(True)
else if aTimeOut > 20 then
Sleep(10);
@@ -573,42 +584,42 @@
function TIPCServer.PeekRequest(out outMsgType: TMessageType): Boolean;
var
- xMsgID: Integer;
+ xRequestID: Integer;
begin
- Result := PeekRequest(xMsgID, outMsgType);
+ Result := PeekRequest(xRequestID, outMsgType);
end;
-function TIPCServer.PeekRequest(const aStream: TStream; out outMsgID: Integer;
+function TIPCServer.PeekRequest(const aStream: TStream; out outRequestID: Integer;
out outMsgType: TMessageType): Boolean;
begin
- Result := PeekRequest(outMsgID, outMsgType);
+ Result := PeekRequest(outRequestID, outMsgType);
if Result then
- Result := ReadRequest(outMsgID, aStream);
+ Result := ReadRequest(outRequestID, aStream);
end;
-function TIPCServer.PeekRequest(const aStream: TStream; out outMsgID: Integer;
+function TIPCServer.PeekRequest(const aStream: TStream; out outRequestID: Integer;
out outMsgType: TMessageType; const aTimeOut: Integer): Boolean;
begin
- Result := PeekRequest(outMsgID, outMsgType, aTimeOut);
+ Result := PeekRequest(outRequestID, outMsgType, aTimeOut);
if Result then
- Result := ReadRequest(outMsgID, aStream);
+ Result := ReadRequest(outRequestID, aStream);
end;
function TIPCServer.PeekRequest(const aStream: TStream; out
outMsgType: TMessageType): Boolean;
var
- xMsgID: Integer;
+ xRequestID: Integer;
begin
- Result := PeekRequest(aStream, xMsgID, outMsgType);
+ Result := PeekRequest(aStream, xRequestID, outMsgType);
end;
-procedure TIPCServer.PostResponse(const aMsgID: Integer;
+procedure TIPCServer.PostResponse(const aRequestID: Integer;
const aMsgType: TMessageType; const aStream: TStream);
begin
- DoPostMessage(GetResponseFileName(aMsgID), aMsgType, aStream);
+ DoPostMessage(GetResponseFileName(aRequestID), aMsgType, aStream);
end;
-function TIPCServer.ReadRequest(const aMsgID: Integer; const aStream: TStream
+function TIPCServer.ReadRequest(const aRequestID: Integer; const aStream: TStream
): Boolean;
var
xStream: TStream;
@@ -617,15 +628,15 @@
xFileRequest: string;
begin
aStream.Size := 0;
- xFileRequest := GetPeekedRequestFileName(aMsgID);
+ xFileRequest := GetPeekedRequestFileName(aRequestID);
Result := CanReadMessage(xFileRequest, xStream, xMsgType, xMsgLen);
if Result then
begin
- aStream.CopyFrom(xStream, xMsgLen);
+ if xMsgLen > 0 then
+ aStream.CopyFrom(xStream, xMsgLen);
xStream.Free;
aStream.Position := 0;
DeleteFile(xFileRequest);
- Exit(True);
end;
end;
@@ -647,6 +658,9 @@
function TIPCServer.StartServer(const aDeletePendingRequests: Boolean): Boolean;
begin
+ if Active then
+ Exit(True);
+
FFileHandle := FileCreate(FFileName, fmCreate or fmShareExclusive, GLOBAL_RIGHTS);
Result := (FFileHandle<>feInvalidHandle);
FActive := Result;
@@ -656,13 +670,12 @@
function TIPCServer.StopServer(const aDeletePendingRequests: Boolean): Boolean;
begin
- if not FActive then
+ if not Active then
Exit(True);
if FFileHandle<>feInvalidHandle then
FileClose(FFileHandle);
Result := DeleteFile(FFileName);
- FFileName := '';
if aDeletePendingRequests then
DeletePendingRequests;
@@ -671,4 +684,3 @@
end;
end.
-
Index: packages/fcl-base/src/custapp.pp
===================================================================
--- packages/fcl-base/src/custapp.pp (revision 31890)
+++ packages/fcl-base/src/custapp.pp (working copy)
@@ -18,12 +18,15 @@
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)
@@ -30,6 +33,7 @@
Private
FEventLogFilter: TEventLogTypes;
FOnException: TExceptionEvent;
+ FSingleInstance: TCustomSingleInstance;
FTerminated : Boolean;
FHelpFile,
FTitle : String;
@@ -86,8 +90,17 @@
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;
Implementation
@@ -228,7 +241,10 @@
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 @@
FOptionChar:='-';
FCaseSensitiveOptions:=True;
FStopOnException:=False;
+ FSingleInstance := TCustomSingleInstance.Create(Self);
end;
destructor TCustomApplication.Destroy;
@@ -276,6 +293,18 @@
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 @@
end;
Procedure AddToResult(Const Msg : string);
-
+
begin
If (Result<>'') then
Result:=Result+sLineBreak;
- Result:=Result+Msg;
+ Result:=Result+Msg;
end;
begin
Index: packages/fcl-base/src/singleinstance.pp
===================================================================
--- packages/fcl-base/src/singleinstance.pp (nonexistent)
+++ packages/fcl-base/src/singleinstance.pp (working copy)
@@ -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+GetThreadID) 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.
+
-------------- next part --------------
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.
More information about the fpc-devel
mailing list