tests.rtti.pas 62 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009
  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. procedure TTestCase1.TestProcVar;
  1694. var
  1695. context: TRttiContext;
  1696. t: TRttiType;
  1697. p: TRttiProcedureType;
  1698. params: {$ifdef fpc}specialize{$endif} TArray<TRttiParameter>;
  1699. begin
  1700. context := TRttiContext.Create;
  1701. try
  1702. t := context.GetType(PTypeInfo(TypeInfo(TTestProc)));
  1703. Check(Assigned(t), 'Rtti Type is Nil');
  1704. Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
  1705. Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
  1706. p := t as TRttiProcedureType;
  1707. Check(p.CallingConvention = ccReg, 'Calling convention does not match');
  1708. Check(not Assigned(p.ReturnType), 'Return type is assigned');
  1709. CheckEquals(0, Length(p.GetParameters), 'Procedure variable has parameters');
  1710. t := context.GetType(PTypeInfo(TypeInfo(TTestFunc1)));
  1711. Check(Assigned(t), 'Rtti Type is Nil');
  1712. Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
  1713. Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
  1714. p := t as TRttiProcedureType;
  1715. Check(p.CallingConvention = ccReg, 'Calling convention does not match');
  1716. Check(Assigned(p.ReturnType), 'Return type is not assigned');
  1717. //Check(p.ReturnType is TRttiOrdinalType, 'Return type is not an ordinal type');
  1718. CheckEquals(0, Length(p.GetParameters), 'Procedure variable has parameters');
  1719. t := context.GetType(PTypeInfo(TypeInfo(TTestFunc2)));
  1720. Check(Assigned(t), 'Rtti Type is Nil');
  1721. Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
  1722. Check(t is TRttiProcedureType, 'Rtti Type is not a procedure type');
  1723. p := t as TRttiProcedureType;
  1724. Check(p.CallingConvention = ccReg, 'Calling convention does not match');
  1725. Check(Assigned(p.ReturnType), 'Return type is not assigned');
  1726. Check(p.ReturnType is TRttiStringType, 'Return type is not a string type');
  1727. params := p.GetParameters;
  1728. CheckEquals(2, Length(params), 'Procedure variable has incorrect amount of parameters');
  1729. Check(params[0].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 1 is not an ordinal type');
  1730. //Check(params[0].ParamType is TRttiOrdinalType, 'Parameter 1 is not an ordinal type');
  1731. Check(pfArray in params[1].Flags, 'Parameter 2 is not an array');
  1732. Check(params[1].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 2 is not an ordinal array');
  1733. finally
  1734. context.Free;
  1735. end;
  1736. end;
  1737. procedure TTestCase1.TestMethod;
  1738. var
  1739. context: TRttiContext;
  1740. t: TRttiType;
  1741. m: TRttiMethodType;
  1742. params: {$ifdef fpc}specialize{$endif} TArray<TRttiParameter>;
  1743. begin
  1744. context := TRttiContext.Create;
  1745. try
  1746. t := context.GetType(PTypeInfo(TypeInfo(TTestMethod)));
  1747. Check(Assigned(t), 'Rtti Type is Nil');
  1748. Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
  1749. Check(t is TRttiMethodType, 'Rtti Type is not a method type');
  1750. m := t as TRttiMethodType;
  1751. Check(m.CallingConvention = ccReg, 'Calling convention does not match');
  1752. Check(not Assigned(m.ReturnType), 'Return type is assigned');
  1753. CheckEquals(0, Length(m.GetParameters), 'Method variable has parameters');
  1754. t := context.GetType(PTypeInfo(TypeInfo(TTestMethod1)));
  1755. Check(Assigned(t), 'Rtti Type is Nil');
  1756. Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
  1757. Check(t is TRttiMethodType, 'Rtti Type is not a method type');
  1758. m := t as TRttiMethodType;
  1759. Check(m.CallingConvention = ccReg, 'Calling convention does not match');
  1760. Check(Assigned(m.ReturnType), 'Return type is not assigned');
  1761. //Check(p.ReturnType is TRttiOrdinalType, 'Return type is not an ordinal type');
  1762. CheckEquals(0, Length(m.GetParameters), 'Method variable has parameters');
  1763. t := context.GetType(PTypeInfo(TypeInfo(TTestMethod2)));
  1764. Check(Assigned(t), 'Rtti Type is Nil');
  1765. Check(t is TRttiInvokableType, 'Rtti Type is not an invokeable');
  1766. Check(t is TRttiMethodType, 'Rtti Type is not a method type');
  1767. m := t as TRttiMethodType;
  1768. Check(m.CallingConvention = ccReg, 'Calling convention does not match');
  1769. Check(Assigned(m.ReturnType), 'Return type is not assigned');
  1770. Check(m.ReturnType is TRttiStringType, 'Return type is not a string type');
  1771. params := m.GetParameters;
  1772. CheckEquals(2, Length(params), 'Method variable has incorrect amount of parameters');
  1773. Check(params[0].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 1 is not an ordinal type');
  1774. //Check(params[0].ParamType is TRttiOrdinalType, 'Parameter 1 is not an ordinal type');
  1775. Check(pfArray in params[1].Flags, 'Parameter 2 is not an array');
  1776. Check(params[1].ParamType.TypeKind in [tkInteger, tkInt64], 'Parameter 2 is not an ordinal array');
  1777. finally
  1778. context.Free;
  1779. end;
  1780. end;
  1781. {$endif}
  1782. initialization
  1783. {$ifdef fpc}
  1784. RegisterTest(TTestCase1);
  1785. {$else fpc}
  1786. RegisterTest(TTestCase1.Suite);
  1787. {$endif fpc}
  1788. end.