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 1 by tony, Mon Jul 31 16:43:00 2000 UTC vs.
Revision 143 by tony, Fri Feb 23 12:11:21 2018 UTC

# Line 24 | Line 24
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 - 2018                                               }
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 objfpc}{$H+}
48 +
49   interface
50  
51   uses
52 <  SysUtils, Windows, Messages, Classes, Graphics, Controls,
53 <  Forms, Dialogs, DB, IBHeader, IBExternals, IB, IBDatabase;
52 > {$IFDEF WINDOWS }
53 >  Windows,
54 > {$ELSE}
55 >  unix,
56 > {$ENDIF}
57 >  Classes, IBExternals, IB, IBDatabase;
58  
59   const
60    MaxEvents = 15;
39 –  EventLength = 64;
61  
62   type
63  
64    TEventAlert = procedure( Sender: TObject; EventName: string; EventCount: longint;
65                             var CancelAlerts: Boolean) of object;
66  
67 <  TEventBuffer = array[ 0..MaxEvents-1, 0..EventLength-1] of char;
67 >  { TIBEvents }
68  
69    TIBEvents = class(TComponent)
70    private
71 <    FIBLoaded: Boolean;
71 >    FBase: TIBBase;
72 >    FEventIntf: IEvents;
73      FEvents: TStrings;
74      FOnEventAlert: TEventAlert;
75 <    FQueued: Boolean;
76 <    FRegistered: Boolean;
77 <    Buffer: TEventBuffer;
78 <    Changing: Boolean;
79 <    CS: TRTLCriticalSection;
80 <    EventBuffer: PChar;
81 <    EventBufferLen: integer;
60 <    EventID: ISC_LONG;
61 <    ProcessingEvents: Boolean;
62 <    RegisteredState: Boolean;
63 <    ResultBuffer: PChar;
64 <    FDatabase: TIBDatabase;
75 >    FRegistered: boolean;
76 >    FDeferredRegister: boolean;
77 >    FStartEvent: boolean;
78 >    procedure EventHandler(Sender: IEvents);
79 >    procedure ProcessEvents;
80 >    procedure EventChange(sender: TObject);
81 >    function GetDatabase: TIBDatabase;
82      procedure SetDatabase( value: TIBDatabase);
83      procedure ValidateDatabase( Database: TIBDatabase);
84 <    procedure DoQueueEvents;
85 <    procedure EventChange( sender: TObject);
69 <    procedure UpdateResultBuffer( length: short; updated: PChar);
84 >    procedure DoBeforeDatabaseDisconnect(Sender: TObject);
85 >    procedure DoAfterDatabaseConnect(Sender: TObject);
86    protected
71 –    procedure HandleEvent;
72 –    procedure Loaded; override;
87      procedure Notification( AComponent: TComponent; Operation: TOperation); override;
88      procedure SetEvents( value: TStrings);
89      procedure SetRegistered( value: boolean);
76 –    function  GetNativeHandle: TISC_DB_HANDLE;
90  
91    public
92      constructor Create( AOwner: TComponent); override;
93      destructor Destroy; override;
81 –    procedure CancelEvents;
82 –    procedure QueueEvents;
94      procedure RegisterEvents;
95      procedure UnRegisterEvents;
96 <    property  Queued: Boolean read FQueued;
96 >    property DeferredRegister: boolean read FDeferredRegister write FDeferredRegister;
97 >    property EventIntf: IEvents read FEventIntf;
98    published
99 <    property  Database: TIBDatabase read FDatabase write SetDatabase;
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
96 <  IBIntf;
108 > uses SysUtils, FBMessages;
109  
110 < function TIBEvents.GetNativeHandle: TISC_DB_HANDLE;
99 < begin
100 <  if assigned( FDatabase) and FDatabase.Connected then
101 <    Result := FDatabase.Handle
102 <  else result := nil;
103 < end;
110 > { TIBEvents }
111  
112   procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
113   begin
# Line 110 | Line 117 | begin
117      IBError(ibxeDatabaseClosed, [nil]);
118   end;
119  
113 – { TIBEvents }
114 –
115 – procedure HandleEvent( param: integer); stdcall;
116 – begin
117 –  { don't let exceptions propogate out of thread }
118 –  try
119 –    TIBEvents( param).HandleEvent;
120 –  except
121 –    Application.HandleException( nil);
122 –  end;
123 – end;
124 –
125 – procedure IBEventCallback( ptr: pointer; length: short; updated: PChar); cdecl;
126 – var
127 –  ThreadID: DWORD;
128 – begin
129 –  { Handle events asynchronously in second thread }
130 –  EnterCriticalSection( TIBEvents( ptr).CS);
131 –  TIBEvents( ptr).UpdateResultBuffer( length, updated);
132 –  if TIBEvents( ptr).Queued then
133 –    CloseHandle( CreateThread( nil, 8192, @HandleEvent, ptr, 0, ThreadID));
134 –  LeaveCriticalSection( TIBEvents( ptr).CS);
135 – end;
136 –
120   constructor TIBEvents.Create( AOwner: TComponent);
121   begin
122    inherited Create( AOwner);
123 <  FIBLoaded := False;
124 <  CheckIBLoaded;
125 <  FIBLoaded := True;
143 <  InitializeCriticalSection( CS);
123 >  FBase := TIBBase.Create(Self);
124 >  FBase.BeforeDatabaseDisconnect := @DoBeforeDatabaseDisconnect;
125 >  FBase.AfterDatabaseConnect := @DoAfterDatabaseConnect;
126    FEvents := TStringList.Create;
127 +  FStartEvent := true;
128    with TStringList( FEvents) do
129    begin
130 <    OnChange := EventChange;
130 >    OnChange := @EventChange;
131      Duplicates := dupIgnore;
132    end;
133   end;
134  
135   destructor TIBEvents.Destroy;
136   begin
137 <  if FIBLoaded then
138 <  begin
139 <    UnregisterEvents;
140 <    SetDatabase( nil);
141 <    TStringList(FEvents).OnChange := nil;
142 <    FEvents.Free;
143 <    DeleteCriticalSection( CS);
144 <  end;
145 <  inherited Destroy;
146 < end;
147 <
148 < procedure TIBEvents.CancelEvents;
149 < begin
150 <  if ProcessingEvents then
151 <    IBError(ibxeInvalidCancellation, [nil]);  
152 <  if FQueued then
137 >  UnregisterEvents;
138 >  SetDatabase(nil);
139 >  TStringList(FEvents).OnChange := nil;
140 >  FBase.Free;
141 >  FEvents.Free;
142 > end;
143 >
144 > procedure TIBEvents.EventHandler(Sender: IEvents);
145 > begin
146 >  TThread.Synchronize(nil,@ProcessEvents);
147 > end;
148 >
149 > procedure TIBEvents.ProcessEvents;
150 > var EventCounts: TEventCounts;
151 >    CancelAlerts: Boolean;
152 >    i: integer;
153 > begin
154 >  if (csDestroying in ComponentState) or (FEventIntf = nil) then Exit;
155 >  CancelAlerts := false;
156 >  EventCounts := FEventIntf.ExtractEventCounts;
157 >  if FStartEvent then
158 >    FStartEvent := false {ignore the first one}
159 >  else
160 >  if assigned(FOnEventAlert) then
161    begin
162 <    try
163 <      { wait for event handler to finish before cancelling events }
164 <      EnterCriticalSection( CS);
165 <      ValidateDatabase( Database);
166 <      FQueued := false;
176 <      Changing := true;
177 <      if (isc_Cancel_events( StatusVector, @FDatabase.Handle, @EventID) > 0) then
178 <        IBDatabaseError;
179 <    finally
180 <      LeaveCriticalSection( CS);
162 >    CancelAlerts := false;
163 >    for i := 0 to Length(EventCounts) -1 do
164 >    begin
165 >      OnEventAlert(self,EventCounts[i].EventName,EventCounts[i].Count,CancelAlerts);
166 >      if CancelAlerts then break;
167      end;
168    end;
169 < end;
170 <
171 < procedure TIBEvents.DoQueueEvents;
172 < var
187 <  callback: pointer;
188 < begin
189 <  ValidateDatabase( DataBase);
190 <  callback := @IBEventCallback;
191 <  if (isc_que_events( StatusVector, @FDatabase.Handle, @EventID, EventBufferLen,
192 <                     EventBuffer, TISC_CALLBACK(callback), PVoid(Self)) > 0) then
193 <    IBDatabaseError;
194 <  FQueued := true;
169 >  if CancelAlerts then
170 >    UnRegisterEvents
171 >  else
172 >    FEventIntf.AsyncWaitForEvent(@EventHandler);
173   end;
174  
175   procedure TIBEvents.EventChange( sender: TObject);
# Line 204 | Line 182 | begin
182    begin
183      TStringList(Events).OnChange := nil;
184      Events.Delete( MaxEvents);
185 <    TStringList(Events).OnChange := EventChange;
185 >    TStringList(Events).OnChange := @EventChange;
186      IBError(ibxeMaximumEvents, [nil]);
187    end;
188 <  if Registered then RegisterEvents;
189 < end;
190 <
191 < procedure TIBEvents.HandleEvent;
214 < var
215 <  Status: PStatusVector;
216 <  CancelAlerts: Boolean;
217 <  i: integer;
218 < begin
219 <  try
220 <    { prevent modification of vital data structures while handling events }
221 <    EnterCriticalSection( CS);
222 <    ProcessingEvents := true;
223 <    isc_event_counts( StatusVector, EventBufferLen, EventBuffer, ResultBuffer);
224 <    CancelAlerts := false;
225 <    if assigned(FOnEventAlert) and not Changing then
226 <    begin
227 <      for i := 0 to Events.Count-1 do
228 <      begin
229 <        try
230 <        Status := StatusVectorArray;
231 <        if (Status[i] <> 0) and not CancelAlerts then
232 <            FOnEventAlert( self, Events[Events.Count-i-1], Status[i], CancelAlerts);
233 <        except
234 <          Application.HandleException( nil);
235 <        end;
236 <      end;
237 <    end;
238 <    Changing := false;
239 <    if not CancelAlerts and FQueued then DoQueueEvents;
240 <  finally
241 <    ProcessingEvents := false;
242 <    LeaveCriticalSection( CS);
243 <  end;
244 < end;
245 <
246 < procedure TIBEvents.Loaded;
247 < begin
248 <  inherited Loaded;
249 <  try
250 <    if RegisteredState then RegisterEvents;
251 <  except
252 <    if csDesigning in ComponentState then
253 <      Application.HandleException( self)
254 <    else raise;
188 >  if Registered  and (FEventIntf <> nil) then
189 >  begin
190 >    FEventIntf.SetEvents(Events);
191 >    FEventIntf.AsyncWaitForEvent(@EventHandler);
192    end;
193   end;
194  
# Line 259 | Line 196 | procedure TIBEvents.Notification( ACompo
196                                          Operation: TOperation);
197   begin
198    inherited Notification( AComponent, Operation);
199 <  if (Operation = opRemove) and (AComponent = FDatabase) then
199 >  if (Operation = opRemove) and (AComponent = FBase.Database) then
200    begin
201      UnregisterEvents;
202 <    FDatabase := nil;
266 <  end;
267 < end;
268 <
269 < procedure TIBEvents.QueueEvents;
270 < begin
271 <  if not FRegistered then
272 <    IBError(ibxeNoEventsRegistered, [nil]);
273 <  if ProcessingEvents then
274 <    IBError(ibxeInvalidQueueing, [nil]);
275 <  if not FQueued then
276 <  begin
277 <    try
278 <      { wait until current event handler is finished before queuing events }
279 <      EnterCriticalSection( CS);
280 <      DoQueueEvents;
281 <      Changing := true;
282 <    finally
283 <      LeaveCriticalSection( CS);
284 <    end;
202 >    FBase.Database := nil;
203    end;
204   end;
205  
206   procedure TIBEvents.RegisterEvents;
289 – var
290 –  i: integer;
291 –  bufptr: pointer;
292 –  eventbufptr: pointer;
293 –  resultbufptr: pointer;
294 –  buflen: integer;
207   begin
208 +  if FRegistered then Exit;
209    ValidateDatabase( Database);
210    if csDesigning in ComponentState then FRegistered := true
211 <  else begin
212 <    UnregisterEvents;
213 <    if Events.Count = 0 then exit;
214 <    for i := 0 to Events.Count-1 do
215 <      StrPCopy( @Buffer[i][0], Events[i]);
216 <    i := Events.Count;
217 <    bufptr := @buffer[0];
218 <    eventbufptr :=  @EventBuffer;
219 <    resultBufPtr := @ResultBuffer;
307 <    asm
308 <      mov ecx, dword ptr [i]
309 <      mov eax, dword ptr [bufptr]
310 <      @@1:
311 <      push eax
312 <      add  eax, EventLength
313 <      loop @@1
314 <      push dword ptr [i]
315 <      push dword ptr [resultBufPtr]
316 <      push dword ptr [eventBufPtr]
317 <      call [isc_event_block]
318 <      mov  dword ptr [bufLen], eax
319 <      mov eax, dword ptr [i]
320 <      shl eax, 2
321 <      add eax, 12
322 <      add esp, eax
211 >  else
212 >  begin
213 >    if not FBase.Database.Connected then
214 >      FDeferredRegister := true
215 >    else
216 >    begin
217 >      FEventIntf := Database.Attachment.GetEventHandler(Events);
218 >      FEventIntf.AsyncWaitForEvent(@EventHandler);
219 >      FRegistered := true;
220      end;
324 –    EventBufferlen := Buflen;
325 –    FRegistered := true;
326 –    QueueEvents;
221    end;
222   end;
223  
# Line 334 | Line 228 | end;
228  
229   procedure TIBEvents.SetDatabase( value: TIBDatabase);
230   begin
231 <  if value <> FDatabase then
231 >  if value <> FBase.Database then
232    begin
233 <    UnregisterEvents;
233 >    if Registered then UnregisterEvents;
234      if assigned( value) and value.Connected then ValidateDatabase( value);
235 <    FDatabase := value;
235 >    FBase.Database := value;
236 >    if (FBase.Database <> nil) and FBase.Database.Connected then
237 >      DoAfterDatabaseConnect(FBase.Database)
238    end;
239   end;
240  
241 < procedure TIBEvents.SetRegistered( value: Boolean);
241 > function TIBEvents.GetDatabase: TIBDatabase;
242 > begin
243 >  Result := FBase.Database
244 > end;
245 >
246 > procedure TIBEvents.SetRegistered(value: boolean);
247   begin
248 <  if (csReading in ComponentState) then
249 <    RegisteredState := value
250 <  else if FRegistered <> value then
251 <    if value then RegisterEvents else UnregisterEvents;
248 >  FDeferredRegister := false;
249 >  if not assigned(FBase) or (FBase.Database = nil) then
250 >  begin
251 >    FDeferredRegister := value;
252 >    Exit;
253 >  end;
254 >
255 >  if value then RegisterEvents else UnregisterEvents;
256   end;
257  
258 < procedure TIBEvents.UnregisterEvents;
258 > procedure TIBEvents.UnRegisterEvents;
259   begin
260 <  if ProcessingEvents then
261 <    IBError(ibxeInvalidRegistration, [nil]);
260 >  FDeferredRegister := false;
261 >  if not FRegistered then
262 >    Exit;
263    if csDesigning in ComponentState then
264      FRegistered := false
265 <  else if not (csLoading in ComponentState) then
265 >  else
266    begin
267 <    CancelEvents;
362 <    if FRegistered then
363 <    begin
364 <      isc_free( EventBuffer);
365 <      EventBuffer := nil;
366 <      isc_free( ResultBuffer);
367 <      ResultBuffer := nil;
368 <    end;
267 >    FEventIntf := nil;
268      FRegistered := false;
269    end;
270   end;
271  
272 < procedure TIBEvents.UpdateResultBuffer( length: short; updated: PChar);
374 < var
375 <  i: integer;
272 > procedure TIBEvents.DoBeforeDatabaseDisconnect(Sender: TObject);
273   begin
274 <  for i := 0 to length-1 do
378 <    ResultBuffer[i] := updated[i];
274 >  UnregisterEvents;
275   end;
276  
277 + procedure TIBEvents.DoAfterDatabaseConnect(Sender: TObject);
278 + begin
279 +  if FDeferredRegister then
280 +    Registered := true
281 + end;
282 +
283 +
284   end.

Diff Legend

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