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 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 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;
65 <    EventID: ISC_LONG;
66 <    ProcessingEvents: Boolean;
67 <    RegisteredState: Boolean;
68 <    ResultBuffer: PChar;
69 <    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);
74 <    procedure UpdateResultBuffer( length: short; updated: PChar);
83 >    procedure DoBeforeDatabaseDisconnect(Sender: TObject);
84 >    procedure DoAfterDatabaseConnect(Sender: TObject);
85    protected
76 –    procedure HandleEvent;
77 –    procedure Loaded; override;
86      procedure Notification( AComponent: TComponent; Operation: TOperation); override;
87      procedure SetEvents( value: TStrings);
88      procedure SetRegistered( value: boolean);
81 –    function  GetNativeHandle: TISC_DB_HANDLE;
89  
90    public
91      constructor Create( AOwner: TComponent); override;
92      destructor Destroy; override;
86 –    procedure CancelEvents;
87 –    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
101 <  IBIntf;
107 > uses SysUtils, FBMessages;
108  
109 < 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;
109 > { TIBEvents }
110  
111   procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
112   begin
# Line 115 | Line 116 | begin
116      IBError(ibxeDatabaseClosed, [nil]);
117   end;
118  
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 –
119   constructor TIBEvents.Create( AOwner: TComponent);
120   begin
121    inherited Create( AOwner);
122 <  FIBLoaded := False;
123 <  CheckIBLoaded;
124 <  FIBLoaded := True;
147 <  InitCriticalSection( 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;
140 <    FEvents.Free;
141 <    DoneCriticalSection( CS);
142 <  end;
143 <  inherited Destroy;
135 >  UnregisterEvents;
136 >  SetDatabase(nil);
137 >  TStringList(FEvents).OnChange := nil;
138 >  FBase.Free;
139 >  FEvents.Free;
140 > end;
141 >
142 > procedure TIBEvents.EventHandler(Sender: IEvents);
143 > begin
144 >  TThread.Synchronize(nil,@ProcessEvents);
145   end;
146  
147 < procedure TIBEvents.CancelEvents;
147 > procedure TIBEvents.ProcessEvents;
148 > var EventCounts: TEventCounts;
149 >    CancelAlerts: Boolean;
150 >    i: integer;
151   begin
152 <  if ProcessingEvents then
153 <    IBError(ibxeInvalidCancellation, [nil]);  
154 <  if FQueued then
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;
180 <      Changing := true;
181 <      if (isc_Cancel_events( StatusVector, @FDatabase.Handle, @EventID) > 0) then
182 <        IBDatabaseError;
183 <    finally
184 <      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
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;
163 >  if CancelAlerts then
164 >    UnRegisterEvents
165 >  else
166 >    FEventIntf.AsyncWaitForEvent(@EventHandler);
167   end;
168  
169   procedure TIBEvents.EventChange( sender: TObject);
# Line 208 | 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;
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;
182 >  if Registered  and (FEventIntf <> nil) then
183 >  begin
184 >    FEventIntf.SetEvents(Events);
185 >    FEventIntf.AsyncWaitForEvent(@EventHandler);
186    end;
187   end;
188  
# Line 263 | 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;
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;
196 >    FBase.Database := nil;
197    end;
198   end;
199  
200   procedure TIBEvents.RegisterEvents;
293 – var
294 –  i: integer;
295 –  EventNames: array of PChar;
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 <    setlength(EventNames,Events.Count);
209 <    for i := 0 to Events.Count-1 do
210 <      EventNames[i] := PChar(Events[i]);
211 <
212 <    EventBufferlen := isc_event_block(@EventBuffer,@ResultBuffer,
213 <                        Events.Count,EventNames);
214 <    FRegistered := true;
309 <    QueueEvents;
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;
215    end;
216   end;
217  
# Line 317 | 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;
345 <    if FRegistered then
346 <    begin
347 <      isc_free( EventBuffer);
348 <      EventBuffer := nil;
349 <      isc_free( ResultBuffer);
350 <      ResultBuffer := nil;
351 <    end;
261 >    FEventIntf := nil;
262      FRegistered := false;
263    end;
264   end;
265  
266 < procedure TIBEvents.UpdateResultBuffer( length: short; updated: PChar);
357 < var
358 <  i: integer;
266 > procedure TIBEvents.DoBeforeDatabaseDisconnect(Sender: TObject);
267   begin
268 <  for i := 0 to length-1 do
361 <    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