apophysis7x/System/NativeXmlObjectStorage.pas

{ unit NativeXmlObjectStorage

  This unit provides functionality to store any TObject descendant to an XML file
  or stream. Internally it makes full use of RTTI (runtime type information) in
  order to store all published properties and events.

  It can even be used to copy forms, but form inheritance is not exploited, so
  child forms descending from parent forms store everything that the parent already
  stored.

  All published properties and events of objects are stored. This includes
  the "DefineProperties". These are stored in binary form in the XML, encoded
  as BASE64.

  Known limitations:
  - The method and event lookup will not work correctly across forms.

  Please see the "ObjectToXML" demo for example usage of this unit.

  Original Author: Nils Haeck M.Sc.
  Copyright (c) 2003-2009 Simdesign B.V.

  It is NOT allowed under ANY circumstances to publish or copy this code
  without accepting the license conditions in accompanying LICENSE.txt
  first!

  This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF
  ANY KIND, either express or implied.

  Please visit http://www.simdesign.nl/xml.html for more information.
}
unit NativeXmlObjectStorage;

{$i NativeXml.inc}

interface

uses
  Classes, Forms, SysUtils, Controls, NativeXml, TypInfo, Variants;

type

  // Use TsdXmlObjectWriter to write any TPersistent descendant's published properties
  // to an XML node.
  TsdXmlObjectWriter = class(TPersistent)
  protected
    procedure WriteProperty(ANode: TXmlNode; AObject: TObject; AParent: TComponent; PropInfo: PPropInfo);
  public
    // Call WriteObject to write the published properties of AObject to the TXmlNode
    // ANode. Specify AParent in order to store references to parent methods and
    // events correctly.
    procedure WriteObject(ANode: TXmlNode; AObject: TObject; AParent: TComponent = nil);
    // Call WriteComponent to write the published properties of AComponent to the TXmlNode
    // ANode. Specify AParent in order to store references to parent methods and
    // events correctly.
    procedure WriteComponent(ANode: TXmlNode; AComponent: TComponent; AParent: TComponent = nil);
  end;

  // Use TsdXmlObjectReader to read any TPersistent descendant's published properties
  // from an XML node.
  TsdXmlObjectReader = class(TPersistent)
  protected
    procedure ReadProperty(ANode: TXmlNode; AObject: TObject; AParent: TComponent; PropInfo: PPropInfo);
  public
    // Call CreateComponent to first create AComponent and then read its published
    // properties from the TXmlNode ANode. Specify AParent in order to resolve
    // references to parent methods and events correctly. In order to successfully
    // create the component from scratch, the component's class must be registered
    // beforehand with a call to RegisterClass. Specify Owner to add the component
    // as a child to Owner's component list. This is usually a form. Specify Name
    // as the new component name for the created component.
    function CreateComponent(ANode: TXmlNode; AOwner, AParent: TComponent; AName: string = ''): TComponent;
    // Call ReadObject to read the published properties of AObject from the TXmlNode
    // ANode. Specify AParent in order to resolve references to parent methods and
    // events correctly.
    procedure ReadObject(ANode: TXmlNode; AObject: TObject; AParent: TComponent = nil);
    // Call ReadComponent to read the published properties of AComponent from the TXmlNode
    // ANode. Specify AParent in order to resolve references to parent methods and
    // events correctly.
    procedure ReadComponent(ANode: TXmlNode; AComponent: TComponent; AParent: TComponent);
  end;

// High-level create methods

// Create and read a component from the XML file with FileName. In order to successfully
// create the component from scratch, the component's class must be registered
// beforehand with a call to RegisterClass. Specify Owner to add the component
// as a child to Owner's component list. This is usually a form. Specify Name
// as the new component name for the created component.
function ComponentCreateFromXmlFile(const FileName: string; Owner: TComponent;
  const Name: string): TComponent;

// Create and read a component from the TXmlNode ANode. In order to successfully
// create the component from scratch, the component's class must be registered
// beforehand with a call to RegisterClass. Specify Owner to add the component
// as a child to Owner's component list. This is usually a form. Specify Name
// as the new component name for the created component.
function ComponentCreateFromXmlNode(ANode: TXmlNode; Owner: TComponent;
  const Name: string): TComponent;

// Create and read a component from the XML stream S. In order to successfully
// create the component from scratch, the component's class must be registered
// beforehand with a call to RegisterClass. Specify Owner to add the component
// as a child to Owner's component list. This is usually a form. Specify Name
// as the new component name for the created component.
function ComponentCreateFromXmlStream(S: TStream; Owner: TComponent;
  const Name: string): TComponent;

// Create and read a component from the XML in string in Value. In order to successfully
// create the component from scratch, the component's class must be registered
// beforehand with a call to RegisterClass. Specify Owner to add the component
// as a child to Owner's component list. This is usually a form. Specify Name
// as the new component name for the created component.
function ComponentCreateFromXmlString(const Value: string; Owner: TComponent;
  const Name: string): TComponent;

// Create and read a form from the XML file with FileName. In order to successfully
// create the form from scratch, the form's class must be registered
// beforehand with a call to RegisterClass. Specify Owner to add the form
// as a child to Owner's component list. For forms this is usually Application.
// Specify Name as the new form name for the created form.
function FormCreateFromXmlFile(const FileName: string; Owner: TComponent;
  const Name: string): TForm;

