ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/winipc.inc
(Generate patch)

Comparing ibx/trunk/runtime/winipc.inc (file contents):
Revision 17 by tony, Sat Dec 28 19:22:24 2013 UTC vs.
Revision 33 by tony, Sat Jul 18 12:30:52 2015 UTC

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

Diff Legend

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