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, 11 months ago) by tony
Content type:	text/x-pascal
File size:	8716 byte(s)
Log Message:	Committing updates for Release R2-0-0
#	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 }
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	procedure EventHandler(Sender: IEvents);
78	procedure ProcessEvents;
79	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	property EventIntf: IEvents read FEventIntf;
97	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	uses SysUtils, FBMessages;
108
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	FBase.BeforeDatabaseDisconnect := @DoBeforeDatabaseDisconnect;
124	FBase.AfterDatabaseConnect := @DoAfterDatabaseConnect;
125	FEvents := TStringList.Create;
126	with TStringList( FEvents) do
127	begin
128	OnChange := @EventChange;
129	Duplicates := dupIgnore;
130	end;
131	end;
132
133	destructor TIBEvents.Destroy;
134	begin
135	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	begin
156	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	end;
163	if CancelAlerts then
164	UnRegisterEvents
165	else
166	FEventIntf.AsyncWaitForEvent(@EventHandler);
167	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	TStringList(Events).OnChange := @EventChange;
180	IBError(ibxeMaximumEvents, [nil]);
181	end;
182	if Registered and (FEventIntf <> nil) then
183	begin
184	FEventIntf.SetEvents(Events);
185	FEventIntf.AsyncWaitForEvent(@EventHandler);
186	end;
187	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	if FRegistered then Exit;
203	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	FEventIntf := Database.Attachment.GetEventHandler(Events);
212	FEventIntf.AsyncWaitForEvent(@EventHandler);
213	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	procedure TIBEvents.SetRegistered(value: boolean);
241	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	procedure TIBEvents.UnRegisterEvents;
253	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	FEventIntf := nil;
262	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.