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, 11 months ago) by tony
Content type:	text/x-pascal
File size:	9068 byte(s)
Log Message:	Committing updates for Release R2-0-0
#	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
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