fbintf/client/FBActivityMonitor.pas

(*
 *  Firebird Interface (fbintf). The fbintf components provide a set of
 *  Pascal language bindings for the Firebird API.
 *
 *  The contents of this file are subject to the Initial Developer's
 *  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 here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  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 Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2016 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit FBActivityMonitor;
{$IFDEF MSWINDOWS} 
{$DEFINE WINDOWS} 
{$ENDIF}

{$IFDEF FPC}
{$mode delphi}
{$interfaces COM}
{$ENDIF}

interface

uses
  Classes, SysUtils, IBExternals;

  { $DEFINE DEBUGINTERFACES}   {Define this to check that all interfaces are
                                being destroyed.}

type
  { TMonitoredObject is an optional class used to journal all interface creatino
   and deletion as well as keeping a count of how many monitored interfaces
   exist at any one time. It is used at development to look for memory leaks
   due to interfaces not being discarded when no longer used.}

  {$IFDEF DEBUGINTERFACES}
  TMonitoredObject = class(TInterfacedObject)
  public
    constructor Create;
    destructor Destroy; override;
  end;

  {TFBInterfacedObject is used as the base class for interfaces objects and can
   be either a synonym for TInterfacedObject (default) or TMonitored object}

    TFBInterfacedObject = TMonitoredObject;
  {$ELSE}
    TFBInterfacedObject = TInterfacedObject;
  {$ENDIF}

  { TInterfaceOwner }

  TInterfaceOwner = class(TFBInterfacedObject)
  private
    FInterfaces: array of TInterfacedObject;
    FInterfaceRefs: array of IUnknown;
    FRetainInterfaces: boolean;
    FMinInterfaces: integer;
    function GetCount: integer;
    procedure SetRetainInterfaces(AValue: boolean);
  protected
    procedure AddInterface(index: integer; obj: TInterfacedObject);
    function HasInterface(index: integer): boolean;
    procedure ReleaseInterfaces;
  public
    constructor Create(aInterfaces: integer=0);
    destructor Destroy; override;
    procedure AddObject(obj: TInterfacedObject);
    function GetInterface(index: integer): TInterfacedObject;
    procedure Remove(intf: TInterfacedObject);
    property InterfaceCount: integer read GetCount;
    property RetainInterfaces: boolean read FRetainInterfaces write SetRetainInterfaces;
  end;

  {The IActivityMonitor interface is provided by classes that receive activity
   reports.}

  IActivityMonitor = interface
    ['{8261840a-741b-4c1c-94ea-c5c66ba72f22}']
    procedure AddObject(obj: TInterfacedObject);
    procedure Remove(intf: TInterfacedObject);
    procedure SignalActivity;
  end;

  { TActivityReporter is a base class for objects that need to report their activity
    to an activity monitor, where activity is defined as use of a Firebird API call.
    Objects descending from this class always used the "Call" method as a wrapper
    for calls to the Firebird API. Each such call is then classed as activity
    and reported to one or more activity monitors.

    In practice, a transaction monitors statements, blobs and arrays. A Database
    monitors transactions and events. Transaction monitors use the ITransactionMonitor
    interface, implemented through the helper object TTransactionMonitor.
  }

  TOnDatabaseError = procedure of object;

  TActivityReporter = class(TInterfaceOwner)
  private
    FHasActivity: boolean;
    FMonitors: array of IActivityMonitor;
    FOnDatabaseError: TOnDatabaseError;
    function FindMonitor(aMonitor: IActivityMonitor): integer;
  protected
    function Call(ErrCode: ISC_STATUS; RaiseError: Boolean = true): ISC_STATUS;
    procedure AddMonitor(aMonitor: IActivityMonitor);
    procedure RemoveMonitor(aMonitor: IActivityMonitor);
  public
    constructor Create(aMonitor: IActivityMonitor;aInterfaces: integer=0);
    destructor Destroy; override;
    function HasActivity: boolean;
    procedure SignalActivity;
    property OnDatabaseError: TOnDatabaseError read FOnDatabaseError write FOnDatabaseError;
  end;

  { TActivityHandler is a base class for classes that receive activity reports.}

  TActivityHandler = class(TInterfaceOwner,IActivityMonitor)
  private
    FHasActivity: boolean;
  public
    function HasActivity: boolean;
    procedure SignalActivity;
  end;

implementation

uses FBClientAPI;

{ TActivityHandler }

function TActivityHandler.HasActivity: boolean;
begin
  Result := FHasActivity;
  FHasActivity := false;
end;

procedure TActivityHandler.SignalActivity;
begin
  FHasActivity := true;
end;

{ TMonitoredObject }

{$IFDEF DEBUGINTERFACES}
var
  FObjectCount: integer;

constructor TMonitoredObject.Create;
begin
  inherited Create;
  Inc(FObjectCount);
  writeln('Creating ' + ClassName,', Obj Count = ',FObjectCount);
end;

destructor TMonitoredObject.Destroy;
begin
  Dec(FObjectCount);
  writeln('Destroying ' + ClassName,' Obj Count = ',FObjectCount);
  inherited Destroy;
end;
{$ENDIF}

{ TActivityReporter}

function TActivityReporter.FindMonitor(aMonitor: IActivityMonitor): integer;
var i: integer;
begin
  Result := -1;
  for i := 0 to Length(FMonitors) - 1 do
    if FMonitors[i] = aMonitor then
    begin
      Result := i;
      Exit;
    end;
end;

function TActivityReporter.Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
begin
  result := ErrCode;
  SignalActivity;
  if RaiseError and (ErrCode > 0) and assigned(FOnDatabaseError) then
    OnDatabaseError;
end;

procedure TActivityReporter.AddMonitor(aMonitor: IActivityMonitor);
var i: integer;
begin
  if FindMonitor(aMonitor) = -1 then
  begin
    i := Length(FMonitors);
    Setlength(FMonitors,i+1);
    FMonitors[i] := aMonitor;
    aMonitor.AddObject(self);
  end;
end;

procedure TActivityReporter.RemoveMonitor(aMonitor: IActivityMonitor);
var i,j: integer;
begin
  i := FindMonitor(aMonitor);
  if i <> -1 then
  begin
    aMonitor.Remove(self);
    if Length(FMonitors) = 1 then
      SetLength(FMonitors,0)
    else
    begin
      for j := i + 1 to Length(FMonitors) - 1 do
        FMonitors[j-1] := FMonitors[j];
      SetLength(FMonitors,Length(FMonitors)-1);
    end;
  end;
end;

procedure TActivityReporter.SignalActivity;
var i: integer;
begin
  FHasActivity := true;
  for i := 0 to Length(FMonitors) - 1 do
      FMonitors[i].SignalActivity;
end;

constructor TActivityReporter.Create(aMonitor: IActivityMonitor;
  aInterfaces: integer);
begin
  inherited Create(aInterfaces);
  if aMonitor <> nil then
  begin
    SetLength(FMonitors,1);
    FMonitors[0] := aMonitor;
  end;
end;

destructor TActivityReporter.Destroy;
var i: integer;
begin
  for i := 0 to Length(FMonitors) - 1 do
    FMonitors[i].Remove(self);
  inherited Destroy;
end;

function TActivityReporter.HasActivity: boolean;
begin
  Result := FHasActivity;
  FHasActivity := false;
end;

{ TInterfaceOwner }

constructor TInterfaceOwner.Create(aInterfaces: integer);
begin
  inherited Create;
  FMinInterfaces := aInterfaces;
  SetLength(FInterfaces,aInterfaces);
  SetLength(FInterfaceRefs,aInterfaces);
end;

destructor TInterfaceOwner.Destroy;
begin
  ReleaseInterfaces;
  inherited Destroy;
end;

procedure TInterfaceOwner.AddObject(obj: TInterfacedObject);
var index: integer;
begin
  index := Length(FInterfaces);
  SetLength(FInterfaces,index+1);
  SetLength(FInterfaceRefs,index+1);
  AddInterface(index,obj);
end;

function TInterfaceOwner.GetInterface(index: integer): TInterfacedObject;
begin
  Result := FInterfaces[index];
end;

procedure TInterfaceOwner.SetRetainInterfaces(AValue: boolean);
begin
  if FRetainInterfaces = AValue then Exit;
  FRetainInterfaces := AValue;
  if not FRetainInterfaces then
    ReleaseInterfaces;
end;

function TInterfaceOwner.GetCount: integer;
begin
  Result := Length(FInterfaces);
end;

procedure TInterfaceOwner.AddInterface(index: integer; obj: TInterfacedObject);
begin
  FInterfaces[index] := obj;
  if RetainInterfaces then
    FInterfaceRefs[index] := obj;
end;

function TInterfaceOwner.HasInterface(index: integer): boolean;
begin
  Result := (Length(FInterfaces) > 0) and (FInterfaces[index] <> nil);
end;

procedure TInterfaceOwner.Remove(intf: TInterfacedObject);
var i, j: integer;
begin
  for i := 0 to Length(FInterfaces) - 1 do
    if FInterfaces[i] = intf then
    begin
      if i < FMinInterfaces then
      begin
        FInterfaceRefs[i] := nil;
        FInterfaces[i] := nil;
      end
      else
      begin
        for j := i to Length(FInterfaces) - 2 do
        begin
          FInterfaceRefs[j] := FInterfaceRefs[j+1];
          FInterfaces[j] := FInterfaces[j+1];
        end;
        SetLength(FInterfaces,Length(FInterfaces)-1);
        SetLength(FInterfaceRefs,Length(FInterfaceRefs)-1);
      end;
      Exit;
    end;
end;

procedure TInterfaceOwner.ReleaseInterfaces;
var i: integer;
begin
  for i := 0 to Length(FInterfaces) - 1 do
  begin
    {$IFNDEF FPC}
    {With Delphi we need to explicitly null the object reference when it is
     going to be disposed of. This is because Delphi does not drop the reference
     count until after the containing object is released.}
    if (FInterfaces[i] <> nil) and (FInterfaces[i].RefCount <= 2) then
      FInterfaces[i] := nil;
    {$ENDIF}
    FInterfaceRefs[i] := nil;
  end;
end;

end.

Revision:	315
Committed:	Thu Feb 25 11:56:36 2021 UTC (3 years, 1 month ago) by tony
Content type:	text/x-pascal
File size:	9722 byte(s)
Log Message:	Updated for IBX 4 release
#	Content
1	(*
2	* Firebird Interface (fbintf). The fbintf components provide a set of
3	* Pascal language bindings for the Firebird API.
4	*
5	* The contents of this file are subject to the Initial Developer's
6	* Public License Version 1.0 (the "License"); you may not use this
7	* file except in compliance with the License. You may obtain a copy
8	* of the License here:
9	*
10	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
11	*
12	* Software distributed under the License is distributed on an "AS
13	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
14	* implied. See the License for the specific language governing rights
15	* and limitations under the License.
16	*
17	* The Initial Developer of the Original Code is Tony Whyman.
18	*
19	* The Original Code is (C) 2016 Tony Whyman, MWA Software
20	* (http://www.mwasoftware.co.uk).
21	*
22	* All Rights Reserved.
23	*
24	* Contributor(s): ______________________________________.
25	*
26	*)
27	unit FBActivityMonitor;
28	{$IFDEF MSWINDOWS}
29	{$DEFINE WINDOWS}
30	{$ENDIF}
31
32	{$IFDEF FPC}
33	{$mode delphi}
34	{$interfaces COM}
35	{$ENDIF}
36
37	interface
38
39	uses
40	Classes, SysUtils, IBExternals;
41
42	{ $DEFINE DEBUGINTERFACES} {Define this to check that all interfaces are
43	being destroyed.}
44
45	type
46	{ TMonitoredObject is an optional class used to journal all interface creatino
47	and deletion as well as keeping a count of how many monitored interfaces
48	exist at any one time. It is used at development to look for memory leaks
49	due to interfaces not being discarded when no longer used.}
50
51	{$IFDEF DEBUGINTERFACES}
52	TMonitoredObject = class(TInterfacedObject)
53	public
54	constructor Create;
55	destructor Destroy; override;
56	end;
57
58	{TFBInterfacedObject is used as the base class for interfaces objects and can
59	be either a synonym for TInterfacedObject (default) or TMonitored object}
60
61	TFBInterfacedObject = TMonitoredObject;
62	{$ELSE}
63	TFBInterfacedObject = TInterfacedObject;
64	{$ENDIF}
65
66	{ TInterfaceOwner }
67
68	TInterfaceOwner = class(TFBInterfacedObject)
69	private
70	FInterfaces: array of TInterfacedObject;
71	FInterfaceRefs: array of IUnknown;
72	FRetainInterfaces: boolean;
73	FMinInterfaces: integer;
74	function GetCount: integer;
75	procedure SetRetainInterfaces(AValue: boolean);
76	protected
77	procedure AddInterface(index: integer; obj: TInterfacedObject);
78	function HasInterface(index: integer): boolean;
79	procedure ReleaseInterfaces;
80	public
81	constructor Create(aInterfaces: integer=0);
82	destructor Destroy; override;
83	procedure AddObject(obj: TInterfacedObject);
84	function GetInterface(index: integer): TInterfacedObject;
85	procedure Remove(intf: TInterfacedObject);
86	property InterfaceCount: integer read GetCount;
87	property RetainInterfaces: boolean read FRetainInterfaces write SetRetainInterfaces;
88	end;
89
90	{The IActivityMonitor interface is provided by classes that receive activity
91	reports.}
92
93	IActivityMonitor = interface
94	['{8261840a-741b-4c1c-94ea-c5c66ba72f22}']
95	procedure AddObject(obj: TInterfacedObject);
96	procedure Remove(intf: TInterfacedObject);
97	procedure SignalActivity;
98	end;
99
100	{ TActivityReporter is a base class for objects that need to report their activity
101	to an activity monitor, where activity is defined as use of a Firebird API call.
102	Objects descending from this class always used the "Call" method as a wrapper
103	for calls to the Firebird API. Each such call is then classed as activity
104	and reported to one or more activity monitors.
105
106	In practice, a transaction monitors statements, blobs and arrays. A Database
107	monitors transactions and events. Transaction monitors use the ITransactionMonitor
108	interface, implemented through the helper object TTransactionMonitor.
109	}
110
111	TOnDatabaseError = procedure of object;
112
113	TActivityReporter = class(TInterfaceOwner)
114	private
115	FHasActivity: boolean;
116	FMonitors: array of IActivityMonitor;
117	FOnDatabaseError: TOnDatabaseError;
118	function FindMonitor(aMonitor: IActivityMonitor): integer;
119	protected
120	function Call(ErrCode: ISC_STATUS; RaiseError: Boolean = true): ISC_STATUS;
121	procedure AddMonitor(aMonitor: IActivityMonitor);
122	procedure RemoveMonitor(aMonitor: IActivityMonitor);
123	public
124	constructor Create(aMonitor: IActivityMonitor;aInterfaces: integer=0);
125	destructor Destroy; override;
126	function HasActivity: boolean;
127	procedure SignalActivity;
128	property OnDatabaseError: TOnDatabaseError read FOnDatabaseError write FOnDatabaseError;
129	end;
130
131	{ TActivityHandler is a base class for classes that receive activity reports.}
132
133	TActivityHandler = class(TInterfaceOwner,IActivityMonitor)
134	private
135	FHasActivity: boolean;
136	public
137	function HasActivity: boolean;
138	procedure SignalActivity;
139	end;
140
141	implementation
142
143	uses FBClientAPI;
144
145	{ TActivityHandler }
146
147	function TActivityHandler.HasActivity: boolean;
148	begin
149	Result := FHasActivity;
150	FHasActivity := false;
151	end;
152
153	procedure TActivityHandler.SignalActivity;
154	begin
155	FHasActivity := true;
156	end;
157
158	{ TMonitoredObject }
159
160	{$IFDEF DEBUGINTERFACES}
161	var
162	FObjectCount: integer;
163
164	constructor TMonitoredObject.Create;
165	begin
166	inherited Create;
167	Inc(FObjectCount);
168	writeln('Creating ' + ClassName,', Obj Count = ',FObjectCount);
169	end;
170
171	destructor TMonitoredObject.Destroy;
172	begin
173	Dec(FObjectCount);
174	writeln('Destroying ' + ClassName,' Obj Count = ',FObjectCount);
175	inherited Destroy;
176	end;
177	{$ENDIF}
178
179	{ TActivityReporter}
180
181	function TActivityReporter.FindMonitor(aMonitor: IActivityMonitor): integer;
182	var i: integer;
183	begin
184	Result := -1;
185	for i := 0 to Length(FMonitors) - 1 do
186	if FMonitors[i] = aMonitor then
187	begin
188	Result := i;
189	Exit;
190	end;
191	end;
192
193	function TActivityReporter.Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
194	begin
195	result := ErrCode;
196	SignalActivity;
197	if RaiseError and (ErrCode > 0) and assigned(FOnDatabaseError) then
198	OnDatabaseError;
199	end;
200
201	procedure TActivityReporter.AddMonitor(aMonitor: IActivityMonitor);
202	var i: integer;
203	begin
204	if FindMonitor(aMonitor) = -1 then
205	begin
206	i := Length(FMonitors);
207	Setlength(FMonitors,i+1);
208	FMonitors[i] := aMonitor;
209	aMonitor.AddObject(self);
210	end;
211	end;
212
213	procedure TActivityReporter.RemoveMonitor(aMonitor: IActivityMonitor);
214	var i,j: integer;
215	begin
216	i := FindMonitor(aMonitor);
217	if i <> -1 then
218	begin
219	aMonitor.Remove(self);
220	if Length(FMonitors) = 1 then
221	SetLength(FMonitors,0)
222	else
223	begin
224	for j := i + 1 to Length(FMonitors) - 1 do
225	FMonitors[j-1] := FMonitors[j];
226	SetLength(FMonitors,Length(FMonitors)-1);
227	end;
228	end;
229	end;
230
231	procedure TActivityReporter.SignalActivity;
232	var i: integer;
233	begin
234	FHasActivity := true;
235	for i := 0 to Length(FMonitors) - 1 do
236	FMonitors[i].SignalActivity;
237	end;
238
239	constructor TActivityReporter.Create(aMonitor: IActivityMonitor;
240	aInterfaces: integer);
241	begin
242	inherited Create(aInterfaces);
243	if aMonitor <> nil then
244	begin
245	SetLength(FMonitors,1);
246	FMonitors[0] := aMonitor;
247	end;
248	end;
249
250	destructor TActivityReporter.Destroy;
251	var i: integer;
252	begin
253	for i := 0 to Length(FMonitors) - 1 do
254	FMonitors[i].Remove(self);
255	inherited Destroy;
256	end;
257
258	function TActivityReporter.HasActivity: boolean;
259	begin
260	Result := FHasActivity;
261	FHasActivity := false;
262	end;
263
264	{ TInterfaceOwner }
265
266	constructor TInterfaceOwner.Create(aInterfaces: integer);
267	begin
268	inherited Create;
269	FMinInterfaces := aInterfaces;
270	SetLength(FInterfaces,aInterfaces);
271	SetLength(FInterfaceRefs,aInterfaces);
272	end;
273
274	destructor TInterfaceOwner.Destroy;
275	begin
276	ReleaseInterfaces;
277	inherited Destroy;
278	end;
279
280	procedure TInterfaceOwner.AddObject(obj: TInterfacedObject);
281	var index: integer;
282	begin
283	index := Length(FInterfaces);
284	SetLength(FInterfaces,index+1);
285	SetLength(FInterfaceRefs,index+1);
286	AddInterface(index,obj);
287	end;
288
289	function TInterfaceOwner.GetInterface(index: integer): TInterfacedObject;
290	begin
291	Result := FInterfaces[index];
292	end;
293
294	procedure TInterfaceOwner.SetRetainInterfaces(AValue: boolean);
295	begin
296	if FRetainInterfaces = AValue then Exit;
297	FRetainInterfaces := AValue;
298	if not FRetainInterfaces then
299	ReleaseInterfaces;
300	end;
301
302	function TInterfaceOwner.GetCount: integer;
303	begin
304	Result := Length(FInterfaces);
305	end;
306
307	procedure TInterfaceOwner.AddInterface(index: integer; obj: TInterfacedObject);
308	begin
309	FInterfaces[index] := obj;
310	if RetainInterfaces then
311	FInterfaceRefs[index] := obj;
312	end;
313
314	function TInterfaceOwner.HasInterface(index: integer): boolean;
315	begin
316	Result := (Length(FInterfaces) > 0) and (FInterfaces[index] <> nil);
317	end;
318
319	procedure TInterfaceOwner.Remove(intf: TInterfacedObject);
320	var i, j: integer;
321	begin
322	for i := 0 to Length(FInterfaces) - 1 do
323	if FInterfaces[i] = intf then
324	begin
325	if i < FMinInterfaces then
326	begin
327	FInterfaceRefs[i] := nil;
328	FInterfaces[i] := nil;
329	end
330	else
331	begin
332	for j := i to Length(FInterfaces) - 2 do
333	begin
334	FInterfaceRefs[j] := FInterfaceRefs[j+1];
335	FInterfaces[j] := FInterfaces[j+1];
336	end;
337	SetLength(FInterfaces,Length(FInterfaces)-1);
338	SetLength(FInterfaceRefs,Length(FInterfaceRefs)-1);
339	end;
340	Exit;
341	end;
342	end;
343
344	procedure TInterfaceOwner.ReleaseInterfaces;
345	var i: integer;
346	begin
347	for i := 0 to Length(FInterfaces) - 1 do
348	begin
349	{$IFNDEF FPC}
350	{With Delphi we need to explicitly null the object reference when it is
351	going to be disposed of. This is because Delphi does not drop the reference
352	count until after the containing object is released.}
353	if (FInterfaces[i] <> nil) and (FInterfaces[i].RefCount <= 2) then
354	FInterfaces[i] := nil;
355	{$ENDIF}
356	FInterfaceRefs[i] := nil;
357	end;
358	end;
359
360	end.
361