ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBEvents.pas
Revision: 17
Committed: Sat Dec 28 19:22:24 2013 UTC (10 years, 3 months ago) by tony
Content type: text/x-pascal
File size: 15504 byte(s)
Log Message:
Committing updates for Release R1-0-5

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 }
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}
48
49 interface
50
51 uses
52 {$IFDEF WINDOWS }
53 Windows,
54 {$ELSE}
55 unix,
56 {$ENDIF}
57 Classes, Graphics, Controls,
58 Forms, Dialogs, IBHeader, IBExternals, IB, IBDatabase;
59
60 const
61 MaxEvents = 15;
62
63 type
64
65 TEventAlert = procedure( Sender: TObject; EventName: string; EventCount: longint;
66 var CancelAlerts: Boolean) of object;
67
68 { TIBEvents }
69
70 TIBEvents = class(TComponent)
71 private
72 FIBLoaded: Boolean;
73 FBase: TIBBase;
74 FEvents: TStrings;
75 FOnEventAlert: TEventAlert;
76 FEventHandler: TObject;
77 FRegistered: boolean;
78 FDeferredRegister: boolean;
79 procedure EventChange(sender: TObject);
80 function GetDatabase: TIBDatabase;
81 function GetDatabaseHandle: TISC_DB_HANDLE;
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 DatabaseHandle: TISC_DB_HANDLE read GetDatabaseHandle;
97 property DeferredRegister: boolean read FDeferredRegister write FDeferredRegister;
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
109 IBIntf, syncobjs;
110
111 type
112
113 TEventHandlerStates = (
114 stIdle, {Events not monitored}
115 stHasEvb, {Event Block Allocated but not queued}
116 stQueued, {Waiting for Event}
117 stSignalled {Event Callback signalled Event}
118 );
119
120 { TEventHandler }
121
122 TEventHandler = class(TThread)
123 private
124 FOwner: TIBEvents;
125 FCriticalSection: TCriticalSection; {protects race conditions in stQueued state}
126 {$IFDEF WINDOWS}
127 {Make direct use of Windows API as TEventObject don't seem to work under
128 Windows!}
129 FEventHandler: THandle;
130 {$ELSE}
131 FEventWaiting: TEventObject;
132 {$ENDIF}
133 FState: TEventHandlerStates;
134 FEventBuffer: PChar;
135 FEventBufferLen: integer;
136 FEventID: ISC_LONG;
137 FRegisteredState: Boolean;
138 FResultBuffer: PChar;
139 FEvents: TStringList;
140 FSignalFired: boolean;
141 procedure QueueEvents;
142 procedure CancelEvents;
143 procedure HandleEventSignalled(length: short; updated: PChar);
144 procedure DoEventSignalled;
145 protected
146 procedure Execute; override;
147 public
148 constructor Create(Owner: TIBEvents);
149 destructor Destroy; override;
150 procedure Terminate;
151 procedure RegisterEvents(Events: TStrings);
152 procedure UnregisterEvents;
153 end;
154
155 {This procedure is used for the event call back - note the cdecl }
156
157 procedure IBEventCallback( ptr: pointer; length: short; updated: PChar); cdecl;
158 begin
159 if (ptr = nil) or (length = 0) or (updated = nil) then
160 Exit;
161 { Handle events asynchronously in second thread }
162 TEventHandler(ptr).HandleEventSignalled(length,updated);
163 end;
164
165
166
167 { TEventHandler }
168
169 procedure TEventHandler.QueueEvents;
170 var
171 callback: pointer;
172 DBH: TISC_DB_HANDLE;
173 begin
174 if FState <> stHasEvb then
175 Exit;
176 FCriticalSection.Enter;
177 try
178 callback := @IBEventCallback;
179 DBH := FOwner.DatabaseHandle;
180 if (isc_que_events( StatusVector, @DBH, @FEventID, FEventBufferLen,
181 FEventBuffer, TISC_CALLBACK(callback), PVoid(Self)) <> 0) then
182 IBDatabaseError;
183 FState := stQueued
184 finally
185 FCriticalSection.Leave
186 end;
187 end;
188
189 procedure TEventHandler.CancelEvents;
190 var
191 DBH: TISC_DB_HANDLE;
192 begin
193 if FState in [stQueued,stSignalled] then
194 begin
195 FCriticalSection.Enter;
196 try
197 DBH := FOwner.DatabaseHandle;
198 if (isc_Cancel_events( StatusVector, @DBH, @FEventID) <> 0) then
199 IBDatabaseError;
200 FState := stHasEvb;
201 finally
202 FCriticalSection.Leave
203 end;
204 end;
205
206 if FState = stHasEvb then
207 begin
208 isc_free( FEventBuffer);
209 FEventBuffer := nil;
210 isc_free( FResultBuffer);
211 FResultBuffer := nil;
212 FState := stIdle
213 end;
214 FSignalFired := false
215 end;
216
217 procedure TEventHandler.HandleEventSignalled(length: short; updated: PChar);
218 begin
219 FCriticalSection.Enter;
220 try
221 if FState <> stQueued then
222 Exit;
223 Move(Updated[0], FResultBuffer[0], Length);
224 FState := stSignalled;
225 {$IFDEF WINDOWS}
226 SetEVent(FEventHandler);
227 {$ELSE}
228 FEventWaiting.SetEvent;
229 {$ENDIF}
230 finally
231 FCriticalSection.Leave
232 end;
233 end;
234
235 procedure TEventHandler.DoEventSignalled;
236 var
237 i: integer;
238 CancelAlerts: boolean;
239 Status: array[0..19] of ISC_LONG; {Note in 64 implementation the ibase.h implementation
240 is different from Interbase 6.0 API documentatoin}
241 begin
242 if FState <> stSignalled then
243 Exit;
244 isc_event_counts( @Status, FEventBufferLen, FEventBuffer, FResultBuffer);
245 CancelAlerts := false;
246 if not FSignalFired then
247 FSignalFired := true {Ignore first time}
248 else
249 if assigned(FOwner.FOnEventAlert) then
250 begin
251 for i := 0 to FEvents.Count - 1 do
252 begin
253 try
254 if (Status[i] <> 0) and not CancelAlerts then
255 FOwner.FOnEventAlert( self, FEvents[i], Status[i], CancelAlerts);
256 except
257 Application.HandleException( nil);
258 end;
259 end;
260 end;
261 FState := stHasEvb;
262 if CancelAlerts then
263 CancelEvents
264 else
265 QueueEvents
266 end;
267
268 procedure TEventHandler.Execute;
269 begin
270 while not Terminated do
271 begin
272 {$IFDEF WINDOWS}
273 WaitForSingleObject(FEventHandler,INFINITE);
274 {$ELSE}
275 FEventWaiting.WaitFor(INFINITE);
276 {$ENDIF}
277
278 if not Terminated and (FState = stSignalled) then
279 Synchronize(DoEventSignalled)
280 end;
281 end;
282
283
284
285 constructor TEventHandler.Create(Owner: TIBEvents);
286 var
287 PSa : PSecurityAttributes;
288 {$IFDEF WINDOWS}
289 Sd : TSecurityDescriptor;
290 Sa : TSecurityAttributes;
291 begin
292 InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
293 SetSecurityDescriptorDacl(@Sd,true,nil,false);
294 Sa.nLength := SizeOf(Sa);
295 Sa.lpSecurityDescriptor := @Sd;
296 Sa.bInheritHandle := true;
297 PSa := @Sa;
298 {$ELSE}
299 begin
300 PSa:= nil;
301 {$ENDIF}
302 inherited Create(true);
303 FOwner := Owner;
304 FState := stIdle;
305 FCriticalSection := TCriticalSection.Create;
306 {$IFDEF WINDOWS}
307 FEventHandler := CreateEvent(PSa,false,true,nil);
308 {$ELSE}
309 FEventWaiting := TEventObject.Create(PSa,false,true,FOwner.Name+'.Events');
310 {$ENDIF}
311 FEvents := TStringList.Create;
312 FreeOnTerminate := true;
313 Resume
314 end;
315
316 destructor TEventHandler.Destroy;
317 begin
318 if assigned(FCriticalSection) then FCriticalSection.Free;
319 {$IFDEF WINDOWS}
320 CloseHandle(FEventHandler);
321 {$ELSE}
322 if assigned(FEventWaiting) then FEventWaiting.Free;
323 {$ENDIF}
324 if assigned(FEvents) then FEvents.Free;
325 inherited Destroy;
326 end;
327
328 procedure TEventHandler.Terminate;
329 begin
330 inherited Terminate;
331 {$IFDEF WINDOWS}
332 SetEvent(FEventHandler);
333 {$ELSE}
334 FEventWaiting.SetEvent;
335 {$ENDIF}
336 CancelEvents;
337 end;
338
339 procedure TEventHandler.RegisterEvents(Events: TStrings);
340 var
341 i: integer;
342 EventNames: array of PChar;
343 begin
344 UnregisterEvents;
345
346 if Events.Count = 0 then
347 exit;
348
349 setlength(EventNames,MaxEvents);
350 try
351 for i := 0 to Events.Count-1 do
352 EventNames[i] := PChar(Events[i]);
353 FEvents.Assign(Events);
354 FEventBufferlen := isc_event_block(@FEventBuffer,@FResultBuffer,
355 Events.Count,
356 EventNames[0],EventNames[1],EventNames[2],
357 EventNames[3],EventNames[4],EventNames[5],
358 EventNames[6],EventNames[7],EventNames[8],
359 EventNames[9],EventNames[10],EventNames[11],
360 EventNames[12],EventNames[13],EventNames[14]
361 );
362 FState := stHasEvb;
363 FRegisteredState := true;
364 QueueEvents
365 finally
366 SetLength(EventNames,0)
367 end;
368 end;
369
370 procedure TEventHandler.UnregisterEvents;
371 begin
372 if FRegisteredState then
373 begin
374 CancelEvents;
375 FRegisteredState := false;
376 end;
377 end;
378
379 { TIBEvents }
380
381 procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
382 begin
383 if not assigned( Database) then
384 IBError(ibxeDatabaseNameMissing, [nil]);
385 if not Database.Connected then
386 IBError(ibxeDatabaseClosed, [nil]);
387 end;
388
389 constructor TIBEvents.Create( AOwner: TComponent);
390 begin
391 inherited Create( AOwner);
392 FIBLoaded := False;
393 CheckIBLoaded;
394 FIBLoaded := True;
395 FBase := TIBBase.Create(Self);
396 FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect;
397 FBase.AfterDatabaseConnect := DoAfterDatabaseConnect;
398 FEvents := TStringList.Create;
399 with TStringList( FEvents) do
400 begin
401 OnChange := EventChange;
402 Duplicates := dupIgnore;
403 end;
404 FEventHandler := TEventHandler.Create(self)
405 end;
406
407 destructor TIBEvents.Destroy;
408 begin
409 if FIBLoaded then
410 begin
411 UnregisterEvents;
412 SetDatabase(nil);
413 TStringList(FEvents).OnChange := nil;
414 FBase.Free;
415 FEvents.Free;
416 end;
417 if assigned(FEventHandler) then
418 TEventHandler(FEventHandler).Terminate;
419 FEventHandler := nil;
420 inherited Destroy;
421 end;
422
423
424
425 procedure TIBEvents.EventChange( sender: TObject);
426 begin
427 { check for blank event }
428 if TStringList(Events).IndexOf( '') <> -1 then
429 IBError(ibxeInvalidEvent, [nil]);
430 { check for too many events }
431 if Events.Count > MaxEvents then
432 begin
433 TStringList(Events).OnChange := nil;
434 Events.Delete( MaxEvents);
435 TStringList(Events).OnChange := EventChange;
436 IBError(ibxeMaximumEvents, [nil]);
437 end;
438 if Registered then
439 TEventHandler(FEventHandler).RegisterEvents(Events);
440 end;
441
442 procedure TIBEvents.Notification( AComponent: TComponent;
443 Operation: TOperation);
444 begin
445 inherited Notification( AComponent, Operation);
446 if (Operation = opRemove) and (AComponent = FBase.Database) then
447 begin
448 UnregisterEvents;
449 FBase.Database := nil;
450 end;
451 end;
452
453 procedure TIBEvents.RegisterEvents;
454 begin
455 ValidateDatabase( Database);
456 if csDesigning in ComponentState then FRegistered := true
457 else
458 begin
459 if not FBase.Database.Connected then
460 FDeferredRegister := true
461 else
462 begin
463 TEventHandler(FEventHandler).RegisterEvents(Events);
464 FRegistered := true;
465 end;
466 end;
467 end;
468
469 procedure TIBEvents.SetEvents( value: TStrings);
470 begin
471 FEvents.Assign( value);
472 end;
473
474 procedure TIBEvents.SetDatabase( value: TIBDatabase);
475 begin
476 if value <> FBase.Database then
477 begin
478 if Registered then UnregisterEvents;
479 if assigned( value) and value.Connected then ValidateDatabase( value);
480 FBase.Database := value;
481 if (FBase.Database <> nil) and FBase.Database.Connected then
482 DoAfterDatabaseConnect(FBase.Database)
483 end;
484 end;
485
486 function TIBEvents.GetDatabase: TIBDatabase;
487 begin
488 Result := FBase.Database
489 end;
490
491 procedure TIBEvents.SetRegistered( value: Boolean);
492 begin
493 FDeferredRegister := false;
494 if not assigned(FBase) or (FBase.Database = nil) then
495 begin
496 FDeferredRegister := value;
497 Exit;
498 end;
499
500 if value then RegisterEvents else UnregisterEvents;
501 end;
502
503 procedure TIBEvents.UnregisterEvents;
504 begin
505 FDeferredRegister := false;
506 if not FRegistered then
507 Exit;
508 if csDesigning in ComponentState then
509 FRegistered := false
510 else
511 begin
512 TEventHandler(FEventHandler).UnRegisterEvents;
513 FRegistered := false;
514 end;
515 end;
516
517 procedure TIBEvents.DoBeforeDatabaseDisconnect(Sender: TObject);
518 begin
519 UnregisterEvents;
520 end;
521
522 procedure TIBEvents.DoAfterDatabaseConnect(Sender: TObject);
523 begin
524 if FDeferredRegister then
525 Registered := true
526 end;
527
528 function TIBEvents.GetDatabaseHandle: TISC_DB_HANDLE;
529 begin
530 ValidateDatabase(FBase.Database);
531 Result := FBase.Database.Handle;
532 end;
533
534
535 end.