trunk/runtime/winipc.inc

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 = 1000; { 1 seconds }

type
  TGlobalInterface = class;

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

  { TIpcCommon }

  TIpcCommon = class
  private
    function GetSa: PSecurityAttributes;
  protected
    class var FInitialiser: boolean;
    FSa : TSecurityAttributes;
  private
    Sd : TSecurityDescriptor;
  public
    constructor Create;
    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.

  }

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

  {TMutex}

  TMutex = class(TIpcCommon)
  private
    FMutex: THandle;
  public
    constructor Create(MutexName: string);
    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)
  private
    FOwner: TGlobalInterface;
    FEvent: THandle;
  public
    constructor Create(EventName: string; AOwner: TGlobalInterface);
    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)
  private
    FOnGateTimeout: TNotifyEvent;
    FOwner: TGlobalInterface;
    FEvent: THandle;
    FLockCount: PInteger;
    FMutex: TMutex;
   function GetLockCount: integer;
  public
    constructor Create(EventName: string; AOwner: TGlobalInterface);
    destructor Destroy; override;
    procedure Lock;
    procedure Unlock;
    procedure PassthroughGate;
    property LockCount: integer read GetLockCount;
    property OnGateTimeout: TNotifyEvent read FOnGateTimeout write FOnGateTimeout;
  end;

  { TGlobalInterface }

  TGlobalInterface = class(TIpcCommon)
  private
    FMaxBufferSize: integer;
    FSharedMemory: TSharedMemory;
    FWriteLock: TMutex;
    FBuffer: PChar;
    FTraceDataType,
    FBufferSize: PInteger;
    FTimeStamp: PDateTime;
    FReadReadyEvent: TMultiLockGate;
    FReadFinishedEvent: TMultiLockGate;
    FDataAvailableEvent: TSingleLockGate;
    FWriterBusyEvent: TSingleLockGate;
    FMonitorCount: PInteger;
    procedure HandleGateTimeout(Sender: TObject);
    function GetMonitorCount: integer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure IncMonitorCount;
    procedure DecMonitorCount;
    procedure SendTrace(TraceObject: TTraceObject);
    procedure ReceiveTrace(TraceObject: TTraceObject);
    property DataAvailableEvent: TSingleLockGate read FDataAvailableEvent;
    property WriterBusyEvent: TSingleLockGate read FWriterBusyEvent;
    property ReadReadyEvent: TMultiLockGate read FReadReadyEvent;
    property ReadFinishedEvent: TMultiLockGate read FReadFinishedEvent;
    property WriteLock: TMutex read FWriteLock;
    property MonitorCount: integer read GetMonitorCount;
    property SharedMemory: TSharedMemory read FSharedMemory;
    property MaxBufferSize: integer read FMaxBufferSize;
  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): PChar;
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;

{ 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);
begin
  inherited Create;
  if FInitialiser 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; AOwner: TGlobalInterface);
begin
  inherited Create;
  FOwner := AOwner;
  if FInitialiser then
    FEvent := CreateEvent(sa, true, true, PChar(EventName))
  else
    FEvent := OpenEvent(EVENT_ALL_ACCESS, true, PChar(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; AOwner: TGlobalInterface);
begin
  inherited Create;
  FOwner := AOwner;
  FLockCount := PInteger(FOwner.SharedMemory.Allocate(sizeof(FLockCount)));
  FMutex := TMutex.Create(EventName + '.Mutex');
  if FInitialiser 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;

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;


{ TGlobalInterface }

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

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

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

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

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

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

  if FInitialiser then
  begin
    FBufferSize^ := 0;
    FDataAvailableEvent.Lock
  end;
end;

destructor TGlobalInterface.Destroy;
begin
  if assigned(FWriteLock) then FWriteLock.Free;
  if assigned(FDataAvailableEvent) then FDataAvailableEvent.Free;
  if assigned(FWriterBusyEvent) then FWriterBusyEvent.Free;
  if assigned(FReadReadyEvent) then FReadReadyEvent.Free;
  if assigned(FReadFinishedEvent) then FReadFinishedEvent.Free;
  if assigned(FSharedMemory) then FSharedMemory.Free;
  inherited Destroy;
end;

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

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

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

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


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