* Delphi compatibility: Add conversion between TValue from/to variant and TVarRec

packages/rtl-objpas/src/inc/rtti.pp

@@ -125,6 +125,8 @@ type
 {$endif}
     class function FromOrdinal(aTypeInfo: PTypeInfo; aValue: Int64): TValue; static; {inline;}
     class function FromArray(aArrayTypeInfo: PTypeInfo; const aValues: array of TValue): TValue; static;
+    class function FromVarRec(const aValue: TVarRec): TValue; static;
+    class function FromVariant(const aValue : Variant) : TValue; static;
     function IsArray: boolean; inline;
     function IsOpenArray: Boolean; inline;
     function AsString: string; inline;
@@ -139,13 +141,19 @@ type
     function AsOrdinal: Int64;
     function AsBoolean: boolean;
     function AsCurrency: Currency;
+    function AsSingle : Single;
+    function AsDateTime : TDateTime;
+    function AsDouble : Double;
     function AsInteger: Integer;
+    function AsError: HRESULT;
     function AsChar: Char; inline;
     function AsAnsiChar: AnsiChar;
     function AsWideChar: WideChar;
     function AsInt64: Int64;
     function AsUInt64: QWord;
     function AsInterface: IInterface;
+    function AsPointer : Pointer;
+    function AsVariant : Variant;
     function ToString: String;
     function GetArrayLength: SizeInt;
     function GetArrayElement(AIndex: SizeInt): TValue;
@@ -163,6 +171,11 @@ type
     class operator := (const AValue: UnicodeString): TValue; inline;
     class operator := (const AValue: WideString): TValue; inline;
     class operator := (AValue: LongInt): TValue; inline;
+    class operator := (AValue: SmallInt): TValue; inline;
+    class operator := (AValue: ShortInt): TValue; inline;
+    class operator := (AValue: Byte): TValue; inline;
+    class operator := (AValue: Word): TValue; inline;
+    class operator := (AValue: Cardinal): TValue; inline;
     class operator := (AValue: Single): TValue; inline;
     class operator := (AValue: Double): TValue; inline;
 {$ifdef FPC_HAS_TYPE_EXTENDED}
@@ -176,13 +189,14 @@ type
     class operator := (AValue: TClass): TValue; inline;
     class operator := (AValue: Boolean): TValue; inline;
     class operator := (AValue: IUnknown): TValue; inline;
+    class operator := (AValue: TVarRec): TValue; inline;
     property DataSize: SizeInt read GetDataSize;
     property Kind: TTypeKind read GetTypeKind;
     property TypeData: PTypeData read GetTypeDataProp;
     property TypeInfo: PTypeInfo read GetTypeInfo;
     property IsEmpty: boolean read GetIsEmpty;
   end;
-
+  PValue = ^TValue;
   TValueArray = specialize TArray<TValue>;
 
   { TRttiContext }
@@ -630,7 +644,9 @@ function CreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; a
 function CreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
 
 function IsManaged(TypeInfo: PTypeInfo): boolean;
+function IsBoolType(ATypeInfo: PTypeInfo): Boolean;
 
+function ArrayOfConstToTValueArray(const aValues: array of const): TValueArray;
 {$ifndef InLazIDE}
 generic function OpenArrayToDynArrayValue<T>(constref aArray: array of T): TValue;
 {$endif}
@@ -656,6 +672,7 @@ uses
 {$ifdef unix}
   BaseUnix,
 {$endif}
+  variants,
   fgl;
 
 function AlignToPtr(aPtr: Pointer): Pointer; inline;
@@ -1685,6 +1702,7 @@ begin
     tkArray    : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, Result.TypeData^.ArrayData.Size, ATypeInfo, False);
     tkObject,
     tkRecord   : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, Result.TypeData^.RecSize, ATypeInfo, False);
+    tkVariant  : result.FData.FValueData := TValueDataIntImpl.CreateCopy(ABuffer, SizeOf(Variant), ATypeInfo, False);
     tkInterface: result.FData.FValueData := TValueDataIntImpl.CreateRef(ABuffer, ATypeInfo, True);
   end;
   if not Assigned(ABuffer) then
