XML сериализация объекта Delphi

Previous  Top  Next

    
 

 

XML сериализация объекта Delphi

Язык XML предоставляет нам чрезвычайно удобный и почти универсальный подход к хранению и передаче информации. Не хватает только средств, которые позволили бы удобно и просто организовать работу с XML. Предлагаемая разработка реализует очень эффективную возможность - XML сериализацию объектов любых классов Delphi и из загрузку из XML кода.
 
Рассматриваемый подход дает возможность наиболее удобно интегрировать обработку XML объектов в среду разработки Delphi и C++Builder. Возможность доступа к свойствам объектов определяется RTTI. Его возможности в Delphi очень велики, т.к. среда разработки сама хранит ресурсы объектов в текстовом формате.
 
Для начала определим ряд простых функций для формирования XML кода. Они позволят нам добавлять открывающие, закрывающие теги и значения в результирующий текст.
 

Code:

{ Добавляет открывающий тег с заданным именем }

procedure addOpenTag(const Value: string);

begin

   Result := Result + '<' + Value + '>';

   inc(Level);

end;

 

{ Добавляет закрывающий тег с заданным именем }

procedure addCloseTag(const Value: string; addBreak: boolean = false);

begin

   dec(Level);

   Result := Result + '</' + Value + '>';

end;

 

{ Добавляет значение в результирующую строку }

procedure addValue(const Value: string);

begin

   Result := Result + Value;

end;

 
 
Следующее, что предстоит реализовать - это перебор всех свойств объекта и формирование тегов. Сведения о свойствах получаются через интерфейс компонента. Это информация о типе. Для каждого свойства, за исключением классовых получается их имя и текстовое значение, после чего формируется XML-тег. Значение загружается через ф-ию TypInfo.GetPropValue();

 

Code:

{ 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];

 

     case PropTypeInf^.Kind of

       tkInteger, tkChar, tkEnumeration, tkFloat, tkString, tkSet,

       tkWChar, tkLString, tkWString, tkVariant:

       begin

         { Получение значения свойства }

        sPropValue := GetPropValue(Component, PropName, true);

 

         { Перевод в XML }

         addOpenTag(PropName);

         addValue(sPropValue); { Добавляем значение свойства в результат }

                 addCloseTag(PropName);

       end;

       ...

 
Для классовых типов придется использовать рекурсию для загрузки всех свойств соответствующего объекта.
Более того, для ряда классов необходимо использовать особый подход. Сюда относятся, к примеру, строковые списки и коллекции. Ими и ограничимся.
 
Для текстового списка TStrings будем сохранять в XML его свойство CommaText, а в случае коллекции после обработки всех ее свойств сохраним в XML каждый элемент TCollectionItem отдельно. При этом в качестве контейнерного тега будем использовать имя класса TCollection(PropObject).Items[j].ClassName.
 

Code:

       ...

       tkClass: { Для классовых типов рекурсивная обработка }

              begin

         addOpenTag(PropName);

 

         PropObject := GetObjectProp(Component, PropInfo);

         if Assigned(PropObject)then

         begin

           { Для дочерних свойств-классов - рекурсивный вызов }

                   if (PropObject is TPersistent) then

              Result := Result + SerializeInternal(PropObject, Level);

 

           { Индивидуальный подход к некоторым классам }

                   if (PropObject is TStrings) then { Текстовые списки }

                   begin

             Result := Result + TStrings(PropObject).CommaText;

           end else

           if (PropObject is TCollection) then { Коллекции }

                   begin

             Result := Result + SerializeInternal(PropObject, Level);

             for j := 0 to (PropObject as TCollection).Count-1 do

             begin

               addOpenTag(TCollection(PropObject).Items[j].ClassName);

               Result := Result +

                SerializeInternal(TCollection(PropObject).Items[j], Level);

               addCloseTag(TCollection(PropObject).Items[j].ClassName, true);

             end

           end;

           { Здесь можно добавить обработку остальных классов: TTreeNodes, TListItems }

         end;

         addCloseTag(PropName, true);

       end;

 
Описанные функции позволят нам получить XML код для объекта включая все его свойства. Остается только 'обернуть' полученный XML в тег верхнего уровня - имя класса объекта. Если мы поместим вышеприведенный код в функцию SerializeInternal(), то результирующая функция Serialize() будет выглядеть так:
 

Code:

procedure Serialize(Component: TObject;);

...

Result := Result + '<' + Component.ClassName + '>';

Result := Result + SerializeInternal(Component);  преобразовать свойства в XML

Result := Result + '</' + Component.ClassName + '>';

 
К вышеприведенному можно добавить еще ф-ии для форматирования генерируемого XML кода. Также можно добавить пропуск пустых значений и свойств со значениями по умолчанию.
 

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

После того, как мы рассмотрели возможность превода данных объекта в XML следует перейти к следующей задаче. Задача состоит в реализации обратного процесса, а именно - загрузки XML данных в объект.
 
Загрузка XML данных в объект, или десериализация, представляет собой более сложный процесс, т.к. в ходе его необходимо осуществить корректный разбор текстового XML документа на предмет инициализации содержащимися в нем данными заданного объекта.
 
Примем ряд упрощений, которые сократят число проверок корректности входящего XML документа к минимуму. Первое, что необходимо делать, тек это проверять соответствие тега верхнего уровня имени класса нашего объекта. Синтаксическая правильность документа будет проверяться в ходе загрузки данных. При необходимости более жесткой проверки загружаемых XML документов можно привлечь, к примеру, парсер MSXML. Последний поможет нам проверить документ на синтаксическую, а также семантическую корректность при наличии соответствующего DTD.
 
Первое, что следует реализовать, это процедура верхнего уровня, которая получает объект для инициализации, а также потоковый источник данных с текстом XML документа.
 

