runtime/nongui/winipc.inc

{Used by IBIPC and implements System V IPC}

uses IBMessages;

const
  MonitorHookNames: array[0..5] of String = (
    'FB.SQL.MONITOR.Mutex1_0',
    'FB.SQL.MONITOR.SharedMem1_0',
    'FB.SQL.MONITOR.WriteEvent1_0',
    'FB.SQL.MONITOR.WriteFinishedEvent1_0',
    'FB.SQL.MONITOR.ReadEvent1_0',
    'FB.SQL.MONITOR.ReadFinishedEvent1_0'
  );
  cDefaultTimeout = 10000; {milli seconds }

type
  {Interprocess Communication Objects. All platform dependent IPC is abstracted
   into this set of objects }

  { TIpcCommon }

  TIpcCommon = class(TInterfacedObject)
  protected
    FSa : TSecurityAttributes;
  private
    Sd : TSecurityDescriptor;
  public
    constructor Create;
    function GetSa: PSecurityAttributes;
    property Sa : PSecurityAttributes read GetSa;
  end;

  { TSharedMemory }

  {
    The shared memory segment is used for interprocess communication and
    holds both a message buffer and a number of shared variables. Shared
    memory is allocated to each shared variable using the Allocate function.
    An underlying assumption is that each process using the shared memory
    calls "Allocate" in the same order and for the same memory sizes.

    Windows:

    The Windows implementation uses Windows shared memory. This is identified
    by a global name known to every process. There is no security with
    the windows implementation and the shared memory can be read by
    any active process.

  }

  ISharedMemory = interface
  ['{db77bdd4-233a-4c9c-9212-dd7945e2e57c}']
  function IsInitialiser: boolean;
  function Allocate(Size: integer): PByte;
  function GetLastAllocationSize: integer;
  property LastAllocationSize: integer read GetLastAllocationSize;
  end;


  TSharedMemory = class(TIpcCommon,ISharedMemory)
  private
    FBuffer: PByte;
    FLastAllocationSize: integer;
    FUnused: integer;
    FBufptr: PByte;
    FSharedBuffer: THandle;
    FInitialiser: boolean;
    procedure GetSharedMemory(MemSize: integer);
  public
    constructor Create(MemSize: integer);
    destructor Destroy; override;
    function Allocate(Size: integer): PByte;
    function GetLastAllocationSize: integer;
    function IsInitialiser: boolean;
    property LastAllocationSize: integer read GetLastAllocationSize;
  end;

  {TMutex}

  TMutex = class(TIpcCommon, IMutex)
  private
    FMutex: THandle;
  public
    constructor Create(MutexName: string; IsInitialiser: boolean);
    destructor Destroy; override;
    procedure Lock;
    procedure Unlock;
  end;

  { TSingleLockGate }

  {
    A single lock gate is either open or closed. When open, any thread can pass
    through it while, when closed, all threads are blocked as they try to pass
    through the gate. When the gate is opened, all blocked threads are resumed.

    There is an implementation assumption that only one writer thread at
    a time (i.e. the thread which locks or unlocks the gate) can have access to
    it at any one time. I.e. an external Mutex prevents race conditions.

    Windows:

    In the Windows implementation, a Windows Event is used to implement
    the "gate". No additional functionality is required as the behaviour
    of a Windows event meets the requirement.


    Always initialised to the Unlocked state
  }

  TSingleLockGate = class(TIpcCommon,ISingleLockGate)
  private
    FEvent: THandle;
  public
    constructor Create(EventName: string; IsInitialiser: boolean);
    destructor Destroy; override;
    procedure PassthroughGate;
    procedure Unlock;
    procedure Lock;
  end;

  { TMultilockGate }

  { This type of Gate is used where several reader threads must pass
    through the gate before it can be opened for a writer thread.

    The reader threads register their interest by each locking the gate.
    The writer thread then waits on the locked gate until all the reader
    threads have separately unlocked the gate.

    There is an underlying assumption of a single writer. A Mutex must
    be used to control access to the gate from the writer side if this
    assumption is invalid.

    Windows:

    The Windows implementation uses an IPC Event and shared memory to hold
    an integer - the reader count.

    The readers lock the gate by resetting the event and incrementing the
    reader count. They unlock the gate by decrementing the reader count
    and calling set event when the reader count reaches zero.

    The writer waits on the event for the gate to open. This is a timed wait
    to avoid the writer being left in an indefinite wait state should a reader
    terminate abnormally.

    Always initialised to the Unlocked state
  }

  TMultilockGate = class(TIpcCommon, IMultilockGate)
  private
    FSharedMemory: ISharedMemory;
    FOnGateTimeout: TNotifyEvent;
    FEvent: THandle;
    FLockCount: PInteger;
    FMutex: TMutex;
  public
    constructor Create(EventName: string; sm: ISharedMemory);
    destructor Destroy; override;
    procedure Lock;
    procedure Unlock;
    procedure PassthroughGate;
    function GetLockCount: integer;
    function GetOnGateTimeout: TNotifyEvent;
    procedure SetOnGateTimeout(aValue: TNotifyEvent);
    property LockCount: integer read GetLockCount;
    property OnGateTimeout: TNotifyEvent read GetOnGateTimeout write SetOnGateTimeout;
  end;

  { TIPCInterface }

  TIPCInterface = class(TIpcCommon, IIPCInterface)
  private
    FMaxBufferSize: integer;
    FSharedMemory: ISharedMemory;
    FWriteLock: IMutex;
    FBuffer: PByte;
    FTraceDataType,
    FBufferSize: PInteger;
    FTimeStamp: PDateTime;
    FMsgNumber: PInteger;
    FReadReadyEvent: IMultiLockGate;
    FReadFinishedEvent: IMultiLockGate;
    FDataAvailableEvent: ISingleLockGate;
    FWriterBusyEvent: ISingleLockGate;
    FMonitorCount: PInteger;
    procedure HandleGateTimeout(Sender: TObject);
  public
    constructor Create;
    procedure IncMonitorCount;
    procedure DecMonitorCount;
    procedure SendTrace(TraceObject: TTraceObject);
    procedure ReceiveTrace(TraceObject: TTraceObject);
    function GetDataAvailableEvent: ISingleLockGate;
    function GetWriterBusyEvent: ISingleLockGate;
    function GetReadReadyEvent: IMultiLockGate;
    function GetReadFinishedEvent: IMultiLockGate;
    function GetWriteLock: IMutex;
    function GetMonitorCount: integer;
    function GetMaxBufferSize: integer;
    property DataAvailableEvent: ISingleLockGate read GetDataAvailableEvent;
    property WriterBusyEvent: ISingleLockGate read GetWriterBusyEvent;
    property ReadReadyEvent: IMultiLockGate read GetReadReadyEvent;
    property ReadFinishedEvent: IMultiLockGate read GetReadFinishedEvent;
    property WriteLock: IMutex read GetWriteLock;
    property MonitorCount: integer read GetMonitorCount;
    property MaxBufferSize: integer read GetMaxBufferSize;
  end;