// Create and read a form from the XML stream in S. In order to successfully
// create the form from scratch, the form's class must be registered
// beforehand with a call to RegisterClass. Specify Owner to add the form
// as a child to Owner's component list. For forms this is usually Application.
// Specify Name as the new form name for the created form.
function FormCreateFromXmlStream(S: TStream; Owner: TComponent;
  const Name: string): TForm;

// Create and read a form from the XML string in Value. In order to successfully
// create the form from scratch, the form's class must be registered
// beforehand with a call to RegisterClass. Specify Owner to add the form
// as a child to Owner's component list. For forms this is usually Application.
// Specify Name as the new form name for the created form.
function FormCreateFromXmlString(const Value: string; Owner: TComponent;
  const Name: string): TForm;

// High-level load methods

// Load all the published properties of AObject from the XML file in Filename.
// Specify AParent in order to resolve references to parent methods and
// events correctly.
procedure ObjectLoadFromXmlFile(AObject: TObject; const FileName: string;
  AParent: TComponent = nil);

// Load all the published properties of AObject from the TXmlNode ANode.
// Specify AParent in order to resolve references to parent methods and
// events correctly.
procedure ObjectLoadFromXmlNode(AObject: TObject; ANode: TXmlNode; AParent: TComponent = nil);

// Load all the published properties of AObject from the XML stream in S.
// Specify AParent in order to resolve references to parent methods and
// events correctly.
procedure ObjectLoadFromXmlStream(AObject: TObject; S: TStream; AParent: TComponent = nil);

// Load all the published properties of AObject from the XML string in Value.
// Specify AParent in order to resolve references to parent methods and
// events correctly.
procedure ObjectLoadFromXmlString(AObject: TObject; const Value: string; AParent: TComponent = nil);

// High-level save methods

// Save all the published properties of AObject as XML to the file in Filename.
// Specify AParent in order to store references to parent methods and
// events correctly.
procedure ObjectSaveToXmlFile(AObject: TObject; const FileName: string;
  AParent: TComponent = nil);

// Save all the published properties of AObject to the TXmlNode ANode.
// Specify AParent in order to store references to parent methods and
// events correctly.
procedure ObjectSaveToXmlNode(AObject: TObject; ANode: TXmlNode; AParent: TComponent = nil);

// Save all the published properties of AObject as XML in stream S.
// Specify AParent in order to store references to parent methods and
// events correctly.
procedure ObjectSaveToXmlStream(AObject: TObject; S: TStream; AParent: TComponent = nil);

// Save all the published properties of AObject as XML in string Value.
// Specify AParent in order to store references to parent methods and
// events correctly.
function ObjectSaveToXmlString(AObject: TObject; AParent: TComponent = nil): string;

// Save all the published properties of AComponent as XML in the file in Filename.
// Specify AParent in order to store references to parent methods and
// events correctly.
procedure ComponentSaveToXmlFile(AComponent: TComponent; const FileName: string;
  AParent: TComponent = nil);

// Save all the published properties of AComponent to the TXmlNode ANode.
// Specify AParent in order to store references to parent methods and
// events correctly.
procedure ComponentSaveToXmlNode(AComponent: TComponent; ANode: TXmlNode;
  AParent: TComponent = nil);

// Save all the published properties of AComponent as XML in the stream in S.
// Specify AParent in order to store references to parent methods and
// events correctly.
procedure ComponentSaveToXmlStream(AComponent: TComponent; S: TStream;
  AParent: TComponent = nil);

// Save all the published properties of AComponent as XML in the string Value.
// Specify AParent in order to store references to parent methods and
// events correctly.
function ComponentSaveToXmlString(AComponent: TComponent; AParent: TComponent = nil): string;

// Save the form AForm as XML to the file in Filename. This method also stores
// properties of all child components on the form, and can therefore be used
// as a form-storage method.
procedure FormSaveToXmlFile(AForm: TForm; const FileName: string);

// Save the form AForm as XML to the stream in S. This method also stores
// properties of all child components on the form, and can therefore be used
// as a form-storage method.
procedure FormSaveToXmlStream(AForm: TForm; S: TStream);

// Save the form AForm as XML to a string. This method also stores
// properties of all child components on the form, and can therefore be used
// as a form-storage method.
function FormSaveToXmlString(AForm: TForm): string;

resourcestring

  sxwIllegalVarType        = 'Illegal variant type';
  sxrUnregisteredClassType = 'Unregistered classtype encountered in ';
  sxrInvalidPropertyValue  = 'Invalid property value';
  sxwInvalidMethodName     = 'Invalid method name';

implementation

type

  TPersistentAccess = class(TPersistent);
  TComponentAccess = class(TComponent)
  public
    procedure SetComponentState(const AState: TComponentState);
  published
    property ComponentState;
  end;

  TReaderAccess = class(TReader);

function ComponentCreateFromXmlFile(const FileName: string; Owner: TComponent;
  const Name: string): TComponent;
var
  S: TStream;
begin
  S := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
  try
    Result := ComponentCreateFromXmlStream(S, Owner, Name);
  finally
    S.Free;
  end;
end;

