ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBActivityMonitor.pas
Revision: 315
Committed: Thu Feb 25 11:56:36 2021 UTC (3 years, 8 months ago) by tony
Content type: text/x-pascal
File size: 9722 byte(s)
Log Message:
Updated for IBX 4 release

File Contents

# 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 ['{8261840a-741b-4c1c-94ea-c5c66ba72f22}']
95 procedure AddObject(obj: TInterfacedObject);
96 procedure Remove(intf: TInterfacedObject);
97 procedure SignalActivity;
98 end;
99
100 { TActivityReporter is a base class for objects that need to report their activity
101 to an activity monitor, where activity is defined as use of a Firebird API call.
102 Objects descending from this class always used the "Call" method as a wrapper
103 for calls to the Firebird API. Each such call is then classed as activity
104 and reported to one or more activity monitors.
105
106 In practice, a transaction monitors statements, blobs and arrays. A Database
107 monitors transactions and events. Transaction monitors use the ITransactionMonitor
108 interface, implemented through the helper object TTransactionMonitor.
109 }
110
111 TOnDatabaseError = procedure of object;
112
113 TActivityReporter = class(TInterfaceOwner)
114 private
115 FHasActivity: boolean;
116 FMonitors: array of IActivityMonitor;
117 FOnDatabaseError: TOnDatabaseError;
118 function FindMonitor(aMonitor: IActivityMonitor): integer;
119 protected
120 function Call(ErrCode: ISC_STATUS; RaiseError: Boolean = true): ISC_STATUS;
121 procedure AddMonitor(aMonitor: IActivityMonitor);
122 procedure RemoveMonitor(aMonitor: IActivityMonitor);
123 public
124 constructor Create(aMonitor: IActivityMonitor;aInterfaces: integer=0);
125 destructor Destroy; override;
126 function HasActivity: boolean;
127 procedure SignalActivity;
128 property OnDatabaseError: TOnDatabaseError read FOnDatabaseError write FOnDatabaseError;
129 end;
130
131 { TActivityHandler is a base class for classes that receive activity reports.}
132
133 TActivityHandler = class(TInterfaceOwner,IActivityMonitor)
134 private
135 FHasActivity: boolean;
136 public
137 function HasActivity: boolean;
138 procedure SignalActivity;
139 end;
140
141 implementation
142
143 uses FBClientAPI;
144
145 { TActivityHandler }
146
147 function TActivityHandler.HasActivity: boolean;
148 begin
149 Result := FHasActivity;
150 FHasActivity := false;
151 end;
152
153 procedure TActivityHandler.SignalActivity;
154 begin
155 FHasActivity := true;
156 end;
157
158 { TMonitoredObject }
159
160 {$IFDEF DEBUGINTERFACES}
161 var
162 FObjectCount: integer;
163
164 constructor TMonitoredObject.Create;
165 begin
166 inherited Create;
167 Inc(FObjectCount);
168 writeln('Creating ' + ClassName,', Obj Count = ',FObjectCount);
169 end;
170
171 destructor TMonitoredObject.Destroy;
172 begin
173 Dec(FObjectCount);
174 writeln('Destroying ' + ClassName,' Obj Count = ',FObjectCount);
175 inherited Destroy;
176 end;
177 {$ENDIF}
178
179 { TActivityReporter}
180
181 function TActivityReporter.FindMonitor(aMonitor: IActivityMonitor): integer;
182 var i: integer;
183 begin
184 Result := -1;
185 for i := 0 to Length(FMonitors) - 1 do
186 if FMonitors[i] = aMonitor then
187 begin
188 Result := i;
189 Exit;
190 end;
191 end;
192
193 function TActivityReporter.Call(ErrCode: ISC_STATUS; RaiseError: Boolean): ISC_STATUS;
194 begin
195 result := ErrCode;
196 SignalActivity;
197 if RaiseError and (ErrCode > 0) and assigned(FOnDatabaseError) then
198 OnDatabaseError;
199 end;
200
201 procedure TActivityReporter.AddMonitor(aMonitor: IActivityMonitor);
202 var i: integer;
203 begin
204 if FindMonitor(aMonitor) = -1 then
205 begin
206 i := Length(FMonitors);
207 Setlength(FMonitors,i+1);
208 FMonitors[i] := aMonitor;
209 aMonitor.AddObject(self);
210 end;
211 end;
212
213 procedure TActivityReporter.RemoveMonitor(aMonitor: IActivityMonitor);
214 var i,j: integer;
215 begin
216 i := FindMonitor(aMonitor);
217 if i <> -1 then
218 begin
219 aMonitor.Remove(self);
220 if Length(FMonitors) = 1 then
221 SetLength(FMonitors,0)
222 else
223 begin
224 for j := i + 1 to Length(FMonitors) - 1 do
225 FMonitors[j-1] := FMonitors[j];
226 SetLength(FMonitors,Length(FMonitors)-1);
227 end;
228 end;
229 end;
230
231 procedure TActivityReporter.SignalActivity;
232 var i: integer;
233 begin
234 FHasActivity := true;
235 for i := 0 to Length(FMonitors) - 1 do
236 FMonitors[i].SignalActivity;
237 end;
238
239 constructor TActivityReporter.Create(aMonitor: IActivityMonitor;
240 aInterfaces: integer);
241 begin
242 inherited Create(aInterfaces);
243 if aMonitor <> nil then
244 begin
245 SetLength(FMonitors,1);
246 FMonitors[0] := aMonitor;
247 end;
248 end;
249
250 destructor TActivityReporter.Destroy;
251 var i: integer;
252 begin
253 for i := 0 to Length(FMonitors) - 1 do
254 FMonitors[i].Remove(self);
255 inherited Destroy;
256 end;
257
258 function TActivityReporter.HasActivity: boolean;
259 begin
260 Result := FHasActivity;
261 FHasActivity := false;
262 end;
263
264 { TInterfaceOwner }
265
266 constructor TInterfaceOwner.Create(aInterfaces: integer);
267 begin
268 inherited Create;
269 FMinInterfaces := aInterfaces;
270 SetLength(FInterfaces,aInterfaces);
271 SetLength(FInterfaceRefs,aInterfaces);
272 end;
273
274 destructor TInterfaceOwner.Destroy;
275 begin
276 ReleaseInterfaces;
277 inherited Destroy;
278 end;
279
280 procedure TInterfaceOwner.AddObject(obj: TInterfacedObject);
281 var index: integer;
282 begin
283 index := Length(FInterfaces);
284 SetLength(FInterfaces,index+1);
285 SetLength(FInterfaceRefs,index+1);
286 AddInterface(index,obj);
287 end;
288
289 function TInterfaceOwner.GetInterface(index: integer): TInterfacedObject;
290 begin
291 Result := FInterfaces[index];
292 end;
293
294 procedure TInterfaceOwner.SetRetainInterfaces(AValue: boolean);
295 begin
296 if FRetainInterfaces = AValue then Exit;
297 FRetainInterfaces := AValue;
298 if not FRetainInterfaces then
299 ReleaseInterfaces;
300 end;
301
302 function TInterfaceOwner.GetCount: integer;
303 begin
304 Result := Length(FInterfaces);
305 end;
306
307 procedure TInterfaceOwner.AddInterface(index: integer; obj: TInterfacedObject);
308 begin
309 FInterfaces[index] := obj;
310 if RetainInterfaces then
311 FInterfaceRefs[index] := obj;
312 end;
313
314 function TInterfaceOwner.HasInterface(index: integer): boolean;
315 begin
316 Result := (Length(FInterfaces) > 0) and (FInterfaces[index] <> nil);
317 end;
318
319 procedure TInterfaceOwner.Remove(intf: TInterfacedObject);
320 var i, j: integer;
321 begin
322 for i := 0 to Length(FInterfaces) - 1 do
323 if FInterfaces[i] = intf then
324 begin
325 if i < FMinInterfaces then
326 begin
327 FInterfaceRefs[i] := nil;
328 FInterfaces[i] := nil;
329 end
330 else
331 begin
332 for j := i to Length(FInterfaces) - 2 do
333 begin
334 FInterfaceRefs[j] := FInterfaceRefs[j+1];
335 FInterfaces[j] := FInterfaces[j+1];
336 end;
337 SetLength(FInterfaces,Length(FInterfaces)-1);
338 SetLength(FInterfaceRefs,Length(FInterfaceRefs)-1);
339 end;
340 Exit;
341 end;
342 end;
343
344 procedure TInterfaceOwner.ReleaseInterfaces;
345 var i: integer;
346 begin
347 for i := 0 to Length(FInterfaces) - 1 do
348 begin
349 {$IFNDEF FPC}
350 {With Delphi we need to explicitly null the object reference when it is
351 going to be disposed of. This is because Delphi does not drop the reference
352 count until after the containing object is released.}
353 if (FInterfaces[i] <> nil) and (FInterfaces[i].RefCount <= 2) then
354 FInterfaces[i] := nil;
355 {$ENDIF}
356 FInterfaceRefs[i] := nil;
357 end;
358 end;
359
360 end.
361