Having written your nice COM Object model to allow access to your application, how do you find out if you have neen clearing up the objects correctly and check you are handling zombie objects correctly too.
If you add the following unit to your aplication and descend your comobjects from TTracker instead of TAutoObject, this unit will count the number of addrefs and releases that occur on the object.
All you need to do is call TTrackerlog.dump to get a list of all the objects, the maximum number of instances ever alive and the current number alive.
All we are doing, is overriding the addref and release implementation, and maintaing a list of stats based up on the objects classname.
unit ObjectTracker;
interface
uses
Classes, SysUtils, ComObj, Contnrs, SyncObjs, ActiveX;
type
TTrackedItemInfo = (iiCreationOnAdd, iiCreationOnRelease);
TTrackedItemInfos = set of TTrackedItemInfo;
TTracker = class (TAutoObject)
FTrackedClassName: string;
public
constructor create; virtual;
function ObjAddRef: Integer; override; stdcall;
function ObjRelease: Integer; override; stdcall;
end;
TTrackedItem = class (TObject)
private
FDesc: string;
FInfo: TTrackedItemInfos;
FMaxCount: Integer;
FMinCount: Integer;
FObjAddress: Pointer;
FRefCount: Integer;
public
constructor Create(AnObj : pointer);
procedure AddReference;
procedure RemoveReference;
property Desc: string read FDesc write FDesc;
property Info: TTrackedItemInfos read FInfo write FInfo;
property MaxCount: Integer read FMaxCount;
property MinCount: Integer read FMinCount;
property ObjAddress: Pointer read FObjAddress write FObjAddress;
property RefCount: Integer read FRefCount;
end;
TTrackerLog = class (TObject)
FList: TObjectList;
FLock: TMultiReadExclusiveWriteSynchronizer;
protected
constructor CreateInstance;
class function AccessInstance(Request: Integer): TTrackerLog;
public
constructor Create; virtual;
destructor Destroy; override;
procedure AddReference(AnObj : TObject; TrackedClassName : string);
procedure Dump(const AFilename : widestring);
class function Instance: TTrackerLog;
class procedure ReleaseInstance;
procedure ReleaseReference(AnObj : TObject; TrackedClassName : string);
end;
implementation
{ TTracker }
{
*************************** TTracker ***************************
}
constructor TTracker.create;
begin
inherited;
FTrackedClassName := Classname;
end;
function TTracker.ObjAddRef: Integer;
begin
result := inherited ObjAddRef;
TTrackerLog.Instance.AddReference(self,FTrackedClassName);
end;
function TTracker.ObjRelease: Integer;
begin
result := inherited ObjRelease;
TTrackerLog.Instance.ReleaseReference(self,FTrackedClassName);
end;
{ TTrackerLog }
{
**************************** TTrackedItem *************************
}
constructor TTrackedItem.Create(AnObj : pointer);
begin
inherited Create;
FMinCount := 0;
FMaxCount := 0;
FObjAddress := Anobj;
FRefCount := 0;
FInfo := [];
end;
procedure TTrackedItem.AddReference;
begin
inc(FRefCount);
if FMaxCount < FRefCount then FMaxCount := FRefCount;
end;
procedure TTrackedItem.RemoveReference;
begin
Dec(FRefCount);
if FMinCount > FRefCount then FMinCount := FRefCount;
end;
{
**************************** TTrackerLog ****************************
}
constructor TTrackerLog.Create;
begin
raise Exception.CreateFmt(‘Access class %s through Instance only’, [ClassName]);
inherited create;
end;
constructor TTrackerLog.CreateInstance;
begin
inherited Create;
FList := TObjectList.create(true);
FLock := TMultiReadExclusiveWriteSynchronizer.create;
end;
destructor TTrackerLog.Destroy;
begin
if AccessInstance(0) = Self then AccessInstance(2);
FreeAndNil(FLock);
FreeAndNil(FList);
inherited Destroy;
end;
class function TTrackerLog.AccessInstance(Request: Integer): TTrackerLog;
{$WRITEABLECONST ON}
const FInstance: TTrackerLog = nil;
{$WRITEABLECONST OFF}
begin
case Request of
0 : ;
1 : if not Assigned(FInstance) then FInstance := CreateInstance;
2 : FInstance := nil;
else
raise Exception.CreateFmt(‘Illegal request %d in AccessInstance’, [Request]);
end;
Result := FInstance;
end;
procedure TTrackerLog.AddReference(AnObj : TObject; TrackedClassName : string);
var
i: Integer;
Item: TTrackedItem;
begin
FLock.BeginWrite;
try
i := FList.count -1;
while (i >= 0) and (TTrackedItem(FList.items[i]).ObjAddress <> AnObj) do dec(i);
if i = -1 then // not found
begin
item := TTrackedItem.create(AnObj);
item.Info := Item.Info + [iiCreationOnAdd];
item.Desc := TrackedClassName;
Flist.add(item);
end
else
item := TTrackedItem(FList.items[i]);
item.AddReference;
finally
 
; FLock.EndWrite
end;
end;
procedure TTrackerLog.Dump(const AFilename : widestring);
var
FName: string;
i: Integer;
Item: TTrackedItem;
fs: TFileStream;
t: string;
begin
FLock.BeginRead;
try
// FName := GetModuleName(HInstance);
// FName := ChangeFileExt(FName,formatdatetime(‘.hhnnss’,now)) + ‘.csv’;
FName := AFilename;
if FList.Count > 0 then
begin
fs := TFileStream.create(fname,fmCreate);
t := ‘”Address”,”ClassName”,”RefCount&quo
t;,”Max”,”Min”‘ + #13#10;
fs.Write(t[1],length(t));
for i := 0 to FList.count -1 do
begin
item := TTrackedItem(FList.items[i]);
t := format(‘”%x”,”%s”,%d,%d,%d’,[integer(item.
ObjAddress),item.Desc, item.RefCount, item.MaxCount, item.MinCount]) + #13#10;
fs.Write(t[1],length(t));
end;
fs.free;
end;
finally
FLock.EndRead;
end;
end;
class function TTrackerLog.Instance: TTrackerLog;
begin
Result := AccessInstance(1);
end;
class procedure TTrackerLog.ReleaseInstance;
begin
AccessInstance(0).Free;
end;
procedure TTrackerLog.ReleaseReference(AnObj : TObject; TrackedClassName : string);
var
i: Integer;
Item: TTrackedItem;
begin
FLock.BeginWrite;
try
i := FList.count – 1;
while (i >= 0) and (TTrackedItem(FList.items[i]).ObjAddress <> AnObj) do dec(i);
if i = -1 then // not found
begin
item := TTrackedItem.create(AnObj);
item.Info := Item.Info + [iiCreationOnRelease];
item.Desc := TrackedClassName;
Flist.add(item);
end
else
item := TTrackedItem(FList.items[i]);
item.RemoveReference;
finally
FLock.EndWrite
end;
end;
initialization
finalization
if TTrackerLog.Instance <> nil then TTrackerLog.ReleaseInstance;
end.