ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/sv5ipc.inc
Revision: 320
Committed: Thu Feb 25 12:07:54 2021 UTC (3 years, 8 months ago) by tony
File size: 21566 byte(s)
Log Message:
ipc tidy up

File Contents

# User Rev Content
1 tony 319 {Used by IBIPC and implements System V IPC}
2 tony 209
3 tony 319 uses IBMessages, ipc, Errors, baseunix;
4    
5 tony 209 const
6     IPCFileName: string = 'FB.SQL.MONITOR1_0';
7     cNumberOfSemaphores = 10;
8     cMutexSemaphore = 0;
9     cMonitorCounter = 1;
10     cReadReadyEventSemaphore = 2;
11     cReadFinishedEventSemaphore = 4;
12     cDataAvailableEventSemaphore = 6;
13     cWriterBusyEventSemaphore = 8;
14 tony 320 cDefaultTimeout = 10; {seconds }
15 tony 209
16     {$IF FPC_FULLVERSION = 30000 }
17     {Fix regression in FPC 3.0.0 ipc.pp unit. Expected to be fixed in fpc 3.0.2}
18     {$IF defined(darwin) }
19     SEM_GETNCNT = 3; { Return the value of sempid (READ) }
20     SEM_GETPID = 4; { Return the value of semval (READ) }
21     SEM_GETVAL = 5; { Return semvals into arg.array (READ) }
22     SEM_GETALL = 6; { Return the value of semzcnt (READ) }
23     SEM_GETZCNT = 7; { Set the value of semval to arg.val (ALTER) }
24     SEM_SETVAL = 8; { Set semvals from arg.array (ALTER) }
25     SEM_SETALL = 9;
26     {$ENDIF}
27     {$ENDIF}
28    
29     function GetLastErrno: cint;
30     begin
31     Result := fpgetErrno
32     end;
33    
34     type
35     {Interprocess Communication Objects. All platform dependent IPC is abstracted
36     into this set of objects }
37    
38     { TIpcCommon }
39    
40 tony 319 TIpcCommon = class(TInterfacedObject)
41     protected
42 tony 320 class var FSemaphoreSetID: cint; {Initialised by TSharedMemory. Used by other classes}
43 tony 209 function sem_op(SemNum, op: integer; flags: cshort = 0): cint;
44     function sem_timedop(SemNum, op: integer; timeout_secs: integer; flags: cshort = 0): cint;
45     function GetSemValue(SemNum: integer): cint;
46     procedure SemInit(SemNum, AValue: cint);
47     public
48 tony 319 function GetSa: PSecurityAttributes;
49 tony 209 property Sa : PSecurityAttributes read GetSa;
50     end;
51    
52     { TSharedMemory }
53    
54     {
55     The shared memory segment is used for interprocess communication and
56     holds both a message buffer and a number of shared variables. Shared
57     memory is allocated to each shared variable using the Allocate function.
58     An underlying assumption is that each process using the shared memory
59     calls "Allocate" in the same order and for the same memory sizes.
60    
61     Linux:
62    
63     The Linux implementation uses Linux shared memory. IPC_PRIVATE is used
64     to allocate the memory and the resulting memory id is written to a
65     well known file. By default this is in the current user's home directory,
66     but this can be over-ridden to specify a globally unique filename.
67    
68     Access to the shared memory is restricted to the current user/group.
69     Note that the Linux semaphore set is also created with the shared memory.
70     }
71    
72 tony 320 ISharedMemoryExt = interface(ISharedMemory)
73     ['{7449e122-61c0-4ea9-acf4-f0a420af14aa}']
74     function IsInitialiser: boolean;
75     end;
76    
77 tony 319 TSharedMemory = class(TIpcCommon,ISharedMemory)
78 tony 209 private
79 tony 320 FSharedMemoryID: cint;
80 tony 319 FBuffer: PByte;
81 tony 209 FLastAllocationSize: integer;
82     FUnused: integer;
83 tony 319 FBufptr: PByte;
84     FIPCFileName: AnsiString;
85 tony 320 FInitialiser: boolean;
86 tony 209 procedure DropSharedMemory;
87     procedure GetSharedMemory(MemSize: integer);
88     public
89     constructor Create(MemSize: integer);
90     destructor Destroy; override;
91 tony 319 function Allocate(Size: integer): PByte;
92     function GetLastAllocationSize: integer;
93 tony 320 function IsInitialiser: boolean;
94 tony 319 property LastAllocationSize: integer read GetLastAllocationSize;
95 tony 209 end;
96    
97     {TMutex}
98    
99 tony 319 TMutex = class(TIpcCommon,IMutex)
100 tony 209 private
101     FMutexSemaphore: cint;
102     FLockCount: integer;
103     public
104 tony 320 constructor Create(SemNumber: cint; IsInitialiser: boolean);
105 tony 209 procedure Lock;
106     procedure Unlock;
107     end;
108    
109     { TSingleLockGate }
110    
111     {
112     A single lock gate is either open or closed. When open, any thread can pass
113     through it while, when closed, all threads are blocked as they try to pass
114     through the gate. When the gate is opened, all blocked threads are resumed.
115    
116     There is an implementation assumption that only one writer thread at
117     a time (i.e. the thread which locks or unlocks the gate) can have access to
118     it at any one time. I.e. an external Mutex prevents race conditions.
119    
120     Linux:
121    
122     In the Linux implementation, the gate is implemented by a semaphore
123     and a share memory integer used as a bi-state variable. When the gate
124     is open, the bi-state variable is non-zero. It is set to zero when closed.
125     Another shared memory integer is used to count the number of waiting
126     threads, and a second semaphore is used to protect access to this.
127    
128     The event semaphore is initialised to zero. When a thread passes through the gate
129     it checks the state. If open, the thread continues. If closed then it
130     increments the count of waiting threads and then decrements the semaphore
131     and hence enters an indefinite wait state.
132    
133     When the gate is locked, the state is set to zero. When unlocked, the state
134     is set to one and the semaphore incremented by the number of waiting threads,
135     which itself is then zeroed.
136    
137     Always initialised to the Unlocked state
138     }
139    
140 tony 319 TSingleLockGate = class(TIpcCommon,ISingleLockGate)
141 tony 209 private
142 tony 320 FSharedMemory: ISharedMemoryExt;
143 tony 209 FSemaphore: cint;
144     FMutex: cint;
145     FSignalledState: PInteger;
146     FWaitingThreads: PInteger;
147     function GetWaitingThreads: integer;
148     public
149 tony 320 constructor Create(SemNum: cint; sm: ISharedMemoryExt);
150 tony 209 property WaitingThreads: integer read GetWaitingThreads;
151     public
152     procedure PassthroughGate;
153     procedure Unlock;
154     procedure Lock;
155     end;
156    
157     { TMultilockGate }
158    
159     { This type of Gate is used where several reader threads must pass
160     through the gate before it can be opened for a writer thread.
161    
162     The reader threads register their interest by each locking the gate.
163     The writer thread then waits on the locked gate until all the reader
164     threads have separately unlocked the gate.
165    
166     There is an underlying assumption of a single writer. A Mutex must
167     be used to control access to the gate from the writer side if this
168     assumption is invalid.
169    
170     Linux:
171    
172     The Linux implementation uses a single semaphore to implement the gate,
173     which is initialised to 1 (unlocked), and a count of the number of
174     threads that have locked the gate (LockCount). A mutex semaphore
175     protects access to the LockCount. When the gate is locked, the lockcount
176     is incremented and, if the LockCount was originally zero, the semaphore is
177     set to zero (Gate Closed).
178    
179     Unlocking the gate, is the reverse. The LockCount is decremented and, if it
180     reaches zero, the semaphore is set to one (Gate Opened).
181    
182     When a writer passes through the gate, it checks the LockCount, if zero it
183     proceeds to pass through the gate. Otherwise it decrements and waits on the
184     semaphore. When the writer resumes, it increments the semaphore in order
185     to return it to its unlocked state. The wait is a timed wait, as there is
186     a risk that a reader thread may terminate while the gate is locked. If the
187     LockCount is non-zero, it is decremented and the writer returns to wait on
188     the gate.
189    
190     Always initialised to the Unlocked state
191     }
192    
193 tony 319 TMultilockGate = class(TIpcCommon,IMultiLockGate)
194 tony 209 private
195 tony 320 FSharedMemory: ISharedMemoryExt;
196 tony 209 FOnGateTimeout: TNotifyEvent;
197     FSemaphore: cint;
198     FMutex: cint;
199     FLockCount: PInteger;
200     function GetLockCount: integer;
201     public
202 tony 320 constructor Create(SemNum: cint; sm: ISharedMemoryExt);
203 tony 209 procedure Lock;
204     procedure Unlock;
205     procedure PassthroughGate;
206 tony 319 function GetOnGateTimeout: TNotifyEvent;
207     procedure SetOnGateTimeout(AValue: TNotifyEvent);
208 tony 209 property LockCount: integer read GetLockCount;
209 tony 319 property OnGateTimeout: TNotifyEvent read GetOnGateTimeout write SetOnGateTimeout;
210 tony 209 end;
211    
212 tony 319 { TIPCInterface }
213 tony 209
214 tony 319 TIPCInterface = class(TIpcCommon,IIPCInterface)
215 tony 209 private
216     FMaxBufferSize: integer;
217 tony 320 FSharedMemory: ISharedMemoryExt;
218 tony 319 FWriteLock: IMutex;
219     FBuffer: PByte;
220 tony 209 FTraceDataType,
221     FBufferSize: PInteger;
222     FTimeStamp: PDateTime;
223 tony 319 FMsgNumber: PInteger;
224     FReadReadyEvent: IMultiLockGate;
225     FReadFinishedEvent: IMultiLockGate;
226     FDataAvailableEvent: ISingleLockGate;
227     FWriterBusyEvent: ISingleLockGate;
228 tony 209 public
229     constructor Create;
230     procedure IncMonitorCount;
231     procedure DecMonitorCount;
232     procedure SendTrace(TraceObject: TTraceObject);
233     procedure ReceiveTrace(TraceObject: TTraceObject);
234 tony 319 function GetDataAvailableEvent: ISingleLockGate;
235     function GetWriterBusyEvent: ISingleLockGate;
236     function GetReadReadyEvent: IMultiLockGate;
237     function GetReadFinishedEvent: IMultiLockGate;
238     function GetWriteLock: IMutex;
239     function GetMonitorCount: integer;
240     function GetSharedMemory: ISharedMemory;
241     function GetMaxBufferSize: integer;
242     property DataAvailableEvent: ISingleLockGate read GetDataAvailableEvent;
243     property WriterBusyEvent: ISingleLockGate read GetWriterBusyEvent;
244     property ReadReadyEvent: IMultiLockGate read GetReadReadyEvent;
245     property ReadFinishedEvent: IMultiLockGate read GetReadFinishedEvent;
246     property WriteLock: IMutex read GetWriteLock;
247 tony 209 property MonitorCount: integer read GetMonitorCount;
248 tony 319 property SharedMemory: ISharedMemory read GetSharedMemory;
249     property MaxBufferSize: integer read GetMaxBufferSize;
250 tony 209 end;
251    
252     { TSharedMemory }
253    
254     procedure TSharedMemory.GetSharedMemory(MemSize: integer);
255     var F: cint;
256     begin
257 tony 319 if GetEnvironmentVariable('FBSQL_IPCFILENAME') <> '' then
258     FIPCFileName := GetEnvironmentVariable('FBSQL_IPCFILENAME')
259     else
260     FIPCFileName := GetTempDir(true) + IPCFileName + '.' + GetEnvironmentVariable('USER');
261    
262 tony 209 {Get the Shared Memory and Semaphore IDs from the Global File if it exists
263     or create them and the file otherwise }
264    
265     repeat
266 tony 319 F := fpOpen(FIPCFileName, O_WrOnly or O_Creat or O_Excl);
267 tony 209 if F < 0 then
268     begin
269     if fpgetErrno = ESysEEXIST {EEXIST} then
270     begin
271     { looks like it already exists}
272     Sleep(100);
273 tony 319 F := fpOpen(FIPCFileName,O_RdOnly);
274 tony 209 if (F < 0) and (fpgetErrno = ESysENOENT {ENOENT}) then
275     {probably just got deleted }
276     else
277     if F < 0 then
278     IBError(ibxeCannotCreateSharedResource,['Error accessing IPC File - ' +
279     StrError(fpgetErrno)]);
280     end
281     else
282     IBError(ibxeCannotCreateSharedResource,['Error creating IPC File - ' +
283     StrError(fpgetErrno)]);
284     end
285     else
286     FInitialiser := true
287     until F >= 0;
288    
289     if FInitialiser then
290     begin
291     FSharedMemoryID := shmget(IPC_PRIVATE,MemSize, IPC_CREAT or
292     S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP);
293     if FSharedMemoryID < 0 then
294     IBError(ibxeCannotCreateSharedResource,['Cannot create shared memory segment - ' +
295     StrError(fpgetErrno)]);
296    
297     FSemaphoreSetID := semget(IPC_PRIVATE, cNumberOfSemaphores,IPC_CREAT or
298     S_IRUSR or S_IWUSR or S_IRGRP or S_IWGRP);
299     if FSemaphoreSetID < 0 then
300     IBError(ibxeCannotCreateSharedResource,['Cannot create shared semaphore set - ' +
301     StrError(fpgetErrno)]);
302    
303     fpWrite(F,FSharedMemoryID,sizeof(FSharedMemoryID));
304     fpWrite(F,FSemaphoreSetID,sizeof(FSemaphoreSetID));
305     end
306     else
307     begin
308     fpRead(F,FSharedMemoryID,sizeof(FSharedMemoryID));
309     fpRead(F,FSemaphoreSetID,sizeof(FSemaphoreSetID));
310     if GetSemValue(cMonitorCounter) = 0 then
311     begin
312     FInitialiser := true;
313     //writeln('Opened file and is initialiser');
314     end
315     end;
316     fpClose(F);
317     end;
318    
319     procedure TSharedMemory.DropSharedMemory;
320     var ds: TShmid_ds;
321     arg: tsemun;
322     begin
323     if shmctl(FSharedMemoryID,IPC_STAT,@ds) < 0 then
324     IBError(ibxeSV5APIError,['Error getting shared memory info' + strError(fpgetErrno)]);
325     if ds.shm_nattch = 0 then { we are the last one out - so, turn off the lights }
326     begin
327     shmctl(FSharedMemoryID,IPC_RMID,nil);
328     semctl(FSemaphoreSetID,0,IPC_RMID,arg);
329 tony 319 DeleteFile(FIPCFileName);
330 tony 209 end;
331     end;
332    
333     constructor TSharedMemory.Create(MemSize: integer);
334     begin
335     inherited Create;
336     FInitialiser := false;
337     GetSharedMemory(MemSize);
338     FBuffer := shmat(FSharedMemoryID,nil,0);
339     if PtrInt(FBuffer) = -1 then
340     IBError(ibxeCannotCreateSharedResource,[StrError(Errno)]);
341     FBufPtr := FBuffer;
342     FUnused := MemSize
343     end;
344    
345     destructor TSharedMemory.Destroy;
346     begin
347     shmdt(FBuffer);
348     DropSharedMemory;
349     inherited Destroy;
350     end;
351    
352 tony 319 function TSharedMemory.Allocate(Size: integer): PByte;
353 tony 209 begin
354     if Size > FUnused then
355     IBError(ibxeCannotCreateSharedResource, ['Not enough shared memory']);
356     Result := FBufPtr;
357    
358     if Size = 0 then
359     begin
360     FLastAllocationSize := FUnused;
361     FUnused := 0
362     end
363     else
364     begin
365     FLastAllocationSize := Size;
366     Dec(FUnused,Size);
367     end;
368     Inc(FBufPtr,Size)
369     end;
370    
371 tony 319 function TSharedMemory.GetLastAllocationSize: integer;
372     begin
373     Result := FLastAllocationSize;
374     end;
375    
376 tony 320 function TSharedMemory.IsInitialiser: boolean;
377     begin
378     Result := FInitialiser;
379     end;
380    
381 tony 209 { TIpcCommon }
382    
383     function TIpcCommon.GetSa: PSecurityAttributes;
384     begin
385     Result := nil
386     end;
387    
388     function TIpcCommon.sem_op(SemNum, op: integer; flags: cshort): cint;
389     var sembuf: TSEMbuf;
390     begin
391     sembuf.sem_num := SemNum;
392     sembuf.sem_op:= op;
393     sembuf.sem_flg := flags or SEM_UNDO;
394     Result := semop(FSemaphoreSetID,@sembuf,1);
395     end;
396    
397     function TIpcCommon.sem_timedop(SemNum, op: integer; timeout_secs: integer;
398     flags: cshort): cint;
399     var sembuf: TSEMbuf;
400     timeout: TimeSpec;
401     begin
402     sembuf.sem_num := SemNum;
403     sembuf.sem_op:= op;
404     sembuf.sem_flg := flags or SEM_UNDO;
405     timeout.tv_sec := timeout_secs;
406     timeout.tv_nsec := 0;
407 tony 319 {$IF declared(semtimedop)}
408 tony 209 Result := semtimedop(FSemaphoreSetID,@sembuf,1,@timeout);
409     {$ELSE}
410     Result := semop(FSemaphoreSetID,@sembuf,1); {May hang on race condition}
411 tony 319 {$IFEND}
412 tony 209 end;
413    
414     function TIpcCommon.GetSemValue(SemNum: integer): cint;
415     var args :TSEMun;
416     begin
417     Result := semctl(FSemaphoreSetID,SemNum,SEM_GETVAL,args);
418     if Result < 0 then
419     IBError(ibxeSV5APIError,['GetSemValue: '+strError(GetLastErrno)]);
420     end;
421    
422     procedure TIpcCommon.SemInit(SemNum, AValue: cint);
423     var args :TSEMun;
424     begin
425     //writeln('Initialising ',SemNum,' to ',AValue);
426     args.val := AValue;
427     if semctl(FSemaphoreSetID,SemNum,SEM_SETVAL,args) < 0 then
428     IBError(ibxeCannotCreateSharedResource,['Unable to initialise Semaphone ' +
429     IntToStr(SemNum) + '- ' + StrError(GetLastErrno)]);
430    
431     end;
432    
433     { TMutex }
434    
435 tony 320 constructor TMutex.Create(SemNumber: cint; IsInitialiser: boolean);
436 tony 209 begin
437     inherited Create;
438     FMutexSemaphore := SemNumber;
439 tony 320 if IsInitialiser then
440 tony 209 SemInit(FMutexSemaphore,1)
441     end;
442    
443     { Obtain ownership of the Mutex and prevent other threads from accessing protected resource }
444    
445     procedure TMutex.Lock;
446     begin
447     //writeln('Lock: Entering Mutex ',FMutexSemaphore,' LockCount=',FLockCount,' State = ',GetSemValue(FMutexSemaphore));
448     if FLockCount = 0 then
449     sem_op(FMutexSemaphore,-1);
450     Inc(FLockCount);
451     //writeln('Lock: Mutex Exit');
452     end;
453    
454     {Give up ownership of the Mutex and allow other threads access }
455    
456     procedure TMutex.Unlock;
457     begin
458     //writeln('UnLock: Entering Mutex, LockCount=',FLockCount);
459     if FLockCount = 0 then Exit;
460     Dec(FLockCount);
461     if FLockCount = 0 then
462     sem_op(FMutexSemaphore,1);
463     //writeln('UnLock: Mutex Exit',' State = ',GetSemValue(FMutexSemaphore));
464     end;
465    
466     { TSingleLockGate }
467    
468     function TSingleLockGate.GetWaitingThreads: integer;
469     begin
470     Result := FWaitingThreads^
471     end;
472    
473 tony 320 constructor TSingleLockGate.Create(SemNum: cint; sm: ISharedMemoryExt);
474 tony 209 begin
475     inherited Create;
476 tony 319 FSharedMemory := sm;
477     FSignalledState := PInteger(FSharedMemory.Allocate(sizeof(FSignalledState)));
478     FWaitingThreads := PInteger(FSharedMemory.Allocate(sizeof(FWaitingThreads)));
479 tony 209 FSemaphore := SemNum;
480     FMutex := SemNum + 1;
481 tony 320 if FSharedMemory.IsInitialiser then
482 tony 209 begin
483     FSignalledState^ := 1;
484     FWaitingThreads^ := 0;
485     SemInit(FSemaphore,0);
486     SemInit(FMutex,1);
487     end;
488     end;
489    
490     procedure TSingleLockGate.PassthroughGate;
491     begin
492     if FSignalledState^ = 0 then
493     begin
494     sem_op(FMutex,-1,0); //Acquire Mutex
495     Inc(FWaitingThreads^);
496     sem_op(FMutex,1,0); //Release Mutex
497     //writeln(ClassName + ': Wait State Entered ',FSemaphore,' = ',GetSemValue(FSemaphore));
498     sem_op(FSemaphore,-1,0); //Enter Wait
499     //writeln(ClassName + ': Wait State Ends ',FSemaphore);
500     end;
501     end;
502    
503     procedure TSingleLockGate.Unlock;
504     begin
505     if FSignalledState^ = 0 then
506     begin
507     FSignalledState^ := 1;
508     sem_op(FMutex,-1,0); //Acquire Mutex
509 tony 319 {$IFDEF DEBUG}writeln(ClassName + ': Unlocking' ,FSemaphore);{$ENDIF}
510 tony 209 sem_op(FSemaphore,FWaitingThreads^,0);
511     FWaitingThreads^ := 0;
512     sem_op(FMutex,1,0); //Release Mutex
513     end;
514     end;
515    
516     procedure TSingleLockGate.Lock;
517     begin
518     if FSignalledState^ = 1 then
519     begin
520 tony 319 {$IFDEF DEBUG}writeln(ClassName + ': Locking Gate ',FSemaphore);{$ENDIF}
521 tony 209 SemInit(FSemaphore,0);
522     FSignalledState^ := 0;
523     end;
524     end;
525    
526     { TMultilockGate }
527    
528 tony 320 constructor TMultilockGate.Create(SemNum: cint; sm: ISharedMemoryExt);
529 tony 209 begin
530     inherited Create;
531     FSemaphore := SemNum;
532     FMutex := SemNum + 1;
533 tony 319 FSharedMemory := sm;
534     FLockCount := PInteger(FSharedMemory.Allocate(sizeof(FLockCount)));
535 tony 320 if FSharedMemory.IsInitialiser then
536 tony 209 begin
537     FLockCount^ := 0;
538     SemInit(FSemaphore,1);
539     SemInit(FMutex,1);
540     end;
541     end;
542    
543     function TMultilockGate.GetLockCount: integer;
544     begin
545     Result := FLockCount^
546     end;
547    
548 tony 319 function TMultilockGate.GetOnGateTimeout: TNotifyEvent;
549     begin
550     Result := FOnGateTimeout;
551     end;
552    
553     procedure TMultilockGate.SetOnGateTimeout(AValue: TNotifyEvent);
554     begin
555     FOnGateTimeout := AValue;
556     end;
557    
558 tony 209 procedure TMultilockGate.Lock;
559     begin
560     sem_op(FMutex,-1,0); //Acquire Mutex
561     if FLockCount^ = 0 then
562     begin
563 tony 319 {$IFDEF DEBUG}writeln(ClassName,': Locking ',FSemaphore);{$ENDIF}
564 tony 209 SemInit(FSemaphore,0);
565     end;
566     Inc(FLockCount^);
567     sem_op(FMutex,1,0); //Release Mutex
568     end;
569    
570     procedure TMultilockGate.Unlock;
571     begin
572     sem_op(FMutex,-1,0); //Acquire Mutex
573     Dec(FLockCount^);
574     if FLockCount^ <= 0 then
575     begin
576 tony 319 {$IFDEF DEBUG}writeln(ClassName,': UnLocking ',FSemaphore);{$ENDIF}
577 tony 209 SemInit(FSemaphore,1);
578     FLockCount^ := 0
579     end;
580     sem_op(FMutex,1,0); //Release Mutex
581     end;
582    
583     procedure TMultilockGate.PassthroughGate;
584     begin
585     if FLockCount^ = 0 then
586     Exit;
587 tony 319 {$IFDEF DEBUG}writeln(ClassName,': Waiting on ',FSemaphore);{$ENDIF}
588 tony 209 while sem_timedop(FSemaphore,-1,cDefaultTimeout) < 0 do
589     {looks like we lost a reader}
590     begin
591 tony 319 {$IFDEF DEBUG}writeln(ClassName,': reader lost timeout');{$ENDIF}
592 tony 209 if FLockCount^ > 0 then
593     begin
594     UnLock;
595     if assigned(FOnGateTimeout) then
596     OnGateTimeout(self)
597     end
598     end;
599     sem_op(FSemaphore,1);
600 tony 319 {$IFDEF DEBUG}writeln(ClassName,': Wait done on ',FSemaphore);{$ENDIF}
601 tony 209 end;
602    
603    
604 tony 319 { TIPCInterface }
605 tony 209
606 tony 319 function TIPCInterface.GetMonitorCount: integer;
607 tony 209 begin
608     Result := GetSemValue(cMonitorCounter)
609     end;
610    
611 tony 319 function TIPCInterface.GetSharedMemory: ISharedMemory;
612 tony 209 begin
613 tony 319 Result := FSharedMemory;
614     end;
615    
616     function TIPCInterface.GetMaxBufferSize: integer;
617     begin
618     Result := FMaxBufferSize;
619     end;
620    
621     constructor TIPCInterface.Create;
622     begin
623 tony 209 inherited Create;
624     FSharedMemory := TSharedMemory.Create(cMonitorHookSize);
625    
626 tony 320 FWriteLock := TMutex.Create(cMutexSemaphore,FSharedMemory.IsInitialiser);
627 tony 209
628 tony 319 FDataAvailableEvent := TSingleLockGate.Create(cDataAvailableEventSemaphore,FSharedMemory);
629     FWriterBusyEvent := TSingleLockGate.Create(cWriterBusyEventSemaphore,FSharedMemory);
630     FReadReadyEvent := TMultiLockGate.Create(cReadReadyEventSemaphore,FSharedMemory);
631     FReadFinishedEvent := TMultiLockGate.Create(cReadFinishedEventSemaphore,FSharedMemory);
632 tony 209
633 tony 320 if FSharedMemory.IsInitialiser then
634 tony 209 SemInit(cMonitorCounter,0);
635     FTraceDataType := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
636     FTimeStamp := PDateTime(FSharedMemory.Allocate(sizeof(TDateTime)));
637     FBufferSize := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
638 tony 319 FMsgNumber := PInteger(FSharedMemory.Allocate(sizeof(Integer)));
639 tony 209 FBuffer := FSharedMemory.Allocate(0); //All remaining
640     FMaxBufferSize := FSharedMemory.LastAllocationSize;
641    
642 tony 320 if FSharedMemory.IsInitialiser then
643 tony 209 begin
644     FBufferSize^ := 0;
645 tony 319 FDataAvailableEvent.Lock;
646     FMsgNumber^ := 0;
647 tony 209 end;
648     end;
649    
650 tony 319 procedure TIPCInterface.IncMonitorCount;
651 tony 209 begin
652     sem_op(cMonitorCounter,1);
653     end;
654    
655 tony 319 procedure TIPCInterface.DecMonitorCount;
656 tony 209 begin
657     sem_op(cMonitorCounter,-1,IPC_NOWAIT);
658     end;
659    
660 tony 319 procedure TIPCInterface.SendTrace(TraceObject: TTraceObject);
661 tony 209 begin
662     FTraceDataType^ := Integer(TraceObject.FDataType);
663     FTimeStamp^ := TraceObject.FTimeStamp;
664 tony 319 if Length(TraceObject.FMsg) > MaxBufferSize then
665     FBufferSize^ := MaxBufferSize
666     else
667     FBufferSize^ := Length(TraceObject.FMsg);
668     FMsgNumber^ := TraceObject.FMsgNumber;
669 tony 209 Move(TraceObject.FMsg[1], FBuffer^, FBufferSize^);
670     end;
671    
672 tony 319 procedure TIPCInterface.ReceiveTrace(TraceObject: TTraceObject);
673 tony 209 begin
674 tony 319 SetString(TraceObject.FMsg, PAnsiChar(FBuffer), FBufferSize^);
675 tony 209 TraceObject.FDataType := TTraceFlag(FTraceDataType^);
676     TraceObject.FTimeStamp := TDateTime(FTimeStamp^);
677 tony 319 TraceObject.FMsgNumber := FMsgNumber^;
678 tony 209 end;
679    
680 tony 319 function TIPCInterface.GetDataAvailableEvent: ISingleLockGate;
681     begin
682     Result := FDataAvailableEvent;
683     end;
684 tony 209
685 tony 319 function TIPCInterface.GetWriterBusyEvent: ISingleLockGate;
686     begin
687     Result := FWriterBusyEvent;
688     end;
689 tony 209
690 tony 319 function TIPCInterface.GetReadReadyEvent: IMultiLockGate;
691     begin
692     Result := FReadReadyEvent;
693     end;
694    
695     function TIPCInterface.GetReadFinishedEvent: IMultiLockGate;
696     begin
697     Result := FReadFinishedEvent;
698     end;
699    
700     function TIPCInterface.GetWriteLock: IMutex;
701     begin
702     Result := FWriteLock;
703     end;
704    
705    
706