function ComponentCreateFromXmlNode(ANode: TXmlNode; Owner: TComponent;
  const Name: string): TComponent;
var
  AReader: TsdXmlObjectReader;
begin
  Result := nil;
  if not assigned(ANode) then
    exit;
  // Create reader
  AReader := TsdXmlObjectReader.Create;
  try
    // Read the component from the node
    Result := AReader.CreateComponent(ANode, Owner, nil, Name);
  finally
    AReader.Free;
  end;
end;

function ComponentCreateFromXmlStream(S: TStream; Owner: TComponent;
  const Name: string): TComponent;
var
  ADoc: TNativeXml;
begin
  Result := nil;
  if not assigned(S) then
    exit;
  // Create XML document
  ADoc := TNativeXml.Create;
  try
    // Load XML
    ADoc.LoadFromStream(S);
    // Load from XML node
    Result := ComponentCreateFromXmlNode(ADoc.Root, Owner, Name);
  finally
    ADoc.Free;
  end;
end;

function ComponentCreateFromXmlString(const Value: string; Owner: TComponent;
  const Name: string): TComponent;
var
  S: TStream;
begin
  S := TStringStream.Create(Value);
  try
    Result := ComponentCreateFromXmlStream(S, Owner, Name);
  finally
    S.Free;
  end;
end;

function FormCreateFromXmlFile(const FileName: string; Owner: TComponent;
  const Name: string): TForm;
var
  S: TStream;
begin
  S := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
  try
    Result := FormCreateFromXmlStream(S, Owner, Name);
  finally
    S.Free;
  end;
end;

function FormCreateFromXmlStream(S: TStream; Owner: TComponent;
  const Name: string): TForm;
var
  ADoc: TNativeXml;
begin
  Result := nil;
  if not assigned(S) then exit;
  // Create XML document
  ADoc := TNativeXml.Create;
  try
    // Load XML
    ADoc.LoadFromStream(S);

    // Load from XML node
    Result := TForm(ComponentCreateFromXmlNode(ADoc.Root, Owner, Name));
  finally
    ADoc.Free;
  end;
end;

function FormCreateFromXmlString(const Value: string; Owner: TComponent;
  const Name: string): TForm;
var
  S: TStream;
begin
  S := TStringStream.Create(Value);
  try
    Result := FormCreateFromXmlStream(S, Owner, Name);
  finally
    S.Free;
  end;
end;

procedure ObjectLoadFromXmlFile(AObject: TObject; const FileName: string;
  AParent: TComponent = nil);
var
  S: TStream;
begin
  S := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone);
  try
    ObjectLoadFromXmlStream(AObject, S, AParent);
  finally
    S.Free;
  end;
end;

procedure ObjectLoadFromXmlNode(AObject: TObject; ANode: TXmlNode; AParent: TComponent = nil);
var
  AReader: TsdXmlObjectReader;
begin
  if not assigned(AObject) or not assigned(ANode) then
    exit;
  // Create writer
  AReader := TsdXmlObjectReader.Create;
  try
    // Write the object to the document
    if AObject is TComponent then
      AReader.ReadComponent(ANode, TComponent(AObject), AParent)
    else
      AReader.ReadObject(ANode, AObject, AParent);
  finally
    AReader.Free;
  end;
end;

procedure ObjectLoadFromXmlStream(AObject: TObject; S: TStream; AParent: TComponent = nil);
var
  ADoc: TNativeXml;
begin
  if not assigned(S) then
    exit;
  // Create XML document
  ADoc := TNativeXml.Create;
  try
    // Load XML
    ADoc.LoadFromStream(S);
    // Load from XML node
    ObjectLoadFromXmlNode(AObject, ADoc.Root, AParent);
  finally
    ADoc.Free;
  end;
end;

procedure ObjectLoadFromXmlString(AObject: TObject; const Value: string; AParent: TComponent = nil);
var
  S: TStringStream;
begin
  S := TStringStream.Create(Value);
  try
    ObjectLoadFromXmlStream(AObject, S, AParent);
  finally
    S.Free;
  end;
end;

procedure ObjectSaveToXmlFile(AObject: TObject; const FileName: string;
  AParent: TComponent = nil);
var
  S: TStream;
begin
  S := TFileStream.Create(FileName, fmCreate);
  try
    ObjectSaveToXmlStream(AObject, S, AParent);
  finally
    S.Free;
  end;
end;

procedure ObjectSaveToXmlNode(AObject: TObject; ANode: TXmlNode; AParent: TComponent = nil);
var
  AWriter: TsdXmlObjectWriter;
begin
  if not assigned(AObject) or not assigned(ANode) then
    exit;
  // Create writer
  AWriter := TsdXmlObjectWriter.Create;
  try
    // Write the object to the document
    if AObject is TComponent then
      AWriter.WriteComponent(ANode, TComponent(AObject), AParent)
    else begin
      ANode.Name := UTF8String(AObject.ClassName);
      AWriter.WriteObject(ANode, AObject, AParent);
    end;
  finally
    AWriter.Free;
  end;
end;

procedure ObjectSaveToXmlStream(AObject: TObject; S: TStream; AParent: TComponent = nil);
var
  ADoc: TNativeXml;
