Chip 2002 September/Chip_2002-09_cd1.bin/zkuste/delphi/kolekce/d56/XMLCOMP.ZIP/DnXml.pas

Pascal/Delphi Source File | 2002-06-16 | 40KB | 1,103 lines

unit DnXml;

interface

{$INCLUDE DnXml.inc}

uses
  Classes, SysUtils, Forms, TypInfo,
  {$IFDEF DN_D6_UP} Variants, {$ENDIF}
  MSXML2_TLB,
  DnXmlPropMapper, DnXmlListMapper;

type
  TGetIdEvent = function(aObject: TObject): string of object;
  TGetObjectEvent = function(aID: string): TObject of object;
  TGetClassEvent = function(aClassName: string): TClass of object;
  TMarkEvent = procedure(aObject: TObject; aId: string) of object;

  IXmlNodeType = IXmlDomNode;

  {:Use the TDnXmlDictionary class to connect component trees which are loaded and saved by
    (different) xml- readers and writers. Simply drop it on your form and connect the reader(s) and
    writer(s) to it. You can also create it runtime, using the Create method.}
  TDnXmlDictionary = class(TComponent)
  private
    FMax: Integer;
    FObjects: TStringList;
    function GetCount: Integer;
    function GetObjects(aIndex: Integer): TObject;
    function GetIds(aIndex: Integer): string;
  public
    {:Constructor, in order to create the object at runtime (aOwner maybe nil).}
    constructor Create(aOwner: TComponent); override;
    {:Plain old destructor.}
    destructor Destroy; override;
    {:Plain old notification. Do not call this externally.}
    procedure Notification(aComponent: TComponent; aOperation: TOperation); override;
    {:Returns the internal id of the object aObject.}
    function IdOfObject(aObject: TObject): string;
    {:Returns the object that belongs to the id aId.}
    function ObjectOfId(aId: string): TObject;
    {:Adds an object to the dictionary. Usually only used by the reader and writer. If the ID already
      exists, its associated component is replace by the new aObject value.}
    procedure Add(aObject: TComponent; aId: string);
    {:Clears the whole dictionary.}
    procedure Clear;
    {:The dictionary is able to generate new id, based on the contents of the dictionary. The new id
      is the next integer value of the highest known integer id (non-integer id's are ignored).}
    function GetNewId: string;
    {:Number of objects in the dictionary.}
    property Count: Integer read GetCount;
    {:Retrieve an object by it's index. 0 >= aIndex < Count. }
    property Objects[aIndex: Integer]: TObject read GetObjects;
    {:Retrieve an id by it's index. 0 >= aIndex < Count. }
    property Ids[aIndex: Integer]: string read GetIds;
  end;

  {:The TDnXmlWriter class is able to convert an object tree to an xml representation. Only TComponent
    objects are written to xml, except for list objects which don't have to be TComponent's (like TList
    and such). }
  TDnXmlWriter = class(TComponent)
  private
    FInternalDictionary: TDnXmlDictionary;
    FTodoNodes: TInterfaceList;
    FTodoObjs: TList;
    FOnExternalRef: TGetIdEvent;
    FStoreReadOnlyProps: Boolean;
    FOnGetId: TGetIdEvent;
    FDictionary: TDnXmlDictionary;
    FTopNodeName: string;
    FPropKinds: TTypeKinds;
    FStoreTagProperty: Boolean;
    FStoreNameProperty: Boolean;
    procedure AddTodo(aNode: IXmlNodeType; aObject: TObject);
    procedure SetRef(aNode: IXmlNodeType; aObject: TObject);
    procedure FixTodos;
    procedure ComponentToXmlImp(aObject: TComponent; aNode: IXmlNodeType; aOwner: TComponent);
    procedure MarkWritten(aObject: TComponent; aId: string);
    function ActiveDictionary: TDnXmlDictionary;
    function GetId(aObject: TObject): string;
    procedure SetDictionary(const Value: TDnXmlDictionary);
    procedure ListItemsToXml(aObject: TObject; aNode: IXmlNodeType;
      aOwner: TComponent);
  public
    {:Plain old constructor.}
    constructor Create(aOwner: TComponent); override;
    {:Plain old destructor.}
    destructor Destroy; override;
    {:Plain old TComponent.Notification.}
    procedure Notification(aComponent: TComponent; aOperation: TOperation); override;
    {:Converts the object aObject into an xml string.}
    function ToXml(aObject: TComponent): string;
    {:Converts the objectt aObject into xml and saves that to aXmlFile.}
    procedure ToXmlFile(aXmlFile: string; aObject: TComponent);
  published
    {:Identifier to use for the top element of the resulting xml. Defaults to 'topobj'.}
    property TopNodeName: string read FTopNodeName write FTopNodeName;
    {:Whether to store read-only properties too. Remember read-only properties can be written but not read
      by TDnXmlReader.}
    property StoreReadOnlyProps: Boolean read FStoreReadOnlyProps write FStoreReadOnlyProps default False;
    {:Whether to store the TComponent.Tag property.}
    property StoreTagProperty: Boolean read FStoreTagProperty write FStoreTagProperty default True;
    {:Whether to store the TComponent.Name property.}
    property StoreNameProperty: Boolean read FStoreNameProperty write FStoreNameProperty default True;
    {:Use this property to setup which kind of properties are written and which aren't. Property types
      which are not in the list aren't written to xml.}
    property PropKinds: TTypeKinds read FPropKinds write FPropKinds default tkProperties;
    {:This event gets called for each object that is outside of the root object tree that is being
      written.}
    property OnExternalRef: TGetIdEvent read FOnExternalRef write FOnExternalRef;
    {:This event is called whenever a object is written of which the id is not yet defined. If not
      supplied, the id generation is handled by the dictionary, see <see method="TDnXmlDictionary.GetNewId"
      text="TDnXmlDictionary.GetNewId"/> for details.}
    property OnGetNewId: TGetIdEvent read FOnGetId write FOnGetId;
    {:Use this property to specify which dictionary to use for attaching id to objects written. This
      is usefull if you want to preserve the id's of objects between saving and loading. }
    property Dictionary: TDnXmlDictionary read FDictionary write SetDictionary;
  end;

  TClearListMode = (clmClear, clmFreeChildrenAndClear, clmFreeAllAndClear, clmFreeChildren, clmFreeAll);

  TSetObjPropMode = (sopmSet, sopmFreeAndSet, sopmTryAssignElseSet, sopmTryAssignElseFreeAndSet);

  {:As <see class="TDnXmlWriter" text="TDnXmlWriter"/> but converts xml to components. See
    <see class="TDnXmlWriter" text="TDnXmlWriter"/> for important usage information.

    <p><b>Warning:</b> The reader clears the lists before reading it from xml. Be sure the contained
    objects are freed if the list is the only one referencing to them (list is called the owner in
    that case). You achieve this by using a TObjectList instead of a TList object for instance. The
    <see property=TDnXmlReader.ClearListMode text="ClearListMode"/> property can be used
    (with caution) to make the reader free the list objects as well. Note that in that case the
    objects are only freed if they are children of the list/listowner or all objects regardless of
    their owner. This means that you mix references to sibling objects in the same class. To have
    this kind of flexability, create your own list class, which implements a Clear method with more
    intelligence.

    <p>Same goes for object properties. The reader sets objects properties for objects readed from xml.
    Be sure that the reader cannot write to properties which contain the only reference to an object
    else that object would be "dangling" causing memory leaks. This can be achieved by providing a
    setter method which frees the referenced object, or simply by making owned object properties
    readonly by ommiting a write specifier from the property definition. Alternatively, the <see
    property=TDnXmlReader.SetObjPropMode text="SetObjPropMode"/> to control how the child-object-
    properties are set.}
  TDnXmlReader = class(TComponent)
  private
    FInternalDictionary: TDnXmlDictionary;
    FDictionary: TDnXmlDictionary;
    FOnGetClass: TGetClassEvent;
    FTodoObjs: TStringList; { of RefId, Object }
    FTodoProp: TStringList; { of IntToStr(PropIndex), MapperClass }
    FTodoList: TStringList; { of RefId, Object }
    FTodoListXtra: TStringList; { of IntToStr(Index), MapperClass }
    FExceptOnMissingProps: Boolean;
    FOnExternalRef: TGetObjectEvent;
    FClearListMode: TClearListMode;
    FSetObjPropMode: TSetObjPropMode;
    FReadNameProperty: Boolean;
    FReadTagProperty: Boolean;
    procedure FromXmlAssignImp(aObject: TComponent; aNode: IXmlNodeType; aOwner: TComponent = nil);
    function FromXmlCreateImp(aOwner: TComponent; aNode: IXmlNodeType): TComponent;
    procedure AddTodo(aRefId: string; aObject: TObject; aMapperClass: TDnXmlPropMapperClass; aPropIndex: Integer);
    procedure AddListTodo(aRefId: string; aObject: TObject; aMapperClass: TDnXmlListMapperClass; aIndex: Integer);
    procedure FixTodos;
    procedure MarkRead(aObject: TComponent; aId: string);
    function ActiveDictionary: TDnXmlDictionary;
    procedure SetDictionary(const Value: TDnXmlDictionary);
    procedure XmlToListItems(aObject: TObject; aNode: IXmlNodeType; aOwner: TComponent);
  protected
    function DoGetClass(const aClass: string): TClass; virtual;
  public
    {:Constructor, in order to create the object at runtime (aOwner maybe nil).}
    constructor Create(aOwner: TComponent); override;
    {:Plain old destructor.}
    destructor Destroy; override;
    {:Plain old TComponent.Notification.}
    procedure Notification(aComponent: TComponent; aOperation: TOperation); override;
    {:Assign the xml in aXml to aObject.}
    procedure FromXmlAssign(aXml: string; aObject: TComponent);
    {:Converts an xml string into a new object.}
    function FromXmlCreate(aOwner: TComponent; aXml: string): TComponent;
    {:Assigns the xml in aXmlFile to aObject.}
    procedure FromXmlFileAssign(aXmlFile: string; aObject: TComponent);
    {:Converts an xml file into a new object.}
    function FromXmlFileCreate(aOwner: TComponent; aXmlFile: string): TComponent;
    {:Returns the id of a loaded object. Returns empty string if the object was not loaded by the reader.
      If a Dictionary is connected using the Dictionary property, you can use the IdOfObject of the
      dictionary (<see method="TDnXmlDictionary.IdOfObject" text="TDnXmlDictionary.IdOfObject"/>) to
      retrieve the id.}
    function IdOfObject(aObject: TComponent): string;
  published
    {:If you're not using the delphi-vcl method of registering classes (RegisterClass and RegisterClasses
      routines), then provide your own class resolving mechanism here. If you do not supply this code
      unregistered objects cause the readed to raise an exception.}
    property OnGetClass: TGetClassEvent read FOnGetClass write FOnGetClass;
    {:Use the OnExternalRef event to resolve objects that are defined outside of the xml. If this
      object was read through another xml reader, you can also use an external dictionary (see
      Dictionary property).}
    property OnExternalRef: TGetObjectEvent read FOnExternalRef write FOnExternalRef;
    {:Use this property to specify which dictionary to use for storing id's of objects that were read.
      This is useful if you want to preserve the id's when writing to xml later (to do that assign
      the same dictionary to TDnXmlWriter.Dictionary before writing with it). The dictionary is also
      used to retrieve external objects that need be resolved during the load of the object tree.}
    property Dictionary: TDnXmlDictionary read FDictionary write SetDictionary;
    {:Set this property to false if you want the reader to accept missing properties in the xml.}
    property ExceptOnMissingProps: Boolean read FExceptOnMissingProps write FExceptOnMissingProps default True;
    {:Use this property to setup the way lists are cleared while reading them from xml.}
    property ClearListMode: TClearListMode read FClearListMode write FClearListMode default clmClear;
    {:Use this property to setup the way object properties are set while reading them from xml.}
    property SetObjPropMode: TSetObjPropMode read FSetObjPropMode write FSetObjPropMode default sopmSet;
    {:Whether to load the TComponent.Name property. Counterpart of <see property="TDnXmlWriter.StoreNameProperty" text="TDnXmlWriter.StoreNameProperty"/>.}
    property ReadNameProperty: Boolean read FReadNameProperty write FReadNameProperty default True;
    {:Whether to load the TComponent.Tag property. Counterpart of <see property="TDnXmlWriter.StoreTagProperty" text="TDnXmlWriter.StoreTagProperty"/>.}
    property ReadTagProperty: Boolean read FReadTagProperty write FReadTagProperty default True;
  end;

  {:Provides a baseclass for classes that are able to resolve classes for the xml reader. If not used
    the classes registered using RegisterClass and RegisterClasses routines are used, and/of the
    TDnXmlReader.OnGetclass event. The order in which these class retrieval mechanisms are invoked is:
    <ol>
    <li>Registered TDnXmlClassResolver subclass
    <li>OnGetClass event if provided
    <li>Delphi's GetClass, classes which were registered using the RegisterClass(es) routines.
    </ol> }
  TDnXmlClassResolver = class(TObject)
  protected
    {:Override this method and provide your class resolving mechanism. If you cannot succeed, return nil.}
    class function GetClass(aClassName: string): TClass; virtual; abstract;
  end;

  TDnXmlClassResolverClass= class of TDnXmlClassResolver;

{:Use this routine to register your custom class which is able to resolve classtypes by their name as
  found in the ClassName tags in the xml file.}
procedure RegisterClassResolver(aResolver: TDnXmlClassResolverClass);

{:Use this routine to unregister the class registered using the <see routine=RegisterClassResolver
  text="RegisterClassResolver"/> routine.}
procedure UnregisterClassResolver(aResolver: TDnXmlClassResolverClass);

implementation

var
  gClassResolvers: TList = nil;

procedure RegisterClassResolver(aResolver: TDnXmlClassResolverClass);
begin
  if gClassResolvers.IndexOf(aResolver) <> -1 then
    raise Exception.CreateFmt('Classresolver %s was already registered', [aResolver.ClassName]);
  gClassResolvers.Add(aResolver);
end;

procedure UnregisterClassResolver(aResolver: TDnXmlClassResolverClass);
begin
  if gClassResolvers.IndexOf(aResolver) = -1 then
    raise Exception.CreateFmt('Classresolver %s was not registered', [aResolver.ClassName]);
  gClassResolvers.Remove(aResolver);
end;

{ helper funcs }

procedure SetAttribute(aNode: IXmlNodeType; const aName, aValue: string);
var attr: IXMLDOMAttribute;
begin
  attr := aNode.ownerDocument.createAttribute(aName);
  attr.value := aValue;
  aNode.attributes.setNamedItem(attr);
end;

function GetAttribute(aNode: IXmlNodeType; const aName: string): string;
var attr: IXmlNodeType;
begin
  attr := aNode.attributes.getNamedItem(aName);
  if attr = nil then
    raise Exception.CreateFmt('Cannot find attribute %s', [aName]);
  result := attr.text;
end;

function HasAttribute(aNode: IXmlNodeType; const aName: string): Boolean;
begin
  result := aNode.attributes.getNamedItem(aName) <> nil;
end;

function SetElement(aNode: IXmlNodeType; const aName: string; const aValue: string = ''): IXmlNodeType;
var elem: IXMLDOMElement;
begin
  elem := aNode.ownerDocument.createElement(aName);
  elem.text := aValue;
  aNode.appendChild(elem);
  result := elem;
end;

function FindNode(aNode: IXmlNodeType; const aName: string): IXmlNodeType;
var i: Integer;
begin
  result := nil;
  for i := 0 to aNode.childNodes.length - 1 do
  begin
    if aNode.childNodes[i].nodeName = aName then
    begin
      result := aNode.childNodes[i];
      break;
    end;
  end;
end;

{ TDnXmlWriter }

procedure TDnXmlWriter.SetRef(aNode: IXmlNodeType; aObject: TObject);
var refid: string;
begin
  refid := ActiveDictionary.IdOfObject(aObject);
  if refid <> '' then
    SetAttribute(aNode, 'RefID', refid)
  else
    AddTodo(aNode, aObject);
end;

procedure TDnXmlWriter.ListItemsToXml(aObject: TObject; aNode: IXmlNodeType; aOwner: TComponent);
var
  listmapper: TDnXmlListMapper;
  listmapperclass: TDnXmlListMapperClass;
  listowner: TComponent;
  i: Integer;
  node: IXmlNodeType;
begin
  listmapperclass := GetListMapper(aObject.ClassType);
  if listmapperclass <> nil then
  begin
    if aObject is TComponent then
      listowner := TComponent(aObject)
    else
      listowner := aOwner;
    listmapper := listmapperclass.CreateWithObject(aObject, aOwner);
    try
      for i := 0 to listmapper.Count - 1 do
      begin
        node := SetElement(aNode, 'list-item');
        if listmapper.StoresObjects then
        begin
          // if not yet in internal dictionary, it's not a ref...
          if not listmapper.IsRef[i] and (FInternalDictionary.IdOfObject(listmapper.ObjectItem[i]) = '') then
            ComponentToXmlImp(listmapper.ObjectItem[i] as TComponent, node, listowner)
          else
            SetRef(node, listmapper.ObjectItem[i]);
        end
        else
        begin
          node.Text := listmapper.StringItem[i];
        end;
      end;
    finally
      listmapper.Free;
    end;
  end;
end;

procedure TDnXmlWriter.ComponentToXmlImp(aObject: TComponent; aNode: IXmlNodeType; aOwner: TComponent);
var
  i, iMapper: Integer;
  node: IXmlNodeType;
  mapperclass: TDnXmlPropMapperClass;
  mapper: TDnXmlPropMapper;
  id: string;
begin
  id := GetId(aObject);
  Assert(id <> '', 'GetId failed');

  MarkWritten(aObject, id);

  SetAttribute(aNode, 'ID', id);
  SetElement(aNode, 'ClassName', aObject.ClassName);

  for iMapper := 0 to GetXmlPropMapperCount(aObject.ClassType) - 1 do
  begin
    mapperclass := GetXmlPropMapper(aObject.ClassType, iMapper);
    if mapperclass = nil then
      raise Exception.CreateFmt('Cannot write xml for class %s (no property mapper(s) registered for it)', [aObject.ClassName]);

    mapper := mapperclass.CreateWithObject(aObject);
    try
      if mapper is TDnXmlRttiPropMapper then
        TDnXmlRttiPropMapper(mapper).PropKinds := PropKinds;

      mapper.StoreReadOnlyProps := StoreReadOnlyProps;
      for i := 0 to mapper.Count - 1 do
      begin
        if not StoreTagProperty and (mapper.PropName[i] = 'Tag') then
          Continue;
        if not StoreNameProperty and (mapper.PropName[i] = 'Name') then
          Continue;

        if mapper.IsStored[i] then
        begin
          node := SetElement(aNode, mapper.PropName[i]);
          if mapper.IsObject[i] then
          begin
            if mapper.ObjectProp[i] = nil then
              node.Text := 'nil'
            else
            begin
              if mapper.ObjectProp[i] is TComponent then
              begin
                // no reference according to mapper and not yet loaded according to internal dictionary?
                if not mapper.IsRef[i] and (FInternalDictionary.IdOfObject(mapper.ObjectProp[i]) = '') then
                  // it's a child, load it recursively
                  ComponentToXmlImp(mapper.ObjectProp[i] as TComponent, node, aObject as TComponent)
                else
                  // it's a reference, just set the refid attribute of the node
                  SetRef(node, mapper.ObjectProp[i]);
              end
              else
              begin
                // non TComponent objects are only supported for list item holders (e.g. TList)
                ListItemsToXml(mapper.ObjectProp[i], node, aOwner);
              end;
            end;
          end
          else
            node.Text := mapper.Value[i];
        end;
      end;
    finally
      mapper.Free;
    end;
  end;

  ListItemsToXml(aObject, aNode, aOwner);
end;

function TDnXmlWriter.ToXml(aObject: TComponent): String;
var doc: IXMLDOMDocument2;
begin
  doc := CoDOMDocument.Create;
  doc.documentElement := doc.createElement(TopNodeName);

  FInternalDictionary.Clear;
  FTodoNodes.Clear;
  FTodoObjs.Clear;
  ComponentToXmlImp(aObject, doc.documentElement, nil);
  FixTodos;

  result := doc.XML;
end;

procedure TDnXmlWriter.AddTodo(aNode: IXmlNodeType; aObject: TObject);
begin
  FTodoNodes.Add(aNode);
  FTodoObjs.Add(aObject);
end;

function TDnXmlWriter.GetId(aObject: TObject): string;
begin
  result := ActiveDictionary.IdOfObject(aObject);
  if result = '' then
  begin
    if Assigned(OnGetNewId) then
    begin
      result := OnGetNewId(aObject);
      if result = '' then
        raise Exception.CreateFmt('OnGetNewId event did not return a valid id for object of type %s', [aObject.ClassName]);
      // check if the id is not already in use
      if ActiveDictionary.ObjectOfId(result) <> nil then
        raise Exception.CreateFmt('The id returned by the OnGetNewId event (id=%s) is already in use. OnGetNewId must return unique id''s', [result]);
    end
    else
      // if event not connected, fall back to our own id generating mechanism
      result := ActiveDictionary.GetNewId;
  end;
end;

constructor TDnXmlWriter.Create;
begin
  inherited;
  FTopNodeName := 'topobj';
  FTodoNodes := TInterfaceList.Create;
  FTodoObjs := TList.Create;
  FInternalDictionary := TDnXmlDictionary.Create(nil);
  FPropKinds := tkProperties;
  FStoreTagProperty := True;
  FStoreNameProperty := True;
end;

destructor TDnXmlWriter.Destroy;
begin
  FTodoNodes.Free;
  FTodoObjs.Free;
  FInternalDictionary.Free;

  inherited;
end;

procedure TDnXmlWriter.FixTodos;
var i: Integer;
    refid: string;
begin
  try
    i := 0;
    while i < FTodoNodes.Count do
    begin
      refid := ActiveDictionary.IdOfObject(FTodoObjs[i]);
      if (refid = '') and (Assigned(OnExternalRef)) then
        refid := OnExternalRef(FTodoObjs[i]);
      if refid <> '' then
      begin
        SetAttribute((FTodoNodes[i] as IXmlNodeType), 'RefID', refid);
        FTodoNodes.Delete(i);
        FTodoObjs.Delete(i);
      end
      else
        inc(i);
    end;

    if FTodoNodes.Count > 0 then
      raise Exception.Create('One or more referenced objects could not be resolved');
  finally
    FTodoNodes.Clear;
    FTodoObjs.Clear;
  end;
end;

procedure TDnXmlWriter.MarkWritten(aObject: TComponent; aId: string);
begin
  FInternalDictionary.Add(aObject, aId);
  if FDictionary <> nil then
    FDictionary.Add(aObject, aId);
end;

function TDnXmlWriter.ActiveDictionary: TDnXmlDictionary;
begin
  if Assigned(FDictionary) then
    result := FDictionary
  else
    result := FInternalDictionary;
end;

procedure TDnXmlWriter.ToXmlFile(aXmlFile: string; aObject: TComponent);
var list: TStringList;
begin
  list := TStringList.Create;
  try
    list.Text := ToXml(aObject);
    list.SaveToFile(aXmlFile);
  finally
    list.Free;
  end;
end;

procedure TDnXmlWriter.SetDictionary(const Value: TDnXmlDictionary);
begin
  FDictionary := Value;
  if FDictionary <> nil then
    FDictionary.FreeNotification(Self);
end;

procedure TDnXmlWriter.Notification(aComponent: TComponent;
  aOperation: TOperation);
begin
  inherited;
  if aOperation = opRemove then
  begin
    if aComponent = FDictionary then
      FDictionary := nil;
  end;
end;

{ TDnXmlReader }

procedure TDnXmlReader.AddListTodo(aRefId: string; aObject: TObject;
  aMapperClass: TDnXmlListMapperClass; aIndex: Integer);
begin
  FTodoList.AddObject(aRefId, aObject);
  FTodoListXtra.AddObject(IntToStr(aIndex), Pointer(aMapperClass));
end;

procedure TDnXmlReader.AddTodo(aRefId: string; aObject: TObject;
  aMapperClass: TDnXmlPropMapperClass; aPropIndex: Integer);
begin
  FTodoObjs.AddObject(aRefId, aObject);
  FTodoProp.AddObject(IntToStr(aPropIndex), Pointer(aMapperClass));
end;

constructor TDnXmlReader.Create;
begin
  inherited;

  FTodoObjs := TStringList.Create;
  FTodoProp := TStringList.Create;
  FTodoList := TStringList.Create;
  FTodoListXtra := TStringList.Create;
  FInternalDictionary := TDnXmlDictionary.Create(nil);
  FExceptOnMissingProps := True;
  FReadNameProperty := True;
  FReadTagProperty := True;
end;

destructor TDnXmlReader.Destroy;
begin
  FTodoObjs.Free;
  FTodoProp.Free;
  FTodoList.Free;
  FTodoListXtra.Free;
  FInternalDictionary.Free;

  inherited;
end;

function TDnXmlReader.DoGetClass(const aClass: string): TClass;
var i: Integer;
begin
  result := nil;
  for i := 0 to gClassResolvers.Count - 1 do
  begin
    result := TDnXmlClassResolverClass(gClassResolvers[i]).GetClass(aClass);
    if result <> nil then Break;
  end;
  if result = nil then
  begin
    if not Assigned(OnGetClass) then
      result := GetClass(aClass)
    else
      result := OnGetClass(aClass);
  end;
end;

procedure TDnXmlReader.FixTodos;
var i: Integer;
    obj: TObject;
    index: Integer;
    mapper: TDnXmlPropMapper;
    mapperclass: TDnXmlPropMapperClass;
    listmapperclass: TDnXmlListMapperClass;
    listmapper: TDnXmlListMapper;

  procedure _SetProp(aObject: TObject);
  var
    parent: TObject;
  begin
    parent := FTodoObjs.Objects[i];
    index := StrToInt(FTodoProp[i]);
    mapperclass := TDnXmlPropMapperClass(FTodoProp.Objects[i]);
    mapper := mapperclass.CreateWithObject(parent);
    try
      mapper.ObjectProp[index] := aObject;
    finally
      mapper.Free;
    end;
    FTodoObjs.Delete(i);
    FTodoProp.Delete(i);
  end;

  procedure _SetList(aObject: TObject);
  var
    parent: TObject;
  begin
    parent := FTodoList.Objects[i];
    index := StrToInt(FTodoListXtra[i]);
    listmapperclass := TDnXmlListMapperClass(FTodoListXtra.Objects[i]);
    listmapper := listmapperclass.CreateWithObject(parent);
    try
      listmapper.ObjectItem[index] := aObject;
    finally
      listmapper.Free;
    end;
    FTodoList.Delete(i);
    FTodoListXtra.Delete(i);
  end;

begin
  // solve object property refs
  i := 0;
  while i < FTodoObjs.Count do
  begin
    obj := ActiveDictionary.ObjectOfId(FTodoObjs[i]);
    if obj = nil then
    begin
      if Assigned(OnExternalRef) then
        obj := OnExternalRef(FTodoObjs[i]);
    end;
    if obj <> nil then
      _SetProp(obj)
    else
      inc(i);
  end;

  // solve list refs
  i := 0;
  while i < FTodoList.Count do
  begin
    obj := ActiveDictionary.ObjectOfId(FTodoList[i]);
    if obj = nil then
    begin
      if Assigned(OnExternalRef) then
        obj := OnExternalRef(FTodoList[i]);
    end;
    if obj <> nil then
      _SetList(obj)
    else
      inc(i);
  end;

  if (FTodoObjs.Count > 0) or (FTodoList.Count > 0) then
    raise Exception.Create('One or more referenced objects could not be resolved');
end;

procedure TDnXmlReader.FromXmlAssign(aXml: string; aObject: TComponent);
var doc: IXMLDOMDocument2;
begin
  FInternalDictionary.Clear;
  doc := CoDOMDocument.Create;
  doc.loadXML(aXml);

  FromXmlAssignImp(aObject, doc.DocumentElement);

  FixTodos;
end;

function TDnXmlReader.FromXmlCreate(aOwner: TComponent; aXml: string): TComponent;
var doc: IXMLDOMDocument2;
begin
  FInternalDictionary.Clear;
  doc := CoDOMDocument.Create;
  doc.loadXML(aXml);

  result := FromXmlCreateImp(aOwner, doc.DocumentElement);

  FixTodos;
end;

procedure TDnXmlReader.FromXmlAssignImp(aObject: TComponent; aNode: IXmlDomNode; aOwner: TComponent);
var node: IXmlNodeType;
    i, iMapper: Integer;
    mapper: TDnXmlPropMapper;
    mapperclass: TDnXmlPropMapperClass;
    obj: TObject;
begin
  node := FindNode(aNode, 'ClassName');
  if node = nil then
    raise Exception.Create('ClassName node not found in XML data');
  if CompareText(node.text, aObject.ClassName) <> 0 then
    raise Exception.CreateFmt('Class %s, specified in the xml data, does not match object class %s', [node.text, aObject.ClassName]);
  if aNode.attributes.getNamedItem('ID') = nil then
    raise Exception.Create('ID node not found in XML data');

  MarkRead(aObject, GetAttribute(aNode, 'ID'));

  // process properties for each registered property mapper
  for iMapper := 0 to GetXmlPropMapperCount(aObject.ClassType) - 1 do
  begin
    mapperclass := GetXmlPropMapper(aObject.ClassType, iMapper);
    if mapperclass = nil then
      raise Exception.CreateFmt('Cannot write xml for class %s (no property mapper(s) registered for it)', [aObject.ClassName]);

    mapper := mapperclass.CreateWithObject(aObject);
    try
      for i := 0 to mapper.Count - 1 do
      begin
        if not ReadNameProperty and (mapper.PropName[i] = 'Name') then
          Continue;
        if not ReadTagProperty and (mapper.PropName[i] = 'Tag') then
          Continue;

        if mapper.IsStored[i] then
        begin
          node := Findnode(aNode, (mapper.PropName[i]));
          if node = nil then
          begin
            // property not found in xml
            if ExceptOnMissingProps then
              raise Exception.CreateFmt('Xml node %s not found while reading class %s', [mapper.PropName[i], aObject.ClassName])
            else
              Continue;
          end;

          if mapper.IsObject[i] then
          begin
            // if the node has the (Ref)ID attribute, its a TComponent object, or if it's nil we cant
            // determine so TComponent is assumed
            if HasAttribute(node, 'ID') or HasAttribute(node, 'RefID') or (node.text = 'nil') then
            begin
              if mapper.IsAssignableObject[i] then
              begin
                // its a reference
                if node.attributes.getNamedItem('RefID') <> nil then
                begin
                  obj := ActiveDictionary.ObjectOfId(GetAttribute(node, 'RefID'));
                  if obj = nil then
                    AddTodo(GetAttribute(node, 'RefID'), aObject, mapperclass, i)
                  else
                    mapper.ObjectProp[i] := obj;
                end
                else
                begin
                  if node.text = 'nil' then
                  begin
                    if SetObjPropMode in [sopmFreeAndSet, sopmTryAssignElseFreeAndSet] then
                      mapper.ObjectProp[i].Free;
                    mapper.ObjectProp[i] := nil
                  end
                  else
                  begin
                    // convert child object property
                    if (SetObjPropMode in [sopmTryAssignElseSet, sopmTryAssignElseFreeAndSet]) and
                       (CompareText(mapper.ObjectProp[i].ClassName, FindNode(node, 'ClassName').text) = 0)
                    then
                      FromXmlAssignImp(mapper.ObjectProp[i] as TComponent, node, aObject)
                    else if SetObjPropMode in [sopmFreeAndSet, sopmTryAssignElseFreeAndSet] then
                    begin
                      if (mapper.ObjectProp[i] as TComponent).Owner = aObject then
                      begin
                        mapper.ObjectProp[i].Free;
                        mapper.ObjectProp[i] := nil;
                      end;
                      mapper.ObjectProp[i] := FromXmlCreateImp(aObject as TComponent, node);
                    end
                    else
                      mapper.ObjectProp[i] := FromXmlCreateImp(aObject as TComponent, node);
                  end;
                end;
              end
              else
              begin
                if (mapper.ObjectProp[i] = nil) and (node.text <> 'nil')then
                  raise Exception.CreateFmt('Property %s.%s must be initialized because it is readonly and cannot be instantiated outside its owner object. It is also possible to make to property writable or non-stored', [aObject.ClassName, mapper.PropName[i]]);
                if mapper.ObjectProp[i] <> nil then
                  FromXmlAssignImp(mapper.ObjectProp[i] as TComponent, node, aObject as TComponent);
              end;
            end
            else
            begin
              obj := mapper.ObjectProp[i];
              if (node.text = 'nil') and (obj <> nil) then
                raise Exception.Create('Non TComponent objects instances cannot have "nil" as their xml data');
              if (node.text <> 'nil') and (obj = nil) then
                raise Exception.CreateFmt('Non TComponent objects cannot be instantiated from xml. Property %s was expected to have an object-instance assigned instead of nil', [mapper.PropName[i]]);
              if (node.text <> 'nil') and (obj <> nil) then
                XmlToListItems(obj, node, aObject as TComponent);
            end;
          end
          else
            mapper.Value[i] := node.text;
        end;
      end;
    finally
      mapper.Free;
    end;
  end;

  XmlToListItems(aObject, aNode, aOwner);
end;

procedure TDnXmlReader.XmlToListItems(aObject: TObject; aNode: IXmlNodeType; aOwner: TComponent);
var listmapperclass: TDnXmlListMapperClass;
    listmapper: TDnXmlListMapper;
    listowner: TComponent;
    i: Integer;
    node: IXmlNodeType;
    obj: TObject;
begin
  // process list-items
  listmapperclass := GetListMapper(aObject.ClassType);
  if listmapperclass <> nil then
  begin
    listmapper := listmapperclass.CreateWithObject(aObject);
    try
      if aObject is TComponent then
        listowner := TComponent(aObject)
      else
        listowner := aOwner;

      if ClearListMode <> clmClear then
      begin
        for i := listmapper.Count - 1 downto 0 do
        begin
          obj := listmapper.ObjectItem[i];
          if ClearListMode in [clmFreeChildren, clmFreeChildrenAndClear] then
          begin
            if TComponent(obj).Owner = listowner then
              obj.Free;
          end
          else if ClearListMode in [clmFreeAll, clmFreeAllAndClear] then
            obj.Free;
        end;
      end;

      if ClearListMode in [clmClear, clmFreeChildrenAndClear, clmFreeAllAndClear] then
        listmapper.Clear;

      for i := 0 to aNode.ChildNodes.length - 1 do
      begin
        if aNode.ChildNodes[i].NodeName = 'list-item' then
        begin
          node := aNode.ChildNodes[i];
          if listmapper.StoresObjects then
          begin
            if not HasAttribute(node, 'RefID') then
              listmapper.Add(FromXmlCreateImp(listowner, node))
            else
            begin
              // reference item
              obj := ActiveDictionary.ObjectOfId(GetAttribute(node, 'RefID'));
              listmapper.Add(obj);
              if obj = nil then
                AddListTodo(GetAttribute(node, 'RefID'), aObject, listmapperclass, listmapper.Count - 1);
            end;
          end
          else
            listmapper.Add(node.Text);
        end;
      end;
    finally
      listmapper.Free;
    end;
  end;
end;

function TDnXmlReader.FromXmlCreateImp(aOwner: TComponent; aNode: IXmlNodeType): TComponent;
var
  node: IXmlNodeType;
  cls: TClass;
begin
  node := FindNode(aNode, 'ClassName');
  if node = nil then
    raise Exception.Create('ClassName node not found in XML data');

  cls := DoGetClass(node.text);

  if cls = nil then
    raise Exception.CreateFmt('Could not resolve class %s, register this class using the ' +
      'RegisterClass or RegisterClasses routines, or resolve the classes in the TDnXmlReader.' +
      'OnGetClass event or register a TDnXmlClassResolver implementation', [node.text]);

  if not cls.InheritsFrom(TComponent) then
    raise Exception.CreateFmt('Xml reader can only create TComponent objects. %s does not descent ' +
      'from TComponent. To work with non TComponent objects use readonly properties and instantiate ' +
      'the objects in the constructor', [cls.ClassName]);

  result := TComponentClass(cls).Create(aOwner as TComponent);

  FromXmlAssignImp(result, aNode, aOwner);
end;

function TDnXmlReader.IdOfObject(aObject: TComponent): string;
begin
  result := ActiveDictionary.IdOfObject(aObject);
end;

procedure TDnXmlReader.MarkRead(aObject: TComponent; aId: string);
begin
  FInternalDictionary.Add(aObject, aId);
  if FDictionary <> nil then
    FDictionary.Add(aObject, aId);
end;

procedure TDnXmlReader.FromXmlFileAssign(aXmlFile: string; aObject: TComponent);
var list: TStringList;
begin
  list := TStringList.Create;
  try
    list.LoadFromFile(aXmlFile);
    FromXmlAssign(list.Text, aObject);
  finally
    list.Free;
  end;
end;

function TDnXmlReader.FromXmlFileCreate(aOwner: TComponent; aXmlFile: string): TComponent;
var list: TStringList;
begin
  list := TStringList.Create;
  try
    list.LoadFromFile(aXmlFile);
    result := FromXmlCreate(aOwner, list.Text);
  finally
    list.Free;
  end;
end;

function TDnXmlReader.ActiveDictionary: TDnXmlDictionary;
begin
  if FDictionary <> nil then
    result := FDictionary
  else
    result := FInternalDictionary;
end;

procedure TDnXmlReader.SetDictionary(const Value: TDnXmlDictionary);
begin
  FDictionary := Value;
  if FDictionary <> nil then
    FDictionary.FreeNotification(Self);
end;

procedure TDnXmlReader.Notification(aComponent: TComponent;
  aOperation: TOperation);
begin
  inherited;
  if aOperation = opRemove then
  begin
    if aComponent = FDictionary then
      FDictionary := nil;
  end;
end;

{ TDnXmlDictionary }

procedure TDnXmlDictionary.Add(aObject: TComponent; aId: string);
var idx, value, code: Integer;
begin
  idx := FObjects.IndexOf(aId);
  if idx <> -1 then
    FObjects.Objects[idx] := aObject
  else
  begin
    Assert(FObjects.IndexOfObject(aObject) = -1, 'Xml Dictionary failure, the object associated with id ' + aId + ' was already in the dictionary');
    FObjects.AddObject(aId, aObject);
    aObject.FreeNotification(Self);
  end;

  // keep track of the highest used id
  Val(aId, value, code);
  if (code = 0) and (Value > FMax) then
    FMax := value;
end;

procedure TDnXmlDictionary.Clear;
begin
  FObjects.Clear;
end;

constructor TDnXmlDictionary.Create(aOwner: TComponent);
begin
  inherited;
  FObjects := TStringList.Create;
end;

destructor TDnXmlDictionary.Destroy;
begin
  FObjects.Free;
  inherited;
end;

function TDnXmlDictionary.GetCount: Integer;
begin
  result := FObjects.Count;
end;

function TDnXmlDictionary.GetIds(aIndex: Integer): string;
begin
  result := FObjects[aIndex];
end;

function TDnXmlDictionary.GetNewId: string;
begin
  inc(FMax);
  result := IntToStr(FMax);
end;

function TDnXmlDictionary.GetObjects(aIndex: Integer): TObject;
begin
  result := FObjects.Objects[aIndex];
end;

function TDnXmlDictionary.IdOfObject(aObject: TObject): string;
var idx: Integer;
begin
  idx := FObjects.IndexOfObject(aObject);
  if idx <> -1 then
    result := FObjects[idx]
  else
    result := '';
end;

procedure TDnXmlDictionary.Notification(aComponent: TComponent;
  aOperation: TOperation);
var idx: Integer;
begin
  inherited;
  if aOperation = opRemove then
  begin
    idx := FObjects.IndexOfObject(aComponent);
    if idx <> -1 then
      FObjects.Delete(idx);
  end;
end;

function TDnXmlDictionary.ObjectOfId(aId: string): TObject;
var idx: Integer;
begin
  idx := FObjects.IndexOf(aId);
  if idx <> -1 then
    result := FObjects.Objects[idx]
  else
    result := nil;
end;

initialization
  gClassResolvers := TList.Create;

finalization
  gClassResolvers.Free;

end.