123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028 |
- unit tests.rtti;
- {$ifdef fpc}
- {$mode objfpc}{$H+}
- {$modeswitch advancedrecords}
- {$endif}
- interface
- uses
- {$IFDEF FPC}
- fpcunit,testregistry, testutils,
- {$ELSE FPC}
- TestFramework,
- {$ENDIF FPC}
- Classes, SysUtils, typinfo,
- Rtti;
- type
- { TTestCase1 }
- TTestCase1= class(TTestCase)
- published
- //procedure GetTypes;
- procedure GetTypeInteger;
- procedure GetTypePointer;
- procedure GetClassProperties;
- procedure GetClassPropertiesValue;
- procedure TestTRttiTypeProperties;
- procedure TestPropGetValueString;
- procedure TestPropGetValueInteger;
- procedure TestPropGetValueBoolean;
- procedure TestPropGetValueShortString;
- procedure TestPropGetValueProcString;
- procedure TestPropGetValueProcInteger;
- procedure TestPropGetValueProcBoolean;
- procedure TestPropGetValueProcShortString;
- procedure TestPropSetValueString;
- procedure TestPropSetValueInteger;
- procedure TestPropSetValueBoolean;
- procedure TestPropSetValueShortString;
- procedure TestGetValueStringCastError;
- procedure TestGetIsReadable;
- procedure TestIsWritable;
- procedure TestMakeNil;
- procedure TestMakeObject;
- procedure TestMakeArrayDynamic;
- procedure TestMakeArrayStatic;
- {$ifdef fpc}
- procedure TestMakeArrayOpen;
- {$endif}
- procedure TestMakeSingle;
- procedure TestMakeDouble;
- procedure TestMakeExtended;
- procedure TestMakeCurrency;
- procedure TestMakeComp;
- procedure TestMakeEnum;
- procedure TestMakeAnsiChar;
- procedure TestMakeWideChar;
- procedure TestFromOrdinal;
- procedure TestDataSize;
- procedure TestDataSizeEmpty;
- procedure TestReferenceRawData;
- procedure TestReferenceRawDataEmpty;
- procedure TestIsManaged;
- {$ifdef fpc}
- procedure TestOpenArrayToDyn;
- {$endif}
- procedure TestInterface;
- {$ifdef fpc}
- procedure TestInterfaceRaw;
- {$endif}
- procedure TestProcVar;
- procedure TestMethod;
- procedure TestRawThunk;
- private
- procedure MakeFromOrdinalTObject;
- procedure MakeFromOrdinalSet;
- procedure MakeFromOrdinalString;
- procedure MakeFromOrdinalNil;
- end;
- implementation
- type
- {$M+}
- TGetClassProperties = class
- private
- FPubPropRO: integer;
- FPubPropRW: integer;
- published
- property PubPropRO: integer read FPubPropRO;
- property PubPropRW: integer read FPubPropRW write FPubPropRW;
- property PubPropSetRO: integer read FPubPropRO;
- property PubPropSetRW: integer read FPubPropRW write FPubPropRW;
- end;
- TGetClassPropertiesSub = class(TGetClassProperties)
- end;
- {$M-}
- { TTestValueClass }
- {$M+}
- TTestValueClass = class
- private
- FAInteger: integer;
- FAString: string;
- FABoolean: boolean;
- FAShortString: ShortString;
- function GetAInteger: integer;
- function GetAString: string;
- function GetABoolean: boolean;
- function GetAShortString: ShortString;
- procedure SetWriteOnly(AValue: integer);
- published
- property AInteger: Integer read FAInteger write FAInteger;
- property AString: string read FAString write FAString;
- property ABoolean: boolean read FABoolean write FABoolean;
- property AShortString: ShortString read FAShortString write FAShortString;
- property AGetInteger: Integer read GetAInteger;
- property AGetString: string read GetAString;
- property AGetBoolean: boolean read GetABoolean;
- property AGetShortString: ShortString read GetAShortString;
- property AWriteOnly: integer write SetWriteOnly;
- end;
- {$M-}
- {$M+}
- ITestInterface = interface
- procedure Test;
- function Test2: LongInt;
- procedure Test3(aArg1: LongInt; const aArg2: AnsiString; var aArg3: Boolean; out aArg4: Word);
- function Test4(aArg1: array of LongInt; aArg2: array of const): AnsiString;
- end;
- {$M-}
- TManagedRec = record
- s: string;
- end;
- {$ifdef fpc}
- TManagedRecOp = record
- class operator AddRef(var a: TManagedRecOp);
- end;
- {$endif}
- TNonManagedRec = record
- i: Integer;
- end;
- TManagedObj = object
- i: IInterface;
- end;
- TNonManagedObj = object
- d: double;
- end;
- TTestEnum = (te1, te2, te3, te4, te5);
- TTestSet = set of TTestEnum;
- TTestProc = procedure;
- TTestFunc1 = function: LongInt;
- TTestFunc2 = function(aArg1: LongInt; aArg2: array of LongInt): String;
- TTestMethod = procedure of object;
- TTestMethod1 = function: LongInt of object;
- TTestMethod2 = function(aArg1: LongInt; aArg2: array of LongInt): String of object;
- TTestHelper = class helper for TObject
- end;
- TArrayOfString = array[0..0] of string;
- TArrayOfManagedRec = array[0..0] of TManagedRec;
- TArrayOfNonManagedRec = array[0..0] of TNonManagedRec;
- TArrayOfByte = array[0..0] of byte;
- TArrayOfLongintDyn = array of LongInt;
- TArrayOfLongintStatic = array[0..3] of LongInt;
- TTestRecord = record
- Value1: LongInt;
- Value2: String;
- end;
- PTestRecord = ^TTestRecord;
- {$ifdef fpc}
- {$PUSH}
- {$INTERFACES CORBA}
- ICORBATest = interface
- end;
- {$POP}
- {$endif}
- {$ifdef fpc}
- class operator TManagedRecOp.AddRef(var a: TManagedRecOp);
- begin
- end;
- {$endif}
- { TTestValueClass }
- function TTestValueClass.GetAInteger: integer;
- begin
- result := FAInteger;
- end;
- function TTestValueClass.GetAString: string;
- begin
- result := FAString;
- end;
- function TTestValueClass.GetABoolean: boolean;
- begin
- result := FABoolean;
- end;
- function TTestValueClass.GetAShortString: ShortString;
- begin
- Result := FAShortString;
- end;
- procedure TTestValueClass.SetWriteOnly(AValue: integer);
- begin
- // Do nothing
- end;
- { Note: GetTypes currently only returns those types that had been acquired using
- GetType, so GetTypes itself can't be really tested currently }
- (*procedure TTestCase1.GetTypes;
- var
- LContext: TRttiContext;
- LType: TRttiType;
- IsTestCaseClassFound: boolean;
- begin
- LContext := TRttiContext.Create;
- { Enumerate all types declared in the application }
- for LType in LContext.GetTypes() do
- begin
- if LType.Name='TTestCase1' then
- IsTestCaseClassFound:=true;
- end;
- LContext.Free;
- CheckTrue(IsTestCaseClassFound, 'RTTI information does not contain class of testcase.');
- end;*)
- procedure TTestCase1.TestGetValueStringCastError;
- var
- ATestClass : TTestValueClass;
- c: TRttiContext;
- ARttiType: TRttiType;
- AValue: TValue;
- i: integer;
- HadException: boolean;
- begin
- c := TRttiContext.Create;
- try
- ATestClass := TTestValueClass.Create;
- ATestClass.AString := '12';
- try
- ARttiType := c.GetType(ATestClass.ClassInfo);
- AValue := ARttiType.GetProperty('astring').GetValue(ATestClass);
- HadException := false;
- try
- i := AValue.AsInteger;
- except
- on E: Exception do
- if E.ClassType=EInvalidCast then
- HadException := true;
- end;
- Check(HadException, 'No or invalid exception on invalid cast');
- finally
- AtestClass.Free;
- end;
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.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 TTestCase1.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 TTestCase1.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, 84);
- CheckEquals(arr[0], 84);
- end;
- procedure TTestCase1.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, 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 TTestCase1.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, 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 TTestCase1.TestMakeSingle;
- var
- fs: Single;
- v: TValue;
- hadexcept: Boolean;
- begin
- fs := 3.14;
- TValue.Make(@fs, TypeInfo(fs), 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 TTestCase1.TestMakeDouble;
- var
- fd: Double;
- v: TValue;
- hadexcept: Boolean;
- begin
- fd := 3.14;
- TValue.Make(@fd, TypeInfo(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 TTestCase1.TestMakeExtended;
- var
- fe: Extended;
- v: TValue;
- hadexcept: Boolean;
- begin
- fe := 3.14;
- TValue.Make(@fe, TypeInfo(fe), 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 TTestCase1.TestMakeCurrency;
- var
- fcu: Currency;
- v: TValue;
- hadexcept: Boolean;
- begin
- fcu := 3.14;
- TValue.Make(@fcu, TypeInfo(fcu), 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 TTestCase1.TestMakeComp;
- var
- fco: Comp;
- v: TValue;
- hadexcept: Boolean;
- begin
- fco := 314;
- TValue.Make(@fco, TypeInfo(fco), 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 TTestCase1.TestMakeEnum;
- var
- e: TTestEnum;
- v: TValue;
- begin
- e := te1;
- TValue.Make(@e, TypeInfo(e), v);
- Check(not v.IsClass);
- Check(not v.IsArray);
- Check(not v.IsEmpty);
- Check(not v.IsOpenArray);
- Check(not v.IsObject);
- Check(v.IsOrdinal);
- Check(v.GetReferenceToRawData <> @e);
- Check(TTestEnum(v.AsOrdinal) = te1);
- end;
- procedure TTestCase1.TestMakeAnsiChar;
- var
- c: AnsiChar;
- v: TValue;
- begin
- c := #20;
- TValue.Make(@c, TypeInfo(c), v);
- Check(not v.IsClass);
- Check(not v.IsArray);
- Check(not v.IsEmpty);
- Check(not v.IsOpenArray);
- Check(not v.IsObject);
- Check(v.IsOrdinal);
- Check(v.GetReferenceToRawData <> @c);
- Check(AnsiChar(v.AsOrdinal) = #20);
- end;
- procedure TTestCase1.TestMakeWideChar;
- var
- c: WideChar;
- v: TValue;
- begin
- c := #$1234;
- TValue.Make(@c, TypeInfo(c), v);
- Check(not v.IsClass);
- Check(not v.IsArray);
- Check(not v.IsEmpty);
- Check(not v.IsOpenArray);
- Check(not v.IsObject);
- Check(v.IsOrdinal);
- Check(v.GetReferenceToRawData <> @c);
- Check(WideChar(v.AsOrdinal) = #$1234);
- end;
- procedure TTestCase1.MakeFromOrdinalTObject;
- begin
- TValue.FromOrdinal(TypeInfo(TObject), 42);
- end;
- procedure TTestCase1.MakeFromOrdinalSet;
- begin
- TValue.FromOrdinal(TypeInfo(TTestSet), 42);
- end;
- procedure TTestCase1.MakeFromOrdinalString;
- begin
- TValue.FromOrdinal(TypeInfo(AnsiString), 42);
- end;
- procedure TTestCase1.MakeFromOrdinalNil;
- begin
- TValue.FromOrdinal(Nil, 42);
- end;
- procedure TTestCase1.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 TTestCase1.TestGetIsReadable;
- var
- c: TRttiContext;
- ARttiType: TRttiType;
- AProperty: TRttiProperty;
- begin
- c := TRttiContext.Create;
- try
- ARttiType := c.GetType(TTestValueClass);
- AProperty := ARttiType.GetProperty('aBoolean');
- CheckEquals(AProperty.IsReadable, true);
- AProperty := ARttiType.GetProperty('aGetBoolean');
- CheckEquals(AProperty.IsReadable, true);
- AProperty := ARttiType.GetProperty('aWriteOnly');
- CheckEquals(AProperty.IsReadable, False);
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.TestIsWritable;
- var
- c: TRttiContext;
- ARttiType: TRttiType;
- AProperty: TRttiProperty;
- begin
- c := TRttiContext.Create;
- try
- ARttiType := c.GetType(TTestValueClass);
- AProperty := ARttiType.GetProperty('aBoolean');
- CheckEquals(AProperty.IsWritable, true);
- AProperty := ARttiType.GetProperty('aGetBoolean');
- CheckEquals(AProperty.IsWritable, false);
- AProperty := ARttiType.GetProperty('aWriteOnly');
- CheckEquals(AProperty.IsWritable, True);
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.TestPropGetValueBoolean;
- var
- ATestClass : TTestValueClass;
- c: TRttiContext;
- ARttiType: TRttiType;
- AProperty: TRttiProperty;
- AValue: TValue;
- begin
- c := TRttiContext.Create;
- try
- ATestClass := TTestValueClass.Create;
- ATestClass.ABoolean := true;
- try
- ARttiType := c.GetType(ATestClass.ClassInfo);
- Check(assigned(ARttiType));
- AProperty := ARttiType.GetProperty('aBoolean');
- AValue := AProperty.GetValue(ATestClass);
- CheckEquals(true,AValue.AsBoolean);
- ATestClass.ABoolean := false;
- CheckEquals(true, AValue.AsBoolean);
- CheckEquals('True', AValue.ToString);
- CheckEquals(True, AValue.IsOrdinal);
- CheckEquals(1, AValue.AsOrdinal);
- finally
- AtestClass.Free;
- end;
- CheckEquals(True,AValue.AsBoolean);
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.TestPropGetValueShortString;
- var
- ATestClass : TTestValueClass;
- c: TRttiContext;
- ARttiType: TRttiType;
- AProperty: TRttiProperty;
- AValue: TValue;
- begin
- c := TRttiContext.Create;
- try
- ATestClass := TTestValueClass.Create;
- ATestClass.AShortString := 'Hello World';
- try
- ARttiType := c.GetType(ATestClass.ClassInfo);
- Check(assigned(ARttiType));
- AProperty := ARttiType.GetProperty('aShortString');
- AValue := AProperty.GetValue(ATestClass);
- CheckEquals('Hello World',AValue.AsString);
- ATestClass.AShortString := 'Foobar';
- CheckEquals('Hello World', AValue.AsString);
- CheckEquals(False, AValue.IsOrdinal);
- CheckEquals(False, AValue.IsObject);
- CheckEquals(False, AValue.IsArray);
- CheckEquals(False, AValue.IsClass);
- finally
- AtestClass.Free;
- end;
- CheckEquals('Hello World',AValue.AsString);
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.TestPropGetValueInteger;
- var
- ATestClass : TTestValueClass;
- c: TRttiContext;
- ARttiType: TRttiType;
- AProperty: TRttiProperty;
- AValue: TValue;
- begin
- c := TRttiContext.Create;
- try
- ATestClass := TTestValueClass.Create;
- ATestClass.AInteger := 472349;
- try
- ARttiType := c.GetType(ATestClass.ClassInfo);
- Check(assigned(ARttiType));
- AProperty := ARttiType.GetProperty('ainteger');
- AValue := AProperty.GetValue(ATestClass);
- CheckEquals(472349,AValue.AsInteger);
- ATestClass.AInteger := 12;
- CheckEquals(472349, AValue.AsInteger);
- CheckEquals('472349', AValue.ToString);
- CheckEquals(True, AValue.IsOrdinal);
- finally
- AtestClass.Free;
- end;
- CheckEquals(472349,AValue.AsInteger);
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.TestPropGetValueString;
- var
- ATestClass : TTestValueClass;
- c: TRttiContext;
- ARttiType: TRttiType;
- AProperty: TRttiProperty;
- AValue: TValue;
- i: int64;
- begin
- c := TRttiContext.Create;
- try
- ATestClass := TTestValueClass.Create;
- ATestClass.AString := 'Hello World';
- try
- ARttiType := c.GetType(ATestClass.ClassInfo);
- Check(assigned(ARttiType));
- AProperty := ARttiType.GetProperty('astring');
- AValue := AProperty.GetValue(ATestClass);
- CheckEquals('Hello World',AValue.AsString);
- ATestClass.AString := 'Goodbye World';
- CheckEquals('Hello World',AValue.AsString);
- CheckEquals('Hello World',AValue.ToString);
- Check(TypeInfo(string)=AValue.TypeInfo);
- Check(AValue.TypeData=GetTypeData(AValue.TypeInfo));
- Check(AValue.IsEmpty=false);
- Check(AValue.IsObject=false);
- Check(AValue.IsClass=false);
- CheckEquals(AValue.IsOrdinal, false);
- CheckEquals(AValue.TryAsOrdinal(i), false);
- CheckEquals(AValue.IsType(TypeInfo(string)), true);
- CheckEquals(AValue.IsType(TypeInfo(integer)), false);
- CheckEquals(AValue.IsArray, false);
- finally
- AtestClass.Free;
- end;
- CheckEquals('Hello World',AValue.AsString);
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.TestPropGetValueProcBoolean;
- var
- ATestClass : TTestValueClass;
- c: TRttiContext;
- ARttiType: TRttiType;
- AProperty: TRttiProperty;
- AValue: TValue;
- begin
- c := TRttiContext.Create;
- try
- ATestClass := TTestValueClass.Create;
- ATestClass.ABoolean := true;
- try
- ARttiType := c.GetType(ATestClass.ClassInfo);
- Check(assigned(ARttiType));
- AProperty := ARttiType.GetProperty('aGetBoolean');
- AValue := AProperty.GetValue(ATestClass);
- CheckEquals(true,AValue.AsBoolean);
- finally
- AtestClass.Free;
- end;
- CheckEquals(True,AValue.AsBoolean);
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.TestPropGetValueProcShortString;
- var
- ATestClass : TTestValueClass;
- c: TRttiContext;
- ARttiType: TRttiType;
- AProperty: TRttiProperty;
- AValue: TValue;
- begin
- c := TRttiContext.Create;
- try
- ATestClass := TTestValueClass.Create;
- ATestClass.AShortString := 'Hello World';
- try
- ARttiType := c.GetType(ATestClass.ClassInfo);
- Check(assigned(ARttiType));
- AProperty := ARttiType.GetProperty('aGetShortString');
- AValue := AProperty.GetValue(ATestClass);
- CheckEquals('Hello World',AValue.AsString);
- finally
- AtestClass.Free;
- end;
- CheckEquals('Hello World',AValue.AsString);
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.TestPropSetValueString;
- var
- ATestClass : TTestValueClass;
- c: TRttiContext;
- ARttiType: TRttiType;
- AProperty: TRttiProperty;
- AValue: TValue;
- s: string;
- begin
- c := TRttiContext.Create;
- try
- ATestClass := TTestValueClass.Create;
- try
- ARttiType := c.GetType(ATestClass.ClassInfo);
- AProperty := ARttiType.GetProperty('astring');
- s := 'ipse lorem or something like that';
- TValue.Make(@s, TypeInfo(string), AValue);
- AProperty.SetValue(ATestClass, AValue);
- CheckEquals(ATestClass.AString, s);
- s := 'Another string';
- CheckEquals(ATestClass.AString, 'ipse lorem or something like that');
- finally
- AtestClass.Free;
- end;
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.TestPropSetValueInteger;
- var
- ATestClass : TTestValueClass;
- c: TRttiContext;
- ARttiType: TRttiType;
- AProperty: TRttiProperty;
- AValue: TValue;
- i: integer;
- begin
- c := TRttiContext.Create;
- try
- ATestClass := TTestValueClass.Create;
- try
- ARttiType := c.GetType(ATestClass.ClassInfo);
- AProperty := ARttiType.GetProperty('aInteger');
- i := -43573;
- TValue.Make(@i, TypeInfo(Integer), AValue);
- AProperty.SetValue(ATestClass, AValue);
- CheckEquals(ATestClass.AInteger, i);
- i := 1;
- CheckEquals(ATestClass.AInteger, -43573);
- finally
- AtestClass.Free;
- end;
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.TestPropSetValueBoolean;
- var
- ATestClass : TTestValueClass;
- c: TRttiContext;
- ARttiType: TRttiType;
- AProperty: TRttiProperty;
- AValue: TValue;
- b: boolean;
- begin
- c := TRttiContext.Create;
- try
- ATestClass := TTestValueClass.Create;
- try
- ARttiType := c.GetType(ATestClass.ClassInfo);
- AProperty := ARttiType.GetProperty('aboolean');
- b := true;
- TValue.Make(@b, TypeInfo(Boolean), AValue);
- AProperty.SetValue(ATestClass, AValue);
- CheckEquals(ATestClass.ABoolean, b);
- b := false;
- CheckEquals(ATestClass.ABoolean, true);
- TValue.Make(@b, TypeInfo(Boolean), AValue);
- AProperty.SetValue(ATestClass, AValue);
- CheckEquals(ATestClass.ABoolean, false);
- finally
- AtestClass.Free;
- end;
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.TestPropSetValueShortString;
- var
- ATestClass : TTestValueClass;
- c: TRttiContext;
- ARttiType: TRttiType;
- AProperty: TRttiProperty;
- AValue: TValue;
- s: string;
- ss: ShortString;
- begin
- c := TRttiContext.Create;
- try
- ATestClass := TTestValueClass.Create;
- try
- ARttiType := c.GetType(ATestClass.ClassInfo);
- AProperty := ARttiType.GetProperty('aShortString');
- s := 'ipse lorem or something like that';
- TValue.Make(@s, TypeInfo(String), AValue);
- AProperty.SetValue(ATestClass, AValue);
- CheckEquals(ATestClass.AShortString, s);
- s := 'Another string';
- CheckEquals(ATestClass.AShortString, 'ipse lorem or something like that');
- ss := 'Hello World';
- TValue.Make(@ss, TypeInfo(ShortString), AValue);
- AProperty.SetValue(ATestClass, AValue);
- CheckEquals(ATestClass.AShortString, ss);
- ss := 'Foobar';
- CheckEquals(ATestClass.AShortString, 'Hello World');
- finally
- AtestClass.Free;
- end;
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.TestPropGetValueProcInteger;
- var
- ATestClass : TTestValueClass;
- c: TRttiContext;
- ARttiType: TRttiType;
- AProperty: TRttiProperty;
- AValue: TValue;
- begin
- c := TRttiContext.Create;
- try
- ATestClass := TTestValueClass.Create;
- ATestClass.AInteger := 472349;
- try
- ARttiType := c.GetType(ATestClass.ClassInfo);
- Check(assigned(ARttiType));
- AProperty := ARttiType.GetProperty('agetinteger');
- AValue := AProperty.GetValue(ATestClass);
- CheckEquals(472349,AValue.AsInteger);
- finally
- AtestClass.Free;
- end;
- CheckEquals(472349,AValue.AsInteger);
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.TestPropGetValueProcString;
- var
- ATestClass : TTestValueClass;
- c: TRttiContext;
- ARttiType: TRttiType;
- AProperty: TRttiProperty;
- AValue: TValue;
- begin
- c := TRttiContext.Create;
- try
- ATestClass := TTestValueClass.Create;
- ATestClass.AString := 'Hello World';
- try
- ARttiType := c.GetType(ATestClass.ClassInfo);
- Check(assigned(ARttiType));
- AProperty := ARttiType.GetProperty('agetstring');
- AValue := AProperty.GetValue(ATestClass);
- CheckEquals('Hello World',AValue.AsString);
- finally
- AtestClass.Free;
- end;
- CheckEquals('Hello World',AValue.AsString);
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.TestTRttiTypeProperties;
- var
- c: TRttiContext;
- ARttiType: TRttiType;
- begin
- c := TRttiContext.Create;
- try
- ARttiType := c.GetType(TTestValueClass);
- Check(assigned(ARttiType));
- CheckEquals(ARttiType.Name,'TTestValueClass');
- Check(ARttiType.TypeKind=tkClass);
- // CheckEquals(ARttiType.IsPublicType,false);
- CheckEquals(ARttiType.TypeSize,SizeOf(TObject));
- CheckEquals(ARttiType.IsManaged,false);
- CheckEquals(ARttiType.BaseType.classname,'TRttiInstanceType');
- CheckEquals(ARttiType.IsInstance,True);
- CheckEquals(ARttiType.AsInstance.DeclaringUnitName,'tests.rtti');
- Check(ARttiType.BaseType.Name='TObject');
- Check(ARttiType.AsInstance.BaseType.Name='TObject');
- CheckEquals(ARttiType.IsOrdinal,False);
- CheckEquals(ARttiType.IsRecord,False);
- CheckEquals(ARttiType.IsSet,False);
- finally
- c.Free;
- end;
- end;
- procedure TTestCase1.GetTypeInteger;
- var
- LContext: TRttiContext;
- LType: TRttiType;
- begin
- LContext := TRttiContext.Create;
- LType := LContext.GetType(TypeInfo(integer));
- {$ifdef fpc}
- CheckEquals(LType.Name, 'LongInt');
- {$else}
- CheckEquals(LType.Name, 'Integer');
- {$endif}
- LContext.Free;
- end;
- procedure TTestCase1.GetTypePointer;
- var
- context: TRttiContext;
- t: TRttiType;
- p: TRttiPointerType absolute t;
- begin
- context := TRttiContext.Create;
- try
- t := context.GetType(TypeInfo(Pointer));
- Assert(t is TRttiPointerType, 'Type of Pointer is not a TRttiPointerType');
- Assert(not Assigned(p.ReferredType), 'ReferredType of Pointer is not Nil');
- t := context.GetType(TypeInfo(PLongInt));
- Assert(t is TRttiPointerType, 'Type of Pointer is not a TRttiPointerType');
- Assert(Assigned(p.ReferredType), 'ReferredType of PLongInt is Nil');
- Assert(p.ReferredType = context.GetType(TypeInfo(LongInt)), 'ReferredType of PLongInt is not a LongInt');
- t := context.GetType(TypeInfo(PWideChar));
- Assert(t is TRttiPointerType, 'Type of Pointer is not a TRttiPointerType');
- Assert(Assigned(p.ReferredType), 'ReferredType of PWideChar is Nil');
- Assert(p.ReferredType = context.GetType(TypeInfo(WideChar)), 'ReferredType of PWideChar is not a WideChar');
- finally
- context.Free;
- end;
- end;
- procedure TTestCase1.GetClassProperties;
- var
- LContext: TRttiContext;
- LType: TRttiType;
- PropList, PropList2: {$ifdef fpc}specialize{$endif} TArray<TRttiProperty>;
- i: LongInt;
- begin
- LContext := TRttiContext.Create;
- LType := LContext.GetType(TypeInfo(TGetClassProperties));
- PropList := LType.GetProperties;
- CheckEquals(4, length(PropList));
- CheckEquals('PubPropRO', PropList[0].Name);
- CheckEquals('PubPropRW', PropList[1].Name);
- CheckEquals('PubPropSetRO', PropList[2].Name);
- CheckEquals('PubPropSetRW', PropList[3].Name);
- LType := LContext.GetType(TypeInfo(TGetClassPropertiesSub));
- PropList2 := LType.GetProperties;
- CheckEquals(Length(PropList), Length(PropList2));
- for i := 0 to High(PropList) do
- Check(PropList[i] = PropList2[i], 'Property instances are not equal');
- LContext.Free;
- end;
- procedure TTestCase1.GetClassPropertiesValue;
- var
- AGetClassProperties: TGetClassProperties;
- LContext: TRttiContext;
- LType: TRttiType;
- AValue: TValue;
- begin
- LContext := TRttiContext.Create;
- LType := LContext.GetType(TGetClassProperties);
- AGetClassProperties := TGetClassProperties.Create;
- try
- AGetClassProperties.PubPropRW:=12345;
- AValue := LType.GetProperty('PubPropRW').GetValue(AGetClassProperties);
- CheckEquals(12345, AValue.AsInteger);
- finally
- AGetClassProperties.Free;
- end;
- LContext.Free;
- end;
- procedure TTestCase1.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 TTestCase1.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;
- procedure TTestCase1.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 TTestCase1.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 TTestCase1.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<byte>)), 'IsManaged for tkDynArray');
- {$else}
- CheckEquals(true, IsManaged(TypeInfo(TArray<byte>)), '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;
- {$ifdef fpc}
- procedure TTestCase1.TestOpenArrayToDyn;
- procedure OpenArrayProc(aArr: array of LongInt);
- var
- value: TValue;
- begin
- {$ifndef InLazIDE}
- value := specialize OpenArrayToDynArrayValue<LongInt>(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, 21);
- { since this is a copy the original array is not modified! }
- CheckEquals(aArr[0], 42);
- end;
- begin
- OpenArrayProc([42, 84]);
- end;
- {$endif}
- procedure TTestCase1.TestInterface;
- var
- context: TRttiContext;
- t: TRttiType;
- ti1, ti2: TRttiInterfaceType;
- methods: {$ifdef fpc}specialize{$endif} TArray<TRttiMethod>;
- params: {$ifdef fpc}specialize{$endif} TArray<TRttiParameter>;
- method: TRttiMethod;
- param: TRttiParameter;
- flag: TParamFlag;
- begin
- context := TRttiContext.Create;
- try
- t := context.GetType(TypeInfo(IInterface));
- Check(t is TRttiInterfaceType, 'Type is not an interface type');
- Check(not Assigned(t.BaseType), 'Base type is assigned');
- ti1 := TRttiInterfaceType(t);
- Check(not Assigned(ti1.BaseType), 'Base type is assigned');
- methods := t.GetMethods;
- CheckEquals(0, Length(methods), 'Overall method count does not match');
- methods := t.GetDeclaredMethods;
- CheckEquals(0, Length(methods), 'Declared method conut does not match');
- t := context.GetType(TypeInfo(ITestInterface));
- Check(t is TRttiInterfaceType, 'Type is not an interface type');
- Check(Assigned(t.BaseType), 'Base type is not assigned');
- Check(t.BaseType = TRttiType(ti1), 'Base type does not match');
- ti2 := TRttiInterfaceType(t);
- Check(Assigned(ti2.BaseType), 'Base type is not assigned');
- Check(ti2.BaseType = ti1, 'Base type does not match');
- methods := t.GetMethods;
- CheckEquals(4, Length(methods), 'Overall method count does not match');
- methods := t.GetDeclaredMethods;
- CheckEquals(4, Length(methods), 'Declared method count does not match');
- method := methods[0];
- CheckEquals(method.Name, 'Test', 'Method name of Test does not match');
- Check(method.CallingConvention = ccReg, 'Calling convention of Test does not match');
- Check(method.MethodKind = mkProcedure, 'Method kind of Test does not match');
- Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test does not match');
- Check(not Assigned(method.CodeAddress), 'Code address of Test is not Nil');
- CheckEquals(method.VirtualIndex, 3, 'Virtual index of Test does not match');
- Check(not Assigned(method.ReturnType), 'Return type of Test is not Nil');
- params := method.GetParameters;
- CheckEquals(0, Length(params), 'Parameter count of Test does not match');
- method := methods[1];
- CheckEquals(method.Name, 'Test2', 'Method name of Test2 does not match');
- Check(method.CallingConvention = ccReg, 'Calling convention of Test2 does not match');
- Check(method.MethodKind = mkFunction, 'Method kind of Test2 does not match');
- Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test2 does not match');
- Check(not Assigned(method.CodeAddress), 'Code address of Test2 is not Nil');
- CheckEquals(method.VirtualIndex, 4, 'Virtual index of Test2 does not match');
- Check(Assigned(method.ReturnType), 'Return type of Test2 is Nil');
- Check(method.ReturnType.TypeKind = tkInteger, 'Return type of Test2 is not an ordinal');
- params := method.GetParameters;
- CheckEquals(0, Length(params), 'Parameter count of Test2 does not match');
- method := methods[2];
- CheckEquals(method.Name, 'Test3', 'Method name of Test3 does not match');
- Check(method.CallingConvention = ccReg, 'Calling convention of Test3 does not match');
- Check(method.MethodKind = mkProcedure, 'Method kind of Test3 does not match');
- Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test3 does not match');
- Check(not Assigned(method.CodeAddress), 'Code address of Test3 is not Nil');
- CheckEquals(method.VirtualIndex, 5, 'Virtual index of Test3 does not match');
- Check(not Assigned(method.ReturnType), 'Return type of Test3 is not Nil');
- params := method.GetParameters;
- CheckEquals(4, Length(params), 'Parameter count of Test3 does not match');
- param := params[0];
- CheckEquals(param.Name, 'aArg1', 'Parameter name of Test3.aArg1 does not match');
- Check(param.Flags = [], 'Parameter flags of Test3.aArg1 do not match');
- Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg1 is Nil');
- Check(param.ParamType.TypeKind = tkInteger, 'Parameter type of Test3.aArg1 is not an ordinal');
- param := params[1];
- CheckEquals(param.Name, 'aArg2', 'Parameter name of Test3.aArg2 does not match');
- Check(param.Flags = [pfConst], 'Parameter flags of Test3.aArg2 do not match');
- Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg2 is Nil');
- Check(param.ParamType.TypeKind = tkAnsiString, 'Parameter type of Test3.aArg2 is not a string');
- param := params[2];
- CheckEquals(param.Name, 'aArg3', 'Parameter name of Test3.aArg3 does not match');
- Check(param.Flags = [pfVar], 'Parameter flags of Test3.aArg3 do not match');
- Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg3 is Nil');
- Check(param.ParamType.TypeKind = {$ifdef fpc}tkBool{$else}tkEnumeration{$endif}, 'Parameter type of Test3.aArg3 is not a boolean');
- param := params[3];
- CheckEquals(param.Name, 'aArg4', 'Parameter name of Test3.aArg4 does not match');
- Check(param.Flags = [pfOut], 'Parameter flags of Test3.aArg4 do not match');
- Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg4 is Nil');
- Check(param.ParamType.TypeKind = tkInteger, 'Parameter type of Test3.aArg4 is not a string');
- method := methods[3];
- CheckEquals(method.Name, 'Test4', 'Method name of Test4 does not match');
- Check(method.CallingConvention = ccReg, 'Calling convention of Test4 does not match');
- Check(method.MethodKind = mkFunction, 'Method kind of Test4 does not match');
- Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test4 does not match');
- Check(not Assigned(method.CodeAddress), 'Code address of Test4 is not Nil');
- CheckEquals(method.VirtualIndex, 6, 'Virtual index of Test4 does not match');
- Check(Assigned(method.ReturnType), 'Return type of Test4 is not Nil');
- Check(method.ReturnType.TypeKind = tkAnsiString, 'Return type of Test4 is not a string');
- params := method.GetParameters;
- CheckEquals(2, Length(params), 'Parameter count of Test4 does not match');
- param := params[0];
- CheckEquals(param.Name, 'aArg1', 'Parameter name of Test4.aArg1 does not match');
- Check(param.Flags = [pfArray, pfReference], 'Parameter flags of Test4.aArg1 do not match');
- Check(Assigned(param.ParamType), 'Parameter type of Test4.aArg1 is Nil');
- Check(param.ParamType.TypeKind = tkInteger, 'Parameter type of Test4.aArg1 is not an ordinal');
- param := params[1];
- CheckEquals(param.Name, 'aArg2', 'Parameter name of Test4.aArg2 does not match');
- Check(param.Flags = [pfArray, pfReference], 'Parameter flags of Test4.aArg2 do not match');
- Check(Assigned(param.ParamType), 'Parameter type of Test4.aArg2 is Nil');
- Check(param.ParamType.TypeKind = tkRecord, 'Parameter type of Test4.aArg2 is not a record');
- finally
- context.Free;
- end;
- end;
- procedure TTestCase1.TestRawThunk;
- var
- intf: IInterface;
- begin
- { we test the raw thunking by instantiating a TVirtualInterface of IInterface }
- { this does not require a function call manager as the thunking is implemented
- directly inside the RTTI unit }
- try
- intf := TVirtualInterface.Create(PTypeInfo(TypeInfo(IInterface))) as IInterface;
- except
- on e: ENotImplemented do
- Ignore('RawThunk not implemented');
- end;
- { if all went well QueryInterface and _AddRef were called and now we call
- _Release as well }
- intf := Nil;
- end;
- {$ifdef fpc}
- procedure TTestCase1.TestInterfaceRaw;
- var
- context: TRttiContext;
- t: TRttiType;
- ti: TRttiInterfaceType;
- begin
- context := TRttiContext.Create;
- try
- t := context.GetType(TypeInfo(ICORBATest));
- Check(t is TRttiInterfaceType, 'Type is not a raw interface type');
- Check(not Assigned(t.BaseType), 'Base type is assigned');
- ti := TRttiInterfaceType(t);
- Check(not Assigned(ti.BaseType), 'Base type is assigned');
- finally
- context.Free;
- end;
- end;
- {$endif}
- procedure TTestCase1.TestProcVar;
- var
- context: TRttiContext;
- t: TRttiType;
- p: TRttiProcedureType;
- params: {$ifdef fpc}specialize{$endif} TArray<TRttiParameter>;
- begin
- context := TRttiContext.Create;
- try
- t := context.GetType(PTypeInfo(TypeInfo(TTestProc)));
- Check(Assigned(t), 'Rtti Type is Nil');
- Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
- Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
- p := t as TRttiProcedureType;
- Check(p.CallingConvention = ccReg, 'Calling convention does not match');
- Check(not Assigned(p.ReturnType), 'Return type is assigned');
- CheckEquals(0, Length(p.GetParameters), 'Procedure variable has parameters');
- t := context.GetType(PTypeInfo(TypeInfo(TTestFunc1)));
- Check(Assigned(t), 'Rtti Type is Nil');
- Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
- Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
- p := t as TRttiProcedureType;
- Check(p.CallingConvention = ccReg, 'Calling convention does not match');
- Check(Assigned(p.ReturnType), 'Return type is not assigned');
- //Check(p.ReturnType is TRttiOrdinalType, 'Return type is not an ordinal type');
- CheckEquals(0, Length(p.GetParameters), 'Procedure variable has parameters');
- t := context.GetType(PTypeInfo(TypeInfo(TTestFunc2)));
- Check(Assigned(t), 'Rtti Type is Nil');
- Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
- Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
- p := t as TRttiProcedureType;
- Check(p.CallingConvention = ccReg, 'Calling convention does not match');
- Check(Assigned(p.ReturnType), 'Return type is not assigned');
- Check(p.ReturnType is TRttiStringType, 'Return type is not a string type');
- params := p.GetParameters;
- CheckEquals(2, Length(params), 'Procedure variable has incorrect amount of parameters');
- Check(params[0].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 1 is not an ordinal type');
- //Check(params[0].ParamType is TRttiOrdinalType, 'Parameter 1 is not an ordinal type');
- Check(pfArray in params[1].Flags, 'Parameter 2 is not an array');
- Check(params[1].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 2 is not an ordinal array');
- finally
- context.Free;
- end;
- end;
- procedure TTestCase1.TestMethod;
- var
- context: TRttiContext;
- t: TRttiType;
- m: TRttiMethodType;
- params: {$ifdef fpc}specialize{$endif} TArray<TRttiParameter>;
- begin
- context := TRttiContext.Create;
- try
- t := context.GetType(PTypeInfo(TypeInfo(TTestMethod)));
- Check(Assigned(t), 'Rtti Type is Nil');
- Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
- Check(t is TRttiMethodType, 'Rtti Type is not a method type');
- m := t as TRttiMethodType;
- Check(m.CallingConvention = ccReg, 'Calling convention does not match');
- Check(not Assigned(m.ReturnType), 'Return type is assigned');
- CheckEquals(0, Length(m.GetParameters), 'Method variable has parameters');
- t := context.GetType(PTypeInfo(TypeInfo(TTestMethod1)));
- Check(Assigned(t), 'Rtti Type is Nil');
- Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
- Check(t is TRttiMethodType, 'Rtti Type is not a method type');
- m := t as TRttiMethodType;
- Check(m.CallingConvention = ccReg, 'Calling convention does not match');
- Check(Assigned(m.ReturnType), 'Return type is not assigned');
- //Check(p.ReturnType is TRttiOrdinalType, 'Return type is not an ordinal type');
- CheckEquals(0, Length(m.GetParameters), 'Method variable has parameters');
- t := context.GetType(PTypeInfo(TypeInfo(TTestMethod2)));
- Check(Assigned(t), 'Rtti Type is Nil');
- Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
- Check(t is TRttiMethodType, 'Rtti Type is not a method type');
- m := t as TRttiMethodType;
- Check(m.CallingConvention = ccReg, 'Calling convention does not match');
- Check(Assigned(m.ReturnType), 'Return type is not assigned');
- Check(m.ReturnType is TRttiStringType, 'Return type is not a string type');
- params := m.GetParameters;
- CheckEquals(2, Length(params), 'Method variable has incorrect amount of parameters');
- Check(params[0].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 1 is not an ordinal type');
- //Check(params[0].ParamType is TRttiOrdinalType, 'Parameter 1 is not an ordinal type');
- Check(pfArray in params[1].Flags, 'Parameter 2 is not an array');
- Check(params[1].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 2 is not an ordinal array');
- finally
- context.Free;
- end;
- end;
- initialization
- {$ifdef fpc}
- RegisterTest(TTestCase1);
- {$else fpc}
- RegisterTest(TTestCase1.Suite);
- {$endif fpc}
- end.
|