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, 9 months ago) by tony
Content type:	text/x-pascal
File size:	9722 byte(s)
Log Message:	Updated for IBX 4 release
#	User	Rev	Content
1	tony	45	(*
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	tony	56	{$IFDEF MSWINDOWS}
29			{$DEFINE WINDOWS}
30			{$ENDIF}
31	tony	45
32			{$IFDEF FPC}
33	tony	56	{$mode delphi}
34	tony	45	{$interfaces COM}
35			{$ENDIF}
36
37			interface
38
39			uses
40	tony	315	Classes, SysUtils, IBExternals;
41	tony	45
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	tony	315	['{8261840a-741b-4c1c-94ea-c5c66ba72f22}']
95	tony	45	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	tony	263	TOnDatabaseError = procedure of object;
112
113	tony	45	TActivityReporter = class(TInterfaceOwner)
114			private
115			FHasActivity: boolean;
116			FMonitors: array of IActivityMonitor;
117	tony	263	FOnDatabaseError: TOnDatabaseError;
118	tony	45	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	tony	263	property OnDatabaseError: TOnDatabaseError read FOnDatabaseError write FOnDatabaseError;
129	tony	45	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	tony	263	uses FBClientAPI;
144	tony	45
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	tony	56	var
162			FObjectCount: integer;
163
164	tony	45	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	tony	263	if RaiseError and (ErrCode > 0) and assigned(FOnDatabaseError) then
198			OnDatabaseError;
199	tony	45	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	tony	87	Result := (Length(FInterfaces) > 0) and (FInterfaces[index] <> nil);
317	tony	45	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	tony	56	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	tony	45	FInterfaceRefs[i] := nil;
357	tony	56	end;
358	tony	45	end;
359
360			end.
361