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 |
|
|
|