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 = 10000; {milli seconds }

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

  { TIpcCommon }

  TIpcCommon = class(TInterfacedObject)
  protected
    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.

  }

  ISharedMemoryExt = interface(ISharedMemory)
  ['{7449e122-61c0-4ea9-acf4-f0a420af14aa}']
  function IsInitialiser: boolean;
  end;

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

  {TMutex}

  TMutex = class(TIpcCommon, IMutex)
  private
    FMutex: THandle;
  public
    constructor Create(MutexName: string; IsInitialiser: boolean);
    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; IsInitialiser: boolean);
    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: ISharedMemoryExt;
    FOnGateTimeout: TNotifyEvent;
    FEvent: THandle;
    FLockCount: PInteger;
    FMutex: TMutex;
  public
    constructor Create(EventName: string; sm: ISharedMemoryExt);
    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: ISharedMemoryExt;
    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;

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