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 5 by tony, Fri Feb 18 16:26:16 2011 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 Delphi}
47 > {$mode objfpc}{$H+}
48  
49   interface
50  
51   uses
52 < {$IFDEF LINUX }
37 <  {$IFNDEF DESIGNTIME} cthreads,{$ENDIF}unix,
38 < {$ELSE}
52 > {$IFDEF WINDOWS }
53    Windows,
54 < {$ENDIF}  Classes, Graphics, Controls,
55 <  Forms, Dialogs, IBHeader, IBExternals, IB, IBDatabase;
54 > {$ELSE}
55 >  unix,
56 > {$ENDIF}
57 >  Classes, IBExternals, IB, IBDatabase;
58  
59   const
60    MaxEvents = 15;
45 –  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 <    Changing: Boolean;
78 <    CS: TRTLCriticalSection;
79 <    EventBuffer: PChar;
80 <    EventBufferLen: integer;
81 <    EventID: ISC_LONG;
66 <    ProcessingEvents: Boolean;
67 <    RegisteredState: Boolean;
68 <    ResultBuffer: PChar;
69 <    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);
74 <    procedure UpdateResultBuffer( length: short; updated: PChar);
84 >    procedure DoBeforeDatabaseDisconnect(Sender: TObject);
85 >    procedure DoAfterDatabaseConnect(Sender: TObject);
86    protected
76 –    procedure HandleEvent;
77 –    procedure Loaded; override;
87      procedure Notification( AComponent: TComponent; Operation: TOperation); override;
88      procedure SetEvents( value: TStrings);
89      procedure SetRegistered( value: boolean);
81 –    function  GetNativeHandle: TISC_DB_HANDLE;
90  
91    public
92      constructor Create( AOwner: TComponent); override;
93      destructor Destroy; override;
86 –    procedure CancelEvents;
87 –    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
101 <  IBIntf;
108 > uses SysUtils, FBMessages;
109  
110 < function TIBEvents.GetNativeHandle: TISC_DB_HANDLE;
104 < begin
105 <  if assigned( FDatabase) and FDatabase.Connected then
106 <    Result := FDatabase.Handle
107 <  else result := nil;
108 < end;
110 > { TIBEvents }
111  
112   procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
113   begin
# Line 115 | Line 117 | begin
117      IBError(ibxeDatabaseClosed, [nil]);
118   end;
119  
118 – { TIBEvents }
119 –
120 – function HandleEvent( param: pointer): ptrint;
121 – begin
122 –  { don't let exceptions propogate out of thread }
123 –  try
124 –    TIBEvents( param).HandleEvent;
125 –  except
126 –    Application.HandleException( nil);
127 –  end;
128 –  EndThread;
129 – end;
130 –
131 – procedure IBEventCallback( ptr: pointer; length: short; updated: PChar); cdecl;
132 – begin
133 –  { Handle events asynchronously in second thread }
134 –  EnterCriticalSection( TIBEvents( ptr).CS);
135 –  TIBEvents( ptr).UpdateResultBuffer( length, updated);
136 –  if TIBEvents( ptr).Queued then
137 –    BeginThread( @HandleEvent,ptr);
138 –  LeaveCriticalSection( TIBEvents( ptr).CS);
139 – end;
140 –
120   constructor TIBEvents.Create( AOwner: TComponent);
121   begin
122    inherited Create( AOwner);
123 <  FIBLoaded := False;
124 <  CheckIBLoaded;
125 <  FIBLoaded := True;
147 <  InitCriticalSection( 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 <    DoneCriticalSection( 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;
180 <      Changing := true;
181 <      if (isc_Cancel_events( StatusVector, @FDatabase.Handle, @EventID) > 0) then
182 <        IBDatabaseError;
183 <    finally
184 <      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
191 <  callback: pointer;
192 < begin
193 <  ValidateDatabase( DataBase);
194 <  callback := @IBEventCallback;
195 <  if (isc_que_events( StatusVector, @FDatabase.Handle, @EventID, EventBufferLen,
196 <                     EventBuffer, TISC_CALLBACK(callback), PVoid(Self)) > 0) then
197 <    IBDatabaseError;
198 <  FQueued := true;
169 >  if CancelAlerts then
170 >    UnRegisterEvents
171 >  else
172 >    FEventIntf.AsyncWaitForEvent(@EventHandler);
173   end;
174  
175   procedure TIBEvents.EventChange( sender: TObject);
# Line 208 | 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;
218 < var
219 <  Status: PStatusVector;
220 <  CancelAlerts: Boolean;
221 <  i: integer;
222 < begin
223 <  try
224 <    { prevent modification of vital data structures while handling events }
225 <    EnterCriticalSection( CS);
226 <    ProcessingEvents := true;
227 <    isc_event_counts( StatusVector, EventBufferLen, EventBuffer, ResultBuffer);
228 <    CancelAlerts := false;
229 <    if assigned(FOnEventAlert) and not Changing then
230 <    begin
231 <      for i := 0 to Events.Count-1 do
232 <      begin
233 <        try
234 <        Status := StatusVectorArray;
235 <        if (Status[i] <> 0) and not CancelAlerts then
236 <            FOnEventAlert( self, Events[Events.Count-i-1], Status[i], CancelAlerts);
237 <        except
238 <          Application.HandleException( nil);
239 <        end;
240 <      end;
241 <    end;
242 <    Changing := false;
243 <    if not CancelAlerts and FQueued then DoQueueEvents;
244 <  finally
245 <    ProcessingEvents := false;
246 <    LeaveCriticalSection( CS);
247 <  end;
248 < end;
249 <
250 < procedure TIBEvents.Loaded;
251 < begin
252 <  inherited Loaded;
253 <  try
254 <    if RegisteredState then RegisterEvents;
255 <  except
256 <    if csDesigning in ComponentState then
257 <      Application.HandleException( self)
258 <    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 263 | 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;
270 <  end;
271 < end;
272 <
273 < procedure TIBEvents.QueueEvents;
274 < begin
275 <  if not FRegistered then
276 <    IBError(ibxeNoEventsRegistered, [nil]);
277 <  if ProcessingEvents then
278 <    IBError(ibxeInvalidQueueing, [nil]);
279 <  if not FQueued then
280 <  begin
281 <    try
282 <      { wait until current event handler is finished before queuing events }
283 <      EnterCriticalSection( CS);
284 <      DoQueueEvents;
285 <      Changing := true;
286 <    finally
287 <      LeaveCriticalSection( CS);
288 <    end;
202 >    FBase.Database := nil;
203    end;
204   end;
205  
206   procedure TIBEvents.RegisterEvents;
293 – var
294 –  i: integer;
295 –  EventNames: array of PChar;
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 <    setlength(EventNames,Events.Count);
215 <    for i := 0 to Events.Count-1 do
216 <      EventNames[i] := PChar(Events[i]);
217 <
218 <    EventBufferlen := isc_event_block(@EventBuffer,@ResultBuffer,
219 <                        Events.Count,EventNames);
220 <    FRegistered := true;
309 <    QueueEvents;
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;
221    end;
222   end;
223  
# Line 317 | 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;
345 <    if FRegistered then
346 <    begin
347 <      isc_free( EventBuffer);
348 <      EventBuffer := nil;
349 <      isc_free( ResultBuffer);
350 <      ResultBuffer := nil;
351 <    end;
267 >    FEventIntf := nil;
268      FRegistered := false;
269    end;
270   end;
271  
272 < procedure TIBEvents.UpdateResultBuffer( length: short; updated: PChar);
357 < var
358 <  i: integer;
272 > procedure TIBEvents.DoBeforeDatabaseDisconnect(Sender: TObject);
273   begin
274 <  for i := 0 to length-1 do
361 <    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