unit RefObjects;

interface

uses
	Classes, SysUtils, ComObj;

type
	TDebugInfoType = (diNames, diValues);
	TRefObject = class(TInterfacedObject)
	protected
		procedure OnFree; virtual;
	public
		constructor Create;
		destructor Destroy; override;
		procedure Free(YouMustNotCallThisMethodDirectly: Boolean);

		procedure AddRef;
		procedure Release;

		procedure GetDebugInfo(aType: TDebugInfoType; aList: TStrings); virtual;
	end;

	TRefObjectList = class(TList)
	private
		FOwnObjects: Boolean;
	protected
		procedure Notify(anItem: Pointer; anAction: TListNotification); override;
		procedure ItemInserted(anItem: Pointer); virtual;
		procedure ItemRemoved(anItem: Pointer); virtual;
	public
		constructor Create(anOwnObjects: Boolean = False);

		procedure FreeItems;
		property OwnObjects: Boolean read FOwnObjects;
	end;

	TAutoIntfRefObject = class(TAutoIntfObject)
	protected
		procedure OnFree; virtual;
	public
		procedure AddRef;
		procedure Release;
		destructor Destroy; override;
	end;

procedure oInit(var aDst; aSrc: TObject);
procedure oReplace(var aDst; aSrc: TObject);
procedure oRelease(var aDst);
procedure oFree(var aDst);

{$IFDEF DEBUG}
var
	GlobalRefObjectList: TStringList = nil; { Strings: ClassNames; Objects: TList }
{$ENDIF}

procedure roReplace(var aDst; aSrc: TRefObject); deprecated;
function RO_Replace(var aDst{ : TRefObject}; aSrc: TRefObject): Boolean; deprecated;
function RO_Init(var aDst{ : TRefObject}; aSrc: TRefObject): Boolean; deprecated;
procedure RO_Release(var aDst{ : TRefObject}); deprecated;
procedure RO_Free(var aDst{ : TRefObject}); deprecated;

implementation

type
	TInterfracedObjectAccess = class(TInterfacedObject)
	end;

procedure oInit(var aDst; aSrc: TObject);
begin
	if aSrc is TInterfacedObject then
		TInterfracedObjectAccess(aSrc)._AddRef;
	TObject(aDst) := aSrc;
end;

function GetClassName(const anObject: TObject): String;
begin
	try
		Result := anObject.ClassName
	except
		Result := 'НЕ известно'
	end;
end;

procedure AssertRefCount(aRefCount: Integer; anObject: TObject);
begin
	Assert(aRefCount > 0, format('Объект не инициализирован, имя класса "%S"', [GetClassName(anObject)]));
end;

procedure oReplace(var aDst; aSrc: TObject);
var
	aPrev, aNew: TObject;
begin
	if TObject(aDst) <> aSrc then begin
		aPrev := TObject(aDst);
		aNew := aSrc;
		if Assigned(aNew) and (aNew is TInterfacedObject) then
			TInterfracedObjectAccess(aNew)._AddRef;
		if Assigned(aPrev) and (aPrev is TInterfacedObject) then begin
			AssertRefCount(TInterfracedObjectAccess(aPrev).RefCount, aPrev);
			TInterfracedObjectAccess(aPrev)._Release;
		end;
		TObject(aDst) := aSrc;
	end;
end;

procedure oRelease(var aDst);
var
	anObject: TObject;
begin
	if Pointer(aDst) = nil then
		Exit;

	anObject := TObject(aDst);
	if anObject is TInterfacedObject then begin
		AssertRefCount(TInterfacedObject(anObject).RefCount, anObject);
		TInterfracedObjectAccess(anObject)._Release;
	end;
	TObject(aDst) := nil;
end;

procedure oFree(var aDst);
var
	anObject: TObject;
begin
	anObject := TObject(aDst);
	if anObject is TRefObject then begin
		AssertRefCount(TRefObject(anObject).RefCount, anObject);
		TRefObject(anObject).AddRef;
		try
			TRefObject(anObject).OnFree;
		finally
			TRefObject(anObject).Release
		end;
		TRefObject(anObject).Release;
	end
	else if (anObject is TAutoIntfRefObject) then begin
		AssertRefCount(TAutoIntfRefObject(anObject).RefCount, anObject);
		TAutoIntfRefObject(anObject).AddRef;
		try
			TAutoIntfRefObject(anObject).OnFree;
		finally
			TAutoIntfRefObject(anObject).Release
		end;
		TAutoIntfRefObject(anObject).Release;
	end
	else if anObject is TInterfacedObject then begin
		AssertRefCount(TInterfacedObject(anObject).RefCount, anObject);
		TInterfracedObjectAccess(anObject)._Release
	end
	else
		anObject.Free;
	TObject(aDst) := nil;
end;

procedure roReplace(var aDst; aSrc: TRefObject);
begin
	if TRefObject(aDst) <> aSrc then begin
		TRefObject(aDst).Release;
		TRefObject(aDst) := aSrc;
		aSrc.AddRef;
	end;
end;

function RO_Replace(var aDst{ : TRefObject}; aSrc: TRefObject): Boolean;
begin
	if TRefObject(aDst) <> aSrc then begin
		TRefObject(aDst).Release;
		TRefObject(aDst) := aSrc;
		if Assigned(aSrc) then
			aSrc.AddRef;
		Result := True
	end
	else
		Result := False;
