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 (8 years, 9 months ago) by tony
File size:	13237 byte(s)
Log Message:	Committing updates for Release R1-3-1
#	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	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