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