{ TSharedMemory }

procedure TSharedMemory.GetSharedMemory(MemSize: integer);
begin
  FSharedBuffer := CreateFileMapping(INVALID_HANDLE_VALUE, sa, PAGE_READWRITE,
                       0, MemSize, PChar(MonitorHookNames[1]));

  if GetLastError = ERROR_ALREADY_EXISTS then
    FSharedBuffer := OpenFileMapping(FILE_MAP_ALL_ACCESS, false, PChar(MonitorHookNames[1]))
  else
    FInitialiser := true;
  if (FSharedBuffer = 0) then
      IBError(ibxeCannotCreateSharedResource, [GetLastError]);
end;

constructor TSharedMemory.Create(MemSize: integer);
begin
  inherited Create;
  FInitialiser := false;
  GetSharedMemory(MemSize);
  FBuffer := MapViewOfFile(FSharedBuffer, FILE_MAP_ALL_ACCESS, 0, 0, 0);

  if FBuffer = nil then
      IBError(ibxeCannotCreateSharedResource, [GetLastError]);
  FBufPtr := FBuffer;
  FUnused := MemSize
end;

destructor TSharedMemory.Destroy;
begin
  UnmapViewOfFile(FBuffer);
  CloseHandle(FSharedBuffer);
  inherited Destroy;
end;

function TSharedMemory.Allocate(Size: integer): PByte;
begin
  if Size > FUnused then
      IBError(ibxeCannotCreateSharedResource, ['Not enough shared memory']);
  Result := FBufPtr;

  if Size = 0 then
  begin
    FLastAllocationSize := FUnused;
    FUnused := 0
  end
  else
  begin
    FLastAllocationSize := Size;
    Dec(FUnused,Size);
  end;
  Inc(FBufPtr,Size)
end;

function TSharedMemory.GetLastAllocationSize: integer;
begin
  Result := FLastAllocationSize;
end;

function TSharedMemory.IsInitialiser: boolean;
begin
  Result := FInitialiser;
end;

{ TIpcCommon }

function TIpcCommon.GetSa: PSecurityAttributes;
begin
  Result := @FSa
end;

constructor TIpcCommon.Create;
begin
  { Setup Security so anyone can connect to the MMF/Mutex/Event.  This is
    needed when IBX is used in a Service. }

  InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
  SetSecurityDescriptorDacl(@Sd,true,nil,false);
  FSa.nLength := SizeOf(FSa);
  FSa.lpSecurityDescriptor := @Sd;
  FSa.bInheritHandle := true;
end;


  { TMutex }

