typinfo.pp 45 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1999-2000 by Florian Klaempfl
  5. member of the Free Pascal development team
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. { This unit provides the same Functionality as the TypInfo Unit }
  13. { of Delphi }
  14. unit typinfo;
  15. interface
  16. {$MODE objfpc}
  17. uses SysUtils;
  18. // temporary types:
  19. type
  20. {$ifndef HASVARIANT}
  21. Variant = Pointer;
  22. {$endif}
  23. {$MINENUMSIZE 1 this saves a lot of memory }
  24. // if you change one of the following enumeration types
  25. // you have also to change the compiler in an appropriate way !
  26. TTypeKind = (tkUnknown,tkInteger,tkChar,tkEnumeration,
  27. tkFloat,tkSet,tkMethod,tkSString,tkLString,tkAString,
  28. tkWString,tkVariant,tkArray,tkRecord,tkInterface,
  29. tkClass,tkObject,tkWChar,tkBool,tkInt64,tkQWord,
  30. tkDynArray,tkInterfaceRaw);
  31. TTOrdType = (otSByte,otUByte,otSWord,otUWord,otSLong,otULong);
  32. TFloatType = (ftSingle,ftDouble,ftExtended,ftComp,ftCurr);
  33. TMethodKind = (mkProcedure,mkFunction,mkConstructor,mkDestructor,
  34. mkClassProcedure, mkClassFunction);
  35. TParamFlags = set of (pfVar,pfConst,pfArray,pfAddress,pfReference,pfOut);
  36. TIntfFlag = (ifHasGuid,ifDispInterface,ifDispatch);
  37. TIntfFlags = set of TIntfFlag;
  38. TIntfFlagsBase = set of TIntfFlag;
  39. {$MINENUMSIZE DEFAULT}
  40. const
  41. ptField = 0;
  42. ptStatic = 1;
  43. ptVirtual = 2;
  44. ptConst = 3;
  45. tkString = tkSString;
  46. type
  47. TTypeKinds = set of TTypeKind;
  48. {$PACKRECORDS 1}
  49. TTypeInfo = record
  50. Kind : TTypeKind;
  51. Name : ShortString;
  52. // here the type data follows as TTypeData record
  53. end;
  54. PTypeInfo = ^TTypeInfo;
  55. PPTypeInfo = ^PTypeInfo;
  56. PTypeData = ^TTypeData;
  57. TTypeData = packed record
  58. case TTypeKind of
  59. tkUnKnown,tkLString,tkWString,tkAString,tkVariant:
  60. ();
  61. tkInteger,tkChar,tkEnumeration,tkWChar:
  62. (OrdType : TTOrdType;
  63. case TTypeKind of
  64. tkInteger,tkChar,tkEnumeration,tkBool,tkWChar : (
  65. MinValue,MaxValue : Longint;
  66. case TTypeKind of
  67. tkEnumeration:
  68. (
  69. BaseType : PTypeInfo;
  70. NameList : ShortString)
  71. );
  72. tkSet:
  73. (CompType : PTypeInfo)
  74. );
  75. tkFloat:
  76. (FloatType : TFloatType);
  77. tkSString:
  78. (MaxLength : Byte);
  79. tkClass:
  80. (ClassType : TClass;
  81. ParentInfo : PTypeInfo;
  82. PropCount : SmallInt;
  83. UnitName : ShortString
  84. // here the properties follow as array of TPropInfo
  85. );
  86. tkMethod:
  87. (MethodKind : TMethodKind;
  88. ParamCount : Byte;
  89. ParamList : array[0..1023] of Char
  90. {in reality ParamList is a array[1..ParamCount] of:
  91. record
  92. Flags : TParamFlags;
  93. ParamName : ShortString;
  94. TypeName : ShortString;
  95. end;
  96. followed by
  97. ResultType : ShortString}
  98. );
  99. tkInt64:
  100. (MinInt64Value, MaxInt64Value: Int64);
  101. tkQWord:
  102. (MinQWordValue, MaxQWordValue: QWord);
  103. tkInterface,
  104. tkInterfaceRaw:
  105. (
  106. IntfParent: PPTypeInfo;
  107. IID: PGUID;
  108. IIDStr: ShortString;
  109. IntfUnit: ShortString;
  110. );
  111. end;
  112. // unsed, just for completeness
  113. TPropData = packed record
  114. PropCount : Word;
  115. PropList : record end;
  116. end;
  117. PPropInfo = ^TPropInfo;
  118. TPropInfo = packed record
  119. PropType : PTypeInfo;
  120. GetProc : Pointer;
  121. SetProc : Pointer;
  122. StoredProc : Pointer;
  123. Index : Integer;
  124. Default : Longint;
  125. NameIndex : SmallInt;
  126. // contains the type of the Get/Set/Storedproc, see also ptxxx
  127. // bit 0..1 GetProc
  128. // 2..3 SetProc
  129. // 4..5 StoredProc
  130. // 6 : true, constant index property
  131. PropProcs : Byte;
  132. Name : ShortString;
  133. end;
  134. TProcInfoProc = Procedure(PropInfo : PPropInfo) of object;
  135. PPropList = ^TPropList;
  136. TPropList = array[0..65535] of PPropInfo;
  137. const
  138. tkAny = [Low(TTypeKind)..High(TTypeKind)];
  139. tkMethods = [tkMethod];
  140. tkProperties = tkAny-tkMethods-[tkUnknown];
  141. // general property handling
  142. Function GetTypeData(TypeInfo : PTypeInfo) : PTypeData;
  143. Function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string) : PPropInfo;
  144. Function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string; AKinds : TTypeKinds) : PPropInfo;
  145. Function GetPropInfo(Instance: TObject; const PropName: string; AKinds: TTypeKinds) : PPropInfo;
  146. Function GetPropInfo(Instance: TObject; const PropName: string): PPropInfo;
  147. Function GetPropInfo(AClass: TClass; const PropName: string; AKinds: TTypeKinds) : PPropInfo;
  148. Function GetPropInfo(AClass: TClass; const PropName: string): PPropInfo;
  149. Function FindPropInfo(Instance: TObject; const PropName: string): PPropInfo;
  150. Function FindPropInfo(AClass:TClass;const PropName: string): PPropInfo;
  151. Procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList);
  152. Function GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds; PropList : PPropList) : Integer;
  153. // Property information routines.
  154. Function IsStoredProp(Instance: TObject;PropInfo : PPropInfo) : Boolean;
  155. Function IsStoredProp(Instance: TObject; const PropName: string): Boolean;
  156. Function IsPublishedProp(Instance: TObject; const PropName: string): Boolean;
  157. Function IsPublishedProp(AClass: TClass; const PropName: string): Boolean;
  158. Function PropType(Instance: TObject; const PropName: string): TTypeKind;
  159. Function PropType(AClass: TClass; const PropName: string): TTypeKind;
  160. Function PropIsType(Instance: TObject; const PropName: string; TypeKind: TTypeKind): Boolean;
  161. Function PropIsType(AClass: TClass; const PropName: string; TypeKind: TTypeKind): Boolean;
  162. // subroutines to read/write properties
  163. Function GetOrdProp(Instance: TObject; PropInfo : PPropInfo) : Longint;
  164. Function GetOrdProp(Instance: TObject; const PropName: string): Longint;
  165. Procedure SetOrdProp(Instance: TObject; PropInfo : PPropInfo; Value : Longint);
  166. Procedure SetOrdProp(Instance: TObject; const PropName: string; Value: Longint);
  167. Function GetEnumProp(Instance: TObject; const PropName: string): string;
  168. Function GetEnumProp(Instance: TObject; const PropInfo: PPropInfo): string;
  169. Procedure SetEnumProp(Instance: TObject; const PropName: string;const Value: string);
  170. Procedure SetEnumProp(Instance: TObject; const PropInfo: PPropInfo;const Value: string);
  171. Function GetSetProp(Instance: TObject; const PropName: string): string;
  172. Function GetSetProp(Instance: TObject; const PropName: string; Brackets: Boolean): string;
  173. Function GetSetProp(Instance: TObject; const PropInfo: PPropInfo; Brackets: Boolean): string;
  174. Procedure SetSetProp(Instance: TObject; const PropName: string; const Value: string);
  175. Procedure SetSetProp(Instance: TObject; const PropInfo: PPropInfo; const Value: string);
  176. Function GetStrProp(Instance: TObject; PropInfo : PPropInfo) : Ansistring;
  177. Function GetStrProp(Instance: TObject; const PropName: string): string;
  178. Procedure SetStrProp(Instance: TObject; const PropName: string; const Value: AnsiString);
  179. Procedure SetStrProp(Instance: TObject; PropInfo : PPropInfo; const Value : Ansistring);
  180. {$ifdef HASWIDESTRING}
  181. Function GetWideStrProp(Instance: TObject; PropInfo: PPropInfo): WideString;
  182. Function GetWideStrProp(Instance: TObject; const PropName: string): WideString;
  183. Procedure SetWideStrProp(Instance: TObject; const PropName: string; const Value: WideString);
  184. Procedure SetWideStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: WideString);
  185. {$endif HASWIDESTRING}
  186. Function GetFloatProp(Instance: TObject; PropInfo : PPropInfo) : Extended;
  187. Function GetFloatProp(Instance: TObject; const PropName: string): Extended;
  188. Procedure SetFloatProp(Instance: TObject; const PropName: string; Value: Extended);
  189. Procedure SetFloatProp(Instance: TObject; PropInfo : PPropInfo; Value : Extended);
  190. Function GetVariantProp(Instance: TObject; PropInfo : PPropInfo): Variant;
  191. Function GetVariantProp(Instance: TObject; const PropName: string): Variant;
  192. Procedure SetVariantProp(Instance: TObject; const PropName: string; const Value: Variant);
  193. Procedure SetVariantProp(Instance: TObject; PropInfo : PPropInfo; const Value: Variant);
  194. Function GetObjectProp(Instance: TObject; const PropName: string): TObject;
  195. Function GetObjectProp(Instance: TObject; const PropName: string; MinClass: TClass): TObject;
  196. Function GetObjectProp(Instance: TObject; PropInfo: PPropInfo): TObject;
  197. Function GetObjectProp(Instance: TObject; PropInfo: PPropInfo; MinClass: TClass): TObject;
  198. Procedure SetObjectProp(Instance: TObject; const PropName: string; Value: TObject);
  199. Procedure SetObjectProp(Instance: TObject; PropInfo: PPropInfo; Value: TObject);
  200. Function GetObjectPropClass(Instance: TObject; const PropName: string): TClass;
  201. Function GetMethodProp(Instance: TObject; PropInfo: PPropInfo) : TMethod;
  202. Function GetMethodProp(Instance: TObject; const PropName: string): TMethod;
  203. Procedure SetMethodProp(Instance: TObject; PropInfo: PPropInfo; const Value : TMethod);
  204. Procedure SetMethodProp(Instance: TObject; const PropName: string; const Value: TMethod);
  205. Function GetInt64Prop(Instance: TObject; PropInfo: PPropInfo): Int64;
  206. Function GetInt64Prop(Instance: TObject; const PropName: string): Int64;
  207. Procedure SetInt64Prop(Instance: TObject; PropInfo: PPropInfo; const Value: Int64);
  208. Procedure SetInt64Prop(Instance: TObject; const PropName: string; const Value: Int64);
  209. Function GetPropValue(Instance: TObject; const PropName: string): Variant;
  210. Function GetPropValue(Instance: TObject; const PropName: string; PreferStrings: Boolean): Variant;
  211. Procedure SetPropValue(Instance: TObject; const PropName: string; const Value: Variant);
  212. // Auxiliary routines, which may be useful
  213. Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
  214. Function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
  215. function SetToString(PropInfo: PPropInfo; Value: Integer; Brackets: Boolean) : String;
  216. function SetToString(PropInfo: PPropInfo; Value: Integer) : String;
  217. function StringToSet(PropInfo: PPropInfo; const Value: string): Integer;
  218. const
  219. BooleanIdents: array[Boolean] of String = ('False', 'True');
  220. DotSep: String = '.';
  221. Type
  222. EPropertyError = Class(Exception);
  223. Implementation
  224. ResourceString
  225. SErrPropertyNotFound = 'Unknown property: "%s"';
  226. SErrUnknownEnumValue = 'Unknown enumeration value: "%s"';
  227. type
  228. PMethod = ^TMethod;
  229. { ---------------------------------------------------------------------
  230. Auxiliary methods
  231. ---------------------------------------------------------------------}
  232. Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;
  233. Var PS : PShortString;
  234. PT : PTypeData;
  235. begin
  236. PT:=GetTypeData(TypeInfo);
  237. // ^.BaseType);
  238. // If PT^.MinValue<0 then Value:=Ord(Value<>0); {map to 0/1}
  239. PS:=@PT^.NameList;
  240. While Value>0 Do
  241. begin
  242. PS:=PShortString(pointer(PS)+PByte(PS)^+1);
  243. Dec(Value);
  244. end;
  245. Result:=PS^;
  246. end;
  247. Function GetEnumValue(TypeInfo : PTypeInfo;const Name : string) : Integer;
  248. Var PS : PShortString;
  249. PT : PTypeData;
  250. Count : longint;
  251. begin
  252. If Length(Name)=0 then
  253. exit(-1);
  254. PT:=GetTypeData(TypeInfo);
  255. Count:=0;
  256. Result:=-1;
  257. PS:=@PT^.NameList;
  258. While (Result=-1) and (PByte(PS)^<>0) do
  259. begin
  260. If CompareText(PS^, Name) = 0 then
  261. Result:=Count;
  262. PS:=PShortString(pointer(PS)+PByte(PS)^+1);
  263. Inc(Count);
  264. end;
  265. end;
  266. Function SetToString(PropInfo: PPropInfo; Value: Integer; Brackets: Boolean) : String;
  267. Var
  268. I : Integer;
  269. PTI : PTypeInfo;
  270. begin
  271. PTI:=GetTypeData(PropInfo^.PropType)^.CompType;
  272. Result:='';
  273. For I:=0 to SizeOf(Integer)*8-1 do
  274. begin
  275. if ((Value and 1)<>0) then
  276. begin
  277. If Result='' then
  278. Result:=GetEnumName(PTI,i)
  279. else
  280. Result:=Result+','+GetEnumName(PTI,I);
  281. end;
  282. Value:=Value shr 1;
  283. end;
  284. if Brackets then
  285. Result:='['+Result+']';
  286. end;
  287. Function SetToString(PropInfo: PPropInfo; Value: Integer) : String;
  288. begin
  289. Result:=SetToString(PropInfo,Value,False);
  290. end;
  291. Const
  292. SetDelim = ['[',']',',',' '];
  293. Function GetNextElement(Var S : String) : String;
  294. Var
  295. J : Integer;
  296. begin
  297. J:=1;
  298. Result:='';
  299. If Length(S)>0 then
  300. begin
  301. While (J<=Length(S)) and Not (S[j] in SetDelim) do
  302. Inc(j);
  303. Result:=Copy(S,1,j-1);
  304. Delete(S,1,j);
  305. end;
  306. end;
  307. Function StringToSet(PropInfo: PPropInfo; const Value: string): Integer;
  308. Var
  309. S,T : String;
  310. I : Integer;
  311. PTI : PTypeInfo;
  312. begin
  313. Result:=0;
  314. PTI:=GetTypeData(PropInfo^.PropType)^.Comptype;
  315. S:=Value;
  316. I:=1;
  317. If Length(S)>0 then
  318. begin
  319. While (I<=Length(S)) and (S[i] in SetDelim) do
  320. Inc(I);
  321. Delete(S,1,i-1);
  322. end;
  323. While (S<>'') do
  324. begin
  325. T:=GetNextElement(S);
  326. if T<>'' then
  327. begin
  328. I:=GetEnumValue(PTI,T);
  329. if (I<0) then
  330. raise EPropertyError.CreateFmt(SErrUnknownEnumValue, [T]);
  331. Result:=Result or (1 shl i);
  332. end;
  333. end;
  334. end;
  335. Function GetTypeData(TypeInfo : PTypeInfo) : PTypeData;
  336. begin
  337. GetTypeData:=PTypeData(pointer(TypeInfo)+2+PByte(pointer(TypeInfo)+1)^);
  338. end;
  339. { ---------------------------------------------------------------------
  340. Basic Type information functions.
  341. ---------------------------------------------------------------------}
  342. Function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string) : PPropInfo;
  343. var
  344. hp : PTypeData;
  345. i : longint;
  346. p : string;
  347. pd : ^TPropData;
  348. begin
  349. P:=UpCase(PropName);
  350. while Assigned(TypeInfo) do
  351. begin
  352. // skip the name
  353. hp:=GetTypeData(Typeinfo);
  354. // the class info rtti the property rtti follows immediatly
  355. pd:=pointer(pointer(@hp^.UnitName)+Length(hp^.UnitName)+1);
  356. Result:=@pd^.PropList;
  357. for i:=1 to pd^.PropCount do
  358. begin
  359. // found a property of that name ?
  360. if Upcase(Result^.Name)=P then
  361. exit;
  362. // skip to next property
  363. Result:=PPropInfo(pointer(@Result^.Name)+byte(Result^.Name[0])+1);
  364. end;
  365. // parent class
  366. Typeinfo:=hp^.ParentInfo;
  367. end;
  368. Result:=Nil;
  369. end;
  370. Function GetPropInfo(TypeInfo : PTypeInfo;const PropName : string; Akinds : TTypeKinds) : PPropInfo;
  371. begin
  372. Result:=GetPropInfo(TypeInfo,PropName);
  373. If (Akinds<>[]) then
  374. If (Result<>Nil) then
  375. If Not (Result^.PropType^.Kind in AKinds) then
  376. Result:=Nil;
  377. end;
  378. Function GetPropInfo(AClass: TClass; const PropName: string; AKinds: TTypeKinds) : PPropInfo;
  379. begin
  380. Result:=GetPropInfo(PTypeInfo(AClass.ClassInfo),PropName,AKinds);
  381. end;
  382. Function GetPropInfo(Instance: TObject; const PropName: string; AKinds: TTypeKinds) : PPropInfo;
  383. begin
  384. Result:=GetPropInfo(Instance.ClassType,PropName,AKinds);
  385. end;
  386. Function GetPropInfo(Instance: TObject; const PropName: string): PPropInfo;
  387. begin
  388. Result:=GetPropInfo(Instance,PropName,[]);
  389. end;
  390. Function GetPropInfo(AClass: TClass; const PropName: string): PPropInfo;
  391. begin
  392. Result:=GetPropInfo(AClass,PropName,[]);
  393. end;
  394. Function FindPropInfo(Instance: TObject; const PropName: string): PPropInfo;
  395. begin
  396. result:=GetPropInfo(Instance, PropName);
  397. if Result=nil then
  398. Raise EPropertyError.CreateFmt(SErrPropertyNotFound, [PropName]);
  399. end;
  400. Function FindPropInfo(AClass:TClass;const PropName: string): PPropInfo;
  401. begin
  402. result:=GetPropInfo(AClass,PropName);
  403. if result=nil then
  404. Raise EPropertyError.CreateFmt(SErrPropertyNotFound, [PropName]);
  405. end;
  406. Function IsStoredProp(Instance : TObject;PropInfo : PPropInfo) : Boolean;
  407. type
  408. TBooleanFunc=function:boolean of object;
  409. var
  410. AMethod : TMethod;
  411. begin
  412. case (PropInfo^.PropProcs shr 4) and 3 of
  413. ptfield:
  414. Result:=PBoolean(Pointer(Instance)+Longint(PropInfo^.StoredProc))^;
  415. ptconst:
  416. Result:=LongBool(PropInfo^.StoredProc);
  417. ptstatic,
  418. ptvirtual:
  419. begin
  420. if (PropInfo^.PropProcs shr 4) and 3=ptstatic then
  421. AMethod.Code:=PropInfo^.StoredProc
  422. else
  423. AMethod.Code:=ppointer(Pointer(Instance.ClassType)+Longint(PropInfo^.StoredProc))^;
  424. AMethod.Data:=Instance;
  425. Result:=TBooleanFunc(AMethod)();
  426. end;
  427. end;
  428. end;
  429. Procedure GetPropInfos(TypeInfo : PTypeInfo;PropList : PPropList);
  430. {
  431. Store Pointers to property information in the list pointed
  432. to by proplist. PRopList must contain enough space to hold ALL
  433. properties.
  434. }
  435. Var
  436. TD : PTypeData;
  437. TP : PPropInfo;
  438. Count : Longint;
  439. begin
  440. TD:=GetTypeData(TypeInfo);
  441. // Get this objects TOTAL published properties count
  442. TP:=(@TD^.UnitName+Length(TD^.UnitName)+1);
  443. Count:=PWord(TP)^;
  444. // Now point TP to first propinfo record.
  445. Inc(Pointer(TP),SizeOF(Word));
  446. While Count>0 do
  447. begin
  448. PropList^[0]:=TP;
  449. Inc(Pointer(PropList),SizeOf(Pointer));
  450. // Point to TP next propinfo record.
  451. // Located at Name[Length(Name)+1] !
  452. TP:=PPropInfo(pointer(@TP^.Name)+PByte(@TP^.Name)^+1);
  453. Dec(Count);
  454. end;
  455. // recursive call for parent info.
  456. If TD^.Parentinfo<>Nil then
  457. GetPropInfos (TD^.ParentInfo,PropList);
  458. end;
  459. Procedure InsertProp (PL : PProplist;PI : PPropInfo; Count : longint);
  460. Var
  461. I : Longint;
  462. begin
  463. I:=0;
  464. While (I<Count) and (PI^.Name>PL^[I]^.Name) do
  465. Inc(I);
  466. If I<Count then
  467. Move(PL^[I], PL^[I+1], (Count - I) * SizeOf(Pointer));
  468. PL^[I]:=PI;
  469. end;
  470. Function GetPropList(TypeInfo : PTypeInfo;TypeKinds : TTypeKinds; PropList : PPropList) : Integer;
  471. {
  472. Store Pointers to property information OF A CERTAIN KIND in the list pointed
  473. to by proplist. PRopList must contain enough space to hold ALL
  474. properties.
  475. }
  476. Var
  477. TempList : PPropList;
  478. PropInfo : PPropinfo;
  479. I,Count : longint;
  480. begin
  481. Result:=0;
  482. Count:=GetTypeData(TypeInfo)^.Propcount;
  483. If Count>0 then
  484. begin
  485. GetMem(TempList,Count*SizeOf(Pointer));
  486. Try
  487. GetPropInfos(TypeInfo,TempList);
  488. For I:=0 to Count-1 do
  489. begin
  490. PropInfo:=TempList^[i];
  491. If PropInfo^.PropType^.Kind in TypeKinds then
  492. begin
  493. InsertProp(PropList,PropInfo,Result);
  494. Inc(Result);
  495. end;
  496. end;
  497. finally
  498. FreeMem(TempList,Count*SizeOf(Pointer));
  499. end;
  500. end;
  501. end;
  502. { ---------------------------------------------------------------------
  503. Property access functions
  504. ---------------------------------------------------------------------}
  505. { ---------------------------------------------------------------------
  506. Ordinal properties
  507. ---------------------------------------------------------------------}
  508. Function GetOrdProp(Instance : TObject;PropInfo : PPropInfo) : Longint;
  509. type
  510. TGetIntegerProcIndex=function(index:longint):longint of object;
  511. TGetIntegerProc=function:longint of object;
  512. var
  513. TypeInfo: PTypeInfo;
  514. AMethod : TMethod;
  515. begin
  516. Result:=0;
  517. case (PropInfo^.PropProcs) and 3 of
  518. ptfield:
  519. Result:=PLongint(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  520. ptstatic,
  521. ptvirtual :
  522. begin
  523. if (PropInfo^.PropProcs and 3)=ptStatic then
  524. AMethod.Code:=PropInfo^.GetProc
  525. else
  526. AMethod.Code:=PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^;
  527. AMethod.Data:=Instance;
  528. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  529. Result:=TGetIntegerProcIndex(AMethod)(PropInfo^.Index)
  530. else
  531. Result:=TGetIntegerProc(AMethod)();
  532. end;
  533. end;
  534. { cut off unnecessary stuff }
  535. TypeInfo := PropInfo^.PropType;
  536. case TypeInfo^.Kind of
  537. tkChar, tkBool:
  538. Result:=Result and $ff;
  539. tkWChar:
  540. Result:=Result and $ffff;
  541. tkEnumeration,
  542. tkInteger:
  543. case GetTypeData(TypeInfo)^.OrdType of
  544. otSWord,otUWord:
  545. Result:=Result and $ffff;
  546. otSByte,otUByte:
  547. Result:=Result and $ff;
  548. end;
  549. end;
  550. end;
  551. Procedure SetOrdProp(Instance : TObject;PropInfo : PPropInfo;Value : Longint);
  552. type
  553. TSetIntegerProcIndex=procedure(index,i:longint) of object;
  554. TSetIntegerProc=procedure(i:longint) of object;
  555. var
  556. DataSize: Integer;
  557. AMethod : TMethod;
  558. begin
  559. DataSize := 4;
  560. if PropInfo^.PropType^.Kind <> tkClass then
  561. begin
  562. { cut off unnecessary stuff }
  563. case GetTypeData(PropInfo^.PropType)^.OrdType of
  564. otSWord,otUWord:
  565. begin
  566. Value:=Value and $ffff;
  567. DataSize := 2;
  568. end;
  569. otSByte,otUByte:
  570. begin
  571. Value:=Value and $ff;
  572. DataSize := 1;
  573. end;
  574. end;
  575. end;
  576. case (PropInfo^.PropProcs shr 2) and 3 of
  577. ptfield:
  578. case DataSize of
  579. 1: PByte(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Byte(Value);
  580. 2: PWord(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Word(Value);
  581. 4: PLongint(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
  582. end;
  583. ptstatic,
  584. ptvirtual :
  585. begin
  586. if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
  587. AMethod.Code:=PropInfo^.SetProc
  588. else
  589. AMethod.Code:=PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^;
  590. AMethod.Data:=Instance;
  591. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  592. TSetIntegerProcIndex(AMethod)(PropInfo^.Index,Value)
  593. else
  594. TSetIntegerProc(AMethod)(Value);
  595. end;
  596. end;
  597. end;
  598. Function GetOrdProp(Instance: TObject; const PropName: string): Longint;
  599. begin
  600. Result:=GetOrdProp(Instance,FindPropInfo(Instance,PropName));
  601. end;
  602. Procedure SetOrdProp(Instance: TObject; const PropName: string; Value: Longint);
  603. begin
  604. SetOrdProp(Instance,FindPropInfo(Instance,PropName),Value);
  605. end;
  606. Function GetEnumProp(Instance: TObject; Const PropInfo: PPropInfo): string;
  607. begin
  608. Result:=GetEnumName(PropInfo^.PropType, GetOrdProp(Instance, PropInfo));
  609. end;
  610. Function GetEnumProp(Instance: TObject; const PropName: string): string;
  611. begin
  612. Result:=GetEnumProp(Instance,FindPropInfo(Instance,PropName));
  613. end;
  614. Procedure SetEnumProp(Instance: TObject; const PropName: string; const Value: string);
  615. begin
  616. SetEnumProp(Instance,FindPropInfo(Instance,PropName),Value);
  617. end;
  618. Procedure SetEnumProp(Instance: TObject; Const PropInfo : PPropInfo; const Value: string);
  619. Var
  620. PV : Longint;
  621. begin
  622. If PropInfo<>Nil then
  623. begin
  624. PV:=GetEnumValue(PropInfo^.PropType, Value);
  625. if (PV<0) then
  626. raise EPropertyError.CreateFmt(SErrUnknownEnumValue, [Value]);
  627. SetOrdProp(Instance, PropInfo,PV);
  628. end;
  629. end;
  630. { ---------------------------------------------------------------------
  631. Set properties
  632. ---------------------------------------------------------------------}
  633. Function GetSetProp(Instance: TObject; const PropName: string): string;
  634. begin
  635. Result:=GetSetProp(Instance,PropName,False);
  636. end;
  637. Function GetSetProp(Instance: TObject; const PropName: string; Brackets: Boolean): string;
  638. begin
  639. Result:=GetSetProp(Instance,FindPropInfo(Instance,PropName),Brackets);
  640. end;
  641. Function GetSetProp(Instance: TObject; const PropInfo: PPropInfo; Brackets: Boolean): string;
  642. begin
  643. Result:=SetToString(PropInfo,GetOrdProp(Instance,PropInfo),Brackets);
  644. end;
  645. Procedure SetSetProp(Instance: TObject; const PropName: string; const Value: string);
  646. begin
  647. SetSetProp(Instance,FindPropInfo(Instance,PropName),Value);
  648. end;
  649. Procedure SetSetProp(Instance: TObject; const PropInfo: PPropInfo; const Value: string);
  650. begin
  651. SetOrdProp(Instance,PropInfo,StringToSet(PropInfo,Value));
  652. end;
  653. { ---------------------------------------------------------------------
  654. Object properties
  655. ---------------------------------------------------------------------}
  656. Function GetObjectProp(Instance: TObject; const PropName: string): TObject;
  657. begin
  658. Result:=GetObjectProp(Instance,PropName,Nil);
  659. end;
  660. Function GetObjectProp(Instance: TObject; const PropName: string; MinClass: TClass): TObject;
  661. begin
  662. Result:=GetObjectProp(Instance,FindPropInfo(Instance,PropName),MinClass);
  663. end;
  664. Function GetObjectProp(Instance: TObject; PropInfo : PPropInfo): TObject;
  665. begin
  666. Result:=GetObjectProp(Instance,PropInfo,Nil);
  667. end;
  668. Function GetObjectProp(Instance: TObject; PropInfo : PPropInfo; MinClass: TClass): TObject;
  669. begin
  670. {$ifdef cpu64}
  671. Result:=TObject(GetInt64Prop(Instance,PropInfo));
  672. {$else cpu64}
  673. Result:=TObject(GetOrdProp(Instance,PropInfo));
  674. {$endif cpu64}
  675. If (MinClass<>Nil) and (Result<>Nil) Then
  676. If Not Result.InheritsFrom(MinClass) then
  677. Result:=Nil;
  678. end;
  679. Procedure SetObjectProp(Instance: TObject; const PropName: string; Value: TObject);
  680. begin
  681. SetObjectProp(Instance,FindPropInfo(Instance,PropName),Value);
  682. end;
  683. Procedure SetObjectProp(Instance: TObject; PropInfo : PPropInfo; Value: TObject);
  684. begin
  685. {$ifdef cpu64}
  686. SetInt64Prop(Instance,PropInfo,Int64(Value));
  687. {$else cpu64}
  688. SetOrdProp(Instance,PropInfo,Integer(Value));
  689. {$endif cpu64}
  690. end;
  691. Function GetObjectPropClass(Instance: TObject; const PropName: string): TClass;
  692. begin
  693. Result:=GetTypeData(FindPropInfo(Instance,PropName)^.PropType)^.ClassType;
  694. end;
  695. { ---------------------------------------------------------------------
  696. String properties
  697. ---------------------------------------------------------------------}
  698. Function GetStrProp(Instance: TObject; PropInfo: PPropInfo): AnsiString;
  699. type
  700. TGetShortStrProcIndex=function(index:longint):ShortString of object;
  701. TGetShortStrProc=function():ShortString of object;
  702. TGetAnsiStrProcIndex=function(index:longint):AnsiString of object;
  703. TGetAnsiStrProc=function():AnsiString of object;
  704. var
  705. AMethod : TMethod;
  706. begin
  707. Result:='';
  708. case Propinfo^.PropType^.Kind of
  709. {$ifdef HASWIDESTRING}
  710. tkWString:
  711. Result:=GetWideStrProp(Instance,PropInfo);
  712. {$endif HASWIDESTRING}
  713. tkSString:
  714. begin
  715. case (PropInfo^.PropProcs) and 3 of
  716. ptField:
  717. Result := PShortString(Pointer(Instance) + LongWord(PropInfo^.GetProc))^;
  718. ptstatic,
  719. ptvirtual :
  720. begin
  721. if (PropInfo^.PropProcs and 3)=ptStatic then
  722. AMethod.Code:=PropInfo^.GetProc
  723. else
  724. AMethod.Code:=PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^;
  725. AMethod.Data:=Instance;
  726. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  727. Result:=TGetShortStrProcIndex(AMethod)(PropInfo^.Index)
  728. else
  729. Result:=TGetShortStrProc(AMethod)();
  730. end;
  731. end;
  732. end;
  733. tkAString:
  734. begin
  735. case (PropInfo^.PropProcs) and 3 of
  736. ptField:
  737. Result := PAnsiString(Pointer(Instance) + LongWord(PropInfo^.GetProc))^;
  738. ptstatic,
  739. ptvirtual :
  740. begin
  741. if (PropInfo^.PropProcs and 3)=ptStatic then
  742. AMethod.Code:=PropInfo^.GetProc
  743. else
  744. AMethod.Code:=PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^;
  745. AMethod.Data:=Instance;
  746. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  747. Result:=TGetAnsiStrProcIndex(AMethod)(PropInfo^.Index)
  748. else
  749. Result:=TGetAnsiStrProc(AMethod)();
  750. end;
  751. end;
  752. end;
  753. end;
  754. end;
  755. Procedure SetStrProp(Instance : TObject;PropInfo : PPropInfo; const Value : AnsiString);
  756. type
  757. TSetShortStrProcIndex=procedure(index:longint;const s:ShortString) of object;
  758. TSetShortStrProc=procedure(const s:ShortString) of object;
  759. TSetAnsiStrProcIndex=procedure(index:longint;s:AnsiString) of object;
  760. TSetAnsiStrProc=procedure(s:AnsiString) of object;
  761. var
  762. AMethod : TMethod;
  763. begin
  764. case Propinfo^.PropType^.Kind of
  765. {$ifdef HASWIDESTRING}
  766. tkWString:
  767. SetWideStrProp(Instance,PropInfo,Value);
  768. {$endif HASWIDESTRING}
  769. tkSString:
  770. begin
  771. case (PropInfo^.PropProcs shr 2) and 3 of
  772. ptField:
  773. PShortString(Pointer(Instance) + LongWord(PropInfo^.SetProc))^:=Value;
  774. ptstatic,
  775. ptvirtual :
  776. begin
  777. if (PropInfo^.PropProcs and 3)=ptStatic then
  778. AMethod.Code:=PropInfo^.SetProc
  779. else
  780. AMethod.Code:=PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^;
  781. AMethod.Data:=Instance;
  782. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  783. TSetShortStrProcIndex(AMethod)(PropInfo^.Index,Value)
  784. else
  785. TSetShortStrProc(AMethod)(Value);
  786. end;
  787. end;
  788. end;
  789. tkAString:
  790. begin
  791. case (PropInfo^.PropProcs shr 2) and 3 of
  792. ptField:
  793. PAnsiString(Pointer(Instance) + LongWord(PropInfo^.SetProc))^:=Value;
  794. ptstatic,
  795. ptvirtual :
  796. begin
  797. if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
  798. AMethod.Code:=PropInfo^.SetProc
  799. else
  800. AMethod.Code:=PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^;
  801. AMethod.Data:=Instance;
  802. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  803. TSetAnsiStrProcIndex(AMethod)(PropInfo^.Index,Value)
  804. else
  805. TSetAnsiStrProc(AMethod)(Value);
  806. end;
  807. end;
  808. end;
  809. end;
  810. end;
  811. Function GetStrProp(Instance: TObject; const PropName: string): string;
  812. begin
  813. Result:=GetStrProp(Instance,FindPropInfo(Instance,PropName));
  814. end;
  815. Procedure SetStrProp(Instance: TObject; const PropName: string; const Value: AnsiString);
  816. begin
  817. SetStrProp(Instance,FindPropInfo(Instance,PropName),Value);
  818. end;
  819. {$ifdef HASWIDESTRING}
  820. Function GetWideStrProp(Instance: TObject; const PropName: string): WideString;
  821. begin
  822. Result:=GetWideStrProp(Instance, FindPropInfo(Instance, PropName));
  823. end;
  824. procedure SetWideStrProp(Instance: TObject; const PropName: string; const Value: WideString);
  825. begin
  826. SetStrProp(Instance,FindPropInfo(Instance,PropName),Value);
  827. end;
  828. Function GetWideStrProp(Instance: TObject; PropInfo: PPropInfo): WideString;
  829. type
  830. TGetWideStrProcIndex=function(index:longint):WideString of object;
  831. TGetWideStrProc=function():WideString of object;
  832. var
  833. AMethod : TMethod;
  834. begin
  835. Result:='';
  836. case Propinfo^.PropType^.Kind of
  837. tkSString,tkAString:
  838. Result:=GetStrProp(Instance,PropInfo);
  839. tkWString:
  840. begin
  841. case (PropInfo^.PropProcs) and 3 of
  842. ptField:
  843. Result := PWideString(Pointer(Instance)+PtrUInt(PropInfo^.GetProc))^;
  844. ptstatic,
  845. ptvirtual :
  846. begin
  847. if (PropInfo^.PropProcs and 3)=ptStatic then
  848. AMethod.Code:=PropInfo^.GetProc
  849. else
  850. AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.GetProc))^;
  851. AMethod.Data:=Instance;
  852. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  853. Result:=TGetWideStrProcIndex(AMethod)(PropInfo^.Index)
  854. else
  855. Result:=TGetWideStrProc(AMethod)();
  856. end;
  857. end;
  858. end;
  859. end;
  860. end;
  861. Procedure SetWideStrProp(Instance: TObject; PropInfo: PPropInfo; const Value: WideString);
  862. type
  863. TSetWideStrProcIndex=procedure(index:longint;s:WideString) of object;
  864. TSetWideStrProc=procedure(s:WideString) of object;
  865. var
  866. AMethod : TMethod;
  867. begin
  868. case Propinfo^.PropType^.Kind of
  869. tkSString,tkAString:
  870. SetStrProp(Instance,PropInfo,Value);
  871. tkWString:
  872. begin
  873. case (PropInfo^.PropProcs shr 2) and 3 of
  874. ptField:
  875. PWideString(Pointer(Instance)+PtrUInt(PropInfo^.SetProc))^:=Value;
  876. ptstatic,
  877. ptvirtual :
  878. begin
  879. if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
  880. AMethod.Code:=PropInfo^.SetProc
  881. else
  882. AMethod.Code:=PPointer(Pointer(Instance.ClassType)+PtrUInt(PropInfo^.SetProc))^;
  883. AMethod.Data:=Instance;
  884. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  885. TSetWideStrProcIndex(AMethod)(PropInfo^.Index,Value)
  886. else
  887. TSetWideStrProc(AMethod)(Value);
  888. end;
  889. end;
  890. end;
  891. end;
  892. end;
  893. {$endif HASWIDESTRING}
  894. { ---------------------------------------------------------------------
  895. Float properties
  896. ---------------------------------------------------------------------}
  897. function GetFloatProp(Instance : TObject;PropInfo : PPropInfo) : Extended;
  898. type
  899. TGetExtendedProc = function:Extended of object;
  900. TGetExtendedProcIndex = function(Index: integer): Extended of object;
  901. TGetDoubleProc = function:Double of object;
  902. TGetDoubleProcIndex = function(Index: integer): Double of object;
  903. TGetSingleProc = function:Single of object;
  904. TGetSingleProcIndex = function(Index: integer):Single of object;
  905. {$ifdef HASCURRENCY}
  906. TGetCurrencyProc = function : Currency of object;
  907. TGetCurrencyProcIndex = function(Index: integer) : Currency of object;
  908. {$endif HASCURRENCY}
  909. var
  910. AMethod : TMethod;
  911. begin
  912. Result:=0.0;
  913. case PropInfo^.PropProcs and 3 of
  914. ptField:
  915. Case GetTypeData(PropInfo^.PropType)^.FloatType of
  916. ftSingle:
  917. Result:=PSingle(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  918. ftDouble:
  919. Result:=PDouble(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  920. ftExtended:
  921. Result:=PExtended(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  922. ftcomp:
  923. Result:=PComp(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  924. {$ifdef HASCURRENCY}
  925. ftcurr:
  926. Result:=PCurrency(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  927. {$endif HASCURRENCY}
  928. end;
  929. ptStatic,
  930. ptVirtual:
  931. begin
  932. if (PropInfo^.PropProcs and 3)=ptStatic then
  933. AMethod.Code:=PropInfo^.GetProc
  934. else
  935. AMethod.Code:=PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^;
  936. AMethod.Data:=Instance;
  937. Case GetTypeData(PropInfo^.PropType)^.FloatType of
  938. ftSingle:
  939. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  940. Result:=TGetSingleProc(AMethod)()
  941. else
  942. Result:=TGetSingleProcIndex(AMethod)(PropInfo^.Index);
  943. ftDouble:
  944. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  945. Result:=TGetDoubleProc(AMethod)()
  946. else
  947. Result:=TGetDoubleProcIndex(AMethod)(PropInfo^.Index);
  948. ftExtended:
  949. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  950. Result:=TGetExtendedProc(AMethod)()
  951. else
  952. Result:=TGetExtendedProcIndex(AMethod)(PropInfo^.Index);
  953. end;
  954. end;
  955. end;
  956. end;
  957. Procedure SetFloatProp(Instance : TObject;PropInfo : PPropInfo; Value : Extended);
  958. type
  959. TSetExtendedProc = procedure(const AValue: Extended) of object;
  960. TSetExtendedProcIndex = procedure(Index: integer; const AValue: Extended) of object;
  961. TSetDoubleProc = procedure(const AValue: Double) of object;
  962. TSetDoubleProcIndex = procedure(Index: integer; const AValue: Double) of object;
  963. TSetSingleProc = procedure(const AValue: Single) of object;
  964. TSetSingleProcIndex = procedure(Index: integer; const AValue: Single) of object;
  965. {$ifdef HASCURRENCY}
  966. TSetCurrencyProc = procedure(const AValue: Currency) of object;
  967. TSetCurrencyProcIndex = procedure(Index: integer; const AValue: Currency) of object;
  968. {$endif HASCURRENCY}
  969. Var
  970. AMethod : TMethod;
  971. begin
  972. case (PropInfo^.PropProcs shr 2) and 3 of
  973. ptfield:
  974. Case GetTypeData(PropInfo^.PropType)^.FloatType of
  975. ftSingle:
  976. PSingle(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
  977. ftDouble:
  978. PDouble(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
  979. ftExtended:
  980. PExtended(Pointer(Instance)+Longint(PropInfo^.SetProc))^:=Value;
  981. {$ifdef FPC_COMP_IS_INT64}
  982. ftComp:
  983. PComp(Pointer(Instance)+PtrUInt(PropInfo^.SetProc))^:=trunc(Value);
  984. {$else FPC_COMP_IS_INT64}
  985. ftComp:
  986. PComp(Pointer(Instance)+PtrUInt(PropInfo^.SetProc))^:=Value;
  987. {$endif FPC_COMP_IS_INT64}
  988. end;
  989. ptStatic,
  990. ptVirtual:
  991. begin
  992. if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
  993. AMethod.Code:=PropInfo^.SetProc
  994. else
  995. AMethod.Code:=PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^;
  996. AMethod.Data:=Instance;
  997. Case GetTypeData(PropInfo^.PropType)^.FloatType of
  998. ftSingle:
  999. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  1000. TSetSingleProc(AMethod)(Value)
  1001. else
  1002. TSetSingleProcIndex(AMethod)(PropInfo^.Index,Value);
  1003. ftDouble:
  1004. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  1005. TSetDoubleProc(AMethod)(Value)
  1006. else
  1007. TSetDoubleProcIndex(AMethod)(PropInfo^.Index,Value);
  1008. ftExtended:
  1009. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  1010. TSetExtendedProc(AMethod)(Value)
  1011. else
  1012. TSetExtendedProcIndex(AMethod)(PropInfo^.Index,Value);
  1013. end;
  1014. end;
  1015. end;
  1016. end;
  1017. function GetFloatProp(Instance: TObject; const PropName: string): Extended;
  1018. begin
  1019. Result:=GetFloatProp(Instance,FindPropInfo(Instance,PropName))
  1020. end;
  1021. Procedure SetFloatProp(Instance: TObject; const PropName: string; Value: Extended);
  1022. begin
  1023. SetFloatProp(Instance,FindPropInfo(Instance,PropName),Value);
  1024. end;
  1025. { ---------------------------------------------------------------------
  1026. Variant properties
  1027. ---------------------------------------------------------------------}
  1028. Function GetVariantProp(Instance : TObject;PropInfo : PPropInfo): Variant;
  1029. begin
  1030. {$warning GetVariantProp not implemented}
  1031. {$ifdef HASVARIANT}
  1032. Result:=Null;
  1033. {$else}
  1034. Result:=nil;
  1035. {$endif}
  1036. end;
  1037. Procedure SetVariantProp(Instance : TObject;PropInfo : PPropInfo; const Value: Variant);
  1038. begin
  1039. {$warning SetVariantProp not implemented}
  1040. end;
  1041. Function GetVariantProp(Instance: TObject; const PropName: string): Variant;
  1042. begin
  1043. Result:=GetVariantProp(Instance,FindPropInfo(Instance,PropName));
  1044. end;
  1045. Procedure SetVariantProp(Instance: TObject; const PropName: string; const Value: Variant);
  1046. begin
  1047. SetVariantprop(instance,FindpropInfo(Instance,PropName),Value);
  1048. end;
  1049. { ---------------------------------------------------------------------
  1050. Method properties
  1051. ---------------------------------------------------------------------}
  1052. Function GetMethodProp(Instance : TObject;PropInfo : PPropInfo) : TMethod;
  1053. type
  1054. TGetMethodProcIndex=function(Index: Longint): TMethod of object;
  1055. TGetMethodProc=function(): TMethod of object;
  1056. var
  1057. value: PMethod;
  1058. AMethod : TMethod;
  1059. begin
  1060. Result.Code:=nil;
  1061. Result.Data:=nil;
  1062. case (PropInfo^.PropProcs) and 3 of
  1063. ptfield:
  1064. begin
  1065. Value:=PMethod(Pointer(Instance)+Longint(PropInfo^.GetProc));
  1066. if Value<>nil then
  1067. Result:=Value^;
  1068. end;
  1069. ptstatic,
  1070. ptvirtual :
  1071. begin
  1072. if (PropInfo^.PropProcs and 3)=ptStatic then
  1073. AMethod.Code:=PropInfo^.GetProc
  1074. else
  1075. AMethod.Code:=PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^;
  1076. AMethod.Data:=Instance;
  1077. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  1078. Result:=TGetMethodProcIndex(AMethod)(PropInfo^.Index)
  1079. else
  1080. Result:=TGetMethodProc(AMethod)();
  1081. end;
  1082. end;
  1083. end;
  1084. Procedure SetMethodProp(Instance : TObject;PropInfo : PPropInfo; const Value : TMethod);
  1085. type
  1086. TSetMethodProcIndex=procedure(index:longint;p:PMethod) of object;
  1087. TSetMethodProc=procedure(p:PMethod) of object;
  1088. var
  1089. AMethod : TMethod;
  1090. begin
  1091. case (PropInfo^.PropProcs shr 2) and 3 of
  1092. ptfield:
  1093. PMethod(Pointer(Instance)+Longint(PropInfo^.SetProc))^ := Value;
  1094. ptstatic,
  1095. ptvirtual :
  1096. begin
  1097. if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
  1098. AMethod.Code:=PropInfo^.SetProc
  1099. else
  1100. AMethod.Code:=PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^;
  1101. AMethod.Data:=Instance;
  1102. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  1103. TSetMethodProcIndex(AMethod)(PropInfo^.Index,@Value)
  1104. else
  1105. TSetMethodProc(AMethod)(@Value);
  1106. end;
  1107. end;
  1108. end;
  1109. Function GetMethodProp(Instance: TObject; const PropName: string): TMethod;
  1110. begin
  1111. Result:=GetMethodProp(Instance,FindPropInfo(Instance,PropName));
  1112. end;
  1113. Procedure SetMethodProp(Instance: TObject; const PropName: string; const Value: TMethod);
  1114. begin
  1115. SetMethodProp(Instance,FindPropInfo(Instance,PropName),Value);
  1116. end;
  1117. { ---------------------------------------------------------------------
  1118. Int64 properties
  1119. ---------------------------------------------------------------------}
  1120. Function GetInt64Prop(Instance: TObject; PropInfo: PPropInfo): Int64;
  1121. type
  1122. TGetInt64ProcIndex=function(index:longint):Int64 of object;
  1123. TGetInt64Proc=function():Int64 of object;
  1124. var
  1125. AMethod : TMethod;
  1126. begin
  1127. Result:=0;
  1128. case (PropInfo^.PropProcs) and 3 of
  1129. ptfield:
  1130. Result:=PInt64(Pointer(Instance)+Longint(PropInfo^.GetProc))^;
  1131. ptstatic,
  1132. ptvirtual :
  1133. begin
  1134. if (PropInfo^.PropProcs and 3)=ptStatic then
  1135. AMethod.Code:=PropInfo^.GetProc
  1136. else
  1137. AMethod.Code:=PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.GetProc))^;
  1138. AMethod.Data:=Instance;
  1139. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  1140. result:=TGetInt64ProcIndex(AMethod)(PropInfo^.Index)
  1141. else
  1142. result:=TGetInt64Proc(AMethod)();
  1143. end;
  1144. end;
  1145. end;
  1146. procedure SetInt64Prop(Instance: TObject; PropInfo: PPropInfo; const Value: Int64);
  1147. type
  1148. TSetInt64ProcIndex=procedure(index:longint;i:Int64) of object;
  1149. TSetInt64Proc=procedure(i:Int64) of object;
  1150. var
  1151. AMethod : TMethod;
  1152. begin
  1153. case (PropInfo^.PropProcs shr 2) and 3 of
  1154. ptfield:
  1155. PInt64(Pointer(Instance)+Longint(PropInfo^.SetProc))^ := Value;
  1156. ptstatic,
  1157. ptvirtual :
  1158. begin
  1159. if ((PropInfo^.PropProcs shr 2) and 3)=ptStatic then
  1160. AMethod.Code:=PropInfo^.SetProc
  1161. else
  1162. AMethod.Code:=PPointer(Pointer(Instance.ClassType)+Longint(PropInfo^.SetProc))^;
  1163. AMethod.Data:=Instance;
  1164. if ((PropInfo^.PropProcs shr 6) and 1)<>0 then
  1165. TSetInt64ProcIndex(AMethod)(PropInfo^.Index,Value)
  1166. else
  1167. TSetInt64Proc(AMethod)(Value);
  1168. end;
  1169. end;
  1170. end;
  1171. Function GetInt64Prop(Instance: TObject; const PropName: string): Int64;
  1172. begin
  1173. Result:=GetInt64Prop(Instance,FindPropInfo(Instance,PropName));
  1174. end;
  1175. Procedure SetInt64Prop(Instance: TObject; const PropName: string; const Value: Int64);
  1176. begin
  1177. SetInt64Prop(Instance,FindPropInfo(Instance,PropName),Value);
  1178. end;
  1179. { ---------------------------------------------------------------------
  1180. All properties through variant.
  1181. ---------------------------------------------------------------------}
  1182. Function GetPropValue(Instance: TObject; const PropName: string): Variant;
  1183. begin
  1184. Result:=GetPropValue(Instance,PropName,True);
  1185. end;
  1186. Function GetPropValue(Instance: TObject; const PropName: string; PreferStrings: Boolean): Variant;
  1187. begin
  1188. end;
  1189. Procedure SetPropValue(Instance: TObject; const PropName: string; const Value: Variant);
  1190. begin
  1191. end;
  1192. { ---------------------------------------------------------------------
  1193. Easy access methods that appeared in Delphi 5
  1194. ---------------------------------------------------------------------}
  1195. Function IsPublishedProp(Instance: TObject; const PropName: string): Boolean;
  1196. begin
  1197. Result:=GetPropInfo(Instance,PropName)<>Nil;
  1198. end;
  1199. Function IsPublishedProp(AClass: TClass; const PropName: string): Boolean;
  1200. begin
  1201. Result:=GetPropInfo(AClass,PropName)<>Nil;
  1202. end;
  1203. Function PropIsType(Instance: TObject; const PropName: string; TypeKind: TTypeKind): Boolean;
  1204. begin
  1205. Result:=FindPropInfo(Instance,PropName)^.PropType^.Kind=TypeKind
  1206. end;
  1207. Function PropIsType(AClass: TClass; const PropName: string; TypeKind: TTypeKind): Boolean;
  1208. begin
  1209. Result:=PropType(AClass,PropName)=TypeKind
  1210. end;
  1211. Function PropType(Instance: TObject; const PropName: string): TTypeKind;
  1212. begin
  1213. Result:=FindPropInfo(Instance,PropName)^.PropType^.Kind;
  1214. end;
  1215. Function PropType(AClass: TClass; const PropName: string): TTypeKind;
  1216. begin
  1217. Result:=FindPropInfo(AClass,PropName)^.PropType^.Kind;
  1218. end;
  1219. Function IsStoredProp(Instance: TObject; const PropName: string): Boolean;
  1220. begin
  1221. Result:=IsStoredProp(instance,FindPropInfo(Instance,PropName));
  1222. end;
  1223. end.
  1224. {
  1225. $Log$
  1226. Revision 1.26 2004-06-02 14:33:18 michael
  1227. + Patch from matthias gaertner to fix GetMethodProp with procedural spec
  1228. Revision 1.25 2004/05/24 21:05:19 florian
  1229. * fixed comp property writing for cpus where comp=int64
  1230. Revision 1.24 2004/05/23 19:00:40 florian
  1231. + added widestring routines
  1232. Revision 1.23 2004/02/22 16:48:39 florian
  1233. * several 64 bit issues fixed
  1234. Revision 1.22 2004/02/21 22:53:49 florian
  1235. * several 64 bit/x86-64 fixes
  1236. Revision 1.21 2004/02/20 15:55:26 peter
  1237. * enable variant again
  1238. Revision 1.20 2003/12/24 22:27:13 peter
  1239. * removed assembler
  1240. * cleanup
  1241. Revision 1.19 2003/12/22 11:32:04 marco
  1242. * splitted up tintfflags into several components
  1243. Revision 1.18 2003/10/24 08:37:20 marco
  1244. * Fix from Peter
  1245. Revision 1.17 2003/10/17 20:58:27 olle
  1246. * Changed m68k to cpum68k, i386 to cpui386
  1247. Revision 1.16 2003/04/24 11:46:25 florian
  1248. * fixed wrong newlines
  1249. Revision 1.15 2003/03/29 16:55:56 michael
  1250. + Patch from Mattias Gaertner for single typeinfo
  1251. Revision 1.14 2002/09/07 16:01:22 peter
  1252. * old logs removed and tabs fixed
  1253. Revision 1.13 2002/04/04 18:32:59 peter
  1254. * merged getpropinfo fix
  1255. }