ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/nongui/IBEvents.pas
Revision: 209
Committed: Wed Mar 14 12:48:51 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
File size: 8872 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, IBExternals, 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 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 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 if CancelAlerts then
170 UnRegisterEvents
171 else
172 FEventIntf.AsyncWaitForEvent(@EventHandler);
173 end;
174
175 procedure TIBEvents.EventChange( sender: TObject);
176 begin
177 { check for blank event }
178 if TStringList(Events).IndexOf( '') <> -1 then
179 IBError(ibxeInvalidEvent, [nil]);
180 { check for too many events }
181 if Events.Count > MaxEvents then
182 begin
183 TStringList(Events).OnChange := nil;
184 Events.Delete( MaxEvents);
185 TStringList(Events).OnChange := @EventChange;
186 IBError(ibxeMaximumEvents, [nil]);
187 end;
188 if Registered and (FEventIntf <> nil) then
189 begin
190 FEventIntf.SetEvents(Events);
191 FEventIntf.AsyncWaitForEvent(@EventHandler);
192 end;
193 end;
194
195 procedure TIBEvents.Notification( AComponent: TComponent;
196 Operation: TOperation);
197 begin
198 inherited Notification( AComponent, Operation);
199 if (Operation = opRemove) and (AComponent = FBase.Database) then
200 begin
201 UnregisterEvents;
202 FBase.Database := nil;
203 end;
204 end;
205
206 procedure TIBEvents.RegisterEvents;
207 begin
208 if FRegistered then Exit;
209 ValidateDatabase( Database);
210 if csDesigning in ComponentState then FRegistered := true
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
224 procedure TIBEvents.SetEvents( value: TStrings);
225 begin
226 FEvents.Assign( value);
227 end;
228
229 procedure TIBEvents.SetDatabase( value: TIBDatabase);
230 begin
231 if value <> FBase.Database then
232 begin
233 if Registered then UnregisterEvents;
234 if assigned( value) and value.Connected then ValidateDatabase( 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 function TIBEvents.GetDatabase: TIBDatabase;
242 begin
243 Result := FBase.Database
244 end;
245
246 procedure TIBEvents.SetRegistered(value: boolean);
247 begin
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;
259 begin
260 FDeferredRegister := false;
261 if not FRegistered then
262 Exit;
263 if csDesigning in ComponentState then
264 FRegistered := false
265 else
266 begin
267 FEventIntf := nil;
268 FRegistered := false;
269 end;
270 end;
271
272 procedure TIBEvents.DoBeforeDatabaseDisconnect(Sender: TObject);
273 begin
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.