paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 05:59:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

--- Merging r33697 into '.':

Browse Source 
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 -
This commit is contained in:
marco 2016-05-26 14:48:46 +00:00
parent f194d71cef
commit 0455973fe4
15 changed files with 1092 additions and 591 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.gitattributes vendored
View File

@ -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

2
packages/fcl-base/fpmake.pp
View File

@ -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

313
packages/fcl-base/src/advancedipc.pp
View File

@ -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);

350
packages/fcl-base/src/advancedsingleinstance.pas Normal file
View File

@ -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.

60
packages/fcl-process/examples/checkipcserver.lpi Normal file
View File

@ -0,0 +1,60 @@
<?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 Client"/>
<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>

55
packages/fcl-process/examples/checkipcserver.lpr Normal file
View File

@ -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.

22
packages/fcl-process/examples/ipcclient.pp
View File

@ -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;

4
packages/fcl-process/examples/ipcserver.lpi
View File

@ -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>

62
packages/fcl-process/examples/ipcserver.pp
View File

@ -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.

59
packages/fcl-process/examples/simpleipcserver.lpi Normal file
View File

@ -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>

81
packages/fcl-process/examples/simpleipcserver.lpr Normal file
View File

@ -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.

14
packages/fcl-process/src/os2/simpleipc.inc
View File

@ -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;

390
packages/fcl-process/src/simpleipc.pp
View File

@ -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;
{ ---------------------------------------------------------------------

108
packages/fcl-process/src/unix/simpleipc.inc
View File

@ -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}

158
packages/fcl-process/src/winall/simpleipc.inc
View File

@ -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;