Компонент для XML сериализации

procedure Serialize(Component: TObject; Stream: TStream); 

procedure DeSerialize(Component: TObject; Stream: TStream); 

property GenerateFormattedXML; // создавать форматированный XML код 
property ExcludeEmptyValues;   // пропускать пустые значения свойств 
property ExcludeDefaultValues; // пропускать значения по умолчанию 
property OnGetXMLHeader;       // позволяет указать свой XML заголовок 

unit glXMLSerializer;
{
Globus Delphi VCL Extensions Library ' GLOBUS LIB '
Copyright (c) 2001 Chudin A.V, chudin@yandex.ru
glXMLSerializer Unit 08.2001 component TglXMLSerializer
}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, comctrls, TypInfo;

type
  TOnGetXMLHeader = procedure Ошибка! Недопустимый объект гиперссылки.
  (Sender: TObject; var Value: string) of object;

  XMLSerializerException = class(Exception)
end;

  TglXMLSerializer = class(TComponent)
  private
    { Private declarations }
    Buffer: PChar;
    BufferLength: DWORD;
    TokenPtr: PChar;
    OutStream: TStream;

    FOnGetXMLHeader: TOnGetXMLHeader;
    FGenerateFormattedXML: boolean;
    FExcludeEmptyValues: boolean;
    FExcludeDefaultValues: boolean;
    FReplaceReservedSymbols: boolean;
    procedure check(Expr: boolean; const message: string);
    procedure WriteOutStream(Value: string);
  protected
    procedure SerializeInternal(Component: TObject; Level: integer = 1);
    procedure DeSerializeInternal(Component: TObject; const ComponentTagName:
    string; ParentBlockEnd: PChar = nil);
    procedure GenerateDTDInternal(Component: TObject; DTDList: TStrings;
    Stream: TStream; const ComponentTagName: string);
    procedure SetPropertyValue(Component: TObject; PropInfo: PPropInfo;
    Value, ValueEnd: PChar; ParentBlockEnd: PChar);
  public
    tickCounter, tickCount: DWORD;
    constructor Create(AOwner: TComponent); override;
    { Сериализация объекта в XML }
    procedure Serialize(Component: TObject; Stream: TStream);
    { Загрузка XML в объект }
    procedure DeSerialize(Component: TObject; Stream: TStream);
    { Генерация DTD }
    procedure GenerateDTD(Component: TObject; Stream: TStream);
  published
    property GenerateFormattedXML: boolean
    read FGenerateFormattedXML write FGenerateFormattedXML default true;
    property ExcludeEmptyValues: boolean
    read FExcludeEmptyValues write FExcludeEmptyValues;
    property ExcludeDefaultValues: boolean
    read FExcludeDefaultValues write FExcludeDefaultValues;
    property ReplaceReservedSymbols: boolean
    read FReplaceReservedSymbols write FReplaceReservedSymbols;
    property OnGetXMLHeader: TOnGetXMLHeader
    read FOnGetXMLHeader write FOnGetXMLHeader;
end;

procedure register;

implementation

uses dsgnintf, glUtils;

const
  ORDINAL_TYPES = [tkInteger, tkChar, tkEnumeration, tkSet];
  TAB: string = #9;
  CR: string = #13#10;

procedure register;
begin
  RegisterComponents('Gl Components', [TglXMLSerializer]);
end;


constructor TglXMLSerializer.Create(AOwner: TComponent);
begin
  inherited;
  //...defaults
  FGenerateFormattedXML := true;
end;

{ пишет строку в выходящий поток. Исп-ся при сериализации }
procedure TglXMLSerializer.WriteOutStream(Value: string);
begin
  OutStream.write(Pchar(Value)[0], Length(Value));
end;

{
Конвертирует компонент в XML-код в соответствии
с published интерфейсом класса объекта.
Вход:
Component - компонент для конвертации
Выход:
текст XML в поток Stream
}
procedure TglXMLSerializer.Serialize(Component: TObject; Stream: TStream);
var
  Result: string;