constructor TMutex.Create(MutexName: string; IsInitialiser: boolean);
begin
  inherited Create;
  if IsInitialiser then
    FMutex := CreateMutex(sa, False, PChar(MutexName))
  else
    FMutex := OpenMutex(MUTEX_ALL_ACCESS, False, PChar(MutexName));

  if FMutex = 0 then
    IBError(ibxeCannotCreateSharedResource, [GetLastError])
end;

destructor TMutex.Destroy;
begin
  CloseHandle(FMutex);
  inherited Destroy;
end;

{ Obtain ownership of the Mutex and prevent other threads from accessing protected resource }

procedure TMutex.Lock;
begin
  WaitForSingleObject(FMutex, INFINITE);
end;

{Give up ownership of the Mutex and allow other threads access }

procedure TMutex.Unlock;
begin
  ReleaseMutex(FMutex);
end;

{ TSingleLockGate }
constructor TSingleLockGate.Create(EventName: string; IsInitialiser: boolean);
begin
  inherited Create;
  if IsInitialiser then
    FEvent := CreateEvent(sa, true, true, PAnsiChar(EventName))
  else
    FEvent := OpenEvent(EVENT_ALL_ACCESS, true, PAnsiChar(EventName));

  if FEvent = 0 then
    IBError(ibxeCannotCreateSharedResource, [GetLastError])
end;

destructor TSingleLockGate.Destroy;
begin
  CloseHandle(FEvent);
  inherited Destroy;
end;


procedure TSingleLockGate.PassthroughGate;
begin
  WaitForSingleObject(FEvent,INFINITE)
end;

procedure TSingleLockGate.Unlock;
begin
  SetEvent(FEvent) //Event State set to "signaled"
end;

procedure TSingleLockGate.Lock;
begin
  ResetEvent(FEvent) //Event State set to "unsignaled"
end;

{ TMultilockGate }

constructor TMultilockGate.Create(EventName: string; sm: ISharedMemory);
begin
  inherited Create;
  FSharedMemory := sm;
  FLockCount := PInteger(FSharedMemory.Allocate(sizeof(FLockCount)));
  FMutex := TMutex.Create(EventName + '.Mutex',FSharedMemory.IsInitialiser);
  if FSharedMemory.IsInitialiser then
  begin
    FEvent := CreateEvent(sa, true, true, PChar(EventName));
    FLockCount^ := 0;
  end
  else
    FEvent := OpenEvent(EVENT_ALL_ACCESS, true, PChar(EventName));

  if FEvent = 0 then
    IBError(ibxeCannotCreateSharedResource, [GetLastError])
end;

destructor TMultilockGate.Destroy;
begin
  if assigned(FMutex) then FMutex.Free;
  CloseHandle(FEvent);
  inherited Destroy;
end;

function TMultilockGate.GetLockCount: integer;
begin
  Result := FLockCount^
end;

function TMultilockGate.GetOnGateTimeout: TNotifyEvent;
begin
  Result := FOnGateTimeout;
end;

procedure TMultilockGate.SetOnGateTimeout(aValue: TNotifyEvent);
begin
  FOnGateTimeout := AValue;
end;

procedure TMultilockGate.Lock;
begin
  FMutex.Lock;
  try
    Inc(FLockCount^);
    ResetEvent(FEvent);
  finally
    FMutex.Unlock;
  end;
  //writeln('Lock '+IntToStr(FLockCount^));
end;

procedure TMultilockGate.Unlock;
begin
  //writeln('Start UnLock '+IntToStr(FLockCount^));
  FMutex.Lock;
  try
    Dec(FLockCount^);
    if FLockCount^ <= 0 then
    begin
       SetEvent(FEvent);
       FLockCount^ := 0
    end;
  finally
    FMutex.Unlock;
  end;
  //writeln('UnLock '+IntToStr(FLockCount^));
end;

procedure TMultilockGate.PassthroughGate;
begin
  if FLockCount^ = 0 then
    Exit;
  while WaitForSingleObject(FEvent,cDefaultTimeout)= WAIT_TIMEOUT do
  { If we have timed out then we have lost a reader }
  begin
    if FLockCount^ > 0 then
    begin
      UnLock;
      if assigned(FOnGateTimeout) then
        OnGateTimeout(self)
    end
  end;
end;


{ TIPCInterface }

function TIPCInterface.GetMonitorCount: integer;
begin
  Result := FMonitorCount^
end;

function TIPCInterface.GetMaxBufferSize: integer;
begin
  Result := FMaxBufferSize;
end;

procedure TIPCInterface.HandleGateTimeout(Sender: TObject);
begin
  //writeln(ClassName+': Gate TimeOut');
  DecMonitorCount
end;

