tests.rtti.pas 62 KB

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