tests.rtti.pas 63 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028
  1. unit tests.rtti;
  2. {$ifdef fpc}
  3. {$mode objfpc}{$H+}
  4. {$modeswitch advancedrecords}
  5. {$endif}
  6. interface
  7. uses
  8. {$IFDEF FPC}
  9. fpcunit,testregistry, testutils,
  10. {$ELSE FPC}
  11. TestFramework,
  12. {$ENDIF FPC}
  13. Classes, SysUtils, typinfo,
  14. Rtti;
  15. type
  16. { TTestCase1 }
  17. TTestCase1= class(TTestCase)
  18. published
  19. //procedure GetTypes;
  20. procedure GetTypeInteger;
  21. procedure GetTypePointer;
  22. procedure GetClassProperties;
  23. procedure GetClassPropertiesValue;
  24. procedure TestTRttiTypeProperties;
  25. procedure TestPropGetValueString;
  26. procedure TestPropGetValueInteger;
  27. procedure TestPropGetValueBoolean;
  28. procedure TestPropGetValueShortString;
  29. procedure TestPropGetValueProcString;
  30. procedure TestPropGetValueProcInteger;
  31. procedure TestPropGetValueProcBoolean;
  32. procedure TestPropGetValueProcShortString;
  33. procedure TestPropSetValueString;
  34. procedure TestPropSetValueInteger;
  35. procedure TestPropSetValueBoolean;
  36. procedure TestPropSetValueShortString;
  37. procedure TestGetValueStringCastError;
  38. procedure TestGetIsReadable;
  39. procedure TestIsWritable;
  40. procedure TestMakeNil;
  41. procedure TestMakeObject;
  42. procedure TestMakeArrayDynamic;
  43. procedure TestMakeArrayStatic;
  44. {$ifdef fpc}
  45. procedure TestMakeArrayOpen;
  46. {$endif}
  47. procedure TestMakeSingle;
  48. procedure TestMakeDouble;
  49. procedure TestMakeExtended;
  50. procedure TestMakeCurrency;
  51. procedure TestMakeComp;
  52. procedure TestMakeEnum;
  53. procedure TestMakeAnsiChar;
  54. procedure TestMakeWideChar;
  55. procedure TestFromOrdinal;
  56. procedure TestDataSize;
  57. procedure TestDataSizeEmpty;
  58. procedure TestReferenceRawData;
  59. procedure TestReferenceRawDataEmpty;
  60. procedure TestIsManaged;
  61. {$ifdef fpc}
  62. procedure TestOpenArrayToDyn;
  63. {$endif}
  64. procedure TestInterface;
  65. {$ifdef fpc}
  66. procedure TestInterfaceRaw;
  67. {$endif}
  68. procedure TestProcVar;
  69. procedure TestMethod;
  70. procedure TestRawThunk;
  71. private
  72. procedure MakeFromOrdinalTObject;
  73. procedure MakeFromOrdinalSet;
  74. procedure MakeFromOrdinalString;
  75. procedure MakeFromOrdinalNil;
  76. end;
  77. implementation
  78. type
  79. {$M+}
  80. TGetClassProperties = class
  81. private
  82. FPubPropRO: integer;
  83. FPubPropRW: integer;
  84. published
  85. property PubPropRO: integer read FPubPropRO;
  86. property PubPropRW: integer read FPubPropRW write FPubPropRW;
  87. property PubPropSetRO: integer read FPubPropRO;
  88. property PubPropSetRW: integer read FPubPropRW write FPubPropRW;
  89. end;
  90. TGetClassPropertiesSub = class(TGetClassProperties)
  91. end;
  92. {$M-}
  93. { TTestValueClass }
  94. {$M+}
  95. TTestValueClass = class
  96. private
  97. FAInteger: integer;
  98. FAString: string;
  99. FABoolean: boolean;
  100. FAShortString: ShortString;
  101. function GetAInteger: integer;
  102. function GetAString: string;
  103. function GetABoolean: boolean;
  104. function GetAShortString: ShortString;
  105. procedure SetWriteOnly(AValue: integer);
  106. published
  107. property AInteger: Integer read FAInteger write FAInteger;
  108. property AString: string read FAString write FAString;
  109. property ABoolean: boolean read FABoolean write FABoolean;
  110. property AShortString: ShortString read FAShortString write FAShortString;
  111. property AGetInteger: Integer read GetAInteger;
  112. property AGetString: string read GetAString;
  113. property AGetBoolean: boolean read GetABoolean;
  114. property AGetShortString: ShortString read GetAShortString;
  115. property AWriteOnly: integer write SetWriteOnly;
  116. end;
  117. {$M-}
  118. {$M+}
  119. ITestInterface = interface
  120. procedure Test;
  121. function Test2: LongInt;
  122. procedure Test3(aArg1: LongInt; const aArg2: AnsiString; var aArg3: Boolean; out aArg4: Word);
  123. function Test4(aArg1: array of LongInt; aArg2: array of const): AnsiString;
  124. end;
  125. {$M-}
  126. TManagedRec = record
  127. s: string;
  128. end;
  129. {$ifdef fpc}
  130. TManagedRecOp = record
  131. class operator AddRef(var a: TManagedRecOp);
  132. end;
  133. {$endif}
  134. TNonManagedRec = record
  135. i: Integer;
  136. end;
  137. TManagedObj = object
  138. i: IInterface;
  139. end;
  140. TNonManagedObj = object
  141. d: double;
  142. end;
  143. TTestEnum = (te1, te2, te3, te4, te5);
  144. TTestSet = set of TTestEnum;
  145. TTestProc = procedure;
  146. TTestFunc1 = function: LongInt;
  147. TTestFunc2 = function(aArg1: LongInt; aArg2: array of LongInt): String;
  148. TTestMethod = procedure of object;
  149. TTestMethod1 = function: LongInt of object;
  150. TTestMethod2 = function(aArg1: LongInt; aArg2: array of LongInt): String of object;
  151. TTestHelper = class helper for TObject
  152. end;
  153. TArrayOfString = array[0..0] of string;
  154. TArrayOfManagedRec = array[0..0] of TManagedRec;
  155. TArrayOfNonManagedRec = array[0..0] of TNonManagedRec;
  156. TArrayOfByte = array[0..0] of byte;
  157. TArrayOfLongintDyn = array of LongInt;
  158. TArrayOfLongintStatic = array[0..3] of LongInt;
  159. TTestRecord = record
  160. Value1: LongInt;
  161. Value2: String;
  162. end;
  163. PTestRecord = ^TTestRecord;
  164. {$ifdef fpc}
  165. {$PUSH}
  166. {$INTERFACES CORBA}
  167. ICORBATest = interface
  168. end;
  169. {$POP}
  170. {$endif}
  171. {$ifdef fpc}
  172. class operator TManagedRecOp.AddRef(var a: TManagedRecOp);
  173. begin
  174. end;
  175. {$endif}
  176. { TTestValueClass }
  177. function TTestValueClass.GetAInteger: integer;
  178. begin
  179. result := FAInteger;
  180. end;
  181. function TTestValueClass.GetAString: string;
  182. begin
  183. result := FAString;
  184. end;
  185. function TTestValueClass.GetABoolean: boolean;
  186. begin
  187. result := FABoolean;
  188. end;
  189. function TTestValueClass.GetAShortString: ShortString;
  190. begin
  191. Result := FAShortString;
  192. end;
  193. procedure TTestValueClass.SetWriteOnly(AValue: integer);
  194. begin
  195. // Do nothing
  196. end;
  197. { Note: GetTypes currently only returns those types that had been acquired using
  198. GetType, so GetTypes itself can't be really tested currently }
  199. (*procedure TTestCase1.GetTypes;
  200. var
  201. LContext: TRttiContext;
  202. LType: TRttiType;
  203. IsTestCaseClassFound: boolean;
  204. begin
  205. LContext := TRttiContext.Create;
  206. { Enumerate all types declared in the application }
  207. for LType in LContext.GetTypes() do
  208. begin
  209. if LType.Name='TTestCase1' then
  210. IsTestCaseClassFound:=true;
  211. end;
  212. LContext.Free;
  213. CheckTrue(IsTestCaseClassFound, 'RTTI information does not contain class of testcase.');
  214. end;*)
  215. procedure TTestCase1.TestGetValueStringCastError;
  216. var
  217. ATestClass : TTestValueClass;
  218. c: TRttiContext;
  219. ARttiType: TRttiType;
  220. AValue: TValue;
  221. i: integer;
  222. HadException: boolean;
  223. begin
  224. c := TRttiContext.Create;
  225. try
  226. ATestClass := TTestValueClass.Create;
  227. ATestClass.AString := '12';
  228. try
  229. ARttiType := c.GetType(ATestClass.ClassInfo);
  230. AValue := ARttiType.GetProperty('astring').GetValue(ATestClass);
  231. HadException := false;
  232. try
  233. i := AValue.AsInteger;
  234. except
  235. on E: Exception do
  236. if E.ClassType=EInvalidCast then
  237. HadException := true;
  238. end;
  239. Check(HadException, 'No or invalid exception on invalid cast');
  240. finally
  241. AtestClass.Free;
  242. end;
  243. finally
  244. c.Free;
  245. end;
  246. end;
  247. procedure TTestCase1.TestMakeNil;
  248. var
  249. value: TValue;
  250. begin
  251. TValue.Make(Nil, Nil, value);
  252. CheckTrue(value.Kind = tkUnknown);
  253. CheckTrue(value.IsEmpty);
  254. CheckTrue(value.IsObject);
  255. CheckTrue(value.IsClass);
  256. CheckTrue(value.IsOrdinal);
  257. CheckFalse(value.IsArray);
  258. CheckTrue(value.AsObject = Nil);
  259. CheckTrue(value.AsClass = Nil);
  260. CheckTrue(value.AsInterface = Nil);
  261. CheckEquals(0, value.AsOrdinal);
  262. TValue.Make(Nil, TypeInfo(TObject), value);
  263. CheckTrue(value.IsEmpty);
  264. CheckTrue(value.IsObject);
  265. CheckTrue(value.IsClass);
  266. CheckTrue(value.IsOrdinal);
  267. CheckFalse(value.IsArray);
  268. CheckTrue(value.AsObject=Nil);
  269. CheckTrue(value.AsClass=Nil);
  270. CheckTrue(value.AsInterface=Nil);
  271. CheckEquals(0, value.AsOrdinal);
  272. TValue.Make(Nil, TypeInfo(TClass), value);
  273. CheckTrue(value.IsEmpty);
  274. CheckTrue(value.IsClass);
  275. CheckTrue(value.IsOrdinal);
  276. CheckFalse(value.IsArray);
  277. CheckTrue(value.AsObject=Nil);
  278. CheckTrue(value.AsClass=Nil);
  279. CheckTrue(value.AsInterface=Nil);
  280. CheckEquals(0, value.AsOrdinal);
  281. TValue.Make(Nil, TypeInfo(LongInt), value);
  282. CheckTrue(value.IsOrdinal);
  283. CheckFalse(value.IsEmpty);
  284. CheckFalse(value.IsClass);
  285. CheckFalse(value.IsObject);
  286. CheckFalse(value.IsArray);
  287. CheckEquals(0, value.AsOrdinal);
  288. CheckEquals(0, value.AsInteger);
  289. CheckEquals(0, value.AsInt64);
  290. CheckEquals(0, value.AsUInt64);
  291. TValue.Make(Nil, TypeInfo(String), value);
  292. CheckFalse(value.IsEmpty);
  293. CheckFalse(value.IsObject);
  294. CheckFalse(value.IsClass);
  295. CheckFalse(value.IsArray);
  296. CheckEquals('', value.AsString);
  297. end;
  298. procedure TTestCase1.TestMakeObject;
  299. var
  300. AValue: TValue;
  301. ATestClass: TTestValueClass;
  302. begin
  303. ATestClass := TTestValueClass.Create;
  304. ATestClass.AInteger := 54329;
  305. TValue.Make(@ATestClass, TypeInfo(TTestValueClass),AValue);
  306. CheckEquals(AValue.IsClass, False);
  307. CheckEquals(AValue.IsObject, True);
  308. Check(AValue.AsObject=ATestClass);
  309. Check(PPointer(AValue.GetReferenceToRawData)^ = Pointer(ATestClass));
  310. CheckEquals(TTestValueClass(AValue.AsObject).AInteger, 54329);
  311. ATestClass.Free;
  312. end;
  313. procedure TTestCase1.TestMakeArrayDynamic;
  314. var
  315. arr: TArrayOfLongintDyn;
  316. value: TValue;
  317. begin
  318. SetLength(arr, 2);
  319. arr[0] := 42;
  320. arr[1] := 21;
  321. TValue.Make(@arr, TypeInfo(TArrayOfLongintDyn), value);
  322. CheckEquals(value.IsArray, True);
  323. CheckEquals(value.IsObject, False);
  324. CheckEquals(value.IsOrdinal, False);
  325. CheckEquals(value.IsClass, False);
  326. CheckEquals(value.GetArrayLength, 2);
  327. CheckEquals(value.GetArrayElement(0).AsInteger, 42);
  328. CheckEquals(value.GetArrayElement(1).AsInteger, 21);
  329. Check(PPointer(value.GetReferenceToRawData)^ = Pointer(arr));
  330. value.SetArrayElement(0, 84);
  331. CheckEquals(arr[0], 84);
  332. end;
  333. procedure TTestCase1.TestMakeArrayStatic;
  334. type
  335. TArrStat = array[0..1] of LongInt;
  336. TArrStat2D = array[0..1, 0..1] of LongInt;
  337. var
  338. arr: TArrStat;
  339. arr2D: TArrStat2D;
  340. value: TValue;
  341. begin
  342. arr[0] := 42;
  343. arr[1] := 21;
  344. TValue.Make(@arr, TypeInfo(TArrStat), value);
  345. CheckEquals(value.IsArray, True);
  346. CheckEquals(value.IsObject, False);
  347. CheckEquals(value.IsOrdinal, False);
  348. CheckEquals(value.IsClass, False);
  349. CheckEquals(value.GetArrayLength, 2);
  350. CheckEquals(value.GetArrayElement(0).AsInteger, 42);
  351. CheckEquals(value.GetArrayElement(1).AsInteger, 21);
  352. value.SetArrayElement(0, 84);
  353. { since this is a static array the original array isn't touched! }
  354. CheckEquals(arr[0], 42);
  355. arr2D[0, 0] := 42;
  356. arr2D[0, 1] := 21;
  357. arr2D[1, 0] := 84;
  358. arr2D[1, 1] := 63;
  359. TValue.Make(@arr2D, TypeInfo(TArrStat2D), value);
  360. CheckEquals(value.IsArray, True);
  361. CheckEquals(value.GetArrayLength, 4);
  362. CheckEquals(value.GetArrayElement(0).AsInteger, 42);
  363. CheckEquals(value.GetArrayElement(1).AsInteger, 21);
  364. CheckEquals(value.GetArrayElement(2).AsInteger, 84);
  365. CheckEquals(value.GetArrayElement(3).AsInteger, 63);
  366. end;
  367. {$ifdef fpc}
  368. procedure TTestCase1.TestMakeArrayOpen;
  369. procedure TestOpenArrayValueCopy(aArr: array of LongInt);
  370. var
  371. value: TValue;
  372. begin
  373. TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value);
  374. CheckEquals(value.IsArray, True);
  375. CheckEquals(value.IsOpenArray, True);
  376. CheckEquals(value.IsObject, False);
  377. CheckEquals(value.IsOrdinal, False);
  378. CheckEquals(value.IsClass, False);
  379. CheckEquals(value.GetArrayLength, 2);
  380. CheckEquals(value.GetArrayElement(0).AsInteger, 42);
  381. CheckEquals(value.GetArrayElement(1).AsInteger, 21);
  382. value.SetArrayElement(0, 84);
  383. { since this is an open array the original array is modified! }
  384. CheckEquals(aArr[0], 84);
  385. end;
  386. procedure TestOpenArrayValueVar(var aArr: array of LongInt);
  387. var
  388. value: TValue;
  389. begin
  390. TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value);
  391. CheckEquals(value.IsArray, True);
  392. CheckEquals(value.IsOpenArray, True);
  393. CheckEquals(value.IsObject, False);
  394. CheckEquals(value.IsOrdinal, False);
  395. CheckEquals(value.IsClass, False);
  396. CheckEquals(value.GetArrayLength, 2);
  397. CheckEquals(value.GetArrayElement(0).AsInteger, 42);
  398. CheckEquals(value.GetArrayElement(1).AsInteger, 21);
  399. value.SetArrayElement(0, 84);
  400. { since this is an open array the original array is modified! }
  401. CheckEquals(aArr[0], 84);
  402. end;
  403. procedure TestOpenArrayValueOut(var aArr: array of LongInt);
  404. var
  405. value: TValue;
  406. begin
  407. TValue.MakeOpenArray(@aArr[0], Length(aArr), PTypeInfo(TypeInfo(aArr)), value);
  408. CheckEquals(value.IsArray, True);
  409. CheckEquals(value.IsOpenArray, True);
  410. CheckEquals(value.IsObject, False);
  411. CheckEquals(value.IsOrdinal, False);
  412. CheckEquals(value.IsClass, False);
  413. CheckEquals(value.GetArrayLength, 2);
  414. CheckEquals(value.GetArrayElement(0).AsInteger, 42);
  415. CheckEquals(value.GetArrayElement(1).AsInteger, 21);
  416. value.SetArrayElement(0, 84);
  417. value.SetArrayElement(1, 128);
  418. { since this is an open array the original array is modified! }
  419. CheckEquals(aArr[0], 84);
  420. CheckEquals(aArr[1], 128);
  421. CheckEquals(value.GetArrayElement(0).AsInteger, 84);
  422. CheckEquals(value.GetArrayElement(1).AsInteger, 128);
  423. end;
  424. var
  425. arr: array of LongInt;
  426. begin
  427. TestOpenArrayValueCopy([42, 21]);
  428. arr := [42, 21];
  429. TestOpenArrayValueVar(arr);
  430. CheckEquals(arr[0], 84);
  431. CheckEquals(arr[1], 21);
  432. arr := [42, 21];
  433. TestOpenArrayValueOut(arr);
  434. CheckEquals(arr[0], 84);
  435. CheckEquals(arr[1], 128);
  436. end;
  437. {$endif}
  438. procedure TTestCase1.TestMakeSingle;
  439. var
  440. fs: Single;
  441. v: TValue;
  442. hadexcept: Boolean;
  443. begin
  444. fs := 3.14;
  445. TValue.Make(@fs, TypeInfo(fs), v);
  446. CheckEquals(v.IsClass, False);
  447. CheckEquals(v.IsObject, False);
  448. CheckEquals(v.IsOrdinal, False);
  449. Check(v.AsExtended=fs);
  450. Check(v.GetReferenceToRawData <> @fs);
  451. try
  452. hadexcept := False;
  453. v.AsInt64;
  454. except
  455. hadexcept := True;
  456. end;
  457. CheckTrue(hadexcept, 'No signed type conversion exception');
  458. try
  459. hadexcept := False;
  460. v.AsUInt64;
  461. except
  462. hadexcept := True;
  463. end;
  464. CheckTrue(hadexcept, 'No unsigned type conversion exception');
  465. end;
  466. procedure TTestCase1.TestMakeDouble;
  467. var
  468. fd: Double;
  469. v: TValue;
  470. hadexcept: Boolean;
  471. begin
  472. fd := 3.14;
  473. TValue.Make(@fd, TypeInfo(fd), v);
  474. CheckEquals(v.IsClass, False);
  475. CheckEquals(v.IsObject, False);
  476. CheckEquals(v.IsOrdinal, False);
  477. Check(v.AsExtended=fd);
  478. Check(v.GetReferenceToRawData <> @fd);
  479. try
  480. hadexcept := False;
  481. v.AsInt64;
  482. except
  483. hadexcept := True;
  484. end;
  485. CheckTrue(hadexcept, 'No signed type conversion exception');
  486. try
  487. hadexcept := False;
  488. v.AsUInt64;
  489. except
  490. hadexcept := True;
  491. end;
  492. CheckTrue(hadexcept, 'No unsigned type conversion exception');
  493. end;
  494. procedure TTestCase1.TestMakeExtended;
  495. var
  496. fe: Extended;
  497. v: TValue;
  498. hadexcept: Boolean;
  499. begin
  500. fe := 3.14;
  501. TValue.Make(@fe, TypeInfo(fe), v);
  502. CheckEquals(v.IsClass, False);
  503. CheckEquals(v.IsObject, False);
  504. CheckEquals(v.IsOrdinal, False);
  505. Check(v.AsExtended=fe);
  506. Check(v.GetReferenceToRawData <> @fe);
  507. try
  508. hadexcept := False;
  509. v.AsInt64;
  510. except
  511. hadexcept := True;
  512. end;
  513. CheckTrue(hadexcept, 'No signed type conversion exception');
  514. try
  515. hadexcept := False;
  516. v.AsUInt64;
  517. except
  518. hadexcept := True;
  519. end;
  520. CheckTrue(hadexcept, 'No unsigned type conversion exception');
  521. end;
  522. procedure TTestCase1.TestMakeCurrency;
  523. var
  524. fcu: Currency;
  525. v: TValue;
  526. hadexcept: Boolean;
  527. begin
  528. fcu := 3.14;
  529. TValue.Make(@fcu, TypeInfo(fcu), v);
  530. CheckEquals(v.IsClass, False);
  531. CheckEquals(v.IsObject, False);
  532. CheckEquals(v.IsOrdinal, False);
  533. Check(v.AsExtended=Extended(fcu));
  534. Check(v.AsCurrency=fcu);
  535. Check(v.GetReferenceToRawData <> @fcu);
  536. try
  537. hadexcept := False;
  538. v.AsInt64;
  539. except
  540. hadexcept := True;
  541. end;
  542. CheckTrue(hadexcept, 'No signed type conversion exception');
  543. try
  544. hadexcept := False;
  545. v.AsUInt64;
  546. except
  547. hadexcept := True;
  548. end;
  549. CheckTrue(hadexcept, 'No unsigned type conversion exception');
  550. end;
  551. procedure TTestCase1.TestMakeComp;
  552. var
  553. fco: Comp;
  554. v: TValue;
  555. hadexcept: Boolean;
  556. begin
  557. fco := 314;
  558. TValue.Make(@fco, TypeInfo(fco), v);
  559. if v.Kind <> tkFloat then
  560. Exit;
  561. CheckEquals(v.IsClass, False);
  562. CheckEquals(v.IsObject, False);
  563. CheckEquals(v.IsOrdinal, False);
  564. Check(v.AsExtended=Extended(fco));
  565. Check(v.GetReferenceToRawData <> @fco);
  566. try
  567. hadexcept := False;
  568. CheckEquals(v.AsInt64, 314);
  569. except
  570. hadexcept := True;
  571. end;
  572. CheckFalse(hadexcept, 'Had signed type conversion exception');
  573. try
  574. hadexcept := False;
  575. CheckEquals(v.AsUInt64, 314);
  576. except
  577. hadexcept := True;
  578. end;
  579. CheckFalse(hadexcept, 'Had unsigned type conversion exception');
  580. end;
  581. procedure TTestCase1.TestMakeEnum;
  582. var
  583. e: TTestEnum;
  584. v: TValue;
  585. begin
  586. e := te1;
  587. TValue.Make(@e, TypeInfo(e), v);
  588. Check(not v.IsClass);
  589. Check(not v.IsArray);
  590. Check(not v.IsEmpty);
  591. Check(not v.IsOpenArray);
  592. Check(not v.IsObject);
  593. Check(v.IsOrdinal);
  594. Check(v.GetReferenceToRawData <> @e);
  595. Check(TTestEnum(v.AsOrdinal) = te1);
  596. end;
  597. procedure TTestCase1.TestMakeAnsiChar;
  598. var
  599. c: AnsiChar;
  600. v: TValue;
  601. begin
  602. c := #20;
  603. TValue.Make(@c, TypeInfo(c), v);
  604. Check(not v.IsClass);
  605. Check(not v.IsArray);
  606. Check(not v.IsEmpty);
  607. Check(not v.IsOpenArray);
  608. Check(not v.IsObject);
  609. Check(v.IsOrdinal);
  610. Check(v.GetReferenceToRawData <> @c);
  611. Check(AnsiChar(v.AsOrdinal) = #20);
  612. end;
  613. procedure TTestCase1.TestMakeWideChar;
  614. var
  615. c: WideChar;
  616. v: TValue;
  617. begin
  618. c := #$1234;
  619. TValue.Make(@c, TypeInfo(c), v);
  620. Check(not v.IsClass);
  621. Check(not v.IsArray);
  622. Check(not v.IsEmpty);
  623. Check(not v.IsOpenArray);
  624. Check(not v.IsObject);
  625. Check(v.IsOrdinal);
  626. Check(v.GetReferenceToRawData <> @c);
  627. Check(WideChar(v.AsOrdinal) = #$1234);
  628. end;
  629. procedure TTestCase1.MakeFromOrdinalTObject;
  630. begin
  631. TValue.FromOrdinal(TypeInfo(TObject), 42);
  632. end;
  633. procedure TTestCase1.MakeFromOrdinalSet;
  634. begin
  635. TValue.FromOrdinal(TypeInfo(TTestSet), 42);
  636. end;
  637. procedure TTestCase1.MakeFromOrdinalString;
  638. begin
  639. TValue.FromOrdinal(TypeInfo(AnsiString), 42);
  640. end;
  641. procedure TTestCase1.MakeFromOrdinalNil;
  642. begin
  643. TValue.FromOrdinal(Nil, 42);
  644. end;
  645. procedure TTestCase1.TestFromOrdinal;
  646. var
  647. v: TValue;
  648. begin
  649. v := TValue.FromOrdinal(TypeInfo(LongInt), 42);
  650. Check(v.IsOrdinal);
  651. CheckEquals(v.AsOrdinal, 42);
  652. v := TValue.FromOrdinal(TypeInfo(Boolean), Ord(True));
  653. Check(v.IsOrdinal);
  654. CheckEquals(v.AsOrdinal, Ord(True));
  655. v := TValue.FromOrdinal(TypeInfo(Int64), $1234123412341234);
  656. Check(v.IsOrdinal);
  657. CheckEquals(v.AsOrdinal, $1234123412341234);
  658. v := TValue.FromOrdinal(TypeInfo(QWord), $1234123412341234);
  659. Check(v.IsOrdinal);
  660. CheckEquals(v.AsOrdinal, $1234123412341234);
  661. v := TValue.FromOrdinal(TypeInfo(LongBool), Ord(True));
  662. Check(v.IsOrdinal);
  663. CheckEquals(v.AsOrdinal, Ord(True));
  664. v := TValue.FromOrdinal(TypeInfo(TTestEnum), Ord(te1));
  665. Check(v.IsOrdinal);
  666. CheckEquals(v.AsOrdinal, Ord(te1));
  667. v := TValue.FromOrdinal(TypeInfo(AnsiChar), Ord(#20));
  668. Check(v.IsOrdinal);
  669. CheckEquals(v.AsOrdinal, Ord(#20));
  670. v := TValue.FromOrdinal(TypeInfo(WideChar), Ord(#$1234));
  671. Check(v.IsOrdinal);
  672. CheckEquals(v.AsOrdinal, Ord(#$1234));
  673. CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalNil, EInvalidCast);
  674. CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalTObject, EInvalidCast);
  675. CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalSet, EInvalidCast);
  676. CheckException({$ifdef fpc}@{$endif}MakeFromOrdinalString, EInvalidCast);
  677. end;
  678. procedure TTestCase1.TestGetIsReadable;
  679. var
  680. c: TRttiContext;
  681. ARttiType: TRttiType;
  682. AProperty: TRttiProperty;
  683. begin
  684. c := TRttiContext.Create;
  685. try
  686. ARttiType := c.GetType(TTestValueClass);
  687. AProperty := ARttiType.GetProperty('aBoolean');
  688. CheckEquals(AProperty.IsReadable, true);
  689. AProperty := ARttiType.GetProperty('aGetBoolean');
  690. CheckEquals(AProperty.IsReadable, true);
  691. AProperty := ARttiType.GetProperty('aWriteOnly');
  692. CheckEquals(AProperty.IsReadable, False);
  693. finally
  694. c.Free;
  695. end;
  696. end;
  697. procedure TTestCase1.TestIsWritable;
  698. var
  699. c: TRttiContext;
  700. ARttiType: TRttiType;
  701. AProperty: TRttiProperty;
  702. begin
  703. c := TRttiContext.Create;
  704. try
  705. ARttiType := c.GetType(TTestValueClass);
  706. AProperty := ARttiType.GetProperty('aBoolean');
  707. CheckEquals(AProperty.IsWritable, true);
  708. AProperty := ARttiType.GetProperty('aGetBoolean');
  709. CheckEquals(AProperty.IsWritable, false);
  710. AProperty := ARttiType.GetProperty('aWriteOnly');
  711. CheckEquals(AProperty.IsWritable, True);
  712. finally
  713. c.Free;
  714. end;
  715. end;
  716. procedure TTestCase1.TestPropGetValueBoolean;
  717. var
  718. ATestClass : TTestValueClass;
  719. c: TRttiContext;
  720. ARttiType: TRttiType;
  721. AProperty: TRttiProperty;
  722. AValue: TValue;
  723. begin
  724. c := TRttiContext.Create;
  725. try
  726. ATestClass := TTestValueClass.Create;
  727. ATestClass.ABoolean := true;
  728. try
  729. ARttiType := c.GetType(ATestClass.ClassInfo);
  730. Check(assigned(ARttiType));
  731. AProperty := ARttiType.GetProperty('aBoolean');
  732. AValue := AProperty.GetValue(ATestClass);
  733. CheckEquals(true,AValue.AsBoolean);
  734. ATestClass.ABoolean := false;
  735. CheckEquals(true, AValue.AsBoolean);
  736. CheckEquals('True', AValue.ToString);
  737. CheckEquals(True, AValue.IsOrdinal);
  738. CheckEquals(1, AValue.AsOrdinal);
  739. finally
  740. AtestClass.Free;
  741. end;
  742. CheckEquals(True,AValue.AsBoolean);
  743. finally
  744. c.Free;
  745. end;
  746. end;
  747. procedure TTestCase1.TestPropGetValueShortString;
  748. var
  749. ATestClass : TTestValueClass;
  750. c: TRttiContext;
  751. ARttiType: TRttiType;
  752. AProperty: TRttiProperty;
  753. AValue: TValue;
  754. begin
  755. c := TRttiContext.Create;
  756. try
  757. ATestClass := TTestValueClass.Create;
  758. ATestClass.AShortString := 'Hello World';
  759. try
  760. ARttiType := c.GetType(ATestClass.ClassInfo);
  761. Check(assigned(ARttiType));
  762. AProperty := ARttiType.GetProperty('aShortString');
  763. AValue := AProperty.GetValue(ATestClass);
  764. CheckEquals('Hello World',AValue.AsString);
  765. ATestClass.AShortString := 'Foobar';
  766. CheckEquals('Hello World', AValue.AsString);
  767. CheckEquals(False, AValue.IsOrdinal);
  768. CheckEquals(False, AValue.IsObject);
  769. CheckEquals(False, AValue.IsArray);
  770. CheckEquals(False, AValue.IsClass);
  771. finally
  772. AtestClass.Free;
  773. end;
  774. CheckEquals('Hello World',AValue.AsString);
  775. finally
  776. c.Free;
  777. end;
  778. end;
  779. procedure TTestCase1.TestPropGetValueInteger;
  780. var
  781. ATestClass : TTestValueClass;
  782. c: TRttiContext;
  783. ARttiType: TRttiType;
  784. AProperty: TRttiProperty;
  785. AValue: TValue;
  786. begin
  787. c := TRttiContext.Create;
  788. try
  789. ATestClass := TTestValueClass.Create;
  790. ATestClass.AInteger := 472349;
  791. try
  792. ARttiType := c.GetType(ATestClass.ClassInfo);
  793. Check(assigned(ARttiType));
  794. AProperty := ARttiType.GetProperty('ainteger');
  795. AValue := AProperty.GetValue(ATestClass);
  796. CheckEquals(472349,AValue.AsInteger);
  797. ATestClass.AInteger := 12;
  798. CheckEquals(472349, AValue.AsInteger);
  799. CheckEquals('472349', AValue.ToString);
  800. CheckEquals(True, AValue.IsOrdinal);
  801. finally
  802. AtestClass.Free;
  803. end;
  804. CheckEquals(472349,AValue.AsInteger);
  805. finally
  806. c.Free;
  807. end;
  808. end;
  809. procedure TTestCase1.TestPropGetValueString;
  810. var
  811. ATestClass : TTestValueClass;
  812. c: TRttiContext;
  813. ARttiType: TRttiType;
  814. AProperty: TRttiProperty;
  815. AValue: TValue;
  816. i: int64;
  817. begin
  818. c := TRttiContext.Create;
  819. try
  820. ATestClass := TTestValueClass.Create;
  821. ATestClass.AString := 'Hello World';
  822. try
  823. ARttiType := c.GetType(ATestClass.ClassInfo);
  824. Check(assigned(ARttiType));
  825. AProperty := ARttiType.GetProperty('astring');
  826. AValue := AProperty.GetValue(ATestClass);
  827. CheckEquals('Hello World',AValue.AsString);
  828. ATestClass.AString := 'Goodbye World';
  829. CheckEquals('Hello World',AValue.AsString);
  830. CheckEquals('Hello World',AValue.ToString);
  831. Check(TypeInfo(string)=AValue.TypeInfo);
  832. Check(AValue.TypeData=GetTypeData(AValue.TypeInfo));
  833. Check(AValue.IsEmpty=false);
  834. Check(AValue.IsObject=false);
  835. Check(AValue.IsClass=false);
  836. CheckEquals(AValue.IsOrdinal, false);
  837. CheckEquals(AValue.TryAsOrdinal(i), false);
  838. CheckEquals(AValue.IsType(TypeInfo(string)), true);
  839. CheckEquals(AValue.IsType(TypeInfo(integer)), false);
  840. CheckEquals(AValue.IsArray, false);
  841. finally
  842. AtestClass.Free;
  843. end;
  844. CheckEquals('Hello World',AValue.AsString);
  845. finally
  846. c.Free;
  847. end;
  848. end;
  849. procedure TTestCase1.TestPropGetValueProcBoolean;
  850. var
  851. ATestClass : TTestValueClass;
  852. c: TRttiContext;
  853. ARttiType: TRttiType;
  854. AProperty: TRttiProperty;
  855. AValue: TValue;
  856. begin
  857. c := TRttiContext.Create;
  858. try
  859. ATestClass := TTestValueClass.Create;
  860. ATestClass.ABoolean := true;
  861. try
  862. ARttiType := c.GetType(ATestClass.ClassInfo);
  863. Check(assigned(ARttiType));
  864. AProperty := ARttiType.GetProperty('aGetBoolean');
  865. AValue := AProperty.GetValue(ATestClass);
  866. CheckEquals(true,AValue.AsBoolean);
  867. finally
  868. AtestClass.Free;
  869. end;
  870. CheckEquals(True,AValue.AsBoolean);
  871. finally
  872. c.Free;
  873. end;
  874. end;
  875. procedure TTestCase1.TestPropGetValueProcShortString;
  876. var
  877. ATestClass : TTestValueClass;
  878. c: TRttiContext;
  879. ARttiType: TRttiType;
  880. AProperty: TRttiProperty;
  881. AValue: TValue;
  882. begin
  883. c := TRttiContext.Create;
  884. try
  885. ATestClass := TTestValueClass.Create;
  886. ATestClass.AShortString := 'Hello World';
  887. try
  888. ARttiType := c.GetType(ATestClass.ClassInfo);
  889. Check(assigned(ARttiType));
  890. AProperty := ARttiType.GetProperty('aGetShortString');
  891. AValue := AProperty.GetValue(ATestClass);
  892. CheckEquals('Hello World',AValue.AsString);
  893. finally
  894. AtestClass.Free;
  895. end;
  896. CheckEquals('Hello World',AValue.AsString);
  897. finally
  898. c.Free;
  899. end;
  900. end;
  901. procedure TTestCase1.TestPropSetValueString;
  902. var
  903. ATestClass : TTestValueClass;
  904. c: TRttiContext;
  905. ARttiType: TRttiType;
  906. AProperty: TRttiProperty;
  907. AValue: TValue;
  908. s: string;
  909. begin
  910. c := TRttiContext.Create;
  911. try
  912. ATestClass := TTestValueClass.Create;
  913. try
  914. ARttiType := c.GetType(ATestClass.ClassInfo);
  915. AProperty := ARttiType.GetProperty('astring');
  916. s := 'ipse lorem or something like that';
  917. TValue.Make(@s, TypeInfo(string), AValue);
  918. AProperty.SetValue(ATestClass, AValue);
  919. CheckEquals(ATestClass.AString, s);
  920. s := 'Another string';
  921. CheckEquals(ATestClass.AString, 'ipse lorem or something like that');
  922. finally
  923. AtestClass.Free;
  924. end;
  925. finally
  926. c.Free;
  927. end;
  928. end;
  929. procedure TTestCase1.TestPropSetValueInteger;
  930. var
  931. ATestClass : TTestValueClass;
  932. c: TRttiContext;
  933. ARttiType: TRttiType;
  934. AProperty: TRttiProperty;
  935. AValue: TValue;
  936. i: integer;
  937. begin
  938. c := TRttiContext.Create;
  939. try
  940. ATestClass := TTestValueClass.Create;
  941. try
  942. ARttiType := c.GetType(ATestClass.ClassInfo);
  943. AProperty := ARttiType.GetProperty('aInteger');
  944. i := -43573;
  945. TValue.Make(@i, TypeInfo(Integer), AValue);
  946. AProperty.SetValue(ATestClass, AValue);
  947. CheckEquals(ATestClass.AInteger, i);
  948. i := 1;
  949. CheckEquals(ATestClass.AInteger, -43573);
  950. finally
  951. AtestClass.Free;
  952. end;
  953. finally
  954. c.Free;
  955. end;
  956. end;
  957. procedure TTestCase1.TestPropSetValueBoolean;
  958. var
  959. ATestClass : TTestValueClass;
  960. c: TRttiContext;
  961. ARttiType: TRttiType;
  962. AProperty: TRttiProperty;
  963. AValue: TValue;
  964. b: boolean;
  965. begin
  966. c := TRttiContext.Create;
  967. try
  968. ATestClass := TTestValueClass.Create;
  969. try
  970. ARttiType := c.GetType(ATestClass.ClassInfo);
  971. AProperty := ARttiType.GetProperty('aboolean');
  972. b := true;
  973. TValue.Make(@b, TypeInfo(Boolean), AValue);
  974. AProperty.SetValue(ATestClass, AValue);
  975. CheckEquals(ATestClass.ABoolean, b);
  976. b := false;
  977. CheckEquals(ATestClass.ABoolean, true);
  978. TValue.Make(@b, TypeInfo(Boolean), AValue);
  979. AProperty.SetValue(ATestClass, AValue);
  980. CheckEquals(ATestClass.ABoolean, false);
  981. finally
  982. AtestClass.Free;
  983. end;
  984. finally
  985. c.Free;
  986. end;
  987. end;
  988. procedure TTestCase1.TestPropSetValueShortString;
  989. var
  990. ATestClass : TTestValueClass;
  991. c: TRttiContext;
  992. ARttiType: TRttiType;
  993. AProperty: TRttiProperty;
  994. AValue: TValue;
  995. s: string;
  996. ss: ShortString;
  997. begin
  998. c := TRttiContext.Create;
  999. try
  1000. ATestClass := TTestValueClass.Create;
  1001. try
  1002. ARttiType := c.GetType(ATestClass.ClassInfo);
  1003. AProperty := ARttiType.GetProperty('aShortString');
  1004. s := 'ipse lorem or something like that';
  1005. TValue.Make(@s, TypeInfo(String), AValue);
  1006. AProperty.SetValue(ATestClass, AValue);
  1007. CheckEquals(ATestClass.AShortString, s);
  1008. s := 'Another string';
  1009. CheckEquals(ATestClass.AShortString, 'ipse lorem or something like that');
  1010. ss := 'Hello World';
  1011. TValue.Make(@ss, TypeInfo(ShortString), AValue);
  1012. AProperty.SetValue(ATestClass, AValue);
  1013. CheckEquals(ATestClass.AShortString, ss);
  1014. ss := 'Foobar';
  1015. CheckEquals(ATestClass.AShortString, 'Hello World');
  1016. finally
  1017. AtestClass.Free;
  1018. end;
  1019. finally
  1020. c.Free;
  1021. end;
  1022. end;
  1023. procedure TTestCase1.TestPropGetValueProcInteger;
  1024. var
  1025. ATestClass : TTestValueClass;
  1026. c: TRttiContext;
  1027. ARttiType: TRttiType;
  1028. AProperty: TRttiProperty;
  1029. AValue: TValue;
  1030. begin
  1031. c := TRttiContext.Create;
  1032. try
  1033. ATestClass := TTestValueClass.Create;
  1034. ATestClass.AInteger := 472349;
  1035. try
  1036. ARttiType := c.GetType(ATestClass.ClassInfo);
  1037. Check(assigned(ARttiType));
  1038. AProperty := ARttiType.GetProperty('agetinteger');
  1039. AValue := AProperty.GetValue(ATestClass);
  1040. CheckEquals(472349,AValue.AsInteger);
  1041. finally
  1042. AtestClass.Free;
  1043. end;
  1044. CheckEquals(472349,AValue.AsInteger);
  1045. finally
  1046. c.Free;
  1047. end;
  1048. end;
  1049. procedure TTestCase1.TestPropGetValueProcString;
  1050. var
  1051. ATestClass : TTestValueClass;
  1052. c: TRttiContext;
  1053. ARttiType: TRttiType;
  1054. AProperty: TRttiProperty;
  1055. AValue: TValue;
  1056. begin
  1057. c := TRttiContext.Create;
  1058. try
  1059. ATestClass := TTestValueClass.Create;
  1060. ATestClass.AString := 'Hello World';
  1061. try
  1062. ARttiType := c.GetType(ATestClass.ClassInfo);
  1063. Check(assigned(ARttiType));
  1064. AProperty := ARttiType.GetProperty('agetstring');
  1065. AValue := AProperty.GetValue(ATestClass);
  1066. CheckEquals('Hello World',AValue.AsString);
  1067. finally
  1068. AtestClass.Free;
  1069. end;
  1070. CheckEquals('Hello World',AValue.AsString);
  1071. finally
  1072. c.Free;
  1073. end;
  1074. end;
  1075. procedure TTestCase1.TestTRttiTypeProperties;
  1076. var
  1077. c: TRttiContext;
  1078. ARttiType: TRttiType;
  1079. begin
  1080. c := TRttiContext.Create;
  1081. try
  1082. ARttiType := c.GetType(TTestValueClass);
  1083. Check(assigned(ARttiType));
  1084. CheckEquals(ARttiType.Name,'TTestValueClass');
  1085. Check(ARttiType.TypeKind=tkClass);
  1086. // CheckEquals(ARttiType.IsPublicType,false);
  1087. CheckEquals(ARttiType.TypeSize,SizeOf(TObject));
  1088. CheckEquals(ARttiType.IsManaged,false);
  1089. CheckEquals(ARttiType.BaseType.classname,'TRttiInstanceType');
  1090. CheckEquals(ARttiType.IsInstance,True);
  1091. CheckEquals(ARttiType.AsInstance.DeclaringUnitName,'tests.rtti');
  1092. Check(ARttiType.BaseType.Name='TObject');
  1093. Check(ARttiType.AsInstance.BaseType.Name='TObject');
  1094. CheckEquals(ARttiType.IsOrdinal,False);
  1095. CheckEquals(ARttiType.IsRecord,False);
  1096. CheckEquals(ARttiType.IsSet,False);
  1097. finally
  1098. c.Free;
  1099. end;
  1100. end;
  1101. procedure TTestCase1.GetTypeInteger;
  1102. var
  1103. LContext: TRttiContext;
  1104. LType: TRttiType;
  1105. begin
  1106. LContext := TRttiContext.Create;
  1107. LType := LContext.GetType(TypeInfo(integer));
  1108. {$ifdef fpc}
  1109. CheckEquals(LType.Name, 'LongInt');
  1110. {$else}
  1111. CheckEquals(LType.Name, 'Integer');
  1112. {$endif}
  1113. LContext.Free;
  1114. end;
  1115. procedure TTestCase1.GetTypePointer;
  1116. var
  1117. context: TRttiContext;
  1118. t: TRttiType;
  1119. p: TRttiPointerType absolute t;
  1120. begin
  1121. context := TRttiContext.Create;
  1122. try
  1123. t := context.GetType(TypeInfo(Pointer));
  1124. Assert(t is TRttiPointerType, 'Type of Pointer is not a TRttiPointerType');
  1125. Assert(not Assigned(p.ReferredType), 'ReferredType of Pointer is not Nil');
  1126. t := context.GetType(TypeInfo(PLongInt));
  1127. Assert(t is TRttiPointerType, 'Type of Pointer is not a TRttiPointerType');
  1128. Assert(Assigned(p.ReferredType), 'ReferredType of PLongInt is Nil');
  1129. Assert(p.ReferredType = context.GetType(TypeInfo(LongInt)), 'ReferredType of PLongInt is not a LongInt');
  1130. t := context.GetType(TypeInfo(PWideChar));
  1131. Assert(t is TRttiPointerType, 'Type of Pointer is not a TRttiPointerType');
  1132. Assert(Assigned(p.ReferredType), 'ReferredType of PWideChar is Nil');
  1133. Assert(p.ReferredType = context.GetType(TypeInfo(WideChar)), 'ReferredType of PWideChar is not a WideChar');
  1134. finally
  1135. context.Free;
  1136. end;
  1137. end;
  1138. procedure TTestCase1.GetClassProperties;
  1139. var
  1140. LContext: TRttiContext;
  1141. LType: TRttiType;
  1142. PropList, PropList2: {$ifdef fpc}specialize{$endif} TArray<TRttiProperty>;
  1143. i: LongInt;
  1144. begin
  1145. LContext := TRttiContext.Create;
  1146. LType := LContext.GetType(TypeInfo(TGetClassProperties));
  1147. PropList := LType.GetProperties;
  1148. CheckEquals(4, length(PropList));
  1149. CheckEquals('PubPropRO', PropList[0].Name);
  1150. CheckEquals('PubPropRW', PropList[1].Name);
  1151. CheckEquals('PubPropSetRO', PropList[2].Name);
  1152. CheckEquals('PubPropSetRW', PropList[3].Name);
  1153. LType := LContext.GetType(TypeInfo(TGetClassPropertiesSub));
  1154. PropList2 := LType.GetProperties;
  1155. CheckEquals(Length(PropList), Length(PropList2));
  1156. for i := 0 to High(PropList) do
  1157. Check(PropList[i] = PropList2[i], 'Property instances are not equal');
  1158. LContext.Free;
  1159. end;
  1160. procedure TTestCase1.GetClassPropertiesValue;
  1161. var
  1162. AGetClassProperties: TGetClassProperties;
  1163. LContext: TRttiContext;
  1164. LType: TRttiType;
  1165. AValue: TValue;
  1166. begin
  1167. LContext := TRttiContext.Create;
  1168. LType := LContext.GetType(TGetClassProperties);
  1169. AGetClassProperties := TGetClassProperties.Create;
  1170. try
  1171. AGetClassProperties.PubPropRW:=12345;
  1172. AValue := LType.GetProperty('PubPropRW').GetValue(AGetClassProperties);
  1173. CheckEquals(12345, AValue.AsInteger);
  1174. finally
  1175. AGetClassProperties.Free;
  1176. end;
  1177. LContext.Free;
  1178. end;
  1179. procedure TTestCase1.TestReferenceRawData;
  1180. var
  1181. value: TValue;
  1182. str: String;
  1183. intf: IInterface;
  1184. i: LongInt;
  1185. test: TTestRecord;
  1186. arrdyn: TArrayOfLongintDyn;
  1187. arrstat: TArrayOfLongintStatic;
  1188. begin
  1189. str := 'Hello World';
  1190. UniqueString(str);
  1191. TValue.Make(@str, TypeInfo(String), value);
  1192. Check(PPointer(value.GetReferenceToRawData)^ = Pointer(str), 'Reference to string data differs');
  1193. intf := TInterfacedObject.Create;
  1194. TValue.Make(@intf, TypeInfo(IInterface), value);
  1195. Check(PPointer(value.GetReferenceToRawData)^ = Pointer(intf), 'Reference to interface data differs');
  1196. i := 42;
  1197. TValue.Make(@i, TypeInfo(LongInt), value);
  1198. Check(value.GetReferenceToRawData <> @i, 'Reference to longint is equal');
  1199. Check(PLongInt(value.GetReferenceToRawData)^ = PLongInt(@i)^, 'Reference to longint data differs');
  1200. test.value1 := 42;
  1201. test.value2 := 'Hello World';
  1202. TValue.Make(@test, TypeInfo(TTestRecord), value);
  1203. Check(value.GetReferenceToRawData <> @test, 'Reference to record is equal');
  1204. Check(PTestRecord(value.GetReferenceToRawData)^.value1 = PTestRecord(@test)^.value1, 'Reference to record data value1 differs');
  1205. Check(PTestRecord(value.GetReferenceToRawData)^.value2 = PTestRecord(@test)^.value2, 'Reference to record data value2 differs');
  1206. SetLength(arrdyn, 3);
  1207. arrdyn[0] := 42;
  1208. arrdyn[1] := 23;
  1209. arrdyn[2] := 49;
  1210. TValue.Make(@arrdyn, TypeInfo(TArrayOfLongintDyn), value);
  1211. Check(PPointer(value.GetReferenceToRawData)^ = Pointer(arrdyn), 'Reference to dynamic array data differs');
  1212. arrstat[0] := 42;
  1213. arrstat[1] := 23;
  1214. arrstat[2] := 49;
  1215. arrstat[3] := 59;
  1216. TValue.Make(@arrstat, TypeInfo(TArrayOfLongintStatic), value);
  1217. Check(value.GetReferenceToRawData <> @arrstat, 'Reference to static array is equal');
  1218. Check(PLongInt(value.GetReferenceToRawData)^ = PLongInt(@arrstat)^, 'Reference to static array data differs');
  1219. end;
  1220. procedure TTestCase1.TestReferenceRawDataEmpty;
  1221. var
  1222. value: TValue;
  1223. begin
  1224. TValue.Make(Nil, TypeInfo(String), value);
  1225. Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty String is not assigned');
  1226. Check(not Assigned(PPointer(value.GetReferenceToRawData)^), 'Empty String data is assigned');
  1227. TValue.Make(Nil, TypeInfo(IInterface), value);
  1228. Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty interface is not assigned');
  1229. Check(not Assigned(PPointer(value.GetReferenceToRawData)^), 'Empty interface data is assigned');
  1230. TValue.Make(Nil, TypeInfo(LongInt), value);
  1231. Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty LongInt is not assigned');
  1232. Check(PLongInt(value.GetReferenceToRawData)^ = 0, 'Empty longint data is not 0');
  1233. TValue.Make(Nil, TypeInfo(TTestRecord), value);
  1234. Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty record is not assigned');
  1235. Check(PTestRecord(value.GetReferenceToRawData)^.value1 = 0, 'Empty record data value1 is not 0');
  1236. Check(PTestRecord(value.GetReferenceToRawData)^.value2 = '', 'Empty record data value2 is not empty');
  1237. TValue.Make(Nil, TypeInfo(TArrayOfLongintDyn), value);
  1238. Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty dynamic array is not assigned');
  1239. Check(not Assigned(PPointer(value.GetReferenceToRawData)^), 'Empty dynamic array data is assigned');
  1240. TValue.Make(Nil, TypeInfo(TArrayOfLongintStatic), value);
  1241. Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty static array is not assigned');
  1242. Check(PLongInt(value.GetReferenceToRawData)^ = 0, 'Empty static array data is not 0');
  1243. end;
  1244. procedure TTestCase1.TestDataSize;
  1245. var
  1246. u8: UInt8;
  1247. u16: UInt16;
  1248. u32: UInt32;
  1249. u64: UInt64;
  1250. s8: Int8;
  1251. s16: Int16;
  1252. s32: Int32;
  1253. s64: Int64;
  1254. f32: Single;
  1255. f64: Double;
  1256. {$ifdef FPC_HAS_TYPE_EXTENDED}
  1257. f80: Extended;
  1258. {$endif}
  1259. fco: Comp;
  1260. fcu: Currency;
  1261. ss: ShortString;
  1262. sa: AnsiString;
  1263. su: UnicodeString;
  1264. sw: WideString;
  1265. o: TObject;
  1266. c: TClass;
  1267. i: IInterface;
  1268. ad: TArrayOfLongintDyn;
  1269. _as: TArrayOfLongintStatic;
  1270. b8: Boolean;
  1271. {$ifdef fpc}
  1272. b16: Boolean16;
  1273. b32: Boolean32;
  1274. b64: Boolean64;
  1275. {$endif}
  1276. bl8: ByteBool;
  1277. bl16: WordBool;
  1278. bl32: LongBool;
  1279. {$ifdef fpc}
  1280. bl64: QWordBool;
  1281. {$endif}
  1282. e: TTestEnum;
  1283. s: TTestSet;
  1284. t: TTestRecord;
  1285. p: Pointer;
  1286. proc: TTestProc;
  1287. method: TTestMethod;
  1288. value: TValue;
  1289. begin
  1290. u8:=245;
  1291. TValue.Make(@u8, TypeInfo(UInt8), value);
  1292. CheckEquals(1, value.DataSize, 'Size of UInt8 differs');
  1293. u16:=789;
  1294. TValue.Make(@u16, TypeInfo(UInt16), value);
  1295. CheckEquals(2, value.DataSize, 'Size of UInt16 differs');
  1296. u32:=568789;
  1297. TValue.Make(@u32, TypeInfo(UInt32), value);
  1298. CheckEquals(4, value.DataSize, 'Size of UInt32 differs');
  1299. u64:=$abdcefadbcef;
  1300. TValue.Make(@u64, TypeInfo(UInt64), value);
  1301. CheckEquals(8, value.DataSize, 'Size of UInt64 differs');
  1302. s8:=-32;
  1303. TValue.Make(@s8, TypeInfo(Int8), value);
  1304. CheckEquals(1, value.DataSize, 'Size of Int8 differs');
  1305. s16:=-5345;
  1306. TValue.Make(@s16, TypeInfo(Int16), value);
  1307. CheckEquals(2, value.DataSize, 'Size of Int16 differs');
  1308. s32:=-234567;
  1309. TValue.Make(@s32, TypeInfo(Int32), value);
  1310. CheckEquals(4, value.DataSize, 'Size of Int32 differs');
  1311. s64:=23456789012;
  1312. TValue.Make(@s64, TypeInfo(Int64), value);
  1313. CheckEquals(8, value.DataSize, 'Size of Int64 differs');
  1314. b8:=false;
  1315. TValue.Make(@b8, TypeInfo(Boolean), value);
  1316. CheckEquals(1, value.DataSize, 'Size of Boolean differs');
  1317. {$ifdef fpc}
  1318. b16:=true;
  1319. TValue.Make(@b16, TypeInfo(Boolean16), value);
  1320. CheckEquals(2, value.DataSize, 'Size of Boolean16 differs');
  1321. b32:=false;
  1322. TValue.Make(@b32, TypeInfo(Boolean32), value);
  1323. CheckEquals(4, value.DataSize, 'Size of Boolean32 differs');
  1324. b64:=true;
  1325. TValue.Make(@b64, TypeInfo(Boolean64), value);
  1326. CheckEquals(8, value.DataSize, 'Size of Boolean64 differs');
  1327. {$endif}
  1328. bl8:=true;
  1329. TValue.Make(@bl8, TypeInfo(ByteBool), value);
  1330. CheckEquals(1, value.DataSize, 'Size of ByteBool differs');
  1331. bl16:=false;
  1332. TValue.Make(@bl16, TypeInfo(WordBool), value);
  1333. CheckEquals(2, value.DataSize, 'Size of WordBool differs');
  1334. bl32:=false;
  1335. TValue.Make(@bl32, TypeInfo(LongBool), value);
  1336. CheckEquals(4, value.DataSize, 'Size of LongBool differs');
  1337. {$ifdef fpc}
  1338. bl64:=true;
  1339. TValue.Make(@bl64, TypeInfo(QWordBool), value);
  1340. CheckEquals(8, value.DataSize, 'Size of QWordBool differs');
  1341. {$endif}
  1342. f32:=4.567;
  1343. TValue.Make(@f32, TypeInfo(Single), value);
  1344. CheckEquals(4, value.DataSize, 'Size of Single differs');
  1345. f64:=-3456.678;
  1346. TValue.Make(@f64, TypeInfo(Double), value);
  1347. CheckEquals(8, value.DataSize, 'Size of Double differs');
  1348. {$ifdef FPC_HAS_TYPE_EXTENDED}
  1349. f80:=-2345.678;
  1350. TValue.Make(@f80, TypeInfo(Extended), value);
  1351. CheckEquals(10, value.DataSize, 'Size of Extended differs');
  1352. {$endif}
  1353. fcu:=56.78;
  1354. TValue.Make(@fcu, TypeInfo(Currency), value);
  1355. CheckEquals(SizeOf(Currency), value.DataSize, 'Size of Currency differs');
  1356. fco:=456;
  1357. TValue.Make(@fco, TypeInfo(Comp), value);
  1358. CheckEquals(SizeOf(Comp), value.DataSize, 'Size of Comp differs');
  1359. ss := '';
  1360. TValue.Make(@ss, TypeInfo(ShortString), value);
  1361. CheckEquals(254, value.DataSize, 'Size ofShortString differs');
  1362. sa:= '';
  1363. TValue.Make(@sa, TypeInfo(AnsiString), value);
  1364. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of AnsiString differs');
  1365. sw := '';
  1366. TValue.Make(@sw, TypeInfo(WideString), value);
  1367. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of WideString differs');
  1368. su:='';
  1369. TValue.Make(@su, TypeInfo(UnicodeString), value);
  1370. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of UnicodeString differs');
  1371. o := TTestValueClass.Create;
  1372. TValue.Make(@o, TypeInfo(TObject), value);
  1373. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TObject differs');
  1374. o.Free;
  1375. c := TObject;
  1376. TValue.Make(@c, TypeInfo(TClass), value);
  1377. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TClass differs');
  1378. i := Nil;
  1379. TValue.Make(@i, TypeInfo(IInterface), value);
  1380. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of IInterface differs');
  1381. TValue.Make(@t, TypeInfo(TTestRecord), value);
  1382. CheckEquals(SizeOf(TTestRecord), value.DataSize, 'Size of TTestRecord differs');
  1383. proc := Nil;
  1384. TValue.Make(@proc, TypeInfo(TTestProc), value);
  1385. CheckEquals(SizeOf(TTestProc), value.DataSize, 'Size of TTestProc differs');
  1386. method := Nil;
  1387. TValue.Make(@method, TypeInfo(TTestMethod), value);
  1388. CheckEquals(SizeOf(TTestMethod), value.DataSize, 'Size of TTestMethod differs');
  1389. TValue.Make(@_as, TypeInfo(TArrayOfLongintStatic), value);
  1390. CheckEquals(SizeOf(TArrayOfLongintStatic), value.DataSize, 'Size of TArrayOfLongintStatic differs');
  1391. TValue.Make(@ad, TypeInfo(TArrayOfLongintDyn), value);
  1392. CheckEquals(SizeOf(TArrayOfLongintDyn), value.DataSize, 'Size of TArrayOfLongintDyn differs');
  1393. e:=low(TTestEnum);
  1394. TValue.Make(@e, TypeInfo(TTestEnum), value);
  1395. CheckEquals(SizeOf(TTestEnum), value.DataSize, 'Size of TTestEnum differs');
  1396. s:=[low(TTestEnum),high(TTestEnum)];
  1397. TValue.Make(@s, TypeInfo(TTestSet), value);
  1398. CheckEquals(SizeOf(TTestSet), value.DataSize, 'Size of TTestSet differs');
  1399. p := Nil;
  1400. TValue.Make(@p, TypeInfo(Pointer), value);
  1401. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of Pointer differs');
  1402. end;
  1403. procedure TTestCase1.TestDataSizeEmpty;
  1404. var
  1405. value: TValue;
  1406. begin
  1407. TValue.Make(Nil, TypeInfo(UInt8), value);
  1408. CheckEquals(1, value.DataSize, 'Size of UInt8 differs');
  1409. TValue.Make(Nil, TypeInfo(UInt16), value);
  1410. CheckEquals(2, value.DataSize, 'Size of UInt16 differs');
  1411. TValue.Make(Nil, TypeInfo(UInt32), value);
  1412. CheckEquals(4, value.DataSize, 'Size of UInt32 differs');
  1413. TValue.Make(Nil, TypeInfo(UInt64), value);
  1414. CheckEquals(8, value.DataSize, 'Size of UInt64 differs');
  1415. TValue.Make(Nil, TypeInfo(Int8), value);
  1416. CheckEquals(1, value.DataSize, 'Size of Int8 differs');
  1417. TValue.Make(Nil, TypeInfo(Int16), value);
  1418. CheckEquals(2, value.DataSize, 'Size of Int16 differs');
  1419. TValue.Make(Nil, TypeInfo(Int32), value);
  1420. CheckEquals(4, value.DataSize, 'Size of Int32 differs');
  1421. TValue.Make(Nil, TypeInfo(Int64), value);
  1422. CheckEquals(8, value.DataSize, 'Size of Int64 differs');
  1423. TValue.Make(Nil, TypeInfo(Boolean), value);
  1424. CheckEquals(1, value.DataSize, 'Size of Boolean differs');
  1425. {$ifdef fpc}
  1426. TValue.Make(Nil, TypeInfo(Boolean16), value);
  1427. CheckEquals(2, value.DataSize, 'Size of Boolean16 differs');
  1428. TValue.Make(Nil, TypeInfo(Boolean32), value);
  1429. CheckEquals(4, value.DataSize, 'Size of Boolean32 differs');
  1430. TValue.Make(Nil, TypeInfo(Boolean64), value);
  1431. CheckEquals(8, value.DataSize, 'Size of Boolean64 differs');
  1432. {$endif}
  1433. TValue.Make(Nil, TypeInfo(ByteBool), value);
  1434. CheckEquals(1, value.DataSize, 'Size of ByteBool differs');
  1435. TValue.Make(Nil, TypeInfo(WordBool), value);
  1436. CheckEquals(2, value.DataSize, 'Size of WordBool differs');
  1437. TValue.Make(Nil, TypeInfo(LongBool), value);
  1438. CheckEquals(4, value.DataSize, 'Size of LongBool differs');
  1439. {$ifdef fpc}
  1440. TValue.Make(Nil, TypeInfo(QWordBool), value);
  1441. CheckEquals(8, value.DataSize, 'Size of QWordBool differs');
  1442. {$endif}
  1443. TValue.Make(Nil, TypeInfo(Single), value);
  1444. CheckEquals(4, value.DataSize, 'Size of Single differs');
  1445. TValue.Make(Nil, TypeInfo(Double), value);
  1446. CheckEquals(8, value.DataSize, 'Size of Double differs');
  1447. {$ifdef FPC_HAS_TYPE_EXTENDED}
  1448. TValue.Make(Nil, TypeInfo(Extended), value);
  1449. CheckEquals(10, value.DataSize, 'Size of Extended differs');
  1450. {$endif}
  1451. TValue.Make(Nil, TypeInfo(Currency), value);
  1452. CheckEquals(SizeOf(Currency), value.DataSize, 'Size of Currency differs');
  1453. TValue.Make(Nil, TypeInfo(Comp), value);
  1454. CheckEquals(SizeOf(Comp), value.DataSize, 'Size of Comp differs');
  1455. TValue.Make(Nil, TypeInfo(ShortString), value);
  1456. CheckEquals(254, value.DataSize, 'Size of ShortString differs');
  1457. TValue.Make(Nil, TypeInfo(AnsiString), value);
  1458. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of Pointer differs');
  1459. TValue.Make(Nil, TypeInfo(WideString), value);
  1460. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of WideString differs');
  1461. TValue.Make(Nil, TypeInfo(UnicodeString), value);
  1462. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of UnicodeString differs');
  1463. TValue.Make(Nil, TypeInfo(TObject), value);
  1464. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TObject differs');
  1465. TValue.Make(Nil, TypeInfo(TClass), value);
  1466. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TClass differs');
  1467. TValue.Make(Nil, TypeInfo(IInterface), value);
  1468. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of IInterface differs');
  1469. TValue.Make(Nil, TypeInfo(TTestRecord), value);
  1470. CheckEquals(SizeOf(TTestRecord), value.DataSize, 'Size of TTestRecord differs');
  1471. TValue.Make(Nil, TypeInfo(TTestProc), value);
  1472. CheckEquals(SizeOf(TTestProc), value.DataSize, 'Size of TTestProc differs');
  1473. TValue.Make(Nil, TypeInfo(TTestMethod), value);
  1474. CheckEquals(SizeOf(TTestMethod), value.DataSize, 'Size of TTestMethod differs');
  1475. TValue.Make(Nil, TypeInfo(TArrayOfLongintStatic), value);
  1476. CheckEquals(SizeOf(TArrayOfLongintStatic), value.DataSize, 'Size of TArrayOfLongintStatic differs');
  1477. TValue.Make(Nil, TypeInfo(TArrayOfLongintDyn), value);
  1478. CheckEquals(SizeOf(TArrayOfLongintDyn), value.DataSize, 'Size of TArrayOfLongintDyn differs');
  1479. TValue.Make(Nil, TypeInfo(TTestEnum), value);
  1480. CheckEquals(SizeOf(TTestEnum), value.DataSize, 'Size of TTestEnum differs');
  1481. TValue.Make(Nil, TypeInfo(TTestSet), value);
  1482. CheckEquals(SizeOf(TTestSet), value.DataSize, 'Size of TTestSet differs');
  1483. TValue.Make(Nil, TypeInfo(Pointer), value);
  1484. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of Pointer differs');
  1485. end;
  1486. procedure TTestCase1.TestIsManaged;
  1487. begin
  1488. CheckEquals(true, IsManaged(TypeInfo(ansistring)), 'IsManaged for tkAString');
  1489. CheckEquals(true, IsManaged(TypeInfo(widestring)), 'IsManaged for tkWString');
  1490. CheckEquals(true, IsManaged(TypeInfo(Variant)), 'IsManaged for tkVariant');
  1491. CheckEquals(true, IsManaged(TypeInfo(TArrayOfManagedRec)),
  1492. 'IsManaged for tkArray (with managed ElType)');
  1493. CheckEquals(true, IsManaged(TypeInfo(TArrayOfString)),
  1494. 'IsManaged for tkArray (with managed ElType)');
  1495. CheckEquals(true, IsManaged(TypeInfo(TManagedRec)), 'IsManaged for tkRecord');
  1496. {$ifdef fpc}
  1497. CheckEquals(true, IsManaged(TypeInfo(TManagedRecOp)), 'IsManaged for tkRecord');
  1498. {$endif}
  1499. CheckEquals(true, IsManaged(TypeInfo(IInterface)), 'IsManaged for tkInterface');
  1500. CheckEquals(true, IsManaged(TypeInfo(TManagedObj)), 'IsManaged for tkObject');
  1501. {$ifdef fpc}
  1502. CheckEquals(true, IsManaged(TypeInfo(specialize TArray<byte>)), 'IsManaged for tkDynArray');
  1503. {$else}
  1504. CheckEquals(true, IsManaged(TypeInfo(TArray<byte>)), 'IsManaged for tkDynArray');
  1505. {$endif}
  1506. CheckEquals(true, IsManaged(TypeInfo(unicodestring)), 'IsManaged for tkUString');
  1507. CheckEquals(false, IsManaged(TypeInfo(shortstring)), 'IsManaged for tkSString');
  1508. CheckEquals(false, IsManaged(TypeInfo(Byte)), 'IsManaged for tkInteger');
  1509. CheckEquals(false, IsManaged(TypeInfo(Char)), 'IsManaged for tkChar');
  1510. CheckEquals(false, IsManaged(TypeInfo(TTestEnum)), 'IsManaged for tkEnumeration');
  1511. CheckEquals(false, IsManaged(TypeInfo(Single)), 'IsManaged for tkFloat');
  1512. CheckEquals(false, IsManaged(TypeInfo(TTestSet)), 'IsManaged for tkSet');
  1513. {$ifdef fpc}
  1514. CheckEquals(false, IsManaged(TypeInfo(TTestMethod)), 'IsManaged for tkMethod');
  1515. {$else}
  1516. { Delphi bug (or sabotage). For some reason Delphi considers method pointers to be managed (only in newer versions, probably since XE7) :/ }
  1517. CheckEquals({$if RTLVersion>=28}true{$else}false{$endif}, IsManaged(TypeInfo(TTestMethod)), 'IsManaged for tkMethod');
  1518. {$endif}
  1519. CheckEquals(false, IsManaged(TypeInfo(TArrayOfByte)),
  1520. 'IsManaged for tkArray (with non managed ElType)');
  1521. CheckEquals(false, IsManaged(TypeInfo(TArrayOfNonManagedRec)),
  1522. 'IsManaged for tkArray (with non managed ElType)');
  1523. CheckEquals(false, IsManaged(TypeInfo(TNonManagedRec)), 'IsManaged for tkRecord');
  1524. CheckEquals(false, IsManaged(TypeInfo(TObject)), 'IsManaged for tkClass');
  1525. CheckEquals(false, IsManaged(TypeInfo(TNonManagedObj)), 'IsManaged for tkObject');
  1526. CheckEquals(false, IsManaged(TypeInfo(WideChar)), 'IsManaged for tkWChar');
  1527. CheckEquals(false, IsManaged(TypeInfo(Boolean)), 'IsManaged for tkBool');
  1528. CheckEquals(false, IsManaged(TypeInfo(Int64)), 'IsManaged for tkInt64');
  1529. CheckEquals(false, IsManaged(TypeInfo(UInt64)), 'IsManaged for tkQWord');
  1530. {$ifdef fpc}
  1531. CheckEquals(false, IsManaged(TypeInfo(ICORBATest)), 'IsManaged for tkInterfaceRaw');
  1532. {$endif}
  1533. CheckEquals(false, IsManaged(TypeInfo(TTestProc)), 'IsManaged for tkProcVar');
  1534. CheckEquals(false, IsManaged(TypeInfo(TTestHelper)), 'IsManaged for tkHelper');
  1535. {$ifdef fpc}
  1536. CheckEquals(false, IsManaged(TypeInfo(file)), 'IsManaged for tkFile');
  1537. {$endif}
  1538. CheckEquals(false, IsManaged(TypeInfo(TClass)), 'IsManaged for tkClassRef');
  1539. CheckEquals(false, IsManaged(TypeInfo(Pointer)), 'IsManaged for tkPointer');
  1540. CheckEquals(false, IsManaged(nil), 'IsManaged for nil');
  1541. end;
  1542. {$ifdef fpc}
  1543. procedure TTestCase1.TestOpenArrayToDyn;
  1544. procedure OpenArrayProc(aArr: array of LongInt);
  1545. var
  1546. value: TValue;
  1547. begin
  1548. {$ifndef InLazIDE}
  1549. value := specialize OpenArrayToDynArrayValue<LongInt>(aArr);
  1550. {$endif}
  1551. CheckEquals(value.IsArray, True);
  1552. CheckEquals(value.IsOpenArray, False);
  1553. CheckEquals(value.IsObject, False);
  1554. CheckEquals(value.IsOrdinal, False);
  1555. CheckEquals(value.IsClass, False);
  1556. CheckEquals(value.GetArrayLength, 2);
  1557. CheckEquals(value.GetArrayElement(0).AsInteger, 42);
  1558. CheckEquals(value.GetArrayElement(1).AsInteger, 84);
  1559. value.SetArrayElement(0, 21);
  1560. { since this is a copy the original array is not modified! }
  1561. CheckEquals(aArr[0], 42);
  1562. end;
  1563. begin
  1564. OpenArrayProc([42, 84]);
  1565. end;
  1566. {$endif}
  1567. procedure TTestCase1.TestInterface;
  1568. var
  1569. context: TRttiContext;
  1570. t: TRttiType;
  1571. ti1, ti2: TRttiInterfaceType;
  1572. methods: {$ifdef fpc}specialize{$endif} TArray<TRttiMethod>;
  1573. params: {$ifdef fpc}specialize{$endif} TArray<TRttiParameter>;
  1574. method: TRttiMethod;
  1575. param: TRttiParameter;
  1576. flag: TParamFlag;
  1577. begin
  1578. context := TRttiContext.Create;
  1579. try
  1580. t := context.GetType(TypeInfo(IInterface));
  1581. Check(t is TRttiInterfaceType, 'Type is not an interface type');
  1582. Check(not Assigned(t.BaseType), 'Base type is assigned');
  1583. ti1 := TRttiInterfaceType(t);
  1584. Check(not Assigned(ti1.BaseType), 'Base type is assigned');
  1585. methods := t.GetMethods;
  1586. CheckEquals(0, Length(methods), 'Overall method count does not match');
  1587. methods := t.GetDeclaredMethods;
  1588. CheckEquals(0, Length(methods), 'Declared method conut does not match');
  1589. t := context.GetType(TypeInfo(ITestInterface));
  1590. Check(t is TRttiInterfaceType, 'Type is not an interface type');
  1591. Check(Assigned(t.BaseType), 'Base type is not assigned');
  1592. Check(t.BaseType = TRttiType(ti1), 'Base type does not match');
  1593. ti2 := TRttiInterfaceType(t);
  1594. Check(Assigned(ti2.BaseType), 'Base type is not assigned');
  1595. Check(ti2.BaseType = ti1, 'Base type does not match');
  1596. methods := t.GetMethods;
  1597. CheckEquals(4, Length(methods), 'Overall method count does not match');
  1598. methods := t.GetDeclaredMethods;
  1599. CheckEquals(4, Length(methods), 'Declared method count does not match');
  1600. method := methods[0];
  1601. CheckEquals(method.Name, 'Test', 'Method name of Test does not match');
  1602. Check(method.CallingConvention = ccReg, 'Calling convention of Test does not match');
  1603. Check(method.MethodKind = mkProcedure, 'Method kind of Test does not match');
  1604. Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test does not match');
  1605. Check(not Assigned(method.CodeAddress), 'Code address of Test is not Nil');
  1606. CheckEquals(method.VirtualIndex, 3, 'Virtual index of Test does not match');
  1607. Check(not Assigned(method.ReturnType), 'Return type of Test is not Nil');
  1608. params := method.GetParameters;
  1609. CheckEquals(0, Length(params), 'Parameter count of Test does not match');
  1610. method := methods[1];
  1611. CheckEquals(method.Name, 'Test2', 'Method name of Test2 does not match');
  1612. Check(method.CallingConvention = ccReg, 'Calling convention of Test2 does not match');
  1613. Check(method.MethodKind = mkFunction, 'Method kind of Test2 does not match');
  1614. Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test2 does not match');
  1615. Check(not Assigned(method.CodeAddress), 'Code address of Test2 is not Nil');
  1616. CheckEquals(method.VirtualIndex, 4, 'Virtual index of Test2 does not match');
  1617. Check(Assigned(method.ReturnType), 'Return type of Test2 is Nil');
  1618. Check(method.ReturnType.TypeKind = tkInteger, 'Return type of Test2 is not an ordinal');
  1619. params := method.GetParameters;
  1620. CheckEquals(0, Length(params), 'Parameter count of Test2 does not match');
  1621. method := methods[2];
  1622. CheckEquals(method.Name, 'Test3', 'Method name of Test3 does not match');
  1623. Check(method.CallingConvention = ccReg, 'Calling convention of Test3 does not match');
  1624. Check(method.MethodKind = mkProcedure, 'Method kind of Test3 does not match');
  1625. Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test3 does not match');
  1626. Check(not Assigned(method.CodeAddress), 'Code address of Test3 is not Nil');
  1627. CheckEquals(method.VirtualIndex, 5, 'Virtual index of Test3 does not match');
  1628. Check(not Assigned(method.ReturnType), 'Return type of Test3 is not Nil');
  1629. params := method.GetParameters;
  1630. CheckEquals(4, Length(params), 'Parameter count of Test3 does not match');
  1631. param := params[0];
  1632. CheckEquals(param.Name, 'aArg1', 'Parameter name of Test3.aArg1 does not match');
  1633. Check(param.Flags = [], 'Parameter flags of Test3.aArg1 do not match');
  1634. Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg1 is Nil');
  1635. Check(param.ParamType.TypeKind = tkInteger, 'Parameter type of Test3.aArg1 is not an ordinal');
  1636. param := params[1];
  1637. CheckEquals(param.Name, 'aArg2', 'Parameter name of Test3.aArg2 does not match');
  1638. Check(param.Flags = [pfConst], 'Parameter flags of Test3.aArg2 do not match');
  1639. Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg2 is Nil');
  1640. Check(param.ParamType.TypeKind = tkAnsiString, 'Parameter type of Test3.aArg2 is not a string');
  1641. param := params[2];
  1642. CheckEquals(param.Name, 'aArg3', 'Parameter name of Test3.aArg3 does not match');
  1643. Check(param.Flags = [pfVar], 'Parameter flags of Test3.aArg3 do not match');
  1644. Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg3 is Nil');
  1645. Check(param.ParamType.TypeKind = {$ifdef fpc}tkBool{$else}tkEnumeration{$endif}, 'Parameter type of Test3.aArg3 is not a boolean');
  1646. param := params[3];
  1647. CheckEquals(param.Name, 'aArg4', 'Parameter name of Test3.aArg4 does not match');
  1648. Check(param.Flags = [pfOut], 'Parameter flags of Test3.aArg4 do not match');
  1649. Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg4 is Nil');
  1650. Check(param.ParamType.TypeKind = tkInteger, 'Parameter type of Test3.aArg4 is not a string');
  1651. method := methods[3];
  1652. CheckEquals(method.Name, 'Test4', 'Method name of Test4 does not match');
  1653. Check(method.CallingConvention = ccReg, 'Calling convention of Test4 does not match');
  1654. Check(method.MethodKind = mkFunction, 'Method kind of Test4 does not match');
  1655. Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test4 does not match');
  1656. Check(not Assigned(method.CodeAddress), 'Code address of Test4 is not Nil');
  1657. CheckEquals(method.VirtualIndex, 6, 'Virtual index of Test4 does not match');
  1658. Check(Assigned(method.ReturnType), 'Return type of Test4 is not Nil');
  1659. Check(method.ReturnType.TypeKind = tkAnsiString, 'Return type of Test4 is not a string');
  1660. params := method.GetParameters;
  1661. CheckEquals(2, Length(params), 'Parameter count of Test4 does not match');
  1662. param := params[0];
  1663. CheckEquals(param.Name, 'aArg1', 'Parameter name of Test4.aArg1 does not match');
  1664. Check(param.Flags = [pfArray, pfReference], 'Parameter flags of Test4.aArg1 do not match');
  1665. Check(Assigned(param.ParamType), 'Parameter type of Test4.aArg1 is Nil');
  1666. Check(param.ParamType.TypeKind = tkInteger, 'Parameter type of Test4.aArg1 is not an ordinal');
  1667. param := params[1];
  1668. CheckEquals(param.Name, 'aArg2', 'Parameter name of Test4.aArg2 does not match');
  1669. Check(param.Flags = [pfArray, pfReference], 'Parameter flags of Test4.aArg2 do not match');
  1670. Check(Assigned(param.ParamType), 'Parameter type of Test4.aArg2 is Nil');
  1671. Check(param.ParamType.TypeKind = tkRecord, 'Parameter type of Test4.aArg2 is not a record');
  1672. finally
  1673. context.Free;
  1674. end;
  1675. end;
  1676. procedure TTestCase1.TestRawThunk;
  1677. var
  1678. intf: IInterface;
  1679. begin
  1680. { we test the raw thunking by instantiating a TVirtualInterface of IInterface }
  1681. { this does not require a function call manager as the thunking is implemented
  1682. directly inside the RTTI unit }
  1683. try
  1684. intf := TVirtualInterface.Create(PTypeInfo(TypeInfo(IInterface))) as IInterface;
  1685. except
  1686. on e: ENotImplemented do
  1687. Ignore('RawThunk not implemented');
  1688. end;
  1689. { if all went well QueryInterface and _AddRef were called and now we call
  1690. _Release as well }
  1691. intf := Nil;
  1692. end;
  1693. {$ifdef fpc}
  1694. procedure TTestCase1.TestInterfaceRaw;
  1695. var
  1696. context: TRttiContext;
  1697. t: TRttiType;
  1698. ti: TRttiInterfaceType;
  1699. begin
  1700. context := TRttiContext.Create;
  1701. try
  1702. t := context.GetType(TypeInfo(ICORBATest));
  1703. Check(t is TRttiInterfaceType, 'Type is not a raw interface type');
  1704. Check(not Assigned(t.BaseType), 'Base type is assigned');
  1705. ti := TRttiInterfaceType(t);
  1706. Check(not Assigned(ti.BaseType), 'Base type is assigned');
  1707. finally
  1708. context.Free;
  1709. end;
  1710. end;
  1711. {$endif}
  1712. procedure TTestCase1.TestProcVar;
  1713. var
  1714. context: TRttiContext;
  1715. t: TRttiType;
  1716. p: TRttiProcedureType;
  1717. params: {$ifdef fpc}specialize{$endif} TArray<TRttiParameter>;
  1718. begin
  1719. context := TRttiContext.Create;
  1720. try
  1721. t := context.GetType(PTypeInfo(TypeInfo(TTestProc)));
  1722. Check(Assigned(t), 'Rtti Type is Nil');
  1723. Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
  1724. Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
  1725. p := t as TRttiProcedureType;
  1726. Check(p.CallingConvention = ccReg, 'Calling convention does not match');
  1727. Check(not Assigned(p.ReturnType), 'Return type is assigned');
  1728. CheckEquals(0, Length(p.GetParameters), 'Procedure variable has parameters');
  1729. t := context.GetType(PTypeInfo(TypeInfo(TTestFunc1)));
  1730. Check(Assigned(t), 'Rtti Type is Nil');
  1731. Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
  1732. Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
  1733. p := t as TRttiProcedureType;
  1734. Check(p.CallingConvention = ccReg, 'Calling convention does not match');
  1735. Check(Assigned(p.ReturnType), 'Return type is not assigned');
  1736. //Check(p.ReturnType is TRttiOrdinalType, 'Return type is not an ordinal type');
  1737. CheckEquals(0, Length(p.GetParameters), 'Procedure variable has parameters');
  1738. t := context.GetType(PTypeInfo(TypeInfo(TTestFunc2)));
  1739. Check(Assigned(t), 'Rtti Type is Nil');
  1740. Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
  1741. Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
  1742. p := t as TRttiProcedureType;
  1743. Check(p.CallingConvention = ccReg, 'Calling convention does not match');
  1744. Check(Assigned(p.ReturnType), 'Return type is not assigned');
  1745. Check(p.ReturnType is TRttiStringType, 'Return type is not a string type');
  1746. params := p.GetParameters;
  1747. CheckEquals(2, Length(params), 'Procedure variable has incorrect amount of parameters');
  1748. Check(params[0].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 1 is not an ordinal type');
  1749. //Check(params[0].ParamType is TRttiOrdinalType, 'Parameter 1 is not an ordinal type');
  1750. Check(pfArray in params[1].Flags, 'Parameter 2 is not an array');
  1751. Check(params[1].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 2 is not an ordinal array');
  1752. finally
  1753. context.Free;
  1754. end;
  1755. end;
  1756. procedure TTestCase1.TestMethod;
  1757. var
  1758. context: TRttiContext;
  1759. t: TRttiType;
  1760. m: TRttiMethodType;
  1761. params: {$ifdef fpc}specialize{$endif} TArray<TRttiParameter>;
  1762. begin
  1763. context := TRttiContext.Create;
  1764. try
  1765. t := context.GetType(PTypeInfo(TypeInfo(TTestMethod)));
  1766. Check(Assigned(t), 'Rtti Type is Nil');
  1767. Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
  1768. Check(t is TRttiMethodType, 'Rtti Type is not a method type');
  1769. m := t as TRttiMethodType;
  1770. Check(m.CallingConvention = ccReg, 'Calling convention does not match');
  1771. Check(not Assigned(m.ReturnType), 'Return type is assigned');
  1772. CheckEquals(0, Length(m.GetParameters), 'Method variable has parameters');
  1773. t := context.GetType(PTypeInfo(TypeInfo(TTestMethod1)));
  1774. Check(Assigned(t), 'Rtti Type is Nil');
  1775. Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
  1776. Check(t is TRttiMethodType, 'Rtti Type is not a method type');
  1777. m := t as TRttiMethodType;
  1778. Check(m.CallingConvention = ccReg, 'Calling convention does not match');
  1779. Check(Assigned(m.ReturnType), 'Return type is not assigned');
  1780. //Check(p.ReturnType is TRttiOrdinalType, 'Return type is not an ordinal type');
  1781. CheckEquals(0, Length(m.GetParameters), 'Method variable has parameters');
  1782. t := context.GetType(PTypeInfo(TypeInfo(TTestMethod2)));
  1783. Check(Assigned(t), 'Rtti Type is Nil');
  1784. Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
  1785. Check(t is TRttiMethodType, 'Rtti Type is not a method type');
  1786. m := t as TRttiMethodType;
  1787. Check(m.CallingConvention = ccReg, 'Calling convention does not match');
  1788. Check(Assigned(m.ReturnType), 'Return type is not assigned');
  1789. Check(m.ReturnType is TRttiStringType, 'Return type is not a string type');
  1790. params := m.GetParameters;
  1791. CheckEquals(2, Length(params), 'Method variable has incorrect amount of parameters');
  1792. Check(params[0].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 1 is not an ordinal type');
  1793. //Check(params[0].ParamType is TRttiOrdinalType, 'Parameter 1 is not an ordinal type');
  1794. Check(pfArray in params[1].Flags, 'Parameter 2 is not an array');
  1795. Check(params[1].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 2 is not an ordinal array');
  1796. finally
  1797. context.Free;
  1798. end;
  1799. end;
  1800. initialization
  1801. {$ifdef fpc}
  1802. RegisterTest(TTestCase1);
  1803. {$else fpc}
  1804. RegisterTest(TTestCase1.Suite);
  1805. {$endif fpc}
  1806. end.