ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/FBActivityMonitor.pas
Revision: 56
Committed: Mon Mar 6 10:20:02 2017 UTC (7 years ago) by tony
Content type: text/x-pascal
File size: 9458 byte(s)
Log Message:
Committing updates for Trunk

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 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 := 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