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:	33
Committed:	Sat Jul 18 12:30:52 2015 UTC (8 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	14943 byte(s)
Log Message:	Committing updates for Release R1-3-1
#	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, IBHeader, IBExternals, IB, IBDatabase;
58
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	IBIntf, syncobjs, SysUtils;
109
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	FOwner.FBase.HandleException(Self)
257	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.