@@ -1699,6 +1717,7 @@ begin
     tkArray,
     tkObject,
     tkRecord,
+    tkVariant,
     tkInterface:
       { ignore }
       ;
@@ -1893,6 +1912,69 @@ begin
     Result.SetArrayElement(i, aValues[i]);
 end;
 
+class function TValue.FromVarRec(const aValue: TVarRec): TValue;
+
+begin
+  Result:=Default(TValue);
+  case aValue.VType of
+    vtInteger: Result:=aValue.VInteger;
+    vtBoolean: Result:=aValue.VBoolean;
+    vtWideChar: TValue.Make(@aValue.VChar,System.TypeInfo(WideChar),Result);
+    vtInt64: Result:=aValue.VInt64^;
+    vtQWord: Result:=aValue.VQWord^;
+    vtChar: TValue.Make(@aValue.VChar,System.TypeInfo(AnsiChar),Result);
+    vtPChar: Result:=string(aValue.VPChar);
+    vtPWideChar: Result:=widestring(aValue.VPWideChar);
+    vtString: Result:=aValue.VString^;
+    vtWideString: Result:=WideString(aValue.VWideString);
+    vtAnsiString: Result:=AnsiString(aValue.VAnsiString);
+    vtUnicodeString: Result:=UnicodeString(aValue.VUnicodeString);
+    vtObject: Result:=TObject(aValue.VObject);
+    vtPointer: TValue.Make(@aValue.VPointer,System.TypeInfo(Pointer),Result);
+    vtInterface: Result:=IInterface(aValue.VInterface);
+    vtClass: Result:=aValue.VClass;
+    vtVariant: TValue.Make(@aValue.VVariant^,System.TypeInfo(Variant),result);
+    vtExtended: Result := aValue.VExtended^;
+    vtCurrency: Result := aValue.VCurrency^;
+  end;
+end;
+
+class function TValue.FromVariant(const aValue : Variant) : TValue;
+
+var
+  aType : TVarType;
+
+begin
+  Result:=Default(TValue);
+  aType:=VarType(aValue);
+  case aType of
+    varEmpty,
+    VarNull : TValue.Make(@aValue,System.TypeInfo(Variant),Result);
+    varInteger : Result:=Integer(aValue);
+    varSmallInt : Result:=SmallInt(aValue);
+    varBoolean : Result:=Boolean(aValue);
+    varOleStr: Result:=WideString(aValue);
+    varInt64: Result:=Int64(aValue);
+    varQWord: Result:=QWord(aValue);
+    varShortInt: Result:=ShortInt(aValue);
+    varByte : Result:=Byte(aValue);
+    varWord : Result:=Word(aValue);
+    varLongWord : Result:=Cardinal(aValue);
+    varSingle : Result:=Single(aValue);
+    varDouble : Result:=Double(aValue);
+    varDate : TValue.Make(@TVarData(aValue).vDate,System.TypeInfo(TDateTime),Result);
+    varDispatch : TValue.Make(@TVarData(aValue).VDispatch,System.TypeInfo(IDispatch),Result);
+    varError : TValue.Make(@TVarData(aValue).vDate,System.TypeInfo(HRESULT),Result);
+    varUnknown : TValue.Make(@TVarData(aValue).vunknown,System.TypeInfo(IUnknown),Result);
+    varCurrency : Result:=Currency(aValue);
+    varString : Result:=AnsiString(aValue);
+    varUString : Result:=UnicodeString(TVarData(aValue).vustring);
+  else
+    raise EVariantTypeCastError.CreateFmt('Invalid variant cast from type %d',[aType]);
+  end;
+end;
+
+
 function TValue.GetIsEmpty: boolean;
 begin
   result := (FData.FTypeInfo=nil) or
@@ -2001,7 +2083,7 @@ begin
 end;
 
 {$ifndef NoGenericMethods}
