|
- 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.
|