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 45 by tony, Tue Dec 6 10:33:46 2016 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                                                 }
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;
59 <    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 >    procedure EventHandler(Sender: IEvents);
78 >    procedure ProcessEvents;
79 >    procedure EventChange(sender: TObject);
80 >    function GetDatabase: TIBDatabase;
81      procedure SetDatabase( value: TIBDatabase);
82      procedure ValidateDatabase( Database: TIBDatabase);
83 <    procedure DoQueueEvents;
84 <    procedure EventChange( sender: TObject);
69 <    procedure UpdateResultBuffer( length: short; updated: PChar);
83 >    procedure DoBeforeDatabaseDisconnect(Sender: TObject);
84 >    procedure DoAfterDatabaseConnect(Sender: TObject);
85    protected
71 –    procedure HandleEvent;
72 –    procedure Loaded; override;
86      procedure Notification( AComponent: TComponent; Operation: TOperation); override;
87      procedure SetEvents( value: TStrings);
88      procedure SetRegistered( value: boolean);
76 –    function  GetNativeHandle: TISC_DB_HANDLE;
89  
90    public
91      constructor Create( AOwner: TComponent); override;
92      destructor Destroy; override;
81 –    procedure CancelEvents;
82 –    procedure QueueEvents;
93      procedure RegisterEvents;
94      procedure UnRegisterEvents;
95 <    property  Queued: Boolean read FQueued;
95 >    property DeferredRegister: boolean read FDeferredRegister write FDeferredRegister;
96 >    property EventIntf: IEvents read FEventIntf;
97    published
98 <    property  Database: TIBDatabase read FDatabase write SetDatabase;
98 >    property Database: TIBDatabase read GetDatabase write SetDatabase;
99      property Events: TStrings read FEvents write SetEvents;
100      property Registered: Boolean read FRegistered write SetRegistered;
101      property OnEventAlert: TEventAlert read FOnEventAlert write FOnEventAlert;
102    end;
103  
104 +
105   implementation
106  
107 < uses
96 <  IBIntf;
107 > uses SysUtils, FBMessages;
108  
109 < 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;
109 > { TIBEvents }
110  
111   procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
112   begin
# Line 110 | Line 116 | begin
116      IBError(ibxeDatabaseClosed, [nil]);
117   end;
118  
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 –
119   constructor TIBEvents.Create( AOwner: TComponent);
120   begin
121    inherited Create( AOwner);
122 <  FIBLoaded := False;
123 <  CheckIBLoaded;
124 <  FIBLoaded := True;
143 <  InitializeCriticalSection( CS);
122 >  FBase := TIBBase.Create(Self);
123 >  FBase.BeforeDatabaseDisconnect := @DoBeforeDatabaseDisconnect;
124 >  FBase.AfterDatabaseConnect := @DoAfterDatabaseConnect;
125    FEvents := TStringList.Create;
126    with TStringList( FEvents) do
127    begin
128 <    OnChange := EventChange;
128 >    OnChange := @EventChange;
129      Duplicates := dupIgnore;
130    end;
131   end;
132  
133   destructor TIBEvents.Destroy;
134   begin
135 <  if FIBLoaded then
136 <  begin
137 <    UnregisterEvents;
138 <    SetDatabase( nil);
139 <    TStringList(FEvents).OnChange := nil;
159 <    FEvents.Free;
160 <    DeleteCriticalSection( CS);
161 <  end;
162 <  inherited Destroy;
135 >  UnregisterEvents;
136 >  SetDatabase(nil);
137 >  TStringList(FEvents).OnChange := nil;
138 >  FBase.Free;
139 >  FEvents.Free;
140   end;
141  
142 < procedure TIBEvents.CancelEvents;
142 > procedure TIBEvents.EventHandler(Sender: IEvents);
143   begin
144 <  if ProcessingEvents then
145 <    IBError(ibxeInvalidCancellation, [nil]);  
146 <  if FQueued then
144 >  TThread.Synchronize(nil,@ProcessEvents);
145 > end;
146 >
147 > procedure TIBEvents.ProcessEvents;
148 > var EventCounts: TEventCounts;
149 >    CancelAlerts: Boolean;
150 >    i: integer;
151 > begin
152 >  if (csDestroying in ComponentState) or (FEventIntf = nil) then Exit;
153 >  EventCounts := FEventIntf.ExtractEventCounts;
154 >  if assigned(FOnEventAlert) then
155    begin
156 <    try
157 <      { wait for event handler to finish before cancelling events }
158 <      EnterCriticalSection( CS);
159 <      ValidateDatabase( Database);
160 <      FQueued := false;
176 <      Changing := true;
177 <      if (isc_Cancel_events( StatusVector, @FDatabase.Handle, @EventID) > 0) then
178 <        IBDatabaseError;
179 <    finally
180 <      LeaveCriticalSection( CS);
156 >    CancelAlerts := false;
157 >    for i := 0 to Length(EventCounts) -1 do
158 >    begin
159 >      OnEventAlert(self,EventCounts[i].EventName,EventCounts[i].Count,CancelAlerts);
160 >      if CancelAlerts then break;
161      end;
162    end;
163 < end;
164 <
165 < procedure TIBEvents.DoQueueEvents;
166 < 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;
163 >  if CancelAlerts then
164 >    UnRegisterEvents
165 >  else
166 >    FEventIntf.AsyncWaitForEvent(@EventHandler);
167   end;
168  
169   procedure TIBEvents.EventChange( sender: TObject);
# Line 204 | Line 176 | begin
176    begin
177      TStringList(Events).OnChange := nil;
178      Events.Delete( MaxEvents);
179 <    TStringList(Events).OnChange := EventChange;
179 >    TStringList(Events).OnChange := @EventChange;
180      IBError(ibxeMaximumEvents, [nil]);
181    end;
182 <  if Registered then RegisterEvents;
183 < end;
184 <
185 < 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;
182 >  if Registered  and (FEventIntf <> nil) then
183 >  begin
184 >    FEventIntf.SetEvents(Events);
185 >    FEventIntf.AsyncWaitForEvent(@EventHandler);
186    end;
187   end;
188  
# Line 259 | Line 190 | procedure TIBEvents.Notification( ACompo
190                                          Operation: TOperation);
191   begin
192    inherited Notification( AComponent, Operation);
193 <  if (Operation = opRemove) and (AComponent = FDatabase) then
193 >  if (Operation = opRemove) and (AComponent = FBase.Database) then
194    begin
195      UnregisterEvents;
196 <    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;
196 >    FBase.Database := nil;
197    end;
198   end;
199  
200   procedure TIBEvents.RegisterEvents;
289 – var
290 –  i: integer;
291 –  bufptr: pointer;
292 –  eventbufptr: pointer;
293 –  resultbufptr: pointer;
294 –  buflen: integer;
201   begin
202 +  if FRegistered then Exit;
203    ValidateDatabase( Database);
204    if csDesigning in ComponentState then FRegistered := true
205 <  else begin
206 <    UnregisterEvents;
207 <    if Events.Count = 0 then exit;
208 <    for i := 0 to Events.Count-1 do
209 <      StrPCopy( @Buffer[i][0], Events[i]);
210 <    i := Events.Count;
211 <    bufptr := @buffer[0];
212 <    eventbufptr :=  @EventBuffer;
213 <    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
205 >  else
206 >  begin
207 >    if not FBase.Database.Connected then
208 >      FDeferredRegister := true
209 >    else
210 >    begin
211 >      FEventIntf := Database.Attachment.GetEventHandler(Events);
212 >      FEventIntf.AsyncWaitForEvent(@EventHandler);
213 >      FRegistered := true;
214      end;
324 –    EventBufferlen := Buflen;
325 –    FRegistered := true;
326 –    QueueEvents;
215    end;
216   end;
217  
# Line 334 | Line 222 | end;
222  
223   procedure TIBEvents.SetDatabase( value: TIBDatabase);
224   begin
225 <  if value <> FDatabase then
225 >  if value <> FBase.Database then
226    begin
227 <    UnregisterEvents;
227 >    if Registered then UnregisterEvents;
228      if assigned( value) and value.Connected then ValidateDatabase( value);
229 <    FDatabase := value;
229 >    FBase.Database := value;
230 >    if (FBase.Database <> nil) and FBase.Database.Connected then
231 >      DoAfterDatabaseConnect(FBase.Database)
232    end;
233   end;
234  
235 < procedure TIBEvents.SetRegistered( value: Boolean);
235 > function TIBEvents.GetDatabase: TIBDatabase;
236 > begin
237 >  Result := FBase.Database
238 > end;
239 >
240 > procedure TIBEvents.SetRegistered(value: boolean);
241   begin
242 <  if (csReading in ComponentState) then
243 <    RegisteredState := value
244 <  else if FRegistered <> value then
245 <    if value then RegisterEvents else UnregisterEvents;
242 >  FDeferredRegister := false;
243 >  if not assigned(FBase) or (FBase.Database = nil) then
244 >  begin
245 >    FDeferredRegister := value;
246 >    Exit;
247 >  end;
248 >
249 >  if value then RegisterEvents else UnregisterEvents;
250   end;
251  
252 < procedure TIBEvents.UnregisterEvents;
252 > procedure TIBEvents.UnRegisterEvents;
253   begin
254 <  if ProcessingEvents then
255 <    IBError(ibxeInvalidRegistration, [nil]);
254 >  FDeferredRegister := false;
255 >  if not FRegistered then
256 >    Exit;
257    if csDesigning in ComponentState then
258      FRegistered := false
259 <  else if not (csLoading in ComponentState) then
259 >  else
260    begin
261 <    CancelEvents;
362 <    if FRegistered then
363 <    begin
364 <      isc_free( EventBuffer);
365 <      EventBuffer := nil;
366 <      isc_free( ResultBuffer);
367 <      ResultBuffer := nil;
368 <    end;
261 >    FEventIntf := nil;
262      FRegistered := false;
263    end;
264   end;
265  
266 < procedure TIBEvents.UpdateResultBuffer( length: short; updated: PChar);
374 < var
375 <  i: integer;
266 > procedure TIBEvents.DoBeforeDatabaseDisconnect(Sender: TObject);
267   begin
268 <  for i := 0 to length-1 do
378 <    ResultBuffer[i] := updated[i];
268 >  UnregisterEvents;
269   end;
270  
271 + procedure TIBEvents.DoAfterDatabaseConnect(Sender: TObject);
272 + begin
273 +  if FDeferredRegister then
274 +    Registered := true
275 + end;
276 +
277 +
278   end.

Diff Legend

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