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, 7 months ago) by tony
Content type:	text/x-pascal
File size:	8951 byte(s)
Log Message:	Fixes merged
#	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 - 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	Classes, 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	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, IBMessages;
109
110	{ TIBEvents }
111
112	procedure TIBEvents.ValidateDatabase( Database: TIBDatabase);
113	begin
114	if not assigned( Database) then
115	IBError(ibxeDatabaseNameMissing, [nil]);
116	if csDesigning in ComponentState then Exit;
117	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	inherited Destroy;
144	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	FStartEvent := true;
272	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.