ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/winipc.inc
Revision: 209
Committed: Wed Mar 14 12:48:51 2018 UTC (6 years ago) by tony
File size: 13442 byte(s)
Log Message:
Fixes Merged

File Contents

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