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
#	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	{$IFDEF MSWINDOWS}
29	{$DEFINE WINDOWS}
30	{$ENDIF}
31
32	{$IFDEF FPC}
33	{$mode delphi}
34	{$interfaces COM}
35	{$ENDIF}
36
37	interface
38
39	uses
40	Classes, SysUtils, IBExternals, IB;
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	TOnDatabaseError = procedure of object;
111
112	TActivityReporter = class(TInterfaceOwner)
113	private
114	FHasActivity: boolean;
115	FMonitors: array of IActivityMonitor;
116	FOnDatabaseError: TOnDatabaseError;
117	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	property OnDatabaseError: TOnDatabaseError read FOnDatabaseError write FOnDatabaseError;
128	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	uses FBClientAPI;
143
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	var
161	FObjectCount: integer;
162
163	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	if RaiseError and (ErrCode > 0) and assigned(FOnDatabaseError) then
197	OnDatabaseError;
198	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	Result := (Length(FInterfaces) > 0) and (FInterfaces[index] <> nil);
316	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	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	FInterfaceRefs[i] := nil;
356	end;
357	end;
358
359	end.
360