runtime/nongui/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 - 2018                                               }
{                                                                        }
{************************************************************************}

{
  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, 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, IBMessages;

{ TIBEvents }

procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
begin
  if not assigned( Database) then
    IBError(ibxeDatabaseNameMissing, [nil]);
  if csDesigning in ComponentState then Exit;
  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;
  inherited Destroy;
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;
    FStartEvent := true;
  end;
end;

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

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


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