constructor TIPCInterface.Create;
begin
  inherited Create;
  FSharedMemory := TSharedMemory.Create(cMonitorHookSize);

  FWriteLock := TMutex.Create(PChar(MonitorHookNames[0]),FSharedMemory.IsInitialiser);
  FDataAvailableEvent := TSingleLockGate.Create(MonitorHookNames[2],FSharedMemory.IsInitialiser);
  FWriterBusyEvent := TSingleLockGate.Create(MonitorHookNames[3],FSharedMemory.IsInitialiser);
  FReadReadyEvent := TMultiLockGate.Create(MonitorHookNames[4],FSharedMemory);
  FReadReadyEvent.OnGateTimeout  := HandleGateTimeout;
  FReadFinishedEvent := TMultiLockGate.Create(MonitorHookNames[5],FSharedMemory);
  FReadFinishedEvent.OnGateTimeout  := HandleGateTimeout;

  FMonitorCount := PInteger(FSharedMemory.Allocate(sizeof(FMonitorCount)));

  if FSharedMemory.IsInitialiser then
    FMonitorCount^ := 0;
  FTraceDataType := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
  FTimeStamp := PDateTime(FSharedMemory.Allocate(sizeof(TDateTime)));
  FBufferSize := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
  FMsgNumber := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
  FBuffer := FSharedMemory.Allocate(0); //All remaining
  FMaxBufferSize := FSharedMemory.LastAllocationSize;

  if FSharedMemory.IsInitialiser then
  begin
    FBufferSize^ := 0;
    FDataAvailableEvent.Lock;
    FMsgNumber^ := 0;
  end;
end;

procedure TIPCInterface.IncMonitorCount;
begin
  InterlockedIncrement(FMonitorCount^)
end;

procedure TIPCInterface.DecMonitorCount;
begin
   InterlockedDecrement(FMonitorCount^)
end;

procedure TIPCInterface.SendTrace(TraceObject: TTraceObject);
begin
  FTraceDataType^ := Integer(TraceObject.FDataType);
  FTimeStamp^ := TraceObject.FTimeStamp;
  FBufferSize^ := Min(Length(TraceObject.FMsg), MaxBufferSize);
  FMsgNumber^ := TraceObject.FMsgNumber;
  Move(TraceObject.FMsg[1], FBuffer^, FBufferSize^);
end;

procedure TIPCInterface.ReceiveTrace(TraceObject: TTraceObject);
begin
  SetString(TraceObject.FMsg, PAnsiChar(FBuffer), FBufferSize^);
  TraceObject.FDataType := TTraceFlag(FTraceDataType^);
  TraceObject.FTimeStamp := TDateTime(FTimeStamp^);
  TraceObject.FMsgNumber := FMsgNumber^;
end;

function TIPCInterface.GetDataAvailableEvent: ISingleLockGate;
begin
  Result := FDataAvailableEvent;
end;

function TIPCInterface.GetWriterBusyEvent: ISingleLockGate;
begin
  Result := FWriterBusyEvent;
end;

function TIPCInterface.GetReadReadyEvent: IMultiLockGate;
begin
  Result := FReadReadyEvent;
end;

function TIPCInterface.GetReadFinishedEvent: IMultiLockGate;
begin
  Result := FReadFinishedEvent;
end;

function TIPCInterface.GetWriteLock: IMutex;
begin
  Result := FWriteLock;
end;


