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:	7
Committed:	Sun Aug 5 18:28:19 2012 UTC (12 years, 3 months ago) by tony
Content type:	text/x-pascal
File size:	14969 byte(s)
Log Message:	Committing updates for Release R1-0-0
#	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.