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 - 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, 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:	143
Committed:	Fri Feb 23 12:11:21 2018 UTC (6 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	8872 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, IBExternals, 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, 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	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	CancelAlerts := false;
156	EventCounts := FEventIntf.ExtractEventCounts;
157	if FStartEvent then
158	FStartEvent := false {ignore the first one}
159	else
160	if assigned(FOnEventAlert) then
161	begin
162	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	end;
169	if CancelAlerts then
170	UnRegisterEvents
171	else
172	FEventIntf.AsyncWaitForEvent(@EventHandler);
173	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	TStringList(Events).OnChange := @EventChange;
186	IBError(ibxeMaximumEvents, [nil]);
187	end;
188	if Registered and (FEventIntf <> nil) then
189	begin
190	FEventIntf.SetEvents(Events);
191	FEventIntf.AsyncWaitForEvent(@EventHandler);
192	end;
193	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	if FRegistered then Exit;
209	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	FEventIntf := Database.Attachment.GetEventHandler(Events);
218	FEventIntf.AsyncWaitForEvent(@EventHandler);
219	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	procedure TIBEvents.SetRegistered(value: boolean);
247	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	procedure TIBEvents.UnRegisterEvents;
259	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	FEventIntf := nil;
268	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.