begin
  if not assigned(S) then
    exit;
  // Create XML document
  ADoc := TNativeXml.Create;
  try
    ADoc.XmlFormat := xfReadable;
    // Save to XML node
    ObjectSaveToXmlNode(AObject, ADoc.Root, AParent);
    // Save to stream
    ADoc.SaveToStream(S);
  finally
    ADoc.Free;
  end;
end;

function ObjectSaveToXmlString(AObject: TObject; AParent: TComponent = nil): string;
var
  S: TStringStream;
begin
  S := TStringStream.Create('');
  try
    ObjectSaveToXmlStream(AObject, S, AParent);
    Result := S.DataString;
  finally
    S.Free;
  end;
end;

procedure ComponentSaveToXmlFile(AComponent: TComponent; const FileName: string;
  AParent: TComponent = nil);
begin
  ObjectSaveToXmlFile(AComponent, FileName, AParent);
end;

procedure ComponentSaveToXmlNode(AComponent: TComponent; ANode: TXmlNode;
  AParent: TComponent = nil);
begin
  ObjectSaveToXmlNode(AComponent, ANode, AParent);
end;

procedure ComponentSaveToXmlStream(AComponent: TComponent; S: TStream;
  AParent: TComponent = nil);
begin
  ObjectSaveToXmlStream(AComponent, S, AParent);
end;

function ComponentSaveToXmlString(AComponent: TComponent; AParent: TComponent = nil): string;
begin
  Result := ObjectSaveToXmlString(AComponent, AParent);
end;

procedure FormSaveToXmlFile(AForm: TForm; const FileName: string);
begin
  ComponentSaveToXmlFile(AForm, FileName, AForm);
end;

procedure FormSaveToXmlStream(AForm: TForm; S: TStream);
begin
  ComponentSaveToXmlStream(AForm, S, AForm);
end;

function FormSaveToXmlString(AForm: TForm): string;
begin
  Result := ComponentSaveToXmlString(AForm, AForm);
end;

{ TsdXmlObjectWriter }

procedure TsdXmlObjectWriter.WriteComponent(ANode: TXmlNode; AComponent,
  AParent: TComponent);
begin
  if not assigned(ANode) or not assigned(AComponent) then
    exit;
  ANode.Name := UTF8String(AComponent.ClassName);
  if length(AComponent.Name) > 0 then
    ANode.AttributeAdd('Name', UTF8String(AComponent.Name));
  WriteObject(ANode, AComponent, AParent);
end;

procedure TsdXmlObjectWriter.WriteObject(ANode: TXmlNode; AObject: TObject;
  AParent: TComponent);
var
  i, Count: Integer;
  PropInfo: PPropInfo;
  PropList: PPropList;
  S: TStringStream;
  AWriter: TWriter;
  AChildNode: TXmlNode;
  AComponentNode: TXmlNode;
begin
  if not assigned(ANode) or not assigned(AObject) then
    exit;

  // If this is a component, store child components
  if AObject is TComponent then with TComponent(AObject) do
  begin
    if ComponentCount > 0 then
    begin
      AChildNode := ANode.NodeNew('Components');
      for i := 0 to ComponentCount - 1 do
      begin
        AComponentNode := AChildNode.NodeNew(UTF8String(Components[i].ClassName));
        if length(Components[i].Name) > 0 then
          AComponentNode.AttributeAdd('Name', UTF8String(Components[i].Name));
        WriteObject(AComponentNode, Components[i], TComponent(AObject));
      end;
    end;
  end;

  // Save all regular properties that need storing
  Count := GetTypeData(AObject.ClassInfo)^.PropCount;
  if Count > 0 then
  begin
    GetMem(PropList, Count * SizeOf(Pointer));
    try
      GetPropInfos(AObject.ClassInfo, PropList);
      for i := 0 to Count - 1 do
      begin
        PropInfo := PropList^[i];
        if PropInfo = nil then
          continue;
        if IsStoredProp(AObject, PropInfo) then
          WriteProperty(ANode, AObject, AParent, PropInfo);
      end;
    finally
      FreeMem(PropList, Count * SizeOf(Pointer));
    end;
  end;

  // Save defined properties
  if AObject is TPersistent then
  begin
    S := TStringStream.Create('');
    try
      AWriter := TWriter.Create(S, 4096);
      try
        TPersistentAccess(AObject).DefineProperties(AWriter);
      finally
        AWriter.Free;
      end;
      // Do we have data from DefineProperties?
      if S.Size > 0 then
      begin
        // Yes, add a node with binary data
        ANode.NodeNew('DefinedProperties').BinaryString := RawByteString(S.DataString);
      end;
    finally
      S.Free;
    end;
  end;
end;

procedure TsdXmlObjectWriter.WriteProperty(ANode: TXmlNode; AObject: TObject;
  AParent: TComponent; PropInfo: PPropInfo);
var
  PropType: PTypeInfo;
  AChildNode: TXmlNode;
  ACollectionNode: TXmlNode;
  //local
  procedure WritePropName;
  begin
    AChildNode := ANode.NodeNew(PPropInfo(PropInfo)^.Name);
  end;
  //local
  procedure WriteInteger(Value: Int64);
  begin
    AChildNode.ValueAsString := UTF8String(IntToStr(Value));
  end;
  //local
  procedure WriteString(Value: string);
  begin
    AChildNode.ValueAsUnicodeString := Value;
  end;
  //local
  procedure WriteSet(Value: Longint);
  var
    I: Integer;
    BaseType: PTypeInfo;
    S, Enum: string;
  begin
    BaseType := GetTypeData(PropType)^.CompType^;
    for i := 0 to SizeOf(TIntegerSet) * 8 - 1 do
    begin
      if i in TIntegerSet(Value) then
      begin
        Enum := GetEnumName(BaseType, i);
        if i > 0 then
          S := S + ',' + Enum
        else
          S := Enum;
      end;
    end;
    AChildNode.ValueAsString := UTF8String(Format('[%s]', [S]));
  end;
  //local
  procedure WriteIntProp(IntType: PTypeInfo; Value: Longint);
  var
    Ident: string;
    IntToIdent: TIntToIdent;
  begin
    IntToIdent := FindIntToIdent(IntType);
    if Assigned(IntToIdent) and IntToIdent(Value, Ident) then
      WriteString(Ident)
    else
      WriteInteger(Value);
  end;
  //local
  procedure WriteCollectionProp(Collection: TCollection);
  var
    i: integer;
  begin
    if assigned(Collection) then
    begin
      for i := 0 to Collection.Count - 1 do
      begin
        ACollectionNode := AChildNode.NodeNew(UTF8String(Collection.Items[i].ClassName));
        WriteObject(ACollectionNode, Collection.Items[I], AParent);
      end;
    end;
  end;
  //local
  procedure WriteOrdProp;
  var
    Value: Longint;
  begin
    Value := GetOrdProp(AObject, PropInfo);
    if not (Value = PPropInfo(PropInfo)^.Default) then
    begin
      WritePropName;
      case PropType^.Kind of
      tkInteger:     WriteIntProp(PPropInfo(PropInfo)^.PropType^, Value);
      tkChar:        WriteString(Chr(Value));
      tkSet:         WriteSet(Value);
      tkEnumeration: WriteString(GetEnumName(PropType, Value));
      end;
    end;
  end;
  //local
  procedure WriteFloatProp;
  var
    Value: Extended;
  begin
    Value := GetFloatProp(AObject, PropInfo);
    if not (Value = 0) then
      ANode.WriteFloat(PPropInfo(PropInfo)^.Name, Value);
  end;
  //local
  procedure WriteInt64Prop;
  var
    Value: Int64;
  begin
    Value := GetInt64Prop(AObject, PropInfo);
    if not (Value = 0) then
      ANode.WriteInt64(PPropInfo(PropInfo)^.Name, Value);
  end;
  //local
  procedure WriteStrProp;
  var
    Value: string;
  begin
    Value := GetStrProp(AObject, PropInfo);
    if not (length(Value) = 0) then
      ANode.WriteUnicodeString(PPropInfo(PropInfo)^.Name, Value);
  end;
  //local
  procedure WriteWideStrProp;
  var
    Value: WideString;
  begin
    Value := GetWideStrProp(AObject, PropInfo);
    if not (length(Value) = 0) then
      ANode.WriteUnicodeString(PPropInfo(PropInfo)^.Name, Value);
  end;
  {$IFDEF D12UP}
  //local
  procedure WriteUnicodeStrProp;
  var
    Value: UnicodeString;
  begin
    Value := GetUnicodeStrProp(AObject, PropInfo);
    if not (length(Value) = 0) then
      ANode.WriteUnicodeString(PPropInfo(PropInfo)^.Name, Value);
  end;
  {$ENDIF}
  //local
  procedure WriteObjectProp;
  var
    Value: TObject;
    ComponentName: string;
    function GetComponentName(Component: TComponent): string;
    begin
      if Component.Owner = AParent then
        Result := Component.Name
      else if Component = AParent then
        Result := 'Owner'
      else if assigned(Component.Owner) and (length(Component.Owner.Name) > 0)
        and (length(Component.Name) > 0) then
        Result := Component.Owner.Name + '.' + Component.Name
      else if length(Component.Name) > 0 then
        Result := Component.Name + '.Owner'
      else Result := '';
    end;
  begin
    Value := TObject(GetOrdProp(AObject, PropInfo));
    if not assigned(Value) then
      exit;
    WritePropName;
    if Value is TComponent then
    begin
      ComponentName := GetComponentName(TComponent(Value));
      if length(ComponentName) > 0 then
        WriteString(ComponentName);
    end else
    begin
      WriteString(Format('(%s)', [Value.ClassName]));
      if Value is TCollection then
        WriteCollectionProp(TCollection(Value))
      else
      begin
        if AObject is TComponent then
          WriteObject(AChildNode, Value, TComponent(AObject))
        else
          WriteObject(AChildNode, Value, AParent)
      end;
      // No need to store an empty child.. so check and remove
      if AChildNode.NodeCount = 0 then
        ANode.NodeRemove(AChildNode);
    end;
  end;
  //local
  procedure WriteMethodProp;
  var
    Value: TMethod;
    function IsDefaultValue: Boolean;
    begin
      Result := (Value.Code = nil) or
        ((Value.Code <> nil) and assigned(AParent) and (AParent.MethodName(Value.Code) = ''));
    end;
  begin
    Value := GetMethodProp(AObject, PropInfo);
    if not IsDefaultValue then
    begin
      if assigned(Value.Code) then
      begin
        WritePropName;
        if assigned(AParent) then
          WriteString(AParent.MethodName(Value.Code))
        else
          AChildNode.ValueAsString := '???';
      end;
    end;
  end;
  //local
  procedure WriteVariantProp;
  var
    AValue: Variant;
    ACurrency: Currency;
  var
    VType: Integer;
  begin
    AValue := GetVariantProp(AObject, PropInfo);
    if not VarIsEmpty(AValue) or VarIsNull(AValue) then
    begin
      if VarIsArray(AValue) then
        raise Exception.Create(sxwIllegalVarType);
      WritePropName;
      VType := VarType(AValue);
      AChildNode.AttributeAdd('VarType', UTF8String(IntToHex(VType, 4)));
      case VType and varTypeMask of
      varNull:    AChildNode.ValueAsUnicodeString := '';
      varOleStr:  AChildNode.ValueAsUnicodeString := AValue;
      varString:  AChildNode.ValueAsUnicodeString := AValue;
      varByte,
      varSmallInt,
      varInteger: AChildNode.ValueAsInteger := AValue;
      varSingle,
      varDouble:  AChildNode.ValueAsFloat := AValue;
      varCurrency:
        begin
          ACurrency := AValue;
          AChildNode.BufferWrite(ACurrency, SizeOf(ACurrency));
        end;
      varDate:    AChildNode.ValueAsDateTime := AValue;
      varBoolean: AChildNode.ValueAsBool := AValue;
      else
        try
          ANode.ValueAsUnicodeString := AValue;
        except
          raise Exception.Create(sxwIllegalVarType);
        end;
      end;//case
    end;
  end;
