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, IB;

  { $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
    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:	263
Committed:	Thu Dec 6 15:55:01 2018 UTC (5 years, 11 months ago) by tony
Content type:	text/x-pascal
File size:	9679 byte(s)
Log Message:	Release 2.3.2 committed
#	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	263	Classes, SysUtils, IBExternals, IB;
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			procedure AddObject(obj: TInterfacedObject);
95			procedure Remove(intf: TInterfacedObject);
96			procedure SignalActivity;
97			end;
98
99			{ TActivityReporter is a base class for objects that need to report their activity
100			to an activity monitor, where activity is defined as use of a Firebird API call.
101			Objects descending from this class always used the "Call" method as a wrapper
102			for calls to the Firebird API. Each such call is then classed as activity
103			and reported to one or more activity monitors.
104
105			In practice, a transaction monitors statements, blobs and arrays. A Database
106			monitors transactions and events. Transaction monitors use the ITransactionMonitor
107			interface, implemented through the helper object TTransactionMonitor.
108			}
109
110	tony	263	TOnDatabaseError = procedure of object;
111
112	tony	45	TActivityReporter = class(TInterfaceOwner)
113			private
114			FHasActivity: boolean;
115			FMonitors: array of IActivityMonitor;
116	tony	263	FOnDatabaseError: TOnDatabaseError;
117	tony	45	function FindMonitor(aMonitor: IActivityMonitor): integer;
118			protected
119			function Call(ErrCode: ISC_STATUS; RaiseError: Boolean = true): ISC_STATUS;
120			procedure AddMonitor(aMonitor: IActivityMonitor);
121			procedure RemoveMonitor(aMonitor: IActivityMonitor);
122			public
123			constructor Create(aMonitor: IActivityMonitor;aInterfaces: integer=0);
124			destructor Destroy; override;
125			function HasActivity: boolean;
126			procedure SignalActivity;
127	tony	263	property OnDatabaseError: TOnDatabaseError read FOnDatabaseError write FOnDatabaseError;
128	tony	45	end;
129
130			{ TActivityHandler is a base class for classes that receive activity reports.}
131
132			TActivityHandler = class(TInterfaceOwner,IActivityMonitor)
133			private
134			FHasActivity: boolean;
135			public
136			function HasActivity: boolean;
137			procedure SignalActivity;
138			end;
139
140			implementation
141
142	tony	263	uses FBClientAPI;
143	tony	45
144			{ TActivityHandler }
145
146			function TActivityHandler.HasActivity: boolean;
147			begin
148			Result := FHasActivity;
149			FHasActivity := false;
150			end;
151
152			procedure TActivityHandler.SignalActivity;
153			begin
154			FHasActivity := true;
155			end;
156
157			{ TMonitoredObject }
158
159			{$IFDEF DEBUGINTERFACES}
160	tony	56	var
161			FObjectCount: integer;
162
163	tony	45	constructor TMonitoredObject.Create;
164			begin
165			inherited Create;
166			Inc(FObjectCount);
167			writeln('Creating ' + ClassName,', Obj Count = ',FObjectCount);
168			end;
169
170			destructor TMonitoredObject.Destroy;
171			begin
172			Dec(FObjectCount);
173			writeln('Destroying ' + ClassName,' Obj Count = ',FObjectCount);
174			inherited Destroy;
175			end;
176			{$ENDIF}
177
178			{ TActivityReporter}
179
180			function TActivityReporter.FindMonitor(aMonitor: IActivityMonitor): integer;
181			var i: integer;
182			begin
183			Result := -1;
184			for i := 0 to Length(FMonitors) - 1 do
185			if FMonitors[i] = aMonitor then
186			begin
187			Result := i;
188			Exit;
189			end;
190			end;
191
192			function TActivityReporter.Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
193			begin
194			result := ErrCode;
195			SignalActivity;
196	tony	263	if RaiseError and (ErrCode > 0) and assigned(FOnDatabaseError) then
197			OnDatabaseError;
198	tony	45	end;
199
200			procedure TActivityReporter.AddMonitor(aMonitor: IActivityMonitor);
201			var i: integer;
202			begin
203			if FindMonitor(aMonitor) = -1 then
204			begin
205			i := Length(FMonitors);
206			Setlength(FMonitors,i+1);
207			FMonitors[i] := aMonitor;
208			aMonitor.AddObject(self);
209			end;
210			end;
211
212			procedure TActivityReporter.RemoveMonitor(aMonitor: IActivityMonitor);
213			var i,j: integer;
214			begin
215			i := FindMonitor(aMonitor);
216			if i <> -1 then
217			begin
218			aMonitor.Remove(self);
219			if Length(FMonitors) = 1 then
220			SetLength(FMonitors,0)
221			else
222			begin
223			for j := i + 1 to Length(FMonitors) - 1 do
224			FMonitors[j-1] := FMonitors[j];
225			SetLength(FMonitors,Length(FMonitors)-1);
226			end;
227			end;
228			end;
229
230			procedure TActivityReporter.SignalActivity;
231			var i: integer;
232			begin
233			FHasActivity := true;
234			for i := 0 to Length(FMonitors) - 1 do
235			FMonitors[i].SignalActivity;
236			end;
237
238			constructor TActivityReporter.Create(aMonitor: IActivityMonitor;
239			aInterfaces: integer);
240			begin
241			inherited Create(aInterfaces);
242			if aMonitor <> nil then
243			begin
244			SetLength(FMonitors,1);
245			FMonitors[0] := aMonitor;
246			end;
247			end;
248
249			destructor TActivityReporter.Destroy;
250			var i: integer;
251			begin
252			for i := 0 to Length(FMonitors) - 1 do
253			FMonitors[i].Remove(self);
254			inherited Destroy;
255			end;
256
257			function TActivityReporter.HasActivity: boolean;
258			begin
259			Result := FHasActivity;
260			FHasActivity := false;
261			end;
262
263			{ TInterfaceOwner }
264
265			constructor TInterfaceOwner.Create(aInterfaces: integer);
266			begin
267			inherited Create;
268			FMinInterfaces := aInterfaces;
269			SetLength(FInterfaces,aInterfaces);
270			SetLength(FInterfaceRefs,aInterfaces);
271			end;
272
273			destructor TInterfaceOwner.Destroy;
274			begin
275			ReleaseInterfaces;
276			inherited Destroy;
277			end;
278
279			procedure TInterfaceOwner.AddObject(obj: TInterfacedObject);
280			var index: integer;
281			begin
282			index := Length(FInterfaces);
283			SetLength(FInterfaces,index+1);
284			SetLength(FInterfaceRefs,index+1);
285			AddInterface(index,obj);
286			end;
287
288			function TInterfaceOwner.GetInterface(index: integer): TInterfacedObject;
289			begin
290			Result := FInterfaces[index];
291			end;
292
293			procedure TInterfaceOwner.SetRetainInterfaces(AValue: boolean);
294			begin
295			if FRetainInterfaces = AValue then Exit;
296			FRetainInterfaces := AValue;
297			if not FRetainInterfaces then
298			ReleaseInterfaces;
299			end;
300
301			function TInterfaceOwner.GetCount: integer;
302			begin
303			Result := Length(FInterfaces);
304			end;
305
306			procedure TInterfaceOwner.AddInterface(index: integer; obj: TInterfacedObject);
307			begin
308			FInterfaces[index] := obj;
309			if RetainInterfaces then
310			FInterfaceRefs[index] := obj;
311			end;
312
313			function TInterfaceOwner.HasInterface(index: integer): boolean;
314			begin
315	tony	87	Result := (Length(FInterfaces) > 0) and (FInterfaces[index] <> nil);
316	tony	45	end;
317
318			procedure TInterfaceOwner.Remove(intf: TInterfacedObject);
319			var i, j: integer;
320			begin
321			for i := 0 to Length(FInterfaces) - 1 do
322			if FInterfaces[i] = intf then
323			begin
324			if i < FMinInterfaces then
325			begin
326			FInterfaceRefs[i] := nil;
327			FInterfaces[i] := nil;
328			end
329			else
330			begin
331			for j := i to Length(FInterfaces) - 2 do
332			begin
333			FInterfaceRefs[j] := FInterfaceRefs[j+1];
334			FInterfaces[j] := FInterfaces[j+1];
335			end;
336			SetLength(FInterfaces,Length(FInterfaces)-1);
337			SetLength(FInterfaceRefs,Length(FInterfaceRefs)-1);
338			end;
339			Exit;
340			end;
341			end;
342
343			procedure TInterfaceOwner.ReleaseInterfaces;
344			var i: integer;
345			begin
346			for i := 0 to Length(FInterfaces) - 1 do
347	tony	56	begin
348			{$IFNDEF FPC}
349			{With Delphi we need to explicitly null the object reference when it is
350			going to be disposed of. This is because Delphi does not drop the reference
351			count until after the containing object is released.}
352			if (FInterfaces[i] <> nil) and (FInterfaces[i].RefCount <= 2) then
353			FInterfaces[i] := nil;
354			{$ENDIF}
355	tony	45	FInterfaceRefs[i] := nil;
356	tony	56	end;
357	tony	45	end;
358
359			end.
360