Рассылка закрыта
При закрытии подписчики были переданы в рассылку "Сетевой адаптер: осваиваем Интернет" на которую и рекомендуем вам подписаться.
Вы можете найти рассылки сходной тематики в Каталоге рассылок.
Все, что вы не знали, но хотели бы узнать о Delphi №10
Выпуск №10 Раздел: Язык Программирования Delphi Подраздел: RTTI и другие трюки с информацией о классах, модулях и т.п. Уважаемый подписчик, О чем будет следующий раздел - решать вам. Варианты: VCL Системные функции и Winapi Базы данных Работа с файловой системой Репортинг, работа с принтером Работа с сетью, Интернетом, протоколами Работа с графикой, мультимедиа
Ваши предложения высылайте на В этом выпуске:
Теория и практика использования RTTI
Delphi — это мощная среда визуальной разработки программ сочетающая в себе весьма простой и эффективный язык программирования, удивительный по быстроте компилятор и подкупающую открытость (в состав Delphi входят исходные тексты стандартных модулей и практически всех компонент библиотеки VCL). Однако, как и на солнце, так и в Delphi существуют пятна (на солнце черные, а в Delphi — белые), пятна недокументированных (или почти не документированных) возможностей. Одно из таких пятен — это информация о типах времени исполнения и методы работы с ней. Информация о типах времени исполнения.(Runtime Type Information, RTTI) —это данные, генерируемые компилятором Delphi о большинстве объектов вашей программы. RTTI представляет собой возможность языка, обеспечивающее приложение информацией об объектах (его имя, размер экземпляра, указатели на класс-предок, имя класса и т. д.) и о простых типах во время работы программы. Сама среда разработки использует RTTI для доступа к значениям свойств компонент, сохраняемых и считываемых из dfm-файлов и для отображения их в Object Inspector, Компилятор Delphi генерирует runtime информацию для простых типов, используемых в программе, автоматически. Для объектов, RTTI информация генерируется компилятором для свойств и методов, описанных в секции published в следующих случаях: Объект унаследован от объекта, дня которого генерируется такая информация. В качестве примера можно назвать объект TPersistent. Декларация класса обрамлена директивами компилятора {$M+} и {$M-}. Необходимо отметить, что published свойства ограничены по типу данных. Они могут быть перечисляемым типом, строковым типом, классом, интерфейсом или событием (указатель на метод класса). Также могут использоваться множества (set), если верхний и нижний пределы их базового типа имеют порядковые значения между 0 и 31 (иначе говоря, множество должно помещаться в байте, слове или двойном слове). Также можно иметь published свойство любого из вещественных типов (за исключением Real48). Свойство-массив не может быть published. Все методы могут быть published, но класс не может иметь два или более перегруженных метода с одинаковыми именами. Члены класса могут быть published, только если они являются классом или интерфейсом. Корневой базовый класс для всех VCL объектов и компонент, TObject, содержит ряд методов для работы с runtime информацией. Наиболее часто используемые из них приведены в таблице 1. Наиболее часто используемые методы класса TObject для работы с RTTI Метод Описание ClassType Возвращает тип класса объекта. Вызывается неявно компилятором при определении типа объекта при использовании операторов is и as ClassName Возвращает строку, содержащую название класса объекта. Например, для объекта типа TForm вызов этой функции вернет строку "TForm" ClassInfo Возвращает указатель на runtime информацию объекта InstanceSize Возвращает размер конкретного экземпляра объекта в байтах. Object Pascal предоставляет в распоряжение программиста два оператора, работа которых основана на неявном для программиста использовании RTTI информации. Это операторы is и as. Оператор is предназначен для проверки соответствия экземпляра объекта заданному объектному типу. Так, выражение вида: AObject is TSomeObjectType является истинным в том случае, если объект AObject является экземпляром класса TSomeObjectType или одного из порожденных от него классов. Следует отметить, что определенная проверка происходит еще на этапе компиляции программы. если фактические объект и класс несовместимы, компилятор выдаст ошибку в этом операторе. Так, следующий программный код if Edit1 is TForm then ShowMessage('Враки!'); даже не будет пропущен компилятором, и он выдаст сообщение о не совместимости типов (разумеется, что Edit1 — это компонент типа TEdit): Incompatible types: 'TForm' and 'TEdit'. Перейдем теперь к оператору as. Он введен в язык специально для приведения объектных типов. Посредством него можно рассматривать экземпляр объекта как принадлежащий к другому совместимому типу: AObject as TSomeObjectType Использование оператора as отличается от обычного способа приведения типов TSomeObjectType(AObject) наличием проверки на совместимость типов. Так при попытке приведения этого оператора с несовместимым типом он сгенерирует исключение EInvalidCast. Определенным недостатком операторов is и as является то, что присваиваемый фактически тип должен быть известен на этапе компиляции программы и поэтому на месте TSomeObjectType не может стоять переменная указателя на класс. Для иллюстрации только что написанного рассмотрим небольшой пример. Предположим у вас на форме имеется ряд компонент типа TEdit, и вы хотите реализовать их очистку их свойств перед созданием формы. С применением RTTI это можно сделать следующим программным кодом: var I: Integer; begin for I := 0 to ComponentCount - 1 do if Components[I] is TEdit then (Components[I] as TEdit).Text := ''; { или так TEdit (Components[I]).Text := ''; } end; Хочу обратить ваше внимание, а то, что стандартное приведение типа в данном примере предпочтительнее, поскольку в операторе if мы уже установили что компонент является объектом нужного нам типа и дополнительная проверка соответствия типов, проводимая оператором as, нам уже не нужна. Первые шаги в понимании RTTI мы уже сделали. Теперь переходим к подробностям. Все основополагающие определения типов, основные функции и процедуры для работы с runtime информацией находятся в модуле TypInfo. Этот модуль содержит две фундаментальные структуры для работы с RTTI — TTypeInfo и TTypeData (типы указателей на них — PTypeInfo и PTypeData соответственно). Суть работы с RTTI выглядит следующим образом. Получаем указатель на структуру типа TTypeInfo (для объектов указатель можно получить, вызвав метод, реализованный в TObject, ClassInfo, а для простых типов в модуле System существует функция TypeInfo). Затем, посредством имеющегося указателя и вызова функции GetTypeData получаем указатель на структуру типа TTypeData. Далее используя оба указателя и функции модуля TypInfo творим маленькие чудеса. Для пояснения написанного выше рассмотрим пример получения текстового вида значений перечисляемого типа. Пусть, например, это будет тип TBrushStyle. Этот тип описан в модуле Graphics следующим образом: TBrushStyle = (bsSolid, bsClear, bsHorizontal, bsVertical, bsFDiagonal, bsBDiagonal, bsCross, bsDiagCross); Вот мы и попробуем получить конкретные значения этого типа в виде текстовых строк. Для этого создайте пустую форму. Поместите на нее компонент типа TListBox с именем ListBox1 и кнопку. Реализацию события OnClick кнопки замените следующим кодом: var ATypeInfo: PTypeInfo; ATypeData: PTypeData; I: Integer; S: string; begin ATypeInfo := TypeInfo(TBrushStyle); ATypeData := GetTypeData(ATypeInfo); for I := ATypeData.MinValue to ATypeData.MaxValue do begin S := GetEnumName(ATypeInfo, I); ListBox1.Items.Add(S); end; end; Ну вот, теперь, когда на вооружении у нас есть базовые знания о противнике, чье имя, на первый взгляд выглядит непонятно и пугающее — RTTI настало время большого примера. Мы приступаем к созданию объекта опций для хранения различных параметров, использующего в своей работе мощь RTTI на полную катушку. Чем же примечателен, будет наш будущий класс? А тем, что он реализует сохранение в ini-файл и считывание из него свои свойства секции published. Его потомки будут иметь способность сохранять свойства, объявленные в секции published, и считывать их, не имея для этого никакой собственной реализации. Надо лишь создать свойство, а все остальное сделает наш базовый класс. Сохранение свойств организуется при уничтожении объекта (т.е. при вызове деструктора класса), а считывание и инициализация происходит при вызове конструктора класса. Декларация нашего класса имеет следующий вид: {$M+} TOptions = class(TObject) protected FIniFile: TIniFile; function Section: string; procedure SaveProps; procedure ReadProps; public constructor Create(const FileName: string); destructor Destroy; override; end; {$M-} Класс TOptions является производным от TObject и по этому, что бы компилятор генерировал runtime информацию его надо объявлять директивами {$M+/-}. Декларация класса весьма проста и вызвать затруднений в понимании не должна. Теперь переходим к реализации методов. constructor TOptions.Create(const FileName: string); begin FIniFile:=TIniFile.Create(FileName); ReadProps; end; destructor TOptions.Destroy; begin SaveProps; FIniFile.Free; inherited Destroy; end; Как видно реализация конструктора и деструктора тривиальна. В конструкторе мы создаем объект для работы с ini-файлом и организуем считывание свойств. В деструкторе мы в сохраняем значения свойств в файл и уничтожаем файловый объект. Всю нагрузку по реализации сохранения и считывания published-свойств несут методы SaveProps и ReadProps соответственно. procedure TOptions.SaveProps; var I, N: Integer; TypeData: PTypeData; List: PPropList; begin TypeData:= GetTypeData(ClassInfo); N:= TypeData.PropCount; if N <= 0 then Exit; GetMem(List, SizeOf(PPropInfo)*N); try GetPropInfos(ClassInfo,List); for I:= 0 to N - 1 do case List[I].PropType^.Kind of tkEnumeration, tkInteger: FIniFile.WriteInteger(Section, List[I]^.name,GetOrdProp(Self,List[I])); tkFloat: FIniFile.WriteFloat(Section, List[I]^.name, GetFloatProp(Self, List[I])); tkString, tkLString, tkWString: FIniFile.WriteString(Section, List[I]^.name, GetStrProp(Self, List[I])); end; finally FreeMem(List,SizeOf(PPropInfo)*N); end; end; procedure TOptions.ReadProps; var I, N: Integer; TypeData: PTypeData; List: PPropList; AInt: Integer; AFloat: Double; AStr: string; begin TypeData:= GetTypeData(ClassInfo); N:= TypeData.PropCount; if N <= 0 then Exit; GetMem(List, SizeOf(PPropInfo)*N); try GetPropInfos(ClassInfo, List); for I:= 0 to N - 1 do case List[I].PropType^.Kind of tkEnumeration, tkInteger: begin AInt:= GetOrdProp(Self, List[I]); AInt:= FIniFile.ReadInteger(Section, List[I]^.name, AInt); SetOrdProp(Self, List[i], AInt); end; tkFloat: begin AFloat:=GetFloatProp(Self,List[i]); AFloat:=FIniFile.ReadFloat(Section, List[I]^.name,AFloat); SetFloatProp(Self,List[i],AFloat); end; tkString, tkLString, tkWString: begin AStr:= GetStrProp(Self,List[i]); AStr:= FIniFile.ReadString(Section, List[I]^.name, AStr); SetStrProp(Self,List[i], AStr); end; end; finally FreeMem(List,SizeOf(PPropInfo)*N); end; end; function TOptions.Section: string; begin Result := ClassName; end; Теперь, для проверки работоспособности, и отладки объекта опций создадим новое приложение и подключим к нему модуль, в котором описан и реализован объект TOptions. Ниже приведен программный код, иллюстрирующий создание наследника от класса TOptions и его использования в главной (и единственной) форме нашего тестового приложения интерфейсная часть выглядит так: TMainOpt = class(TOptions) private FText: string; FHeight: Integer; FTop: Integer; FWidth: Integer; FLeft: Integer; procedure SetText(const Value: string); procedure SetHeight(Value: Integer); procedure SetLeft(Value: Integer); procedure SetTop(Value: Integer); procedure SetWidth(Value: Integer); published property Text: string read FText write SetText; property Left: Integer read FLeft write SetLeft; property Top: Integer read FTop write SetTop; property Width: Integer read FWidth write SetWidth; property Height: Integer read FHeight write SetHeight; end; TForm1 = class(TForm) Edit1: TEdit; procedure Edit1Change(Sender: TObject); private FMainOpt: TMainOpt; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; end; А вот и реализация: constructor TForm1.Create(AOwner: TComponent); var S: string; begin inherited Create(AOwner); S := ChangeFileExt(Application.ExeName, '.ini'); FMainOpt := TMainOpt.Create(S); Edit1.Text := FMainOpt.Text; Left := FMainOpt.Left; Top := FMainOpt.Top; Width := FMainOpt.Width; Height := FMainOpt.Height; end; destructor TForm1.Destroy; begin FMainOpt.Left := Left; FMainOpt.Top := Top; FMainOpt.Width := Width; FMainOpt.Height := Height; FMainOpt.Free; inherited Destroy; end; { TMainOpt } procedure TMainOpt.SetText(const Value: string); begin FText := Value; end; procedure TForm1.Edit1Change(Sender: TObject); begin FMainOpt.Text := Edit1.Text; end; procedure TMainOpt.SetHeight(Value: Integer); begin FHeight := Value; end; procedure TMainOpt.SetLeft(Value: Integer); begin FLeft := Value; end; procedure TMainOpt.SetTop(Value: Integer); begin FTop := Value; end; procedure TMainOpt.SetWidth(Value: Integer); begin FWidth := Value; end; В заключение своей статьи хочу сказать, что RTTI является недокументированной возможностью Object Pascal и поэтому информации на эту тему в справочной системе и электронной документации весьма мало. Наиболее легкодоступный способ изучить более подробно эту фишку — просмотр и изучение исходного текста модуля TypInfo.
The first parameter for GetPropList is of type PTypeInfo, and is part of the RTTI (Run Time Type Information) available for any object. The record structure defined: PPTypeInfo = ^PTypeInfo; PTypeInfo = ^TTypeInfo; TTypeInfo = record Kind: TTypeKind; Name: ShortString; {TypeData: TTypeData} end; The TTypeInfo record can be accessed through the objects ClassInfo property. For example, if you were getting the property list of a TButton, the call might look, so far, like this: GetPropList(Button1.ClassInfo, .... The second parameter, of type TTypeKinds, is a set type that acts as a filter for the kinds of properties to include in the list. There are a number of valid entries that could be included in the set (see TYPEINFO.PAS), but tkProperties covers the majority. Now our call to GetPropList would look like: GetPropList(Button1.ClassInfo, tkProperties .... The last parameter, PPropList is an array of PPropInfo and is defined in TYPEINFO.PAS: PPropList = ^TPropList; TPropList = array[0..16379] of PPropInfo; Now the call might read: procedure TForm1.FormCreate(Sender: TObject); var PropList: PPropList; begin PropList := AllocMem(SizeOf(PropList^)); GetPropList(TButton.ClassInfo, tkProperties + [tkMethod], PropList); {...} Getting Additional Information from the TTypeInfo Record: The example at the end of this document lists not just the property name, but it's type. The name of the property type resides in an additional set of structures. Let's take a second look at the TPropInfo record. Notice that it contains a PPTypeInfo that points ultimately to a TTypeInfo record. TTypeInfo contains the class name of the property. PPropInfo = ^TPropInfo; TPropInfo = packed record PropType: PPTypeInfo; GetProc: Pointer; SetProc: Pointer; StoredProc: Pointer; Index: Integer; Default: Longint; NameIndex: SmallInt; Name: ShortString; end; PPTypeInfo = ^PTypeInfo; PTypeInfo = ^TTypeInfo; TTypeInfo = record Kind: TTypeKind; Name: ShortString; {TypeData: TTypeData} end; The example below shows how to set up the call to GetPropList, and how to access the array elements. TForm will be referenced in this example instead of TButton, but you can substitute other values in the GetPropList call. The visible result will be to fill the list with the property name and type of the TForm properties. This project requires a TListBox. Enter the code below in the forms OnCreate event handler. uses TypInfo; procedure TForm1.FormCreate(Sender: TObject); var PropList: PPropList; i: integer; begin PropList := AllocMem(SizeOf(PropList^)); i := 0; try GetPropList(TForm.ClassInfo, tkProperties + [tkMethod], PropList); while (PropList^[i] <> Nil) and (i < High(PropList^)) do begin ListBox1.Items.Add(PropList^[i].Name + ': ' + PropList^[i].PropType^.Name); Inc(i); end; finally FreeMem(PropList); end; end;
function GetProperty(AControl: TPersistent; AProperty: String): PPropInfo; var i: Integer; props: PPropList; typeData: PTypeData; begin Result := nil; if (AControl = nil) or (AControl.ClassInfo = nil) then Exit; typeData := GetTypeData(AControl.ClassInfo); if (typeData = nil) or (typeData^.PropCount = 0) then Exit; GetMem(props, typeData^.PropCount * SizeOf(Pointer)); try GetPropInfos(AControl.ClassInfo, props); for i := 0 to typeData^.PropCount - 1 do begin with Props^[i]^ do if (Name = AProperty) then result := Props^[i]; end; finally FreeMem(props); end; end; procedure TForm1.Button1Click(Sender: TObject); var propInfo: PPropInfo; begin PropInfo := GetProperty(Button1.Font, 'Name'); if PropInfo <> nil then SetStrProp(Button1.Font, PropInfo, 'Arial'); end; You can use RTTI to do this. Here is how to change a particular component: procedure TForm1.BtnClick(Sender: TObject); var p: PPropInfo; f: TFont; begin f := TFont.Create; {Setup the font properties} f.Name := 'Arial'; p := GetPropInfo(Sender.ClassInfo, 'Font'); if Assigned(p) then SetOrdProp(Sender, p, Integer(f)); f.Free; end; To get at all the forms loop through the Screen global variable. For each form loop through its Components list calling the above procedure (or something close). If you only create your components at design time that is it. If you create some at runtime and the owner is not the form, then for each component loop through its Components list recursively to get at all the owned components. I am building a routine that checks our forms for validity before deploying them. I would like to use some kind of structure that tests if a component type has access to a certain property, something like: " if (self.Controls[b] has Tag) then ...". Can anyone offer suggestions? Here's an example of setting a string property for a component if it exists and another for an integer property: procedure SetStringPropertyIfExists(AComp: TComponent; APropName: String; AValue: String); var PropInfo: PPropInfo; TK: TTypeKind; begin PropInfo := GetPropInfo(AComp.ClassInfo, APropName); if PropInfo <> nil then begin TK := PropInfo^.PropType^.Kind; if (TK = tkString) or (TK = tkLString) or (TK = tkWString) then SetStrProp(AComp, PropInfo, AValue); end; end; procedure SetIntegerPropertyIfExists(AComp: TComponent; APropName: String; AValue: Integer); var PropInfo: PPropInfo; begin PropInfo := GetPropInfo(AComp.ClassInfo, APropName); if PropInfo <> nil then begin if PropInfo^.PropType^.Kind = tkInteger then SetOrdProp(AComp, PropInfo, AValue); end; end;
unit PropertyList; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons; type TMyStream = class(TFileStream) private FFred: integer; published property Fred: integer read FFred write FFred; end; type TFrmPropertyList = class(TForm) SpeedButton1: TSpeedButton; ListBox1: TListBox; procedure SpeedButton1Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var FrmPropertyList: TFrmPropertyList; implementation {$R *.DFM} uses TypInfo; procedure ListProperties(AInstance: TPersistent; AList: TStrings); var i: integer; pInfo: PTypeInfo; pType: PTypeData; propList: PPropList; propCnt: integer; tmpStr: string; begin pInfo := AInstance.ClassInfo; if (pInfo = nil) or (pInfo^.Kind <> tkClass) then raise Exception.Create('Invalid type information'); pType := GetTypeData(pInfo); {Pointer to TTypeData} AList.Add('Class name: ' + pInfo^.Name); {If any properties, add them to the list} propCnt := pType^.PropCount; if propCnt > 0 then begin AList.Add (EmptyStr); tmpStr := IntToStr(propCnt) + ' Propert'; if propCnt > 1 then tmpStr := tmpStr + 'ies' else tmpStr := tmpStr + 'y'; AList.Add(tmpStr); FillChar(tmpStr[1], Length(tmpStr), '-'); AList.Add(tmpStr); {Get memory for the property list} GetMem(propList, sizeOf(PPropInfo) * propCnt); try {Fill in the property list} GetPropInfos(pInfo, propList); {Fill in info for each property} for i := 0 to propCnt - 1 do AList.Add(propList[i].Name + ': ' + propList[i].PropType^.Name); finally FreeMem(propList, sizeOf(PPropInfo) * propCnt); end; end; end; function GetPropertyList(AControl: TPersistent; AProperty: string): PPropInfo; var i: integer; props: PPropList; typeData: PTypeData; begin Result := nil; if (AControl = nil) or (AControl.ClassInfo = nil) then Exit; typeData := GetTypeData(AControl.ClassInfo); if (typeData = nil) or (typeData^.PropCount = 0) then Exit; GetMem(props, typeData^.PropCount * SizeOf(Pointer)); try GetPropInfos(AControl.ClassInfo, props); for i := 0 to typeData^.PropCount - 1 do begin with Props^[i]^ do if (Name = AProperty) then result := Props^[i]; end; finally FreeMem(props); end; end; procedure TFrmPropertyList.SpeedButton1Click(Sender: TObject); var c: integer; begin ListProperties(self, ListBox1.Items); for c := 0 to ComponentCount - 1 do begin ListBox1.Items.Add(EmptyStr); ListProperties(Components[c], ListBox1.Items); end; end; end.
unit MorePropInfo; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TFrmMorePropInfo = class(TForm) Button1: TButton; Button2: TButton; ListBox1: TListBox; procedure Button2Click(Sender: TObject); private { Private declarations } public { Public declarations } end; var FrmMorePropInfo: TFrmMorePropInfo; implementation {$R *.DFM} uses TypInfo; procedure GetPropertyValues(AObj: TObject; AValues: TStrings); var count: integer; data: PTypeData; default: string; i: integer; info: PTypeInfo; propList: PPropList; propInfo: PPropInfo; propName: string; value: variant; begin info := AObj.ClassInfo; data := GetTypeData(info); GetMem(propList, data^.PropCount * SizeOf(PPropInfo)); try count := GetPropList(info, tkAny, propList); for i := 0 to count - 1 do begin propName := propList^[i]^.Name; propInfo := GetPropInfo(info, propName); if propInfo <> nil then begin case propInfo^.PropType^.Kind of tkClass, tkMethod: value := '$' + IntToHex(GetOrdProp(AObj, propInfo), 8); tkFloat: value := GetFloatProp(AObj, propInfo); tkInteger: value := GetOrdProp(AObj, propInfo); tkString, tkLString, tkWString: value := GetStrProp(AObj, propInfo); tkEnumeration: value := GetEnumProp(AObj, propInfo); else value := '???'; end; if propInfo.default = longint($80000000) then default := 'none' else default := IntToStr(propInfo.default); AValues.Add(Format('%s: %s [default: %s]', [propName, value, default])); {$80000000 apparently indicates "no default"} end; end; finally FreeMem(propList, data^.PropCount * SizeOf(PPropInfo)); end; end; procedure TFrmMorePropInfo.Button2Click(Sender: TObject); var count: integer; data: PTypeData; i: integer; info: PTypeInfo; propList: PPropList; propInfo: PPropInfo; propName: string; propVal: variant; tmpS: string; begin info := Button2.ClassInfo; data := GetTypeData(info); GetMem(propList, data^.PropCount * SizeOf(PPropInfo)); try count := GetPropList(info, tkAny, propList); ListBox1.Clear; for i := 0 to count - 1 do begin propName := propList^[i]^.Name; propInfo := GetPropInfo(info, propName); if propInfo <> nil then begin case propInfo^.PropType^.Kind of tkClass, tkMethod: propVal := '$' + IntToHex(GetOrdProp(Button2, propInfo), 8); tkFloat: propVal := GetFloatProp(Button2, propInfo); tkInteger: propVal := GetOrdProp(Button2, propInfo); tkString, tkLString, tkWString: propVal := GetStrProp(Button2, propInfo); tkEnumeration: propVal := GetEnumProp(Button2, propInfo); else propVal := '...'; end; tmpS := propVal; ListBox1.Items.Add(Format('%s: %s [default: %s]', [propName, tmpS, '$' + IntToHex(propInfo.default, 8)])); {$80000000 apparently indicates "no default"} end; end; finally FreeMem(propList, data^.PropCount * SizeOf(PPropInfo)); end; end; end.
procedure EnumMethods( aClass: TClass; lines: TStrings ); type TMethodtableEntry = packed Record len: Word; adr: Pointer; name: ShortString; end; {Note: name occupies only the size required, so it is not a true shortstring! The actual entry size is variable, so the method table is not an array of TMethodTableEntry!} var pp: ^Pointer; pMethodTable: Pointer; pMethodEntry: ^TMethodTableEntry; i, numEntries: Word; begin if aClass = nil then Exit; pp := Pointer(Integer( aClass ) + vmtMethodtable); pMethodTable := pp^; lines.Add(format('Class %s: method table at %p', [aClass.Classname, pMethodTable ] )); if pMethodtable <> nil then begin {first word of the method table contains the number of entries} numEntries := PWord( pMethodTable )^; lines.Add(format(' %d published methods', [numEntries] )); {make pointer to first method entry, it starts at the second word of the table} pMethodEntry := Pointer(Integer( pMethodTable ) + 2); for i := 1 to numEntries do begin with pMethodEntry^ do lines.Add(format( ' %d: len: %d, adr: %p, name: %s', [i, len, adr, name] )); {make pointer to next method entry} pMethodEntry := Pointer(Integer( pMethodEntry ) + pMethodEntry^.len); end; end; EnumMethods( aClass.ClassParent, lines ); end; procedure TForm2.Button1Click(Sender: TObject); begin memo1.clear; EnumMethods( Classtype, memo1.lines ); end; function GetComponentProperties(Instance: TPersistent; AList: TStrings): Integer; var I, Count: Integer; PropInfo: PPropInfo; PropList: PPropList; begin Result := 0; Count := GetTypeData(Instance.ClassInfo)^.PropCount; if Count > 0 then begin GetMem(PropList, Count * SizeOf(Pointer)); try GetPropInfos(Instance.ClassInfo, PropList); for I := 0 to Count - 1 do begin PropInfo := PropList^[I]; if PropInfo = nil then Break; if IsStoredProp(Instance, PropInfo) then begin { case PropInfo^.PropType^.Kind of tkInteger: tkMethod: tkClass: ... end; } end; Result := AList.Add(PropInfo^.Name); end; finally FreeMem(PropList, Count * SizeOf(Pointer)); end; end; end; Tip by Grega Loboda uses TypInfo procedure ListProperties(AInstance: TPersistent; AList: TStrings); var i: integer; pInfo: PTypeInfo; pType: PTypeData; propList: PPropList; propCnt: integer; tmpStr: string; begin pInfo := AInstance.ClassInfo; if (pInfo = nil) or (pInfo^.Kind <> tkClass) then raise Exception.Create('Invalid type information'); pType := GetTypeData(pInfo); {Pointer to TTypeData} AList.Add('Class name: ' + pInfo^.Name); {If any properties, add them to the list} propCnt := pType^.PropCount; if propCnt > 0 then begin AList.Add(EmptyStr); tmpStr := IntToStr(propCnt) + ' Propert'; if propCnt > 1 then tmpStr := tmpStr + 'ies' else tmpStr := tmpStr + 'y'; AList.Add(tmpStr); FillChar(tmpStr[1], Length(tmpStr), '-'); AList.Add(tmpStr); {Get memory for the property list} GetMem(propList, sizeOf(PPropInfo) * propCnt); try {Fill in the property list} GetPropInfos(pInfo, propList); {Fill in info for each property} for i := 0 to propCnt - 1 do AList.Add(propList[i].Name+': '+propList[i].PropType^.Name); finally FreeMem(propList, sizeOf(PPropInfo) * propCnt); end; end; end; function GetPropertyList(AControl: TPersistent; AProperty: string): PPropInfo; var i: integer; props: PPropList; typeData: PTypeData; begin Result := nil; if (AControl = nil) or (AControl.ClassInfo = nil) then Exit; typeData := GetTypeData(AControl.ClassInfo); if (typeData = nil) or (typeData^.PropCount = 0) then Exit; GetMem(props, typeData^.PropCount * SizeOf(Pointer)); try GetPropInfos(AControl.ClassInfo, props); for i := 0 to typeData^.PropCount - 1 do begin with Props^[i]^ do if (Name = AProperty) then result := Props^[i]; end; finally FreeMem(props); end; end; And calling this code by: ListProperties(TProject(treeview1.items[0].data), memo3.lines); My tProject is defined as type TProject = class(tComponent) private FNaam: string; procedure SetNaam(const Value: string); public constructor Create(AOwner: tComponent); destructor Destroy; published property Naam: string read FNaam write SetNaam; end; Also note the output, there seem to be 2 standard properties (Name and Tag) ! Memo3 Class name: TProject 3 Properties ------------------- Name: TComponentName Tag: Integer Naam: String
var proplist: PPropList; numprops, i: Integer; begin result := false; getmem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer)); try NumProps := getproplist(comp.classInfo, tkProperties, proplist); for i := 0 to pred (NumProps) do begin if comparetext(proplist[i]^.Name, prop) = 0 then begin result := true; break; end; end; finally freemem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer)); end; end; procedure setcomppropstring(comp: TComponent; const prop, s: String); var proplist: PPropList; numprops, i: Integer; begin getmem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer)); try NumProps := getproplist(comp.classInfo, tkProperties, proplist); for i := 0 to pred (NumProps) do begin if (comparetext(proplist[i]^.Name, prop) = 0) and (comparetext(proplist[i]^.proptype^.name, 'string') = 0 then begin setStrProp(comp, proplist[i], s); break; end; end; finally freemem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer)); end; end; function HasProperty(Obj: TObject; Prop: string): PPropInfo; begin Result := GetPropInfo(Obj.ClassInfo, Prop); end; procedure TForm1.Button1Click(Sender: TObject); var p: pointer; begin p := HasProperty(Button1, 'Color'); if p <> nil then SetOrdProp(Button1, p, clRed) else ShowMessage('Button has no color property'); p := HasProperty(Label1, 'Color'); if p <> nil then SetOrdProp(Label1, p, clRed) else ShowMessage('Label has no color property'); p := HasProperty(Label1.Font, 'Color'); if p <> nil then SetOrdProp(Label1.Font.Color, p, clBlue) else ShowMessage('Label.Font has no color property'); end; TypInfo.GetPropInfo (My_Component.ClassInfo, 'Hint') <> nil Таким образом можно узнать наличие таковой published "прОперти". А вот если это не поможет, то можно и "ломиком" поковыряться посредством FieldAddress. Однако этот метод дает адрес полей, которые перечисляются сразу после объявления класса как в unit'ых форм. А вот ежели "прОперть" нигде не "засветилась" (published) то фиг ты ее достанешь. А модифицировать значение можно посредством прямой записи по адресу FieldAddress (крайне нежелательно!) либо используя цивилизованный способы, перечисленные в unit'е TypInfo. Модифицировать кучу объектов можно организовав цикл перебора оных с получением в цикле PropertyInfo объекта и записи в объект на основе PropInfo.
Сайт рассылки Здесь Так же можете посетить несколько сайтов для заработка в Интернете: |
| В избранное | ||
