unit tests.rtti.value; {$mode ObjFPC}{$H+} interface uses fpcunit,testregistry, testutils, typinfo, Classes, SysUtils, Rtti; Type TTestValueGeneral = Class(TTestCase) Published procedure TestDataSize; procedure TestDataSizeEmpty; procedure TestReferenceRawData; procedure TestReferenceRawDataEmpty; procedure TestIsManaged; procedure TestCasts; end; TTestValueSimple = Class(TTestCase) private procedure MakeFromOrdinalTObject; procedure MakeFromOrdinalSet; procedure MakeFromOrdinalString; procedure MakeFromOrdinalNil; Published // Moved here from Tests.rtti procedure TestIsType; procedure TestMakeNil; procedure TestMakeObject; procedure TestMakeSingle; procedure TestMakeDouble; procedure TestMakeExtended; procedure TestMakeCurrency; procedure TestMakeComp; procedure TestMakeEnum; procedure TestMakeAnsiChar; procedure TestMakeWideChar; procedure TestMakeNativeInt; procedure TestMakeVariant; procedure TestMakeGenericNil; procedure TestMakeGenericLongInt; procedure TestMakeGenericString; procedure TestMakeGenericObject; procedure TestMakeGenericDouble; procedure TestMakeGenericAnsiChar; procedure TestMakeGenericWideChar; procedure TestFromOrdinal; Procedure TestTryCastUnicodeString; end; { TTestValueArray } TTestValueArray = class(TTestCase) Published procedure TestMakeArrayDynamic; procedure TestMakeArrayStatic; procedure TestMakeFromArray; {$ifdef fpc} procedure TestMakeArrayOpen; Procedure TestOpenArrayToDyn; {$ENDIF} end; { TTestValueVariant } TTestValueVariant = 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 tests.rtti.types, variants; { TTestValueVariant } procedure TTestValueVariant.Setup; begin inherited Setup; FValue:=Default(TValue); FSrc:=unassigned; end; procedure TTestValueVariant.TearDown; begin FValue:=Default(TValue); FSrc:=unassigned; inherited TearDown; end; procedure TTestValueVariant.DoFromVariant; begin FValue:=TValue.FromVariant(Src); end; procedure TTestValueVariant.DoFromVarRec; begin FValue:=TValue.FromVarRec(FVarRec); end; procedure TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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 TTestValueVariant.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; type TMyLongInt = type LongInt; procedure TTestValueSimple.TestIsType; { Delphi does not provide type information for local types :/ } {type TMyLongInt = type LongInt;} var v: TValue; l: LongInt; ml: TMyLongInt; begin l := 42; ml := 42; TValue.Make(@l, TypeInfo(LongInt), v); Check(v.IsType(TypeInfo(LongInt))); Check(not v.IsType(TypeInfo(TMyLongInt))); Check(not v.IsType(TypeInfo(String))); Check(v.{$ifdef fpc}specialize{$endif} IsType); Check(not v.{$ifdef fpc}specialize{$endif} IsType); Check(not v.{$ifdef fpc}specialize{$endif} IsType); TValue.Make(@ml, TypeInfo(TMyLongInt), v); Check(v.IsType(TypeInfo(TMyLongInt))); Check(not v.IsType(TypeInfo(LongInt))); Check(not v.IsType(TypeInfo(String))); Check(v.{$ifdef fpc}specialize{$endif} IsType); Check(not v.{$ifdef fpc}specialize{$endif} IsType); Check(not v.{$ifdef fpc}specialize{$endif} IsType); end; procedure TTestValueSimple.TestMakeNil; var value: TValue; begin TValue.Make(Nil, Nil, value); CheckTrue(value.Kind = tkUnknown); CheckTrue(value.IsEmpty); CheckTrue(value.IsObject); CheckTrue(value.IsClass); CheckTrue(value.IsOrdinal); CheckFalse(value.IsArray); CheckTrue(value.AsObject = Nil); CheckTrue(value.AsClass = Nil); CheckTrue(value.AsInterface = Nil); CheckEquals(0, value.AsOrdinal); TValue.Make(Nil, TypeInfo(TObject), value); CheckTrue(value.IsEmpty); CheckTrue(value.IsObject); CheckTrue(value.IsClass); CheckTrue(value.IsOrdinal); CheckFalse(value.IsArray); CheckTrue(value.AsObject=Nil); CheckTrue(value.AsClass=Nil); CheckTrue(value.AsInterface=Nil); CheckEquals(0, value.AsOrdinal); TValue.Make(Nil, TypeInfo(TClass), value); CheckTrue(value.IsEmpty); CheckTrue(value.IsClass); CheckTrue(value.IsOrdinal); CheckFalse(value.IsArray); CheckTrue(value.AsObject=Nil); CheckTrue(value.AsClass=Nil); CheckTrue(value.AsInterface=Nil); CheckEquals(0, value.AsOrdinal); TValue.Make(Nil, TypeInfo(LongInt), value); CheckTrue(value.IsOrdinal); CheckFalse(value.IsEmpty); CheckFalse(value.IsClass); CheckFalse(value.IsObject); CheckFalse(value.IsArray); CheckEquals(0, value.AsOrdinal); CheckEquals(0, value.AsInteger); CheckEquals(0, value.AsInt64); CheckEquals(0, value.AsUInt64); TValue.Make(Nil, TypeInfo(String), value); CheckFalse(value.IsEmpty); CheckFalse(value.IsObject); CheckFalse(value.IsClass); CheckFalse(value.IsArray); CheckEquals('', value.AsString); end; procedure TTestValueSimple.TestMakeObject; var AValue: TValue; ATestClass: TTestValueClass; begin ATestClass := TTestValueClass.Create; ATestClass.AInteger := 54329; TValue.Make(@ATestClass, TypeInfo(TTestValueClass),AValue); CheckEquals(AValue.IsClass, False); CheckEquals(AValue.IsObject, True); Check(AValue.AsObject=ATestClass); Check(PPointer(AValue.GetReferenceToRawData)^ = Pointer(ATestClass)); CheckEquals(TTestValueClass(AValue.AsObject).AInteger, 54329); ATestClass.Free; end; procedure TTestValueArray.TestMakeArrayDynamic; var arr: TArrayOfLongintDyn; value: TValue; begin SetLength(arr, 2); arr[0] := 42; arr[1] := 21; TValue.Make(@arr, TypeInfo(TArrayOfLongintDyn), value); CheckEquals(value.IsArray, True); CheckEquals(value.IsObject, False); CheckEquals(value.IsOrdinal, False); CheckEquals(value.IsClass, False); CheckEquals(value.GetArrayLength, 2); CheckEquals(value.GetArrayElement(0).AsInteger, 42); CheckEquals(value.GetArrayElement(1).AsInteger, 21); Check(PPointer(value.GetReferenceToRawData)^ = Pointer(arr)); value.SetArrayElement(0, Integer(84)); CheckEquals(arr[0], 84); end; procedure TTestValueArray.TestMakeArrayStatic; type TArrStat = array[0..1] of LongInt; TArrStat2D = array[0..1, 0..1] of LongInt; var arr: TArrStat; arr2D: TArrStat2D; value: TValue; begin arr[0] := 42; arr[1] := 21; TValue.Make(@arr, TypeInfo(TArrStat), value); CheckEquals(value.IsArray, True); CheckEquals(value.IsObject, False); CheckEquals(value.IsOrdinal, False); CheckEquals(value.IsClass, False); CheckEquals(value.GetArrayLength, 2); CheckEquals(value.GetArrayElement(0).AsInteger, 42); CheckEquals(value.GetArrayElement(1).AsInteger, 21); value.SetArrayElement(0, integer(84)); { since this is a static array the original array isn't touched! } CheckEquals(arr[0], 42); arr2D[0, 0] := 42; arr2D[0, 1] := 21; arr2D[1, 0] := 84; arr2D[1, 1] := 63; TValue.Make(@arr2D, TypeInfo(TArrStat2D), value); CheckEquals(value.IsArray, True); CheckEquals(value.GetArrayLength, 4); CheckEquals(value.GetArrayElement(0).AsInteger, 42); CheckEquals(value.GetArrayElement(1).AsInteger, 21); CheckEquals(value.GetArrayElement(2).AsInteger, 84); CheckEquals(value.GetArrayElement(3).AsInteger, 63); end; {$ifdef fpc} procedure TTestValueArray.TestMakeArrayOpen; procedure TestOpenArrayValueCopy(aArr: array of LongInt); var value: TValue; begin TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value); CheckEquals(value.IsArray, True); CheckEquals(value.IsOpenArray, True); CheckEquals(value.IsObject, False); CheckEquals(value.IsOrdinal, False); CheckEquals(value.IsClass, False); CheckEquals(value.GetArrayLength, 2); CheckEquals(value.GetArrayElement(0).AsInteger, 42); CheckEquals(value.GetArrayElement(1).AsInteger, 21); value.SetArrayElement(0, Integer(84)); { since this is an open array the original array is modified! } CheckEquals(aArr[0], 84); end; procedure TestOpenArrayValueVar(var aArr: array of LongInt); var value: TValue; begin TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value); CheckEquals(value.IsArray, True); CheckEquals(value.IsOpenArray, True); CheckEquals(value.IsObject, False); CheckEquals(value.IsOrdinal, False); CheckEquals(value.IsClass, False); CheckEquals(value.GetArrayLength, 2); CheckEquals(value.GetArrayElement(0).AsInteger, 42); CheckEquals(value.GetArrayElement(1).AsInteger, 21); value.SetArrayElement(0, 84); { since this is an open array the original array is modified! } CheckEquals(aArr[0], 84); end; procedure TestOpenArrayValueOut(var aArr: array of LongInt); var value: TValue; begin TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value); CheckEquals(value.IsArray, True); CheckEquals(value.IsOpenArray, True); CheckEquals(value.IsObject, False); CheckEquals(value.IsOrdinal, False); CheckEquals(value.IsClass, False); CheckEquals(value.GetArrayLength, 2); CheckEquals(value.GetArrayElement(0).AsInteger, 42); CheckEquals(value.GetArrayElement(1).AsInteger, 21); value.SetArrayElement(0, 84); value.SetArrayElement(1, 128); { since this is an open array the original array is modified! } CheckEquals(aArr[0], 84); CheckEquals(aArr[1], 128); CheckEquals(value.GetArrayElement(0).AsInteger, 84); CheckEquals(value.GetArrayElement(1).AsInteger, 128); end; var arr: array of LongInt; begin TestOpenArrayValueCopy([42, 21]); arr := [42, 21]; TestOpenArrayValueVar(arr); CheckEquals(arr[0], 84); CheckEquals(arr[1], 21); arr := [42, 21]; TestOpenArrayValueOut(arr); CheckEquals(arr[0], 84); CheckEquals(arr[1], 128); end; {$endif} procedure TTestValueSimple.TestMakeSingle; var fs: Single; v: TValue; hadexcept: Boolean; begin fs := 3.14; TValue.Make(@fs, TypeInfo(Single), v); CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, False); Check(v.AsExtended=fs); Check(v.GetReferenceToRawData <> @fs); try hadexcept := False; v.AsInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No signed type conversion exception'); try hadexcept := False; v.AsUInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No unsigned type conversion exception'); end; procedure TTestValueSimple.TestMakeDouble; var fd: Double; v: TValue; hadexcept: Boolean; begin fd := 3.14; TValue.Make(@fd, TypeInfo(Double), v); CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, False); Check(v.AsExtended=fd); Check(v.GetReferenceToRawData <> @fd); try hadexcept := False; v.AsInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No signed type conversion exception'); try hadexcept := False; v.AsUInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No unsigned type conversion exception'); end; procedure TTestValueSimple.TestMakeExtended; var fe: Extended; v: TValue; hadexcept: Boolean; begin fe := 3.14; TValue.Make(@fe, TypeInfo(Extended), v); CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, False); Check(v.AsExtended=fe); Check(v.GetReferenceToRawData <> @fe); try hadexcept := False; v.AsInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No signed type conversion exception'); try hadexcept := False; v.AsUInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No unsigned type conversion exception'); end; procedure TTestValueSimple.TestMakeCurrency; var fcu: Currency; v: TValue; hadexcept: Boolean; begin fcu := 3.14; TValue.Make(@fcu, TypeInfo(Currency), v); CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, False); Check(v.AsExtended=Extended(fcu)); Check(v.AsCurrency=fcu); Check(v.GetReferenceToRawData <> @fcu); try hadexcept := False; v.AsInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No signed type conversion exception'); try hadexcept := False; v.AsUInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No unsigned type conversion exception'); end; procedure TTestValueSimple.TestMakeComp; var fco: Comp; v: TValue; hadexcept: Boolean; begin fco := 314; TValue.Make(@fco, TypeInfo(Comp), v); if v.Kind <> tkFloat then Exit; CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, False); Check(v.AsExtended=Extended(fco)); Check(v.GetReferenceToRawData <> @fco); try hadexcept := False; CheckEquals(v.AsInt64, 314); except hadexcept := True; end; CheckFalse(hadexcept, 'Had signed type conversion exception'); try hadexcept := False; CheckEquals(v.AsUInt64, 314); except hadexcept := True; end; CheckFalse(hadexcept, 'Had unsigned type conversion exception'); end; procedure TTestValueSimple.TestMakeEnum; var e: TTestEnum; v: TValue; begin e := te1; TValue.Make(@e, TypeInfo(TTestEnum), v); Check(not v.IsClass); Check(not v.IsArray); Check(not v.IsEmpty); {$ifdef fpc} Check(not v.IsOpenArray); {$endif} Check(not v.IsObject); Check(v.IsOrdinal); Check(v.GetReferenceToRawData <> @e); Check(TTestEnum(v.AsOrdinal) = te1); end; procedure TTestValueSimple.TestMakeAnsiChar; var c: AnsiChar; v: TValue; begin c := #20; TValue.Make(@c, TypeInfo(AnsiChar), v); Check(not v.IsClass); Check(not v.IsArray); Check(not v.IsEmpty); {$ifdef fpc} Check(not v.IsOpenArray); {$endif} Check(not v.IsObject); Check(v.IsOrdinal); Check(v.GetReferenceToRawData <> @c); Check(AnsiChar(v.AsOrdinal) = #20); Check(v.AsAnsiChar = #20); end; procedure TTestValueSimple.TestMakeWideChar; var c: WideChar; v: TValue; begin c := #$1234; TValue.Make(@c, TypeInfo(WideChar), v); Check(not v.IsClass); Check(not v.IsArray); Check(not v.IsEmpty); {$ifdef fpc} Check(not v.IsOpenArray); {$endif} Check(not v.IsObject); Check(v.IsOrdinal); Check(v.GetReferenceToRawData <> @c); Check(WideChar(v.AsOrdinal) = #$1234); Check(v.AsWideChar = #$1234); end; procedure TTestValueSimple.TestMakeNativeInt; var fni: NativeInt; s: AnsiString; v: TValue; o: TObject; begin fni := 2021; TValue.Make(fni, TypeInfo(LongInt), v); CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, True); Check(NativeInt(v.GetReferenceToRawData) <> fni); CheckEquals(v.AsOrdinal, 2021); s := 'Hello World'; TValue.Make(NativeInt(s), TypeInfo(AnsiString), v); CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, False); CheckEquals(v.AsString, s); o := TObject.Create; TValue.Make(NativeInt(o), TypeInfo(TObject), v); CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, True); CheckEquals(v.IsOrdinal, False); Check(PPointer(v.GetReferenceToRawData)^ = Pointer(o)); Check(v.AsObject = o); o.Free; end; procedure TTestValueSimple.TestMakeVariant; var vv : Variant; vd : TVarData; v: TValue; begin vv := 'Some String'; TValue.Make(@vv, TypeInfo(Variant), v); Check(not v.IsClass); Check(not v.IsArray); Check(not v.IsEmpty); {$ifdef fpc} Check(not v.IsOpenArray); {$endif} Check(not v.IsObject); Check(not v.IsOrdinal); Check(v.GetReferenceToRawData <> @vv); Check(String(v.AsVariant) = 'Some String'); end; procedure TTestValueArray.TestMakeFromArray; var arr, subarr: array of TValue; v, varr: TValue; ti: PTypeInfo; i: LongInt; begin SetLength(arr, 3 * 4); for i := 0 to High(arr) do TValue.{$ifdef fpc}specialize{$endif} Make(i + 1, arr[i]); ti := PTypeInfo(TypeInfo(LongInt)); v := TValue.FromArray(TypeInfo(TArrayOfLongintDyn), arr); Check(not v.IsEmpty, 'Array is empty'); Check(v.IsArray, 'Value is not an array'); CheckEquals(Length(arr), v.GetArrayLength, 'Array length does not match'); for i := 0 to High(arr) do begin varr := v.GetArrayElement(i); Check(varr.TypeInfo = ti, 'Type info of array element does not match'); Check(varr.IsOrdinal, 'Array element is not an ordinal'); Check(varr.AsInteger = arr[i].AsInteger, 'Value of array element does not match'); end; subarr := Copy(arr, 0, 4); v := TValue.FromArray(TypeInfo(TArrayOfLongintStatic), subarr); Check(not v.IsEmpty, 'Array is empty'); Check(v.IsArray, 'Value is not an array'); CheckEquals(Length(subarr), v.GetArrayLength, 'Array length does not match'); for i := 0 to High(subarr) do begin varr := v.GetArrayElement(i); Check(varr.TypeInfo = ti, 'Type info of array element does not match'); Check(varr.IsOrdinal, 'Array element is not an ordinal'); Check(varr.AsInteger = subarr[i].AsInteger, 'Value of array element does not match'); end; v := TValue.FromArray(TypeInfo(TArrayOfLongint2DStatic), arr); Check(not v.IsEmpty, 'Array is empty'); Check(v.IsArray, 'Value is not an array'); CheckEquals(Length(arr), v.GetArrayLength, 'Array length does not match'); for i := 0 to High(arr) do begin varr := v.GetArrayElement(i); Check(varr.TypeInfo = ti, 'Type info of array element does not match'); Check(varr.IsOrdinal, 'Array element is not an ordinal'); Check(varr.AsInteger = arr[i].AsInteger, 'Value of array element does not match'); end; end; procedure TTestValueSimple.TestMakeGenericNil; var value: TValue; begin TValue.{$ifdef fpc}specialize{$endif} Make(Nil, value); CheckTrue(value.IsEmpty); CheckTrue(value.IsObject); CheckTrue(value.IsClass); CheckTrue(value.IsOrdinal); CheckFalse(value.IsArray); CheckTrue(value.AsObject=Nil); CheckTrue(value.AsClass=Nil); CheckTrue(value.AsInterface=Nil); CheckEquals(0, value.AsOrdinal); TValue.{$ifdef fpc}specialize{$endif} Make(Nil, value); CheckTrue(value.IsEmpty); CheckTrue(value.IsClass); CheckTrue(value.IsOrdinal); CheckFalse(value.IsArray); CheckTrue(value.AsObject=Nil); CheckTrue(value.AsClass=Nil); CheckTrue(value.AsInterface=Nil); CheckEquals(0, value.AsOrdinal); end; procedure TTestValueSimple.TestMakeGenericLongInt; var value: TValue; begin TValue.{$ifdef fpc}specialize{$endif} Make(0, value); CheckTrue(value.IsOrdinal); CheckFalse(value.IsEmpty); CheckFalse(value.IsClass); CheckFalse(value.IsObject); CheckFalse(value.IsArray); CheckEquals(0, value.AsOrdinal); CheckEquals(0, value.AsInteger); CheckEquals(0, value.AsInt64); CheckEquals(0, value.AsUInt64); end; procedure TTestValueSimple.TestMakeGenericString; var value: TValue; begin TValue.{$ifdef fpc}specialize{$endif} Make('test', value); CheckFalse(value.IsEmpty); CheckFalse(value.IsObject); CheckFalse(value.IsClass); CheckFalse(value.IsArray); CheckEquals('test', value.AsString); end; procedure TTestValueSimple.TestMakeGenericObject; var value: TValue; TestClass: TTestValueClass; begin TestClass := TTestValueClass.Create; TestClass.AInteger := 54329; TValue.{$ifdef fpc}specialize{$endif} Make(TestClass, value); CheckEquals(value.IsClass, False); CheckEquals(value.IsObject, True); Check(value.AsObject=TestClass); Check(PPointer(value.GetReferenceToRawData)^ = Pointer(TestClass)); CheckEquals(TTestValueClass(value.AsObject).AInteger, 54329); TestClass.Free; end; procedure TTestValueSimple.TestMakeGenericDouble; var fd: Double; v: TValue; hadexcept: Boolean; begin fd := 3.14; TValue.{$ifdef fpc}specialize{$endif} Make(fd, v); CheckEquals(v.IsClass, False); CheckEquals(v.IsObject, False); CheckEquals(v.IsOrdinal, False); Check(v.AsExtended=fd); Check(v.GetReferenceToRawData <> @fd); try hadexcept := False; v.AsInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No signed type conversion exception'); try hadexcept := False; v.AsUInt64; except hadexcept := True; end; CheckTrue(hadexcept, 'No unsigned type conversion exception'); end; procedure TTestValueSimple.TestMakeGenericAnsiChar; var c: AnsiChar; v: TValue; begin c := #20; TValue.{$ifdef fpc}specialize{$endif} Make(c, v); Check(not v.IsClass); Check(not v.IsArray); Check(not v.IsEmpty); {$ifdef fpc} Check(not v.IsOpenArray); {$endif} Check(not v.IsObject); Check(v.IsOrdinal); Check(v.GetReferenceToRawData <> @c); Check(AnsiChar(v.AsOrdinal) = #20); Check(v.AsAnsiChar = #20); end; procedure TTestValueSimple.TestMakeGenericWideChar; var c: WideChar; v: TValue; begin c := #$1234; TValue.{$ifdef fpc}specialize{$endif} Make(c, v); Check(not v.IsClass); Check(not v.IsArray); Check(not v.IsEmpty); {$ifdef fpc} Check(not v.IsOpenArray); {$endif} Check(not v.IsObject); Check(v.IsOrdinal); Check(v.GetReferenceToRawData <> @c); Check(WideChar(v.AsOrdinal) = #$1234); Check(v.AsWideChar = #$1234); end; procedure TTestValueSimple.MakeFromOrdinalTObject; begin TValue.FromOrdinal(TypeInfo(TObject), 42); end; procedure TTestValueSimple.MakeFromOrdinalSet; begin TValue.FromOrdinal(TypeInfo(TTestSet), 42); end; procedure TTestValueSimple.MakeFromOrdinalString; begin TValue.FromOrdinal(TypeInfo(AnsiString), 42); end; procedure TTestValueSimple.MakeFromOrdinalNil; begin TValue.FromOrdinal(Nil, 42); end; procedure TTestValueSimple.TestFromOrdinal; var v: TValue; begin v := TValue.FromOrdinal(TypeInfo(LongInt), 42); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, 42); v := TValue.FromOrdinal(TypeInfo(Boolean), Ord(True)); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, Ord(True)); v := TValue.FromOrdinal(TypeInfo(Int64), $1234123412341234); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, $1234123412341234); v := TValue.FromOrdinal(TypeInfo(QWord), $1234123412341234); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, $1234123412341234); v := TValue.FromOrdinal(TypeInfo(LongBool), Ord(True)); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, Ord(True)); v := TValue.FromOrdinal(TypeInfo(TTestEnum), Ord(te1)); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, Ord(te1)); v := TValue.FromOrdinal(TypeInfo(AnsiChar), Ord(#20)); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, Ord(#20)); v := TValue.FromOrdinal(TypeInfo(WideChar), Ord(#$1234)); Check(v.IsOrdinal); CheckEquals(v.AsOrdinal, Ord(#$1234)); CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalNil, EInvalidCast); CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalTObject, EInvalidCast); CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalSet, EInvalidCast); CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalString, EInvalidCast); end; procedure TTestValueSimple.TestTryCastUnicodeString; var S: string; V, V2: TValue; begin S := 'str'; V := S; CheckTrue(V.TryCast(TypeInfo(UnicodeString), V2),'Cast OK'); end; { TTestValueArray } {$ifdef fpc} procedure TTestValueArray.TestOpenArrayToDyn; procedure OpenArrayProc(aArr: array of LongInt); var value: TValue; begin {$ifndef InLazIDE} value := specialize OpenArrayToDynArrayValue(aArr); {$endif} CheckEquals(value.IsArray, True); CheckEquals(value.IsOpenArray, False); CheckEquals(value.IsObject, False); CheckEquals(value.IsOrdinal, False); CheckEquals(value.IsClass, False); CheckEquals(value.GetArrayLength, 2); CheckEquals(value.GetArrayElement(0).AsInteger, 42); CheckEquals(value.GetArrayElement(1).AsInteger, 84); value.SetArrayElement(0, Integer(21)); { since this is a copy the original array is not modified! } CheckEquals(aArr[0], 42); end; begin OpenArrayProc([42, 84]); end; {$endif} procedure TTestValueGeneral.TestDataSize; var u8: UInt8; u16: UInt16; u32: UInt32; u64: UInt64; s8: Int8; s16: Int16; s32: Int32; s64: Int64; f32: Single; f64: Double; {$ifdef FPC_HAS_TYPE_EXTENDED} f80: Extended; {$endif} fco: Comp; fcu: Currency; ss: ShortString; sa: AnsiString; su: UnicodeString; sw: WideString; o: TObject; c: TClass; i: IInterface; ad: TArrayOfLongintDyn; _as: TArrayOfLongintStatic; b8: Boolean; {$ifdef fpc} b16: Boolean16; b32: Boolean32; b64: Boolean64; {$endif} bl8: ByteBool; bl16: WordBool; bl32: LongBool; {$ifdef fpc} bl64: QWordBool; {$endif} e: TTestEnum; s: TTestSet; t: TTestRecord; p: Pointer; proc: TTestProc; method: TTestMethod; value: TValue; begin u8:=245; TValue.Make(@u8, TypeInfo(UInt8), value); CheckEquals(1, value.DataSize, 'Size of UInt8 differs'); u16:=789; TValue.Make(@u16, TypeInfo(UInt16), value); CheckEquals(2, value.DataSize, 'Size of UInt16 differs'); u32:=568789; TValue.Make(@u32, TypeInfo(UInt32), value); CheckEquals(4, value.DataSize, 'Size of UInt32 differs'); u64:=$abdcefadbcef; TValue.Make(@u64, TypeInfo(UInt64), value); CheckEquals(8, value.DataSize, 'Size of UInt64 differs'); s8:=-32; TValue.Make(@s8, TypeInfo(Int8), value); CheckEquals(1, value.DataSize, 'Size of Int8 differs'); s16:=-5345; TValue.Make(@s16, TypeInfo(Int16), value); CheckEquals(2, value.DataSize, 'Size of Int16 differs'); s32:=-234567; TValue.Make(@s32, TypeInfo(Int32), value); CheckEquals(4, value.DataSize, 'Size of Int32 differs'); s64:=23456789012; TValue.Make(@s64, TypeInfo(Int64), value); CheckEquals(8, value.DataSize, 'Size of Int64 differs'); b8:=false; TValue.Make(@b8, TypeInfo(Boolean), value); CheckEquals(1, value.DataSize, 'Size of Boolean differs'); {$ifdef fpc} b16:=true; TValue.Make(@b16, TypeInfo(Boolean16), value); CheckEquals(2, value.DataSize, 'Size of Boolean16 differs'); b32:=false; TValue.Make(@b32, TypeInfo(Boolean32), value); CheckEquals(4, value.DataSize, 'Size of Boolean32 differs'); b64:=true; TValue.Make(@b64, TypeInfo(Boolean64), value); CheckEquals(8, value.DataSize, 'Size of Boolean64 differs'); {$endif} bl8:=true; TValue.Make(@bl8, TypeInfo(ByteBool), value); CheckEquals(1, value.DataSize, 'Size of ByteBool differs'); bl16:=false; TValue.Make(@bl16, TypeInfo(WordBool), value); CheckEquals(2, value.DataSize, 'Size of WordBool differs'); bl32:=false; TValue.Make(@bl32, TypeInfo(LongBool), value); CheckEquals(4, value.DataSize, 'Size of LongBool differs'); {$ifdef fpc} bl64:=true; TValue.Make(@bl64, TypeInfo(QWordBool), value); CheckEquals(8, value.DataSize, 'Size of QWordBool differs'); {$endif} f32:=4.567; TValue.Make(@f32, TypeInfo(Single), value); CheckEquals(4, value.DataSize, 'Size of Single differs'); f64:=-3456.678; TValue.Make(@f64, TypeInfo(Double), value); CheckEquals(8, value.DataSize, 'Size of Double differs'); {$ifdef FPC_HAS_TYPE_EXTENDED} f80:=-2345.678; TValue.Make(@f80, TypeInfo(Extended), value); CheckEquals(10, value.DataSize, 'Size of Extended differs'); {$endif} fcu:=56.78; TValue.Make(@fcu, TypeInfo(Currency), value); CheckEquals(SizeOf(Currency), value.DataSize, 'Size of Currency differs'); fco:=456; TValue.Make(@fco, TypeInfo(Comp), value); CheckEquals(SizeOf(Comp), value.DataSize, 'Size of Comp differs'); ss := ''; TValue.Make(@ss, TypeInfo(ShortString), value); CheckEquals(254, value.DataSize, 'Size ofShortString differs'); sa:= ''; TValue.Make(@sa, TypeInfo(AnsiString), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of AnsiString differs'); sw := ''; TValue.Make(@sw, TypeInfo(WideString), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of WideString differs'); su:=''; TValue.Make(@su, TypeInfo(UnicodeString), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of UnicodeString differs'); o := TTestValueClass.Create; TValue.Make(@o, TypeInfo(TObject), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TObject differs'); o.Free; c := TObject; TValue.Make(@c, TypeInfo(TClass), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TClass differs'); i := Nil; TValue.Make(@i, TypeInfo(IInterface), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of IInterface differs'); TValue.Make(@t, TypeInfo(TTestRecord), value); CheckEquals(SizeOf(TTestRecord), value.DataSize, 'Size of TTestRecord differs'); proc := Nil; TValue.Make(@proc, TypeInfo(TTestProc), value); CheckEquals(SizeOf(TTestProc), value.DataSize, 'Size of TTestProc differs'); method := Nil; TValue.Make(@method, TypeInfo(TTestMethod), value); CheckEquals(SizeOf(TTestMethod), value.DataSize, 'Size of TTestMethod differs'); TValue.Make(@_as, TypeInfo(TArrayOfLongintStatic), value); CheckEquals(SizeOf(TArrayOfLongintStatic), value.DataSize, 'Size of TArrayOfLongintStatic differs'); TValue.Make(@ad, TypeInfo(TArrayOfLongintDyn), value); CheckEquals(SizeOf(TArrayOfLongintDyn), value.DataSize, 'Size of TArrayOfLongintDyn differs'); e:=low(TTestEnum); TValue.Make(@e, TypeInfo(TTestEnum), value); CheckEquals(SizeOf(TTestEnum), value.DataSize, 'Size of TTestEnum differs'); s:=[low(TTestEnum),high(TTestEnum)]; TValue.Make(@s, TypeInfo(TTestSet), value); CheckEquals(SizeOf(TTestSet), value.DataSize, 'Size of TTestSet differs'); p := Nil; TValue.Make(@p, TypeInfo(Pointer), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of Pointer differs'); end; procedure TTestValueGeneral.TestDataSizeEmpty; var value: TValue; begin TValue.Make(Nil, TypeInfo(UInt8), value); CheckEquals(1, value.DataSize, 'Size of UInt8 differs'); TValue.Make(Nil, TypeInfo(UInt16), value); CheckEquals(2, value.DataSize, 'Size of UInt16 differs'); TValue.Make(Nil, TypeInfo(UInt32), value); CheckEquals(4, value.DataSize, 'Size of UInt32 differs'); TValue.Make(Nil, TypeInfo(UInt64), value); CheckEquals(8, value.DataSize, 'Size of UInt64 differs'); TValue.Make(Nil, TypeInfo(Int8), value); CheckEquals(1, value.DataSize, 'Size of Int8 differs'); TValue.Make(Nil, TypeInfo(Int16), value); CheckEquals(2, value.DataSize, 'Size of Int16 differs'); TValue.Make(Nil, TypeInfo(Int32), value); CheckEquals(4, value.DataSize, 'Size of Int32 differs'); TValue.Make(Nil, TypeInfo(Int64), value); CheckEquals(8, value.DataSize, 'Size of Int64 differs'); TValue.Make(Nil, TypeInfo(Boolean), value); CheckEquals(1, value.DataSize, 'Size of Boolean differs'); {$ifdef fpc} TValue.Make(Nil, TypeInfo(Boolean16), value); CheckEquals(2, value.DataSize, 'Size of Boolean16 differs'); TValue.Make(Nil, TypeInfo(Boolean32), value); CheckEquals(4, value.DataSize, 'Size of Boolean32 differs'); TValue.Make(Nil, TypeInfo(Boolean64), value); CheckEquals(8, value.DataSize, 'Size of Boolean64 differs'); {$endif} TValue.Make(Nil, TypeInfo(ByteBool), value); CheckEquals(1, value.DataSize, 'Size of ByteBool differs'); TValue.Make(Nil, TypeInfo(WordBool), value); CheckEquals(2, value.DataSize, 'Size of WordBool differs'); TValue.Make(Nil, TypeInfo(LongBool), value); CheckEquals(4, value.DataSize, 'Size of LongBool differs'); {$ifdef fpc} TValue.Make(Nil, TypeInfo(QWordBool), value); CheckEquals(8, value.DataSize, 'Size of QWordBool differs'); {$endif} TValue.Make(Nil, TypeInfo(Single), value); CheckEquals(4, value.DataSize, 'Size of Single differs'); TValue.Make(Nil, TypeInfo(Double), value); CheckEquals(8, value.DataSize, 'Size of Double differs'); {$ifdef FPC_HAS_TYPE_EXTENDED} TValue.Make(Nil, TypeInfo(Extended), value); CheckEquals(10, value.DataSize, 'Size of Extended differs'); {$endif} TValue.Make(Nil, TypeInfo(Currency), value); CheckEquals(SizeOf(Currency), value.DataSize, 'Size of Currency differs'); TValue.Make(Nil, TypeInfo(Comp), value); CheckEquals(SizeOf(Comp), value.DataSize, 'Size of Comp differs'); TValue.Make(Nil, TypeInfo(ShortString), value); CheckEquals(254, value.DataSize, 'Size of ShortString differs'); TValue.Make(Nil, TypeInfo(AnsiString), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of Pointer differs'); TValue.Make(Nil, TypeInfo(WideString), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of WideString differs'); TValue.Make(Nil, TypeInfo(UnicodeString), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of UnicodeString differs'); TValue.Make(Nil, TypeInfo(TObject), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TObject differs'); TValue.Make(Nil, TypeInfo(TClass), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TClass differs'); TValue.Make(Nil, TypeInfo(IInterface), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of IInterface differs'); TValue.Make(Nil, TypeInfo(TTestRecord), value); CheckEquals(SizeOf(TTestRecord), value.DataSize, 'Size of TTestRecord differs'); TValue.Make(Nil, TypeInfo(TTestProc), value); CheckEquals(SizeOf(TTestProc), value.DataSize, 'Size of TTestProc differs'); TValue.Make(Nil, TypeInfo(TTestMethod), value); CheckEquals(SizeOf(TTestMethod), value.DataSize, 'Size of TTestMethod differs'); TValue.Make(Nil, TypeInfo(TArrayOfLongintStatic), value); CheckEquals(SizeOf(TArrayOfLongintStatic), value.DataSize, 'Size of TArrayOfLongintStatic differs'); TValue.Make(Nil, TypeInfo(TArrayOfLongintDyn), value); CheckEquals(SizeOf(TArrayOfLongintDyn), value.DataSize, 'Size of TArrayOfLongintDyn differs'); TValue.Make(Nil, TypeInfo(TTestEnum), value); CheckEquals(SizeOf(TTestEnum), value.DataSize, 'Size of TTestEnum differs'); TValue.Make(Nil, TypeInfo(TTestSet), value); CheckEquals(SizeOf(TTestSet), value.DataSize, 'Size of TTestSet differs'); TValue.Make(Nil, TypeInfo(Pointer), value); CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of Pointer differs'); end; procedure TTestValueGeneral.TestIsManaged; begin CheckEquals(true, IsManaged(TypeInfo(ansistring)), 'IsManaged for tkAString'); CheckEquals(true, IsManaged(TypeInfo(widestring)), 'IsManaged for tkWString'); CheckEquals(true, IsManaged(TypeInfo(Variant)), 'IsManaged for tkVariant'); CheckEquals(true, IsManaged(TypeInfo(TArrayOfManagedRec)), 'IsManaged for tkArray (with managed ElType)'); CheckEquals(true, IsManaged(TypeInfo(TArrayOfString)), 'IsManaged for tkArray (with managed ElType)'); CheckEquals(true, IsManaged(TypeInfo(TManagedRec)), 'IsManaged for tkRecord'); {$ifdef fpc} CheckEquals(true, IsManaged(TypeInfo(TManagedRecOp)), 'IsManaged for tkRecord'); {$endif} CheckEquals(true, IsManaged(TypeInfo(IInterface)), 'IsManaged for tkInterface'); CheckEquals(true, IsManaged(TypeInfo(TManagedObj)), 'IsManaged for tkObject'); {$ifdef fpc} CheckEquals(true, IsManaged(TypeInfo(specialize TArray)), 'IsManaged for tkDynArray'); {$else} CheckEquals(true, IsManaged(TypeInfo(TArray)), 'IsManaged for tkDynArray'); {$endif} CheckEquals(true, IsManaged(TypeInfo(unicodestring)), 'IsManaged for tkUString'); CheckEquals(false, IsManaged(TypeInfo(shortstring)), 'IsManaged for tkSString'); CheckEquals(false, IsManaged(TypeInfo(Byte)), 'IsManaged for tkInteger'); CheckEquals(false, IsManaged(TypeInfo(Char)), 'IsManaged for tkChar'); CheckEquals(false, IsManaged(TypeInfo(TTestEnum)), 'IsManaged for tkEnumeration'); CheckEquals(false, IsManaged(TypeInfo(Single)), 'IsManaged for tkFloat'); CheckEquals(false, IsManaged(TypeInfo(TTestSet)), 'IsManaged for tkSet'); {$ifdef fpc} CheckEquals(false, IsManaged(TypeInfo(TTestMethod)), 'IsManaged for tkMethod'); {$else} { Delphi bug (or sabotage). For some reason Delphi considers method pointers to be managed (only in newer versions, probably since XE7) :/ } CheckEquals({$if RTLVersion>=28}true{$else}false{$endif}, IsManaged(TypeInfo(TTestMethod)), 'IsManaged for tkMethod'); {$endif} CheckEquals(false, IsManaged(TypeInfo(TArrayOfByte)), 'IsManaged for tkArray (with non managed ElType)'); CheckEquals(false, IsManaged(TypeInfo(TArrayOfNonManagedRec)), 'IsManaged for tkArray (with non managed ElType)'); CheckEquals(false, IsManaged(TypeInfo(TNonManagedRec)), 'IsManaged for tkRecord'); CheckEquals(false, IsManaged(TypeInfo(TObject)), 'IsManaged for tkClass'); CheckEquals(false, IsManaged(TypeInfo(TNonManagedObj)), 'IsManaged for tkObject'); CheckEquals(false, IsManaged(TypeInfo(WideChar)), 'IsManaged for tkWChar'); CheckEquals(false, IsManaged(TypeInfo(Boolean)), 'IsManaged for tkBool'); CheckEquals(false, IsManaged(TypeInfo(Int64)), 'IsManaged for tkInt64'); CheckEquals(false, IsManaged(TypeInfo(UInt64)), 'IsManaged for tkQWord'); {$ifdef fpc} CheckEquals(false, IsManaged(TypeInfo(ICORBATest)), 'IsManaged for tkInterfaceRaw'); {$endif} CheckEquals(false, IsManaged(TypeInfo(TTestProc)), 'IsManaged for tkProcVar'); CheckEquals(false, IsManaged(TypeInfo(TTestHelper)), 'IsManaged for tkHelper'); {$ifdef fpc} CheckEquals(false, IsManaged(TypeInfo(file)), 'IsManaged for tkFile'); {$endif} CheckEquals(false, IsManaged(TypeInfo(TClass)), 'IsManaged for tkClassRef'); CheckEquals(false, IsManaged(TypeInfo(Pointer)), 'IsManaged for tkPointer'); CheckEquals(false, IsManaged(nil), 'IsManaged for nil'); end; Type TEnum1 = (en1_1, en1_2); TEnum2 = (en2_1); TEnum3 = en1_1..en1_1; procedure TTestValueGeneral.TestCasts; var TempV,T1,T2,T3 : TValue; begin T1:=TValue. specialize From(en1_1); T2:=T1. specialize Cast; // T3:=T2. specialize AsType; CheckTrue((en1_1 = T2. specialize AsType), 'en1_1 = (TValue.From(en1_1).Cast.AsType)'); CheckFalse(TValue. specialize From(32).TryCast(TypeInfo(AnsiChar), TempV), 'not (TValue.From(32).TryCast(TypeInfo(AnsiChar), V)'); CheckFalse(TValue. specialize From(32).TryCast(TypeInfo(WideChar), TempV), 'not (TValue.From(32).TryCast(TypeInfo(WideChar), V)'); {$ifdef fpc} CheckFalse(TValue. specialize From(32).TryCast(TypeInfo(UnicodeChar), TempV), 'not (TValue.From(32).TryCast(TypeInfo(UnicodeChar), V)'); {$endif} CheckTrue(Byte(397) = (TValue. specialize From(397). specialize Cast(). specialize AsType), 'Byte(397) = (TValue.From(397).Cast().AsType)'); CheckTrue(32 = (TValue. specialize From(32). specialize Cast(). specialize AsType), '32 = (TValue.From(32).Cast().AsType)'); end; procedure TTestValueGeneral.TestReferenceRawData; var value: TValue; str: String; intf: IInterface; i: LongInt; test: TTestRecord; arrdyn: TArrayOfLongintDyn; arrstat: TArrayOfLongintStatic; begin str := 'Hello World'; UniqueString(str); TValue.Make(@str, TypeInfo(String), value); Check(PPointer(value.GetReferenceToRawData)^ = Pointer(str), 'Reference to string data differs'); intf := TInterfacedObject.Create; TValue.Make(@intf, TypeInfo(IInterface), value); Check(PPointer(value.GetReferenceToRawData)^ = Pointer(intf), 'Reference to interface data differs'); i := 42; TValue.Make(@i, TypeInfo(LongInt), value); Check(value.GetReferenceToRawData <> @i, 'Reference to longint is equal'); Check(PLongInt(value.GetReferenceToRawData)^ = PLongInt(@i)^, 'Reference to longint data differs'); test.value1 := 42; test.value2 := 'Hello World'; TValue.Make(@test, TypeInfo(TTestRecord), value); Check(value.GetReferenceToRawData <> @test, 'Reference to record is equal'); Check(PTestRecord(value.GetReferenceToRawData)^.value1 = PTestRecord(@test)^.value1, 'Reference to record data value1 differs'); Check(PTestRecord(value.GetReferenceToRawData)^.value2 = PTestRecord(@test)^.value2, 'Reference to record data value2 differs'); SetLength(arrdyn, 3); arrdyn[0] := 42; arrdyn[1] := 23; arrdyn[2] := 49; TValue.Make(@arrdyn, TypeInfo(TArrayOfLongintDyn), value); Check(PPointer(value.GetReferenceToRawData)^ = Pointer(arrdyn), 'Reference to dynamic array data differs'); arrstat[0] := 42; arrstat[1] := 23; arrstat[2] := 49; arrstat[3] := 59; TValue.Make(@arrstat, TypeInfo(TArrayOfLongintStatic), value); Check(value.GetReferenceToRawData <> @arrstat, 'Reference to static array is equal'); Check(PLongInt(value.GetReferenceToRawData)^ = PLongInt(@arrstat)^, 'Reference to static array data differs'); end; procedure TTestValueGeneral.TestReferenceRawDataEmpty; var value: TValue; begin TValue.Make(Nil, TypeInfo(String), value); Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty String is not assigned'); Check(not Assigned(PPointer(value.GetReferenceToRawData)^), 'Empty String data is assigned'); TValue.Make(Nil, TypeInfo(IInterface), value); Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty interface is not assigned'); Check(not Assigned(PPointer(value.GetReferenceToRawData)^), 'Empty interface data is assigned'); TValue.Make(Nil, TypeInfo(LongInt), value); Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty LongInt is not assigned'); Check(PLongInt(value.GetReferenceToRawData)^ = 0, 'Empty longint data is not 0'); TValue.Make(Nil, TypeInfo(TTestRecord), value); Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty record is not assigned'); Check(PTestRecord(value.GetReferenceToRawData)^.value1 = 0, 'Empty record data value1 is not 0'); Check(PTestRecord(value.GetReferenceToRawData)^.value2 = '', 'Empty record data value2 is not empty'); TValue.Make(Nil, TypeInfo(TArrayOfLongintDyn), value); Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty dynamic array is not assigned'); Check(not Assigned(PPointer(value.GetReferenceToRawData)^), 'Empty dynamic array data is assigned'); TValue.Make(Nil, TypeInfo(TArrayOfLongintStatic), value); Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty static array is not assigned'); Check(PLongInt(value.GetReferenceToRawData)^ = 0, 'Empty static array data is not 0'); end; initialization RegisterTest(TTestValueGeneral); RegisterTest(TTestValueSimple); RegisterTest(TTestValueSimple); RegisterTest(TTestValueVariant); end.