more work on class tracking

library/fsl/fsl_base.pas

@@ -95,6 +95,7 @@ function ExceptionStack(e : Exception) : String;
  // particular subclasses
  EFslAbstract = Class(EFslException);
  EFslAssertion = Class(EFslException);
+ EObjectTrackingFail = class (EFslAssertion);
  ETodo = Class(EFslException)
  public
  Constructor Create(place : String);
@@ -1012,11 +1013,38 @@ procedure TClassTrackingType.check(msg: String; condition: boolean);
  Message := Description;
 End;
 
+procedure handleObjectTrackingFail(msg : String);
+var
+ fn : String;
+ f : System.text;
+begin
+ // Application is pretty much cactus at this point, so we don't mind doing
+ // slow file operation inside such a system critical lock as GLock
+
+ try
+ fn := 'c:\temp\object-tracking-errors.log';
+ AssignFile(f, fn);
+ if (FileExists(fn)) then
+ Append(f)
+ else
+ Rewrite(f);
+ writeln(f, msg);
+ closeFile(f);
+ except
+ // nothing - we really can't do anything
+ end;
+
+ raise EObjectTrackingFail.create(msg);
+end;
+
 { TFslObject }
 
 constructor TFslObject.Create;
 var
  t : TClassTrackingType;
+ {$IFOPT C+}
+ isNil : boolean;
+ {$ENDIF}
 Begin
  Inherited;
  {$IFOPT D+}
@@ -1041,6 +1069,12 @@ constructor TFslObject.Create;
  t := TClassTrackingType.Create;
  GClassTracker.Add(ClassName, t);
  end;
+ {$IFOPT C+}
+ isNil := t.firstObject = nil;
+ if not (isNil = (t.count = 0)) then
+ handleObjectTrackingFail(className+': firstObject = '+BoolToStr(isNil, 'Nil', 'not nil')+' and count = '+inttostr(t.count)+' (create)');
+ {$ENDIF}
+
  inc(t.count);
  inc(t.deltaCount);
  inc(t.serial);
@@ -1051,8 +1085,6 @@ constructor TFslObject.Create;
  {$ENDIF}
  if t.firstObject = nil then
  begin
- if (t.count <> 1) then
- assert(t.count = 1, 'Object Tracking Error - tracking record for '+className+' is nil, but count is '+inttostr(t.count));
  t.firstObject := self;
  t.lastObject := self;
  FPrev := nil;
@@ -1073,20 +1105,26 @@ constructor TFslObject.Create;
 
 destructor TFslObject.Destroy;
 var
- t : TClassTrackingType;
+ t : TClassTrackingType; 
+ {$IFOPT C+}
+ isNil : boolean;
+ {$ENDIF}
 Begin
  {$IFDEF OBJECT_TRACKING}
  if GInited then
  begin
  EnterCriticalSection(GLock);
  try
  if GClassTracker.TryGetValue(ClassName, t) then // this will succeed
- begin
- assert(t.count > 0);
- if FPrev <> nil then 
- assert(FPrev.ClassName = className, 'Previous object wrong class: '+ClassName);
- if FNext <> nil then
- assert(FNext.ClassName = className, 'Next object wrong class: '+ClassName);
+ begin 
+ {$IFOPT C+}
+ if (t.count = 0) then
+ handleObjectTrackingFail(className+': count is 0 freeing object');
+ if (FPrev <> nil) and (FPrev.ClassName <> className) then
+ handleObjectTrackingFail(className+': Previous object wrong class: '+FPrev.ClassName);
+ if (FNext <> nil) and (FNext.ClassName <> className) then
+ handleObjectTrackingFail(className+': Next object wrong class: '+FNext.ClassName);
+ {$ENDIF}
 
  dec(t.Count);
  dec(t.deltaCount);
@@ -1117,10 +1155,17 @@ assert(FNext.ClassName = className, 'Next object wrong class: '+ClassN
  end;
  end
  else
- assert(false, 'Object Tracking Error - tracking record for '+ClassName+' not found');
+ begin
+ {$IFOPT C+}
+ handleObjectTrackingFail(ClassName+': tracking record not found in destroy');
+ {$ENDIF}
+ end;
 
- if (t.firstObject = nil) and (t.count > 0) then
- assert(t.count = 1, 'Object Tracking Error - tracking record for '+ClassName+' just became nil, but count is '+inttostr(t.count));
+ {$IFOPT C+}
+ isNil := t.firstObject = nil;
+ if not (isNil = (t.count = 0)) then
+ handleObjectTrackingFail(className+': firstObject = '+BoolToStr(isNil, 'Nil', 'not nil')+' and count = '+inttostr(t.count)+' (destroy)');
+ {$ENDIF}
  finally
  LeaveCriticalSection(GLock);
  end;