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 objfpc}{$H+}

interface

uses
{$IFDEF WINDOWS }
  Windows,
{$ELSE}
  unix,
{$ENDIF}
  Classes, 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
    FBase: TIBBase;
    FEventIntf: IEvents;
    FEvents: TStrings;
    FOnEventAlert: TEventAlert;
    FRegistered: boolean;
    FDeferredRegister: boolean;
    FStartEvent: boolean;
    procedure EventHandler(Sender: IEvents);
    procedure ProcessEvents;
    procedure EventChange(sender: TObject);
    function GetDatabase: TIBDatabase;
    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 DeferredRegister: boolean read FDeferredRegister write FDeferredRegister;
    property EventIntf: IEvents read FEventIntf;
  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 SysUtils, FBMessages;

{ 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);
  FBase := TIBBase.Create(Self);
  FBase.BeforeDatabaseDisconnect := @DoBeforeDatabaseDisconnect;
  FBase.AfterDatabaseConnect := @DoAfterDatabaseConnect;
  FEvents := TStringList.Create;
  FStartEvent := true;
  with TStringList( FEvents) do
  begin
    OnChange := @EventChange;
    Duplicates := dupIgnore;
  end;
end;

destructor TIBEvents.Destroy;
begin
  UnregisterEvents;
  SetDatabase(nil);
  TStringList(FEvents).OnChange := nil;
  FBase.Free;
  FEvents.Free;
end;

procedure TIBEvents.EventHandler(Sender: IEvents);
begin
  TThread.Synchronize(nil,@ProcessEvents);
end;

procedure TIBEvents.ProcessEvents;
var EventCounts: TEventCounts;
    CancelAlerts: Boolean;
    i: integer;
begin
  if (csDestroying in ComponentState) or (FEventIntf = nil) then Exit;
  CancelAlerts := false;
  EventCounts := FEventIntf.ExtractEventCounts;
  if FStartEvent then
    FStartEvent := false {ignore the first one}
  else
  if assigned(FOnEventAlert) then
  begin
    CancelAlerts := false;
    for i := 0 to Length(EventCounts) -1 do
    begin
      OnEventAlert(self,EventCounts[i].EventName,EventCounts[i].Count,CancelAlerts);
      if CancelAlerts then break;
    end;
  end;
  if CancelAlerts then
    UnRegisterEvents
  else
    FEventIntf.AsyncWaitForEvent(@EventHandler);
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  and (FEventIntf <> nil) then
  begin
    FEventIntf.SetEvents(Events);
    FEventIntf.AsyncWaitForEvent(@EventHandler);
  end;
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
  if FRegistered then Exit;
  ValidateDatabase( Database);
  if csDesigning in ComponentState then FRegistered := true
  else
  begin
    if not FBase.Database.Connected then
      FDeferredRegister := true
    else
    begin
      FEventIntf := Database.Attachment.GetEventHandler(Events);
      FEventIntf.AsyncWaitForEvent(@EventHandler);
      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
    FEventIntf := nil;
    FRegistered := false;
  end;
end;

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

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


