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

Comparing ibx/trunk/runtime/IBEvents.pas (file contents):
Revision 7 by tony, Sun Aug 5 18:28:19 2012 UTC vs.
Revision 17 by tony, Sat Dec 28 19:22:24 2013 UTC

# Line 1 | Line 1
1 < {************************************************************************}
2 < {                                                                        }
3 < {       Borland Delphi Visual Component Library                          }
4 < {       InterBase Express core components                                }
5 < {                                                                        }
6 < {       Copyright (c) 1998-2000 Inprise Corporation                      }
7 < {                                                                        }
8 < {    InterBase Express is based in part on the product                   }
9 < {    Free IB Components, written by Gregory H. Deatz for                 }
10 < {    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
11 < {    Free IB Components is used under license.                           }
12 < {                                                                        }
13 < {    The contents of this file are subject to the InterBase              }
14 < {    Public License Version 1.0 (the "License"); you may not             }
15 < {    use this file except in compliance with the License. You            }
16 < {    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17 < {    Software distributed under the License is distributed on            }
18 < {    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
19 < {    express or implied. See the License for the specific language       }
20 < {    governing rights and limitations under the License.                 }
21 < {    The Original Code was created by InterBase Software Corporation     }
22 < {       and its successors.                                              }
23 < {    Portions created by Inprise Corporation are Copyright (C) Inprise   }
24 < {       Corporation. All Rights Reserved.                                }
25 < {    Contributor(s): Jeff Overcash                                       }
26 < {                                                                        }
27 < {    IBX For Lazarus (Firebird Express)                                  }
28 < {    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29 < {    Portions created by MWA Software are copyright McCallum Whyman      }
30 < {    Associates Ltd 2011                                                 }
31 < {                                                                        }
32 < {************************************************************************}
33 <
34 < {
35 <  This unit has been almost completely re-written as the original code was
36 <  not that robust - and I am not even sure if it worked. The IBPP C++ implementation
37 <  was used for guidance and inspiration. A permanent thread is used to receive
38 <  events from the asynchronous event handler. This then uses "Synchronize" to
39 <  process the event in the main thread.
40 <
41 <  Note that an error will occur if the TIBEvent's Registered property is set to
42 <  true before the Database has been opened.
43 < }
44 <
45 < unit IBEvents;
46 <
47 < {$Mode Delphi}
48 <
49 < interface
50 <
51 < uses
52 < {$IFDEF WINDOWS }
53 <  Windows,
54 < {$ELSE}
55 <  unix,
56 < {$ENDIF}
57 <  Classes, Graphics, Controls,
58 <  Forms, Dialogs, IBHeader, IBExternals, IB, IBDatabase;
59 <
60 < const
61 <  MaxEvents = 15;
62 <
63 < type
64 <
65 <  TEventAlert = procedure( Sender: TObject; EventName: string; EventCount: longint;
66 <                           var CancelAlerts: Boolean) of object;
67 <
68 <  { TIBEvents }
69 <
70 <  TIBEvents = class(TComponent)
71 <  private
72 <    FIBLoaded: Boolean;
73 <    FBase: TIBBase;
74 <    FEvents: TStrings;
75 <    FOnEventAlert: TEventAlert;
76 <    FEventHandler: TObject;
77 <    FRegistered: boolean;
78 <    FDeferredRegister: boolean;
79 <    procedure EventChange(sender: TObject);
80 <    function GetDatabase: TIBDatabase;
81 <    function GetDatabaseHandle: TISC_DB_HANDLE;
82 <    procedure SetDatabase( value: TIBDatabase);
83 <    procedure ValidateDatabase( Database: TIBDatabase);
84 <    procedure DoBeforeDatabaseDisconnect(Sender: TObject);
85 <    procedure DoAfterDatabaseConnect(Sender: TObject);
86 <  protected
87 <    procedure Notification( AComponent: TComponent; Operation: TOperation); override;
88 <    procedure SetEvents( value: TStrings);
89 <    procedure SetRegistered( value: boolean);
90 <
91 <  public
92 <    constructor Create( AOwner: TComponent); override;
93 <    destructor Destroy; override;
94 <    procedure RegisterEvents;
95 <    procedure UnRegisterEvents;
96 <    property DatabaseHandle: TISC_DB_HANDLE read GetDatabaseHandle;
97 <    property DeferredRegister: boolean read FDeferredRegister write FDeferredRegister;
98 <  published
99 <    property Database: TIBDatabase read GetDatabase write SetDatabase;
100 <    property Events: TStrings read FEvents write SetEvents;
101 <    property Registered: Boolean read FRegistered write SetRegistered;
102 <    property OnEventAlert: TEventAlert read FOnEventAlert write FOnEventAlert;
103 <  end;
104 <
105 <
106 < implementation
107 <
108 < uses
109 <  IBIntf, syncobjs;
110 <
111 < type
112 <
113 <  TEventHandlerStates = (
114 <    stIdle,           {Events not monitored}
115 <    stHasEvb,         {Event Block Allocated but not queued}
116 <    stQueued,         {Waiting for Event}
117 <    stSignalled       {Event Callback signalled Event}
118 <   );
119 <
120 <  { TEventHandler }
121 <
122 <  TEventHandler = class(TThread)
123 <  private
124 <    FOwner: TIBEvents;
125 <    FCriticalSection: TCriticalSection;   {protects race conditions in stQueued state}
126 <    {$IFDEF WINDOWS}
127 <    {Make direct use of Windows API as TEventObject don't seem to work under
128 <     Windows!}
129 <    FEventHandler: THandle;
130 <    {$ELSE}
131 <    FEventWaiting: TEventObject;
132 <    {$ENDIF}
133 <    FState: TEventHandlerStates;
134 <    FEventBuffer: PChar;
135 <    FEventBufferLen: integer;
136 <    FEventID: ISC_LONG;
137 <    FRegisteredState: Boolean;
138 <    FResultBuffer: PChar;
139 <    FEvents: TStringList;
140 <    FSignalFired: boolean;
141 <    procedure QueueEvents;
142 <    procedure CancelEvents;
143 <    procedure HandleEventSignalled(length: short; updated: PChar);
144 <    procedure DoEventSignalled;
145 <  protected
146 <    procedure Execute; override;
147 <  public
148 <    constructor Create(Owner: TIBEvents);
149 <    destructor Destroy; override;
150 <    procedure Terminate;
151 <    procedure RegisterEvents(Events: TStrings);
152 <    procedure UnregisterEvents;
153 <  end;
154 <
155 < {This procedure is used for the event call back - note the cdecl }
156 <
157 < procedure IBEventCallback( ptr: pointer; length: short; updated: PChar); cdecl;
158 < begin
159 <  if (ptr = nil) or (length = 0) or (updated = nil) then
160 <    Exit;
161 <  { Handle events asynchronously in second thread }
162 <  TEventHandler(ptr).HandleEventSignalled(length,updated);
163 < end;
164 <
165 <
166 <
167 < { TEventHandler }
168 <
169 < procedure TEventHandler.QueueEvents;
170 < var
171 <  callback: pointer;
172 <  DBH: TISC_DB_HANDLE;
173 < begin
174 <  if FState <> stHasEvb then
175 <    Exit;
176 <  FCriticalSection.Enter;
177 <  try
178 <    callback := @IBEventCallback;
179 <    DBH := FOwner.DatabaseHandle;
180 <    if (isc_que_events( StatusVector, @DBH, @FEventID, FEventBufferLen,
181 <                     FEventBuffer, TISC_CALLBACK(callback), PVoid(Self)) <> 0) then
182 <      IBDatabaseError;
183 <    FState := stQueued
184 <  finally
185 <    FCriticalSection.Leave
186 <  end;
187 < end;
188 <
189 < procedure TEventHandler.CancelEvents;
190 < var
191 <  DBH: TISC_DB_HANDLE;
192 < begin
193 <  if FState in [stQueued,stSignalled] then
194 <  begin
195 <    FCriticalSection.Enter;
196 <    try
197 <      DBH := FOwner.DatabaseHandle;
198 <      if (isc_Cancel_events( StatusVector, @DBH, @FEventID) <> 0) then
199 <          IBDatabaseError;
200 <      FState := stHasEvb;
201 <    finally
202 <      FCriticalSection.Leave
203 <    end;
204 <  end;
205 <
206 <  if FState = stHasEvb then
207 <  begin
208 <    isc_free( FEventBuffer);
209 <    FEventBuffer := nil;
210 <    isc_free( FResultBuffer);
211 <    FResultBuffer := nil;
212 <    FState := stIdle
213 <  end;
214 <  FSignalFired := false
215 < end;
216 <
217 < procedure TEventHandler.HandleEventSignalled(length: short; updated: PChar);
218 < begin
219 <  FCriticalSection.Enter;
220 <  try
221 <    if FState <> stQueued then
222 <      Exit;
223 <    Move(Updated[0], FResultBuffer[0], Length);
224 <    FState := stSignalled;
225 <    {$IFDEF WINDOWS}
226 <    SetEVent(FEventHandler);
227 <    {$ELSE}
228 <    FEventWaiting.SetEvent;
229 <    {$ENDIF}
230 <  finally
231 <    FCriticalSection.Leave
232 <  end;
233 < end;
234 <
235 < procedure TEventHandler.DoEventSignalled;
236 < var
237 <  i: integer;
238 <  CancelAlerts: boolean;
239 <  Status: array[0..19] of ISC_LONG; {Note in 64 implementation the ibase.h implementation
240 <                                     is different from Interbase 6.0 API documentatoin}
241 < begin
242 <    if FState <> stSignalled then
243 <      Exit;
244 <    isc_event_counts( @Status, FEventBufferLen, FEventBuffer, FResultBuffer);
245 <    CancelAlerts := false;
246 <    if not FSignalFired then
247 <      FSignalFired := true   {Ignore first time}
248 <    else
249 <    if assigned(FOwner.FOnEventAlert)  then
250 <    begin
251 <      for i := 0 to FEvents.Count - 1 do
252 <      begin
253 <        try
254 <        if (Status[i] <> 0) and not CancelAlerts then
255 <            FOwner.FOnEventAlert( self, FEvents[i], Status[i], CancelAlerts);
256 <        except
257 <          Application.HandleException( nil);
258 <        end;
259 <      end;
260 <    end;
261 <    FState := stHasEvb;
262 <  if  CancelAlerts then
263 <      CancelEvents
264 <    else
265 <      QueueEvents
266 < end;
267 <
268 < procedure TEventHandler.Execute;
269 < begin
270 <  while not Terminated do
271 <  begin
272 <    {$IFDEF WINDOWS}
273 <    WaitForSingleObject(FEventHandler,INFINITE);
274 <    {$ELSE}
275 <    FEventWaiting.WaitFor(INFINITE);
276 <    {$ENDIF}
277 <
278 <    if not Terminated and (FState = stSignalled) then
279 <      Synchronize(DoEventSignalled)
280 <  end;
281 < end;
282 <
283 <
284 <
285 < constructor TEventHandler.Create(Owner: TIBEvents);
286 < var
287 <  PSa : PSecurityAttributes;
288 < {$IFDEF WINDOWS}
289 <  Sd : TSecurityDescriptor;
290 <  Sa : TSecurityAttributes;
291 < begin
292 <  InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
293 <  SetSecurityDescriptorDacl(@Sd,true,nil,false);
294 <  Sa.nLength := SizeOf(Sa);
295 <  Sa.lpSecurityDescriptor := @Sd;
296 <  Sa.bInheritHandle := true;
297 <  PSa := @Sa;
298 < {$ELSE}
299 < begin
300 <  PSa:= nil;
301 < {$ENDIF}
302 <  inherited Create(true);
303 <  FOwner := Owner;
304 <  FState := stIdle;
305 <  FCriticalSection := TCriticalSection.Create;
306 <  {$IFDEF WINDOWS}
307 <  FEventHandler := CreateEvent(PSa,false,true,nil);
308 <  {$ELSE}
309 <  FEventWaiting := TEventObject.Create(PSa,false,true,FOwner.Name+'.Events');
310 <  {$ENDIF}
311 <  FEvents := TStringList.Create;
312 <  FreeOnTerminate := true;
313 <  Resume
314 < end;
315 <
316 < destructor TEventHandler.Destroy;
317 < begin
318 <  if assigned(FCriticalSection) then FCriticalSection.Free;
319 <  {$IFDEF WINDOWS}
320 <  CloseHandle(FEventHandler);
321 <  {$ELSE}
322 <  if assigned(FEventWaiting) then FEventWaiting.Free;
323 <  {$ENDIF}
324 <  if assigned(FEvents) then FEvents.Free;
325 <  inherited Destroy;
326 < end;
327 <
328 < procedure TEventHandler.Terminate;
329 < begin
330 <  inherited Terminate;
331 <  {$IFDEF WINDOWS}
332 <  SetEvent(FEventHandler);
333 <  {$ELSE}
334 <  FEventWaiting.SetEvent;
335 <  {$ENDIF}
336 <  CancelEvents;
337 < end;
338 <
339 < procedure TEventHandler.RegisterEvents(Events: TStrings);
340 < var
341 <  i: integer;
342 <  EventNames: array of PChar;
343 < begin
344 <  UnregisterEvents;
345 <
346 <  if Events.Count = 0 then
347 <    exit;
348 <
349 <  setlength(EventNames,MaxEvents);
350 <  try
351 <    for i := 0 to Events.Count-1 do
352 <      EventNames[i] := PChar(Events[i]);
353 <    FEvents.Assign(Events);
354 <    FEventBufferlen := isc_event_block(@FEventBuffer,@FResultBuffer,
355 <                        Events.Count,
356 <                        EventNames[0],EventNames[1],EventNames[2],
357 <                        EventNames[3],EventNames[4],EventNames[5],
358 <                        EventNames[6],EventNames[7],EventNames[8],
359 <                        EventNames[9],EventNames[10],EventNames[11],
360 <                        EventNames[12],EventNames[13],EventNames[14]
361 <                        );
362 <    FState := stHasEvb;
363 <    FRegisteredState := true;
364 <    QueueEvents
365 <  finally
366 <    SetLength(EventNames,0)
367 <  end;
368 < end;
369 <
370 < procedure TEventHandler.UnregisterEvents;
371 < begin
372 <  if FRegisteredState then
373 <  begin
374 <    CancelEvents;
375 <    FRegisteredState := false;
376 <  end;
377 < end;
378 <
379 < { TIBEvents }
380 <
381 < procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
382 < begin
383 <  if not assigned( Database) then
384 <    IBError(ibxeDatabaseNameMissing, [nil]);
385 <  if not Database.Connected then
386 <    IBError(ibxeDatabaseClosed, [nil]);
387 < end;
388 <
389 < constructor TIBEvents.Create( AOwner: TComponent);
390 < begin
391 <  inherited Create( AOwner);
392 <  FIBLoaded := False;
393 <  CheckIBLoaded;
394 <  FIBLoaded := True;
395 <  FBase := TIBBase.Create(Self);
396 <  FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect;
397 <  FBase.AfterDatabaseConnect := DoAfterDatabaseConnect;
398 <  FEvents := TStringList.Create;
399 <  with TStringList( FEvents) do
400 <  begin
401 <    OnChange := EventChange;
402 <    Duplicates := dupIgnore;
403 <  end;
404 <  FEventHandler := TEventHandler.Create(self)
405 < end;
406 <
407 < destructor TIBEvents.Destroy;
408 < begin
409 <  if FIBLoaded then
410 <  begin
411 <    UnregisterEvents;
412 <    SetDatabase(nil);
413 <    TStringList(FEvents).OnChange := nil;
414 <    FBase.Free;
415 <    FEvents.Free;
416 <  end;
417 <  if assigned(FEventHandler) then
418 <    TEventHandler(FEventHandler).Terminate;
419 <  FEventHandler := nil;
420 <  inherited Destroy;
421 < end;
422 <
423 <
424 <
425 < procedure TIBEvents.EventChange( sender: TObject);
426 < begin
427 <  { check for blank event }
428 <  if TStringList(Events).IndexOf( '') <> -1 then
429 <    IBError(ibxeInvalidEvent, [nil]);
430 <  { check for too many events }
431 <  if Events.Count > MaxEvents then
432 <  begin
433 <    TStringList(Events).OnChange := nil;
434 <    Events.Delete( MaxEvents);
435 <    TStringList(Events).OnChange := EventChange;
436 <    IBError(ibxeMaximumEvents, [nil]);
437 <  end;
438 <  if Registered then
439 <    TEventHandler(FEventHandler).RegisterEvents(Events);
440 < end;
441 <
442 < procedure TIBEvents.Notification( AComponent: TComponent;
443 <                                        Operation: TOperation);
444 < begin
445 <  inherited Notification( AComponent, Operation);
446 <  if (Operation = opRemove) and (AComponent = FBase.Database) then
447 <  begin
448 <    UnregisterEvents;
449 <    FBase.Database := nil;
450 <  end;
451 < end;
452 <
453 < procedure TIBEvents.RegisterEvents;
454 < begin
455 <  ValidateDatabase( Database);
456 <  if csDesigning in ComponentState then FRegistered := true
457 <  else
458 <  begin
459 <    if not FBase.Database.Connected then
460 <      FDeferredRegister := true
461 <    else
462 <    begin
463 <      TEventHandler(FEventHandler).RegisterEvents(Events);
464 <      FRegistered := true;
465 <    end;
466 <  end;
467 < end;
468 <
469 < procedure TIBEvents.SetEvents( value: TStrings);
470 < begin
471 <  FEvents.Assign( value);
472 < end;
473 <
474 < procedure TIBEvents.SetDatabase( value: TIBDatabase);
475 < begin
476 <  if value <> FBase.Database then
477 <  begin
478 <    if Registered then UnregisterEvents;
479 <    if assigned( value) and value.Connected then ValidateDatabase( value);
480 <    FBase.Database := value;
481 <    if (FBase.Database <> nil) and FBase.Database.Connected then
482 <      DoAfterDatabaseConnect(FBase.Database)
483 <  end;
484 < end;
485 <
486 < function TIBEvents.GetDatabase: TIBDatabase;
487 < begin
488 <  Result := FBase.Database
489 < end;
490 <
491 < procedure TIBEvents.SetRegistered( value: Boolean);
492 < begin
493 <  FDeferredRegister := false;
494 <  if not assigned(FBase) or (FBase.Database = nil) then
495 <  begin
496 <    FDeferredRegister := value;
497 <    Exit;
498 <  end;
499 <
500 <  if value then RegisterEvents else UnregisterEvents;
501 < end;
502 <
503 < procedure TIBEvents.UnregisterEvents;
504 < begin
505 <  FDeferredRegister := false;
506 <  if not FRegistered then
507 <    Exit;
508 <  if csDesigning in ComponentState then
509 <    FRegistered := false
510 <  else
511 <  begin
512 <    TEventHandler(FEventHandler).UnRegisterEvents;
513 <    FRegistered := false;
514 <  end;
515 < end;
516 <
517 < procedure TIBEvents.DoBeforeDatabaseDisconnect(Sender: TObject);
518 < begin
519 <  UnregisterEvents;
520 < end;
521 <
522 < procedure TIBEvents.DoAfterDatabaseConnect(Sender: TObject);
523 < begin
524 <  if FDeferredRegister then
525 <    Registered := true
526 < end;
527 <
528 < function TIBEvents.GetDatabaseHandle: TISC_DB_HANDLE;
529 < begin
530 <  ValidateDatabase(FBase.Database);
531 <  Result := FBase.Database.Handle;
532 < end;
533 <
534 <
535 < end.
1 > {************************************************************************}
2 > {                                                                        }
3 > {       Borland Delphi Visual Component Library                          }
4 > {       InterBase Express core components                                }
5 > {                                                                        }
6 > {       Copyright (c) 1998-2000 Inprise Corporation                      }
7 > {                                                                        }
8 > {    InterBase Express is based in part on the product                   }
9 > {    Free IB Components, written by Gregory H. Deatz for                 }
10 > {    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
11 > {    Free IB Components is used under license.                           }
12 > {                                                                        }
13 > {    The contents of this file are subject to the InterBase              }
14 > {    Public License Version 1.0 (the "License"); you may not             }
15 > {    use this file except in compliance with the License. You            }
16 > {    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
17 > {    Software distributed under the License is distributed on            }
18 > {    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
19 > {    express or implied. See the License for the specific language       }
20 > {    governing rights and limitations under the License.                 }
21 > {    The Original Code was created by InterBase Software Corporation     }
22 > {       and its successors.                                              }
23 > {    Portions created by Inprise Corporation are Copyright (C) Inprise   }
24 > {       Corporation. All Rights Reserved.                                }
25 > {    Contributor(s): Jeff Overcash                                       }
26 > {                                                                        }
27 > {    IBX For Lazarus (Firebird Express)                                  }
28 > {    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
29 > {    Portions created by MWA Software are copyright McCallum Whyman      }
30 > {    Associates Ltd 2011                                                 }
31 > {                                                                        }
32 > {************************************************************************}
33 >
34 > {
35 >  This unit has been almost completely re-written as the original code was
36 >  not that robust - and I am not even sure if it worked. The IBPP C++ implementation
37 >  was used for guidance and inspiration. A permanent thread is used to receive
38 >  events from the asynchronous event handler. This then uses "Synchronize" to
39 >  process the event in the main thread.
40 >
41 >  Note that an error will occur if the TIBEvent's Registered property is set to
42 >  true before the Database has been opened.
43 > }
44 >
45 > unit IBEvents;
46 >
47 > {$Mode Delphi}
48 >
49 > interface
50 >
51 > uses
52 > {$IFDEF WINDOWS }
53 >  Windows,
54 > {$ELSE}
55 >  unix,
56 > {$ENDIF}
57 >  Classes, Graphics, Controls,
58 >  Forms, Dialogs, IBHeader, IBExternals, IB, IBDatabase;
59 >
60 > const
61 >  MaxEvents = 15;
62 >
63 > type
64 >
65 >  TEventAlert = procedure( Sender: TObject; EventName: string; EventCount: longint;
66 >                           var CancelAlerts: Boolean) of object;
67 >
68 >  { TIBEvents }
69 >
70 >  TIBEvents = class(TComponent)
71 >  private
72 >    FIBLoaded: Boolean;
73 >    FBase: TIBBase;
74 >    FEvents: TStrings;
75 >    FOnEventAlert: TEventAlert;
76 >    FEventHandler: TObject;
77 >    FRegistered: boolean;
78 >    FDeferredRegister: boolean;
79 >    procedure EventChange(sender: TObject);
80 >    function GetDatabase: TIBDatabase;
81 >    function GetDatabaseHandle: TISC_DB_HANDLE;
82 >    procedure SetDatabase( value: TIBDatabase);
83 >    procedure ValidateDatabase( Database: TIBDatabase);
84 >    procedure DoBeforeDatabaseDisconnect(Sender: TObject);
85 >    procedure DoAfterDatabaseConnect(Sender: TObject);
86 >  protected
87 >    procedure Notification( AComponent: TComponent; Operation: TOperation); override;
88 >    procedure SetEvents( value: TStrings);
89 >    procedure SetRegistered( value: boolean);
90 >
91 >  public
92 >    constructor Create( AOwner: TComponent); override;
93 >    destructor Destroy; override;
94 >    procedure RegisterEvents;
95 >    procedure UnRegisterEvents;
96 >    property DatabaseHandle: TISC_DB_HANDLE read GetDatabaseHandle;
97 >    property DeferredRegister: boolean read FDeferredRegister write FDeferredRegister;
98 >  published
99 >    property Database: TIBDatabase read GetDatabase write SetDatabase;
100 >    property Events: TStrings read FEvents write SetEvents;
101 >    property Registered: Boolean read FRegistered write SetRegistered;
102 >    property OnEventAlert: TEventAlert read FOnEventAlert write FOnEventAlert;
103 >  end;
104 >
105 >
106 > implementation
107 >
108 > uses
109 >  IBIntf, syncobjs;
110 >
111 > type
112 >
113 >  TEventHandlerStates = (
114 >    stIdle,           {Events not monitored}
115 >    stHasEvb,         {Event Block Allocated but not queued}
116 >    stQueued,         {Waiting for Event}
117 >    stSignalled       {Event Callback signalled Event}
118 >   );
119 >
120 >  { TEventHandler }
121 >
122 >  TEventHandler = class(TThread)
123 >  private
124 >    FOwner: TIBEvents;
125 >    FCriticalSection: TCriticalSection;   {protects race conditions in stQueued state}
126 >    {$IFDEF WINDOWS}
127 >    {Make direct use of Windows API as TEventObject don't seem to work under
128 >     Windows!}
129 >    FEventHandler: THandle;
130 >    {$ELSE}
131 >    FEventWaiting: TEventObject;
132 >    {$ENDIF}
133 >    FState: TEventHandlerStates;
134 >    FEventBuffer: PChar;
135 >    FEventBufferLen: integer;
136 >    FEventID: ISC_LONG;
137 >    FRegisteredState: Boolean;
138 >    FResultBuffer: PChar;
139 >    FEvents: TStringList;
140 >    FSignalFired: boolean;
141 >    procedure QueueEvents;
142 >    procedure CancelEvents;
143 >    procedure HandleEventSignalled(length: short; updated: PChar);
144 >    procedure DoEventSignalled;
145 >  protected
146 >    procedure Execute; override;
147 >  public
148 >    constructor Create(Owner: TIBEvents);
149 >    destructor Destroy; override;
150 >    procedure Terminate;
151 >    procedure RegisterEvents(Events: TStrings);
152 >    procedure UnregisterEvents;
153 >  end;
154 >
155 > {This procedure is used for the event call back - note the cdecl }
156 >
157 > procedure IBEventCallback( ptr: pointer; length: short; updated: PChar); cdecl;
158 > begin
159 >  if (ptr = nil) or (length = 0) or (updated = nil) then
160 >    Exit;
161 >  { Handle events asynchronously in second thread }
162 >  TEventHandler(ptr).HandleEventSignalled(length,updated);
163 > end;
164 >
165 >
166 >
167 > { TEventHandler }
168 >
169 > procedure TEventHandler.QueueEvents;
170 > var
171 >  callback: pointer;
172 >  DBH: TISC_DB_HANDLE;
173 > begin
174 >  if FState <> stHasEvb then
175 >    Exit;
176 >  FCriticalSection.Enter;
177 >  try
178 >    callback := @IBEventCallback;
179 >    DBH := FOwner.DatabaseHandle;
180 >    if (isc_que_events( StatusVector, @DBH, @FEventID, FEventBufferLen,
181 >                     FEventBuffer, TISC_CALLBACK(callback), PVoid(Self)) <> 0) then
182 >      IBDatabaseError;
183 >    FState := stQueued
184 >  finally
185 >    FCriticalSection.Leave
186 >  end;
187 > end;
188 >
189 > procedure TEventHandler.CancelEvents;
190 > var
191 >  DBH: TISC_DB_HANDLE;
192 > begin
193 >  if FState in [stQueued,stSignalled] then
194 >  begin
195 >    FCriticalSection.Enter;
196 >    try
197 >      DBH := FOwner.DatabaseHandle;
198 >      if (isc_Cancel_events( StatusVector, @DBH, @FEventID) <> 0) then
199 >          IBDatabaseError;
200 >      FState := stHasEvb;
201 >    finally
202 >      FCriticalSection.Leave
203 >    end;
204 >  end;
205 >
206 >  if FState = stHasEvb then
207 >  begin
208 >    isc_free( FEventBuffer);
209 >    FEventBuffer := nil;
210 >    isc_free( FResultBuffer);
211 >    FResultBuffer := nil;
212 >    FState := stIdle
213 >  end;
214 >  FSignalFired := false
215 > end;
216 >
217 > procedure TEventHandler.HandleEventSignalled(length: short; updated: PChar);
218 > begin
219 >  FCriticalSection.Enter;
220 >  try
221 >    if FState <> stQueued then
222 >      Exit;
223 >    Move(Updated[0], FResultBuffer[0], Length);
224 >    FState := stSignalled;
225 >    {$IFDEF WINDOWS}
226 >    SetEVent(FEventHandler);
227 >    {$ELSE}
228 >    FEventWaiting.SetEvent;
229 >    {$ENDIF}
230 >  finally
231 >    FCriticalSection.Leave
232 >  end;
233 > end;
234 >
235 > procedure TEventHandler.DoEventSignalled;
236 > var
237 >  i: integer;
238 >  CancelAlerts: boolean;
239 >  Status: array[0..19] of ISC_LONG; {Note in 64 implementation the ibase.h implementation
240 >                                     is different from Interbase 6.0 API documentatoin}
241 > begin
242 >    if FState <> stSignalled then
243 >      Exit;
244 >    isc_event_counts( @Status, FEventBufferLen, FEventBuffer, FResultBuffer);
245 >    CancelAlerts := false;
246 >    if not FSignalFired then
247 >      FSignalFired := true   {Ignore first time}
248 >    else
249 >    if assigned(FOwner.FOnEventAlert)  then
250 >    begin
251 >      for i := 0 to FEvents.Count - 1 do
252 >      begin
253 >        try
254 >        if (Status[i] <> 0) and not CancelAlerts then
255 >            FOwner.FOnEventAlert( self, FEvents[i], Status[i], CancelAlerts);
256 >        except
257 >          Application.HandleException( nil);
258 >        end;
259 >      end;
260 >    end;
261 >    FState := stHasEvb;
262 >  if  CancelAlerts then
263 >      CancelEvents
264 >    else
265 >      QueueEvents
266 > end;
267 >
268 > procedure TEventHandler.Execute;
269 > begin
270 >  while not Terminated do
271 >  begin
272 >    {$IFDEF WINDOWS}
273 >    WaitForSingleObject(FEventHandler,INFINITE);
274 >    {$ELSE}
275 >    FEventWaiting.WaitFor(INFINITE);
276 >    {$ENDIF}
277 >
278 >    if not Terminated and (FState = stSignalled) then
279 >      Synchronize(DoEventSignalled)
280 >  end;
281 > end;
282 >
283 >
284 >
285 > constructor TEventHandler.Create(Owner: TIBEvents);
286 > var
287 >  PSa : PSecurityAttributes;
288 > {$IFDEF WINDOWS}
289 >  Sd : TSecurityDescriptor;
290 >  Sa : TSecurityAttributes;
291 > begin
292 >  InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
293 >  SetSecurityDescriptorDacl(@Sd,true,nil,false);
294 >  Sa.nLength := SizeOf(Sa);
295 >  Sa.lpSecurityDescriptor := @Sd;
296 >  Sa.bInheritHandle := true;
297 >  PSa := @Sa;
298 > {$ELSE}
299 > begin
300 >  PSa:= nil;
301 > {$ENDIF}
302 >  inherited Create(true);
303 >  FOwner := Owner;
304 >  FState := stIdle;
305 >  FCriticalSection := TCriticalSection.Create;
306 >  {$IFDEF WINDOWS}
307 >  FEventHandler := CreateEvent(PSa,false,true,nil);
308 >  {$ELSE}
309 >  FEventWaiting := TEventObject.Create(PSa,false,true,FOwner.Name+'.Events');
310 >  {$ENDIF}
311 >  FEvents := TStringList.Create;
312 >  FreeOnTerminate := true;
313 >  Resume
314 > end;
315 >
316 > destructor TEventHandler.Destroy;
317 > begin
318 >  if assigned(FCriticalSection) then FCriticalSection.Free;
319 >  {$IFDEF WINDOWS}
320 >  CloseHandle(FEventHandler);
321 >  {$ELSE}
322 >  if assigned(FEventWaiting) then FEventWaiting.Free;
323 >  {$ENDIF}
324 >  if assigned(FEvents) then FEvents.Free;
325 >  inherited Destroy;
326 > end;
327 >
328 > procedure TEventHandler.Terminate;
329 > begin
330 >  inherited Terminate;
331 >  {$IFDEF WINDOWS}
332 >  SetEvent(FEventHandler);
333 >  {$ELSE}
334 >  FEventWaiting.SetEvent;
335 >  {$ENDIF}
336 >  CancelEvents;
337 > end;
338 >
339 > procedure TEventHandler.RegisterEvents(Events: TStrings);
340 > var
341 >  i: integer;
342 >  EventNames: array of PChar;
343 > begin
344 >  UnregisterEvents;
345 >
346 >  if Events.Count = 0 then
347 >    exit;
348 >
349 >  setlength(EventNames,MaxEvents);
350 >  try
351 >    for i := 0 to Events.Count-1 do
352 >      EventNames[i] := PChar(Events[i]);
353 >    FEvents.Assign(Events);
354 >    FEventBufferlen := isc_event_block(@FEventBuffer,@FResultBuffer,
355 >                        Events.Count,
356 >                        EventNames[0],EventNames[1],EventNames[2],
357 >                        EventNames[3],EventNames[4],EventNames[5],
358 >                        EventNames[6],EventNames[7],EventNames[8],
359 >                        EventNames[9],EventNames[10],EventNames[11],
360 >                        EventNames[12],EventNames[13],EventNames[14]
361 >                        );
362 >    FState := stHasEvb;
363 >    FRegisteredState := true;
364 >    QueueEvents
365 >  finally
366 >    SetLength(EventNames,0)
367 >  end;
368 > end;
369 >
370 > procedure TEventHandler.UnregisterEvents;
371 > begin
372 >  if FRegisteredState then
373 >  begin
374 >    CancelEvents;
375 >    FRegisteredState := false;
376 >  end;
377 > end;
378 >
379 > { TIBEvents }
380 >
381 > procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
382 > begin
383 >  if not assigned( Database) then
384 >    IBError(ibxeDatabaseNameMissing, [nil]);
385 >  if not Database.Connected then
386 >    IBError(ibxeDatabaseClosed, [nil]);
387 > end;
388 >
389 > constructor TIBEvents.Create( AOwner: TComponent);
390 > begin
391 >  inherited Create( AOwner);
392 >  FIBLoaded := False;
393 >  CheckIBLoaded;
394 >  FIBLoaded := True;
395 >  FBase := TIBBase.Create(Self);
396 >  FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect;
397 >  FBase.AfterDatabaseConnect := DoAfterDatabaseConnect;
398 >  FEvents := TStringList.Create;
399 >  with TStringList( FEvents) do
400 >  begin
401 >    OnChange := EventChange;
402 >    Duplicates := dupIgnore;
403 >  end;
404 >  FEventHandler := TEventHandler.Create(self)
405 > end;
406 >
407 > destructor TIBEvents.Destroy;
408 > begin
409 >  if FIBLoaded then
410 >  begin
411 >    UnregisterEvents;
412 >    SetDatabase(nil);
413 >    TStringList(FEvents).OnChange := nil;
414 >    FBase.Free;
415 >    FEvents.Free;
416 >  end;
417 >  if assigned(FEventHandler) then
418 >    TEventHandler(FEventHandler).Terminate;
419 >  FEventHandler := nil;
420 >  inherited Destroy;
421 > end;
422 >
423 >
424 >
425 > procedure TIBEvents.EventChange( sender: TObject);
426 > begin
427 >  { check for blank event }
428 >  if TStringList(Events).IndexOf( '') <> -1 then
429 >    IBError(ibxeInvalidEvent, [nil]);
430 >  { check for too many events }
431 >  if Events.Count > MaxEvents then
432 >  begin
433 >    TStringList(Events).OnChange := nil;
434 >    Events.Delete( MaxEvents);
435 >    TStringList(Events).OnChange := EventChange;
436 >    IBError(ibxeMaximumEvents, [nil]);
437 >  end;
438 >  if Registered then
439 >    TEventHandler(FEventHandler).RegisterEvents(Events);
440 > end;
441 >
442 > procedure TIBEvents.Notification( AComponent: TComponent;
443 >                                        Operation: TOperation);
444 > begin
445 >  inherited Notification( AComponent, Operation);
446 >  if (Operation = opRemove) and (AComponent = FBase.Database) then
447 >  begin
448 >    UnregisterEvents;
449 >    FBase.Database := nil;
450 >  end;
451 > end;
452 >
453 > procedure TIBEvents.RegisterEvents;
454 > begin
455 >  ValidateDatabase( Database);
456 >  if csDesigning in ComponentState then FRegistered := true
457 >  else
458 >  begin
459 >    if not FBase.Database.Connected then
460 >      FDeferredRegister := true
461 >    else
462 >    begin
463 >      TEventHandler(FEventHandler).RegisterEvents(Events);
464 >      FRegistered := true;
465 >    end;
466 >  end;
467 > end;
468 >
469 > procedure TIBEvents.SetEvents( value: TStrings);
470 > begin
471 >  FEvents.Assign( value);
472 > end;
473 >
474 > procedure TIBEvents.SetDatabase( value: TIBDatabase);
475 > begin
476 >  if value <> FBase.Database then
477 >  begin
478 >    if Registered then UnregisterEvents;
479 >    if assigned( value) and value.Connected then ValidateDatabase( value);
480 >    FBase.Database := value;
481 >    if (FBase.Database <> nil) and FBase.Database.Connected then
482 >      DoAfterDatabaseConnect(FBase.Database)
483 >  end;
484 > end;
485 >
486 > function TIBEvents.GetDatabase: TIBDatabase;
487 > begin
488 >  Result := FBase.Database
489 > end;
490 >
491 > procedure TIBEvents.SetRegistered( value: Boolean);
492 > begin
493 >  FDeferredRegister := false;
494 >  if not assigned(FBase) or (FBase.Database = nil) then
495 >  begin
496 >    FDeferredRegister := value;
497 >    Exit;
498 >  end;
499 >
500 >  if value then RegisterEvents else UnregisterEvents;
501 > end;
502 >
503 > procedure TIBEvents.UnregisterEvents;
504 > begin
505 >  FDeferredRegister := false;
506 >  if not FRegistered then
507 >    Exit;
508 >  if csDesigning in ComponentState then
509 >    FRegistered := false
510 >  else
511 >  begin
512 >    TEventHandler(FEventHandler).UnRegisterEvents;
513 >    FRegistered := false;
514 >  end;
515 > end;
516 >
517 > procedure TIBEvents.DoBeforeDatabaseDisconnect(Sender: TObject);
518 > begin
519 >  UnregisterEvents;
520 > end;
521 >
522 > procedure TIBEvents.DoAfterDatabaseConnect(Sender: TObject);
523 > begin
524 >  if FDeferredRegister then
525 >    Registered := true
526 > end;
527 >
528 > function TIBEvents.GetDatabaseHandle: TISC_DB_HANDLE;
529 > begin
530 >  ValidateDatabase(FBase.Database);
531 >  Result := FBase.Database.Handle;
532 > end;
533 >
534 >
535 > end.

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines