Загрузка XML в объект

var
  // Буфер, в котором находится XML документ
  Buffer: PChar;
  // Указатель на текущее положение парсера XML документа
  TokenPtr: PChar;

{
Загружает в компонент данные из потока с XML-кодом.
Вход:
Component - компонент для конвертации
Stream - источник загрузки XML
Предусловия:
Объект Component должен быть создан до вызова процедуры
}
procedure DeSerialize(Component: TObject; Stream: TStream);
begin
  GetMem(Buffer, Stream.Size);
  try
    { Получаем данные из потока }
    Stream.read(Buffer[0], Stream.Size + 1);
    { Устанавливаем текущий указатель чтения данных }
    TokenPtr := Buffer;
    { Вызываем загрузчик }
    DeSerializeInternal(Component, Component.ClassName);
  finally
    FreeMem(Buffer);
  end;
end;

{
Рекурсивная процедура загрузки объекта их текстового буфера с XML
Вызывается из:
Serialize()
Вход:
Component - компонент для конвертации
ComponentTagName - имя XML тега объекта
}
procedure DeSerializeInternal(Component: TObject; const ComponentTagName: string);
var
  BlockStart, BlockEnd, TagStart, TagEnd: PChar;
  TagName, TagValue: PChar;
  TypeInf: PTypeInfo;
  TypeData: PTypeData;
  PropIndex: integer;
  AName: string;
  PropList: PPropList;
  NumProps: word;

  { Поиск у объекта свойства с заданным именем }
  function FindProperty(TagName: PChar): integer;
  var
    i: integer;
  begin
    Result := -1;
    for i := 0 to NumProps-1 do
      if CompareText(PropList^[i]^.name, TagName) = 0 then
      begin
        Result := i;
        break;
      end;
  end;

  procedure SkipSpaces(var TagEnd: PChar);
  begin
    while (TagEnd[0] in [#0..#20]) do
      inc(TagEnd);
  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);

    { ищем открывающий тег }

    BlockStart := StrPos(TokenPtr, PChar('<' + ComponentTagName + '>'));
    inc(BlockStart, length(ComponentTagName) + 2);
    { ищем закрывающий тег }
    BlockEnd := StrPos(BlockStart, PChar('<<' + ComponentTagName + '>'));

    TagEnd := BlockStart;
    SkipSpaces(TagEnd);

    { XML парсер }
    while TagEnd do
    begin
      TagStart := StrPos(TagEnd, '<');
      TagEnd := StrPos(TagStart, '>');
      GetMem(TagName, TagEnd - TagStart + 1);
      try
        { TagName - имя тега }
        StrLCopy(TagName, TagStart + 1, TagEnd - TagStart - 1);

        TagEnd := StrPos(TagStart, PChar('{ TagValue - значение тега }
        StrLCopy(TagValue, TagStart, TagEnd - TagStart);

        { поиск свойства, соответствующего тегу }
        PropIndex := FindProperty(TagName);
        if PropIndex = -1 then
          raise Exception.Create(
          'TglXMLSerializer.DeSerializeInternal: Uncknown property: ' + TagName);

        SetPropertyValue(Component, PropList^[PropIndex], TagValue);

        inc(TagEnd, length('end;
      finally
        FreeMem(TagName);
      end;
    end;
  finally
    FreeMem(PropList, NumProps*sizeof(pointer));
end; 

end;

procedure SetPropertyValue(Component: TObject; PropInfo: PPropInfo; Value: PChar);
var
  PropTypeInf: PTypeInfo;
  PropObject: TObject;
  CollectionItem: TCollectionItem;
  sValue: string;
begin
  PropTypeInf := PropInfo.PropType^;

  case PropTypeInf^.Kind of
    tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet,
    tkWChar, tkLString, tkWString, tkVariant:
    begin
      sValue := StrPas(Value);
      { Для корректного преобразования парсером tkSet нужны угловые скобки }
      if PropTypeInf^.Kind = tkSet then
        sValue := '[' + sValue + ']';
      SetPropValue(Component, PropInfo^.name, sValue);
    end;
    tkClass:
    begin
      PropObject := GetObjectProp(Component, PropInfo);
      if Assigned(PropObject)then
      begin
        { Индивидуальный подход к некоторым классам }
        if (PropObject is TStrings) then { Текстовые списки }
          TStrings(PropObject).CommaText := Value
        else
        if (PropObject is TCollection) then { Коллекции }
        begin
          while true do { Заранее не известно число элементов в коллекции }
          begin
            CollectionItem := (PropObject as TCollection).Add;
            try
              DeSerializeInternal(CollectionItem, CollectionItem.ClassName);
            except { Исключение, если очередной элемент не найден }
              CollectionItem.Free;
              break;
            end;
          end;
        end
        else { Для остальных классов - рекурсивная обработка }
          DeSerializeInternal(PropObject, PropInfo^.name);
      end;
    end;
  end;
end;