Создание DTD для объекта (XML)

{
Процедура генерации DTD для заданного объекта в
соответсвии с published интерфейсом его класса.

Вход:
  Component - объект
Выход:
  текст DTD в поток Stream
}
procedure GenerateDTD(Component: TObject; Stream: TStream);
var
  DTDList: TStringList;
begin
  DTDList := TStringList.Create;
  try
    GenerateDTDInternal(Component, DTDList, Stream, Component.ClassName);
  finally
    DTDList.Free;
  end;
end;

{
Внутренняя рекурсивная процедура генерации 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;
  begin
    if DTDList.IndexOf(ElementName) <> -1 then
      exit;
    DTDList.Add(ElementName);
    s := '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 do
    begin
      PropName := PropList^[i]^.name;

      PropTypeInf := PropList^[i]^.PropType^;
      PropInfo := PropList^[i];

      { Пропустить не поддерживаемые типы }
      if not (PropTypeInf^.Kind in [tkDynArray, tkArray,
      tkRecord, tkInterface, tkMethod]) then
      begin
        if 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;

        {
        Kод был бы полезен при использовании атрибутов
        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)then
          begin
            { Для дочерних свойств-классов - рекурсивный вызов }
            if (PropObject is TPersistent) then
              GenerateDTDInternal(PropObject, DTDList, Stream, PropName);
          end;
        end;
      end;
    end;

    { Индивидуальный подход к некоторым классам }
    { Для коллекций необходимо включить в модель содержания тип элемента }
    if (Component is TCollection) then
    begin
      if TagContent <> '' then
        TagContent := TagContent + '|';
      TagContent := TagContent + (Component as TCollection).ItemClass.ClassName + '*';
    end;

    { Добавляем модель содержания для элемента }
    addElement(ComponentTagName, TagContent);
  finally
    FreeMem(PropList, NumProps*sizeof(pointer));
  end;
end;