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, 8 months ago) by tony
File size:	14644 byte(s)
Log Message:	Merge into public release
#	User	Rev	Content
1	tony	319	{Used by IBIPC and implements System V IPC}
2
3			uses IBMessages;
4
5	tony	209	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	tony	319	cDefaultTimeout = 1000; {seconds }
15	tony	209
16			type
17			{Interprocess Communication Objects. All platform dependent IPC is abstracted
18			into this set of objects }
19
20			{ TIpcCommon }
21
22	tony	319	TIpcCommon = class(TInterfacedObject)
23	tony	209	protected
24			class var FInitialiser: boolean;
25			FSa : TSecurityAttributes;
26			private
27			Sd : TSecurityDescriptor;
28			public
29			constructor Create;
30	tony	319	function GetSa: PSecurityAttributes;
31	tony	209	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	tony	319	TSharedMemory = class(TIpcCommon,ISharedMemory)
53	tony	209	private
54	tony	319	FBuffer: PByte;
55	tony	209	FLastAllocationSize: integer;
56			FUnused: integer;
57	tony	319	FBufptr: PByte;
58	tony	209	FSharedBuffer: THandle;
59			procedure GetSharedMemory(MemSize: integer);
60			public
61			constructor Create(MemSize: integer);
62			destructor Destroy; override;
63	tony	319	function Allocate(Size: integer): PByte;
64			function GetLastAllocationSize: integer;
65			property LastAllocationSize: integer read GetLastAllocationSize;
66	tony	209	end;
67
68			{TMutex}
69
70	tony	319	TMutex = class(TIpcCommon, IMutex)
71	tony	209	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	tony	319	TSingleLockGate = class(TIpcCommon,ISingleLockGate)
102	tony	209	private
103			FEvent: THandle;
104			public
105	tony	319	constructor Create(EventName: string);
106	tony	209	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	tony	319	TMultilockGate = class(TIpcCommon, IMultilockGate)
142	tony	209	private
143	tony	319	FSharedMemory: ISharedMemory;
144	tony	209	FOnGateTimeout: TNotifyEvent;
145			FEvent: THandle;
146			FLockCount: PInteger;
147			FMutex: TMutex;
148			public
149	tony	319	constructor Create(EventName: string; sm: ISharedMemory);
150	tony	209	destructor Destroy; override;
151			procedure Lock;
152			procedure Unlock;
153			procedure PassthroughGate;
154	tony	319	function GetLockCount: integer;
155			function GetOnGateTimeout: TNotifyEvent;
156			procedure SetOnGateTimeout(aValue: TNotifyEvent);
157	tony	209	property LockCount: integer read GetLockCount;
158	tony	319	property OnGateTimeout: TNotifyEvent read GetOnGateTimeout write SetOnGateTimeout;
159	tony	209	end;
160
161	tony	319	{ TIPCInterface }
162	tony	209
163	tony	319	TIPCInterface = class(TIpcCommon, IIPCInterface)
164	tony	209	private
165			FMaxBufferSize: integer;
166	tony	319	FSharedMemory: ISharedMemory;
167			FWriteLock: IMutex;
168			FBuffer: PByte;
169	tony	209	FTraceDataType,
170			FBufferSize: PInteger;
171			FTimeStamp: PDateTime;
172	tony	319	FMsgNumber: PInteger;
173			FReadReadyEvent: IMultiLockGate;
174			FReadFinishedEvent: IMultiLockGate;
175			FDataAvailableEvent: ISingleLockGate;
176			FWriterBusyEvent: ISingleLockGate;
177	tony	209	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	tony	319	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	tony	209	property MonitorCount: integer read GetMonitorCount;
199	tony	319	property SharedMemory: ISharedMemory read GetSharedMemory;
200			property MaxBufferSize: integer read GetMaxBufferSize;
201	tony	209	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	tony	319	function TSharedMemory.Allocate(Size: integer): PByte;
239	tony	209	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	tony	319	function TSharedMemory.GetLastAllocationSize: integer;
258			begin
259			Result := FLastAllocationSize;
260			end;
261
262	tony	209	{ 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	tony	319	constructor TSingleLockGate.Create(EventName: string);
318	tony	209	begin
319			inherited Create;
320			if FInitialiser then
321	tony	319	FEvent := CreateEvent(sa, true, true, PAnsiChar(EventName))
322	tony	209	else
323	tony	319	FEvent := OpenEvent(EVENT_ALL_ACCESS, true, PAnsiChar(EventName));
324	tony	209
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	tony	319	constructor TMultilockGate.Create(EventName: string; sm: ISharedMemory);
354	tony	209	begin
355			inherited Create;
356	tony	319	FSharedMemory := sm;
357			FLockCount := PInteger(FSharedMemory.Allocate(sizeof(FLockCount)));
358	tony	209	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	tony	319	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	tony	209	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	tony	319	{ TIPCInterface }
440	tony	209
441	tony	319	function TIPCInterface.GetMonitorCount: integer;
442	tony	209	begin
443			Result := FMonitorCount^
444			end;
445
446	tony	319	function TIPCInterface.GetSharedMemory: ISharedMemory;
447	tony	209	begin
448	tony	319	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	tony	209	//writeln(ClassName+': Gate TimeOut');
459			DecMonitorCount
460			end;
461
462	tony	319	constructor TIPCInterface.Create;
463	tony	209	begin
464			inherited Create;
465			FSharedMemory := TSharedMemory.Create(cMonitorHookSize);
466
467			FWriteLock := TMutex.Create(PChar(MonitorHookNames[0]));
468	tony	319	FDataAvailableEvent := TSingleLockGate.Create(MonitorHookNames[2]);
469			FWriterBusyEvent := TSingleLockGate.Create(MonitorHookNames[3]);
470			FReadReadyEvent := TMultiLockGate.Create(MonitorHookNames[4],FSharedMemory);
471	tony	209	FReadReadyEvent.OnGateTimeout := HandleGateTimeout;
472	tony	319	FReadFinishedEvent := TMultiLockGate.Create(MonitorHookNames[5],FSharedMemory);
473	tony	209	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	tony	319	FMsgNumber := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
483	tony	209	FBuffer := FSharedMemory.Allocate(0); //All remaining
484			FMaxBufferSize := FSharedMemory.LastAllocationSize;
485
486			if FInitialiser then
487			begin
488			FBufferSize^ := 0;
489	tony	319	FDataAvailableEvent.Lock;
490			FMsgNumber^ := 0;
491	tony	209	end;
492			end;
493
494	tony	319	procedure TIPCInterface.IncMonitorCount;
495	tony	209	begin
496			InterlockedIncrement(FMonitorCount^)
497			end;
498
499	tony	319	procedure TIPCInterface.DecMonitorCount;
500	tony	209	begin
501			InterlockedDecrement(FMonitorCount^)
502			end;
503
504	tony	319	procedure TIPCInterface.SendTrace(TraceObject: TTraceObject);
505	tony	209	begin
506			FTraceDataType^ := Integer(TraceObject.FDataType);
507			FTimeStamp^ := TraceObject.FTimeStamp;
508			FBufferSize^ := Min(Length(TraceObject.FMsg), MaxBufferSize);
509	tony	319	FMsgNumber^ := TraceObject.FMsgNumber;
510	tony	209	Move(TraceObject.FMsg[1], FBuffer^, FBufferSize^);
511			end;
512
513	tony	319	procedure TIPCInterface.ReceiveTrace(TraceObject: TTraceObject);
514	tony	209	begin
515	tony	319	SetString(TraceObject.FMsg, PAnsiChar(FBuffer), FBufferSize^);
516	tony	209	TraceObject.FDataType := TTraceFlag(FTraceDataType^);
517			TraceObject.FTimeStamp := TDateTime(FTimeStamp^);
518	tony	319	TraceObject.FMsgNumber := FMsgNumber^;
519	tony	209	end;
520
521	tony	319	function TIPCInterface.GetDataAvailableEvent: ISingleLockGate;
522			begin
523			Result := FDataAvailableEvent;
524			end;
525	tony	209
526	tony	319	function TIPCInterface.GetWriterBusyEvent: ISingleLockGate;
527			begin
528			Result := FWriterBusyEvent;
529			end;
530	tony	209
531	tony	319	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