end;

function RO_Init(var aDst{ : TRefObject}; aSrc: TRefObject): Boolean;
begin
	TRefObject(aDst) := aSrc;
	Result := Assigned(aSrc);
	if Result then
		aSrc.AddRef;
end;

procedure RO_Release(var aDst{ : TRefObject});
var
	aDstObject: TRefObject;
begin
	if Assigned(TRefObject(aDst)) then begin
		aDstObject := TRefObject(aDst);
		TRefObject(aDst) := nil;
		aDstObject.Release;
	end;
end;

procedure RO_Free(var aDst{ : TRefObject});
var
	aDstObject: TRefObject;
begin
	aDstObject := TRefObject(aDst);
	if Assigned(aDstObject) then begin
		TRefObject(aDst) := nil;
		aDstObject.AddRef;
		try
			aDstObject.OnFree;
		finally
			aDstObject.Release
		end;
		aDstObject.Release;
	end;
end;


{$IFDEF DEBUG}

{	GlobalRefObjectList }

procedure RefObjectCreated(anObject: TRefObject);
var
	aList: TList;
	i: Integer;
begin
	if not Assigned(GlobalRefObjectList) then begin
		GlobalRefObjectList := TStringList.Create;
		GlobalRefObjectList.Sorted := True;
		GlobalRefObjectList.Duplicates := DupError;
	end;
	if GlobalRefObjectList.Find(anObject.ClassName, i) then
		aList := TList(GlobalRefObjectList.Objects[i])
	else begin
		aList := TList.Create;
		GlobalRefObjectList.AddObject(anObject.ClassName, aList)
	end;
	aList.Add(anObject);
end;

procedure RefObjectDestroing(anObject: TRefObject);
var
	aList: TList;
	i: Integer;
begin
	if Assigned(GlobalRefObjectList) then
		if GlobalRefObjectList.Find(anObject.ClassName, i) then begin
			aList := TList(GlobalRefObjectList.Objects[i]);
			aList.Remove(anObject);
			if aList.Count = 0 then begin
				aList.Free;
        GlobalRefObjectList.Delete(i);
        if GlobalRefObjectList.Count = 0 then begin
          GlobalRefObjectList.Free;
          GlobalRefObjectList := nil
        end
      end;
    end;
end;

{$ENDIF}

{ TRefObject }

constructor TRefObject.Create;
begin
	inherited Create;
	{$IFDEF DEBUG}
	RefObjectCreated(Self);
	{$ENDIF}
end;

destructor TRefObject.Destroy;
begin
	{$IFDEF DEBUG}
	RefObjectDestroing(Self);
	{$ENDIF}
//	OnFree; {todo: Посмотреть почему закоментарено}
	inherited Destroy;
end;

procedure TRefObject.Free(YouMustNotCallThisMethodDirectly: Boolean);
begin
	raise Exception.CreateFmt(
		'Внутренняя ошибка: прямое уничтожение ссылочного объекта [%s]', [ClassName]);
end;

procedure TRefObject.GetDebugInfo(aType: TDebugInfoType; aList: TStrings);
begin
	case aType of
		diNames:
			aList.Add('RefCount');
		diValues:
			aList.Add(IntToStr(RefCount));
	end;
end;

procedure TRefObject.AddRef;
begin
	_AddRef;
end;

procedure TRefObject.Release;
begin
	if Assigned(Self) then
		_Release
end;

procedure TRefObject.OnFree;
begin

end;

{ TRefObjectList }

constructor TRefObjectList.Create(anOwnObjects: Boolean);
begin
	inherited Create;
	FOwnObjects := anOwnObjects;
end;

procedure TRefObjectList.FreeItems;
var
	i: Integer;
	anItem: TRefObject;
begin
	for i := 0 to Count - 1 do begin
		anItem := inherited Items[i];
		if Assigned(anItem) then begin
			anItem.AddRef;
			try
				inherited Items[i] := nil;
			finally
				oFree(anItem);
			end;
		end;
	end;
	inherited Clear;
end;

procedure TRefObjectList.ItemInserted(anItem: Pointer);
var
	p: Pointer;
begin
	oInit(p, anItem);
end;

procedure TRefObjectList.ItemRemoved(anItem: Pointer);
begin
	if FOwnObjects then
		oFree(anItem)
	else
		oRelease(anItem);
end;

procedure TRefObjectList.Notify(anItem: Pointer; anAction: TListNotification);
begin
	inherited;
	case anAction of
		lnAdded: ItemInserted(anItem);
		lnDeleted: ItemRemoved(anItem);
	end;
end;

{ TAutoIntfRefObject }

procedure TAutoIntfRefObject.AddRef;
begin
	inherited _AddRef;
end;

destructor TAutoIntfRefObject.Destroy;
begin
	OnFree;
	inherited;
end;

procedure TAutoIntfRefObject.OnFree;
begin

end;

procedure TAutoIntfRefObject.Release;
begin
	inherited _Release;
end;


initialization

finalization
{$IFDEF DEBUG}
	FreeStringsWithObjects(GlobalRefObjectList);
	GlobalRefObjectList := nil;
{$ENDIF}
end.

