ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBEvents.pas
Revision: 271
Committed: Fri Jan 18 13:35:28 2019 UTC (5 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 8880 byte(s)
Log Message:
Fixes merged

File Contents

# Content
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 - 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 {$IFDEF WINDOWS }
53 Windows,
54 {$ELSE}
55 unix,
56 {$ENDIF}
57 Classes, IB, IBDatabase;
58
59 const
60 MaxEvents = 15;
61
62 type
63
64 TEventAlert = procedure( Sender: TObject; EventName: string; EventCount: longint;
65 var CancelAlerts: Boolean) of object;
66
67 { TIBEvents }
68
69 TIBEvents = class(TComponent)
70 private
71 FBase: TIBBase;
72 FEventIntf: IEvents;
73 FEvents: TStrings;
74 FOnEventAlert: TEventAlert;
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 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 DeferredRegister: boolean read FDeferredRegister write FDeferredRegister;
97 property EventIntf: IEvents read FEventIntf;
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 SysUtils, FBMessages;
109
110 { TIBEvents }
111
112 procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
113 begin
114 if not assigned( Database) then
115 IBError(ibxeDatabaseNameMissing, [nil]);
116 if not Database.Connected then
117 IBError(ibxeDatabaseClosed, [nil]);
118 end;
119
120 constructor TIBEvents.Create( AOwner: TComponent);
121 begin
122 inherited Create( AOwner);
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;
131 Duplicates := dupIgnore;
132 end;
133 end;
134
135 destructor TIBEvents.Destroy;
136 begin
137 UnregisterEvents;
138 SetDatabase(nil);
139 TStringList(FEvents).OnChange := nil;
140 FBase.Free;
141 FEvents.Free;
142 inherited Destroy;
143 end;
144
145 procedure TIBEvents.EventHandler(Sender: IEvents);
146 begin
147 TThread.Synchronize(nil,@ProcessEvents);
148 end;
149
150 procedure TIBEvents.ProcessEvents;
151 var EventCounts: TEventCounts;
152 CancelAlerts: Boolean;
153 i: integer;
154 begin
155 if (csDestroying in ComponentState) or (FEventIntf = nil) then Exit;
156 CancelAlerts := false;
157 EventCounts := FEventIntf.ExtractEventCounts;
158 if FStartEvent then
159 FStartEvent := false {ignore the first one}
160 else
161 if assigned(FOnEventAlert) then
162 begin
163 CancelAlerts := false;
164 for i := 0 to Length(EventCounts) -1 do
165 begin
166 OnEventAlert(self,EventCounts[i].EventName,EventCounts[i].Count,CancelAlerts);
167 if CancelAlerts then break;
168 end;
169 end;
170 if CancelAlerts then
171 UnRegisterEvents
172 else
173 FEventIntf.AsyncWaitForEvent(@EventHandler);
174 end;
175
176 procedure TIBEvents.EventChange( sender: TObject);
177 begin
178 { check for blank event }
179 if TStringList(Events).IndexOf( '') <> -1 then
180 IBError(ibxeInvalidEvent, [nil]);
181 { check for too many events }
182 if Events.Count > MaxEvents then
183 begin
184 TStringList(Events).OnChange := nil;
185 Events.Delete( MaxEvents);
186 TStringList(Events).OnChange := @EventChange;
187 IBError(ibxeMaximumEvents, [nil]);
188 end;
189 if Registered and (FEventIntf <> nil) then
190 begin
191 FEventIntf.SetEvents(Events);
192 FEventIntf.AsyncWaitForEvent(@EventHandler);
193 end;
194 end;
195
196 procedure TIBEvents.Notification( AComponent: TComponent;
197 Operation: TOperation);
198 begin
199 inherited Notification( AComponent, Operation);
200 if (Operation = opRemove) and (AComponent = FBase.Database) then
201 begin
202 UnregisterEvents;
203 FBase.Database := nil;
204 end;
205 end;
206
207 procedure TIBEvents.RegisterEvents;
208 begin
209 if FRegistered then Exit;
210 ValidateDatabase( Database);
211 if csDesigning in ComponentState then FRegistered := true
212 else
213 begin
214 if not FBase.Database.Connected then
215 FDeferredRegister := true
216 else
217 begin
218 FEventIntf := Database.Attachment.GetEventHandler(Events);
219 FEventIntf.AsyncWaitForEvent(@EventHandler);
220 FRegistered := true;
221 end;
222 end;
223 end;
224
225 procedure TIBEvents.SetEvents( value: TStrings);
226 begin
227 FEvents.Assign( value);
228 end;
229
230 procedure TIBEvents.SetDatabase( value: TIBDatabase);
231 begin
232 if value <> FBase.Database then
233 begin
234 if Registered then UnregisterEvents;
235 if assigned( value) and value.Connected then ValidateDatabase( value);
236 FBase.Database := value;
237 if (FBase.Database <> nil) and FBase.Database.Connected then
238 DoAfterDatabaseConnect(FBase.Database)
239 end;
240 end;
241
242 function TIBEvents.GetDatabase: TIBDatabase;
243 begin
244 Result := FBase.Database
245 end;
246
247 procedure TIBEvents.SetRegistered(value: boolean);
248 begin
249 FDeferredRegister := false;
250 if not assigned(FBase) or (FBase.Database = nil) then
251 begin
252 FDeferredRegister := value;
253 Exit;
254 end;
255
256 if value then RegisterEvents else UnregisterEvents;
257 end;
258
259 procedure TIBEvents.UnRegisterEvents;
260 begin
261 FDeferredRegister := false;
262 if not FRegistered then
263 Exit;
264 if csDesigning in ComponentState then
265 FRegistered := false
266 else
267 begin
268 FEventIntf := nil;
269 FRegistered := false;
270 end;
271 end;
272
273 procedure TIBEvents.DoBeforeDatabaseDisconnect(Sender: TObject);
274 begin
275 UnregisterEvents;
276 end;
277
278 procedure TIBEvents.DoAfterDatabaseConnect(Sender: TObject);
279 begin
280 if FDeferredRegister then
281 Registered := true
282 end;
283
284
285 end.