//main
begin
  if (PPropInfo(PropInfo)^.SetProc <> nil) and
    (PPropInfo(PropInfo)^.GetProc <> nil) then
  begin
    PropType := PPropInfo(PropInfo)^.PropType^;
    case PropType^.Kind of
    tkInteger, tkChar, tkEnumeration, tkSet: WriteOrdProp;
    tkFloat:                                 WriteFloatProp;
    tkString, tkLString:                     WriteStrProp;
    {$IFDEF D6UP}
    tkWString:                               WriteWideStrProp;
    {$ENDIF}
    {$IFDEF D12UP}
    tkUString:                               WriteUnicodeStrProp;
    {$ENDIF}
    tkClass:                                 WriteObjectProp;
    tkMethod:                                WriteMethodProp;
    tkVariant:                               WriteVariantProp;
    tkInt64:                                 WriteInt64Prop;
    end;
  end;
end;

{ TsdXmlObjectReader }

function TsdXmlObjectReader.CreateComponent(ANode: TXmlNode;
  AOwner, AParent: TComponent; AName: string): TComponent;
var
  AClass: TComponentClass;
begin
  AClass := TComponentClass(GetClass(string(ANode.Name)));
  if not assigned(AClass) then
    raise Exception.CreateFmt(sxrUnregisteredClassType, [ANode.Name]);
  Result := AClass.Create(AOwner);
  if length(AName) = 0 then
    Result.Name := string(ANode.AttributeByName['Name'])
  else
    Result.Name := AName;
  if not assigned(AParent) then
    AParent := Result;
  ReadComponent(ANode, Result, AParent);
end;

procedure TsdXmlObjectReader.ReadComponent(ANode: TXmlNode; AComponent,
  AParent: TComponent);
begin
  ReadObject(ANode, AComponent, AParent);
end;

procedure TsdXmlObjectReader.ReadObject(ANode: TXmlNode; AObject: TObject; AParent: TComponent);
var
  i, Count: Integer;
  Item: TCollectionItem;
  PropInfo: PPropInfo;
  PropList: PPropList;
  S: TStringStream;
  AReader: TReader;
  AChildNode: TXmlNode;
  AComponentNode: TXmlNode;
  AClass: TComponentClass;
  AComponent: TComponent;
