|
- unit uutlVariantObject;
-
- {$mode objfpc}{$H+}
-
- interface
-
- uses
- Classes, SysUtils, variants;
-
- function VarObject: TVarType; inline;
- function VarIsObject(const aValue: Variant): Boolean; inline;
- function VarAsObject(const aValue: Variant): Variant; inline;
-
- operator :=(const aValue: TObject): Variant; inline;
- operator :=(const aValue: Variant): TObject; inline;
-
- implementation
-
- type
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- TutlVariantObject = 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 FromObject(const aObj: TObject): Variant;
- class function ToObject (const aVar: Variant): TObject;
- end;
-
- var
- VariantObject: TutlVariantObject;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function VarObject: TVarType;
- begin
- result := VariantObject.VarType;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function VarIsObject(const aValue: Variant): Boolean;
- begin
- result := (TVarData(aValue).vtype = VarObject);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function VarAsObject(const aValue: Variant): Variant;
- begin
- if not VarIsObject(aValue)
- then VarCast(result, aValue, VarObject)
- else result := aValue;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- operator := (const aValue: TObject): Variant;
- begin
- result := TutlVariantObject.FromObject(aValue);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- operator := (const aValue: Variant): TObject;
- begin
- result := TutlVariantObject.ToObject(aValue);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- //TutlVariantObject/////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- function TutlVariantObject.IsClear(const V: TVarData): Boolean;
- begin
- result := (V.vpointer = nil);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlVariantObject.Cast(var Dest: TVarData; const Source: TVarData);
- begin
- RaiseCastError;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlVariantObject.CastTo(var Dest: TVarData; const Source: TVarData; const aVarType: TVarType);
- var
- tmp: TVarData;
- begin
- if (Source.vtype <> VarType) then
- RaiseCastError;
- case aVarType of
- varolestr:
- VarDataFromOleStr(Dest, WideString(Format('$%p', [Source.vpointer])));
- varstring:
- VarDataFromStr(Dest, Format('$%p', [Source.vpointer]));
- else
- VarDataInit(tmp{%H-});
- try
- tmp.vtype := varqword;
- tmp.vqword := QWord(Source.vpointer);
- VarDataCastTo(Dest, tmp, aVarType);
- finally
- VarDataClear(tmp);
- end;
- end;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlVariantObject.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean);
- begin
- if (Dest.vtype <> varempty) and (Dest.vtype <> Source.vtype) then
- RaiseInvalidOp;
- Dest := Source;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- procedure TutlVariantObject.Clear(var V: TVarData);
- begin
- V.vpointer := nil;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlVariantObject.FromObject(const aObj: TObject): Variant;
- begin
- TVarData(result).vtype := VarObject;
- TVarData(result).vpointer := aObj;
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- class function TutlVariantObject.ToObject(const aVar: Variant): TObject;
- var
- v: Variant;
- begin
- v := VarAsObject(aVar);
- result := TObject(TVarData(v).vpointer);
- end;
-
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
- initialization
- VariantObject := TutlVariantObject.Create;
-
- finalization
- FreeAndNil(VariantObject);
-
- end.
|