ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBEvents.pas
Revision: 5
Committed: Fri Feb 18 16:26:16 2011 UTC (13 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 10491 byte(s)
Log Message:
Committing updates for Release pre-release

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 {************************************************************************}
28
29 unit IBEvents;
30
31 {$Mode Delphi}
32
33 interface
34
35 uses
36 {$IFDEF LINUX }
37 {$IFNDEF DESIGNTIME} cthreads,{$ENDIF}unix,
38 {$ELSE}
39 Windows,
40 {$ENDIF} Classes, Graphics, Controls,
41 Forms, Dialogs, IBHeader, IBExternals, IB, IBDatabase;
42
43 const
44 MaxEvents = 15;
45 EventLength = 64;
46
47 type
48
49 TEventAlert = procedure( Sender: TObject; EventName: string; EventCount: longint;
50 var CancelAlerts: Boolean) of object;
51
52 TEventBuffer = array[ 0..MaxEvents-1, 0..EventLength-1] of char;
53
54 TIBEvents = class(TComponent)
55 private
56 FIBLoaded: Boolean;
57 FEvents: TStrings;
58 FOnEventAlert: TEventAlert;
59 FQueued: Boolean;
60 FRegistered: Boolean;
61 Changing: Boolean;
62 CS: TRTLCriticalSection;
63 EventBuffer: PChar;
64 EventBufferLen: integer;
65 EventID: ISC_LONG;
66 ProcessingEvents: Boolean;
67 RegisteredState: Boolean;
68 ResultBuffer: PChar;
69 FDatabase: TIBDatabase;
70 procedure SetDatabase( value: TIBDatabase);
71 procedure ValidateDatabase( Database: TIBDatabase);
72 procedure DoQueueEvents;
73 procedure EventChange( sender: TObject);
74 procedure UpdateResultBuffer( length: short; updated: PChar);
75 protected
76 procedure HandleEvent;
77 procedure Loaded; override;
78 procedure Notification( AComponent: TComponent; Operation: TOperation); override;
79 procedure SetEvents( value: TStrings);
80 procedure SetRegistered( value: boolean);
81 function GetNativeHandle: TISC_DB_HANDLE;
82
83 public
84 constructor Create( AOwner: TComponent); override;
85 destructor Destroy; override;
86 procedure CancelEvents;
87 procedure QueueEvents;
88 procedure RegisterEvents;
89 procedure UnRegisterEvents;
90 property Queued: Boolean read FQueued;
91 published
92 property Database: TIBDatabase read FDatabase write SetDatabase;
93 property Events: TStrings read FEvents write SetEvents;
94 property Registered: Boolean read FRegistered write SetRegistered;
95 property OnEventAlert: TEventAlert read FOnEventAlert write FOnEventAlert;
96 end;
97
98 implementation
99
100 uses
101 IBIntf;
102
103 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
110 procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
111 begin
112 if not assigned( Database) then
113 IBError(ibxeDatabaseNameMissing, [nil]);
114 if not Database.Connected then
115 IBError(ibxeDatabaseClosed, [nil]);
116 end;
117
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
141 constructor TIBEvents.Create( AOwner: TComponent);
142 begin
143 inherited Create( AOwner);
144 FIBLoaded := False;
145 CheckIBLoaded;
146 FIBLoaded := True;
147 InitCriticalSection( CS);
148 FEvents := TStringList.Create;
149 with TStringList( FEvents) do
150 begin
151 OnChange := EventChange;
152 Duplicates := dupIgnore;
153 end;
154 end;
155
156 destructor TIBEvents.Destroy;
157 begin
158 if FIBLoaded then
159 begin
160 UnregisterEvents;
161 SetDatabase( nil);
162 TStringList(FEvents).OnChange := nil;
163 FEvents.Free;
164 DoneCriticalSection( CS);
165 end;
166 inherited Destroy;
167 end;
168
169 procedure TIBEvents.CancelEvents;
170 begin
171 if ProcessingEvents then
172 IBError(ibxeInvalidCancellation, [nil]);
173 if FQueued then
174 begin
175 try
176 { wait for event handler to finish before cancelling events }
177 EnterCriticalSection( CS);
178 ValidateDatabase( Database);
179 FQueued := false;
180 Changing := true;
181 if (isc_Cancel_events( StatusVector, @FDatabase.Handle, @EventID) > 0) then
182 IBDatabaseError;
183 finally
184 LeaveCriticalSection( CS);
185 end;
186 end;
187 end;
188
189 procedure TIBEvents.DoQueueEvents;
190 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;
199 end;
200
201 procedure TIBEvents.EventChange( sender: TObject);
202 begin
203 { check for blank event }
204 if TStringList(Events).IndexOf( '') <> -1 then
205 IBError(ibxeInvalidEvent, [nil]);
206 { check for too many events }
207 if Events.Count > MaxEvents then
208 begin
209 TStringList(Events).OnChange := nil;
210 Events.Delete( MaxEvents);
211 TStringList(Events).OnChange := EventChange;
212 IBError(ibxeMaximumEvents, [nil]);
213 end;
214 if Registered then RegisterEvents;
215 end;
216
217 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;
259 end;
260 end;
261
262 procedure TIBEvents.Notification( AComponent: TComponent;
263 Operation: TOperation);
264 begin
265 inherited Notification( AComponent, Operation);
266 if (Operation = opRemove) and (AComponent = FDatabase) then
267 begin
268 UnregisterEvents;
269 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;
289 end;
290 end;
291
292 procedure TIBEvents.RegisterEvents;
293 var
294 i: integer;
295 EventNames: array of PChar;
296 begin
297 ValidateDatabase( Database);
298 if csDesigning in ComponentState then FRegistered := true
299 else begin
300 UnregisterEvents;
301 if Events.Count = 0 then exit;
302 setlength(EventNames,Events.Count);
303 for i := 0 to Events.Count-1 do
304 EventNames[i] := PChar(Events[i]);
305
306 EventBufferlen := isc_event_block(@EventBuffer,@ResultBuffer,
307 Events.Count,EventNames);
308 FRegistered := true;
309 QueueEvents;
310 end;
311 end;
312
313 procedure TIBEvents.SetEvents( value: TStrings);
314 begin
315 FEvents.Assign( value);
316 end;
317
318 procedure TIBEvents.SetDatabase( value: TIBDatabase);
319 begin
320 if value <> FDatabase then
321 begin
322 UnregisterEvents;
323 if assigned( value) and value.Connected then ValidateDatabase( value);
324 FDatabase := value;
325 end;
326 end;
327
328 procedure TIBEvents.SetRegistered( value: Boolean);
329 begin
330 if (csReading in ComponentState) then
331 RegisteredState := value
332 else if FRegistered <> value then
333 if value then RegisterEvents else UnregisterEvents;
334 end;
335
336 procedure TIBEvents.UnregisterEvents;
337 begin
338 if ProcessingEvents then
339 IBError(ibxeInvalidRegistration, [nil]);
340 if csDesigning in ComponentState then
341 FRegistered := false
342 else if not (csLoading in ComponentState) then
343 begin
344 CancelEvents;
345 if FRegistered then
346 begin
347 isc_free( EventBuffer);
348 EventBuffer := nil;
349 isc_free( ResultBuffer);
350 ResultBuffer := nil;
351 end;
352 FRegistered := false;
353 end;
354 end;
355
356 procedure TIBEvents.UpdateResultBuffer( length: short; updated: PChar);
357 var
358 i: integer;
359 begin
360 for i := 0 to length-1 do
361 ResultBuffer[i] := updated[i];
362 end;
363
364 end.