begin
  if not assigned(ANode) or not assigned(AObject) then
    exit;

  // Start loading
  if AObject is TComponent then
    with TComponentAccess(AObject) do
    begin
      TComponentAccess(AObject).Updating;
      SetComponentState(ComponentState + [csLoading, csReading]);
    end;
  try

    // If this is a component, load child components
    if AObject is TComponent then with TComponent(AObject) do
    begin
      AChildNode := ANode.NodeByName('Components');
      if assigned(AChildNode) then
      begin
        for i := 0 to AChildNode.NodeCount - 1 do
        begin
          AComponentNode := AChildNode.Nodes[i];
          AComponent := FindComponent(string(AComponentNode.AttributeByName['Name']));
          if not assigned(AComponent) then
          begin
            AClass := TComponentClass(GetClass(string(AComponentNode.Name)));
            if not assigned(AClass) then
              raise Exception.Create(sxrUnregisteredClassType);
            AComponent := AClass.Create(TComponent(AObject));
            AComponent.Name := AComponentNode.AttributeByName['Name'];
            // In case of new (visual) controls we set the parent
            if (AComponent is TControl) and (AObject is TWinControl) then
              TControl(AComponent).Parent := TWinControl(AObject);
          end;
          ReadComponent(AComponentNode, AComponent, TComponent(AObject));
        end;
      end;
    end;

    // If this is a collection, load collections items
    if AObject is TCollection then
      with TCollection(AObject) do
      begin
        BeginUpdate;
        try
          Clear;
          for i := 0 to ANode.NodeCount - 1 do
          begin
            item := Add;
            ReadObject(ANode.Nodes[i], item, AParent);
          end;
        finally
          EndUpdate;
        end;
      end;

    // Load all loadable regular properties
    Count := GetTypeData(AObject.ClassInfo)^.PropCount;
    if Count > 0 then
    begin
      GetMem(PropList, Count * SizeOf(Pointer));
      try
        GetPropInfos(AObject.ClassInfo, PropList);
        for i := 0 to Count - 1 do
        begin
          PropInfo := PropList^[i];
          if PropInfo = nil then
            continue;
          if IsStoredProp(AObject, PropInfo) then
            ReadProperty(ANode, AObject, AParent, PropInfo);
        end;
      finally
        FreeMem(PropList, Count * SizeOf(Pointer));
      end;
    end;

    // Load defined properties
    if AObject is TPersistent then
    begin
      AChildNode := ANode.NodeByName('DefinedProperties');
      if assigned(AChildNode) then
      begin
        S := TStringStream.Create(AChildNode.BinaryString);
        try
          AReader := TReader.Create(S, 4096);
          try
            with TReaderAccess(AReader) do
              while Position < S.Size do
                ReadProperty(TPersistent(AObject));
          finally
            AReader.Free;
          end;
        finally
          S.Free;
        end;
      end;
    end;

  finally
    // End loading
    if AObject is TComponent then with TComponentAccess(AObject) do
    begin
      SetComponentState(ComponentState - [csReading]);
      TComponentAccess(AObject).Loaded;
      TComponentAccess(AObject).Updated;
    end;
  end;
end;

procedure TsdXmlObjectReader.ReadProperty(ANode: TXmlNode;
  AObject: TObject; AParent: TComponent; PropInfo: PPropInfo);
var
  PropType: PTypeInfo;
  AChildNode: TXmlNode;
  Method: TMethod;
  PropObject: TObject;
  //local
  procedure SetSetProp(const AValue: string);
  var
    S: string;
    P: integer;
    ASet: integer;
    EnumType: PTypeInfo;
    procedure AddToEnum(const EnumName: string);
    var
      V: integer;
    begin
      if length(EnumName) = 0 then
        exit;
      V := GetEnumValue(EnumType, EnumName);
      if V = -1 then
        raise Exception.Create(sxrInvalidPropertyValue);
      Include(TIntegerSet(ASet), V);
    end;
  begin
    ASet := 0;
    EnumType := GetTypeData(PropType)^.CompType^;
    S := copy(AValue, 2, length(AValue) - 2);
    repeat
      P := Pos(',', S);
      if P > 0 then begin
        AddToEnum(copy(S, 1, P - 1));
        S := copy(S, P + 1, length(S));
      end else begin
        AddToEnum(S);
        break;
      end;
    until False;
    SetOrdProp(AObject, PropInfo, ASet);
  end;

  procedure SetIntProp(const AValue: string);
  var
    V: Longint;
    IdentToInt: TIdentToInt;
  begin
    IdentToInt := FindIdentToInt(PropType);
    if Assigned(IdentToInt) and IdentToInt(AValue, V) then
      SetOrdProp(AObject, PropInfo, V)
    else
      SetOrdProp(AObject, PropInfo, StrToInt(AValue));
  end;

  procedure SetCharProp(const AValue: string);
  begin
    if length(AValue) <> 1 then
      raise Exception.Create(sxrInvalidPropertyValue);
    SetOrdProp(AObject, PropInfo, Ord(AValue[1]));
  end;

  procedure SetEnumProp(const AValue: string);
  var
    V: integer;
  begin
    V := GetEnumValue(PropType, AValue);
    if V = -1 then
      raise Exception.Create(sxrInvalidPropertyValue);
    SetOrdProp(AObject, PropInfo, V)
  end;

  procedure ReadCollectionProp(ACollection: TCollection);
  var
    i: integer;
    Item: TPersistent;
  begin
    ACollection.BeginUpdate;
    try
      ACollection.Clear;
      for i := 0 to AChildNode.NodeCount - 1 do
      begin
        Item := ACollection.Add;
        ReadObject(AChildNode.Nodes[i], Item, AParent);
      end;
    finally
      ACollection.EndUpdate;
    end;
  end;

  procedure SetObjectProp(const AValue: string);
  var
    AClassName: string;
    PropObject: TObject;
    Reference: TComponent;
  begin
    if length(AValue) = 0 then
      exit;
    if AValue[1] = '(' then
    begin
      // Persistent class
      AClassName := Copy(AValue, 2, length(AValue) - 2);
      PropObject := TObject(GetOrdProp(AObject, PropInfo));
      if assigned(PropObject) and (PropObject.ClassName = AClassName) then
      begin
        if PropObject is TCollection then
          ReadCollectionProp(TCollection(PropObject))
        else
        begin
          if AObject is TComponent then
            ReadObject(AChildNode, PropObject, TComponent(AObject))
          else
            ReadObject(AChildNode, PropObject, AParent);
        end;
      end else
        raise Exception.Create(sxrUnregisteredClassType);
    end else
    begin
      // Component reference
      if assigned(AParent) then
      begin
        Reference := FindNestedComponent(AParent, AValue);
        SetOrdProp(AObject, PropInfo, Longint(Reference));
      end;
    end;
  end;

  procedure SetMethodProp(const AValue: string);
  var
    Method: TMethod;
  begin
    // to do: add OnFindMethod
    if not assigned(AParent) then
      exit;
    Method.Code := AParent.MethodAddress(AValue);
    if not assigned(Method.Code) then
      raise Exception.Create(sxwInvalidMethodName);
    Method.Data := AParent;
    TypInfo.SetMethodProp(AObject, PropInfo, Method);
  end;

  procedure SetVariantProp(const AValue: string);
  var
    VType: integer;
    Value: Variant;
    ACurrency: Currency;
  begin
    VType := StrToInt('$' + AChildNode.AttributeByName['VarType']);

    case VType and varTypeMask of
    varNull:    Value := Null;
    varOleStr:  Value := AChildNode.ValueAsUnicodeString;
    varString:  Value := AChildNode.ValueAsString;
    varByte,
    varSmallInt,
    varInteger: Value := AChildNode.ValueAsInteger;
    varSingle,
    varDouble:  Value := AChildNode.ValueAsFloat;
    varCurrency:
      begin
        AChildNode.BufferRead(ACurrency, SizeOf(ACurrency));
        Value := ACurrency;
      end;
    varDate:    Value := AChildNode.ValueAsDateTime;
    varBoolean: Value := AChildNode.ValueAsBool;
    else
      try
        Value := ANode.ValueAsString;
      except
        raise Exception.Create(sxwIllegalVarType);
      end;
    end;//case

    TVarData(Value).VType := VType;
    TypInfo.SetVariantProp(AObject, PropInfo, Value);
  end;

