unit glXMLSerializer; 
{ 
Globus Delphi VCL Extensions Library

glXMLSerializer Unit 08.2001	      
component TglXMLSerializer 1.2 
Chudin Andrey, avchudin@yandex.ru
=================================================================== 
 
} 
 
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; 
    FStrongConformity: 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 StrongConformity: boolean 
     read FStrongConformity write FStrongConformity default true; 
    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; 
  FStrongConformity := 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 + '') ); 
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(''); 
  end; 
 
  { Добавляет значение в результирующую строку } 
  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; 
 
{ 
  StrPosExt - ищет позицию одной строки в другой с заданной длиной. 
  На длинных строках превосходит StrPos. 
} 
function StrPosExt(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 := StrPosExt(TokenPtr, PChar('<' + ComponentTagName + '>'), BufferLength); 
 
  { Если тег не найден и его наличие необязательно, то не обрабатываем его } 
  if (BlockStart = nil)and not StrongConformity then exit; 
 
  { иначе проверяем его присутствие } 
  check(BlockStart <> nil, 'Открывающий тег не найден: ' + '<' + ComponentTagName + '>'); 
  inc(BlockStart, length(ComponentTagName) + 2); 
 
  { ищем закрывающий тег } 
  BlockEnd := StrPosExt(BlockStart, PChar(''), BufferLength); 
  check(BlockEnd <> nil, 'Закрывающий тег не найден: ' + '<' + ComponentTagName + '>'); 
 
  { проверка на вхождение закр. тега в родительский тег } 
  check((ParentBlockEnd = nil)or(BlockEnd < ParentBlockEnd), 'Закрывающий тег не найден: ' + '<' + ComponentTagName + '>'); 
 
  TagEnd := BlockStart; 
  SkipSpaces(TagEnd); 
 
  { XML парсер } 
  while TagEnd < BlockEnd 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 := StrPosExt(TagEnd, PChar(''), BufferLength); 
 
      TokenPtr := TagStart; 
      inc(TagStart, length('')-1); 
 
      TagValue := TagStart; 
      TagValueEnd := TagEnd; 
 
      { поиск свойства, соответствующего тегу } 
      PropIndex := FindProperty(TagName); 
 
      check(PropIndex <> -1, 'TglXMLSerializer.DeSerializeInternal: Uncknown property: ' + TagName); 
 
      SetPropertyValue(Component, PropList^[PropIndex], TagValue, TagValueEnd, BlockEnd); 
 
      inc(TagEnd, length('')); 
      SkipSpaces(TagEnd); 
 
    finally 
      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 := '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; 
 
procedure TglXMLSerializer.check(Expr: boolean; const Message: string); 
begin 
  if not Expr then raise XMLSerializerException.Create('XMLSerializerException'#13#10#13#10 + Message); 
end; 
 
end.