ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/runtime/IBEvents.pas
Revision: 7
Committed: Sun Aug 5 18:28:19 2012 UTC (11 years, 7 months ago) by tony
Content type: text/x-pascal
File size: 14969 byte(s)
Log Message:
Committing updates for Release R1-0-0

File Contents

# User Rev Content
1 tony 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 tony 7 { 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 tony 1 {************************************************************************}
33    
34 tony 7 {
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 tony 1 unit IBEvents;
46    
47 tony 5 {$Mode Delphi}
48    
49 tony 1 interface
50    
51     uses
52 tony 7 {$IFDEF WINDOWS }
53     Windows,
54 tony 5 {$ELSE}
55 tony 7 unix,
56     {$ENDIF}
57     Classes, Graphics, Controls,
58 tony 5 Forms, Dialogs, IBHeader, IBExternals, IB, IBDatabase;
59 tony 1
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 tony 7 { TIBEvents }
69 tony 1
70     TIBEvents = class(TComponent)
71     private
72     FIBLoaded: Boolean;
73 tony 7 FBase: TIBBase;
74 tony 1 FEvents: TStrings;
75     FOnEventAlert: TEventAlert;
76 tony 7 FEventHandler: TObject;
77     FRegistered: boolean;
78     FDeferredRegister: boolean;
79     procedure EventChange(sender: TObject);
80     function GetDatabase: TIBDatabase;
81     function GetDatabaseHandle: TISC_DB_HANDLE;
82 tony 1 procedure SetDatabase( value: TIBDatabase);
83     procedure ValidateDatabase( Database: TIBDatabase);
84 tony 7 procedure DoBeforeDatabaseDisconnect(Sender: TObject);
85     procedure DoAfterDatabaseConnect(Sender: TObject);
86 tony 1 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 tony 7 property DatabaseHandle: TISC_DB_HANDLE read GetDatabaseHandle;
97     property DeferredRegister: boolean read FDeferredRegister write FDeferredRegister;
98 tony 1 published
99 tony 7 property Database: TIBDatabase read GetDatabase write SetDatabase;
100 tony 1 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 tony 7
106 tony 1 implementation
107    
108     uses
109 tony 7 IBIntf, syncobjs;
110 tony 1
111 tony 7 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 tony 1 begin
159 tony 7 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 tony 1 end;
164    
165 tony 7
166    
167     { TEventHandler }
168    
169     procedure TEventHandler.QueueEvents;
170     var
171     callback: pointer;
172     DBH: TISC_DB_HANDLE;
173 tony 1 begin
174 tony 7 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 tony 1 end;
188    
189 tony 7 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 tony 1
206 tony 7 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 tony 1 begin
219 tony 7 FCriticalSection.Enter;
220 tony 1 try
221 tony 7 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 tony 1 end;
233     end;
234    
235 tony 7 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 tony 1 begin
242 tony 7 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 tony 1 end;
267    
268 tony 7 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 tony 1 constructor TIBEvents.Create( AOwner: TComponent);
390     begin
391     inherited Create( AOwner);
392     FIBLoaded := False;
393     CheckIBLoaded;
394     FIBLoaded := True;
395 tony 7 FBase := TIBBase.Create(Self);
396     FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect;
397     FBase.AfterDatabaseConnect := DoAfterDatabaseConnect;
398 tony 1 FEvents := TStringList.Create;
399     with TStringList( FEvents) do
400     begin
401     OnChange := EventChange;
402     Duplicates := dupIgnore;
403     end;
404 tony 7 FEventHandler := TEventHandler.Create(self)
405 tony 1 end;
406    
407     destructor TIBEvents.Destroy;
408     begin
409     if FIBLoaded then
410     begin
411     UnregisterEvents;
412 tony 7 SetDatabase(nil);
413 tony 1 TStringList(FEvents).OnChange := nil;
414 tony 7 FBase.Free;
415 tony 1 FEvents.Free;
416     end;
417 tony 7 if assigned(FEventHandler) then
418     TEventHandler(FEventHandler).Terminate;
419     FEventHandler := nil;
420 tony 1 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 tony 7 if Registered then
439     TEventHandler(FEventHandler).RegisterEvents(Events);
440 tony 1 end;
441    
442     procedure TIBEvents.Notification( AComponent: TComponent;
443     Operation: TOperation);
444     begin
445     inherited Notification( AComponent, Operation);
446 tony 7 if (Operation = opRemove) and (AComponent = FBase.Database) then
447 tony 1 begin
448     UnregisterEvents;
449 tony 7 FBase.Database := nil;
450 tony 1 end;
451     end;
452    
453     procedure TIBEvents.RegisterEvents;
454     begin
455     ValidateDatabase( Database);
456     if csDesigning in ComponentState then FRegistered := true
457 tony 7 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 tony 1 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 tony 7 if value <> FBase.Database then
477 tony 1 begin
478 tony 7 if Registered then UnregisterEvents;
479 tony 1 if assigned( value) and value.Connected then ValidateDatabase( value);
480 tony 7 FBase.Database := value;
481     if (FBase.Database <> nil) and FBase.Database.Connected then
482     DoAfterDatabaseConnect(FBase.Database)
483 tony 1 end;
484     end;
485    
486 tony 7 function TIBEvents.GetDatabase: TIBDatabase;
487     begin
488     Result := FBase.Database
489     end;
490    
491 tony 1 procedure TIBEvents.SetRegistered( value: Boolean);
492     begin
493 tony 7 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 tony 1 end;
502    
503     procedure TIBEvents.UnregisterEvents;
504     begin
505 tony 7 FDeferredRegister := false;
506     if not FRegistered then
507     Exit;
508 tony 1 if csDesigning in ComponentState then
509     FRegistered := false
510 tony 7 else
511 tony 1 begin
512 tony 7 TEventHandler(FEventHandler).UnRegisterEvents;
513 tony 1 FRegistered := false;
514     end;
515     end;
516    
517 tony 7 procedure TIBEvents.DoBeforeDatabaseDisconnect(Sender: TObject);
518 tony 1 begin
519 tony 7 UnregisterEvents;
520 tony 1 end;
521    
522 tony 7 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 tony 1 end.