utils/uutlVariantProperty.pas

unit uutlVariantProperty;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, variants, typinfo;

function VarProperty: TVarType; inline;
function VarIsProperty(const aValue: Variant): Boolean; inline;
function VarAsProperty(const aValue: Variant): Variant; inline;

operator :=(const aValue: PPropInfo): Variant;
operator :=(const aValue: Variant): PPropInfo;

implementation

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlVariantPropInfo = 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 FromPropInfo(const aPropInfo: PPropInfo): Variant;
    class function ToPropInfo  (const aValue: Variant): PPropInfo;
  end;

var
  VariantProperty: TutlVariantPropInfo;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarProperty: TVarType;
begin
  result := VariantProperty.VarType;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarIsProperty(const aValue: Variant): Boolean;
begin
  result := (VarType(aValue) = VarProperty);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarAsProperty(const aValue: Variant): Variant;
begin
  if not VarIsProperty(aValue)
    then VarCast(result, aValue, VarProperty)
    else result := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
operator := (const aValue: PPropInfo): Variant;
begin
  result := TutlVariantPropInfo.FromPropInfo(aValue);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
operator := (const aValue: Variant): PPropInfo;
begin
  result := TutlVariantPropInfo.ToPropInfo(aValue);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlVariantProperty///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TutlVariantPropInfo.IsClear(const V: TVarData): Boolean;
begin
  result := not Assigned(V.vpointer);
end;

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

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantPropInfo.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
begin
  if (Source.vtype <> VarType) then
    RaiseCastError;
  case aVarType of
    varolestr:
      if IsClear(Source)
        then VarDataFromOleStr(Dest, '')
        else VarDataFromOleStr(Dest, WideString(PPropInfo(Source.vpointer)^.Name));
    varstring:
      if IsClear(Source)
        then VarDataFromStr(Dest, '')
        else VarDataFromStr(Dest, PPropInfo(Source.vpointer)^.Name);
  else
    RaiseCastError;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantPropInfo.Clear(var V: TVarData);
begin
  if Assigned(V.vpointer) then begin
    Dispose(PPropInfo(V.vpointer));
    V.vpointer := nil;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantPropInfo.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
begin
  if (Dest.vtype <> varempty) and (Dest.vtype <> Source.vtype) then
    RaiseInvalidOp;
  Dest.vtype := Source.vtype;
  if Assigned(Source.vpointer) then begin
    if not Assigned(Dest.vpointer) then
      Dest.vpointer := New(PPropInfo);
    PPropInfo(Dest.vpointer)^ := PPropInfo(Source.vpointer)^;
  end else if Assigned(Dest.vpointer) then begin
    Dispose(PPropInfo(Dest.vpointer));
    Dest.vpointer := nil;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlVariantPropInfo.FromPropInfo(const aPropInfo: PPropInfo): Variant;
begin
  with TVarData(result) do begin
    vPointer              := new(PPropInfo);
    vType                 := VarProperty;
    PPropInfo(vPointer)^  := aPropInfo^;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function TutlVariantPropInfo.ToPropInfo(const aValue: Variant): PPropInfo;
begin
  with TVarData(aValue) do begin
    result := PPropInfo(vpointer);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
initialization
  VariantProperty := TutlVariantPropInfo.Create;

finalization
  FreeAndNil(VariantProperty);

end.