From 0455973fe4484fe90128f43fa28be3d3487b9ff3 Mon Sep 17 00:00:00 2001 From: marco Date: Thu, 26 May 2016 14:48:46 +0000 Subject: [PATCH] --- Merging r33697 into '.': G packages/fcl-process/src/unix/simpleipc.inc --- Recording mergeinfo for merge of r33697 into '.': G . # revisions: 33697 git-svn-id: branches/fixes_3_0@33818 - --- .gitattributes | 5 + packages/fcl-base/fpmake.pp | 2 + packages/fcl-base/src/advancedipc.pp | 313 -------------- .../fcl-base/src/advancedsingleinstance.pas | 350 ++++++++++++++++ .../fcl-process/examples/checkipcserver.lpi | 60 +++ .../fcl-process/examples/checkipcserver.lpr | 55 +++ packages/fcl-process/examples/ipcclient.pp | 22 +- packages/fcl-process/examples/ipcserver.lpi | 4 +- packages/fcl-process/examples/ipcserver.pp | 62 ++- .../fcl-process/examples/simpleipcserver.lpi | 59 +++ .../fcl-process/examples/simpleipcserver.lpr | 81 ++++ packages/fcl-process/src/os2/simpleipc.inc | 14 +- packages/fcl-process/src/simpleipc.pp | 390 ++++++++++++++++-- packages/fcl-process/src/unix/simpleipc.inc | 108 ++--- packages/fcl-process/src/winall/simpleipc.inc | 158 +------ 15 files changed, 1092 insertions(+), 591 deletions(-) create mode 100644 packages/fcl-base/src/advancedsingleinstance.pas create mode 100644 packages/fcl-process/examples/checkipcserver.lpi create mode 100644 packages/fcl-process/examples/checkipcserver.lpr create mode 100644 packages/fcl-process/examples/simpleipcserver.lpi create mode 100644 packages/fcl-process/examples/simpleipcserver.lpr diff --git a/.gitattributes b/.gitattributes index 67241f424c..8a95e4a411 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1985,6 +1985,7 @@ packages/fcl-base/examples/txmlreg.pp svneol=native#text/plain packages/fcl-base/examples/xmldump.pp svneol=native#text/plain packages/fcl-base/fpmake.pp svneol=native#text/plain packages/fcl-base/src/advancedipc.pp svneol=native#text/plain +packages/fcl-base/src/advancedsingleinstance.pas svneol=native#text/plain packages/fcl-base/src/ascii85.pp svneol=native#text/plain packages/fcl-base/src/avl_tree.pp svneol=native#text/plain packages/fcl-base/src/base64.pp svneol=native#text/plain @@ -2569,6 +2570,8 @@ packages/fcl-pdf/utils/ttfdump.lpr svneol=native#text/plain packages/fcl-process/Makefile svneol=native#text/plain packages/fcl-process/Makefile.fpc svneol=native#text/plain packages/fcl-process/Makefile.fpc.fpcmake svneol=native#text/plain +packages/fcl-process/examples/checkipcserver.lpi svneol=native#text/plain +packages/fcl-process/examples/checkipcserver.lpr svneol=native#text/plain packages/fcl-process/examples/demoproject.ico -text packages/fcl-process/examples/demoproject.lpi svneol=native#text/plain packages/fcl-process/examples/demoproject.pp svneol=native#text/plain @@ -2580,6 +2583,8 @@ packages/fcl-process/examples/ipcclient.lpi svneol=native#text/plain packages/fcl-process/examples/ipcclient.pp svneol=native#text/plain packages/fcl-process/examples/ipcserver.lpi svneol=native#text/plain packages/fcl-process/examples/ipcserver.pp svneol=native#text/plain +packages/fcl-process/examples/simpleipcserver.lpi svneol=native#text/plain +packages/fcl-process/examples/simpleipcserver.lpr svneol=native#text/plain packages/fcl-process/fpmake.pp svneol=native#text/plain packages/fcl-process/src/amicommon/pipes.inc svneol=native#text/plain packages/fcl-process/src/amicommon/process.inc svneol=native#text/plain diff --git a/packages/fcl-base/fpmake.pp b/packages/fcl-base/fpmake.pp index 6d91d452f9..f2c2a48fc6 100644 --- a/packages/fcl-base/fpmake.pp +++ b/packages/fcl-base/fpmake.pp @@ -124,6 +124,8 @@ begin end; T:=P.Targets.addUnit('advancedipc.pp'); T.ResourceStrings:=true; + T:=P.Targets.addUnit('advancedsingleinstance.pp'); + T.ResourceStrings:=true; // Additional sources P.Sources.AddSrcFiles('src/win/fclel.*', P.Directory); // Install windows resources diff --git a/packages/fcl-base/src/advancedipc.pp b/packages/fcl-base/src/advancedipc.pp index ca900c1d26..127108e478 100644 --- a/packages/fcl-base/src/advancedipc.pp +++ b/packages/fcl-base/src/advancedipc.pp @@ -168,43 +168,6 @@ 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.'; @@ -809,284 +772,8 @@ 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); diff --git a/packages/fcl-base/src/advancedsingleinstance.pas b/packages/fcl-base/src/advancedsingleinstance.pas new file mode 100644 index 0000000000..222a9a3efd --- /dev/null +++ b/packages/fcl-base/src/advancedsingleinstance.pas @@ -0,0 +1,350 @@ +{ + This file is part of the Free Component Library (FCL) + Copyright (c) 2015 by Ondrej Pokorny + + Unit implementing Single Instance functionality. + + The order of message processing is not deterministic (if there are more + pending messages, the server won't process them in the order they have + been sent to the server. + SendRequest and PostRequest+PeekResponse sequences from 1 client are + blocking and processed in correct order. + + 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. + + **********************************************************************} + +unit AdvancedSingleInstance; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, AdvancedIPC, singleinstance; + +type + + 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; + procedure SetGlobal(const aGlobal: Boolean); + procedure SetID(const aID: string); + protected + procedure DoServerReceivedCustomRequest(const aMsgID: Integer; const aMsgType: Integer; const aStream: TStream); + function GetIsClient: Boolean; override; + function GetIsServer: Boolean; override; + function GetStartResult: TSingleInstanceStart; override; + 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; + +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; + +{ 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 + DefaultSingleInstanceClass:=TAdvancedSingleInstance; + +end. + diff --git a/packages/fcl-process/examples/checkipcserver.lpi b/packages/fcl-process/examples/checkipcserver.lpi new file mode 100644 index 0000000000..0bd7335dfd --- /dev/null +++ b/packages/fcl-process/examples/checkipcserver.lpi @@ -0,0 +1,60 @@ + + + + + + + + + + + + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="checkipcserver.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="checkipcserver"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="../units/$(TargetCPU)-$(TargetOS)"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/packages/fcl-process/examples/checkipcserver.lpr b/packages/fcl-process/examples/checkipcserver.lpr new file mode 100644 index 0000000000..b285a987e0 --- /dev/null +++ b/packages/fcl-process/examples/checkipcserver.lpr @@ -0,0 +1,55 @@ +program checkipcserver; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX}{$IFDEF UseCThreads} + cthreads, + {$ENDIF}{$ENDIF} + Classes, SysUtils, CustApp, simpleipc + { you can add units after this }; + +type + + { TSimpleIPCClientApp } + + TSimpleIPCClientApp = class(TCustomApplication) + protected + procedure DoRun; override; + public + constructor Create(TheOwner: TComponent); override; + end; + +{ TSimpleIPCClientApp } + +procedure TSimpleIPCClientApp.DoRun; +var + IPCClient: TSimpleIPCClient; +begin + IPCClient := TSimpleIPCClient.Create(nil); + IPCClient.ServerID:= 'ipc_test_crash'; + + if IPCClient.ServerRunning then + WriteLn('Server is runnning') + else + WriteLn('Server is NOT runnning'); + + IPCClient.Destroy; + Terminate; +end; + +constructor TSimpleIPCClientApp.Create(TheOwner: TComponent); +begin + inherited Create(TheOwner); + StopOnException:=True; +end; + +var + Application: TSimpleIPCClientApp; +begin + Application:=TSimpleIPCClientApp.Create(nil); + Application.Title:='IPC Client'; + Application.Run; + Application.Free; +end. + diff --git a/packages/fcl-process/examples/ipcclient.pp b/packages/fcl-process/examples/ipcclient.pp index 4e00a37c58..595878e813 100644 --- a/packages/fcl-process/examples/ipcclient.pp +++ b/packages/fcl-process/examples/ipcclient.pp @@ -2,16 +2,32 @@ {$h+} program ipcclient; -uses simpleipc; +uses sysutils,simpleipc; + +Var + I,Count : Integer; + DoStop : Boolean; begin + Count:=1; With TSimpleIPCClient.Create(Nil) do try ServerID:='ipcserver'; If (ParamCount>0) then - ServerInstance:=Paramstr(1); + begin + DoStop:=(ParamStr(1)='-s') or (paramstr(1)='--stop'); + if DoStop then + ServerInstance:=Paramstr(2) + else + ServerInstance:=Paramstr(1); + if (Not DoStop) and (ParamCount>1) then + Count:=StrToIntDef(ParamStr(2),1); + end; Active:=True; - SendStringMessage('Testmessage from client'); + if DoStop then + SendStringMessage('stop') + else for I:=1 to Count do + SendStringMessage(Format('Testmessage %d from client',[i])); Active:=False; finally Free; diff --git a/packages/fcl-process/examples/ipcserver.lpi b/packages/fcl-process/examples/ipcserver.lpi index 1f218ec1a8..159da48a86 100644 --- a/packages/fcl-process/examples/ipcserver.lpi +++ b/packages/fcl-process/examples/ipcserver.lpi @@ -6,7 +6,6 @@ <Flags> <MainUnitHasCreateFormStatements Value="False"/> <MainUnitHasTitleStatement Value="False"/> - <UseDefaultCompilerOptions Value="True"/> </Flags> <SessionStorage Value="InProjectDir"/> <MainUnit Value="0"/> @@ -29,6 +28,7 @@ <RunParams> <local> <FormatVersion Value="1"/> + <CommandLineParams Value="-t"/> </local> </RunParams> <Units Count="1"> @@ -44,6 +44,8 @@ <Filename Value="ipcserver"/> </Target> <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <OtherUnitFiles Value="../units/$(TargetCPU)-$(TargetOS)"/> <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> </SearchPaths> </CompilerOptions> diff --git a/packages/fcl-process/examples/ipcserver.pp b/packages/fcl-process/examples/ipcserver.pp index eb4fa753b1..250e3ec83d 100644 --- a/packages/fcl-process/examples/ipcserver.pp +++ b/packages/fcl-process/examples/ipcserver.pp @@ -5,31 +5,79 @@ program ipcserver; {$APPTYPE CONSOLE} uses + {$ifdef unix}cthreads,{$endif} SysUtils, + Classes, simpleipc; +Type + TApp = Class(TObject) + Srv : TSimpleIPCServer; + DoStop : Boolean; + Procedure MessageQueued(Sender : TObject); + procedure Run; + Procedure PrintMessage; + end; + +Procedure TApp.PrintMessage; + Var - Srv : TSimpleIPCServer; S : String; + +begin + S:=Srv.StringMessage; + Writeln('Received message : ',S); + DoStop:=DoStop or (S='stop'); +end; + +Procedure TApp.MessageQueued(Sender : TObject); + +begin + Srv.ReadMessage; + PrintMessage; +end; + + +Procedure TApp.Run; + +Var + S : String; + Threaded : Boolean; begin Srv:=TSimpleIPCServer.Create(Nil); Try + S:= ParamStr(1); + Threaded:=(S='-t') or (S='--threaded'); Srv.ServerID:='ipcserver'; Srv.Global:=True; - Srv.StartServer; - Writeln('Server started. Listening for messages'); + if Threaded then + Srv.OnMessageQueued:=@MessageQueued; + Srv.StartServer(Threaded); + + Writeln('Server started. Listening for messages. Send "stop" message to stop server.'); Repeat - If Srv.PeekMessage(1,True) then + If Threaded then begin - S:=Srv.StringMessage; - Writeln('Received message : ',S); + Sleep(10); + CheckSynchronize; end + else if Srv.PeekMessage(10,True) then + PrintMessage else Sleep(10); - Until CompareText(S,'stop')=0; + Until DoStop; Finally Srv.Free; end; +end; + +begin + With TApp.Create do + try + Run + finally + Free; + end; end. diff --git a/packages/fcl-process/examples/simpleipcserver.lpi b/packages/fcl-process/examples/simpleipcserver.lpi new file mode 100644 index 0000000000..47c73aec2e --- /dev/null +++ b/packages/fcl-process/examples/simpleipcserver.lpi @@ -0,0 +1,59 @@ +<?xml version="1.0" encoding="UTF-8"?> +<CONFIG> + <ProjectOptions> + <Version Value="9"/> + <General> + <Flags> + <MainUnitHasCreateFormStatements Value="False"/> + </Flags> + <SessionStorage Value="InProjectDir"/> + <MainUnit Value="0"/> + <Title Value="IPC Server"/> + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <VersionInfo> + <StringTable ProductVersion=""/> + </VersionInfo> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="simpleipcserver.lpr"/> + <IsPartOfProject Value="True"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="simpleipcserver"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/packages/fcl-process/examples/simpleipcserver.lpr b/packages/fcl-process/examples/simpleipcserver.lpr new file mode 100644 index 0000000000..cd81f838cf --- /dev/null +++ b/packages/fcl-process/examples/simpleipcserver.lpr @@ -0,0 +1,81 @@ +program simpleipcserver; + +{$mode objfpc}{$H+} + +uses + {$IFDEF UNIX} + BaseUnix, + {$ENDIF} + {$IFDEF windows} + Windows, + {$ENDIF} + Classes, SysUtils, CustApp, simpleipc, Crt; + +type + + { TSimpleIPCServerApp } + + TSimpleIPCServerApp = class(TCustomApplication) + protected + procedure DoRun; override; + public + constructor Create(TheOwner: TComponent); override; + end; + +{ TSimpleIPCServerApp } + +procedure TSimpleIPCServerApp.DoRun; +var + IPCServer: TSimpleIPCServer; + Key: Char; + NullObj: TObject; +begin + IPCServer := TSimpleIPCServer.Create(nil); + IPCServer.ServerID:='ipc_test_crash'; + IPCServer.Global:=True; + IPCServer.StartServer; + NullObj := nil; + + WriteLn('Server started'); + WriteLn(' Press e to finish with an exception'); + WriteLn(' Press t to terminate through OS api - ', {$IFDEF UNIX}'Kill'{$ELSE}'TerminateProcess'{$ENDIF}); + WriteLn(' Press any other key to finish normally'); + Key := ReadKey; + + case Key of + 'e': + begin + NullObj.AfterConstruction; + end; + 't': + begin + {$ifdef unix} + FpKill(FpGetpid, 9); + {$endif} + {$ifdef windows} + TerminateProcess(GetCurrentProcess, 0); + {$endif} + end; + end; + + IPCServer.Active:=False; + WriteLn('Server stopped'); + IPCServer.Destroy; + Terminate; +end; + +constructor TSimpleIPCServerApp.Create(TheOwner: TComponent); +begin + inherited Create(TheOwner); + StopOnException:=True; +end; + +var + Application: TSimpleIPCServerApp; +begin + Application:=TSimpleIPCServerApp.Create(nil); + Application.Title:='IPC Server'; + Application.Run; + Application.Free; +end. + diff --git a/packages/fcl-process/src/os2/simpleipc.inc b/packages/fcl-process/src/os2/simpleipc.inc index 92ca900012..adf3b7af25 100644 --- a/packages/fcl-process/src/os2/simpleipc.inc +++ b/packages/fcl-process/src/os2/simpleipc.inc @@ -164,19 +164,13 @@ end; procedure TPipeServerComm.ReadMessage; + var Hdr: TMsgHeader; + begin - FStream.ReadBuffer (Hdr, SizeOf (Hdr)); - Owner.FMsgType := Hdr.MsgType; - if Hdr.MsgLen > 0 then - begin - Owner.FMsgData.Size:=0; - Owner.FMsgData.Seek (0, soFromBeginning); - Owner.FMsgData.CopyFrom (FStream, Hdr.MsgLen); - end - else - Owner.FMsgData.Size := 0; + FStream.ReadBuffer(Hdr,SizeOf(Hdr)); + PushMessage(Hdr,FStream); end; function TPipeServerComm.GetInstanceID: string; diff --git a/packages/fcl-process/src/simpleipc.pp b/packages/fcl-process/src/simpleipc.pp index 5892762ad8..fd4bd8d4b8 100644 --- a/packages/fcl-process/src/simpleipc.pp +++ b/packages/fcl-process/src/simpleipc.pp @@ -20,11 +20,12 @@ unit simpleipc; interface uses - Classes, SysUtils; + Contnrs, Classes, SysUtils; Const MsgVersion = 1; - + DefaultThreadTimeOut = 50; + //Message types mtUnknown = 0; mtString = 1; @@ -33,7 +34,6 @@ type TIPCMessageOverflowAction = (ipcmoaNone, ipcmoaDiscardOld, ipcmoaDiscardNew, ipcmoaError); var - // Currently implemented only for Windows platform! DefaultIPCMessageOverflowAction: TIPCMessageOverflowAction = ipcmoaNone; DefaultIPCMessageQueueLimit: Integer = 0; @@ -49,6 +49,36 @@ Type TSimpleIPCServer = class; TSimpleIPCClient = class; + TIPCServerMsg = class + strict private + FStream: TStream; + FMsgType: TMessageType; + public + constructor Create; + destructor Destroy; override; + property Stream: TStream read FStream; + property MsgType: TMessageType read FMsgType write FMsgType; + end; + + TIPCServerMsgQueue = class + strict private + FList: TFPObjectList; + FMaxCount: Integer; + FMaxAction: TIPCMessageOverflowAction; + function GetCount: Integer; + procedure DeleteAndFree(Index: Integer); + function PrepareToPush: Boolean; + public + constructor Create; + destructor Destroy; override; + procedure Clear; + procedure Push(AItem: TIPCServerMsg); + function Pop: TIPCServerMsg; + property Count: Integer read GetCount; + property MaxCount: Integer read FMaxCount write FMaxCount; + property MaxAction: TIPCMessageOverflowAction read FMaxAction write FMaxAction; + end; + { TIPCServerComm } TIPCServerComm = Class(TObject) @@ -57,14 +87,16 @@ Type Protected Function GetInstanceID : String; virtual; abstract; Procedure DoError(const Msg : String; const Args : Array of const); - Procedure SetMsgType(AMsgType: TMessageType); - Function MsgData : TStream; + Procedure PushMessage(Const Hdr : TMsgHeader; AStream : TStream); + Procedure PushMessage(Msg : TIPCServerMsg); Public Constructor Create(AOwner : TSimpleIPCServer); virtual; Property Owner : TSimpleIPCServer read FOwner; Procedure StartServer; virtual; Abstract; Procedure StopServer;virtual; Abstract; + // May push messages on the queue Function PeekMessage(TimeOut : Integer) : Boolean;virtual; Abstract; + // Must put message on the queue. Procedure ReadMessage ;virtual; Abstract; Property InstanceID : String read GetInstanceID; end; @@ -93,24 +125,46 @@ Type { TSimpleIPCServer } + TMessageQueueEvent = Procedure(Sender : TObject; Msg : TIPCServerMsg) of object; + TSimpleIPCServer = Class(TSimpleIPC) - private + protected + Private + FOnMessageError: TMessageQueueEvent; + FOnMessageQueued: TNotifyEvent; + FQueue : TIPCServerMsgQueue; FGlobal: Boolean; FOnMessage: TNotifyEvent; FMsgType: TMessageType; FMsgData : TStream; + FThreadTimeOut: Integer; + FThread : TThread; + FLock : TRTLCriticalSection; + FErrMsg : TIPCServerMsg; + procedure DoMessageQueued; + procedure DoMessageError; function GetInstanceID: String; + function GetMaxAction: TIPCMessageOverflowAction; + function GetMaxQueue: Integer; function GetStringMessage: String; procedure SetGlobal(const AValue: Boolean); + procedure SetMaxAction(AValue: TIPCMessageOverflowAction); + procedure SetMaxQueue(AValue: Integer); Protected FIPCComm: TIPCServerComm; + procedure StartThread; virtual; + procedure StopThread; virtual; Function CommClass : TIPCServerCommClass; virtual; + Procedure PushMessage(Msg : TIPCServerMsg); virtual; + function PopMessage: Boolean; virtual; Procedure Activate; override; Procedure Deactivate; override; + Property Queue : TIPCServerMsgQueue Read FQueue; + Property Thread : TThread Read FThread; Public Constructor Create(AOwner : TComponent); override; Destructor Destroy; override; - Procedure StartServer; + Procedure StartServer(Threaded : Boolean = False); Procedure StopServer; Function PeekMessage(TimeOut : Integer; DoReadMessage : Boolean): Boolean; Procedure ReadMessage; @@ -120,8 +174,18 @@ Type Property MsgData : TStream Read FMsgData; Property InstanceID : String Read GetInstanceID; Published + Property ThreadTimeOut : Integer Read FThreadTimeOut Write FThreadTimeOut; Property Global : Boolean Read FGlobal Write SetGlobal; + // Called during ReadMessage Property OnMessage : TNotifyEvent Read FOnMessage Write FOnMessage; + // Called when a message is pushed on the queue. + Property OnMessageQueued : TNotifyEvent Read FOnMessageQueued Write FOnMessageQueued; + // Called when the queue overflows and MaxAction = ipcmoaError. + Property OnMessageError : TMessageQueueEvent Read FOnMessageError Write FOnMessageError; + // Maximum number of messages to keep in the queue + property MaxQueue: Integer read GetMaxQueue write SetMaxQueue; + // What to do when the queue overflows + property MaxAction: TIPCMessageOverflowAction read GetMaxAction write SetMaxAction; end; @@ -194,6 +258,103 @@ implementation {$i simpleipc.inc} +Resourcestring + SErrMessageQueueOverflow = 'Message queue overflow (limit %s)'; + +{ --------------------------------------------------------------------- + TIPCServerMsg + ---------------------------------------------------------------------} + + +constructor TIPCServerMsg.Create; +begin + FMsgType := 0; + FStream := TMemoryStream.Create; +end; + +destructor TIPCServerMsg.Destroy; +begin + FStream.Free; +end; + +{ --------------------------------------------------------------------- + TIPCServerMsgQueue + ---------------------------------------------------------------------} + +constructor TIPCServerMsgQueue.Create; +begin + FMaxCount := DefaultIPCMessageQueueLimit; + FMaxAction := DefaultIPCMessageOverflowAction; + FList := TFPObjectList.Create(False); // FreeObjects = False! +end; + +destructor TIPCServerMsgQueue.Destroy; +begin + Clear; + FList.Free; +end; + +procedure TIPCServerMsgQueue.Clear; +begin + while FList.Count > 0 do + DeleteAndFree(FList.Count - 1); +end; + +procedure TIPCServerMsgQueue.DeleteAndFree(Index: Integer); +begin + FList[Index].Free; // Free objects manually! + FList.Delete(Index); +end; + +function TIPCServerMsgQueue.GetCount: Integer; +begin + Result := FList.Count; +end; + +function TIPCServerMsgQueue.PrepareToPush: Boolean; +begin + Result := True; + case FMaxAction of + ipcmoaDiscardOld: + begin + while (FList.Count >= FMaxCount) do + DeleteAndFree(FList.Count - 1); + end; + ipcmoaDiscardNew: + begin + Result := (FList.Count < FMaxCount); + end; + ipcmoaError: + begin + if (FList.Count >= FMaxCount) then + // Caller is expected to catch this exception, so not using Owner.DoError() + raise EIPCError.CreateFmt(SErrMessageQueueOverflow, [IntToStr(FMaxCount)]); + end; + end; +end; + +procedure TIPCServerMsgQueue.Push(AItem: TIPCServerMsg); +begin + if PrepareToPush then + FList.Insert(0, AItem); +end; + +function TIPCServerMsgQueue.Pop: TIPCServerMsg; +var + Index: Integer; +begin + Index := FList.Count - 1; + if Index >= 0 then + begin + // Caller is responsible for freeing the object. + Result := TIPCServerMsg(FList[Index]); + FList.Delete(Index); + end + else + Result := nil; +end; + + { --------------------------------------------------------------------- TIPCServerComm ---------------------------------------------------------------------} @@ -203,22 +364,33 @@ begin FOwner:=AOWner; end; -Procedure TIPCServerComm.DoError(const Msg : String; const Args : Array of const); +procedure TIPCServerComm.DoError(const Msg: String; const Args: array of const); begin FOwner.DoError(Msg,Args); -end; - -Function TIPCServerComm.MsgData : TStream; - -begin - Result:=FOwner.FMsgData; end; -Procedure TIPCServerComm.SetMsgType(AMsgType: TMessageType); +procedure TIPCServerComm.PushMessage(const Hdr: TMsgHeader; AStream: TStream); + +Var + M : TIPCServerMsg; begin - Fowner.FMsgType:=AMsgType; + M:=TIPCServerMsg.Create; + try + M.MsgType:=Hdr.MsgType; + if Hdr.MsgLen>0 then + M.Stream.CopyFrom(AStream,Hdr.MsgLen); + except + M.Free; + Raise; + end; + PushMessage(M); +end; + +procedure TIPCServerComm.PushMessage(Msg: TIPCServerMsg); +begin + FOwner.PushMessage(Msg); end; { --------------------------------------------------------------------- @@ -314,11 +486,14 @@ begin FActive:=False; FBusy:=False; FMsgData:=TStringStream.Create(''); + FQueue:=TIPCServerMsgQueue.Create; + FThreadTimeOut:=DefaultThreadTimeOut; end; destructor TSimpleIPCServer.Destroy; begin Active:=False; + FreeAndNil(FQueue); FreeAndNil(FMsgData); inherited Destroy; end; @@ -332,11 +507,31 @@ begin end; end; +procedure TSimpleIPCServer.SetMaxAction(AValue: TIPCMessageOverflowAction); +begin + FQueue.MaxAction:=AValue; +end; + +procedure TSimpleIPCServer.SetMaxQueue(AValue: Integer); +begin + FQueue.MaxCount:=AValue; +end; + function TSimpleIPCServer.GetInstanceID: String; begin Result:=FIPCComm.InstanceID; end; +function TSimpleIPCServer.GetMaxAction: TIPCMessageOverflowAction; +begin + Result:=FQueue.MaxAction; +end; + +function TSimpleIPCServer.GetMaxQueue: Integer; +begin + Result:=FQueue.MaxCount; +end; + function TSimpleIPCServer.GetStringMessage: String; begin @@ -344,7 +539,7 @@ begin end; -procedure TSimpleIPCServer.StartServer; +procedure TSimpleIPCServer.StartServer(Threaded : Boolean = False); begin if Not Assigned(FIPCComm) then begin @@ -354,47 +549,135 @@ begin FIPCComm.StartServer; end; FActive:=True; + If Threaded then + StartThread; +end; + +Type + + { TServerThread } + + TServerThread = Class(TThread) + private + FServer: TSimpleIPCServer; + FThreadTimeout: Integer; + Public + Constructor Create(AServer : TSimpleIPCServer; ATimeout : integer); + procedure Execute; override; + Property Server : TSimpleIPCServer Read FServer; + Property ThreadTimeout : Integer Read FThreadTimeout; + end; + +{ TServerThread } + +constructor TServerThread.Create(AServer: TSimpleIPCServer; ATimeout: integer); +begin + FServer:=AServer; + FThreadTimeout:=ATimeOut; + Inherited Create(False); +end; + +procedure TServerThread.Execute; +begin + While Not Terminated do + FServer.PeekMessage(ThreadTimeout,False); +end; + +procedure TSimpleIPCServer.StartThread; + +begin + InitCriticalSection(FLock); + FThread:=TServerThread.Create(Self,ThreadTimeOut); +end; + +procedure TSimpleIPCServer.StopThread; + +begin + if Assigned(FThread) then + begin + FThread.Terminate; + FThread.WaitFor; + FreeAndNil(FThread); + DoneCriticalSection(FLock); + end; end; procedure TSimpleIPCServer.StopServer; begin + StopThread; If Assigned(FIPCComm) then begin FIPCComm.StopServer; FreeAndNil(FIPCComm); end; + FQueue.Clear; FActive:=False; end; // TimeOut values: -// > 0 -- number of milliseconds to wait +// > 0 -- Number of milliseconds to wait // = 0 -- return immediately // = -1 -- wait infinitely // < -1 -- wait infinitely (force to -1) function TSimpleIPCServer.PeekMessage(TimeOut: Integer; DoReadMessage: Boolean): Boolean; begin CheckActive; - if TimeOut < -1 then - TimeOut := -1; - FBusy:=True; - Try - Result:=FIPCComm.PeekMessage(Timeout); - Finally - FBusy:=False; - end; + Result:=Queue.Count>0; + If Not Result then + begin + if TimeOut < -1 then + TimeOut := -1; + FBusy:=True; + Try + Result:=FIPCComm.PeekMessage(Timeout); + Finally + FBusy:=False; + end; + end; If Result then If DoReadMessage then Readmessage; end; +function TSimpleIPCServer.PopMessage: Boolean; + +var + MsgItem: TIPCServerMsg; + DoLock : Boolean; + +begin + DoLock:=Assigned(FThread); + if DoLock then + EnterCriticalsection(Flock); + try + MsgItem:=FQueue.Pop; + finally + LeaveCriticalsection(FLock); + end; + Result:=Assigned(MsgItem); + if Result then + try + FMsgType := MsgItem.MsgType; + MsgItem.Stream.Position := 0; + FMsgData.Size := 0; + FMsgData.CopyFrom(MsgItem.Stream, MsgItem.Stream.Size); + finally + MsgItem.Free; + end; +end; + procedure TSimpleIPCServer.ReadMessage; + begin CheckActive; FBusy:=True; Try - FIPCComm.ReadMessage; - If Assigned(FOnMessage) then - FOnMessage(Self); + if (FQueue.Count=0) then + // Readmessage pushes a message to the queue + FIPCComm.ReadMessage; + if PopMessage then + If Assigned(FOnMessage) then + FOnMessage(Self); Finally FBusy:=False; end; @@ -416,6 +699,55 @@ begin end; +procedure TSimpleIPCServer.DoMessageQueued; + +begin + if Assigned(FOnMessageQueued) then + FOnMessageQueued(Self); +end; + +procedure TSimpleIPCServer.DoMessageError; +begin + try + if Assigned(FOnMessageQueued) then + FOnMessageError(Self,FErrMsg); + finally + FreeAndNil(FErrMsg) + end; +end; + +procedure TSimpleIPCServer.PushMessage(Msg: TIPCServerMsg); + +Var + DoLock : Boolean; + +begin + try + DoLock:=Assigned(FThread); + If DoLock then + EnterCriticalsection(FLock); + try + Queue.Push(Msg); + finally + If DoLock then + LeaveCriticalsection(FLock); + end; + if DoLock then + TThread.Synchronize(FThread,@DoMessageQueued) + else + DoMessageQueued; + except + On E : Exception do + FErrMsg:=Msg; + end; + if Assigned(FErrMsg) then + if DoLock then + TThread.Synchronize(FThread,@DoMessageError) + else + DoMessageQueued; + +end; + { --------------------------------------------------------------------- diff --git a/packages/fcl-process/src/unix/simpleipc.inc b/packages/fcl-process/src/unix/simpleipc.inc index f64a2bccca..85b471be65 100644 --- a/packages/fcl-process/src/unix/simpleipc.inc +++ b/packages/fcl-process/src/unix/simpleipc.inc @@ -26,10 +26,6 @@ uses sysutils, classes, simpleipc, baseunix; uses baseunix; {$endif} -{$DEFINE OSNEEDIPCINITDONE} - - - ResourceString SErrFailedToCreatePipe = 'Failed to create named pipe: %s'; @@ -58,57 +54,6 @@ Type implementation {$endif} -Var - SocketFiles : TStringList; - -Procedure IPCInit; - -begin -end; - -Procedure IPCDone; - -Var - I : integer; - -begin - if Assigned(SocketFiles) then - try - For I:=0 to SocketFiles.Count-1 do - DeleteFile(SocketFiles[i]); - finally - FreeAndNil(SocketFiles); - end; -end; - - -Procedure RegisterSocketFile(Const AFileName : String); - -begin - If Not Assigned(SocketFiles) then - begin - SocketFiles:=TStringList.Create; - SocketFiles.Sorted:=True; - end; - SocketFiles.Add(AFileName); -end; - -Procedure UnRegisterSocketFile(Const AFileName : String); - -Var - I : Integer; -begin - If Assigned(SocketFiles) then - begin - I:=SocketFiles.IndexOf(AFileName); - If (I<>-1) then - SocketFiles.Delete(I); - If (SocketFiles.Count=0) then - FreeAndNil(SocketFiles); - end; -end; - - constructor TPipeClientComm.Create(AOWner: TSimpleIPCClient); begin inherited Create(AOWner); @@ -140,7 +85,6 @@ procedure TPipeClientComm.SendMessage(MsgType : TMessagetype; AStream: TStream); Var Hdr : TMsgHeader; - P,L,Count : Integer; begin Hdr.Version:=MsgVersion; @@ -180,10 +124,15 @@ end; ---------------------------------------------------------------------} Type + + { TPipeServerComm } + TPipeServerComm = Class(TIPCServerComm) Private FFileName: String; FStream: TFileStream; + Protected + Procedure DoReadMessage; virtual; Public Constructor Create(AOWner : TSimpleIPCServer); override; Procedure StartServer; override; @@ -195,6 +144,16 @@ Type Property Stream : TFileStream Read FStream; end; +procedure TPipeServerComm.DoReadMessage; + +Var + Hdr : TMsgHeader; + +begin + FStream.ReadBuffer(Hdr,SizeOf(Hdr)); + PushMessage(Hdr,FStream); +end; + constructor TPipeServerComm.Create(AOWner: TSimpleIPCServer); begin inherited Create(AOWner); @@ -218,12 +177,10 @@ begin If (fpmkFifo(FFileName,438)<>0) then DoError(SErrFailedToCreatePipe,[FFileName]); FStream:=TFileStream.Create(FFileName,fmOpenReadWrite+fmShareDenyNone,Rights[Owner.Global]); - RegisterSocketFile(FFileName); end; procedure TPipeServerComm.StopServer; begin - UnregisterSocketFile(FFileName); FreeAndNil(FStream); if Not DeleteFile(FFileName) then DoError(SErrFailedtoRemovePipe,[FFileName]); @@ -237,40 +194,33 @@ Var begin fpfd_zero(FDS); fpfd_set(FStream.Handle,FDS); - Result:=fpSelect(FStream.Handle+1,@FDS,Nil,Nil,TimeOut)>0; + Result:=False; + While fpSelect(FStream.Handle+1,@FDS,Nil,Nil,TimeOut)>0 do + begin + DoReadMessage; + Result:=True; + end; end; procedure TPipeServerComm.ReadMessage; -Var - L,P,Count : Integer; - Hdr : TMsgHeader; - M : TStream; begin - FStream.ReadBuffer(Hdr,SizeOf(Hdr)); - SetMsgType(Hdr.MsgType); - Count:=Hdr.MsgLen; - M:=MsgData; - if count > 0 then - begin - M.Size:=0; - M.Seek(0,soFrombeginning); - M.CopyFrom(FStream,Count); - end - else - M.Size := 0; + DoReadMessage; end; + function TPipeServerComm.GetInstanceID: String; begin Result:=IntToStr(fpGetPID); end; + { --------------------------------------------------------------------- Set TSimpleIPCClient / TSimpleIPCServer defaults. ---------------------------------------------------------------------} + {$ifndef ipcunit} -Function TSimpleIPCServer.CommClass : TIPCServerCommClass; +function TSimpleIPCServer.CommClass: TIPCServerCommClass; begin if (DefaultIPCServerClass<>Nil) then @@ -288,10 +238,6 @@ begin end; {$else ipcunit} -initialization - IPCInit; - -Finalization - IPCDone; + end. {$endif} diff --git a/packages/fcl-process/src/winall/simpleipc.inc b/packages/fcl-process/src/winall/simpleipc.inc index 99eeac8634..1c70dcce09 100644 --- a/packages/fcl-process/src/winall/simpleipc.inc +++ b/packages/fcl-process/src/winall/simpleipc.inc @@ -14,7 +14,7 @@ **********************************************************************} -uses Windows,messages,contnrs; +uses Windows,messages; const MsgWndClassName: WideString = 'FPCMsgWindowCls'; @@ -22,7 +22,6 @@ const resourcestring SErrFailedToRegisterWindowClass = 'Failed to register message window class'; SErrFailedToCreateWindow = 'Failed to create message window %s'; - SErrMessageQueueOverflow = 'Message queue overflow (limit %s)'; var MsgWindowClass: TWndClassW = ( @@ -38,43 +37,12 @@ var lpszClassName: nil); type - TWinMsgServerMsg = class - strict private - FStream: TStream; - FMsgType: TMessageType; - public - constructor Create; - destructor Destroy; override; - property Stream: TStream read FStream; - property MsgType: TMessageType read FMsgType write FMsgType; - end; - - TWinMsgServerMsgQueue = class - strict private - FList: TFPObjectList; - FMaxCount: Integer; - FMaxAction: TIPCMessageOverflowAction; - function GetCount: Integer; - procedure DeleteAndFree(Index: Integer); - function PrepareToPush: Boolean; - public - constructor Create; - destructor Destroy; override; - procedure Clear; - procedure Push(AItem: TWinMsgServerMsg); - function Pop: TWinMsgServerMsg; - property Count: Integer read GetCount; - property MaxCount: Integer read FMaxCount write FMaxCount; - property MaxAction: TIPCMessageOverflowAction read FMaxAction write FMaxAction; - end; - TWinMsgServerComm = Class(TIPCServerComm) strict private FHWND : HWND; FWindowName : String; FWndProcException: Boolean; FWndProcExceptionMsg: String; - FMsgQueue: TWinMsgServerMsgQueue; function AllocateHWnd(const aWindowName: WideString) : HWND; procedure ProcessMessages; procedure ProcessMessagesWait(TimeOut: Integer); @@ -97,95 +65,6 @@ type Property WindowName : String Read FWindowName; end; - { --------------------------------------------------------------------- - TWinMsgServerMsg / TWinMsgServerMsgQueue - ---------------------------------------------------------------------} - -constructor TWinMsgServerMsg.Create; -begin - FMsgType := 0; - FStream := TMemoryStream.Create; -end; - -destructor TWinMsgServerMsg.Destroy; -begin - FStream.Free; -end; - - -constructor TWinMsgServerMsgQueue.Create; -begin - FMaxCount := DefaultIPCMessageQueueLimit; - FMaxAction := DefaultIPCMessageOverflowAction; - FList := TFPObjectList.Create(False); // FreeObjects = False! -end; - -destructor TWinMsgServerMsgQueue.Destroy; -begin - Clear; - FList.Free; -end; - -procedure TWinMsgServerMsgQueue.Clear; -begin - while FList.Count > 0 do - DeleteAndFree(FList.Count - 1); -end; - -procedure TWinMsgServerMsgQueue.DeleteAndFree(Index: Integer); -begin - FList[Index].Free; // Free objects manually! - FList.Delete(Index); -end; - -function TWinMsgServerMsgQueue.GetCount: Integer; -begin - Result := FList.Count; -end; - -function TWinMsgServerMsgQueue.PrepareToPush: Boolean; -begin - Result := True; - case FMaxAction of - ipcmoaDiscardOld: - begin - while (FList.Count >= FMaxCount) do - DeleteAndFree(FList.Count - 1); - end; - ipcmoaDiscardNew: - begin - Result := (FList.Count < FMaxCount); - end; - ipcmoaError: - begin - if (FList.Count >= FMaxCount) then - // Caller is expected to catch this exception, so not using Owner.DoError() - raise EIPCError.CreateFmt(SErrMessageQueueOverflow, [IntToStr(FMaxCount)]); - end; - end; -end; - -procedure TWinMsgServerMsgQueue.Push(AItem: TWinMsgServerMsg); -begin - if PrepareToPush then - FList.Insert(0, AItem); -end; - -function TWinMsgServerMsgQueue.Pop: TWinMsgServerMsg; -var - Index: Integer; -begin - Index := FList.Count - 1; - if Index >= 0 then - begin - // Caller is responsible for freeing the object. - Result := TWinMsgServerMsg(FList[Index]); - FList.Delete(Index); - end - else - Result := nil; -end; - { --------------------------------------------------------------------- MsgWndProc ---------------------------------------------------------------------} @@ -257,13 +136,11 @@ begin FWindowName := FWindowName+'_'+InstanceID; FWndProcException := False; FWndProcExceptionMsg := ''; - FMsgQueue := TWinMsgServerMsgQueue.Create; end; destructor TWinMsgServerComm.Destroy; begin StopServer; - FMsgQueue.Free; inherited; end; @@ -275,7 +152,6 @@ end; procedure TWinMsgServerComm.StopServer; begin - FMsgQueue.Clear; if FHWND <> 0 then begin DestroyWindow(FHWND); @@ -304,12 +180,12 @@ end; function TWinMsgServerComm.HaveQueuedMessages: Boolean; inline; begin - Result := (FMsgQueue.Count > 0); + Result := (Owner.Queue.Count > 0); end; function TWinMsgServerComm.CountQueuedMessages: Integer; inline; begin - Result := FMsgQueue.Count; + Result := Owner.Queue.Count; end; procedure TWinMsgServerComm.HandlePostedMessage(const Msg: TMsg); inline; @@ -397,10 +273,11 @@ end; procedure TWinMsgServerComm.ReadMsgData(var Msg: TMsg); var CDS: PCopyDataStruct; - MsgItem: TWinMsgServerMsg; + MsgItem: TIPCServerMsg; + begin CDS := PCopyDataStruct(Msg.lParam); - MsgItem := TWinMsgServerMsg.Create; + MsgItem := TIPCServerMsg.Create; try MsgItem.MsgType := CDS^.dwData; MsgItem.Stream.WriteBuffer(CDS^.lpData^,CDS^.cbData); @@ -409,7 +286,7 @@ begin // Caller is expected to catch this exception, so not using Owner.DoError() raise; end; - FMsgQueue.Push(MsgItem); + PushMessage(MsgItem); end; function TWinMsgServerComm.TryReadMsgData(var Msg: TMsg; out Error: String): Boolean; @@ -426,21 +303,8 @@ begin end; procedure TWinMsgServerComm.ReadMessage; -var - MsgItem: TWinMsgServerMsg; begin - MsgItem := FMsgQueue.Pop; - if Assigned(MsgItem) then - try - // Load message from the queue into the owner's message data. - MsgItem.Stream.Position := 0; - Owner.FMsgData.Size := 0; - Owner.FMsgType := MsgItem.MsgType; - Owner.FMsgData.CopyFrom(MsgItem.Stream, MsgItem.Stream.Size); - finally - // We are responsible for freeing the message from the queue. - MsgItem.Free; - end; + // Do nothing, PeekMessages has pushed messages to the queue. end; function TWinMsgServerComm.GetInstanceID: String; @@ -451,7 +315,7 @@ end; { --------------------------------------------------------------------- TWinMsgClientComm ---------------------------------------------------------------------} - + Type TWinMsgClientComm = Class(TIPCClientComm) Private @@ -544,7 +408,7 @@ Function TSimpleIPCServer.CommClass : TIPCServerCommClass; begin if (DefaultIPCServerClass<>Nil) then Result:=DefaultIPCServerClass - else + else Result:=TWinMsgServerComm; end; @@ -553,7 +417,7 @@ Function TSimpleIPCClient.CommClass : TIPCClientCommClass; begin if (DefaultIPCClientClass<>Nil) then Result:=DefaultIPCClientClass - else + else Result:=TWinMsgClientComm; end;