-generic function TValue.IsType<T>: Boolean;
+generic function TValue.IsType<T>:Boolean;
 begin
   Result := IsType(PTypeInfo(System.TypeInfo(T)));
 end;
@@ -2060,6 +2142,7 @@ begin
     raise EInvalidCast.Create(SErrInvalidTypecast);
 end;
 
+
 function TValue.AsCurrency: Currency;
 begin
   if (Kind = tkFloat) and (TypeData^.FloatType=ftCurr) then
@@ -2068,6 +2151,66 @@ begin
     raise EInvalidCast.Create(SErrInvalidTypecast);
 end;
 
+function TValue.AsSingle: Single;
+
+begin
+  if Kind = tkFloat then
+    begin
+    case TypeData^.FloatType of
+      ftSingle   : result := FData.FAsSingle;
+      ftDouble   : result := FData.FAsDouble;
+      ftExtended : result := FData.FAsExtended;
+      ftCurr     : result := FData.FAsCurr;
+      ftComp     : result := FData.FAsComp;
+    else
+      raise EInvalidCast.Create(SErrInvalidTypecast);
+    end;
+    end
+  else if Kind in [tkInteger, tkInt64, tkQWord] then
+    Result := AsInt64
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
+end;
+
+function TValue.AsDateTime: TDateTime;
+
+begin
+  if (Kind = tkFloat) and (TypeData^.FloatType=ftDouble) and (TypeInfo=System.TypeInfo(TDateTime)) then
+    result := FData.FAsDouble
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
+end;
+
+function TValue.AsDouble: Double;
+begin
+  if Kind = tkFloat then
+    begin
+    case TypeData^.FloatType of
+      ftSingle   : result := FData.FAsSingle;
+      ftDouble   : result := FData.FAsDouble;
+      ftExtended : result := FData.FAsExtended;
+      ftCurr     : result := FData.FAsCurr;
+      ftComp     : result := FData.FAsComp;
+    else
+      raise EInvalidCast.Create(SErrInvalidTypecast);
+    end;
+    end
+  else if Kind in [tkInteger, tkInt64, tkQWord] then
+    Result := AsInt64
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
+end;
+
+
+function TValue.AsError: HRESULT;
+
+begin
+  if (Kind = tkInteger) and (TypeInfo=System.TypeInfo(HRESULT)) then
+    result := HResult(AsInteger)
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
+end;
+
 function TValue.AsInteger: Integer;
 begin
   if Kind in [tkInteger, tkInt64, tkQWord] then
@@ -2110,6 +2253,24 @@ begin
 {$endif}
 end;
 
+function TValue.AsPointer : Pointer;
+
+begin
+  if Kind in [tkPointer, tkInterface, tkInterfaceRaw, tkClass,tkClassRef,tkAString,tkWideString,tkUnicodeString] then
+    Result:=FData.FAsPointer
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
+end;
+
+function TValue.AsVariant : Variant;
+
+begin
+  if (Kind=tkVariant) then
+    Result:= PVariant(FData.FValueData.GetReferenceToRawData)^
+  else
+    raise EInvalidCast.Create(SErrInvalidTypecast);
+end;
+
 function TValue.AsInt64: Int64;
 begin
   if Kind in [tkInteger, tkInt64, tkQWord] then
@@ -2409,11 +2570,41 @@ begin
   Make(@AValue, System.TypeInfo(AValue), Result);
 end;
 
+
 class operator TValue.:=(const AValue: WideString): TValue;
 begin
   Make(@AValue, System.TypeInfo(AValue), Result);
 end;
 
