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, 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, SysUtils;

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