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