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 FPC}
{$mode objfpc}{$H+}
{$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)
  private
    FObjectCount: integer; static;
  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.
  }

  TActivityReporter = class(TInterfaceOwner)
  private
    FHasActivity: boolean;
    FMonitors: array of IActivityMonitor;
    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;
  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 FB25ClientAPI;

{ TActivityHandler }

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

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

{ TMonitoredObject }

{$IFDEF DEBUGINTERFACES}
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) then
    Firebird25ClientAPI.IBDataBaseError;
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 := 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
    FInterfaceRefs[i] := nil;
end;

end.

Revision:	45
Committed:	Tue Dec 6 10:33:46 2016 UTC (7 years, 4 months ago) by tony
Content type:	text/x-pascal
File size:	9068 byte(s)
Log Message:	Committing updates for Release R2-0-0
#	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
29			{$IFDEF FPC}
30			{$mode objfpc}{$H+}
31			{$interfaces COM}
32			{$ENDIF}
33
34			interface
35
36			uses
37			Classes, SysUtils, IBExternals;
38
39			{ $DEFINE DEBUGINTERFACES} {Define this to check that all interfaces are
40			being destroyed.}
41
42			type
43			{ TMonitoredObject is an optional class used to journal all interface creatino
44			and deletion as well as keeping a count of how many monitored interfaces
45			exist at any one time. It is used at development to look for memory leaks
46			due to interfaces not being discarded when no longer used.}
47
48			{$IFDEF DEBUGINTERFACES}
49			TMonitoredObject = class(TInterfacedObject)
50			private
51			FObjectCount: integer; static;
52			public
53			constructor Create;
54			destructor Destroy; override;
55			end;
56
57			{TFBInterfacedObject is used as the base class for interfaces objects and can
58			be either a synonym for TInterfacedObject (default) or TMonitored object}
59
60			TFBInterfacedObject = TMonitoredObject;
61			{$ELSE}
62			TFBInterfacedObject = TInterfacedObject;
63			{$ENDIF}
64
65			{ TInterfaceOwner }
66
67			TInterfaceOwner = class(TFBInterfacedObject)
68			private
69			FInterfaces: array of TInterfacedObject;
70			FInterfaceRefs: array of IUnknown;
71			FRetainInterfaces: boolean;
72			FMinInterfaces: integer;
73			function GetCount: integer;
74			procedure SetRetainInterfaces(AValue: boolean);
75			protected
76			procedure AddInterface(index: integer; obj: TInterfacedObject);
77			function HasInterface(index: integer): boolean;
78			procedure ReleaseInterfaces;
79			public
80			constructor Create(aInterfaces: integer=0);
81			destructor Destroy; override;
82			procedure AddObject(obj: TInterfacedObject);
83			function GetInterface(index: integer): TInterfacedObject;
84			procedure Remove(intf: TInterfacedObject);
85			property InterfaceCount: integer read GetCount;
86			property RetainInterfaces: boolean read FRetainInterfaces write SetRetainInterfaces;
87			end;
88
89			{The IActivityMonitor interface is provided by classes that receive activity
90			reports.}
91
92			IActivityMonitor = interface
93			procedure AddObject(obj: TInterfacedObject);
94			procedure Remove(intf: TInterfacedObject);
95			procedure SignalActivity;
96			end;
97
98			{ TActivityReporter is a base class for objects that need to report their activity
99			to an activity monitor, where activity is defined as use of a Firebird API call.
100			Objects descending from this class always used the "Call" method as a wrapper
101			for calls to the Firebird API. Each such call is then classed as activity
102			and reported to one or more activity monitors.
103
104			In practice, a transaction monitors statements, blobs and arrays. A Database
105			monitors transactions and events. Transaction monitors use the ITransactionMonitor
106			interface, implemented through the helper object TTransactionMonitor.
107			}
108
109			TActivityReporter = class(TInterfaceOwner)
110			private
111			FHasActivity: boolean;
112			FMonitors: array of IActivityMonitor;
113			function FindMonitor(aMonitor: IActivityMonitor): integer;
114			protected
115			function Call(ErrCode: ISC_STATUS; RaiseError: Boolean = true): ISC_STATUS;
116			procedure AddMonitor(aMonitor: IActivityMonitor);
117			procedure RemoveMonitor(aMonitor: IActivityMonitor);
118			public
119			constructor Create(aMonitor: IActivityMonitor;aInterfaces: integer=0);
120			destructor Destroy; override;
121			function HasActivity: boolean;
122			procedure SignalActivity;
123			end;
124
125			{ TActivityHandler is a base class for classes that receive activity reports.}
126
127			TActivityHandler = class(TInterfaceOwner,IActivityMonitor)
128			private
129			FHasActivity: boolean;
130			public
131			function HasActivity: boolean;
132			procedure SignalActivity;
133			end;
134
135			implementation
136
137			uses FB25ClientAPI;
138
139			{ TActivityHandler }
140
141			function TActivityHandler.HasActivity: boolean;
142			begin
143			Result := FHasActivity;
144			FHasActivity := false;
145			end;
146
147			procedure TActivityHandler.SignalActivity;
148			begin
149			FHasActivity := true;
150			end;
151
152			{ TMonitoredObject }
153
154			{$IFDEF DEBUGINTERFACES}
155			constructor TMonitoredObject.Create;
156			begin
157			inherited Create;
158			Inc(FObjectCount);
159			writeln('Creating ' + ClassName,', Obj Count = ',FObjectCount);
160			end;
161
162			destructor TMonitoredObject.Destroy;
163			begin
164			Dec(FObjectCount);
165			writeln('Destroying ' + ClassName,' Obj Count = ',FObjectCount);
166			inherited Destroy;
167			end;
168			{$ENDIF}
169
170			{ TActivityReporter}
171
172			function TActivityReporter.FindMonitor(aMonitor: IActivityMonitor): integer;
173			var i: integer;
174			begin
175			Result := -1;
176			for i := 0 to Length(FMonitors) - 1 do
177			if FMonitors[i] = aMonitor then
178			begin
179			Result := i;
180			Exit;
181			end;
182			end;
183
184			function TActivityReporter.Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
185			begin
186			result := ErrCode;
187			SignalActivity;
188			if RaiseError and (ErrCode > 0) then
189			Firebird25ClientAPI.IBDataBaseError;
190			end;
191
192			procedure TActivityReporter.AddMonitor(aMonitor: IActivityMonitor);
193			var i: integer;
194			begin
195			if FindMonitor(aMonitor) = -1 then
196			begin
197			i := Length(FMonitors);
198			Setlength(FMonitors,i+1);
199			FMonitors[i] := aMonitor;
200			aMonitor.AddObject(self);
201			end;
202			end;
203
204			procedure TActivityReporter.RemoveMonitor(aMonitor: IActivityMonitor);
205			var i,j: integer;
206			begin
207			i := FindMonitor(aMonitor);
208			if i <> -1 then
209			begin
210			aMonitor.Remove(self);
211			if Length(FMonitors) = 1 then
212			SetLength(FMonitors,0)
213			else
214			begin
215			for j := i + 1 to Length(FMonitors) - 1 do
216			FMonitors[j-1] := FMonitors[j];
217			SetLength(FMonitors,Length(FMonitors)-1);
218			end;
219			end;
220			end;
221
222			procedure TActivityReporter.SignalActivity;
223			var i: integer;
224			begin
225			FHasActivity := true;
226			for i := 0 to Length(FMonitors) - 1 do
227			FMonitors[i].SignalActivity;
228			end;
229
230			constructor TActivityReporter.Create(aMonitor: IActivityMonitor;
231			aInterfaces: integer);
232			begin
233			inherited Create(aInterfaces);
234			if aMonitor <> nil then
235			begin
236			SetLength(FMonitors,1);
237			FMonitors[0] := aMonitor;
238			end;
239			end;
240
241			destructor TActivityReporter.Destroy;
242			var i: integer;
243			begin
244			for i := 0 to Length(FMonitors) - 1 do
245			FMonitors[i].Remove(self);
246			inherited Destroy;
247			end;
248
249			function TActivityReporter.HasActivity: boolean;
250			begin
251			Result := FHasActivity;
252			FHasActivity := false;
253			end;
254
255			{ TInterfaceOwner }
256
257			constructor TInterfaceOwner.Create(aInterfaces: integer);
258			begin
259			inherited Create;
260			FMinInterfaces := aInterfaces;
261			SetLength(FInterfaces,aInterfaces);
262			SetLength(FInterfaceRefs,aInterfaces);
263			end;
264
265			destructor TInterfaceOwner.Destroy;
266			begin
267			ReleaseInterfaces;
268			inherited Destroy;
269			end;
270
271			procedure TInterfaceOwner.AddObject(obj: TInterfacedObject);
272			var index: integer;
273			begin
274			index := Length(FInterfaces);
275			SetLength(FInterfaces,index+1);
276			SetLength(FInterfaceRefs,index+1);
277			AddInterface(index,obj);
278			end;
279
280			function TInterfaceOwner.GetInterface(index: integer): TInterfacedObject;
281			begin
282			Result := FInterfaces[index];
283			end;
284
285			procedure TInterfaceOwner.SetRetainInterfaces(AValue: boolean);
286			begin
287			if FRetainInterfaces = AValue then Exit;
288			FRetainInterfaces := AValue;
289			if not FRetainInterfaces then
290			ReleaseInterfaces;
291			end;
292
293			function TInterfaceOwner.GetCount: integer;
294			begin
295			Result := Length(FInterfaces);
296			end;
297
298			procedure TInterfaceOwner.AddInterface(index: integer; obj: TInterfacedObject);
299			begin
300			FInterfaces[index] := obj;
301			if RetainInterfaces then
302			FInterfaceRefs[index] := obj;
303			end;
304
305			function TInterfaceOwner.HasInterface(index: integer): boolean;
306			begin
307			Result := FInterfaces[index] <> nil;
308			end;
309
310			procedure TInterfaceOwner.Remove(intf: TInterfacedObject);
311			var i, j: integer;
312			begin
313			for i := 0 to Length(FInterfaces) - 1 do
314			if FInterfaces[i] = intf then
315			begin
316			if i < FMinInterfaces then
317			begin
318			FInterfaceRefs[i] := nil;
319			FInterfaces[i] := nil;
320			end
321			else
322			begin
323			for j := i to Length(FInterfaces) - 2 do
324			begin
325			FInterfaceRefs[j] := FInterfaceRefs[j+1];
326			FInterfaces[j] := FInterfaces[j+1];
327			end;
328			SetLength(FInterfaces,Length(FInterfaces)-1);
329			SetLength(FInterfaceRefs,Length(FInterfaceRefs)-1);
330			end;
331			Exit;
332			end;
333			end;
334
335			procedure TInterfaceOwner.ReleaseInterfaces;
336			var i: integer;
337			begin
338			for i := 0 to Length(FInterfaces) - 1 do
339			FInterfaceRefs[i] := nil;
340			end;
341
342			end.
343