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 := (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:	87
Committed:	Mon Jan 1 11:31:26 2018 UTC (6 years, 10 months ago) by tony
Content type:	text/x-pascal
File size:	9490 byte(s)
Log Message:	fnintf fixes merged
#	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;
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	var
157	FObjectCount: integer;
158
159	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 := (Length(FInterfaces) > 0) and (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	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	FInterfaceRefs[i] := nil;
352	end;
353	end;
354
355	end.
356