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, 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;
  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;
  end;
end;

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

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


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