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
    FInitialiser: boolean;  static;
    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;
    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)));
  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
  CloseHandle(FEvent);
  inherited Destroy;
end;

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

procedure TMultilockGate.Lock;
begin
  InterlockedIncrement(FLockCount^);
  ResetEvent(FEvent);
  //writeln('Lock '+IntToStr(FLockCount^));
end;

procedure TMultilockGate.Unlock;
begin
  //writeln('Start UnLock '+IntToStr(FLockCount^));
  InterlockedDecrement(FLockCount^);
  if FLockCount^ <= 0 then
  begin
     SetEvent(FEvent);
     FLockCount^ := 0
  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:	33
Committed:	Sat Jul 18 12:30:52 2015 UTC (9 years, 4 months ago) by tony
File size:	13237 byte(s)
Log Message:	Committing updates for Release R1-3-1
#	User	Rev	Content
1	tony	33	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			FInitialiser: boolean; static;
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			function GetLockCount: integer;
147			public
148			constructor Create(EventName: string; AOwner: TGlobalInterface);
149			destructor Destroy; override;
150			procedure Lock;
151			procedure Unlock;
152			procedure PassthroughGate;
153			property LockCount: integer read GetLockCount;
154			property OnGateTimeout: TNotifyEvent read FOnGateTimeout write FOnGateTimeout;
155			end;
156
157			{ TGlobalInterface }
158
159			TGlobalInterface = class(TIpcCommon)
160			private
161			FMaxBufferSize: integer;
162			FSharedMemory: TSharedMemory;
163			FWriteLock: TMutex;
164			FBuffer: PChar;
165			FTraceDataType,
166			FBufferSize: PInteger;
167			FTimeStamp: PDateTime;
168			FReadReadyEvent: TMultiLockGate;
169			FReadFinishedEvent: TMultiLockGate;
170			FDataAvailableEvent: TSingleLockGate;
171			FWriterBusyEvent: TSingleLockGate;
172			FMonitorCount: PInteger;
173			procedure HandleGateTimeout(Sender: TObject);
174			function GetMonitorCount: integer;
175			public
176			constructor Create;
177			destructor Destroy; override;
178			procedure IncMonitorCount;
179			procedure DecMonitorCount;
180			procedure SendTrace(TraceObject: TTraceObject);
181			procedure ReceiveTrace(TraceObject: TTraceObject);
182			property DataAvailableEvent: TSingleLockGate read FDataAvailableEvent;
183			property WriterBusyEvent: TSingleLockGate read FWriterBusyEvent;
184			property ReadReadyEvent: TMultiLockGate read FReadReadyEvent;
185			property ReadFinishedEvent: TMultiLockGate read FReadFinishedEvent;
186			property WriteLock: TMutex read FWriteLock;
187			property MonitorCount: integer read GetMonitorCount;
188			property SharedMemory: TSharedMemory read FSharedMemory;
189			property MaxBufferSize: integer read FMaxBufferSize;
190			end;
191
192			{ TSharedMemory }
193
194			procedure TSharedMemory.GetSharedMemory(MemSize: integer);
195			begin
196			FSharedBuffer := CreateFileMapping(INVALID_HANDLE_VALUE, sa, PAGE_READWRITE,
197			0, MemSize, PChar(MonitorHookNames[1]));
198
199			if GetLastError = ERROR_ALREADY_EXISTS then
200			FSharedBuffer := OpenFileMapping(FILE_MAP_ALL_ACCESS, false, PChar(MonitorHookNames[1]))
201			else
202			FInitialiser := true;
203			if (FSharedBuffer = 0) then
204			IBError(ibxeCannotCreateSharedResource, [GetLastError]);
205			end;
206
207			constructor TSharedMemory.Create(MemSize: integer);
208			begin
209			inherited Create;
210			FInitialiser := false;
211			GetSharedMemory(MemSize);
212			FBuffer := MapViewOfFile(FSharedBuffer, FILE_MAP_ALL_ACCESS, 0, 0, 0);
213
214			if FBuffer = nil then
215			IBError(ibxeCannotCreateSharedResource, [GetLastError]);
216			FBufPtr := FBuffer;
217			FUnused := MemSize
218			end;
219
220			destructor TSharedMemory.Destroy;
221			begin
222			UnmapViewOfFile(FBuffer);
223			CloseHandle(FSharedBuffer);
224			inherited Destroy;
225			end;
226
227			function TSharedMemory.Allocate(Size: integer): PChar;
228			begin
229			if Size > FUnused then
230			IBError(ibxeCannotCreateSharedResource, ['Not enough shared memory']);
231			Result := FBufPtr;
232
233			if Size = 0 then
234			begin
235			FLastAllocationSize := FUnused;
236			FUnused := 0
237			end
238			else
239			begin
240			FLastAllocationSize := Size;
241			Dec(FUnused,Size);
242			end;
243			Inc(FBufPtr,Size)
244			end;
245
246			{ TIpcCommon }
247
248			function TIpcCommon.GetSa: PSecurityAttributes;
249			begin
250			Result := @FSa
251			end;
252
253			constructor TIpcCommon.Create;
254			begin
255			{ Setup Security so anyone can connect to the MMF/Mutex/Event. This is
256			needed when IBX is used in a Service. }
257
258			InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
259			SetSecurityDescriptorDacl(@Sd,true,nil,false);
260			FSa.nLength := SizeOf(FSa);
261			FSa.lpSecurityDescriptor := @Sd;
262			FSa.bInheritHandle := true;
263			end;
264
265
266			{ TMutex }
267
268			constructor TMutex.Create(MutexName: string);
269			begin
270			inherited Create;
271			if FInitialiser then
272			FMutex := CreateMutex(sa, False, PChar(MutexName))
273			else
274			FMutex := OpenMutex(MUTEX_ALL_ACCESS, False, PChar(MutexName));
275
276			if FMutex = 0 then
277			IBError(ibxeCannotCreateSharedResource, [GetLastError])
278			end;
279
280			destructor TMutex.Destroy;
281			begin
282			CloseHandle(FMutex);
283			inherited Destroy;
284			end;
285
286			{ Obtain ownership of the Mutex and prevent other threads from accessing protected resource }
287
288			procedure TMutex.Lock;
289			begin
290			WaitForSingleObject(FMutex, INFINITE);
291			end;
292
293			{Give up ownership of the Mutex and allow other threads access }
294
295			procedure TMutex.Unlock;
296			begin
297			ReleaseMutex(FMutex);
298			end;
299
300			{ TSingleLockGate }
301			constructor TSingleLockGate.Create(EventName: string; AOwner: TGlobalInterface);
302			begin
303			inherited Create;
304			FOwner := AOwner;
305			if FInitialiser then
306			FEvent := CreateEvent(sa, true, true, PChar(EventName))
307			else
308			FEvent := OpenEvent(EVENT_ALL_ACCESS, true, PChar(EventName));
309
310			if FEvent = 0 then
311			IBError(ibxeCannotCreateSharedResource, [GetLastError])
312			end;
313
314			destructor TSingleLockGate.Destroy;
315			begin
316			CloseHandle(FEvent);
317			inherited Destroy;
318			end;
319
320
321			procedure TSingleLockGate.PassthroughGate;
322			begin
323			WaitForSingleObject(FEvent,INFINITE)
324			end;
325
326			procedure TSingleLockGate.Unlock;
327			begin
328			SetEvent(FEvent) //Event State set to "signaled"
329			end;
330
331			procedure TSingleLockGate.Lock;
332			begin
333			ResetEvent(FEvent) //Event State set to "unsignaled"
334			end;
335
336			{ TMultilockGate }
337
338			constructor TMultilockGate.Create(EventName: string; AOwner: TGlobalInterface);
339			begin
340			inherited Create;
341			FOwner := AOwner;
342			FLockCount := PInteger(FOwner.SharedMemory.Allocate(sizeof(FLockCount)));
343			if FInitialiser then
344			begin
345			FEvent := CreateEvent(sa, true, true, PChar(EventName));
346			FLockCount^ := 0;
347			end
348			else
349			FEvent := OpenEvent(EVENT_ALL_ACCESS, true, PChar(EventName));
350
351			if FEvent = 0 then
352			IBError(ibxeCannotCreateSharedResource, [GetLastError])
353			end;
354
355			destructor TMultilockGate.Destroy;
356			begin
357			CloseHandle(FEvent);
358			inherited Destroy;
359			end;
360
361			function TMultilockGate.GetLockCount: integer;
362			begin
363			Result := FLockCount^
364			end;
365
366			procedure TMultilockGate.Lock;
367			begin
368			InterlockedIncrement(FLockCount^);
369			ResetEvent(FEvent);
370			//writeln('Lock '+IntToStr(FLockCount^));
371			end;
372
373			procedure TMultilockGate.Unlock;
374			begin
375			//writeln('Start UnLock '+IntToStr(FLockCount^));
376			InterlockedDecrement(FLockCount^);
377			if FLockCount^ <= 0 then
378			begin
379			SetEvent(FEvent);
380			FLockCount^ := 0
381			end;
382			//writeln('UnLock '+IntToStr(FLockCount^));
383			end;
384
385			procedure TMultilockGate.PassthroughGate;
386			begin
387			if FLockCount^ = 0 then
388			Exit;
389			while WaitForSingleObject(FEvent,cDefaultTimeout)= WAIT_TIMEOUT do
390			{ If we have timed out then we have lost a reader }
391			begin
392			if FLockCount^ > 0 then
393			begin
394			UnLock;
395			if assigned(FOnGateTimeout) then
396			OnGateTimeout(self)
397			end
398			end;
399			end;
400
401
402			{ TGlobalInterface }
403
404			function TGlobalInterface.GetMonitorCount: integer;
405			begin
406			Result := FMonitorCount^
407			end;
408
409			procedure TGlobalInterface.HandleGateTimeout(Sender: TObject);
410			begin
411			//writeln(ClassName+': Gate TimeOut');
412			DecMonitorCount
413			end;
414
415			constructor TGlobalInterface.Create;
416			begin
417			inherited Create;
418			FSharedMemory := TSharedMemory.Create(cMonitorHookSize);
419
420			FWriteLock := TMutex.Create(PChar(MonitorHookNames[0]));
421			FDataAvailableEvent := TSingleLockGate.Create(MonitorHookNames[2],self);
422			FWriterBusyEvent := TSingleLockGate.Create(MonitorHookNames[3],self);
423			FReadReadyEvent := TMultiLockGate.Create(MonitorHookNames[4],self);
424			FReadReadyEvent.OnGateTimeout := HandleGateTimeout;
425			FReadFinishedEvent := TMultiLockGate.Create(MonitorHookNames[5],self);
426			FReadFinishedEvent.OnGateTimeout := HandleGateTimeout;
427
428			FMonitorCount := PInteger(FSharedMemory.Allocate(sizeof(FMonitorCount)));
429
430			if FInitialiser then
431			FMonitorCount^ := 0;
432			FTraceDataType := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
433			FTimeStamp := PDateTime(FSharedMemory.Allocate(sizeof(TDateTime)));
434			FBufferSize := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
435			FBuffer := FSharedMemory.Allocate(0); //All remaining
436			FMaxBufferSize := FSharedMemory.LastAllocationSize;
437
438			if FInitialiser then
439			begin
440			FBufferSize^ := 0;
441			FDataAvailableEvent.Lock
442			end;
443			end;
444
445			destructor TGlobalInterface.Destroy;
446			begin
447			if assigned(FWriteLock) then FWriteLock.Free;
448			if assigned(FDataAvailableEvent) then FDataAvailableEvent.Free;
449			if assigned(FWriterBusyEvent) then FWriterBusyEvent.Free;
450			if assigned(FReadReadyEvent) then FReadReadyEvent.Free;
451			if assigned(FReadFinishedEvent) then FReadFinishedEvent.Free;
452			if assigned(FSharedMemory) then FSharedMemory.Free;
453			inherited Destroy;
454			end;
455
456			procedure TGlobalInterface.IncMonitorCount;
457			begin
458			InterlockedIncrement(FMonitorCount^)
459			end;
460
461			procedure TGlobalInterface.DecMonitorCount;
462			begin
463			InterlockedDecrement(FMonitorCount^)
464			end;
465
466			procedure TGlobalInterface.SendTrace(TraceObject: TTraceObject);
467			begin
468			FTraceDataType^ := Integer(TraceObject.FDataType);
469			FTimeStamp^ := TraceObject.FTimeStamp;
470			FBufferSize^ := Min(Length(TraceObject.FMsg), MaxBufferSize);
471			Move(TraceObject.FMsg[1], FBuffer^, FBufferSize^);
472			end;
473
474			procedure TGlobalInterface.ReceiveTrace(TraceObject: TTraceObject);
475			begin
476			SetString(TraceObject.FMsg, FBuffer, FBufferSize^);
477			TraceObject.FDataType := TTraceFlag(FTraceDataType^);
478			TraceObject.FTimeStamp := TDateTime(FTimeStamp^);
479			end;
480
481
482