runtime/nongui/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:	209
Committed:	Wed Mar 14 12:48:51 2018 UTC (6 years, 8 months ago) by tony
File size:	13442 byte(s)
Log Message:	Fixes Merged
#	User	Rev	Content
1	tony	209	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