unit autofree experimental;
{$if fpc_fullversion < 30301}
{$error this code needs FPC version 3.3.1 or higher}
{$ifend}
{$mode delphi}{$interfaces com}
{
This code is inspired by the code from ASerge on the Freepascal forum.
I added a interface storage, which makes it possible to drop is and as
At the moment it has the disadvantage that all allocations are governed
by the store so all objects are released when the store is released.
I am working on that....}
interface
type
{ Our own interface type }
IAutoFree = interface(IUnknown)
['{89D8F215-61FF-4EBF-8C9E-9C027619DC0E}']
end;
{ create an instance from a class reference }
function Auto(ACls: TClass ): IAutoFree;overload;
{ create an instance of a class }
function Auto(AObj: TObject): IAutoFree;overload;
{ Currently the compiler chokes on this:
function Auto<T:class, constructor>:T;overload;
procedure Auto<T:class>(out value:T);overload;}
function AutoAdd(AObj: TObject): IAutoFree;overload;
implementation
uses
classes;
type
TAutoFreeHolder = class(TInterfacedObject,IAutoFree)
strict private
FObj: TObject;
protected
function QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;winapi;
public
class var Store:IInterfaceList;
class constructor Create;
constructor Create(AObj: TObject);
destructor Destroy; override;
end;
{ for some reason my current trunk version does not let me
add these two generics to the autofree unit
function Auto<T:class, constructor>:T;overload;
begin
Result := Auto(T.Create) as T;
end;
procedure Auto<T:class>(out value:T);overload;
begin
Value := Auto(T.Create) as T;
end;
}
function Auto(AObj: TObject): IAutoFree;overload;
begin
Result := TAutoFreeHolder.Create(AObj);
TAutoFreeHolder.Store.Add(Result);
end;
function Auto(ACls: TClass): IAutofree;overload;
begin
Result := Auto(ACls.Create);
end;
function AutoAdd(AObj: TObject): IAutofree;
begin
Result := TAutoFreeHolder.Create(AObj);
end;
class constructor TAutoFreeHolder.Create;
begin
Store :=TInterfaceList.Create;
end;
constructor TAutoFreeHolder.Create(AObj: TObject);
begin
inherited Create;
FObj := AObj;
end;
destructor TAutoFreeHolder.Destroy;
begin
FObj.Free;
inherited;
end;
function TAutoFreeHolder.QueryInterface({$IFDEF FPC_HAS_CONSTREF}constref{$ELSE}const{$ENDIF} iid : tguid;out obj) : longint;winapi;
begin
if Assigned(FObj) and FObj.GetInterface(iid, obj) then
Result := S_OK
else
Result := inherited;
end;
end.
Recent
