XML сериализация объекта Delphi
01.01.2007
XML сериализация объекта Delphi
Язык XML предоставляет нам чрезвычайно удобный и почти универсальный подход к хранению и передаче информации. Не хватает только средств, которые позволили бы удобно и просто организовать работу с XML. Предлагаемая разработка реализует очень эффективную возможность - XML сериализацию объектов любых классов Delphi и из загрузку из XML кода.Рассматриваемый подход дает возможность наиболее удобно интегрировать обработку XML объектов в среду разработки Delphi и C++Builder. Возможность доступа к свойствам объектов определяется RTTI. Его возможности в Delphi очень велики, т.к. среда разработки сама хранит ресурсы объектов в текстовом формате.
Для начала определим ряд простых функций для формирования XML кода. Они позволят нам добавлять открывающие, закрывающие теги и значения в результирующий текст.
{ Добавляет открывающий тег с заданным именем }
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();
{ 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.
...
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() будет выглядеть так:
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 документа.
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 по мере выборки данных.
{
Рекурсивная процедура загрузки объекта их текстового буфера с 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.
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().
{
Процедура генерации 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 модель содержания может выглядеть так: .
{
Внутренняя рекурсивная процедура генерации 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 содержимое коллекций в объекте не очищается, что позволяет дозагружать данные из множества источников в один объект.
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