Code:

var

Buffer: PChar; { Буфер, в котором находится XML документ  }

   TokenPtr: PChar; { Указатель на текущее положение парсера XML документа }

 

{

Загружает в компонент данные из потока с 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 текта. Ищется первый открывающий тег, затем его закрывающая пара. Найденная пара содержит в себе данные для свойств объекта. Внутри найденной пары тегов последовательно выбираются теги (TagName) и текст их содержания (TagValue). Эти теги предположительно соответствуют свойствам объекта, что мы тут же и проверяем.
 
Среди свойств объекта отыскивается через FindProperty() оноименное свойство. При неудаче генерируется исключение об ошибочности XML тега. Если для тега найден соответвующее свойство, то передаем дальнейшую обработку процедуре SetPropertyValue(), которая заданное свойство с именем TagName проинициализирует найденным значением TagValue.
 
Не забываем также передвигать указатель чтения данных TokenPtr по мере выборки данных.
 

Code:

{

Рекурсивная процедура загрузки объекта их текстового буфера с 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('</' TagName + ?try

       { 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('</' TagName + ?finally

       FreeMem(TagValue);

     end;

   finally

     FreeMem(TagName);

   end;

end;

 

finally

   FreeMem(PropList, NumProps*sizeof(pointer));

end;

 

end;

 
Остается только код, который загрузит найденные данные в заданной свойство. Процедуре SetPropertyValue() передаются данные о соответствующем свойстве (PropInfo), которое на следует проинициализировать. Также процедура получает и текстовое значение, содержащееся в найденном теге.
 
В случае, если тип данные не является классовым типом, то, очевидно, текст Value следует просто загрузить в свойство. Это реализуется вызовом процедуры TypInfo.SetPropValue(). Последняя самостоятельно разберется, как корректно преобразовать тестовое значение в значение свойства в завистимости от его типа.
 
Если свойство имеет классовый тип, то его значение Value должно содержать XML код, описывающий свойства данного класса. В этом случае воспользуемся рекурсией и передадим обработку вышеприведенной процедуре DeSerializeInternal(). При этом передаем ей в качестве объекта ссылку на найденное свойство PropObject и его имя PropInfo^.Name.
 
Нам также необходимо озаботиться отдельной обработкой данных для таких классовых типов как списки TStrings и коллекции TCollection. Данные для списков мы загружаем из значения Value как CommaText. Тут все понятно. В сллучае же коллеций данные о элементах коллекции в XML документе содержаться в виде последовательных контейнерных тегов с именем типа элемента коллекци. Т.е., к примеру, <TMyCollection> ... </TMyCollection> <TMyCollection> ... </TMyCollection> <TMyCollection> ... </TMyCollection> и так далее. Внутри каждой пары тегов <TMyCollection> содержатся свойства объекта TMyCollection.

 

Code:

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;

 
К приведенному коду следует добавить еще ряд возможностей для более корректной реакции для обработки неверного XML кода. Также можно достаточно просто реализовать автоматическую генерацию DTD для любого класса Delphi. После этого можно собрать полноценный компонент, объединяющий в себе всю необходимую функциональность для XML сериализации.

 

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

За созданием кода для сериализации и десериализации объектов в Delphi логично перейти к рассмотрению вопроса о возможности генерации соответствующего DTD для сохраняемых в XML классов. DTD понадобится нам, если мы захотим провести проверку XML документа на корректность и допустимость с помощью одного из XML анализаторов. Работа с анализатором MSXML рассмотрена в статье Загрузка и анализ документа XML..
 
Автоматическое создание DTD очень простая задача. У нас все для этого есть. Необходимо рекурсивно пройтись по всем свойствам объекта и сгенерировать модели содержания для каждого тега. При сериализации в XML мы не использовали атрибутов, а значит мы не сможем в DTD установить контроль над содержанием конкретных элементов. Остается только определить модель содержания для XML, т.е. вложенность тегов в друг друга.
 
Создадим процедуру GenerateDTD(), которая обеспечит запись формируемого DTD для заданного объекта Component в заданный поток Stream. Она создает список DTDList, в котором будут накапливаться атрибуты DTD, после чего передает всю черновую работу процедуре GenerateDTDInternal().
 

Code:

{

Процедура генерации 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;

 
Следующий код просматривает свойства объекта, составляет их список, а затем формирует из этого модель содержания для элемента. Для свойств классовых типов используется рекурсия. Поскольку при сериализации объекта мы не использовали атрибутов, то определений для них создавать нет необходимости.
 
Для всех неклассовых типов модель содержания это - (#PCDATA). К примеру, свойство объекта Tag: integer превращается в .
 
Отдельно подходим к коллекциям. Для них необходимо указать на множественность дочернего тега элемента коллекции. Например, для свойства TMyCollection модель содержания может выглядеть так: .
 

Code:

{

Внутренняя рекурсивная процедура генерации 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 := '<!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 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;

 

 
 
Закоментированный код нам не нужен, но он не удален, т.к. он демонстрирует получение списка возможных значений для перечисления (Enumeration) и набора (Set). Это может понадобится, если появится необходимость генерировать свойства в виде атрибутов XML тегов и, соответственно, DTD для возможных значений этих атрибутов.

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

 
Объединяя сказанное о сериализации, десериализации объектов и создании 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 содержимое коллекций в объекте не очищается, что позволяет дозагружать данные из множества источников в один объект.

Code:

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

   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);

   { Private declarations }

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.ClassName + ?end;

 

{

Внутренняя процедура конвертации объекта в 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);

 

Андрей Чудин, ЦПР ТД Библио-Глобус.

 

Взято из http://delphi.chertenok.ru

©Drkb::03110