utils/uutlVariantSet.pas

unit uutlVariantSet;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, variants,
  uutlGenerics;

function VarSet: TVarType; inline;
function VarIsSet(const aValue: Variant): Boolean; inline;
function VarAsSet(const aValue: Variant): Variant; inline;
function VarMakeSet(const aValue; const aSize: Integer): Variant;
function VarMakeSet(const aValue; const aSize: Integer; const aHelper: TutlSetHelperBaseClass): Variant;
function VarGetSetHelper(const aValue: Variant): TutlSetHelperBaseClass;

implementation

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  PSetData = ^TSetData;
  TSetData = packed record
    Data: array[0..31] of Byte;
    Size: Integer;
    Helper: TutlSetHelperBaseClass;
  end;

  PSetVarData = ^TSetVarData;
  TSetVarData = packed record
    vType: TVarType;
    case Integer of
      0: (vData: PSetData);
      1: (vBytes: array[0..13] of Byte);
  end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  TutlVariantSet = 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
  VariantSet: TutlVariantSet;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarSet: TVarType;
begin
  result := VariantSet.VarType;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarIsSet(const aValue: Variant): Boolean;
begin
  result := (VarType(aValue) = VarSet);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarAsSet(const aValue: Variant): Variant;
begin
  if not VarIsSet(aValue)
    then VarCast(result, aValue, VarSet)
    else result := aValue;
end;

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

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarMakeSet(const aValue; const aSize: Integer; const aHelper: TutlSetHelperBaseClass): Variant;
begin
  with PSetVarData(@TVarData(result))^ do begin
    New     (vData);
    FillByte(vData^.Data, SizeOf(vData^.Data), 0);
    Move    (aValue, vData^.Data, aSize);
    vType         := VarSet;
    vData^.Size   := aSize;
    vData^.Helper := aHelper;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function VarGetSetHelper(const aValue: Variant): TutlSetHelperBaseClass;
begin
  if not VarIsSet(aValue) then
    VarBadTypeError;
  with PSetVarData(@TVarData(aValue))^ do begin
    if not Assigned(vData) then
      VarInvalidOp;
    result := vData^.Helper;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//TutlVariantSet////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantSet.Cast(var Dest: TVarData; const Source: TVarData);
begin
  if (Dest.vType <> VariantSet.VarType) then
    RaiseCastError;
  with PSetVarData(@Dest)^ do begin
    if not Assigned(vData^.Helper) then
      RaiseCastError;
    if not vData^.Helper.TryToSet(Variant(Source), vData^.Data, vData^.Size) then
      RaiseCastError;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantSet.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
begin
  if (Source.vtype <> VarType) then
    RaiseCastError;
  with PSetVarData(@Source)^ do begin
    if not Assigned(vData^.Helper) then
      RaiseCastError;
    case aVarType of
      varolestr:
        VarDataFromOleStr(Dest, WideString(vData^.Helper.ToString(vData^.Data, vData^.Size)));
      varstring:
        VarDataFromStr(Dest, vData^.Helper.ToString(vData^.Data, vData^.Size));
    else
      RaiseCastError;
    end;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantSet.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
var
  src, dst: PSetVarData;
begin
  if (Dest.vtype <> varempty) and (Dest.vtype <> Source.vtype) then
    RaiseInvalidOp;
  src := PSetVarData(@Source);
  dst := PSetVarData(@Dest);
  dst^.vType   := src^.vType;
  if not Assigned(dst^.vData) then
    new(dst^.vData);
  dst^.vData^ := src^.vData^;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure TutlVariantSet.Clear(var V: TVarData);
begin
  with PSetVarData(@V)^ do begin
    if Assigned(vData) then begin
      Dispose(vData);
      vData := nil;
    end;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
initialization
  VariantSet := TutlVariantSet.Create;

finalization
  FreeAndNil(VariantSet);

end.