runtime/nongui/winipc.inc

{Used by IBIPC and implements System V IPC}

uses IBMessages;

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

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

  { TIpcCommon }

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

  { TSharedMemory }

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

    Windows:

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

  }

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

  {TMutex}

  TMutex = class(TIpcCommon, IMutex)
  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,ISingleLockGate)
  private
    FEvent: THandle;
  public
    constructor Create(EventName: string);
    destructor Destroy; override;
    procedure PassthroughGate;
    procedure Unlock;
    procedure Lock;
  end;

  { TMultilockGate }

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

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

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

    Windows:

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

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

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

    Always initialised to the Unlocked state
  }

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

  { TIPCInterface }

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

{ TSharedMemory }

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

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

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

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

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

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

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

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

{ 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);
begin
  inherited Create;
  if FInitialiser then
    FEvent := CreateEvent(sa, true, true, PAnsiChar(EventName))
  else
    FEvent := OpenEvent(EVENT_ALL_ACCESS, true, PAnsiChar(EventName));

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

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


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

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

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

{ TMultilockGate }

constructor TMultilockGate.Create(EventName: string; sm: ISharedMemory);
begin
  inherited Create;
  FSharedMemory := sm;
  FLockCount := PInteger(FSharedMemory.Allocate(sizeof(FLockCount)));
  FMutex := TMutex.Create(EventName + '.Mutex');
  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;

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

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

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

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

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


{ TIPCInterface }

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

function TIPCInterface.GetSharedMemory: ISharedMemory;
begin
  Result := FSharedMemory;
end;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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