end.
Revision:	47
Committed:	Mon Jan 9 15:31:51 2017 UTC (7 years, 10 months ago) by tony
Content type:	text/x-pascal
File size:	8867 byte(s)
Log Message:	Committing updates for Release R2-0-1
#	User	Rev	Content
1	tony	33	{************************************************************************}
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	tony	45	{$mode objfpc}{$H+}
48	tony	33
49			interface
50
51			uses
52			{$IFDEF WINDOWS }
53			Windows,
54			{$ELSE}
55			unix,
56			{$ENDIF}
57	tony	45	Classes, IBExternals, IB, IBDatabase;
58	tony	33
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			FBase: TIBBase;
72	tony	45	FEventIntf: IEvents;
73	tony	33	FEvents: TStrings;
74			FOnEventAlert: TEventAlert;
75			FRegistered: boolean;
76			FDeferredRegister: boolean;
77	tony	47	FStartEvent: boolean;
78	tony	45	procedure EventHandler(Sender: IEvents);
79			procedure ProcessEvents;
80	tony	33	procedure EventChange(sender: TObject);
81			function GetDatabase: TIBDatabase;
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 DeferredRegister: boolean read FDeferredRegister write FDeferredRegister;
97	tony	45	property EventIntf: IEvents read FEventIntf;
98	tony	33	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	tony	45	uses SysUtils, FBMessages;
109	tony	33
110			{ TIBEvents }
111
112			procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
113			begin
114			if not assigned( Database) then
115			IBError(ibxeDatabaseNameMissing, [nil]);
116			if not Database.Connected then
117			IBError(ibxeDatabaseClosed, [nil]);
118			end;
119
120			constructor TIBEvents.Create( AOwner: TComponent);
121			begin
122			inherited Create( AOwner);
123			FBase := TIBBase.Create(Self);
124	tony	45	FBase.BeforeDatabaseDisconnect := @DoBeforeDatabaseDisconnect;
125			FBase.AfterDatabaseConnect := @DoAfterDatabaseConnect;
126	tony	33	FEvents := TStringList.Create;
127	tony	47	FStartEvent := true;
128	tony	33	with TStringList( FEvents) do
129			begin
130	tony	45	OnChange := @EventChange;
131	tony	33	Duplicates := dupIgnore;
132			end;
133			end;
134
135			destructor TIBEvents.Destroy;
136			begin
137	tony	45	UnregisterEvents;
138			SetDatabase(nil);
139			TStringList(FEvents).OnChange := nil;
140			FBase.Free;
141			FEvents.Free;
142			end;
143
144			procedure TIBEvents.EventHandler(Sender: IEvents);
145			begin
146			TThread.Synchronize(nil,@ProcessEvents);
147			end;
148
149			procedure TIBEvents.ProcessEvents;
150			var EventCounts: TEventCounts;
151			CancelAlerts: Boolean;
152			i: integer;
153			begin
154			if (csDestroying in ComponentState) or (FEventIntf = nil) then Exit;
155	tony	47	CancelAlerts := false;
156	tony	45	EventCounts := FEventIntf.ExtractEventCounts;
157	tony	47	if FStartEvent then
158			FStartEvent := false {ignore the first one}
159			else
160	tony	45	if assigned(FOnEventAlert) then
161	tony	33	begin
162	tony	45	CancelAlerts := false;
163			for i := 0 to Length(EventCounts) -1 do
164			begin
165			OnEventAlert(self,EventCounts[i].EventName,EventCounts[i].Count,CancelAlerts);
166			if CancelAlerts then break;
167			end;
168	tony	33	end;
169	tony	45	if CancelAlerts then
170			UnRegisterEvents
171			else
172			FEventIntf.AsyncWaitForEvent(@EventHandler);
173	tony	33	end;
174
175			procedure TIBEvents.EventChange( sender: TObject);
176			begin
177			{ check for blank event }
178			if TStringList(Events).IndexOf( '') <> -1 then
179			IBError(ibxeInvalidEvent, [nil]);
180			{ check for too many events }
181			if Events.Count > MaxEvents then
182			begin
183			TStringList(Events).OnChange := nil;
184			Events.Delete( MaxEvents);
185	tony	45	TStringList(Events).OnChange := @EventChange;
186	tony	33	IBError(ibxeMaximumEvents, [nil]);
187			end;
188	tony	45	if Registered and (FEventIntf <> nil) then
189			begin
190			FEventIntf.SetEvents(Events);
191			FEventIntf.AsyncWaitForEvent(@EventHandler);
192			end;
193	tony	33	end;
194
195			procedure TIBEvents.Notification( AComponent: TComponent;
196			Operation: TOperation);
197			begin
198			inherited Notification( AComponent, Operation);
199			if (Operation = opRemove) and (AComponent = FBase.Database) then
200			begin
201			UnregisterEvents;
202			FBase.Database := nil;
203			end;
204			end;
205
206			procedure TIBEvents.RegisterEvents;
207			begin
208	tony	45	if FRegistered then Exit;
209	tony	33	ValidateDatabase( Database);
210			if csDesigning in ComponentState then FRegistered := true
211			else
212			begin
213			if not FBase.Database.Connected then
214			FDeferredRegister := true
215			else
216			begin
217	tony	45	FEventIntf := Database.Attachment.GetEventHandler(Events);
218			FEventIntf.AsyncWaitForEvent(@EventHandler);
219	tony	33	FRegistered := true;
220			end;
221			end;
222			end;
223
224			procedure TIBEvents.SetEvents( value: TStrings);
225			begin
226			FEvents.Assign( value);
227			end;
228
229			procedure TIBEvents.SetDatabase( value: TIBDatabase);
230			begin
231			if value <> FBase.Database then
232			begin
233			if Registered then UnregisterEvents;
234			if assigned( value) and value.Connected then ValidateDatabase( value);
235			FBase.Database := value;
236			if (FBase.Database <> nil) and FBase.Database.Connected then
237			DoAfterDatabaseConnect(FBase.Database)
238			end;
239			end;
240
241			function TIBEvents.GetDatabase: TIBDatabase;
242			begin
243			Result := FBase.Database
244			end;
245
246	tony	45	procedure TIBEvents.SetRegistered(value: boolean);
247	tony	33	begin
248			FDeferredRegister := false;
249			if not assigned(FBase) or (FBase.Database = nil) then
250			begin
251			FDeferredRegister := value;
252			Exit;
253			end;
254
255			if value then RegisterEvents else UnregisterEvents;
256			end;
257
258	tony	45	procedure TIBEvents.UnRegisterEvents;
259	tony	33	begin
260			FDeferredRegister := false;
261			if not FRegistered then
262			Exit;
263			if csDesigning in ComponentState then
264			FRegistered := false
265			else
266			begin
267	tony	45	FEventIntf := nil;
268	tony	33	FRegistered := false;
269			end;
270			end;
271
272			procedure TIBEvents.DoBeforeDatabaseDisconnect(Sender: TObject);
273			begin
274			UnregisterEvents;
275			end;
276
277			procedure TIBEvents.DoAfterDatabaseConnect(Sender: TObject);
278			begin
279			if FDeferredRegister then
280			Registered := true
281			end;
282
283
284			end.