+class operator TValue.:= (AValue: SmallInt): TValue;
+begin
+  Make(@AValue, System.TypeInfo(AValue), Result);
+end;
+
+class operator TValue.:= (AValue: ShortInt): TValue;
+begin
+  Make(@AValue, System.TypeInfo(AValue), Result);
+end;
+
+class operator TValue.:= (AValue: Byte): TValue; inline;
+
+begin
+  Make(@AValue, System.TypeInfo(AValue), Result);
+end;
+
+class operator TValue.:= (AValue: Word): TValue; inline;
+
+begin
+  Make(@AValue, System.TypeInfo(AValue), Result);
+end;
+
+class operator TValue.:= (AValue: Cardinal): TValue; inline;
+
+begin
+  Make(@AValue, System.TypeInfo(AValue), Result);
+end;
+
+
 class operator TValue.:=(AValue: LongInt): TValue;
 begin
   Make(@AValue, System.TypeInfo(AValue), Result);
@@ -2458,7 +2649,7 @@ end;
 
 class operator TValue.:=(AValue: TObject): TValue;
 begin
-  Make(@AValue, System.TypeInfo(AValue), Result);
+  Make(@AValue, PTypeInfo(AValue.ClassInfo), Result);
 end;
 
 class operator TValue.:=(AValue: TClass): TValue;
@@ -2476,6 +2667,12 @@ begin
   Make(@AValue, System.TypeInfo(AValue), Result);
 end;
 
+class operator TValue.:= (AValue: TVarRec): TValue;
+
+begin
+  Result:=TValue.FromVarRec(aValue);
+end;
+
 function Invoke(aCodeAddress: CodePointer; const aArgs: TValueArray;
   aCallConv: TCallConv; aResultType: PTypeInfo; aIsStatic: Boolean;
   aIsConstructor: Boolean): TValue;
@@ -2665,6 +2862,16 @@ begin
     Result := false;
 end;
 
+function IsBoolType(ATypeInfo: PTypeInfo): Boolean;
+
+begin
+  Result:=(ATypeInfo=TypeInfo(Boolean)) or
+          (ATypeInfo=TypeInfo(ByteBool)) or
+          (ATypeInfo=TypeInfo(WordBool)) or
+          (ATypeInfo=TypeInfo(LongBool));
+end;
+
+
 {$ifndef InLazIDE}
 generic function OpenArrayToDynArrayValue<T>(constref aArray: array of T): TValue;
 var
@@ -2678,6 +2885,18 @@ begin
 end;
 {$endif}
 
+function ArrayOfConstToTValueArray(const aValues: array of const): TValueArray;
+
+var
+  I,Len: Integer;
+
+begin
+  Len:=Length(aValues);
+  SetLength(Result,Len);
+  for I:=0 to Len-1 do
+    Result[I]:=aValues[I];
+end;
+
 { TRttiPointerType }
 
 function TRttiPointerType.GetReferredType: TRttiType;

packages/rtl-objpas/tests/testrunner.rtlobjpas.pp

@@ -30,12 +30,14 @@ uses
 {$ifdef testimpl}
   tests.rtti.impl,
 {$endif}
-  tests.rtti;
+  tests.rtti, tests.value;
 
 var
   Application: TTestRunner;
 
 begin
+  DefaultFormat:=fPlain;
+  DefaultRunAllTests:=True;
   Application := TTestRunner.Create(nil);
   Application.Initialize;
   Application.Title := 'RTL-ObjPas unit tests';

packages/rtl-objpas/tests/tests.value.pas

