Snippets

Stefan Glienke TValue owns object

Created by Stefan Glienke last modified
program Project1;

{$APPTYPE CONSOLE}

uses
  Rtti,
  SysUtils;

type
  TValueDataImpl = class(TInterfacedObject, IValueData)
  private
    FInstance: TObject;
  public
    constructor Create(const instance: TObject);
    destructor Destroy; override;

    function GetDataSize: Integer;
    procedure ExtractRawData(ABuffer: Pointer);
    procedure ExtractRawDataNoCopy(ABuffer: Pointer);
    function GetReferenceToRawData: Pointer;
  end;

  TValueHelper = record helper for TValue
    class function FromObject(const value: TObject; ownsObject: Boolean = True): TValue; static;
  end;

class function TValueHelper.FromObject(const value: TObject;
  ownsObject: Boolean): TValue;
begin
  Result := value;
{$IFNDEF AUTOREFCOUNT}
  if ownsObject then
    TValueData(Result).FValueData := TValueDataImpl.Create(value);
{$ENDIF}
end;

constructor TValueDataImpl.Create(const instance: TObject);
begin
  inherited Create;
  FInstance := instance;
end;

destructor TValueDataImpl.Destroy;
begin
  FInstance.Free;
  inherited;
end;

procedure TValueDataImpl.ExtractRawData(ABuffer: Pointer);
begin
end;

procedure TValueDataImpl.ExtractRawDataNoCopy(ABuffer: Pointer);
begin
end;

function TValueDataImpl.GetDataSize: Integer;
begin
  Result := 0;
end;

function TValueDataImpl.GetReferenceToRawData: Pointer;
begin
  Result := nil;
end;

procedure Main;
var
  v: TValue;
  o: TObject;
begin
  o := TObject.Create;
  v := o;
  v := TValue.FromObject(o);
  Writeln(TObject(v.GetReferenceToRawData^).ClassName);
end;

begin
  try
    Main;
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;
  ReportMemoryLeaksOnShutdown := True;
  Readln;
end.

Comments (0)

HTTPS SSH

You can clone a snippet to your computer for local editing. Learn more.