Revision:	321
Committed:	Thu Feb 25 12:10:07 2021 UTC (3 years, 9 months ago) by tony
Original Path:	*ibx/trunk/runtime/nongui/winipc.inc*
File size:	15086 byte(s)
Log Message:	tidy up IPC
#	User	Rev	Content
1	tony	319	{Used by IBIPC and implements System V IPC}
2
3			uses IBMessages;
4
5	tony	209	const
6			MonitorHookNames: array[0..5] of String = (
7			'FB.SQL.MONITOR.Mutex1_0',
8			'FB.SQL.MONITOR.SharedMem1_0',
9			'FB.SQL.MONITOR.WriteEvent1_0',
10			'FB.SQL.MONITOR.WriteFinishedEvent1_0',
11			'FB.SQL.MONITOR.ReadEvent1_0',
12			'FB.SQL.MONITOR.ReadFinishedEvent1_0'
13			);
14	tony	320	cDefaultTimeout = 10000; {milli seconds }
15	tony	209
16			type
17			{Interprocess Communication Objects. All platform dependent IPC is abstracted
18			into this set of objects }
19
20			{ TIpcCommon }
21
22	tony	319	TIpcCommon = class(TInterfacedObject)
23	tony	209	protected
24			FSa : TSecurityAttributes;
25			private
26			Sd : TSecurityDescriptor;
27			public
28			constructor Create;
29	tony	319	function GetSa: PSecurityAttributes;
30	tony	209	property Sa : PSecurityAttributes read GetSa;
31			end;
32
33			{ TSharedMemory }
34
35			{
36			The shared memory segment is used for interprocess communication and
37			holds both a message buffer and a number of shared variables. Shared
38			memory is allocated to each shared variable using the Allocate function.
39			An underlying assumption is that each process using the shared memory
40			calls "Allocate" in the same order and for the same memory sizes.
41
42			Windows:
43
44			The Windows implementation uses Windows shared memory. This is identified
45			by a global name known to every process. There is no security with
46			the windows implementation and the shared memory can be read by
47			any active process.
48
49			}
50
51	tony	321	ISharedMemory = interface
52			['{db77bdd4-233a-4c9c-9212-dd7945e2e57c}']
53	tony	320	function IsInitialiser: boolean;
54	tony	321	function Allocate(Size: integer): PByte;
55			function GetLastAllocationSize: integer;
56			property LastAllocationSize: integer read GetLastAllocationSize;
57	tony	320	end;
58
59	tony	321
60			TSharedMemory = class(TIpcCommon,ISharedMemory)
61	tony	209	private
62	tony	319	FBuffer: PByte;
63	tony	209	FLastAllocationSize: integer;
64			FUnused: integer;
65	tony	319	FBufptr: PByte;
66	tony	209	FSharedBuffer: THandle;
67	tony	320	FInitialiser: boolean;
68	tony	209	procedure GetSharedMemory(MemSize: integer);
69			public
70			constructor Create(MemSize: integer);
71			destructor Destroy; override;
72	tony	319	function Allocate(Size: integer): PByte;
73			function GetLastAllocationSize: integer;
74	tony	320	function IsInitialiser: boolean;
75	tony	319	property LastAllocationSize: integer read GetLastAllocationSize;
76	tony	209	end;
77
78			{TMutex}
79
80	tony	319	TMutex = class(TIpcCommon, IMutex)
81	tony	209	private
82			FMutex: THandle;
83			public
84	tony	320	constructor Create(MutexName: string; IsInitialiser: boolean);
85	tony	209	destructor Destroy; override;
86			procedure Lock;
87			procedure Unlock;
88			end;
89
90			{ TSingleLockGate }
91
92			{
93			A single lock gate is either open or closed. When open, any thread can pass
94			through it while, when closed, all threads are blocked as they try to pass
95			through the gate. When the gate is opened, all blocked threads are resumed.
96
97			There is an implementation assumption that only one writer thread at
98			a time (i.e. the thread which locks or unlocks the gate) can have access to
99			it at any one time. I.e. an external Mutex prevents race conditions.
100
101			Windows:
102
103			In the Windows implementation, a Windows Event is used to implement
104			the "gate". No additional functionality is required as the behaviour
105			of a Windows event meets the requirement.
106
107
108			Always initialised to the Unlocked state
109			}
110
111	tony	319	TSingleLockGate = class(TIpcCommon,ISingleLockGate)
112	tony	209	private
113			FEvent: THandle;
114			public
115	tony	320	constructor Create(EventName: string; IsInitialiser: boolean);
116	tony	209	destructor Destroy; override;
117			procedure PassthroughGate;
118			procedure Unlock;
119			procedure Lock;
120			end;
121
122			{ TMultilockGate }
123
124			{ This type of Gate is used where several reader threads must pass
125			through the gate before it can be opened for a writer thread.
126
127			The reader threads register their interest by each locking the gate.
128			The writer thread then waits on the locked gate until all the reader
129			threads have separately unlocked the gate.
130
131			There is an underlying assumption of a single writer. A Mutex must
132			be used to control access to the gate from the writer side if this
133			assumption is invalid.
134
135			Windows:
136
137			The Windows implementation uses an IPC Event and shared memory to hold
138			an integer - the reader count.
139
140			The readers lock the gate by resetting the event and incrementing the
141			reader count. They unlock the gate by decrementing the reader count
142			and calling set event when the reader count reaches zero.
143
144			The writer waits on the event for the gate to open. This is a timed wait
145			to avoid the writer being left in an indefinite wait state should a reader
146			terminate abnormally.
147
148			Always initialised to the Unlocked state
149			}
150
151	tony	319	TMultilockGate = class(TIpcCommon, IMultilockGate)
152	tony	209	private
153	tony	321	FSharedMemory: ISharedMemory;
154	tony	209	FOnGateTimeout: TNotifyEvent;
155			FEvent: THandle;
156			FLockCount: PInteger;
157			FMutex: TMutex;
158			public
159	tony	321	constructor Create(EventName: string; sm: ISharedMemory);
160	tony	209	destructor Destroy; override;
161			procedure Lock;
162			procedure Unlock;
163			procedure PassthroughGate;
164	tony	319	function GetLockCount: integer;
165			function GetOnGateTimeout: TNotifyEvent;
166			procedure SetOnGateTimeout(aValue: TNotifyEvent);
167	tony	209	property LockCount: integer read GetLockCount;
168	tony	319	property OnGateTimeout: TNotifyEvent read GetOnGateTimeout write SetOnGateTimeout;
169	tony	209	end;
170
171	tony	319	{ TIPCInterface }
172	tony	209
173	tony	319	TIPCInterface = class(TIpcCommon, IIPCInterface)
174	tony	209	private
175			FMaxBufferSize: integer;
176	tony	321	FSharedMemory: ISharedMemory;
177	tony	319	FWriteLock: IMutex;
178			FBuffer: PByte;
179	tony	209	FTraceDataType,
180			FBufferSize: PInteger;
181			FTimeStamp: PDateTime;
182	tony	319	FMsgNumber: PInteger;
183			FReadReadyEvent: IMultiLockGate;
184			FReadFinishedEvent: IMultiLockGate;
185			FDataAvailableEvent: ISingleLockGate;
186			FWriterBusyEvent: ISingleLockGate;
187	tony	209	FMonitorCount: PInteger;
188			procedure HandleGateTimeout(Sender: TObject);
189			public
190			constructor Create;
191			procedure IncMonitorCount;
192			procedure DecMonitorCount;
193			procedure SendTrace(TraceObject: TTraceObject);
194			procedure ReceiveTrace(TraceObject: TTraceObject);
195	tony	319	function GetDataAvailableEvent: ISingleLockGate;
196			function GetWriterBusyEvent: ISingleLockGate;
197			function GetReadReadyEvent: IMultiLockGate;
198			function GetReadFinishedEvent: IMultiLockGate;
199			function GetWriteLock: IMutex;
200			function GetMonitorCount: integer;
201			function GetMaxBufferSize: integer;
202			property DataAvailableEvent: ISingleLockGate read GetDataAvailableEvent;
203			property WriterBusyEvent: ISingleLockGate read GetWriterBusyEvent;
204			property ReadReadyEvent: IMultiLockGate read GetReadReadyEvent;
205			property ReadFinishedEvent: IMultiLockGate read GetReadFinishedEvent;
206			property WriteLock: IMutex read GetWriteLock;
207	tony	209	property MonitorCount: integer read GetMonitorCount;
208	tony	319	property MaxBufferSize: integer read GetMaxBufferSize;
209	tony	209	end;
210
211			{ TSharedMemory }
212
213			procedure TSharedMemory.GetSharedMemory(MemSize: integer);
214			begin
215			FSharedBuffer := CreateFileMapping(INVALID_HANDLE_VALUE, sa, PAGE_READWRITE,
216			0, MemSize, PChar(MonitorHookNames[1]));
217
218			if GetLastError = ERROR_ALREADY_EXISTS then
219			FSharedBuffer := OpenFileMapping(FILE_MAP_ALL_ACCESS, false, PChar(MonitorHookNames[1]))
220			else
221			FInitialiser := true;
222			if (FSharedBuffer = 0) then
223			IBError(ibxeCannotCreateSharedResource, [GetLastError]);
224			end;
225
226			constructor TSharedMemory.Create(MemSize: integer);
227			begin
228			inherited Create;
229			FInitialiser := false;
230			GetSharedMemory(MemSize);
231			FBuffer := MapViewOfFile(FSharedBuffer, FILE_MAP_ALL_ACCESS, 0, 0, 0);
232
233			if FBuffer = nil then
234			IBError(ibxeCannotCreateSharedResource, [GetLastError]);
235			FBufPtr := FBuffer;
236			FUnused := MemSize
237			end;
238
239			destructor TSharedMemory.Destroy;
240			begin
241			UnmapViewOfFile(FBuffer);
242			CloseHandle(FSharedBuffer);
243			inherited Destroy;
244			end;
245
246	tony	319	function TSharedMemory.Allocate(Size: integer): PByte;
247	tony	209	begin
248			if Size > FUnused then
249			IBError(ibxeCannotCreateSharedResource, ['Not enough shared memory']);
250			Result := FBufPtr;
251
252			if Size = 0 then
253			begin
254			FLastAllocationSize := FUnused;
255			FUnused := 0
256			end
257			else
258			begin
259			FLastAllocationSize := Size;
260			Dec(FUnused,Size);
261			end;
262			Inc(FBufPtr,Size)
263			end;
264
265	tony	319	function TSharedMemory.GetLastAllocationSize: integer;
266			begin
267			Result := FLastAllocationSize;
268			end;
269
270	tony	320	function TSharedMemory.IsInitialiser: boolean;
271			begin
272			Result := FInitialiser;
273			end;
274
275	tony	209	{ TIpcCommon }
276
277			function TIpcCommon.GetSa: PSecurityAttributes;
278			begin
279			Result := @FSa
280			end;
281
282			constructor TIpcCommon.Create;
283			begin
284			{ Setup Security so anyone can connect to the MMF/Mutex/Event. This is
285			needed when IBX is used in a Service. }
286
287			InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
288			SetSecurityDescriptorDacl(@Sd,true,nil,false);
289			FSa.nLength := SizeOf(FSa);
290			FSa.lpSecurityDescriptor := @Sd;
291			FSa.bInheritHandle := true;
292			end;
293
294
295			{ TMutex }
296
297	tony	320	constructor TMutex.Create(MutexName: string; IsInitialiser: boolean);
298	tony	209	begin
299			inherited Create;
300	tony	320	if IsInitialiser then
301	tony	209	FMutex := CreateMutex(sa, False, PChar(MutexName))
302			else
303			FMutex := OpenMutex(MUTEX_ALL_ACCESS, False, PChar(MutexName));
304
305			if FMutex = 0 then
306			IBError(ibxeCannotCreateSharedResource, [GetLastError])
307			end;
308
309			destructor TMutex.Destroy;
310			begin
311			CloseHandle(FMutex);
312			inherited Destroy;
313			end;
314
315			{ Obtain ownership of the Mutex and prevent other threads from accessing protected resource }
316
317			procedure TMutex.Lock;
318			begin
319			WaitForSingleObject(FMutex, INFINITE);
320			end;
321
322			{Give up ownership of the Mutex and allow other threads access }
323
324			procedure TMutex.Unlock;
325			begin
326			ReleaseMutex(FMutex);
327			end;
328
329			{ TSingleLockGate }
330	tony	320	constructor TSingleLockGate.Create(EventName: string; IsInitialiser: boolean);
331	tony	209	begin
332			inherited Create;
333	tony	320	if IsInitialiser then
334	tony	319	FEvent := CreateEvent(sa, true, true, PAnsiChar(EventName))
335	tony	209	else
336	tony	319	FEvent := OpenEvent(EVENT_ALL_ACCESS, true, PAnsiChar(EventName));
337	tony	209
338			if FEvent = 0 then
339			IBError(ibxeCannotCreateSharedResource, [GetLastError])
340			end;
341
342			destructor TSingleLockGate.Destroy;
343			begin
344			CloseHandle(FEvent);
345			inherited Destroy;
346			end;
347
348
349			procedure TSingleLockGate.PassthroughGate;
350			begin
351			WaitForSingleObject(FEvent,INFINITE)
352			end;
353
354			procedure TSingleLockGate.Unlock;
355			begin
356			SetEvent(FEvent) //Event State set to "signaled"
357			end;
358
359			procedure TSingleLockGate.Lock;
360			begin
361			ResetEvent(FEvent) //Event State set to "unsignaled"
362			end;
363
364			{ TMultilockGate }
365
366	tony	321	constructor TMultilockGate.Create(EventName: string; sm: ISharedMemory);
367	tony	209	begin
368			inherited Create;
369	tony	319	FSharedMemory := sm;
370			FLockCount := PInteger(FSharedMemory.Allocate(sizeof(FLockCount)));
371	tony	320	FMutex := TMutex.Create(EventName + '.Mutex',FSharedMemory.IsInitialiser);
372			if FSharedMemory.IsInitialiser then
373	tony	209	begin
374			FEvent := CreateEvent(sa, true, true, PChar(EventName));
375			FLockCount^ := 0;
376			end
377			else
378			FEvent := OpenEvent(EVENT_ALL_ACCESS, true, PChar(EventName));
379
380			if FEvent = 0 then
381			IBError(ibxeCannotCreateSharedResource, [GetLastError])
382			end;
383
384			destructor TMultilockGate.Destroy;
385			begin
386			if assigned(FMutex) then FMutex.Free;
387			CloseHandle(FEvent);
388			inherited Destroy;
389			end;
390
391			function TMultilockGate.GetLockCount: integer;
392			begin
393			Result := FLockCount^
394			end;
395
396	tony	319	function TMultilockGate.GetOnGateTimeout: TNotifyEvent;
397			begin
398			Result := FOnGateTimeout;
399			end;
400
401	tony	320	procedure TMultilockGate.SetOnGateTimeout(aValue: TNotifyEvent);
402	tony	319	begin
403			FOnGateTimeout := AValue;
404			end;
405
406	tony	209	procedure TMultilockGate.Lock;
407			begin
408			FMutex.Lock;
409			try
410			Inc(FLockCount^);
411			ResetEvent(FEvent);
412			finally
413			FMutex.Unlock;
414			end;
415			//writeln('Lock '+IntToStr(FLockCount^));
416			end;
417
418			procedure TMultilockGate.Unlock;
419			begin
420			//writeln('Start UnLock '+IntToStr(FLockCount^));
421			FMutex.Lock;
422			try
423			Dec(FLockCount^);
424			if FLockCount^ <= 0 then
425			begin
426			SetEvent(FEvent);
427			FLockCount^ := 0
428			end;
429			finally
430			FMutex.Unlock;
431			end;
432			//writeln('UnLock '+IntToStr(FLockCount^));
433			end;
434
435			procedure TMultilockGate.PassthroughGate;
436			begin
437			if FLockCount^ = 0 then
438			Exit;
439			while WaitForSingleObject(FEvent,cDefaultTimeout)= WAIT_TIMEOUT do
440			{ If we have timed out then we have lost a reader }
441			begin
442			if FLockCount^ > 0 then
443			begin
444			UnLock;
445			if assigned(FOnGateTimeout) then
446			OnGateTimeout(self)
447			end
448			end;
449			end;
450
451
452	tony	319	{ TIPCInterface }
453	tony	209
454	tony	319	function TIPCInterface.GetMonitorCount: integer;
455	tony	209	begin
456			Result := FMonitorCount^
457			end;
458
459	tony	319	function TIPCInterface.GetMaxBufferSize: integer;
460			begin
461			Result := FMaxBufferSize;
462			end;
463
464			procedure TIPCInterface.HandleGateTimeout(Sender: TObject);
465			begin
466	tony	209	//writeln(ClassName+': Gate TimeOut');
467			DecMonitorCount
468			end;
469
470	tony	319	constructor TIPCInterface.Create;
471	tony	209	begin
472			inherited Create;
473			FSharedMemory := TSharedMemory.Create(cMonitorHookSize);
474
475	tony	320	FWriteLock := TMutex.Create(PChar(MonitorHookNames[0]),FSharedMemory.IsInitialiser);
476			FDataAvailableEvent := TSingleLockGate.Create(MonitorHookNames[2],FSharedMemory.IsInitialiser);
477			FWriterBusyEvent := TSingleLockGate.Create(MonitorHookNames[3],FSharedMemory.IsInitialiser);
478	tony	319	FReadReadyEvent := TMultiLockGate.Create(MonitorHookNames[4],FSharedMemory);
479	tony	209	FReadReadyEvent.OnGateTimeout := HandleGateTimeout;
480	tony	319	FReadFinishedEvent := TMultiLockGate.Create(MonitorHookNames[5],FSharedMemory);
481	tony	209	FReadFinishedEvent.OnGateTimeout := HandleGateTimeout;
482
483			FMonitorCount := PInteger(FSharedMemory.Allocate(sizeof(FMonitorCount)));
484
485	tony	320	if FSharedMemory.IsInitialiser then
486	tony	209	FMonitorCount^ := 0;
487			FTraceDataType := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
488			FTimeStamp := PDateTime(FSharedMemory.Allocate(sizeof(TDateTime)));
489			FBufferSize := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
490	tony	319	FMsgNumber := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
491	tony	209	FBuffer := FSharedMemory.Allocate(0); //All remaining
492			FMaxBufferSize := FSharedMemory.LastAllocationSize;
493
494	tony	320	if FSharedMemory.IsInitialiser then
495	tony	209	begin
496			FBufferSize^ := 0;
497	tony	319	FDataAvailableEvent.Lock;
498			FMsgNumber^ := 0;
499	tony	209	end;
500			end;
501
502	tony	319	procedure TIPCInterface.IncMonitorCount;
503	tony	209	begin
504			InterlockedIncrement(FMonitorCount^)
505			end;
506
507	tony	319	procedure TIPCInterface.DecMonitorCount;
508	tony	209	begin
509			InterlockedDecrement(FMonitorCount^)
510			end;
511
512	tony	319	procedure TIPCInterface.SendTrace(TraceObject: TTraceObject);
513	tony	209	begin
514			FTraceDataType^ := Integer(TraceObject.FDataType);
515			FTimeStamp^ := TraceObject.FTimeStamp;
516			FBufferSize^ := Min(Length(TraceObject.FMsg), MaxBufferSize);
517	tony	319	FMsgNumber^ := TraceObject.FMsgNumber;
518	tony	209	Move(TraceObject.FMsg[1], FBuffer^, FBufferSize^);
519			end;
520
521	tony	319	procedure TIPCInterface.ReceiveTrace(TraceObject: TTraceObject);
522	tony	209	begin
523	tony	319	SetString(TraceObject.FMsg, PAnsiChar(FBuffer), FBufferSize^);
524	tony	209	TraceObject.FDataType := TTraceFlag(FTraceDataType^);
525			TraceObject.FTimeStamp := TDateTime(FTimeStamp^);
526	tony	319	TraceObject.FMsgNumber := FMsgNumber^;
527	tony	209	end;
528
529	tony	319	function TIPCInterface.GetDataAvailableEvent: ISingleLockGate;
530			begin
531			Result := FDataAvailableEvent;
532			end;
533	tony	209
534	tony	319	function TIPCInterface.GetWriterBusyEvent: ISingleLockGate;
535			begin
536			Result := FWriterBusyEvent;
537			end;
538	tony	209
539	tony	319	function TIPCInterface.GetReadReadyEvent: IMultiLockGate;
540			begin
541			Result := FReadReadyEvent;
542			end;
543
544			function TIPCInterface.GetReadFinishedEvent: IMultiLockGate;
545			begin
546			Result := FReadFinishedEvent;
547			end;
548
549			function TIPCInterface.GetWriteLock: IMutex;
550			begin
551			Result := FWriteLock;
552			end;
553
554
555