trunk/runtime/IBEvents.pas

{************************************************************************}
{                                                                        }
{       Borland Delphi Visual Component Library                          }
{       InterBase Express core components                                }
{                                                                        }
{       Copyright (c) 1998-2000 Inprise Corporation                      }
{                                                                        }
{    InterBase Express is based in part on the product                   }
{    Free IB Components, written by Gregory H. Deatz for                 }
{    Hoagland, Longo, Moran, Dunst & Doukas Company.                     }
{    Free IB Components is used under license.                           }
{                                                                        }
{    The contents of this file are subject to the InterBase              }
{    Public License Version 1.0 (the "License"); you may not             }
{    use this file except in compliance with the License. You            }
{    may obtain a copy of the License at http://www.Inprise.com/IPL.html }
{    Software distributed under the License is distributed on            }
{    an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either              }
{    express or implied. See the License for the specific language       }
{    governing rights and limitations under the License.                 }
{    The Original Code was created by InterBase Software Corporation     }
{       and its successors.                                              }
{    Portions created by Inprise Corporation are Copyright (C) Inprise   }
{       Corporation. All Rights Reserved.                                }
{    Contributor(s): Jeff Overcash                                       }
{                                                                        }
{    IBX For Lazarus (Firebird Express)                                  }
{    Contributor: Tony Whyman, MWA Software http://www.mwasoftware.co.uk }
{    Portions created by MWA Software are copyright McCallum Whyman      }
{    Associates Ltd 2011                                                 }
{                                                                        }
{************************************************************************}

{
  This unit has been almost completely re-written as the original code was
  not that robust - and I am not even sure if it worked. The IBPP C++ implementation
  was used for guidance and inspiration. A permanent thread is used to receive
  events from the asynchronous event handler. This then uses "Synchronize" to
  process the event in the main thread.

  Note that an error will occur if the TIBEvent's Registered property is set to
  true before the Database has been opened.
}

unit IBEvents;

{$Mode Delphi}

interface

uses
{$IFDEF WINDOWS }
  Windows,
{$ELSE}
  unix,
{$ENDIF}
  Classes, Graphics, Controls,
  Forms, Dialogs, IBHeader, IBExternals, IB, IBDatabase;

const
  MaxEvents = 15;

type

  TEventAlert = procedure( Sender: TObject; EventName: string; EventCount: longint;
                           var CancelAlerts: Boolean) of object;

  { TIBEvents }

  TIBEvents = class(TComponent)
  private
    FIBLoaded: Boolean;
    FBase: TIBBase;
    FEvents: TStrings;
    FOnEventAlert: TEventAlert;
    FEventHandler: TObject;
    FRegistered: boolean;
    FDeferredRegister: boolean;
    procedure EventChange(sender: TObject);
    function GetDatabase: TIBDatabase;
    function GetDatabaseHandle: TISC_DB_HANDLE;
    procedure SetDatabase( value: TIBDatabase);
    procedure ValidateDatabase( Database: TIBDatabase);
    procedure DoBeforeDatabaseDisconnect(Sender: TObject);
    procedure DoAfterDatabaseConnect(Sender: TObject);
  protected
    procedure Notification( AComponent: TComponent; Operation: TOperation); override;
    procedure SetEvents( value: TStrings);
    procedure SetRegistered( value: boolean);

  public
    constructor Create( AOwner: TComponent); override;
    destructor Destroy; override;
    procedure RegisterEvents;
    procedure UnRegisterEvents;
    property DatabaseHandle: TISC_DB_HANDLE read GetDatabaseHandle;
    property DeferredRegister: boolean read FDeferredRegister write FDeferredRegister;
  published
    property Database: TIBDatabase read GetDatabase write SetDatabase;
    property Events: TStrings read FEvents write SetEvents;
    property Registered: Boolean read FRegistered write SetRegistered;
    property OnEventAlert: TEventAlert read FOnEventAlert write FOnEventAlert;
  end;


implementation

uses
  IBIntf, syncobjs;

type

  TEventHandlerStates = (
    stIdle,           {Events not monitored}
    stHasEvb,         {Event Block Allocated but not queued}
    stQueued,         {Waiting for Event}
    stSignalled       {Event Callback signalled Event}
   );

  { TEventHandler }

  TEventHandler = class(TThread)
  private
    FOwner: TIBEvents;
    FCriticalSection: TCriticalSection;   {protects race conditions in stQueued state}
    {$IFDEF WINDOWS}
    {Make direct use of Windows API as TEventObject don't seem to work under
     Windows!}
    FEventHandler: THandle;
    {$ELSE}
    FEventWaiting: TEventObject;
    {$ENDIF}
    FState: TEventHandlerStates;
    FEventBuffer: PChar;
    FEventBufferLen: integer;
    FEventID: ISC_LONG;
    FRegisteredState: Boolean;
    FResultBuffer: PChar;
    FEvents: TStringList;
    FSignalFired: boolean;
    procedure QueueEvents;
    procedure CancelEvents;
    procedure HandleEventSignalled(length: short; updated: PChar);
    procedure DoEventSignalled;
  protected
    procedure Execute; override;
  public
    constructor Create(Owner: TIBEvents);
    destructor Destroy; override;
    procedure Terminate;
    procedure RegisterEvents(Events: TStrings);
    procedure UnregisterEvents;
  end;

 {This procedure is used for the event call back - note the cdecl }

procedure IBEventCallback( ptr: pointer; length: short; updated: PChar); cdecl;
begin
  if (ptr = nil) or (length = 0) or (updated = nil) then
    Exit;
  { Handle events asynchronously in second thread }
  TEventHandler(ptr).HandleEventSignalled(length,updated);
end;


{ TEventHandler }

procedure TEventHandler.QueueEvents;
var
  callback: pointer;
  DBH: TISC_DB_HANDLE;
begin
  if FState <> stHasEvb then
    Exit;
  FCriticalSection.Enter;
  try
    callback := @IBEventCallback;
    DBH := FOwner.DatabaseHandle;
    if (isc_que_events( StatusVector, @DBH, @FEventID, FEventBufferLen,
                     FEventBuffer, TISC_CALLBACK(callback), PVoid(Self)) <> 0) then
      IBDatabaseError;
    FState := stQueued
  finally
    FCriticalSection.Leave
  end;
end;

procedure TEventHandler.CancelEvents;
var
  DBH: TISC_DB_HANDLE;
begin
  if FState in [stQueued,stSignalled] then
  begin
    FCriticalSection.Enter;
    try
      DBH := FOwner.DatabaseHandle;
      if (isc_Cancel_events( StatusVector, @DBH, @FEventID) <> 0) then
          IBDatabaseError;
      FState := stHasEvb;
    finally
      FCriticalSection.Leave
    end;
  end;

  if FState = stHasEvb then
  begin
    isc_free( FEventBuffer);
    FEventBuffer := nil;
    isc_free( FResultBuffer);
    FResultBuffer := nil;
    FState := stIdle
  end;
  FSignalFired := false
end;

procedure TEventHandler.HandleEventSignalled(length: short; updated: PChar);
begin
  FCriticalSection.Enter;
  try
    if FState <> stQueued then
      Exit;
    Move(Updated[0], FResultBuffer[0], Length);
    FState := stSignalled;
    {$IFDEF WINDOWS}
    SetEVent(FEventHandler);
    {$ELSE}
    FEventWaiting.SetEvent;
    {$ENDIF}
  finally
    FCriticalSection.Leave
  end;
end;

procedure TEventHandler.DoEventSignalled;
var
  i: integer;
  CancelAlerts: boolean;
  Status: array[0..19] of ISC_LONG; {Note in 64 implementation the ibase.h implementation
                                     is different from Interbase 6.0 API documentatoin}
begin
    if FState <> stSignalled then
      Exit;
    isc_event_counts( @Status, FEventBufferLen, FEventBuffer, FResultBuffer);
    CancelAlerts := false;
    if not FSignalFired then
      FSignalFired := true   {Ignore first time}
    else
    if assigned(FOwner.FOnEventAlert)  then
    begin
      for i := 0 to FEvents.Count - 1 do
      begin
        try
        if (Status[i] <> 0) and not CancelAlerts then
            FOwner.FOnEventAlert( self, FEvents[i], Status[i], CancelAlerts);
        except
          Application.HandleException( nil);
        end;
      end;
    end;
    FState := stHasEvb;
  if  CancelAlerts then
      CancelEvents
    else
      QueueEvents
end;

procedure TEventHandler.Execute;
begin
  while not Terminated do
  begin
    {$IFDEF WINDOWS}
    WaitForSingleObject(FEventHandler,INFINITE);
    {$ELSE}
    FEventWaiting.WaitFor(INFINITE);
    {$ENDIF}

    if not Terminated and (FState = stSignalled) then
      Synchronize(DoEventSignalled)
  end;
end;


constructor TEventHandler.Create(Owner: TIBEvents);
var
  PSa : PSecurityAttributes;
{$IFDEF WINDOWS}
  Sd : TSecurityDescriptor;
  Sa : TSecurityAttributes;
begin
  InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
  SetSecurityDescriptorDacl(@Sd,true,nil,false);
  Sa.nLength := SizeOf(Sa);
  Sa.lpSecurityDescriptor := @Sd;
  Sa.bInheritHandle := true;
  PSa := @Sa;
{$ELSE}
begin
  PSa:= nil;
{$ENDIF}
  inherited Create(true);
  FOwner := Owner;
  FState := stIdle;
  FCriticalSection := TCriticalSection.Create;
  {$IFDEF WINDOWS}
  FEventHandler := CreateEvent(PSa,false,true,nil);
  {$ELSE}
  FEventWaiting := TEventObject.Create(PSa,false,true,FOwner.Name+'.Events');
  {$ENDIF}
  FEvents := TStringList.Create;
  FreeOnTerminate := true;
  Resume
end;

destructor TEventHandler.Destroy;
begin
  if assigned(FCriticalSection) then FCriticalSection.Free;
  {$IFDEF WINDOWS}
  CloseHandle(FEventHandler);
  {$ELSE}
  if assigned(FEventWaiting) then FEventWaiting.Free;
  {$ENDIF}
  if assigned(FEvents) then FEvents.Free;
  inherited Destroy;
end;

procedure TEventHandler.Terminate;
begin
  inherited Terminate;
  {$IFDEF WINDOWS}
  SetEvent(FEventHandler);
  {$ELSE}
  FEventWaiting.SetEvent;
  {$ENDIF}
  CancelEvents;
end;

procedure TEventHandler.RegisterEvents(Events: TStrings);
var
  i: integer;
  EventNames: array of PChar;
begin
  UnregisterEvents;

  if Events.Count = 0 then
    exit;

  setlength(EventNames,MaxEvents);
  try
    for i := 0 to Events.Count-1 do
      EventNames[i] := PChar(Events[i]);
    FEvents.Assign(Events);
    FEventBufferlen := isc_event_block(@FEventBuffer,@FResultBuffer,
                        Events.Count,
                        EventNames[0],EventNames[1],EventNames[2],
                        EventNames[3],EventNames[4],EventNames[5],
                        EventNames[6],EventNames[7],EventNames[8],
                        EventNames[9],EventNames[10],EventNames[11],
                        EventNames[12],EventNames[13],EventNames[14]
                        );
    FState := stHasEvb;
    FRegisteredState := true;
    QueueEvents
  finally
    SetLength(EventNames,0)
  end;
end;

procedure TEventHandler.UnregisterEvents;
begin
  if FRegisteredState then
  begin
    CancelEvents;
    FRegisteredState := false;
  end;
end;

{ TIBEvents }

procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
begin
  if not assigned( Database) then
    IBError(ibxeDatabaseNameMissing, [nil]);
  if not Database.Connected then
    IBError(ibxeDatabaseClosed, [nil]);
end;

constructor TIBEvents.Create( AOwner: TComponent);
begin
  inherited Create( AOwner);
  FIBLoaded := False;
  CheckIBLoaded;
  FIBLoaded := True;
  FBase := TIBBase.Create(Self);
  FBase.BeforeDatabaseDisconnect := DoBeforeDatabaseDisconnect;
  FBase.AfterDatabaseConnect := DoAfterDatabaseConnect;
  FEvents := TStringList.Create;
  with TStringList( FEvents) do
  begin
    OnChange := EventChange;
    Duplicates := dupIgnore;
  end;
  FEventHandler := TEventHandler.Create(self)
end;

destructor TIBEvents.Destroy;
begin
  if FIBLoaded then
  begin
    UnregisterEvents;
    SetDatabase(nil);
    TStringList(FEvents).OnChange := nil;
    FBase.Free;
    FEvents.Free;
  end;
  if assigned(FEventHandler) then
    TEventHandler(FEventHandler).Terminate;
  FEventHandler := nil;
  inherited Destroy;
end;


procedure TIBEvents.EventChange( sender: TObject);
begin
  { check for blank event }
  if TStringList(Events).IndexOf( '') <> -1 then
    IBError(ibxeInvalidEvent, [nil]);
  { check for too many events }
  if Events.Count > MaxEvents then
  begin
    TStringList(Events).OnChange := nil;
    Events.Delete( MaxEvents);
    TStringList(Events).OnChange := EventChange;
    IBError(ibxeMaximumEvents, [nil]);
  end;
  if Registered then
    TEventHandler(FEventHandler).RegisterEvents(Events);
end;

procedure TIBEvents.Notification( AComponent: TComponent;
                                        Operation: TOperation);
begin
  inherited Notification( AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FBase.Database) then
  begin
    UnregisterEvents;
    FBase.Database := nil;
  end;
end;

procedure TIBEvents.RegisterEvents;
begin
  ValidateDatabase( Database);
  if csDesigning in ComponentState then FRegistered := true
  else
  begin
    if not FBase.Database.Connected then
      FDeferredRegister := true
    else
    begin
      TEventHandler(FEventHandler).RegisterEvents(Events);
      FRegistered := true;
    end;
  end;
end;

procedure TIBEvents.SetEvents( value: TStrings);
begin
  FEvents.Assign( value);
end;

procedure TIBEvents.SetDatabase( value: TIBDatabase);
begin
  if value <> FBase.Database then
  begin
    if Registered then UnregisterEvents;
    if assigned( value) and value.Connected then ValidateDatabase( value);
    FBase.Database := value;
    if (FBase.Database <> nil) and FBase.Database.Connected then
      DoAfterDatabaseConnect(FBase.Database)
  end;
end;

function TIBEvents.GetDatabase: TIBDatabase;
begin
  Result := FBase.Database
end;

procedure TIBEvents.SetRegistered( value: Boolean);
begin
  FDeferredRegister := false;
  if not assigned(FBase) or (FBase.Database = nil) then
  begin
    FDeferredRegister := value;
    Exit;
  end;

  if value then RegisterEvents else UnregisterEvents;
end;

procedure TIBEvents.UnregisterEvents;
begin
  FDeferredRegister := false;
  if not FRegistered then
    Exit;
  if csDesigning in ComponentState then
    FRegistered := false
  else
  begin
    TEventHandler(FEventHandler).UnRegisterEvents;
    FRegistered := false;
  end;
end;

procedure TIBEvents.DoBeforeDatabaseDisconnect(Sender: TObject);
begin
  UnregisterEvents;
end;

procedure TIBEvents.DoAfterDatabaseConnect(Sender: TObject);
begin
  if FDeferredRegister then
    Registered := true
end;

function TIBEvents.GetDatabaseHandle: TISC_DB_HANDLE;
begin
  ValidateDatabase(FBase.Database);
  Result := FBase.Database.Handle;
end;


end.
Revision:	17
Committed:	Sat Dec 28 19:22:24 2013 UTC (10 years, 10 months ago) by tony
Content type:	text/x-pascal
File size:	15504 byte(s)
Log Message:	Committing updates for Release R1-0-5
#	User	Rev	Content
1	tony	17	{************************************************************************}
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.