Delphi World - Компонент для XML сериализации
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Компонент для XML сериализации

Автор: Chudin A.V

Встpечаются два интернетчика:
- Жена меня нy совсем достала! Все вpемя шипит на меня!
- А может, она сконнектиться пытается?

Объединяя сказанное о сериализации, десериализации объектов и создании DTD соберем полноценный компонент для XML сериализации.

Компонент конвертирует компонент в XML и обратно в соответствии с published-интерфейсом класса компонента.

XML формируется в виде пар тегов с вложенными в них значениями. Атрибуты у тегов отсутствуют.

Тег верхнего уровня соответствует классу объекта. Вложенные теги соответствуют именам свойств. Для элементов коллекций контейнерный тег соответствует имени класса.

Вложенность тегов не ограничена и полностью повторяет published интерфейс класса заданного объекта.

Поддерживаются целые типы, типы с плавающей точкой, перечисления, наборы, строки, символы. вариантные типы, классовые типы, стоковые списки и коллекции.

Интерфейс:


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

  • Сериализация объекта в XML

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

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

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

Ограничения:

В объекте допустимо использовать только одну коллекцию каждого типа. Для преодоления этого ограничения требуется некоторая доработка.

Наследники класса TStrings не могут иметь published свойств.

Процедурные типы не обрабатываются.

Для генерации DTD у объекта все свойства классовых типов, одноименные со свойствами агрегированных объектов, должны быть одного класса.

Предусловия:

Объект для (де)сериализации должен быть создан до вызова процедуры.

Дополнительно:

При загрузке из 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);

Загрузить последнюю версию библиотеки GlobusLib с исходными текстами можно на странице Download

Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования