utils/uutlVariantEnum.pas

unit uutlVariantEnum;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, variants,
  uutlGenerics;

function VarEnum: TVarType; inline;
function VarIsEnum(const aValue: Variant): Boolean; inline;
function VarAsEnum(const aValue: Variant): Variant; inline;
function VarMakeEnum(const aValue: Integer): Variant;
function VarMakeEnum(const aValue: Integer; const aHelper: TutlEnumHelperBaseClass): Variant;
function VarGetEnumHelper(const aValue: Variant): TutlEnumHelperBaseClass;

implementation

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  PEnumVarData = ^TEnumVarData;
  TEnumVarData = packed record
    vType: TVarType;
    case Integer of
      0: (
        vValue: Integer;
        vHelper: TutlEnumHelperBaseClass;
      );
      1: (vBytes : array[0..13] of byte);
  end;

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

var
  VariantEnum: TutlVariantEnum;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarEnum: TVarType;
begin
  result := VariantEnum.VarType;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarIsEnum(const aValue: Variant): Boolean;
begin
  result := (VarType(aValue) = VariantEnum.VarType);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarAsEnum(const aValue: Variant): Variant;
begin
  if not VarIsEnum(aValue)
    then VarCast(result, aValue, VarEnum)
    else result := aValue;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarMakeEnum(const aValue: Integer): Variant;
begin
  result := VarMakeEnum(aValue, nil);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarMakeEnum(const aValue: Integer; const aHelper: TutlEnumHelperBaseClass): Variant;
begin
  with PEnumVarData(@TVarData(result))^ do begin
    vType   := VariantEnum.VarType;
    vValue  := aValue;
    vHelper := aHelper;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarGetEnumHelper(const aValue: Variant): TutlEnumHelperBaseClass;
begin
  if not VarIsEnum(aValue) then
    VarBadTypeError;
  result := PEnumVarData(@TVarData(aValue))^.vHelper;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlVariantEnum///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantEnum.Cast(var Dest: TVarData; const Source: TVarData);

  function CheckValue(const aValue: Integer): Boolean;
  var
    i: Integer;
  begin
    with PEnumVarData(@Dest)^ do begin
      result := true;
      if not Assigned(vHelper) then
        exit;
      for i in vHelper.IntValues do
        if (i = aValue) then
          exit;
      result := false;
    end;
  end;

var
  LSource: TVarData;
begin
  if (Dest.vtype <> VariantEnum.VarType) then
    RaiseCastError;
  VarDataInit(LSource{%H-});
  try
    VarDataCopyNoInd(LSource, Source);
    case LSource.vtype of
      varsmallint,
      varinteger,
      vardecimal,
      varshortint,
      varbyte,
      varword,
      varlongword,
      varint64,
      varqword: with PEnumVarData(@Dest)^ do begin
        if not CheckValue(Variant(LSource)) then
          RaiseCastError;
        vValue := Variant(Source);
      end;
    else
      with PEnumVarData(@Dest)^ do begin
        if not Assigned(vHelper) then
          RaiseCastError;
        if not vHelper.TryToEnum(Variant(LSource), vValue, true) then
          RaiseCastError;
      end;
    end;
  finally
    VarDataClear(LSource);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantEnum.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
var
  tmp: TVarData;
begin
  if (Source.vtype <> VarType) then
    RaiseCastError;
  with PEnumVarData(@Source)^ do begin
    case aVarType of
      varolestr:
        if Assigned(vHelper) then begin
          VarDataFromOleStr(Dest, WideString(vHelper.ToString(vValue, true)));
          exit;
        end;
      varstring:
        if Assigned(vHelper) then begin
          VarDataFromStr(Dest, vHelper.ToString(vValue, true));
          exit;
        end;
    end;
    VarDataInit(tmp{%H-});
    try
      tmp.vtype    := varinteger;
      tmp.vinteger := vValue;
      VarDataCastTo(Dest, tmp, aVarType);
    finally
      VarDataClear(tmp);
    end;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantEnum.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
var
  src, dst: PEnumVarData;
begin
  if (Dest.vtype <> varempty) and (Dest.vtype <> Source.vtype) then
    RaiseInvalidOp;
  src := PEnumVarData(@Source);
  dst := PEnumVarData(@Dest);
  dst^ := src^;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantEnum.Clear(var V: TVarData);
begin
  // DUMMY
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
initialization
  VariantEnum := TutlVariantEnum.Create;

finalization
  FreeAndNil(VariantEnum);

end.