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
    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}
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) 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
  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:	56
Committed:	Mon Mar 6 10:20:02 2017 UTC (7 years, 1 month ago) by tony
Content type:	text/x-pascal
File size:	9458 byte(s)
Log Message:	Committing updates for Trunk
#	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			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			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			TActivityReporter = class(TInterfaceOwner)
111			private
112			FHasActivity: boolean;
113			FMonitors: array of IActivityMonitor;
114			function FindMonitor(aMonitor: IActivityMonitor): integer;
115			protected
116			function Call(ErrCode: ISC_STATUS; RaiseError: Boolean = true): ISC_STATUS;
117			procedure AddMonitor(aMonitor: IActivityMonitor);
118			procedure RemoveMonitor(aMonitor: IActivityMonitor);
119			public
120			constructor Create(aMonitor: IActivityMonitor;aInterfaces: integer=0);
121			destructor Destroy; override;
122			function HasActivity: boolean;
123			procedure SignalActivity;
124			end;
125
126			{ TActivityHandler is a base class for classes that receive activity reports.}
127
128			TActivityHandler = class(TInterfaceOwner,IActivityMonitor)
129			private
130			FHasActivity: boolean;
131			public
132			function HasActivity: boolean;
133			procedure SignalActivity;
134			end;
135
136			implementation
137
138			uses FB25ClientAPI;
139
140			{ TActivityHandler }
141
142			function TActivityHandler.HasActivity: boolean;
143			begin
144			Result := FHasActivity;
145			FHasActivity := false;
146			end;
147
148			procedure TActivityHandler.SignalActivity;
149			begin
150			FHasActivity := true;
151			end;
152
153			{ TMonitoredObject }
154
155			{$IFDEF DEBUGINTERFACES}
156	tony	56	var
157			FObjectCount: integer;
158
159	tony	45	constructor TMonitoredObject.Create;
160			begin
161			inherited Create;
162			Inc(FObjectCount);
163			writeln('Creating ' + ClassName,', Obj Count = ',FObjectCount);
164			end;
165
166			destructor TMonitoredObject.Destroy;
167			begin
168			Dec(FObjectCount);
169			writeln('Destroying ' + ClassName,' Obj Count = ',FObjectCount);
170			inherited Destroy;
171			end;
172			{$ENDIF}
173
174			{ TActivityReporter}
175
176			function TActivityReporter.FindMonitor(aMonitor: IActivityMonitor): integer;
177			var i: integer;
178			begin
179			Result := -1;
180			for i := 0 to Length(FMonitors) - 1 do
181			if FMonitors[i] = aMonitor then
182			begin
183			Result := i;
184			Exit;
185			end;
186			end;
187
188			function TActivityReporter.Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
189			begin
190			result := ErrCode;
191			SignalActivity;
192			if RaiseError and (ErrCode > 0) then
193			Firebird25ClientAPI.IBDataBaseError;
194			end;
195
196			procedure TActivityReporter.AddMonitor(aMonitor: IActivityMonitor);
197			var i: integer;
198			begin
199			if FindMonitor(aMonitor) = -1 then
200			begin
201			i := Length(FMonitors);
202			Setlength(FMonitors,i+1);
203			FMonitors[i] := aMonitor;
204			aMonitor.AddObject(self);
205			end;
206			end;
207
208			procedure TActivityReporter.RemoveMonitor(aMonitor: IActivityMonitor);
209			var i,j: integer;
210			begin
211			i := FindMonitor(aMonitor);
212			if i <> -1 then
213			begin
214			aMonitor.Remove(self);
215			if Length(FMonitors) = 1 then
216			SetLength(FMonitors,0)
217			else
218			begin
219			for j := i + 1 to Length(FMonitors) - 1 do
220			FMonitors[j-1] := FMonitors[j];
221			SetLength(FMonitors,Length(FMonitors)-1);
222			end;
223			end;
224			end;
225
226			procedure TActivityReporter.SignalActivity;
227			var i: integer;
228			begin
229			FHasActivity := true;
230			for i := 0 to Length(FMonitors) - 1 do
231			FMonitors[i].SignalActivity;
232			end;
233
234			constructor TActivityReporter.Create(aMonitor: IActivityMonitor;
235			aInterfaces: integer);
236			begin
237			inherited Create(aInterfaces);
238			if aMonitor <> nil then
239			begin
240			SetLength(FMonitors,1);
241			FMonitors[0] := aMonitor;
242			end;
243			end;
244
245			destructor TActivityReporter.Destroy;
246			var i: integer;
247			begin
248			for i := 0 to Length(FMonitors) - 1 do
249			FMonitors[i].Remove(self);
250			inherited Destroy;
251			end;
252
253			function TActivityReporter.HasActivity: boolean;
254			begin
255			Result := FHasActivity;
256			FHasActivity := false;
257			end;
258
259			{ TInterfaceOwner }
260
261			constructor TInterfaceOwner.Create(aInterfaces: integer);
262			begin
263			inherited Create;
264			FMinInterfaces := aInterfaces;
265			SetLength(FInterfaces,aInterfaces);
266			SetLength(FInterfaceRefs,aInterfaces);
267			end;
268
269			destructor TInterfaceOwner.Destroy;
270			begin
271			ReleaseInterfaces;
272			inherited Destroy;
273			end;
274
275			procedure TInterfaceOwner.AddObject(obj: TInterfacedObject);
276			var index: integer;
277			begin
278			index := Length(FInterfaces);
279			SetLength(FInterfaces,index+1);
280			SetLength(FInterfaceRefs,index+1);
281			AddInterface(index,obj);
282			end;
283
284			function TInterfaceOwner.GetInterface(index: integer): TInterfacedObject;
285			begin
286			Result := FInterfaces[index];
287			end;
288
289			procedure TInterfaceOwner.SetRetainInterfaces(AValue: boolean);
290			begin
291			if FRetainInterfaces = AValue then Exit;
292			FRetainInterfaces := AValue;
293			if not FRetainInterfaces then
294			ReleaseInterfaces;
295			end;
296
297			function TInterfaceOwner.GetCount: integer;
298			begin
299			Result := Length(FInterfaces);
300			end;
301
302			procedure TInterfaceOwner.AddInterface(index: integer; obj: TInterfacedObject);
303			begin
304			FInterfaces[index] := obj;
305			if RetainInterfaces then
306			FInterfaceRefs[index] := obj;
307			end;
308
309			function TInterfaceOwner.HasInterface(index: integer): boolean;
310			begin
311			Result := FInterfaces[index] <> nil;
312			end;
313
314			procedure TInterfaceOwner.Remove(intf: TInterfacedObject);
315			var i, j: integer;
316			begin
317			for i := 0 to Length(FInterfaces) - 1 do
318			if FInterfaces[i] = intf then
319			begin
320			if i < FMinInterfaces then
321			begin
322			FInterfaceRefs[i] := nil;
323			FInterfaces[i] := nil;
324			end
325			else
326			begin
327			for j := i to Length(FInterfaces) - 2 do
328			begin
329			FInterfaceRefs[j] := FInterfaceRefs[j+1];
330			FInterfaces[j] := FInterfaces[j+1];
331			end;
332			SetLength(FInterfaces,Length(FInterfaces)-1);
333			SetLength(FInterfaceRefs,Length(FInterfaceRefs)-1);
334			end;
335			Exit;
336			end;
337			end;
338
339			procedure TInterfaceOwner.ReleaseInterfaces;
340			var i: integer;
341			begin
342			for i := 0 to Length(FInterfaces) - 1 do
343	tony	56	begin
344			{$IFNDEF FPC}
345			{With Delphi we need to explicitly null the object reference when it is
346			going to be disposed of. This is because Delphi does not drop the reference
347			count until after the containing object is released.}
348			if (FInterfaces[i] <> nil) and (FInterfaces[i].RefCount <= 2) then
349			FInterfaces[i] := nil;
350			{$ENDIF}
351	tony	45	FInterfaceRefs[i] := nil;
352	tony	56	end;
353	tony	45	end;
354
355			end.
356