@@ -0,0 +1,689 @@
+unit tests.value;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  fpcunit,testregistry, testutils,
+  Classes, SysUtils, Rtti;
+
+Type
+
+  { TTestTValue }
+
+  TTestTValue = class(TTestCase)
+  private
+    FSrc: Variant;
+    FValue: TValue;
+    FVarRec: TVarRec;
+  Public
+    Procedure Setup; override;
+    Procedure TearDown; override;
+    Procedure DoFromVariant;
+    Procedure DoFromVarRec;
+    Property Value : TValue Read FValue;
+    Property Src : Variant Read FSrc;
+    Property VarRec : TVarRec Read FVarRec;
+  Published
+    Procedure TestFromVariantInteger;
+    Procedure TestFromVariantBoolean;
+    Procedure TestFromVariantSmallInt;
+    Procedure TestFromVariantOleStr;
+    Procedure TestFromVariantInt64;
+    Procedure TestFromVariantQWord;
+    Procedure TestFromVariantShortInt;
+    Procedure TestFromVariantByte;
+    Procedure TestFromVariantWord;
+    Procedure TestFromVariantLongWord;
+    Procedure TestFromVariantSingle;
+    Procedure TestFromVariantDouble;
+    Procedure TestFromVariantDate;
+    Procedure TestFromVariantDispatch;
+    Procedure TestFromVariantError;
+    Procedure TestFromVariantUnknown;
+    Procedure TestFromVariantCurrency;
+    Procedure TestFromVariantString;
+    Procedure TestFromVariantUnicodeString;
+    Procedure TestFromVarrecInteger;
+    Procedure TestFromVarrecBoolean;
+    Procedure TestFromVarRecChar;
+    Procedure TestFromVarRecExtended;
+    Procedure TestFromVarRecString;
+    Procedure TestFromVarRecPointer;
+    Procedure TestFromVarRecPChar;
+    Procedure TestFromVarRecObject;
+    Procedure TestFromVarRecClass;
+    Procedure TestFromVarRecWideChar;
+    Procedure TestFromVarRecPWideChar;
+    Procedure TestFromVarRecAnsiString;
+    Procedure TestFromVarRecCurrency;
+    Procedure TestFromVarRecVariant;
+    Procedure TestFromVarRecInterface;
+    Procedure TestFromVarRecWideString;
+    Procedure TestFromVarRecInt64;
+    Procedure TestFromVarRecQWord;
+    Procedure TestFromVarRecUnicodeString;
+    Procedure TestArrayOfConstToTValue;
+  end;
+
+  { TMyUNknown }
+
+  TMyUNknown = Class(TInterfacedObject,IDispatch)
+    function GetTypeInfoCount(out count : longint) : HResult;stdcall;
+    function GetTypeInfo(Index,LocaleID : longint; out TypeInfo): HResult;stdcall;
+    function GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount, LocaleID: LongInt; DispIDs: Pointer) : HResult;stdcall;
+    function Invoke(DispID: LongInt;const iid : TGUID; LocaleID : longint; Flags: Word;var params; VarResult,ExcepInfo,ArgErr : pointer) : HResult;stdcall;
+  end;
+
+
+implementation
+
+uses variants;
+
+{ TTestTValue }
+
+procedure TTestTValue.Setup;
+begin
+  inherited Setup;
+  FValue:=Default(TValue);
+  FSrc:=unassigned;
+end;
+
+procedure TTestTValue.TearDown;
+begin
+  FValue:=Default(TValue);
+  FSrc:=unassigned;
+  inherited TearDown;
+end;
+
+procedure TTestTValue.DoFromVariant;
+begin
+  FValue:=TValue.FromVariant(Src);
+end;
+
+procedure TTestTValue.DoFromVarRec;
+begin
+  FValue:=TValue.FromVarRec(FVarRec);
+end;
+
+procedure TTestTValue.TestFromVarrecInteger;
+begin
+  FVarrec.VType:=vtInteger;
+  FVarrec.VInteger:=1;
+  DoFromVarRec;
+  CheckEquals(1,Value.AsInteger,'Value');
+  CheckTrue(TypeInfo(Integer)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarrecBoolean;
+begin
+  FVarrec.VType:=vtBoolean;
+  FVarrec.VBoolean:=True;
+  DoFromVarRec;
+  CheckEquals(True,Value.AsBoolean,'Value');
+  CheckTrue(TypeInfo(Boolean)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecChar;
+begin
+  FVarrec.VType:=vtChar;
+  FVarrec.VChar:='c';
+  DoFromVarRec;
+  CheckEquals('c',Value.AsAnsiChar,'Value');
+  CheckTrue(TypeInfo(AnsiChar)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecExtended;
+
+var
+  E : Extended;
+
+begin
+  E:=1.23;
+  FVarRec.VExtended:=@E;
+  FVarRec.vType:=vtExtended;
+  DoFromVarRec;
+  CheckEquals(1.23,Value.AsExtended,0.01,'Value');
+  CheckTrue(TypeInfo(Extended)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecString;
+
+Var
+  s : ShortString;
+
+begin
+  S:='123';
+  FVarrec.VType:=vtString;
+  FVarrec.VString:=@S;
+  DoFromVarRec;
+  CheckEquals('123',Value.AsString,'Value');
+  CheckTrue(TypeInfo(ShortString)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecPointer;
+Var
+  s : ShortString;
+
+begin
+  S:='123';
+  FVarrec.VType:=vtPointer;
+  FVarrec.VString:=@S;
+  DoFromVarRec;
+  CheckTrue(@S=Value.AsPointer,'Value');
+  CheckTrue(TypeInfo(Pointer)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecPChar;
+Var
+  s : AnsiString;
+
+begin
+  S:='123';
+  FVarrec.VType:=vtPChar;
+  FVarrec.VPChar:=PAnsiChar(S);
+  DoFromVarRec;
+  CheckTrue(S=Value.AsAnsiString,'Value');
+  // In delphi it is String, but not widestring !
+  CheckTrue(TypeInfo(AnsiString)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecObject;
+Var
+  C : TObject;
+
+begin
+  C:=TComponent.Create(Nil);
+  FVarrec.VType:=vtObject;
+  FVarrec.VObject:=C;
+  DoFromVarRec;
+  CheckSame(C,Value.AsObject,'Value');
+  // In delphi it is String, but not widestring !
+  CheckTrue(TypeInfo(TComponent)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, True,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecClass;
+Var
+  C : TClass;
+
+begin
+  C:=TComponent;
+  FVarrec.VType:=vtClass;
+  FVarrec.VClass:=C;
+  DoFromVarRec;
+  CheckEquals(C,Value.AsClass,'Value');
+  // In delphi it is String, but not widestring !
+  CheckTrue(TypeInfo(TClass)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, True,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+
+end;
+
+procedure TTestTValue.TestFromVarRecWideChar;
+begin
+  FVarrec.VType:=vtWideChar;
+  FVarrec.VWideChar:='c';
+  DoFromVarRec;
+  CheckEquals('c',Value.AsWideChar,'Value');
+  CheckTrue(TypeInfo(WideChar)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecPWideChar;
+Var
+  s : WideString;
+
+begin
+  S:='123';
+  FVarrec.VType:=vtPWideChar;
+  FVarrec.VPWideChar:=PWideChar(S);
+  DoFromVarRec;
+  CheckEquals('123',Value.AsUnicodeString,'Value');
+  CheckTrue(TypeInfo(WideString)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecAnsiString;
+Var
+  s : AnsiString;
+
+begin
+  S:='123';
+  FVarrec.VType:=vtAnsiString;
+  FVarrec.VAnsiString:=Pointer(S);
+  DoFromVarRec;
+  CheckEquals('123',Value.AsAnsiString,'Value');
+  CheckTrue(TypeInfo(AnsiString)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecCurrency;
+
+var
+  C : Currency;
+
+begin
+  C:=1.23;
+  FVarRec.VCurrency:=@C;
+  FVarRec.vType:=vtCurrency;
+  DoFromVarRec;
+  CheckEquals(1.23,Value.AsCurrency,0.01,'Value');
+  CheckTrue(TypeInfo(Currency)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecVariant;
+
+var
+  V : Variant;
+
+begin
+  V:='1.23';
+  FVarRec.VVariant:=@V;
+  FVarRec.vType:=vtVariant;
+  DoFromVarRec;
+  CheckEquals(V,String(Value.AsVariant),'Value');
+  CheckTrue(TypeInfo(Variant)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecInterface;
+Var
+  U : IInterface;
+
+begin
+  U:=TMyUNknown.Create;
+  FVarRec.VInterface:=U;
+  FVarRec.VType:=vtInterface;
+  DoFromVarRec;
+  CheckTrue(U=Value.AsInterface,'Value');
+  CheckTrue(TypeInfo(IInterface)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecWideString;
+Var
+  s : WideString;
+
+begin
+  S:='123';
+  FVarrec.VType:=vtWideString;
+  FVarrec.VWideString:=Pointer(S);
+  DoFromVarRec;
+  CheckEquals('123',Value.AsUnicodeString,'Value');
+  CheckTrue(TypeInfo(WideString)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecInt64;
+
+Var
+  I : Int64;
+
+begin
+  I:=Int64(1);
+  FVarRec.VInt64:=@I;
+  FVarRec.vType:=vtInt64;
+  DoFromVarRec;
+  CheckEquals(1,Value.AsInt64,'Value');
+  CheckTrue(TypeInfo(Int64)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecQWord;
+
+Var
+  Q : QWord;
+
+
+begin
+  Q:=1;
+  FVarRec.VQWord:=@Q;
+  FVarRec.vType:=vtQWord;
+  DoFromVarRec;
+  CheckEquals(1,Value.AsUInt64,'Value');
+  CheckTrue(TypeInfo(QWord)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVarRecUnicodeString;
+
+Var
+  s : UnicodeString;
+
+begin
+  S:='123';
+  FVarrec.VType:=vtUnicodeString;
+  FVarrec.VUnicodeString:=Pointer(S);
+  DoFromVarRec;
+  CheckEquals('123',Value.AsUnicodeString,'Value');
+  CheckTrue(TypeInfo(UnicodeString)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+
+procedure TTestTValue.TestFromVariantInteger;
+
+
+begin
+  FSrc:=Integer(1);
+  DoFromVariant;
+  CheckEquals(1,Value.AsInteger,'Value');
+  CheckTrue(TypeInfo(Longint)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+
+procedure TTestTValue.TestFromVariantBoolean;
+begin
+  FSrc:=True;
+  DoFromVariant;
+  CheckEquals(True,Value.AsBoolean,'Value');
+  CheckTrue(TypeInfo(Boolean)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantSmallInt;
+begin
+  FSrc:=SmallInt(1);
+  DoFromVariant;
+  CheckEquals(1,Value.AsInteger,'Value');
+  CheckTrue(TypeInfo(SmallInt)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantOleStr;
+
+begin
+  FSrc:=WideString('1.23');
+  DoFromVariant;
+  CheckEquals('1.23',Value.AsUnicodeString,'Value');
+  CheckTrue(TypeInfo(WideString)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantInt64;
+begin
+  FSrc:=Int64(1);
+  DoFromVariant;
+  CheckEquals(1,Value.AsInt64,'Value');
+  CheckTrue(TypeInfo(Int64)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantQWord;
+begin
+  FSrc:=QWord(1);
+  DoFromVariant;
+  CheckEquals(1,Value.AsInt64,'Value');
+  CheckTrue(TypeInfo(QWord)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantShortInt;
+begin
+  FSrc:=ShortInt(1);
+  DoFromVariant;
+  CheckEquals(1,Value.AsInteger,'Value');
+  CheckTrue(TypeInfo(Shortint)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantByte;
+begin
+  FSrc:=Byte(1);
+  DoFromVariant;
+  CheckEquals(1,Value.AsInteger,'Value');
+  CheckTrue(TypeInfo(Byte)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantWord;
+begin
+  FSrc:=Word(1);
+  DoFromVariant;
+  CheckEquals(1,Value.AsInteger,'Value');
+  CheckTrue(TypeInfo(Word)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantLongWord;
+begin
+  FSrc:=Cardinal(1);
+  DoFromVariant;
+  CheckEquals(1,Value.AsInteger,'Value');
+  CheckTrue(TypeInfo(Cardinal)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantSingle;
+begin
+  FSrc:=Single(1.23); // Results in double...
+  VarCast(FSrc,FSrc,varSingle);
+  DoFromVariant;
+  CheckEquals(1.23,Value.AsSingle,0.01,'Value');
+  CheckTrue(TypeInfo(Single)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantDouble;
+begin
+  FSrc:=Double(1.23);
+  DoFromVariant;
+  CheckEquals(1.23,Value.AsDouble,0.01,'Value');
+  CheckTrue(TypeInfo(Double)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantDate;
+
+Var
+  D : TDateTime;
+
+begin
+  D:=Time;
+  FSrc:=D;
+  DoFromVariant;
+  CheckEquals(D,Value.AsDateTime,0.01,'Value');
+  CheckTrue(TypeInfo(TDateTime)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantDispatch;
+Var
+  U : IDispatch;
+
+begin
+  U:=TMyUNknown.Create;
+  FSrc:=U;
+  DoFromVariant;
+  CheckTrue(U=Value.AsInterface,'Value');
+  CheckTrue(TypeInfo(IDispatch)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantError;
+
+begin
+  TVarData(FSrc).verror:=S_FALSE;
+  TVarData(FSrc).vtype:=varError;
+  DoFromVariant;
+  CheckTrue(S_FALSE=Value.AsError,'Value');
+  CheckTrue(TypeInfo(HRESULT)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, True,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantUnknown;
+
+Var
+  U : IInterface;
+
+begin
+  U:=TMyUNknown.Create;
+  FSrc:=U;
+  DoFromVariant;
+  CheckTrue(U=Value.AsInterface,'Value');
+  CheckTrue(TypeInfo(IInterface)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantCurrency;
+begin
+  FSrc:=Currency(1.23);
+  DoFromVariant;
+  CheckEquals(1.23,Value.AsCurrency,0.01,'Value');
+  CheckTrue(TypeInfo(Currency)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantString;
+begin
+  FSrc:='1.23';
+  DoFromVariant;
+  CheckEquals('1.23',Value.AsString,'Value');
+  CheckTrue(TypeInfo(AnsiString)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+procedure TTestTValue.TestFromVariantUnicodeString;
+begin
+  TVarData(FSrc).vustring:=Pointer(UnicodeString('1.23'));
+  TVarData(FSrc).vtype:=varUString;
+  DoFromVariant;
+  CheckEquals('1.23',Value.AsString,'Value');
+  CheckTrue(TypeInfo(UnicodeString)=Value.TypeInfo,'Correct typeinfo');
+  CheckEquals(Value.IsClass, False,'Class');
+  CheckEquals(Value.IsObject, False,'Object');
+  CheckEquals(Value.IsOrdinal, False,'Ordinal');
+end;
+
+
+
+procedure TTestTValue.TestArrayOfConstToTValue;
+
+Var
+  S:TValueArray;
+
+begin
+  S:=ArrayOfConstToTValueArray([1,'something',1.23]);
+  CheckEquals(3,Length(S),'Length');
+  CheckEquals(1,S[0].AsInteger,'Value 1');
+  CheckEquals('something',S[1].AsString,'Value 3');
+  CheckEquals(1.23,S[2].AsDouble,0.01,'Value 3');
+end;
+
+{ TMyUNknown }
+
+function TMyUNknown.GetTypeInfoCount(out count: longint): HResult; stdcall;
+begin
+  count:=0;
+  Result:=S_OK;
+end;
+
+function TMyUNknown.GetTypeInfo(Index, LocaleID: longint; out TypeInfo
+  ): HResult; stdcall;
+begin
+
+  Result:=S_OK;
+end;
+
+function TMyUNknown.GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount,
+  LocaleID: LongInt; DispIDs: Pointer): HResult; stdcall;
+begin
+  Result:=S_OK;
+end;
+
+function TMyUNknown.Invoke(DispID: LongInt; const iid: TGUID;
+  LocaleID: longint; Flags: Word; var params; VarResult, ExcepInfo,
+  ArgErr: pointer): HResult; stdcall;
+begin
+  Result:=S_OK;
+end;
+
+
+initialization
+  RegisterTest(TTestTValue);
+end.
+