[fpc-devel] simpleipc issues
Ondrej Pokorny
lazarus at kluug.net
Wed Nov 11 15:12:40 CET 2015
On 29.09.2015 12:52, Michael Van Canneyt wrote:
> Juha, if you want to implement the single IDE instance, then I would
> like to ask you to implement this in custapp.pp. This is useful
> functionality for all kinds of applications, and is since very long on
> my todo list.
On 30.09.2015 18:50, Ondrej Pokorny wrote:
> 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).
Hello Michael,
you asked for implementing "single instance" in custapp.pp. I did it and
sent a patch on Sept 28th. Did you have the time to check it and find
eventual issues?
I am resending the patch against current trunk and a testing application.
Ondrej
-------------- next part --------------
Index: packages/fcl-base/src/custapp.pp
===================================================================
--- packages/fcl-base/src/custapp.pp (revision 32284)
+++ 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
-------------- 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.
-------------- next part --------------
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+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.
More information about the fpc-devel
mailing list