begin
  if (PPropInfo(PropInfo)^.SetProc <> nil) and
    (PPropInfo(PropInfo)^.GetProc <> nil) then
  begin
    PropType := PPropInfo(PropInfo)^.PropType^;
    AChildNode := ANode.NodeByName(PPropInfo(PropInfo)^.Name);
    if assigned(AChildNode) then
    begin
      // Non-default values from XML
      case PropType^.Kind of
      tkInteger:     SetIntProp(AChildNode.ValueAsString);
      tkChar:        SetCharProp(AChildNode.ValueAsString);
      tkSet:         SetSetProp(AChildNode.ValueAsString);
      tkEnumeration: SetEnumProp(AChildNode.ValueAsString);
      tkFloat:       SetFloatProp(AObject, PropInfo, AChildNode.ValueAsFloat);
      tkString,
      tkLString:     SetStrProp(AObject, PropInfo, AChildNode.ValueAsString);
      tkWString:     SetWideStrProp(AObject, PropInfo, UTF8Decode(AChildNode.ValueAsUnicodeString));
      {$IFDEF D12UP}
      tkUString:     SetUnicodeStrProp(AObject, PropInfo, AChildNode.ValueAsUnicodeString);
      {$ENDIF}
      tkClass:       SetObjectProp(AChildNode.ValueAsString);
      tkMethod:      SetMethodProp(AChildNode.ValueAsString);
      tkVariant:     SetVariantProp(AChildNode.ValueAsString);
      tkInt64:       SetInt64Prop(AObject, PropInfo, AChildNode.ValueAsInt64);
      end;//case
    end else
    begin
      // Set Default value
      case PropType^.Kind of
      tkInteger:     SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default);
      tkChar:        SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default);
      tkSet:         SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default);
      tkEnumeration: SetOrdProp(AObject, PropInfo, PPropInfo(PropInfo)^.Default);
      tkFloat:       SetFloatProp(AObject, PropInfo, 0);
      tkString,
      tkLString,
      tkWString:     SetStrProp(AObject, PropInfo, '');
      {$IFDEF D12UP}
      tkUString:     SetStrProp(AObject, PropInfo, '');
      {$ENDIF}
      tkClass:
        begin
          PropObject := TObject(GetOrdProp(AObject, PropInfo));
          if PropObject is TComponent then
            SetOrdProp(AObject, PropInfo, 0);
        end;
      tkMethod:
        begin
          Method := TypInfo.GetMethodProp(AObject, PropInfo);
          Method.Code := nil;
          TypInfo.SetMethodProp(AObject, PropInfo, Method);
        end;
      tkInt64:       SetInt64Prop(AObject, PropInfo, 0);
      end;//case
    end;
  end;
end;

{ TComponentAccess }

procedure TComponentAccess.SetComponentState(const AState: TComponentState);
type
  PInteger = ^integer;
var
  PSet: PInteger;
  AInfo: PPropInfo;
begin
  // This is a "severe" hack in order to set a non-writable property value,
  // also using RTTI
  PSet := PInteger(@AState);
  AInfo := GetPropInfo(TComponentAccess, 'ComponentState');
  if assigned(AInfo.GetProc) then
    PInteger(Integer(Self) + Integer(AInfo.GetProc) and $00FFFFFF)^ := PSet^;
end;

end.