ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/trunk/runtime/sv5ipc.inc

Comparing ibx/trunk/runtime/sv5ipc.inc (file contents):
Revision 17 by tony, Sat Dec 28 19:22:24 2013 UTC vs.
Revision 39 by tony, Tue May 17 08:14:52 2016 UTC

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

Diff Legend

–	Removed lines
+	Added lines
<	Changed lines
>	Changed lines