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
#	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	320	cDefaultTimeout = 10000; {milli 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			FSa : TSecurityAttributes;
25			private
26			Sd : TSecurityDescriptor;
27			public
28			constructor Create;
29	tony	319	function GetSa: PSecurityAttributes;
30	tony	209	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	tony	320	ISharedMemoryExt = interface(ISharedMemory)
52			['{7449e122-61c0-4ea9-acf4-f0a420af14aa}']
53			function IsInitialiser: boolean;
54			end;
55
56			TSharedMemory = class(TIpcCommon,ISharedMemoryExt)
57	tony	209	private
58	tony	319	FBuffer: PByte;
59	tony	209	FLastAllocationSize: integer;
60			FUnused: integer;
61	tony	319	FBufptr: PByte;
62	tony	209	FSharedBuffer: THandle;
63	tony	320	FInitialiser: boolean;
64	tony	209	procedure GetSharedMemory(MemSize: integer);
65			public
66			constructor Create(MemSize: integer);
67			destructor Destroy; override;
68	tony	319	function Allocate(Size: integer): PByte;
69			function GetLastAllocationSize: integer;
70	tony	320	function IsInitialiser: boolean;
71	tony	319	property LastAllocationSize: integer read GetLastAllocationSize;
72	tony	209	end;
73
74			{TMutex}
75
76	tony	319	TMutex = class(TIpcCommon, IMutex)
77	tony	209	private
78			FMutex: THandle;
79			public
80	tony	320	constructor Create(MutexName: string; IsInitialiser: boolean);
81	tony	209	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	tony	319	TSingleLockGate = class(TIpcCommon,ISingleLockGate)
108	tony	209	private
109			FEvent: THandle;
110			public
111	tony	320	constructor Create(EventName: string; IsInitialiser: boolean);
112	tony	209	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	tony	319	TMultilockGate = class(TIpcCommon, IMultilockGate)
148	tony	209	private
149	tony	320	FSharedMemory: ISharedMemoryExt;
150	tony	209	FOnGateTimeout: TNotifyEvent;
151			FEvent: THandle;
152			FLockCount: PInteger;
153			FMutex: TMutex;
154			public
155	tony	320	constructor Create(EventName: string; sm: ISharedMemoryExt);
156	tony	209	destructor Destroy; override;
157			procedure Lock;
158			procedure Unlock;
159			procedure PassthroughGate;
160	tony	319	function GetLockCount: integer;
161			function GetOnGateTimeout: TNotifyEvent;
162			procedure SetOnGateTimeout(aValue: TNotifyEvent);
163	tony	209	property LockCount: integer read GetLockCount;
164	tony	319	property OnGateTimeout: TNotifyEvent read GetOnGateTimeout write SetOnGateTimeout;
165	tony	209	end;
166
167	tony	319	{ TIPCInterface }
168	tony	209
169	tony	319	TIPCInterface = class(TIpcCommon, IIPCInterface)
170	tony	209	private
171			FMaxBufferSize: integer;
172	tony	320	FSharedMemory: ISharedMemoryExt;
173	tony	319	FWriteLock: IMutex;
174			FBuffer: PByte;
175	tony	209	FTraceDataType,
176			FBufferSize: PInteger;
177			FTimeStamp: PDateTime;
178	tony	319	FMsgNumber: PInteger;
179			FReadReadyEvent: IMultiLockGate;
180			FReadFinishedEvent: IMultiLockGate;
181			FDataAvailableEvent: ISingleLockGate;
182			FWriterBusyEvent: ISingleLockGate;
183	tony	209	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	tony	319	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	tony	209	property MonitorCount: integer read GetMonitorCount;
205	tony	319	property SharedMemory: ISharedMemory read GetSharedMemory;
206			property MaxBufferSize: integer read GetMaxBufferSize;
207	tony	209	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	tony	319	function TSharedMemory.Allocate(Size: integer): PByte;
245	tony	209	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	tony	319	function TSharedMemory.GetLastAllocationSize: integer;
264			begin
265			Result := FLastAllocationSize;
266			end;
267
268	tony	320	function TSharedMemory.IsInitialiser: boolean;
269			begin
270			Result := FInitialiser;
271			end;
272
273	tony	209	{ 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	tony	320	constructor TMutex.Create(MutexName: string; IsInitialiser: boolean);
296	tony	209	begin
297			inherited Create;
298	tony	320	if IsInitialiser then
299	tony	209	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	tony	320	constructor TSingleLockGate.Create(EventName: string; IsInitialiser: boolean);
329	tony	209	begin
330			inherited Create;
331	tony	320	if IsInitialiser then
332	tony	319	FEvent := CreateEvent(sa, true, true, PAnsiChar(EventName))
333	tony	209	else
334	tony	319	FEvent := OpenEvent(EVENT_ALL_ACCESS, true, PAnsiChar(EventName));
335	tony	209
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	tony	320	constructor TMultilockGate.Create(EventName: string; sm: ISharedMemoryExt);
365	tony	209	begin
366			inherited Create;
367	tony	319	FSharedMemory := sm;
368			FLockCount := PInteger(FSharedMemory.Allocate(sizeof(FLockCount)));
369	tony	320	FMutex := TMutex.Create(EventName + '.Mutex',FSharedMemory.IsInitialiser);
370			if FSharedMemory.IsInitialiser then
371	tony	209	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	tony	319	function TMultilockGate.GetOnGateTimeout: TNotifyEvent;
395			begin
396			Result := FOnGateTimeout;
397			end;
398
399	tony	320	procedure TMultilockGate.SetOnGateTimeout(aValue: TNotifyEvent);
400	tony	319	begin
401			FOnGateTimeout := AValue;
402			end;
403
404	tony	209	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	tony	319	{ TIPCInterface }
451	tony	209
452	tony	319	function TIPCInterface.GetMonitorCount: integer;
453	tony	209	begin
454			Result := FMonitorCount^
455			end;
456
457	tony	319	function TIPCInterface.GetSharedMemory: ISharedMemory;
458	tony	209	begin
459	tony	319	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	tony	209	//writeln(ClassName+': Gate TimeOut');
470			DecMonitorCount
471			end;
472
473	tony	319	constructor TIPCInterface.Create;
474	tony	209	begin
475			inherited Create;
476			FSharedMemory := TSharedMemory.Create(cMonitorHookSize);
477
478	tony	320	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	tony	319	FReadReadyEvent := TMultiLockGate.Create(MonitorHookNames[4],FSharedMemory);
482	tony	209	FReadReadyEvent.OnGateTimeout := HandleGateTimeout;
483	tony	319	FReadFinishedEvent := TMultiLockGate.Create(MonitorHookNames[5],FSharedMemory);
484	tony	209	FReadFinishedEvent.OnGateTimeout := HandleGateTimeout;
485
486			FMonitorCount := PInteger(FSharedMemory.Allocate(sizeof(FMonitorCount)));
487
488	tony	320	if FSharedMemory.IsInitialiser then
489	tony	209	FMonitorCount^ := 0;
490			FTraceDataType := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
491			FTimeStamp := PDateTime(FSharedMemory.Allocate(sizeof(TDateTime)));
492			FBufferSize := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
493	tony	319	FMsgNumber := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
494	tony	209	FBuffer := FSharedMemory.Allocate(0); //All remaining
495			FMaxBufferSize := FSharedMemory.LastAllocationSize;
496
497	tony	320	if FSharedMemory.IsInitialiser then
498	tony	209	begin
499			FBufferSize^ := 0;
500	tony	319	FDataAvailableEvent.Lock;
501			FMsgNumber^ := 0;
502	tony	209	end;
503			end;
504
505	tony	319	procedure TIPCInterface.IncMonitorCount;
506	tony	209	begin
507			InterlockedIncrement(FMonitorCount^)
508			end;
509
510	tony	319	procedure TIPCInterface.DecMonitorCount;
511	tony	209	begin
512			InterlockedDecrement(FMonitorCount^)
513			end;
514
515	tony	319	procedure TIPCInterface.SendTrace(TraceObject: TTraceObject);
516	tony	209	begin
517			FTraceDataType^ := Integer(TraceObject.FDataType);
518			FTimeStamp^ := TraceObject.FTimeStamp;
519			FBufferSize^ := Min(Length(TraceObject.FMsg), MaxBufferSize);
520	tony	319	FMsgNumber^ := TraceObject.FMsgNumber;
521	tony	209	Move(TraceObject.FMsg[1], FBuffer^, FBufferSize^);
522			end;
523
524	tony	319	procedure TIPCInterface.ReceiveTrace(TraceObject: TTraceObject);
525	tony	209	begin
526	tony	319	SetString(TraceObject.FMsg, PAnsiChar(FBuffer), FBufferSize^);
527	tony	209	TraceObject.FDataType := TTraceFlag(FTraceDataType^);
528			TraceObject.FTimeStamp := TDateTime(FTimeStamp^);
529	tony	319	TraceObject.FMsgNumber := FMsgNumber^;
530	tony	209	end;
531
532	tony	319	function TIPCInterface.GetDataAvailableEvent: ISingleLockGate;
533			begin
534			Result := FDataAvailableEvent;
535			end;
536	tony	209
537	tony	319	function TIPCInterface.GetWriterBusyEvent: ISingleLockGate;
538			begin
539			Result := FWriterBusyEvent;
540			end;
541	tony	209
542	tony	319	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