{ Внутренняя рекурсивная процедура генерации DTD для заданного объекта. Вход: Component - объект DTDList - список уже определенных элементов DTD для предотвращения повторений. Выход: текст DTD в поток Stream } procedure GenerateDTDInternal(Component: TObject; DTDList: TStrings; Stream: TStream; const ComponentTagName: string); var PropInfo: PPropInfo; TypeInf, PropTypeInf: PTypeInfo; EnumInfo: PTypeInfo; TypeData: PTypeData; i, j: integer; AName, PropName, sPropValue, s, TagContent: string; PropList: PPropList; NumProps: word; PropObject: TObject; const PCDATA = '#PCDATA'; procedure addElement(const ElementName: string; Data: string); var s: string; beginif DTDList.IndexOf(ElementName) <> -1 then exit; DTDList.Add(ElementName); s := '<!ELEMENT ' + ElementName + ' '; if Data = '' then Data := PCDATA; s := s + '(' + Data + ')>'#13#10; Stream.Write(PChar(s)[0], length(s)); end; begin { Playing with RTTI } TypeInf := Component.ClassInfo; AName := TypeInf^.Name; TypeData := GetTypeData(TypeInf); NumProps := TypeData^.PropCount; GetMem(PropList, NumProps*sizeof(pointer)); try { Получаем список свойств } GetPropInfos(TypeInf, PropList); TagContent := ''; for i := 0 to NumProps-1 dobegin PropName := PropList^[i]^.Name; PropTypeInf := PropList^[i]^.PropType^; PropInfo := PropList^[i]; { Пропустить не поддерживаемые типы } ifnot (PropTypeInf^.Kind in [tkDynArray, tkArray, tkRecord, tkInterface, tkMethod]) thenbeginif TagContent <> '' then TagContent := TagContent + '|'; TagContent := TagContent + PropName; end; case PropTypeInf^.Kind of tkInteger, tkChar, tkFloat, tkString, tkWChar, tkLString, tkWString, tkVariant, tkEnumeration, tkSet: begin { Перевод в DTD. Для данных типов модель содержания - #PCDATA } addElement(PropName, PCDATA); end; { код был бы полезен при использовании атрибутов tkEnumeration: begin TypeData:= GetTypeData(GetTypeData(PropTypeInf)^.BaseType^); s := ''; for j := TypeData^.MinValue to TypeData^.MaxValue do begin if s <> '' then s := s + '|'; s := s + GetEnumName(PropTypeInf, j); end; addElement(PropName, s); end; } tkClass: { Для классовых типов рекурсивная обработка } begin PropObject := GetObjectProp(Component, PropInfo); if Assigned(PropObject)thenbegin { Для дочерних свойств-классов - рекурсивный вызов } if (PropObject is TPersistent) then GenerateDTDInternal(PropObject, DTDList, Stream, PropName); end; end; end; end; { Индивидуальный подход к некоторым классам } { Для коллекций необходимо включить в модель содержания тип элемента } if (Component is TCollection) thenbeginif TagContent <> '' then TagContent := TagContent + '|'; TagContent := TagContent + (Component as TCollection).ItemClass.ClassName + '*'; end; { Добавляем модель содержания для элемента } addElement(ComponentTagName, TagContent); finally FreeMem(PropList, NumProps*sizeof(pointer)); end; end;
Закоментированный код нам не нужен, но он не удален, т.к. он демонстрирует получение списка возможных значений для перечисления (Enumeration) и набора (Set). Это может понадобится, если появится необходимость генерировать свойства в виде атрибутов XML тегов и, соответственно, DTD для возможных значений этих атрибутов.
