tests.rtti.pas 47 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446
  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. procedure TestDataSize;
  45. procedure TestDataSizeEmpty;
  46. procedure TestReferenceRawData;
  47. procedure TestReferenceRawDataEmpty;
  48. procedure TestIsManaged;
  49. procedure TestInterface;
  50. {$ifdef fpc}
  51. procedure TestInterfaceRaw;
  52. {$endif}
  53. end;
  54. implementation
  55. type
  56. {$M+}
  57. TGetClassProperties = class
  58. private
  59. FPubPropRO: integer;
  60. FPubPropRW: integer;
  61. published
  62. property PubPropRO: integer read FPubPropRO;
  63. property PubPropRW: integer read FPubPropRW write FPubPropRW;
  64. property PubPropSetRO: integer read FPubPropRO;
  65. property PubPropSetRW: integer read FPubPropRW write FPubPropRW;
  66. end;
  67. TGetClassPropertiesSub = class(TGetClassProperties)
  68. end;
  69. {$M-}
  70. { TTestValueClass }
  71. {$M+}
  72. TTestValueClass = class
  73. private
  74. FAInteger: integer;
  75. FAString: string;
  76. FABoolean: boolean;
  77. FAShortString: ShortString;
  78. function GetAInteger: integer;
  79. function GetAString: string;
  80. function GetABoolean: boolean;
  81. function GetAShortString: ShortString;
  82. procedure SetWriteOnly(AValue: integer);
  83. published
  84. property AInteger: Integer read FAInteger write FAInteger;
  85. property AString: string read FAString write FAString;
  86. property ABoolean: boolean read FABoolean write FABoolean;
  87. property AShortString: ShortString read FAShortString write FAShortString;
  88. property AGetInteger: Integer read GetAInteger;
  89. property AGetString: string read GetAString;
  90. property AGetBoolean: boolean read GetABoolean;
  91. property AGetShortString: ShortString read GetAShortString;
  92. property AWriteOnly: integer write SetWriteOnly;
  93. end;
  94. {$M-}
  95. {$M+}
  96. ITestInterface = interface
  97. procedure Test;
  98. function Test2: LongInt;
  99. procedure Test3(aArg1: LongInt; const aArg2: AnsiString; var aArg3: Boolean; out aArg4: Word);
  100. function Test4(aArg1: array of LongInt; aArg2: array of const): AnsiString;
  101. end;
  102. {$M-}
  103. TManagedRec = record
  104. s: string;
  105. end;
  106. {$ifdef fpc}
  107. TManagedRecOp = record
  108. class operator AddRef(var a: TManagedRecOp);
  109. end;
  110. {$endif}
  111. TNonManagedRec = record
  112. i: Integer;
  113. end;
  114. TManagedObj = object
  115. i: IInterface;
  116. end;
  117. TNonManagedObj = object
  118. d: double;
  119. end;
  120. TTestEnum = (te1, te2, te3, te4, te5);
  121. TTestSet = set of TTestEnum;
  122. TTestProc = procedure;
  123. TTestMethod = procedure of object;
  124. TTestHelper = class helper for TObject
  125. end;
  126. TArrayOfString = array[0..0] of string;
  127. TArrayOfManagedRec = array[0..0] of TManagedRec;
  128. TArrayOfNonManagedRec = array[0..0] of TNonManagedRec;
  129. TArrayOfByte = array[0..0] of byte;
  130. TArrayOfLongintDyn = array of LongInt;
  131. TArrayOfLongintStatic = array[0..3] of LongInt;
  132. TTestRecord = record
  133. Value1: LongInt;
  134. Value2: String;
  135. end;
  136. PTestRecord = ^TTestRecord;
  137. {$ifdef fpc}
  138. {$PUSH}
  139. {$INTERFACES CORBA}
  140. ICORBATest = interface
  141. end;
  142. {$POP}
  143. {$endif}
  144. {$ifdef fpc}
  145. class operator TManagedRecOp.AddRef(var a: TManagedRecOp);
  146. begin
  147. end;
  148. {$endif}
  149. { TTestValueClass }
  150. function TTestValueClass.GetAInteger: integer;
  151. begin
  152. result := FAInteger;
  153. end;
  154. function TTestValueClass.GetAString: string;
  155. begin
  156. result := FAString;
  157. end;
  158. function TTestValueClass.GetABoolean: boolean;
  159. begin
  160. result := FABoolean;
  161. end;
  162. function TTestValueClass.GetAShortString: ShortString;
  163. begin
  164. Result := FAShortString;
  165. end;
  166. procedure TTestValueClass.SetWriteOnly(AValue: integer);
  167. begin
  168. // Do nothing
  169. end;
  170. { Note: GetTypes currently only returns those types that had been acquired using
  171. GetType, so GetTypes itself can't be really tested currently }
  172. (*procedure TTestCase1.GetTypes;
  173. var
  174. LContext: TRttiContext;
  175. LType: TRttiType;
  176. IsTestCaseClassFound: boolean;
  177. begin
  178. LContext := TRttiContext.Create;
  179. { Enumerate all types declared in the application }
  180. for LType in LContext.GetTypes() do
  181. begin
  182. if LType.Name='TTestCase1' then
  183. IsTestCaseClassFound:=true;
  184. end;
  185. LContext.Free;
  186. CheckTrue(IsTestCaseClassFound, 'RTTI information does not contain class of testcase.');
  187. end;*)
  188. procedure TTestCase1.TestGetValueStringCastError;
  189. var
  190. ATestClass : TTestValueClass;
  191. c: TRttiContext;
  192. ARttiType: TRttiType;
  193. AValue: TValue;
  194. i: integer;
  195. HadException: boolean;
  196. begin
  197. c := TRttiContext.Create;
  198. try
  199. ATestClass := TTestValueClass.Create;
  200. ATestClass.AString := '12';
  201. try
  202. ARttiType := c.GetType(ATestClass.ClassInfo);
  203. AValue := ARttiType.GetProperty('astring').GetValue(ATestClass);
  204. HadException := false;
  205. try
  206. i := AValue.AsInteger;
  207. except
  208. on E: Exception do
  209. if E.ClassType=EInvalidCast then
  210. HadException := true;
  211. end;
  212. Check(HadException, 'No or invalid exception on invalid cast');
  213. finally
  214. AtestClass.Free;
  215. end;
  216. finally
  217. c.Free;
  218. end;
  219. end;
  220. procedure TTestCase1.TestMakeNil;
  221. var
  222. value: TValue;
  223. begin
  224. TValue.Make(Nil, Nil, value);
  225. CheckTrue(value.Kind = tkUnknown);
  226. CheckTrue(value.IsEmpty);
  227. CheckTrue(value.IsObject);
  228. CheckTrue(value.IsClass);
  229. CheckTrue(value.IsOrdinal);
  230. CheckFalse(value.IsArray);
  231. CheckTrue(value.AsObject = Nil);
  232. CheckTrue(value.AsClass = Nil);
  233. CheckTrue(value.AsInterface = Nil);
  234. CheckEquals(0, value.AsOrdinal);
  235. TValue.Make(Nil, TypeInfo(TObject), value);
  236. CheckTrue(value.IsEmpty);
  237. CheckTrue(value.IsObject);
  238. CheckTrue(value.IsClass);
  239. CheckTrue(value.IsOrdinal);
  240. CheckFalse(value.IsArray);
  241. CheckTrue(value.AsObject=Nil);
  242. CheckTrue(value.AsClass=Nil);
  243. CheckTrue(value.AsInterface=Nil);
  244. CheckEquals(0, value.AsOrdinal);
  245. TValue.Make(Nil, TypeInfo(TClass), value);
  246. CheckTrue(value.IsEmpty);
  247. CheckTrue(value.IsClass);
  248. CheckTrue(value.IsOrdinal);
  249. CheckFalse(value.IsArray);
  250. CheckTrue(value.AsObject=Nil);
  251. CheckTrue(value.AsClass=Nil);
  252. CheckTrue(value.AsInterface=Nil);
  253. CheckEquals(0, value.AsOrdinal);
  254. TValue.Make(Nil, TypeInfo(LongInt), value);
  255. CheckTrue(value.IsOrdinal);
  256. CheckFalse(value.IsEmpty);
  257. CheckFalse(value.IsClass);
  258. CheckFalse(value.IsObject);
  259. CheckFalse(value.IsArray);
  260. CheckEquals(0, value.AsOrdinal);
  261. CheckEquals(0, value.AsInteger);
  262. CheckEquals(0, value.AsInt64);
  263. CheckEquals(0, value.AsUInt64);
  264. TValue.Make(Nil, TypeInfo(String), value);
  265. CheckFalse(value.IsEmpty);
  266. CheckFalse(value.IsObject);
  267. CheckFalse(value.IsClass);
  268. CheckFalse(value.IsArray);
  269. CheckEquals('', value.AsString);
  270. end;
  271. procedure TTestCase1.TestMakeObject;
  272. var
  273. AValue: TValue;
  274. ATestClass: TTestValueClass;
  275. begin
  276. ATestClass := TTestValueClass.Create;
  277. ATestClass.AInteger := 54329;
  278. TValue.Make(@ATestClass, TypeInfo(TTestValueClass),AValue);
  279. CheckEquals(AValue.IsClass, False);
  280. CheckEquals(AValue.IsObject, True);
  281. Check(AValue.AsObject=ATestClass);
  282. CheckEquals(TTestValueClass(AValue.AsObject).AInteger, 54329);
  283. ATestClass.Free;
  284. end;
  285. procedure TTestCase1.TestMakeArrayDynamic;
  286. var
  287. arr: TArrayOfLongintDyn;
  288. value: TValue;
  289. begin
  290. SetLength(arr, 2);
  291. arr[0] := 42;
  292. arr[1] := 21;
  293. TValue.Make(@arr, TypeInfo(TArrayOfLongintDyn), value);
  294. CheckEquals(value.IsArray, True);
  295. CheckEquals(value.IsObject, False);
  296. CheckEquals(value.IsOrdinal, False);
  297. CheckEquals(value.IsClass, False);
  298. CheckEquals(value.GetArrayLength, 2);
  299. CheckEquals(value.GetArrayElement(0).AsInteger, 42);
  300. CheckEquals(value.GetArrayElement(1).AsInteger, 21);
  301. value.SetArrayElement(0, 84);
  302. CheckEquals(arr[0], 84);
  303. end;
  304. procedure TTestCase1.TestMakeArrayStatic;
  305. type
  306. TArrStat = array[0..1] of LongInt;
  307. TArrStat2D = array[0..1, 0..1] of LongInt;
  308. var
  309. arr: TArrStat;
  310. arr2D: TArrStat2D;
  311. value: TValue;
  312. begin
  313. arr[0] := 42;
  314. arr[1] := 21;
  315. TValue.Make(@arr, TypeInfo(TArrStat), value);
  316. CheckEquals(value.IsArray, True);
  317. CheckEquals(value.IsObject, False);
  318. CheckEquals(value.IsOrdinal, False);
  319. CheckEquals(value.IsClass, False);
  320. CheckEquals(value.GetArrayLength, 2);
  321. CheckEquals(value.GetArrayElement(0).AsInteger, 42);
  322. CheckEquals(value.GetArrayElement(1).AsInteger, 21);
  323. value.SetArrayElement(0, 84);
  324. { since this is a static array the original array isn't touched! }
  325. CheckEquals(arr[0], 42);
  326. arr2D[0, 0] := 42;
  327. arr2D[0, 1] := 21;
  328. arr2D[1, 0] := 84;
  329. arr2D[1, 1] := 63;
  330. TValue.Make(@arr2D, TypeInfo(TArrStat2D), value);
  331. CheckEquals(value.IsArray, True);
  332. CheckEquals(value.GetArrayLength, 4);
  333. CheckEquals(value.GetArrayElement(0).AsInteger, 42);
  334. CheckEquals(value.GetArrayElement(1).AsInteger, 21);
  335. CheckEquals(value.GetArrayElement(2).AsInteger, 84);
  336. CheckEquals(value.GetArrayElement(3).AsInteger, 63);
  337. end;
  338. procedure TTestCase1.TestGetIsReadable;
  339. var
  340. c: TRttiContext;
  341. ARttiType: TRttiType;
  342. AProperty: TRttiProperty;
  343. begin
  344. c := TRttiContext.Create;
  345. try
  346. ARttiType := c.GetType(TTestValueClass);
  347. AProperty := ARttiType.GetProperty('aBoolean');
  348. CheckEquals(AProperty.IsReadable, true);
  349. AProperty := ARttiType.GetProperty('aGetBoolean');
  350. CheckEquals(AProperty.IsReadable, true);
  351. AProperty := ARttiType.GetProperty('aWriteOnly');
  352. CheckEquals(AProperty.IsReadable, False);
  353. finally
  354. c.Free;
  355. end;
  356. end;
  357. procedure TTestCase1.TestIsWritable;
  358. var
  359. c: TRttiContext;
  360. ARttiType: TRttiType;
  361. AProperty: TRttiProperty;
  362. begin
  363. c := TRttiContext.Create;
  364. try
  365. ARttiType := c.GetType(TTestValueClass);
  366. AProperty := ARttiType.GetProperty('aBoolean');
  367. CheckEquals(AProperty.IsWritable, true);
  368. AProperty := ARttiType.GetProperty('aGetBoolean');
  369. CheckEquals(AProperty.IsWritable, false);
  370. AProperty := ARttiType.GetProperty('aWriteOnly');
  371. CheckEquals(AProperty.IsWritable, True);
  372. finally
  373. c.Free;
  374. end;
  375. end;
  376. procedure TTestCase1.TestPropGetValueBoolean;
  377. var
  378. ATestClass : TTestValueClass;
  379. c: TRttiContext;
  380. ARttiType: TRttiType;
  381. AProperty: TRttiProperty;
  382. AValue: TValue;
  383. begin
  384. c := TRttiContext.Create;
  385. try
  386. ATestClass := TTestValueClass.Create;
  387. ATestClass.ABoolean := true;
  388. try
  389. ARttiType := c.GetType(ATestClass.ClassInfo);
  390. Check(assigned(ARttiType));
  391. AProperty := ARttiType.GetProperty('aBoolean');
  392. AValue := AProperty.GetValue(ATestClass);
  393. CheckEquals(true,AValue.AsBoolean);
  394. ATestClass.ABoolean := false;
  395. CheckEquals(true, AValue.AsBoolean);
  396. CheckEquals('True', AValue.ToString);
  397. CheckEquals(True, AValue.IsOrdinal);
  398. CheckEquals(1, AValue.AsOrdinal);
  399. finally
  400. AtestClass.Free;
  401. end;
  402. CheckEquals(True,AValue.AsBoolean);
  403. finally
  404. c.Free;
  405. end;
  406. end;
  407. procedure TTestCase1.TestPropGetValueShortString;
  408. var
  409. ATestClass : TTestValueClass;
  410. c: TRttiContext;
  411. ARttiType: TRttiType;
  412. AProperty: TRttiProperty;
  413. AValue: TValue;
  414. begin
  415. c := TRttiContext.Create;
  416. try
  417. ATestClass := TTestValueClass.Create;
  418. ATestClass.AShortString := 'Hello World';
  419. try
  420. ARttiType := c.GetType(ATestClass.ClassInfo);
  421. Check(assigned(ARttiType));
  422. AProperty := ARttiType.GetProperty('aShortString');
  423. AValue := AProperty.GetValue(ATestClass);
  424. CheckEquals('Hello World',AValue.AsString);
  425. ATestClass.AShortString := 'Foobar';
  426. CheckEquals('Hello World', AValue.AsString);
  427. CheckEquals(False, AValue.IsOrdinal);
  428. CheckEquals(False, AValue.IsObject);
  429. CheckEquals(False, AValue.IsArray);
  430. CheckEquals(False, AValue.IsClass);
  431. finally
  432. AtestClass.Free;
  433. end;
  434. CheckEquals('Hello World',AValue.AsString);
  435. finally
  436. c.Free;
  437. end;
  438. end;
  439. procedure TTestCase1.TestPropGetValueInteger;
  440. var
  441. ATestClass : TTestValueClass;
  442. c: TRttiContext;
  443. ARttiType: TRttiType;
  444. AProperty: TRttiProperty;
  445. AValue: TValue;
  446. begin
  447. c := TRttiContext.Create;
  448. try
  449. ATestClass := TTestValueClass.Create;
  450. ATestClass.AInteger := 472349;
  451. try
  452. ARttiType := c.GetType(ATestClass.ClassInfo);
  453. Check(assigned(ARttiType));
  454. AProperty := ARttiType.GetProperty('ainteger');
  455. AValue := AProperty.GetValue(ATestClass);
  456. CheckEquals(472349,AValue.AsInteger);
  457. ATestClass.AInteger := 12;
  458. CheckEquals(472349, AValue.AsInteger);
  459. CheckEquals('472349', AValue.ToString);
  460. CheckEquals(True, AValue.IsOrdinal);
  461. finally
  462. AtestClass.Free;
  463. end;
  464. CheckEquals(472349,AValue.AsInteger);
  465. finally
  466. c.Free;
  467. end;
  468. end;
  469. procedure TTestCase1.TestPropGetValueString;
  470. var
  471. ATestClass : TTestValueClass;
  472. c: TRttiContext;
  473. ARttiType: TRttiType;
  474. AProperty: TRttiProperty;
  475. AValue: TValue;
  476. i: int64;
  477. begin
  478. c := TRttiContext.Create;
  479. try
  480. ATestClass := TTestValueClass.Create;
  481. ATestClass.AString := 'Hello World';
  482. try
  483. ARttiType := c.GetType(ATestClass.ClassInfo);
  484. Check(assigned(ARttiType));
  485. AProperty := ARttiType.GetProperty('astring');
  486. AValue := AProperty.GetValue(ATestClass);
  487. CheckEquals('Hello World',AValue.AsString);
  488. ATestClass.AString := 'Goodbye World';
  489. CheckEquals('Hello World',AValue.AsString);
  490. CheckEquals('Hello World',AValue.ToString);
  491. Check(TypeInfo(string)=AValue.TypeInfo);
  492. Check(AValue.TypeData=GetTypeData(AValue.TypeInfo));
  493. Check(AValue.IsEmpty=false);
  494. Check(AValue.IsObject=false);
  495. Check(AValue.IsClass=false);
  496. CheckEquals(AValue.IsOrdinal, false);
  497. CheckEquals(AValue.TryAsOrdinal(i), false);
  498. CheckEquals(AValue.IsType(TypeInfo(string)), true);
  499. CheckEquals(AValue.IsType(TypeInfo(integer)), false);
  500. CheckEquals(AValue.IsArray, false);
  501. finally
  502. AtestClass.Free;
  503. end;
  504. CheckEquals('Hello World',AValue.AsString);
  505. finally
  506. c.Free;
  507. end;
  508. end;
  509. procedure TTestCase1.TestPropGetValueProcBoolean;
  510. var
  511. ATestClass : TTestValueClass;
  512. c: TRttiContext;
  513. ARttiType: TRttiType;
  514. AProperty: TRttiProperty;
  515. AValue: TValue;
  516. begin
  517. c := TRttiContext.Create;
  518. try
  519. ATestClass := TTestValueClass.Create;
  520. ATestClass.ABoolean := true;
  521. try
  522. ARttiType := c.GetType(ATestClass.ClassInfo);
  523. Check(assigned(ARttiType));
  524. AProperty := ARttiType.GetProperty('aGetBoolean');
  525. AValue := AProperty.GetValue(ATestClass);
  526. CheckEquals(true,AValue.AsBoolean);
  527. finally
  528. AtestClass.Free;
  529. end;
  530. CheckEquals(True,AValue.AsBoolean);
  531. finally
  532. c.Free;
  533. end;
  534. end;
  535. procedure TTestCase1.TestPropGetValueProcShortString;
  536. var
  537. ATestClass : TTestValueClass;
  538. c: TRttiContext;
  539. ARttiType: TRttiType;
  540. AProperty: TRttiProperty;
  541. AValue: TValue;
  542. begin
  543. c := TRttiContext.Create;
  544. try
  545. ATestClass := TTestValueClass.Create;
  546. ATestClass.AShortString := 'Hello World';
  547. try
  548. ARttiType := c.GetType(ATestClass.ClassInfo);
  549. Check(assigned(ARttiType));
  550. AProperty := ARttiType.GetProperty('aGetShortString');
  551. AValue := AProperty.GetValue(ATestClass);
  552. CheckEquals('Hello World',AValue.AsString);
  553. finally
  554. AtestClass.Free;
  555. end;
  556. CheckEquals('Hello World',AValue.AsString);
  557. finally
  558. c.Free;
  559. end;
  560. end;
  561. procedure TTestCase1.TestPropSetValueString;
  562. var
  563. ATestClass : TTestValueClass;
  564. c: TRttiContext;
  565. ARttiType: TRttiType;
  566. AProperty: TRttiProperty;
  567. AValue: TValue;
  568. s: string;
  569. begin
  570. c := TRttiContext.Create;
  571. try
  572. ATestClass := TTestValueClass.Create;
  573. try
  574. ARttiType := c.GetType(ATestClass.ClassInfo);
  575. AProperty := ARttiType.GetProperty('astring');
  576. s := 'ipse lorem or something like that';
  577. TValue.Make(@s, TypeInfo(string), AValue);
  578. AProperty.SetValue(ATestClass, AValue);
  579. CheckEquals(ATestClass.AString, s);
  580. s := 'Another string';
  581. CheckEquals(ATestClass.AString, 'ipse lorem or something like that');
  582. finally
  583. AtestClass.Free;
  584. end;
  585. finally
  586. c.Free;
  587. end;
  588. end;
  589. procedure TTestCase1.TestPropSetValueInteger;
  590. var
  591. ATestClass : TTestValueClass;
  592. c: TRttiContext;
  593. ARttiType: TRttiType;
  594. AProperty: TRttiProperty;
  595. AValue: TValue;
  596. i: integer;
  597. begin
  598. c := TRttiContext.Create;
  599. try
  600. ATestClass := TTestValueClass.Create;
  601. try
  602. ARttiType := c.GetType(ATestClass.ClassInfo);
  603. AProperty := ARttiType.GetProperty('aInteger');
  604. i := -43573;
  605. TValue.Make(@i, TypeInfo(Integer), AValue);
  606. AProperty.SetValue(ATestClass, AValue);
  607. CheckEquals(ATestClass.AInteger, i);
  608. i := 1;
  609. CheckEquals(ATestClass.AInteger, -43573);
  610. finally
  611. AtestClass.Free;
  612. end;
  613. finally
  614. c.Free;
  615. end;
  616. end;
  617. procedure TTestCase1.TestPropSetValueBoolean;
  618. var
  619. ATestClass : TTestValueClass;
  620. c: TRttiContext;
  621. ARttiType: TRttiType;
  622. AProperty: TRttiProperty;
  623. AValue: TValue;
  624. b: boolean;
  625. begin
  626. c := TRttiContext.Create;
  627. try
  628. ATestClass := TTestValueClass.Create;
  629. try
  630. ARttiType := c.GetType(ATestClass.ClassInfo);
  631. AProperty := ARttiType.GetProperty('aboolean');
  632. b := true;
  633. TValue.Make(@b, TypeInfo(Boolean), AValue);
  634. AProperty.SetValue(ATestClass, AValue);
  635. CheckEquals(ATestClass.ABoolean, b);
  636. b := false;
  637. CheckEquals(ATestClass.ABoolean, true);
  638. TValue.Make(@b, TypeInfo(Boolean), AValue);
  639. AProperty.SetValue(ATestClass, AValue);
  640. CheckEquals(ATestClass.ABoolean, false);
  641. finally
  642. AtestClass.Free;
  643. end;
  644. finally
  645. c.Free;
  646. end;
  647. end;
  648. procedure TTestCase1.TestPropSetValueShortString;
  649. var
  650. ATestClass : TTestValueClass;
  651. c: TRttiContext;
  652. ARttiType: TRttiType;
  653. AProperty: TRttiProperty;
  654. AValue: TValue;
  655. s: string;
  656. ss: ShortString;
  657. begin
  658. c := TRttiContext.Create;
  659. try
  660. ATestClass := TTestValueClass.Create;
  661. try
  662. ARttiType := c.GetType(ATestClass.ClassInfo);
  663. AProperty := ARttiType.GetProperty('aShortString');
  664. s := 'ipse lorem or something like that';
  665. TValue.Make(@s, TypeInfo(String), AValue);
  666. AProperty.SetValue(ATestClass, AValue);
  667. CheckEquals(ATestClass.AShortString, s);
  668. s := 'Another string';
  669. CheckEquals(ATestClass.AShortString, 'ipse lorem or something like that');
  670. ss := 'Hello World';
  671. TValue.Make(@ss, TypeInfo(ShortString), AValue);
  672. AProperty.SetValue(ATestClass, AValue);
  673. CheckEquals(ATestClass.AShortString, ss);
  674. ss := 'Foobar';
  675. CheckEquals(ATestClass.AShortString, 'Hello World');
  676. finally
  677. AtestClass.Free;
  678. end;
  679. finally
  680. c.Free;
  681. end;
  682. end;
  683. procedure TTestCase1.TestPropGetValueProcInteger;
  684. var
  685. ATestClass : TTestValueClass;
  686. c: TRttiContext;
  687. ARttiType: TRttiType;
  688. AProperty: TRttiProperty;
  689. AValue: TValue;
  690. begin
  691. c := TRttiContext.Create;
  692. try
  693. ATestClass := TTestValueClass.Create;
  694. ATestClass.AInteger := 472349;
  695. try
  696. ARttiType := c.GetType(ATestClass.ClassInfo);
  697. Check(assigned(ARttiType));
  698. AProperty := ARttiType.GetProperty('agetinteger');
  699. AValue := AProperty.GetValue(ATestClass);
  700. CheckEquals(472349,AValue.AsInteger);
  701. finally
  702. AtestClass.Free;
  703. end;
  704. CheckEquals(472349,AValue.AsInteger);
  705. finally
  706. c.Free;
  707. end;
  708. end;
  709. procedure TTestCase1.TestPropGetValueProcString;
  710. var
  711. ATestClass : TTestValueClass;
  712. c: TRttiContext;
  713. ARttiType: TRttiType;
  714. AProperty: TRttiProperty;
  715. AValue: TValue;
  716. begin
  717. c := TRttiContext.Create;
  718. try
  719. ATestClass := TTestValueClass.Create;
  720. ATestClass.AString := 'Hello World';
  721. try
  722. ARttiType := c.GetType(ATestClass.ClassInfo);
  723. Check(assigned(ARttiType));
  724. AProperty := ARttiType.GetProperty('agetstring');
  725. AValue := AProperty.GetValue(ATestClass);
  726. CheckEquals('Hello World',AValue.AsString);
  727. finally
  728. AtestClass.Free;
  729. end;
  730. CheckEquals('Hello World',AValue.AsString);
  731. finally
  732. c.Free;
  733. end;
  734. end;
  735. procedure TTestCase1.TestTRttiTypeProperties;
  736. var
  737. c: TRttiContext;
  738. ARttiType: TRttiType;
  739. begin
  740. c := TRttiContext.Create;
  741. try
  742. ARttiType := c.GetType(TTestValueClass);
  743. Check(assigned(ARttiType));
  744. CheckEquals(ARttiType.Name,'TTestValueClass');
  745. Check(ARttiType.TypeKind=tkClass);
  746. // CheckEquals(ARttiType.IsPublicType,false);
  747. CheckEquals(ARttiType.TypeSize,SizeOf(TObject));
  748. CheckEquals(ARttiType.IsManaged,false);
  749. CheckEquals(ARttiType.BaseType.classname,'TRttiInstanceType');
  750. CheckEquals(ARttiType.IsInstance,True);
  751. CheckEquals(ARttiType.AsInstance.DeclaringUnitName,'tests.rtti');
  752. Check(ARttiType.BaseType.Name='TObject');
  753. Check(ARttiType.AsInstance.BaseType.Name='TObject');
  754. CheckEquals(ARttiType.IsOrdinal,False);
  755. CheckEquals(ARttiType.IsRecord,False);
  756. CheckEquals(ARttiType.IsSet,False);
  757. finally
  758. c.Free;
  759. end;
  760. end;
  761. procedure TTestCase1.GetTypeInteger;
  762. var
  763. LContext: TRttiContext;
  764. LType: TRttiType;
  765. begin
  766. LContext := TRttiContext.Create;
  767. LType := LContext.GetType(TypeInfo(integer));
  768. {$ifdef fpc}
  769. CheckEquals(LType.Name, 'LongInt');
  770. {$else}
  771. CheckEquals(LType.Name, 'Integer');
  772. {$endif}
  773. LContext.Free;
  774. end;
  775. procedure TTestCase1.GetTypePointer;
  776. var
  777. context: TRttiContext;
  778. t: TRttiType;
  779. p: TRttiPointerType absolute t;
  780. begin
  781. context := TRttiContext.Create;
  782. try
  783. t := context.GetType(TypeInfo(Pointer));
  784. Assert(t is TRttiPointerType, 'Type of Pointer is not a TRttiPointerType');
  785. Assert(not Assigned(p.ReferredType), 'ReferredType of Pointer is not Nil');
  786. t := context.GetType(TypeInfo(PLongInt));
  787. Assert(t is TRttiPointerType, 'Type of Pointer is not a TRttiPointerType');
  788. Assert(Assigned(p.ReferredType), 'ReferredType of PLongInt is Nil');
  789. Assert(p.ReferredType = context.GetType(TypeInfo(LongInt)), 'ReferredType of PLongInt is not a LongInt');
  790. t := context.GetType(TypeInfo(PWideChar));
  791. Assert(t is TRttiPointerType, 'Type of Pointer is not a TRttiPointerType');
  792. Assert(Assigned(p.ReferredType), 'ReferredType of PWideChar is Nil');
  793. Assert(p.ReferredType = context.GetType(TypeInfo(WideChar)), 'ReferredType of PWideChar is not a WideChar');
  794. finally
  795. context.Free;
  796. end;
  797. end;
  798. procedure TTestCase1.GetClassProperties;
  799. var
  800. LContext: TRttiContext;
  801. LType: TRttiType;
  802. PropList, PropList2: {$ifdef fpc}specialize{$endif} TArray<TRttiProperty>;
  803. i: LongInt;
  804. begin
  805. LContext := TRttiContext.Create;
  806. LType := LContext.GetType(TypeInfo(TGetClassProperties));
  807. PropList := LType.GetProperties;
  808. CheckEquals(4, length(PropList));
  809. CheckEquals('PubPropRO', PropList[0].Name);
  810. CheckEquals('PubPropRW', PropList[1].Name);
  811. CheckEquals('PubPropSetRO', PropList[2].Name);
  812. CheckEquals('PubPropSetRW', PropList[3].Name);
  813. LType := LContext.GetType(TypeInfo(TGetClassPropertiesSub));
  814. PropList2 := LType.GetProperties;
  815. CheckEquals(Length(PropList), Length(PropList2));
  816. for i := 0 to High(PropList) do
  817. Check(PropList[i] = PropList2[i], 'Property instances are not equal');
  818. LContext.Free;
  819. end;
  820. procedure TTestCase1.GetClassPropertiesValue;
  821. var
  822. AGetClassProperties: TGetClassProperties;
  823. LContext: TRttiContext;
  824. LType: TRttiType;
  825. AValue: TValue;
  826. begin
  827. LContext := TRttiContext.Create;
  828. LType := LContext.GetType(TGetClassProperties);
  829. AGetClassProperties := TGetClassProperties.Create;
  830. try
  831. AGetClassProperties.PubPropRW:=12345;
  832. AValue := LType.GetProperty('PubPropRW').GetValue(AGetClassProperties);
  833. CheckEquals(12345, AValue.AsInteger);
  834. finally
  835. AGetClassProperties.Free;
  836. end;
  837. LContext.Free;
  838. end;
  839. procedure TTestCase1.TestReferenceRawData;
  840. var
  841. value: TValue;
  842. str: String;
  843. intf: IInterface;
  844. i: LongInt;
  845. test: TTestRecord;
  846. arrdyn: TArrayOfLongintDyn;
  847. arrstat: TArrayOfLongintStatic;
  848. begin
  849. str := 'Hello World';
  850. UniqueString(str);
  851. TValue.Make(@str, TypeInfo(String), value);
  852. Check(PPointer(value.GetReferenceToRawData)^ = Pointer(str), 'Reference to string data differs');
  853. intf := TInterfacedObject.Create;
  854. TValue.Make(@intf, TypeInfo(IInterface), value);
  855. Check(PPointer(value.GetReferenceToRawData)^ = Pointer(intf), 'Reference to interface data differs');
  856. i := 42;
  857. TValue.Make(@i, TypeInfo(LongInt), value);
  858. Check(value.GetReferenceToRawData <> @i, 'Reference to longint is equal');
  859. Check(PLongInt(value.GetReferenceToRawData)^ = PLongInt(@i)^, 'Reference to longint data differs');
  860. test.value1 := 42;
  861. test.value2 := 'Hello World';
  862. TValue.Make(@test, TypeInfo(TTestRecord), value);
  863. Check(value.GetReferenceToRawData <> @test, 'Reference to record is equal');
  864. Check(PTestRecord(value.GetReferenceToRawData)^.value1 = PTestRecord(@test)^.value1, 'Reference to record data value1 differs');
  865. Check(PTestRecord(value.GetReferenceToRawData)^.value2 = PTestRecord(@test)^.value2, 'Reference to record data value2 differs');
  866. SetLength(arrdyn, 3);
  867. arrdyn[0] := 42;
  868. arrdyn[1] := 23;
  869. arrdyn[2] := 49;
  870. TValue.Make(@arrdyn, TypeInfo(TArrayOfLongintDyn), value);
  871. Check(PPointer(value.GetReferenceToRawData)^ = Pointer(arrdyn), 'Reference to dynamic array data differs');
  872. arrstat[0] := 42;
  873. arrstat[1] := 23;
  874. arrstat[2] := 49;
  875. arrstat[3] := 59;
  876. TValue.Make(@arrstat, TypeInfo(TArrayOfLongintStatic), value);
  877. Check(value.GetReferenceToRawData <> @arrstat, 'Reference to static array is equal');
  878. Check(PLongInt(value.GetReferenceToRawData)^ = PLongInt(@arrstat)^, 'Reference to static array data differs');
  879. end;
  880. procedure TTestCase1.TestReferenceRawDataEmpty;
  881. var
  882. value: TValue;
  883. begin
  884. TValue.Make(Nil, TypeInfo(String), value);
  885. Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty String is not assigned');
  886. Check(not Assigned(PPointer(value.GetReferenceToRawData)^), 'Empty String data is assigned');
  887. TValue.Make(Nil, TypeInfo(IInterface), value);
  888. Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty interface is not assigned');
  889. Check(not Assigned(PPointer(value.GetReferenceToRawData)^), 'Empty interface data is assigned');
  890. TValue.Make(Nil, TypeInfo(LongInt), value);
  891. Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty LongInt is not assigned');
  892. Check(PLongInt(value.GetReferenceToRawData)^ = 0, 'Empty longint data is not 0');
  893. TValue.Make(Nil, TypeInfo(TTestRecord), value);
  894. Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty record is not assigned');
  895. Check(PTestRecord(value.GetReferenceToRawData)^.value1 = 0, 'Empty record data value1 is not 0');
  896. Check(PTestRecord(value.GetReferenceToRawData)^.value2 = '', 'Empty record data value2 is not empty');
  897. TValue.Make(Nil, TypeInfo(TArrayOfLongintDyn), value);
  898. Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty dynamic array is not assigned');
  899. Check(not Assigned(PPointer(value.GetReferenceToRawData)^), 'Empty dynamic array data is assigned');
  900. TValue.Make(Nil, TypeInfo(TArrayOfLongintStatic), value);
  901. Check(Assigned(value.GetReferenceToRawData()), 'Reference to empty static array is not assigned');
  902. Check(PLongInt(value.GetReferenceToRawData)^ = 0, 'Empty static array data is not 0');
  903. end;
  904. procedure TTestCase1.TestDataSize;
  905. var
  906. u8: UInt8;
  907. u16: UInt16;
  908. u32: UInt32;
  909. u64: UInt64;
  910. s8: Int8;
  911. s16: Int16;
  912. s32: Int32;
  913. s64: Int64;
  914. f32: Single;
  915. f64: Double;
  916. {$ifdef FPC_HAS_TYPE_EXTENDED}
  917. f80: Extended;
  918. {$endif}
  919. fco: Comp;
  920. fcu: Currency;
  921. ss: ShortString;
  922. sa: AnsiString;
  923. su: UnicodeString;
  924. sw: WideString;
  925. o: TObject;
  926. c: TClass;
  927. i: IInterface;
  928. ad: TArrayOfLongintDyn;
  929. _as: TArrayOfLongintStatic;
  930. b8: Boolean;
  931. {$ifdef fpc}
  932. b16: Boolean16;
  933. b32: Boolean32;
  934. b64: Boolean64;
  935. {$endif}
  936. bl8: ByteBool;
  937. bl16: WordBool;
  938. bl32: LongBool;
  939. {$ifdef fpc}
  940. bl64: QWordBool;
  941. {$endif}
  942. e: TTestEnum;
  943. s: TTestSet;
  944. t: TTestRecord;
  945. p: Pointer;
  946. proc: TTestProc;
  947. method: TTestMethod;
  948. value: TValue;
  949. begin
  950. TValue.Make(@u8, TypeInfo(UInt8), value);
  951. CheckEquals(1, value.DataSize, 'Size of UInt8 differs');
  952. TValue.Make(@u16, TypeInfo(UInt16), value);
  953. CheckEquals(2, value.DataSize, 'Size of UInt16 differs');
  954. TValue.Make(@u32, TypeInfo(UInt32), value);
  955. CheckEquals(4, value.DataSize, 'Size of UInt32 differs');
  956. TValue.Make(@u64, TypeInfo(UInt64), value);
  957. CheckEquals(8, value.DataSize, 'Size of UInt64 differs');
  958. TValue.Make(@s8, TypeInfo(Int8), value);
  959. CheckEquals(1, value.DataSize, 'Size of Int8 differs');
  960. TValue.Make(@s16, TypeInfo(Int16), value);
  961. CheckEquals(2, value.DataSize, 'Size of Int16 differs');
  962. TValue.Make(@s32, TypeInfo(Int32), value);
  963. CheckEquals(4, value.DataSize, 'Size of Int32 differs');
  964. TValue.Make(@s64, TypeInfo(Int64), value);
  965. CheckEquals(8, value.DataSize, 'Size of Int64 differs');
  966. TValue.Make(@b8, TypeInfo(Boolean), value);
  967. CheckEquals(1, value.DataSize, 'Size of Boolean differs');
  968. {$ifdef fpc}
  969. TValue.Make(@b16, TypeInfo(Boolean16), value);
  970. CheckEquals(2, value.DataSize, 'Size of Boolean16 differs');
  971. TValue.Make(@b32, TypeInfo(Boolean32), value);
  972. CheckEquals(4, value.DataSize, 'Size of Boolean32 differs');
  973. TValue.Make(@b64, TypeInfo(Boolean64), value);
  974. CheckEquals(8, value.DataSize, 'Size of Boolean64 differs');
  975. {$endif}
  976. TValue.Make(@bl8, TypeInfo(ByteBool), value);
  977. CheckEquals(1, value.DataSize, 'Size of ByteBool differs');
  978. TValue.Make(@bl16, TypeInfo(WordBool), value);
  979. CheckEquals(2, value.DataSize, 'Size of WordBool differs');
  980. TValue.Make(@bl32, TypeInfo(LongBool), value);
  981. CheckEquals(4, value.DataSize, 'Size of LongBool differs');
  982. {$ifdef fpc}
  983. TValue.Make(@bl64, TypeInfo(QWordBool), value);
  984. CheckEquals(8, value.DataSize, 'Size of QWordBool differs');
  985. {$endif}
  986. TValue.Make(@f32, TypeInfo(Single), value);
  987. CheckEquals(4, value.DataSize, 'Size of Single differs');
  988. TValue.Make(@f64, TypeInfo(Double), value);
  989. CheckEquals(8, value.DataSize, 'Size of Double differs');
  990. {$ifdef FPC_HAS_TYPE_EXTENDED}
  991. TValue.Make(@f80, TypeInfo(Extended), value);
  992. CheckEquals(10, value.DataSize, 'Size of Extended differs');
  993. {$endif}
  994. TValue.Make(@fcu, TypeInfo(Currency), value);
  995. CheckEquals(SizeOf(Currency), value.DataSize, 'Size of Currency differs');
  996. TValue.Make(@fco, TypeInfo(Comp), value);
  997. CheckEquals(SizeOf(Comp), value.DataSize, 'Size of Comp differs');
  998. ss := '';
  999. TValue.Make(@ss, TypeInfo(ShortString), value);
  1000. CheckEquals(254, value.DataSize, 'Size ofShortString differs');
  1001. TValue.Make(@sa, TypeInfo(AnsiString), value);
  1002. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of AnsiString differs');
  1003. TValue.Make(@sw, TypeInfo(WideString), value);
  1004. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of WideString differs');
  1005. TValue.Make(@su, TypeInfo(UnicodeString), value);
  1006. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of UnicodeString differs');
  1007. o := TTestValueClass.Create;
  1008. TValue.Make(@o, TypeInfo(TObject), value);
  1009. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TObject differs');
  1010. o.Free;
  1011. c := TObject;
  1012. TValue.Make(@c, TypeInfo(TClass), value);
  1013. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TClass differs');
  1014. TValue.Make(@i, TypeInfo(IInterface), value);
  1015. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of IInterface differs');
  1016. TValue.Make(@t, TypeInfo(TTestRecord), value);
  1017. CheckEquals(SizeOf(TTestRecord), value.DataSize, 'Size of TTestRecord differs');
  1018. proc := Nil;
  1019. TValue.Make(@proc, TypeInfo(TTestProc), value);
  1020. CheckEquals(SizeOf(TTestProc), value.DataSize, 'Size of TTestProc differs');
  1021. method := Nil;
  1022. TValue.Make(@method, TypeInfo(TTestMethod), value);
  1023. CheckEquals(SizeOf(TTestMethod), value.DataSize, 'Size of TTestMethod differs');
  1024. TValue.Make(@_as, TypeInfo(TArrayOfLongintStatic), value);
  1025. CheckEquals(SizeOf(TArrayOfLongintStatic), value.DataSize, 'Size of TArrayOfLongintStatic differs');
  1026. TValue.Make(@ad, TypeInfo(TArrayOfLongintDyn), value);
  1027. CheckEquals(SizeOf(TArrayOfLongintDyn), value.DataSize, 'Size of TArrayOfLongintDyn differs');
  1028. TValue.Make(@e, TypeInfo(TTestEnum), value);
  1029. CheckEquals(SizeOf(TTestEnum), value.DataSize, 'Size of TTestEnum differs');
  1030. TValue.Make(@s, TypeInfo(TTestSet), value);
  1031. CheckEquals(SizeOf(TTestSet), value.DataSize, 'Size of TTestSet differs');
  1032. p := Nil;
  1033. TValue.Make(@p, TypeInfo(Pointer), value);
  1034. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of Pointer differs');
  1035. end;
  1036. procedure TTestCase1.TestDataSizeEmpty;
  1037. var
  1038. value: TValue;
  1039. begin
  1040. TValue.Make(Nil, TypeInfo(UInt8), value);
  1041. CheckEquals(1, value.DataSize, 'Size of UInt8 differs');
  1042. TValue.Make(Nil, TypeInfo(UInt16), value);
  1043. CheckEquals(2, value.DataSize, 'Size of UInt16 differs');
  1044. TValue.Make(Nil, TypeInfo(UInt32), value);
  1045. CheckEquals(4, value.DataSize, 'Size of UInt32 differs');
  1046. TValue.Make(Nil, TypeInfo(UInt64), value);
  1047. CheckEquals(8, value.DataSize, 'Size of UInt64 differs');
  1048. TValue.Make(Nil, TypeInfo(Int8), value);
  1049. CheckEquals(1, value.DataSize, 'Size of Int8 differs');
  1050. TValue.Make(Nil, TypeInfo(Int16), value);
  1051. CheckEquals(2, value.DataSize, 'Size of Int16 differs');
  1052. TValue.Make(Nil, TypeInfo(Int32), value);
  1053. CheckEquals(4, value.DataSize, 'Size of Int32 differs');
  1054. TValue.Make(Nil, TypeInfo(Int64), value);
  1055. CheckEquals(8, value.DataSize, 'Size of Int64 differs');
  1056. TValue.Make(Nil, TypeInfo(Boolean), value);
  1057. CheckEquals(1, value.DataSize, 'Size of Boolean differs');
  1058. {$ifdef fpc}
  1059. TValue.Make(Nil, TypeInfo(Boolean16), value);
  1060. CheckEquals(2, value.DataSize, 'Size of Boolean16 differs');
  1061. TValue.Make(Nil, TypeInfo(Boolean32), value);
  1062. CheckEquals(4, value.DataSize, 'Size of Boolean32 differs');
  1063. TValue.Make(Nil, TypeInfo(Boolean64), value);
  1064. CheckEquals(8, value.DataSize, 'Size of Boolean64 differs');
  1065. {$endif}
  1066. TValue.Make(Nil, TypeInfo(ByteBool), value);
  1067. CheckEquals(1, value.DataSize, 'Size of ByteBool differs');
  1068. TValue.Make(Nil, TypeInfo(WordBool), value);
  1069. CheckEquals(2, value.DataSize, 'Size of WordBool differs');
  1070. TValue.Make(Nil, TypeInfo(LongBool), value);
  1071. CheckEquals(4, value.DataSize, 'Size of LongBool differs');
  1072. {$ifdef fpc}
  1073. TValue.Make(Nil, TypeInfo(QWordBool), value);
  1074. CheckEquals(8, value.DataSize, 'Size of QWordBool differs');
  1075. {$endif}
  1076. TValue.Make(Nil, TypeInfo(Single), value);
  1077. CheckEquals(4, value.DataSize, 'Size of Single differs');
  1078. TValue.Make(Nil, TypeInfo(Double), value);
  1079. CheckEquals(8, value.DataSize, 'Size of Double differs');
  1080. {$ifdef FPC_HAS_TYPE_EXTENDED}
  1081. TValue.Make(Nil, TypeInfo(Extended), value);
  1082. CheckEquals(10, value.DataSize, 'Size of Extended differs');
  1083. {$endif}
  1084. TValue.Make(Nil, TypeInfo(Currency), value);
  1085. CheckEquals(SizeOf(Currency), value.DataSize, 'Size of Currency differs');
  1086. TValue.Make(Nil, TypeInfo(Comp), value);
  1087. CheckEquals(SizeOf(Comp), value.DataSize, 'Size of Comp differs');
  1088. TValue.Make(Nil, TypeInfo(ShortString), value);
  1089. CheckEquals(254, value.DataSize, 'Size of ShortString differs');
  1090. TValue.Make(Nil, TypeInfo(AnsiString), value);
  1091. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of Pointer differs');
  1092. TValue.Make(Nil, TypeInfo(WideString), value);
  1093. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of WideString differs');
  1094. TValue.Make(Nil, TypeInfo(UnicodeString), value);
  1095. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of UnicodeString differs');
  1096. TValue.Make(Nil, TypeInfo(TObject), value);
  1097. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TObject differs');
  1098. TValue.Make(Nil, TypeInfo(TClass), value);
  1099. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of TClass differs');
  1100. TValue.Make(Nil, TypeInfo(IInterface), value);
  1101. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of IInterface differs');
  1102. TValue.Make(Nil, TypeInfo(TTestRecord), value);
  1103. CheckEquals(SizeOf(TTestRecord), value.DataSize, 'Size of TTestRecord differs');
  1104. TValue.Make(Nil, TypeInfo(TTestProc), value);
  1105. CheckEquals(SizeOf(TTestProc), value.DataSize, 'Size of TTestProc differs');
  1106. TValue.Make(Nil, TypeInfo(TTestMethod), value);
  1107. CheckEquals(SizeOf(TTestMethod), value.DataSize, 'Size of TTestMethod differs');
  1108. TValue.Make(Nil, TypeInfo(TArrayOfLongintStatic), value);
  1109. CheckEquals(SizeOf(TArrayOfLongintStatic), value.DataSize, 'Size of TArrayOfLongintStatic differs');
  1110. TValue.Make(Nil, TypeInfo(TArrayOfLongintDyn), value);
  1111. CheckEquals(SizeOf(TArrayOfLongintDyn), value.DataSize, 'Size of TArrayOfLongintDyn differs');
  1112. TValue.Make(Nil, TypeInfo(TTestEnum), value);
  1113. CheckEquals(SizeOf(TTestEnum), value.DataSize, 'Size of TTestEnum differs');
  1114. TValue.Make(Nil, TypeInfo(TTestSet), value);
  1115. CheckEquals(SizeOf(TTestSet), value.DataSize, 'Size of TTestSet differs');
  1116. TValue.Make(Nil, TypeInfo(Pointer), value);
  1117. CheckEquals(SizeOf(Pointer), value.DataSize, 'Size of Pointer differs');
  1118. end;
  1119. procedure TTestCase1.TestIsManaged;
  1120. begin
  1121. CheckEquals(true, IsManaged(TypeInfo(ansistring)), 'IsManaged for tkAString');
  1122. CheckEquals(true, IsManaged(TypeInfo(widestring)), 'IsManaged for tkWString');
  1123. CheckEquals(true, IsManaged(TypeInfo(Variant)), 'IsManaged for tkVariant');
  1124. CheckEquals(true, IsManaged(TypeInfo(TArrayOfManagedRec)),
  1125. 'IsManaged for tkArray (with managed ElType)');
  1126. CheckEquals(true, IsManaged(TypeInfo(TArrayOfString)),
  1127. 'IsManaged for tkArray (with managed ElType)');
  1128. CheckEquals(true, IsManaged(TypeInfo(TManagedRec)), 'IsManaged for tkRecord');
  1129. {$ifdef fpc}
  1130. CheckEquals(true, IsManaged(TypeInfo(TManagedRecOp)), 'IsManaged for tkRecord');
  1131. {$endif}
  1132. CheckEquals(true, IsManaged(TypeInfo(IInterface)), 'IsManaged for tkInterface');
  1133. CheckEquals(true, IsManaged(TypeInfo(TManagedObj)), 'IsManaged for tkObject');
  1134. {$ifdef fpc}
  1135. CheckEquals(true, IsManaged(TypeInfo(specialize TArray<byte>)), 'IsManaged for tkDynArray');
  1136. {$else}
  1137. CheckEquals(true, IsManaged(TypeInfo(TArray<byte>)), 'IsManaged for tkDynArray');
  1138. {$endif}
  1139. CheckEquals(true, IsManaged(TypeInfo(unicodestring)), 'IsManaged for tkUString');
  1140. CheckEquals(false, IsManaged(TypeInfo(shortstring)), 'IsManaged for tkSString');
  1141. CheckEquals(false, IsManaged(TypeInfo(Byte)), 'IsManaged for tkInteger');
  1142. CheckEquals(false, IsManaged(TypeInfo(Char)), 'IsManaged for tkChar');
  1143. CheckEquals(false, IsManaged(TypeInfo(TTestEnum)), 'IsManaged for tkEnumeration');
  1144. CheckEquals(false, IsManaged(TypeInfo(Single)), 'IsManaged for tkFloat');
  1145. CheckEquals(false, IsManaged(TypeInfo(TTestSet)), 'IsManaged for tkSet');
  1146. {$ifdef fpc}
  1147. CheckEquals(false, IsManaged(TypeInfo(TTestMethod)), 'IsManaged for tkMethod');
  1148. {$else}
  1149. { Delphi bug (or sabotage). For some reason Delphi considers method pointers to be managed (only in newer versions, probably since XE7) :/ }
  1150. CheckEquals({$if RTLVersion>=28}true{$else}false{$endif}, IsManaged(TypeInfo(TTestMethod)), 'IsManaged for tkMethod');
  1151. {$endif}
  1152. CheckEquals(false, IsManaged(TypeInfo(TArrayOfByte)),
  1153. 'IsManaged for tkArray (with non managed ElType)');
  1154. CheckEquals(false, IsManaged(TypeInfo(TArrayOfNonManagedRec)),
  1155. 'IsManaged for tkArray (with non managed ElType)');
  1156. CheckEquals(false, IsManaged(TypeInfo(TNonManagedRec)), 'IsManaged for tkRecord');
  1157. CheckEquals(false, IsManaged(TypeInfo(TObject)), 'IsManaged for tkClass');
  1158. CheckEquals(false, IsManaged(TypeInfo(TNonManagedObj)), 'IsManaged for tkObject');
  1159. CheckEquals(false, IsManaged(TypeInfo(WideChar)), 'IsManaged for tkWChar');
  1160. CheckEquals(false, IsManaged(TypeInfo(Boolean)), 'IsManaged for tkBool');
  1161. CheckEquals(false, IsManaged(TypeInfo(Int64)), 'IsManaged for tkInt64');
  1162. CheckEquals(false, IsManaged(TypeInfo(UInt64)), 'IsManaged for tkQWord');
  1163. {$ifdef fpc}
  1164. CheckEquals(false, IsManaged(TypeInfo(ICORBATest)), 'IsManaged for tkInterfaceRaw');
  1165. {$endif}
  1166. CheckEquals(false, IsManaged(TypeInfo(TTestProc)), 'IsManaged for tkProcVar');
  1167. CheckEquals(false, IsManaged(TypeInfo(TTestHelper)), 'IsManaged for tkHelper');
  1168. {$ifdef fpc}
  1169. CheckEquals(false, IsManaged(TypeInfo(file)), 'IsManaged for tkFile');
  1170. {$endif}
  1171. CheckEquals(false, IsManaged(TypeInfo(TClass)), 'IsManaged for tkClassRef');
  1172. CheckEquals(false, IsManaged(TypeInfo(Pointer)), 'IsManaged for tkPointer');
  1173. CheckEquals(false, IsManaged(nil), 'IsManaged for nil');
  1174. end;
  1175. procedure TTestCase1.TestInterface;
  1176. var
  1177. context: TRttiContext;
  1178. t: TRttiType;
  1179. ti1, ti2: TRttiInterfaceType;
  1180. methods: {$ifdef fpc}specialize{$endif} TArray<TRttiMethod>;
  1181. params: {$ifdef fpc}specialize{$endif} TArray<TRttiParameter>;
  1182. method: TRttiMethod;
  1183. param: TRttiParameter;
  1184. flag: TParamFlag;
  1185. begin
  1186. context := TRttiContext.Create;
  1187. try
  1188. t := context.GetType(TypeInfo(IInterface));
  1189. Check(t is TRttiInterfaceType, 'Type is not an interface type');
  1190. Check(not Assigned(t.BaseType), 'Base type is assigned');
  1191. ti1 := TRttiInterfaceType(t);
  1192. Check(not Assigned(ti1.BaseType), 'Base type is assigned');
  1193. methods := t.GetMethods;
  1194. CheckEquals(0, Length(methods), 'Overall method count does not match');
  1195. methods := t.GetDeclaredMethods;
  1196. CheckEquals(0, Length(methods), 'Declared method conut does not match');
  1197. t := context.GetType(TypeInfo(ITestInterface));
  1198. Check(t is TRttiInterfaceType, 'Type is not an interface type');
  1199. Check(Assigned(t.BaseType), 'Base type is not assigned');
  1200. Check(t.BaseType = TRttiType(ti1), 'Base type does not match');
  1201. ti2 := TRttiInterfaceType(t);
  1202. Check(Assigned(ti2.BaseType), 'Base type is not assigned');
  1203. Check(ti2.BaseType = ti1, 'Base type does not match');
  1204. methods := t.GetMethods;
  1205. CheckEquals(4, Length(methods), 'Overall method count does not match');
  1206. methods := t.GetDeclaredMethods;
  1207. CheckEquals(4, Length(methods), 'Declared method count does not match');
  1208. method := methods[0];
  1209. CheckEquals(method.Name, 'Test', 'Method name of Test does not match');
  1210. Check(method.CallingConvention = ccReg, 'Calling convention of Test does not match');
  1211. Check(method.MethodKind = mkProcedure, 'Method kind of Test does not match');
  1212. Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test does not match');
  1213. Check(not Assigned(method.CodeAddress), 'Code address of Test is not Nil');
  1214. CheckEquals(method.VirtualIndex, 3, 'Virtual index of Test does not match');
  1215. Check(not Assigned(method.ReturnType), 'Return type of Test is not Nil');
  1216. params := method.GetParameters;
  1217. CheckEquals(0, Length(params), 'Parameter count of Test does not match');
  1218. method := methods[1];
  1219. CheckEquals(method.Name, 'Test2', 'Method name of Test2 does not match');
  1220. Check(method.CallingConvention = ccReg, 'Calling convention of Test2 does not match');
  1221. Check(method.MethodKind = mkFunction, 'Method kind of Test2 does not match');
  1222. Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test2 does not match');
  1223. Check(not Assigned(method.CodeAddress), 'Code address of Test2 is not Nil');
  1224. CheckEquals(method.VirtualIndex, 4, 'Virtual index of Test2 does not match');
  1225. Check(Assigned(method.ReturnType), 'Return type of Test2 is Nil');
  1226. Check(method.ReturnType.TypeKind = tkInteger, 'Return type of Test2 is not an ordinal');
  1227. params := method.GetParameters;
  1228. CheckEquals(0, Length(params), 'Parameter count of Test2 does not match');
  1229. method := methods[2];
  1230. CheckEquals(method.Name, 'Test3', 'Method name of Test3 does not match');
  1231. Check(method.CallingConvention = ccReg, 'Calling convention of Test3 does not match');
  1232. Check(method.MethodKind = mkProcedure, 'Method kind of Test3 does not match');
  1233. Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test3 does not match');
  1234. Check(not Assigned(method.CodeAddress), 'Code address of Test3 is not Nil');
  1235. CheckEquals(method.VirtualIndex, 5, 'Virtual index of Test3 does not match');
  1236. Check(not Assigned(method.ReturnType), 'Return type of Test3 is not Nil');
  1237. params := method.GetParameters;
  1238. CheckEquals(4, Length(params), 'Parameter count of Test3 does not match');
  1239. param := params[0];
  1240. CheckEquals(param.Name, 'aArg1', 'Parameter name of Test3.aArg1 does not match');
  1241. Check(param.Flags = [], 'Parameter flags of Test3.aArg1 do not match');
  1242. Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg1 is Nil');
  1243. Check(param.ParamType.TypeKind = tkInteger, 'Parameter type of Test3.aArg1 is not an ordinal');
  1244. param := params[1];
  1245. CheckEquals(param.Name, 'aArg2', 'Parameter name of Test3.aArg2 does not match');
  1246. Check(param.Flags = [pfConst], 'Parameter flags of Test3.aArg2 do not match');
  1247. Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg2 is Nil');
  1248. Check(param.ParamType.TypeKind = tkAnsiString, 'Parameter type of Test3.aArg2 is not a string');
  1249. param := params[2];
  1250. CheckEquals(param.Name, 'aArg3', 'Parameter name of Test3.aArg3 does not match');
  1251. Check(param.Flags = [pfVar], 'Parameter flags of Test3.aArg3 do not match');
  1252. Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg3 is Nil');
  1253. Check(param.ParamType.TypeKind = {$ifdef fpc}tkBool{$else}tkEnumeration{$endif}, 'Parameter type of Test3.aArg3 is not a boolean');
  1254. param := params[3];
  1255. CheckEquals(param.Name, 'aArg4', 'Parameter name of Test3.aArg4 does not match');
  1256. Check(param.Flags = [pfOut], 'Parameter flags of Test3.aArg4 do not match');
  1257. Check(Assigned(param.ParamType), 'Parameter type of Test3.aArg4 is Nil');
  1258. Check(param.ParamType.TypeKind = tkInteger, 'Parameter type of Test3.aArg4 is not a string');
  1259. method := methods[3];
  1260. CheckEquals(method.Name, 'Test4', 'Method name of Test4 does not match');
  1261. Check(method.CallingConvention = ccReg, 'Calling convention of Test4 does not match');
  1262. Check(method.MethodKind = mkFunction, 'Method kind of Test4 does not match');
  1263. Check(method.DispatchKind = dkInterface, 'Dispatch kind of Test4 does not match');
  1264. Check(not Assigned(method.CodeAddress), 'Code address of Test4 is not Nil');
  1265. CheckEquals(method.VirtualIndex, 6, 'Virtual index of Test4 does not match');
  1266. Check(Assigned(method.ReturnType), 'Return type of Test4 is not Nil');
  1267. Check(method.ReturnType.TypeKind = tkAnsiString, 'Return type of Test4 is not a string');
  1268. params := method.GetParameters;
  1269. CheckEquals(2, Length(params), 'Parameter count of Test4 does not match');
  1270. param := params[0];
  1271. CheckEquals(param.Name, 'aArg1', 'Parameter name of Test4.aArg1 does not match');
  1272. Check(param.Flags = [pfArray, pfReference], 'Parameter flags of Test4.aArg1 do not match');
  1273. Check(Assigned(param.ParamType), 'Parameter type of Test4.aArg1 is Nil');
  1274. Check(param.ParamType.TypeKind = tkInteger, 'Parameter type of Test4.aArg1 is not an ordinal');
  1275. param := params[1];
  1276. CheckEquals(param.Name, 'aArg2', 'Parameter name of Test4.aArg2 does not match');
  1277. Check(param.Flags = [pfArray, pfReference], 'Parameter flags of Test4.aArg2 do not match');
  1278. Check(Assigned(param.ParamType), 'Parameter type of Test4.aArg2 is Nil');
  1279. Check(param.ParamType.TypeKind = tkRecord, 'Parameter type of Test4.aArg2 is not a record');
  1280. finally
  1281. context.Free;
  1282. end;
  1283. end;
  1284. {$ifdef fpc}
  1285. procedure TTestCase1.TestInterfaceRaw;
  1286. var
  1287. context: TRttiContext;
  1288. t: TRttiType;
  1289. ti: TRttiInterfaceType;
  1290. begin
  1291. context := TRttiContext.Create;
  1292. try
  1293. t := context.GetType(TypeInfo(ICORBATest));
  1294. Check(t is TRttiInterfaceType, 'Type is not a raw interface type');
  1295. Check(not Assigned(t.BaseType), 'Base type is assigned');
  1296. ti := TRttiInterfaceType(t);
  1297. Check(not Assigned(ti.BaseType), 'Base type is assigned');
  1298. finally
  1299. context.Free;
  1300. end;
  1301. end;
  1302. {$endif}
  1303. initialization
  1304. {$ifdef fpc}
  1305. RegisterTest(TTestCase1);
  1306. {$else fpc}
  1307. RegisterTest(TTestCase1.Suite);
  1308. {$endif fpc}
  1309. end.