begin
  TAB := IIF(GenerateFormattedXML, #9, '');
  CR := IIF(GenerateFormattedXML, #13#10, '');

  Result := '';
  { Получение XML заголовка }
  if Assigned(OnGetXMLHeader) then
    OnGetXMLHeader(self, Result);

  OutStream := Stream;

  WriteOutStream( PChar(CR + '<' + Component.ClassName + '>') );
  SerializeInternal(Component);
  WriteOutStream( PChar(CR + '</' ? + Component.ClassNameend;

  {
  Внутренняя процедура конвертации объекта в XML
  Вызывается из:
  Serialize()
  Вход:
  Component - компонент для конвертации
  Level - уровень вложенности тега для форматирования результата
  Выход:
  строка XML в выходной поток через метод WriteOutStream()
  }

  procedure TglXMLSerializer.SerializeInternal(Component: TObject; Level: integer = 1);
  var
    PropInfo: PPropInfo;
    TypeInf, PropTypeInf: PTypeInfo;
    TypeData: PTypeData;
    i, j: integer;
    AName, PropName, sPropValue: string;
    PropList: PPropList;
    NumProps: word;
    PropObject: TObject;

    { Добавляет открывающий тег с заданным именем }
    procedure addOpenTag(const Value: string);
    begin
      WriteOutStream(CR + DupStr(TAB, Level) + '<' + Value + '>');
      inc(Level);
    end;

    { Добавляет закрывающий тег с заданным именем }
    procedure addCloseTag(const Value: string; addBreak: boolean = false);
    begin
      dec(Level);
      if addBreak then
        WriteOutStream(CR + DupStr(TAB, Level));
      WriteOutStream('</' ? + Valueend;

      { Добавляет значение в результирующую строку }
      procedure addValue(const Value: string);
      begin
        WriteOutStream(Value);
      end;
  begin
    // Result := '';

    { Playing with RTTI }
    TypeInf := Component.ClassInfo;
    AName := TypeInf^.name;
    TypeData := GetTypeData(TypeInf);
    NumProps := TypeData^.PropCount;

    GetMem(PropList, NumProps*sizeof(pointer));
    try

      { Получаем список свойств }
      GetPropInfos(TypeInf, PropList);

      for i := 0 to NumProps-1 do
      begin
        PropName := PropList^[i]^.name;

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

        { Хочет ли свойство, чтобы его сохранили ? }
        if not IsStoredProp(Component, PropInfo) then
          continue;

        case PropTypeInf^.Kind of
          tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet,
          tkWChar, tkLString, tkWString, tkVariant:
          begin
            { Получение значения свойства }
            sPropValue := GetPropValue(Component, PropName, true);

            { Проверяем на пустое значение и значение по умолчанию }
            if ExcludeEmptyValues and (sPropValue = '') then
              continue;
            if ExcludeDefaultValues and (PropTypeInf^.Kind in ORDINAL_TYPES)
            and (sPropValue = IntToStr(PropInfo.default)) then
              continue;

            { Замена спецсимволов }
            if FReplaceReservedSymbols then
            begin
              sPropValue := StringReplace(sPropValue, '<', '%lt;', [rfReplaceAll]);
              sPropValue := StringReplace(sPropValue, '>', '%gt;', [rfReplaceAll]);
              sPropValue := StringReplace(sPropValue, '&', '%', [rfReplaceAll]);
            end;

            { Перевод в XML }
            addOpenTag(PropName);
            addValue(sPropValue); { Добавляем значение свойства в результат }
            addCloseTag(PropName);
          end;
          tkClass: { Для классовых типов рекурсивная обработка }
          begin
            addOpenTag(PropName);

            PropObject := GetObjectProp(Component, PropInfo);
            if Assigned(PropObject)then
            begin
              { Для дочерних свойств-классов - рекурсивный вызов }
              if (PropObject is TPersistent) then
                SerializeInternal(PropObject, Level);

              { Индивидуальный подход к некоторым классам }
              if (PropObject is TStrings) then { Текстовые списки }
              begin
                WriteOutStream(TStrings(PropObject).CommaText);
              end
              else
              if (PropObject is TCollection) then { Коллекции }
              begin
                SerializeInternal(PropObject, Level);
                for j := 0 to (PropObject as TCollection).Count-1 do
                begin { Контейнерный тег по имени класса }
                  addOpenTag(TCollection(PropObject).Items[j].ClassName);
                  SerializeInternal(TCollection(PropObject).Items[j], Level);
                  addCloseTag(TCollection(PropObject).Items[j].ClassName, true);
                end
              end;
              { Здесь можно добавить обработку остальных классов: TTreeNodes, TListItems }
            end;
          { После обработки свойств закрываем тег объекта }
          addCloseTag(PropName, true);
        end;
      end;
    end;
  finally
    FreeMem(PropList, NumProps*sizeof(pointer));
  end;
end;


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

{
Рекурсивная процедура загрузки объекта их текстового буфера с XML
Вызывается из:
Serialize()
Вход:
Component - компонент для конвертации
ComponentTagName - имя XML тега объекта
ParentBlockEnd - указатель на конец XML описания родительского тега
}
procedure TglXMLSerializer.DeSerializeInternal(Component: TObject;
const ComponentTagName: string; ParentBlockEnd: PChar = nil);
var
  BlockStart, BlockEnd, TagStart, TagEnd: PChar;
  TagName, TagValue, TagValueEnd: 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 CompareStr(PropList^[i]^.name, TagName) = 0 then
      begin
        Result := i;
        break;
      end;
  end;

  procedure SkipSpaces(var TagEnd: PChar);
  begin
    while TagEnd[0] <= #33 do
      inc(TagEnd);
  end;

  function StrPos2(const Str1, Str2: PChar; Str2Len: DWORD): PChar; assembler;
  asm
    PUSH EDI
    PUSH ESI
    PUSH EBX
    or EAX,EAX // Str1
    JE @@2 // если строка Str1 пуста - на выход
    or EDX,EDX // Str2
    JE @@2 // если строка Str2 пуста - на выход
    MOV EBX,EAX
    MOV EDI,EDX // установим смещение для SCASB - подстрока Str2
    xor AL,AL // обнулим AL

    push ECX // длина строки

    MOV ECX,0FFFFFFFFH // счетчик с запасом
    REPNE SCASB // ищем конец подстроки Str2
    not ECX // инвертируем ECX - получаем длину строки+1
    DEC ECX // в ECX - длина искомой подстроки Str2

    JE @@2 // при нулевой длине - все на выход
    MOV ESI,ECX // сохраняем длину подстроки в ESI

    pop ECX

    SUB ECX,ESI // ECX == разница длин строк : Str1 - Str2
    JBE @@2 // если длина подсроки больше длине строки - выход
    MOV EDI,EBX // EDI - начало строки Str1
    LEA EBX,[ESI-1] // EBX - длина сравнения строк
    @@1: MOV ESI,EDX // ESI - смещение строки Str2
    LODSB // загужаем первый символ подстроки в AL
    REPNE SCASB // ищем этот символ в строке EDI
    JNE @@2 // если символ не обнаружен - на выход
    MOV EAX,ECX // сохраним разницу длин строк
    PUSH EDI // запомним текущее смещение поиска
    MOV ECX,EBX
    REPE CMPSB // побайтно сравниваем строки
    POP EDI
    MOV ECX,EAX
    JNE @@1 // если строки различны - ищем следующее совпадение первого символа
    LEA EAX,[EDI-1]
    JMP @@3
    @@2: xor EAX,EAX
    @@3: POP EBX
    POP ESI
    POP EDI
  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 := StrPos2(TokenPtr, PChar('<' + ComponentTagName + '>'), BufferLength);
    check(BlockStart <> nil, 'Открывающий тег не найден: ' + '<' + ComponentTagName + '>');
    inc(BlockStart, length(ComponentTagName) + 2);

    { ищем закрывающий тег }
    BlockEnd := StrPos2(BlockStart, PChar('</' ? + ComponentTagName nil,
    'Закрывающий тег не найден: ' + '<' + ComponentTagName + '>');

    { проверка на вхождение закр. тега в родительский тег }
    check((ParentBlockEnd = nil)or(BlockEnd { XML парсер }
    while TagEnd do
    begin
      { быстрый поиск угловых скобок }
      asm
        mov CL, '<'
        mov EDX, Pointer(TagEnd)
        dec EDX
        @@1: inc EDX
        mov AL, byte[EDX]
        cmp AL, CL
        jne @@1
        mov TagStart, EDX

        mov CL, '>'
        @@2: inc EDX
        mov AL, byte[EDX]
        cmp AL, CL
        jne @@2
        mov TagEnd, EDX
      end;

      GetMem(TagName, TagEnd - TagStart + 1);
      try

        { TagName - имя тега }
        StrLCopy(TagName, TagStart + 1, TagEnd - TagStart - 1);

        { TagEnd - закрывающий тег }
        { поиск свойства, соответствующего тегу }
        TagEnd := StrPos2(TagEnd, PChar('</' ? + TagName
        PropIndex := FindProperty(TagName);

        check(PropIndex <> -1, 'TglXMLSerializer.DeSerializeInternal: Uncknown property: ' +
        TagName);

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

        inc(TagEnd, length('</' ? + TagNamefinally
        FreeMem(TagName);
      end;
    end;
  finally
    FreeMem(PropList, NumProps*sizeof(pointer));
  end;
end;

{
Процедура инициализации свойства объекта
Вызывается из:
DeSerializeInternal()
Вход:
Component - инициализируемый объект
PropInfo - информация о типе для устанавливаемого свойства
Value - значение свойства
ParentBlockEnd - указатель на конец XML описания родительского тега
Используется для рекурсии
}
procedure TglXMLSerializer.SetPropertyValue(Component: TObject;
PropInfo: PPropInfo; Value, ValueEnd: PChar; ParentBlockEnd: PChar);
var
  PropTypeInf: PTypeInfo;
  PropObject: TObject;
  CollectionItem: TCollectionItem;
  sValue: string;
  charTmp: char;
begin
  PropTypeInf := PropInfo.PropType^;

  case PropTypeInf^.Kind of
    tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet,
    tkWChar, tkLString, tkWString, tkVariant:
    begin
      { имитируем zero terminated string }
      charTmp := ValueEnd[0];
      ValueEnd[0] := #0;
      sValue := StrPas(Value);
      ValueEnd[0] := charTmp;

      { Замена спецсимволов. Актуально только для XML,
      сохраненного с помощью этого компонента }
      if FReplaceReservedSymbols then
      begin
        sValue := StringReplace(sValue, '%lt;', '<', [rfReplaceAll]);
        sValue := StringReplace(sValue, '%gt;', '>', [rfReplaceAll]);
        sValue := StringReplace(sValue, '%', '&', [rfReplaceAll]);
      end;

      { Для корректного преобразования парсером 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 { Текстовые списки }
        begin
          charTmp := ValueEnd[0];
          ValueEnd[0] := #0;
          sValue := StrPas(Value);
          ValueEnd[0] := charTmp;
          TStrings(PropObject).CommaText := sValue;
        end
        else
        if (PropObject is TCollection) then { Коллекции }
        begin
          while true do { Заранее не известно число элементов в коллекции }
          begin
            CollectionItem := (PropObject as TCollection).Add;
            try
              DeSerializeInternal(CollectionItem, CollectionItem.ClassName,
              ParentBlockEnd);
            except { Исключение, если очередной элемент не найден }
              CollectionItem.Free;
              break;
            end;
          end;
        end
        else { Для остальных классов - рекурсивная обработка }
          DeSerializeInternal(PropObject, PropInfo^.name, ParentBlockEnd);
      end;
    end;
  end;
end;

{
Процедура генерации DTD для заданного объекта в
соответствии с published интерфейсом его класса.
Вход:
Component - объект
Выход:
текст DTD в поток Stream
}
procedure TglXMLSerializer.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 TglXMLSerializer.GenerateDTDInternal(Component: TObject; DTDList:
TStrings; Stream: TStream; const ComponentTagName: string);
var
  PropInfo: PPropInfo;
  TypeInf, PropTypeInf: PTypeInfo;
  TypeData: PTypeData;
  i: integer;
  AName, PropName, 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 := '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;
        { код был бы полезен при использовании атрибутов
        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;

procedure TglXMLSerializer.check(Expr: boolean; const message: string);
begin
  if not Expr then
    raise XMLSerializerException.Create ('XMLSerializerException'#13#10#13#10 + message);
end;

end.

//(PShortString(@(GetTypeData(GetTypeData (PropTypeInf)^.BaseType^).NameList)))
//tickCount := GetTickCount();
//inc(tickCounter, GetTickCount() - tickCount);