utils/uutlVariantObject.pas

unit uutlVariantObject;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, variants;

function VarObject: TVarType; inline;
function VarIsObject(const aValue: Variant): Boolean; inline;
function VarAsObject(const aValue: Variant): Variant; inline;

operator :=(const aValue: TObject): Variant; inline;
operator :=(const aValue: Variant): TObject; inline;

implementation

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlVariantObject = class(TCustomVariantType)
  public
    function  IsClear (const V: TVarData): Boolean; override;
    procedure Cast    (var Dest: TVarData; const Source: TVarData); override;
    procedure CastTo  (var Dest: TVarData; const Source: TVarData; const aVarType: TVarType); override;
    procedure Clear   (var V: TVarData); override;
    procedure Copy    (var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override;

  public
    class function FromObject(const aObj: TObject): Variant;
    class function ToObject  (const aVar: Variant): TObject;
  end;

var
  VariantObject: TutlVariantObject;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarObject: TVarType;
begin
  result := VariantObject.VarType;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarIsObject(const aValue: Variant): Boolean;
begin
  result := (TVarData(aValue).vtype = VarObject);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarAsObject(const aValue: Variant): Variant;
begin
  if not VarIsObject(aValue)
    then VarCast(result, aValue, VarObject)
    else result := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
operator := (const aValue: TObject): Variant;
begin
  result := TutlVariantObject.FromObject(aValue);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
operator := (const aValue: Variant): TObject;
begin
  result := TutlVariantObject.ToObject(aValue);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlVariantObject/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlVariantObject.IsClear(const V: TVarData): Boolean;
begin
  result := (V.vpointer = nil);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantObject.Cast(var Dest: TVarData; const Source: TVarData);
begin
  RaiseCastError;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantObject.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
var
  tmp: TVarData;
begin
  if (Source.vtype <> VarType) then
    RaiseCastError;
  case aVarType of
    varolestr:
      VarDataFromOleStr(Dest, WideString(Format('$%p', [Source.vpointer])));
    varstring:
      VarDataFromStr(Dest, Format('$%p', [Source.vpointer]));
  else
    VarDataInit(tmp{%H-});
    try
      tmp.vtype  := varqword;
      tmp.vqword := QWord(Source.vpointer);
      VarDataCastTo(Dest, tmp, aVarType);
    finally
      VarDataClear(tmp);
    end;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantObject.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
begin
  if (Dest.vtype <> varempty) and (Dest.vtype <> Source.vtype) then
    RaiseInvalidOp;
  Dest := Source;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantObject.Clear(var V: TVarData);
begin
  V.vpointer := nil;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlVariantObject.FromObject(const aObj: TObject): Variant;
begin
  TVarData(result).vtype    := VarObject;
  TVarData(result).vpointer := aObj;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlVariantObject.ToObject(const aVar: Variant): TObject;
var
  v: Variant;
begin
  v := VarAsObject(aVar);
  result := TObject(TVarData(v).vpointer);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
initialization
  VariantObject := TutlVariantObject.Create;

finalization
  FreeAndNil(VariantObject);

end.