Delphi

Tracking COM Object instancing

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
   &nbsp
; 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.