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.

  }

  ISharedMemory = interface
  ['{db77bdd4-233a-4c9c-9212-dd7945e2e57c}']
  function IsInitialiser: boolean;
  function Allocate(Size: integer): PByte;
  function GetLastAllocationSize: integer;
  property LastAllocationSize: integer read GetLastAllocationSize;
  end;


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