unit XMLu;
{ Common (switchable) interface to XML engine(s) }

interface
uses
  SysUtils, Classes, PropUtl;{example03\example03main.pas}

{ Loads (creates) AComponent and its children components (recursively) from
  xml AFile. The component and all the children classes must be registered
  (using RegisterClass procedure in the component's unit initialization part)
  and tag names of all xml elements must equal to the class names (without
  the starting letter 'T'). E.g. component of the class 'Tdevice' copies
  attribute values of the xml element with tag 'device' to its published
  properties with the same names. }

type
// from xdom_2_3:
{$DEFINE INCLUDE_XPATH}
  TDomNodeType = (ntUnknown,
                  ntElement_Node,
                  ntAttribute_Node,
                  ntText_Node,
                  ntCDATA_Section_Node,
                  ntEntity_Reference_Node,
                  ntEntity_Node,
                  ntProcessing_Instruction_Node,
                  ntComment_Node,
                  ntDocument_Node,
                  ntDocument_Type_Node,
                  ntDocument_Fragment_Node,
                  ntNotation_Node,
                  ntDocument_Type_Decl_Node
{$ifdef INCLUDE_XPATH}
                  ,ntXPath_Namespace_Node
{$endif}
                  );
// /from xdom_2_3
  TXMLNodeType = TDomNodeType;

type
  TXMLNodeName = string;
  TXMLNodeValue = string;
  TXMLNode = class;

  EXML = class(Exception);

  TXMLNodes = class(TList)
  private
    FIsAttrList: boolean;
    FOwnerNode: TXMLNode;
    //FList: TList;
    procedure SetNodeValue(const AName: TXMLNodeName; const AValue: TXMLNodeValue);
    function GetNodeValue(const AName: TXMLNodeName): TXMLNodeValue;
    function GetNodeName(Index: integer): TXMLNodeName;
    function GetNode(Index: integer): TXMLNode;
    //function GetCount: integer;
    function NodeFind(const AName: TXMLNodeName; var ANode: TXMLNode): boolean;
    function NodeAdd(const AName: TXMLNodeName; const AValue: TXMLNodeValue; ANodeType: TXMLNodeType): TXMLNode; overload;
      // creates and add new XML node (source XML node is also created by FOwnerNode)
    //function NodeAdd(ANode: pointer): TXMLNode; overload;
      // create new XML node from existing source and add it to the list
    //procedure Update;
      // update Items/Nodes according to FOwnerNode and FNodesType
  protected
  public
    constructor Create(AOwnerNode: TXMLNode; ANodesType: TXMLNodeType);
    //procedure SetNodeValue(Index: integer; const AValue: TXMLNodeValue); overload;
    //function GetNodeValue(Index: integer): TXMLNodeValue; overload;

    //property Count: integer read GetCount;
    property Nodes[Index: integer]: TXMLNode read GetNode; default;
    property Values[const AName: TXMLNodeName]: TXMLNodeValue read GetNodeValue write SetNodeValue;
    property Names[Index: integer]: TXMLNodeName read GetNodeName;
  end;

  TXMLNode = class(TObject) // abstract xmlnode wrapper
  private
    FOwner: TXMLNode;
    FSrcNode: pointer; // pointer to the xml node produced by given XML implementaion
    FChilds: TXMLNodes;// if non nil, contains list of child nodes (non attributes)
    FAttrs: TXMLNodes; // if non nil, contains list of attributes
  protected
    procedure SetResult(const msg: string);

    function GetNodeType: TXMLNodeType; virtual; abstract;
    function GetNodeName: TXMLNodeName; virtual; abstract;
    function GetNodeValue: TXMLNodeValue; virtual; abstract;
    procedure SetNodeValue(const AValue: TXMLNodeValue); virtual; abstract;
    function GetChilds: TXMLNodes; virtual; abstract;
    function GetAttrs: TXMLNodes; virtual; abstract;
    procedure SetSrcNode(ASrcNode: Pointer); virtual;

    function NodeAdd(ASrcNode: pointer): TXMLNode; overload; virtual; abstract;
      // create child XMLNode from source node (must have owner = Node)
    function GetOwner: TXMLNode; virtual; abstract;
    procedure ChildsUpdate; virtual; abstract;// rebuilds FChilds from FSrcNode element child nodes
    procedure AttrsUpdate; virtual; abstract; // rebuilds FAttrs from FSrcNode attributes
  public
    function NodeAdd(const AName: TXMLNodeName; const AValue: TXMLNodeValue;
      AXMLNodeType: TXMLNodeType): TXMLNode; overload; virtual; abstract;
      // add direct child node - element or attribute and creates corresponding
      // source node
    function NodeRemove(ANode: TXMLNode): integer;
      // remove specified child node; returns its index in Childs or Attrs list
    constructor Create(AOwner: TXMLNode; ASrcNode: pointer); reintroduce;
    destructor Destroy; override;
    procedure LoadFromFile(const AFileName: TFileName); virtual; abstract;
    procedure SaveToFile(const AFileName: TFileName); virtual; abstract;

    property NodeType: TXMLNodeType read GetNodeType;
    property SrcNode: pointer read FSrcNode write SetSrcNode;
    property Name: TXMLNodeName read GetNodeName; // returns tag name for element, attribute name for attribute
    property Value: TXMLNodeValue read GetNodeValue write SetNodeValue; // returns text for element, attribute value for attribute
    property Childs: TXMLNodes read GetChilds; // returns list of direct children for element, empty list for attribute
    property Attrs: TXMLNodes read GetAttrs;  // returns list of attributes for element, empty list for attribute
    property Owner: TXMLNode read GetOwner;
  end;

  TXDomXMLNode = class(TXMLNode)
  protected
    function GetNodeType: TXMLNodeType; override;
    function GetNodeName: TXMLNodeName; override;
    function GetNodeValue: TXMLNodeValue; override;
    procedure SetNodeValue(const AValue: TXMLNodeValue); override;
    function GetChilds: TXMLNodes; override;
    function GetAttrs: TXMLNodes; override;
    function NodeAdd(ASrcNode: pointer): TXMLNode; override;
       // create TXMLNode from FSrcNode source's child node ANode
    function GetOwner: TXMLNode; override;
    procedure ChildsUpdate; override;
    procedure AttrsUpdate; override;
  public
    function NodeAdd(const AName: TXMLNodeName; const AValue: TXMLNodeValue;
      AXMLNodeType: TXMLNodeType): TXMLNode; override;
       // create new XML node and attach it as a child or attribute to itself

    destructor Destroy; override;
    procedure LoadFromFile(const AFileName: TFileName); override;
    procedure SaveToFile(const AFileName: TFileName); override;
  end;

function XMLFileToComp(var AComponent: TComponent; const AFileName: string): integer;

{ Writes AComponent and its children to AFileName in xml format. Each component
  will be a xml element with tag name equal to ClassName of the component
  (without the starting letter 'T') and the attributes of the element will have
  names and values equal to the published properties of the corresponding
  component. }
function CompToXMLFile(AComponent: TComponent; const AFileName: string): integer;

function XMLNodeCreate(AOwner: TXMLNode; ASrcNode: pointer): TXMLNode;

implementation
uses
   XDOM_2_4;

var
  DI: TDomImplementation;


{TXMLNode.}
constructor TXMLNode.Create(AOwner: TXMLNode; ASrcNode: pointer);
begin
  inherited Create;
  FOwner := AOwner;
  SrcNode := ASrcNode;
end;

procedure TXMLNode.SetResult(const msg: string);
begin
  raise EXML.Create('XMLNode: ' + msg);
end;

procedure TXMLNode.SetSrcNode(ASrcNode: Pointer);
begin
  if ASrcNode <> FSrcNode then begin
    FSrcNode := ASrcNode;
    ChildsUpdate; // rebuild child list
    AttrsUpdate;  // rebuild attr list
  end;
end;

function TXMLNode.NodeRemove(ANode: TXMLNode): integer;
begin
  if ANode.NodeType = ntAttribute_Node then begin
    Result := Attrs.Remove(ANode);
  end else begin
    Result := Childs.Remove(ANode);
  end;
end;

destructor TXMLNode.Destroy;
begin
  if FOwner <> nil then
    FOwner.NodeRemove(Self);//tlist
  FreeAndNil(FChilds);
  FreeAndNil(FAttrs);
  inherited;
end;
{/TXMLNode.}

{TXMLNodes.}
function TXMLNodes.NodeFind(const AName: TXMLNodeName; var ANode: TXMLNode): boolean;
var
  i: integer;
begin
  Result := false;
  for i := 0 to Count - 1 do begin
    if Nodes[i].Name = AName then begin
      ANode := Nodes[i];
      Result := true;
      exit;
    end;
  end;
end;

function TXMLNodes.NodeAdd(const AName: TXMLNodeName; const AValue: TXMLNodeValue; ANodeType: TXMLNodeType): TXMLNode;
begin
  if FIsAttrList and (ANodeType <> ntAttribute_Node) then
    FOwnerNode.SetResult('NodeAdd - adding non attribute node to attr list');
  Result := FOwnerNode.NodeAdd(AName, AValue, ANodeType);
{  case FNodesType of
    ntElement_Node: Result := FOwnerNode.ChildAdd(AName, AValue);
    ntAttribute_Node: Result := FOwnerNode.AttrAdd(AName, AValue);
  end;}
end;

procedure TXMLNodes.SetNodeValue(const AName: TXMLNodeName; const AValue: TXMLNodeValue);
var
  n: TXMLNode;
  nt: TXMLNodeType;
begin
  if NodeFind(AName, n) then
    n.Value := AValue
  else begin
    if FIsAttrList then
      nt := ntAttribute_Node
    else begin
      nt := ntElement_Node;
    end;
    NodeAdd(AName, AValue, nt);
  end;
end;

function TXMLNodes.GetNodeValue(const AName: TXMLNodeName): TXMLNodeValue;
var
  n: TXMLNode;
begin
  if NodeFind(AName, n) then
    Result := n.Value
  else
    Result := '';
end;


function TXMLNodes.GetNodeName(Index: integer): TXMLNodeName;
begin
  Result := Nodes[Index].Name;
end;

function TXMLNodes.GetNode(Index: integer): TXMLNode;
begin
  Result := TXMLNode(Items[Index]);
end;

//function TXMLNodes.GetCount: integer;
//begin
//  Result := FOwnerNode.Childs.Count;
//end;

constructor TXMLNodes.Create(AOwnerNode: TXMLNode; ANodesType: TXMLNodeType);
begin
  inherited Create;
  FOwnerNode := AOwnerNode;
  FIsAttrList := ANodesType = ntAttribute_Node;
end;

{
procedure TXMLNodes.Update;
begin
  case FOwnerNode.NodeType of
    ntElement_Node: begin
      case FNodesType of
        ntElement_Node: FOwnerNode.ChildsUpdate;
        ntAttribute_Node: FOwnerNode.AttrsUpdate;
      end;
    end;
  end
end;
}
{/TXMLNodes.}

{TXDomXMLNode.}
function TXDomXMLNode.GetNodeType: TXMLNodeType;
begin
  Result := TXMLNodeType(TDomNode(FSrcNode).nodeType);
end;

function TXDomXMLNode.GetNodeName: TXMLNodeName;
begin
  Result := TDomNode(FSrcNode).nodeName;
end;

function TXDomXMLNode.GetNodeValue: TXMLNodeValue;
begin
  case NodeType of
    ntAttribute_Node: Result := TDomNode(FSrcNode).nodeValue;
    ntElement_Node: Result := TDomElement(FSrcNode).textContent;
  else
    Result := TDomNode(FSrcNode).nodeValue;
  end;
end;

procedure TXDomXMLNode.SetNodeValue(const AValue: TXMLNodeValue);
begin
  TDomNode(FSrcNode).nodeValue := AValue;
end;

procedure TXDomXMLNode.ChildsUpdate;
var
  //e: TDomElement;
  n: TDomNode;
  nt: TXMLNodeType;
  i: integer;
begin
  Childs.Clear;
  for i := 0 to TDomNode(FSrcNode).ChildNodes.Length - 1 do begin
    n := TDomNode(FSrcNode).childNodes.item(i);
    nt := TXMLNodeType(n.nodeType);
    if nt <> ntAttribute_Node then begin
      if (nt = ntText_Node) then begin
        if Trim(n.nodeValue) <> '' then
          NodeAdd(n);
      end else begin
        NodeAdd(n);
      end;
    end;
  end;
  {
  e := TDomNode(FSrcNode).findFirstChildElement;
  while e <> nil do begin
    NodeAdd(e);
    e := e.findNextSiblingElement;
  end;
  }
end;

function TXDomXMLNode.GetChilds: TXMLNodes;
begin
  if FChilds = nil then begin
    FChilds := TXMLNodes.Create(Self, ntUnknown);
    //FChilds.Update;
  end;
  Result := FChilds;
end;

function TXDomXMLNode.NodeAdd(ASrcNode: pointer): TXMLNode;
{v0.74}{/v0.74 var
  nt: TXMLNodeType;}
begin
  Result := TXDomXMLNode.Create(Self, ASrcNode);
{v0.74}{/v0.74  nt := Result.NodeType;}
//  if Result.Owner <> Self then
//    SetResult('Trying to add non child node as a child.');
  case Result.NodeType of
    ntAttribute_Node: FAttrs.Add(Result);
  else
    FChilds.Add(Result);
    //Result.Free;
    //SetResult('NodeAdd - unsupported node type ' + IntToStr(integer(nt)));
  end;
end;

function TXDomXMLNode.NodeAdd(const AName: TXMLNodeName; const AValue: TXMLNodeValue;
  AXMLNodeType: TXMLNodeType): TXMLNode;
var
  e: TDomElement;
  a: TDomAttr absolute e;
  t: TDomText absolute e;
begin
  case NodeType of
    ntElement_Node: begin
      case AXMLNodeType of
        ntElement_Node: begin
          e := TDomNode(FSrcNode).ownerDocument.CreateElement(AName);
          e.NodeValue := AValue;//???
          TDomNode(FSrcNode).appendChild(e);
        end;
        ntAttribute_Node: begin
          a := TDomElement(FSrcNode).SetAttribute(AName, AValue);
        end;
        ntText_Node:  begin
          with TDomNode(FSrcNode) do begin
            t := ownerDocument.CreateTextNode(AValue);
            appendChild(t);
          end;
        end;
      else
        SetResult('NodeAdd - unsupported child node type ' + IntToStr(integer(AXMLNodeType)));
      end;
      Result := NodeAdd(e);
    end;
  else
    SetResult('NodeAdd - for node type ' + IntToStr(integer(NodeType)) + ' is child node type '
       + IntToStr(integer(AXMLNodeType)) + ' unsupported.');
  end;
end;

        //FAttrs.Add(TXMLNode.Create(a));

procedure TXDomXMLNode.AttrsUpdate;
var
  ats: TDomNamedNodeMap;
  a: TDomAttr;
  i: integer;
begin
  Attrs.Clear;
  ats := TDomNode(FSrcNode).Attributes;
  if ats <> nil then begin
    for i := 0 to ats.length - 1 do begin
      a := TDomAttr(ats.Item(i));
      NodeAdd(a);
      //FAttrs.NodeNodeAdd(a)
      //FAttrs.Add(TXMLNode.Create(a));
    end;
  end;  
end;

function TXDomXMLNode.GetAttrs: TXMLNodes;
begin
  if FAttrs = nil then begin
    FAttrs := TXMLNodes.Create(Self, ntAttribute_Node);
  end;
  Result := FAttrs;
end;

function TXDomXMLNode.GetOwner: TXMLNode;
begin
  Result := FOwner;
end;

{
procedure TXDomXMLNode.SetNode(ANode: Pointer);
begin
  FSrcNode := ANode;
end;
}

procedure TXDomXMLNode.LoadFromFile(const AFileName: TFileName);
var
  xp: TXmlToDomParser;
begin
  if DI = nil then
    DI := TDomImplementation.Create(nil);
  xp := TXmlToDomParser.create(nil);
  try
    xp.domImpl := DI;
    try
      SrcNode := xp.FileToDom(AFileName);
    finally
    end;
  finally
    xp.Free;
  end;
end;

procedure TXDomXMLNode.SaveToFile(const AFileName: TFileName);
var
  dd: TDomDocument;
  dp: TDomToXmlParser;
  f: TFileStream;
  //cursp: string;

  {
  function GetTag(AComp: TComponent): string;
  begin
    Result := copy(AComp.ClassName, 2, length(AComp.ClassName));
  end;

  procedure SetAttrs(de: TDomElement; c: TComponent);
  var
    j: integer;
    n: shortstring;
    v: AnsiString;
  begin
    j := 0;
    while ClassGetPropNameAndValue(c, j, n, v) do begin
      de.SetAttribute(n, v);
      inc(j);
    end;
  end;

  procedure DoElement(dn: TDomElement; o: TComponent);
  var
    c: TComponent;
    de: TDomElement;
    i: integer;
    dt: TDomText;
  begin
    SetAttrs(dn, o);

    dt := dd.createTextNode(#13#10 + cursp);
    dn.appendChild(dt);

    for i := 0 to o.ComponentCount - 1 do begin
      c := o.Components[i];
      de := dd.CreateElement(GetTag(c));

      cursp := cursp + '  ';
      DoElement(de, c);
      cursp := copy(cursp, 1, length(cursp) - 2);

      dn.AppendChild(de);

      dt := dd.CreateTextNode(#13#10 + cursp);
      dn.AppendChild(dt);

    end;
  end;
  }

begin
  if not (TObject(FSrcNode) is TDomDocument) then
    SetResult('Not a root element, can not save.');
  dd := TDomDocument(FSrcNode);
  //cursp := '';
  if DI = nil then
    DI := TDomImplementation.Create(nil);
  //dd := DI.CreateDocument(GetTag(AComponent),nil);
  //try
    //DoElement(dd.DocumentElement, AComponent);
    dp := TDomToXmlParser.Create(nil);
    try
      dp.DomImpl := DI;
      f := TFileStream.Create(AFileName, fmCreate);
      try
        dp.WriteToStream(dd.DocumentElement, 'windows-1250', f);
      finally
        f.Free;
      end;
    finally
      dp.Free;
    end;
  //finally
  // di.FreeDocument(dd);
  //end;
end;

destructor TXDomXMLNode.Destroy;
begin
  if TObject(FSrcNode) is TDomDocument then
    DI.FreeDocument(TDomDocument(FSrcNode));
  inherited;
end;
{/TXDomXMLNode.}

function XMLNodeCreate(AOwner: TXMLNode; ASrcNode: pointer): TXMLNode;
begin
  Result := TXDomXMLNode.Create(AOwner, ASrcNode);
end;

function XMLFileToComp(var AComponent: TComponent; const AFileName: string): integer;
var
  di: TDomImplementation;
  xp: TXmlToDomParser;
  doc: TDomDocument;

  function DoElement(el: TDomElement; AOwner: TComponent): TComponent;
  var
    o: TComponent;
    i: integer;
    ats: TDomNamedNodeMap;
    a: TDomAttr;
    cel: TDomElement;
  begin
    o := TComponentClass(FindClass('T' + el.TagName)).Create(AOwner);
    ats := el.Attributes;
    for i := 0 to ats.length - 1 do begin
      a := TDomAttr(ats.Item(i));
      ClassSetPropStr(o, a.name, a.value);
    end;
    cel := el.findFirstChildElement;
    while cel <> nil do begin
      DoElement(cel, o);
      cel := cel.findNextSiblingElement;
    end;
    Result := o;
  end;

begin
  Result := -1;
  di := TDomImplementation.Create(nil);
  try
    xp := TXmlToDomParser.create(nil);
    try
      xp.domImpl := di;
      doc := xp.FileToDom(AFileName);
      try
        AComponent := DoElement(doc.DocumentElement, nil);
      finally
        di.FreeDocument(doc);
      end;
    finally
      xp.Free;
    end;
  finally
    di.Free;
  end;
end;

function CompToXMLFile(AComponent: TComponent; const AFileName: string): integer;
var
  di: TDomImplementation;
  dd: TDomDocument;
  dp: TDomToXmlParser;
  f: TFileStream;
  cursp: string;

  function GetTag(AComp: TComponent): string;
  begin
    Result := copy(AComp.ClassName, 2, length(AComp.ClassName));
  end;

  procedure SetAttrs(de: TDomElement; c: TComponent);
  var
    j: integer;
    n: shortstring;
    v: AnsiString;
  begin
    j := 0;
    while ClassGetPropNameAndValue(c, j, n, v) do begin
      de.SetAttribute(n, v);
      inc(j);
    end;
  end;

  procedure DoElement(dn: TDomElement; o: TComponent);
  var
    c: TComponent;
    de: TDomElement;
    i: integer;
    dt: TDomText;
  begin
    SetAttrs(dn, o);

    dt := dd.createTextNode(#13#10 + cursp);
    dn.appendChild(dt);

    for i := 0 to o.ComponentCount - 1 do begin
      c := o.Components[i];
      de := dd.CreateElement(GetTag(c));

      cursp := cursp + '  ';
      DoElement(de, c);
      cursp := copy(cursp, 1, length(cursp) - 2);

      dn.AppendChild(de);

      dt := dd.CreateTextNode(#13#10 + cursp);
      dn.AppendChild(dt); {sysutils}

    end;
  end;

begin
  //Result := -1;
  cursp := '';
  di := TDomImplementation.Create(nil);
  try
    dd := di.CreateDocument(GetTag(AComponent),nil);
    try
      DoElement(dd.DocumentElement, AComponent);
        // Memo1.Lines.Text := DD.CodeAsString;
      dp := TDomToXmlParser.Create(nil);
      try
        dp.DomImpl := di;
        f := TFileStream.Create(AFileName, fmCreate);
        try
          dp.WriteToStream(dd.DocumentElement, 'windows-1250', f);
            // dd.CodeAsString;
          Result := 0;
        finally
          f.Free;
        end;
      finally
        dp.Free;
      end;
    finally
      di.FreeDocument(dd);
    end;
  finally
    di.Free;
  end;
end;

initialization
  DI := nil;
finalization
  DI.Free;
end.
