Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue50/XML/XmlClasses.pas

Pascal/Delphi Source File | 1999-09-04 | 32.6 KB | 1,206 lines

unit XmlClasses;

interface

uses Classes, SysUtils, MSXML_TLB, Dialogs, ComCtrls, ImgList, Graphics;

type
  TXmlNodeType = (xntDocument, xntElement, xntText,
      xntComment, xntCDATASection);

  TCharEntity = (ceLt, ceGt, ceQuot, ceApos, ceAmp);

  TCharEntities = set of TCharEntity;

  TSubstituteCharEntitiesEvent = procedure(Sender: TObject;
      var Text: String; var SkipTranslation: Boolean) of Object;

const
  XmlNodeNames: array[xntDocument..xntCDATASection] of String =
      ('#document', '', '#text', '#comment', '#cdata-section');

type
  EXmlDError = class(Exception);

  EXmlDParseError = class(Exception)
    FErrorCode:   Integer;
    FReason:      String;
    FSrcText:     String;
    FLine:        Integer;
    FLinePos:     Integer;
  public
    constructor Create(ParseError: IXMLDOMParseError);
    procedure ShowParseError;
    property ErrorCode: Integer read FErrorCode;
    property Reason: String read FReason;
    property SrcText: String read FSrcText;
    property Line: Integer read FLine;
    property LinePos: Integer read FLinePos;
  end;

  TXmlName = String;

  TXmlDDocument = class;
  TXmlDStructureNode = class;
  TXmlDElement = class;
  TXmlDCDATASection = class;
  TXmlDComment = class;
  TXmlDText = class;
  TXmlDAttrList = class;

  TXmlDNode = class(TPersistent)
    private
      FPreviousSibling: TXmlDNode;
      FNextSibling:     TXmlDNode;
      FParentNode:      TXmlDStructureNode;
      FNodeType:        TXmlNodeType;
    protected
      function GetFirstChild: TXmlDNode; virtual;
      function GetLastChild: TXmlDNode; virtual;
      function GetOwnerDocument: TXmlDDocument;
      function GetNodeName: TXmlName; virtual;
      function GetNodeValue: String; virtual;
      procedure SetNodeName(const Value: TXmlName); virtual;
      procedure SetNodeValue(const Value: String); virtual;
      function GetLevel: Integer;
      procedure WriteToStream(Stream: TStream;
          FormattedForPrint: Boolean); virtual; abstract;
      procedure WriteFormattedPrefix(Stream: TStream);
      procedure WriteFormattedSuffix(Stream: TStream);
    public
      constructor Create;
      function CloneNode(RecurseChildren: Boolean = False): TXmlDNode;
          virtual; abstract;
      procedure AppendChild(NewNode: TXmlDNode); virtual;
      function ReplaceChild(NewNode: TXmlDNode; OldNode: TXmlDNode):
          TXmlDNode; virtual;
      procedure InsertBefore(NewNode: TXmlDNode; ThisNode: TXmlDNode);
      function RemoveChild(ThisNode: TXmlDNode): TXmlDNode; virtual;
      function HasChildNodes: Boolean; virtual;
      property FirstChild: TXmlDNode read GetFirstChild;
      property LastChild: TXmlDNode read GetLastChild;
      property PreviousSibling: TXmlDNode read FPreviousSibling;
      property NextSibling: TXmlDNode read FNextSibling;
      property ParentNode: TXmlDStructureNode read FParentNode;
      property OwnerDocument: TXmlDDocument read GetOwnerDocument;
      property NodeName: TXmlName read GetNodeName write SetNodeName;
      property NodeType: TXmlNodeType read FNodeType;
      property NodeValue: String read GetNodeValue write SetNodeValue;
      property Level: Integer read GetLevel;
  end;

  TXmlDStructureNode = class(TXmlDNode)
    private
      FAttrList:        TXmlDAttrList;
      FFirstChild:      TXmlDNode;
      FLastChild:       TXmlDNode;
    protected
      procedure CloneChildren(FromNode: TXmlDStructureNode);
      procedure WriteChildrenToStream(Stream: TStream;
          FormattedForPrint:Boolean);
    public
      constructor Create;
      destructor Destroy; override;
      function GetFirstChild: TXmlDNode; override;
      function GetLastChild: TXmlDNode; override;
      procedure AppendChild(NewNode: TXmlDNode); override;
      function ReplaceChild(NewNode: TXmlDNode; OldNode: TXmlDNode):
          TXmlDNode; override;
      function RemoveChild(ThisNode: TXmlDNode): TXmlDNode; override;
      function HasChildNodes: Boolean; override;
      property AttrList: TXmlDAttrList read FAttrList;
    end;

  TXmlDContentNode = class(TXmlDNode)
    private
      FValue: String;
    protected
      function GetNodeValue: String; override;
      procedure SetNodeValue(const Value: String); override;
  end;

  TXmlDDocument = class(TXmlDStructureNode)
    private
      FDocumentElement: TXmlDElement;
      FDocumentTypeDefinition: String;
      FAttrCharEntities: TCharEntities;
      FTextCharEntities: TCharEntities;
      FOnOutputAttrValue: TSubstituteCharEntitiesEvent;
      FOnOutputTextValue: TSubstituteCharEntitiesEvent;
      DiscardUnsupportedItems: Boolean;
    protected
      procedure WriteToStream(Stream: TStream;
          FormattedForPrint: Boolean); override;
      procedure WritePrologToStream(Stream: TStream);
      procedure DecodePrologAttrs(S: String);
      procedure LoadFromDOMDocument(Doc: IXMLDOMDocument);
      procedure LoadChildNodes(ParNode: TXmlDNode;
          ParDOMNode: IXMLDOMNode);
      procedure LoadAttributes(Node: TXmlDElement;
          DOMNode: IXMLDOMNode);
      procedure AssignNodeToTreeNode(XmlNode: TXmlDNode;
        TreeNode: TTreeNode);
      procedure AssignAttrNodesToTreeNodes(ParXmlNode: TXmlDNode;
        ParTreeNode: TTreeNode);
    public
      constructor Create;
      function CloneNode(RecurseChildren: Boolean): TXmlDNode;
          override;
      procedure Clear;
      procedure AppendChild(NewNode: TXmlDNode); override;
      function ReplaceChild(NewNode: TXmlDNode; OldNode: TXmlDNode):
          TXmlDNode; override;
      procedure InsertBefore(NewNode: TXmlDNode; ThisNode: TXmlDNode);
      function RemoveChild(ThisNode: TXmlDNode): TXmlDNode; override;
      function CreateCDATASection(const Text: String):
          TXmlDCDATASection;
      function CreateComment(const Text: String): TXmlDComment;
      function CreateElement(const TagName: TXmlName): TXmlDElement;
          overload;
      function CreateElement(const TagName: TXmlName;
          const Data: String): TXmlDElement; overload;
      function CreateElement(const TagName: TXmlName;
          const Data: String; const AttrName: TXmlName;
          const AttrValue: String): TXmlDElement; overload;
      function CreateElement(const TagName: TXmlName;
          const Data: String; const AttrNames: array of TXmlName;
          const AttrValues: array of String): TXmlDElement; overload;
      function CreateTextNode(const Text: String): TXmlDText;
      procedure AssignTo(Dest: TPersistent); override;
      procedure LoadFromStream(Stream: TStream;
          ValidateOnParse: Boolean = True;
          DiscardUnsupportedItems: Boolean = False);
      procedure LoadFromFile(const FileName: String;
          ValidateOnParse: Boolean = True;
          DiscardUnsupportedItems: Boolean = False);
      procedure SaveToStream(Stream: TStream;
          FormattedForPrint: Boolean = False);
      procedure SaveToFile(const FileName: String;
          FormattedForPrint: Boolean = False);
      property DocumentElement: TXmlDElement read FDocumentElement;
      property DocumentTypeDefinition: String
          read FDocumentTypeDefinition write FDocumentTypeDefinition;
      property AttrCharEntities: TCharEntities read FAttrCharEntities
          write FAttrCharEntities;
      property TextCharEntities: TCharEntities read FTextCharEntities
          write FTextCharEntities;
      property OnOutputAttrValue: TSubstituteCharEntitiesEvent
          read FOnOutputAttrValue write FOnOutputAttrValue;
      property OnOutputTextValue: TSubstituteCharEntitiesEvent
          read FOnOutputTextValue write FOnOutputTextValue;
  end;

  TXmlDElement = class(TXmlDStructureNode)
    private
      FNodeName:        TXmlName;
    protected
      function GetNodeName: TXmlName; override;
      procedure SetNodeName(const Value: TXmlName); override;
      procedure WriteToStream(Stream: TStream;
          FormattedForPrint: Boolean); override;
    public
      constructor Create;
      function CloneNode(RecurseChildren: Boolean): TXmlDNode;
          override;
  end;

  TXmlDText = class(TXmlDContentNode)
  protected
    procedure WriteToStream(Stream: TStream;
        FormattedForPrint: Boolean); override;
  public
    constructor Create;
    function CloneNode(RecurseChildren: Boolean): TXmlDNode; override;
  end;

  TXmlDComment = class(TXmlDContentNode)
  protected
    procedure WriteToStream(Stream: TStream;
        FormattedForPrint: Boolean); override;
  public
    constructor Create;
    function CloneNode(RecurseChildren: Boolean): TXmlDNode; override;
  end;

  TXmlDCDATASection = class(TXmlDContentNode)
  protected
    procedure WriteToStream(Stream: TStream;
        FormattedForPrint: Boolean); override;
  public
    constructor Create;
    function CloneNode(RecurseChildren: Boolean): TXmlDNode; override;
  end;

  TXmlDAttrList = class(TPersistent)
  private
    List:     TStringList;
    FOwnerNode: TXmlDStructureNode;
  protected
    function Add(const S: String): Integer;
    function GetCount: Integer;
    function GetValues(const Name: TXmlName): String;
    function GetNames(Index: Integer): TXmlName;
    procedure SetValues(const Name: TXmlName; const Value: String);
    procedure WriteToStream(Stream: TStream);
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Clear;
    property Count: Integer read GetCount;
    property OwnerNode: TXmlDStructureNode read FOwnerNode;
    property Names[Index: Integer]: TXmlName read GetNames;
    property Values[const Name: TXmlName]: String read GetValues
        write SetValues; default;
  end;

implementation

{$R XMLTreeView.res}

{ Utility Function }

function CharEntitiesReplace(const S: String; CE: TCharEntities):
    String;
begin
  Result := S;
  if ceAmp in CE then
    Result := StringReplace(Result, '&', '&', [rfReplaceAll]);
  if ceLt in CE then
    Result := StringReplace(Result, '<', '<', [rfReplaceAll]);
  if ceGt in CE then
    Result := StringReplace(Result, '>', '>', [rfReplaceAll]);
  if ceApos in CE then
    Result := StringReplace(Result, '''', ''', [rfReplaceAll]);
  if ceQuot in CE then
    Result := StringReplace(Result, '"', '"', [rfReplaceAll]);
end;

{ EXmlDParseError }

constructor EXmlDParseError.Create(ParseError: IXMLDOMParseError);
begin
  inherited Create('XML Parse Error');
  FErrorCode := ParseError.errorCode;
  FReason := ParseError.reason;
  FSrcText := ParseError.srcText;
  FLine := ParseError.line;
  FLinePos := ParseError.linePos;
end;

procedure EXmlDParseError.ShowParseError;
var
  S:  String;
begin
  S := 'XML Parse Error:' + FReason +
      'Line=' + IntToStr(FLine) +
      ' LinePos=' + IntToStr(FLinePos);
  MessageDlg(S, mtError, [mbOK], 0);
end;

{ TXmlDNode }

procedure TXmlDNode.AppendChild(NewNode: TXmlDNode);
begin
  raise EXmlDError.Create('AppendChild operation requested on ' +
      'invalid node type');
end;

constructor TXmlDNode.Create;
begin
  inherited Create;
end;

function TXmlDNode.GetFirstChild: TXmlDNode;
begin
  Result := nil;
end;

function TXmlDNode.GetLastChild: TXmlDNode;
begin
  Result := nil;
end;

function TXmlDNode.GetLevel: Integer;
var
  ParentNode: TXmlDStructureNode;
begin
  Result := 0;
  ParentNode := FParentNode;
  while ParentNode <> nil do
  begin
    Inc(Result);
    ParentNode := ParentNode.FParentNode;
  end;
end;

function TXmlDNode.GetNodeName: TXmlName;
begin
  Result := XmlNodeNames[FNodeType];
end;

function TXmlDNode.GetNodeValue: String;
begin
  Result := '';
end;

function TXmlDNode.GetOwnerDocument: TXmlDDocument;
var
  ANode: TXmlDStructureNode;
begin
  ANode := TXmlDStructureNode(Self);
  while ANode.FParentNode <> nil do
    ANode := ANode.FParentNode;
  Result := ANode as TXmlDDocument;
end;

function TXmlDNode.HasChildNodes: Boolean;
begin
  Result := False;
end;

procedure TXmlDNode.InsertBefore(NewNode, ThisNode: TXmlDNode);
begin
  if ThisNode = FParentNode.FFirstChild then
    FParentNode.FFirstChild := NewNode;
  if ThisNode.FPreviousSibling <> nil then
    ThisNode.FPreviousSibling.FNextSibling := NewNode;
  NewNode.FPreviousSibling := ThisNode.FPreviousSibling;
  ThisNode.FPreviousSibling := NewNode;
  NewNode.FNextSibling := ThisNode;
end;

function TXmlDNode.RemoveChild(ThisNode: TXmlDNode): TXmlDNode;
begin
  raise EXmlDError.Create('RemoveChild operation requested on ' +
      'invalid node type');
end;

function TXmlDNode.ReplaceChild(NewNode, OldNode: TXmlDNode): TXmlDNode;
begin
  raise EXmlDError.Create('ReplaceChild operation requested on ' +
      'invalid node type');
end;

procedure TXmlDNode.SetNodeName(const Value: TXmlName);
begin
end;

procedure TXmlDNode.SetNodeValue(const Value: String);
begin
end;

procedure TXmlDNode.WriteFormattedPrefix(Stream: TStream);
var
  S:  String;
begin
  S := StringOfChar(' ', (Level - 1) * 2);
  Stream.WriteBuffer(Pointer(S)^, Length(S));
end;

procedure TXmlDNode.WriteFormattedSuffix(Stream: TStream);
const
  CRLF:  String[3] = #13#10;
begin
  Stream.WriteBuffer(CRLF[1], 2);
end;

{ TXmlDStructureNode }

procedure TXmlDStructureNode.AppendChild(NewNode: TXmlDNode);
begin
  NewNode.FParentNode := Self;
  if FFirstChild = nil then
  begin
    FFirstChild := NewNode;
    FLastChild := NewNode;
  end
  else
  begin
    FLastChild.FNextSibling := NewNode;
    NewNode.FPreviousSibling := FLastChild;
    FLastChild := NewNode;
  end;
end;

procedure TXmlDStructureNode.CloneChildren(FromNode: TXmlDStructureNode);
var
  N:  TXmlDNode;
begin
  N := FromNode.FFirstChild;
  while N <> nil do
  begin
    AppendChild(N.CloneNode(True));
    N := N.NextSibling;
  end;
end;

constructor TXmlDStructureNode.Create;
begin
  FAttrList := TXmlDAttrList.Create;
  FAttrList.FOwnerNode := Self;
end;

destructor TXmlDStructureNode.Destroy;
var
  Node: TXmlDNode;
  NextNode: TXmlDNode;
begin
  Node := FFirstChild;
  while (Node <> nil) do
  begin
    NextNode := Node.FNextSibling;
    Node.Free;
    Node := NextNode;
  end;
  FAttrList.Free;
  inherited Destroy;
end;

function TXmlDStructureNode.GetFirstChild: TXmlDNode;
begin
  Result := FFirstChild;
end;

function TXmlDStructureNode.GetLastChild: TXmlDNode;
begin
  Result := FLastChild;
end;

function TXmlDStructureNode.HasChildNodes: Boolean;
begin
  Result := FFirstChild <> nil;
end;

function TXmlDStructureNode.RemoveChild(ThisNode: TXmlDNode): TXmlDNode;
begin
  Result := FFirstChild;
  while ((Result <> nil) and (Result <> ThisNode)) do
    Result := Result.FNextSibling;
  if Result <> nil then
  begin
    if FFirstChild = FLastChild then
    begin
      FFirstChild := nil;
      FLastChild := nil;
    end
    else if Result = FFirstChild then
    begin
      FFirstChild := FFirstChild.FNextSibling;
      FFirstChild.FPreviousSibling := nil;
    end
    else if Result = FLastChild then
    begin
      FLastChild := FLastChild.FPreviousSibling;
      FLastChild.FNextSibling := nil;
    end
    else
    begin
      Result.FPreviousSibling.FNextSibling := Result.FNextSibling;
      Result.FNextSibling.FPreviousSibling := Result.FPreviousSibling;
    end;
    Result.FNextSibling := nil;
    Result.FPreviousSibling := nil;
    Result.FParentNode := nil;
  end;
end;

function TXmlDStructureNode.ReplaceChild(NewNode,
  OldNode: TXmlDNode): TXmlDNode;
var
  NextNode: TXmlDNode;
begin
  if OldNode = FLastChild then
  begin
    Result := RemoveChild(OldNode);
    AppendChild(NewNode);
  end
  else
  begin
    NextNode := OldNode.FNextSibling;
    Result := RemoveChild(OldNode);
    InsertBefore(NewNode, NextNode);
  end;
end;

procedure TXmlDStructureNode.WriteChildrenToStream(Stream: TStream;
    FormattedForPrint: Boolean);
var
  N:  TXmlDNode;
begin
  N := FFirstChild;
  while (N <> nil) do
  begin
    N.WriteToStream(Stream, FormattedForPrint);
    N := N.FNextSibling;
  end;
end;

{ TXmlDContentNode }

function TXmlDContentNode.GetNodeValue: String;
begin
  Result := FValue;
end;

procedure TXmlDContentNode.SetNodeValue(const Value: String);
begin
  FValue := Value;
end;

{ TXmlDDocument }

procedure TXmlDDocument.AppendChild(NewNode: TXmlDNode);
begin
  if NewNode.NodeType = xntElement then
  begin
    if FDocumentElement <> nil then
      raise EXmlDError.Create('Second document element add attempted');
    FDocumentElement := TXmlDElement(NewNode);
  end;
  inherited AppendChild(NewNode);
end;

procedure TXmlDDocument.AssignAttrNodesToTreeNodes(ParXmlNode: TXmlDNode;
  ParTreeNode: TTreeNode);
var
  I:  Integer;
  S:  String;
  TreeNode: TTreeNode;
  XSN: TXmlDStructureNode;
begin
  XSN := ParXmlNode as TXmlDStructureNode;
  for I := 0 to (XSN.FAttrList.Count - 1) do
  begin
    S := StringReplace(XSN.FAttrList.List.Strings[I],
        '=', '="', []) + '"';
    TreeNode := ParTreeNode.Owner.AddChild(ParTreeNode, S);
    if ParXmlNode.NodeType = xntDocument then
      TreeNode.ImageIndex := 1
    else
      TreeNode.ImageIndex := 3;
    TreeNode.SelectedIndex := TreeNode.ImageIndex;
    TreeNode.Data := XSN.FAttrList;
  end;
end;

procedure TXmlDDocument.AssignNodeToTreeNode(XmlNode: TXmlDNode;
    TreeNode: TTreeNode);
begin
  case XmlNode.NodeType of
    xntDocument:
    begin
      TreeNode.Text := 'XML Document';
      TreeNode.ImageIndex := 0;
      AssignAttrNodesToTreeNodes(XmlNode, TreeNode);
    end;
    xntElement:
    begin
      TreeNode.Text := XmlNode.NodeName;
      TreeNode.ImageIndex := 2;
      AssignAttrNodesToTreeNodes(XmlNode, TreeNode);
    end;
    xntText:
    begin
      TreeNode.Text := XmlNode.NodeValue;
      TreeNode.ImageIndex := 4;
    end;
    xntCDATASection:
    begin
      TreeNode.Text := XmlNode.NodeValue;
      TreeNode.ImageIndex := 5;
    end;
    xntComment:
    begin
      TreeNode.Text := XmlNode.NodeValue;
      TreeNode.ImageIndex := 6;
    end;
  end;
  TreeNode.SelectedIndex := TreeNode.ImageIndex;
  TreeNode.Data := XmlNode;
end;

procedure TXmlDDocument.AssignTo(Dest: TPersistent);
var
  TV: TTreeView;
  TN: TTreeNodes;
  TreeNode: TTreeNode;

  procedure AddChildNodes(ParXmlNode: TXmlDNode;
      ParTreeNode: TTreeNode);
  var
    XmlNode:  TXmlDNode;
    TreeNode: TTreeNode;
  begin
    XmlNode := ParXmlNode.FirstChild;
    while (XmlNode <> nil) do
    begin
      TreeNode := TN.AddChild(ParTreeNode, '');
      AssignNodeToTreeNode(XmlNode, TreeNode);
      AddChildNodes(XmlNode, TreeNode);
      XmlNode := XmlNode.NextSibling;
    end;
  end;

begin
  if Dest is TTreeNodes then
  begin
    TN := TTreeNodes(Dest);
    TV := TTreeView(TN.Owner);
    TV.SortType := stNone;
    TV.ReadOnly := True;
    if TV.Images = nil then
      TV.Images := TCustomImageList.Create(TV);
    TV.Images.Clear;
    TV.Images.GetResource(rtBitmap,
        'XMLTREEVIEWNODES', 0, [], 0);
    TV.Images.BkColor := clBlack;
    TN.BeginUpdate;
    TreeNode := TN.AddChild(nil, '');
    AssignNodeToTreeNode(Self, TreeNode);
    AddChildNodes(Self, TreeNode);
    TN.EndUpdate;
  end
  else
    inherited AssignTo(Dest);
end;

procedure TXmlDDocument.Clear;
var
  Node: TXmlDNode;
  NextNode: TXmlDNode;
begin
  Node := FFirstChild;
  while (Node <> nil) do
  begin
    NextNode := Node.FNextSibling;
    Node.Free;
    Node := NextNode;
  end;
  FFirstChild := nil;
  FLastChild := nil;
  FDocumentElement := nil;
end;

function TXmlDDocument.CloneNode(RecurseChildren: Boolean): TXmlDNode;
var
  Clone: TXmlDDocument;
begin
  Clone := TXmlDDocument.Create;
  if RecurseChildren then
    Clone.CloneChildren(Self);
  Result := Clone;
end;

constructor TXmlDDocument.Create;
begin
  inherited Create;
  FNodeType := xntDocument;
  FAttrCharEntities := [ceQuot, ceAmp];
  FTextCharEntities := [ceLt, ceAmp];
end;

function TXmlDDocument.CreateCDATASection(
  const Text: String): TXmlDCDATASection;
begin
  Result := TXmlDCDATASection.Create;
  Result.NodeValue := Text;
end;

function TXmlDDocument.CreateComment(const Text: String): TXmlDComment;
begin
  Result := TXmlDComment.Create;
  Result.NodeValue := Text;
end;

function TXmlDDocument.CreateElement(
  const TagName: TXmlName): TXmlDElement;
begin
  Result := TXmlDElement.Create;
  Result.NodeName := TagName;
end;

function TXmlDDocument.CreateElement(
  const TagName: TXmlName; const Data: String): TXmlDElement;
begin
  Result := TXmlDElement.Create;
  Result.NodeName := TagName;
  if Data <> '' then
    Result.AppendChild(OwnerDocument.CreateTextNode(Data));
end;

function TXmlDDocument.CreateElement(const TagName: TXmlName;
  const Data: String; const AttrName: TXmlName;
  const AttrValue: String): TXmlDElement;
begin
  Result := TXmlDElement.Create;
  Result.NodeName := TagName;
  if AttrName <> '' then
    Result.FAttrList.Values[AttrName] := AttrValue;
  if Data <> '' then
    Result.AppendChild(OwnerDocument.CreateTextNode(Data));
end;

function TXmlDDocument.CreateElement(const TagName: TXmlName;
  const Data: String; const AttrNames: array of TXmlName;
  const AttrValues: array of String): TXmlDElement;
var
  I:  Integer;
begin
  if (Low(AttrNames) <> Low(AttrValues)) or
      (High(AttrNames) <> High(AttrValues)) then
    raise EXmlDError.Create('Invalid CreateElement call');
  Result := TXmlDElement.Create;
  Result.NodeName := TagName;
  for I := Low(AttrNames) to High(AttrNames) do
    if AttrNames[I] <> '' then
      Result.FAttrList.Values[AttrNames[I]] := AttrValues[I];
  if Data <> '' then
    Result.AppendChild(OwnerDocument.CreateTextNode(Data));
end;

function TXmlDDocument.CreateTextNode(const Text: String): TXmlDText;
begin
  Result := TXmlDText.Create;
  Result.NodeValue := Text;
end;

procedure TXmlDDocument.DecodePrologAttrs(S: String);
var
  I: Integer;
begin
  I := Pos(' ', S);
  while I > 0 do
  begin
    FAttrList.Add(StringReplace(
        Copy(S, 1, I - 1), '"', '', [rfReplaceAll]));
    S := TrimLeft(Copy(S, I + 1, $7FFF));
    I := Pos(' ', S);
  end;
  FAttrList.Add(StringReplace(S, '"', '', [rfReplaceAll]));
end;

procedure TXmlDDocument.InsertBefore(NewNode, ThisNode: TXmlDNode);
begin
  if NewNode.NodeType = xntElement then
  begin
    if FDocumentElement <> nil then
      raise EXmlDError.Create('Second document element add attempted');
    FDocumentElement := TXmlDElement(NewNode);
  end;
  inherited InsertBefore(NewNode, ThisNode);
end;

procedure TXmlDDocument.LoadAttributes(Node: TXmlDElement;
  DOMNode: IXMLDOMNode);
var
  I:  Integer;
  Attributes: IXMLDOMNamedNodeMap;
  Item: IXMLDOMNode;
begin
  Attributes := DOMNode.attributes;
  for I := 0 to (Attributes.length - 1) do
  begin
    Item := Attributes[I];
    Node.FAttrList[Item.nodeName] := Item.nodeValue;
  end;
end;

procedure TXmlDDocument.LoadChildNodes(ParNode: TXmlDNode;
  ParDOMNode: IXMLDOMNode);
var
  ChildDOMNode: IXMLDOMNode;
  NewNode:  TXmlDNode;
begin
  ChildDOMNode := ParDOMNode.firstChild;
  while ChildDOMNode <> nil do
  begin
    NewNode := nil;
    case ChildDOMNode.nodeType of
      NODE_ELEMENT:
      begin
        NewNode := CreateElement(ChildDOMNode.nodeName);
        LoadAttributes(TXmlDElement(NewNode), ChildDOMNode);
      end;
      NODE_TEXT:
        NewNode := CreateTextNode(ChildDOMNode.nodeValue);
      NODE_CDATA_SECTION:
        NewNode := CreateCDataSection(ChildDOMNode.nodeValue);
      NODE_PROCESSING_INSTRUCTION:
        DecodePrologAttrs(ChildDOMNode.nodeValue);
      NODE_COMMENT:
        NewNode := CreateComment(ChildDOMNode.nodeValue);
      NODE_DOCUMENT_TYPE:
        TXmlDDocument(ParNode).DocumentTypeDefinition :=
            ChildDOMNode.xml;
      else
        if not DiscardUnsupportedItems then
          raise EXmlDError('XML document contains unsupported ' +
              'node type of ' + ChildDOMNode.nodeTypeString);
    end;
    if (NewNode <> nil) and (ParNode <> nil) then
      ParNode.AppendChild(NewNode);
    LoadChildNodes(NewNode, ChildDOMNode);
    ChildDOMNode := ChildDOMNode.NextSibling;
  end;
end;

procedure TXmlDDocument.LoadFromDOMDocument(Doc: IXMLDOMDocument);
var
  Err:  IXMLDOMParseError;
begin
  Clear;
  Err := Doc.parseError;
  if Err.errorCode <> 0 then
    raise EXmlDParseError.Create(Err);
  NodeName := Doc.nodeName;
  LoadChildNodes(Self, Doc);
end;

procedure TXmlDDocument.LoadFromFile(const FileName: String;
  ValidateOnParse, DiscardUnsupportedItems: Boolean);
var
  Doc:  IXMLDOMDocument;
begin
  Doc := CoDOMDocument.Create;
  Doc.validateOnParse := ValidateOnParse;
  Self.DiscardUnsupportedItems := DiscardUnsupportedItems;
  Doc.load(FileName);
  LoadFromDOMDocument(Doc);
end;

procedure TXmlDDocument.LoadFromStream(Stream: TStream; ValidateOnParse,
  DiscardUnsupportedItems: Boolean);
var
  Doc:  IXMLDOMDocument;
  SS: TStringStream;
begin
  Doc := CoDOMDocument.Create;
  Doc.validateOnParse := ValidateOnParse;
  Self.DiscardUnsupportedItems := DiscardUnsupportedItems;
  if Stream is TStringStream then
    SS := TStringStream(Stream)
  else
  begin
    SS := TStringStream.Create('');
    SS.CopyFrom(Stream, Stream.Size);
  end;
  SS.Position := 0;
  Doc.loadXML(PChar(SS.DataString));
  LoadFromDOMDocument(Doc);
  if SS <> Stream then
    SS.Free
  else
    SS.Position := 0;
end;

function TXmlDDocument.RemoveChild(ThisNode: TXmlDNode): TXmlDNode;
begin
  if ThisNode = FDocumentElement then
    FDocumentElement := nil;
  Result := inherited RemoveChild(ThisNode);
end;

function TXmlDDocument.ReplaceChild(NewNode,
  OldNode: TXmlDNode): TXmlDNode;
begin
  if OldNode = FDocumentElement then
    FDocumentElement := nil;
  if NewNode.NodeType = xntElement then
    FDocumentElement := TXmlDElement(NewNode);
  Result := inherited ReplaceChild(NewNode, OldNode);
end;

procedure TXmlDDocument.SaveToFile(const FileName: String;
    FormattedForPrint: Boolean);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

procedure TXmlDDocument.SaveToStream(Stream: TStream;
    FormattedForPrint: Boolean = False);
begin
  WriteToStream(Stream, FormattedForPrint);
end;

procedure TXmlDDocument.WritePrologToStream(Stream: TStream);
var
  S:  String;
  AttrVal:  String;
begin
  S := '<?xml version=';
  AttrVal := FAttrList['version'];
  if AttrVal <> '' then
    AppendStr(S, '"' + AttrVal + '"')
  else
    AppendStr(S, '"1.0"');
  AttrVal := FAttrList['encoding'];
  if AttrVal <> '' then
    AppendStr(S, ' encoding=' + '"' + AttrVal + '"');
  AttrVal := FAttrList['standalone'];
  if AttrVal <> '' then
    AppendStr(S, ' standalone=' + '"' + AttrVal + '"');
  AppendStr(S, '?>');
  Stream.WriteBuffer(Pointer(S)^, Length(S));
end;

procedure TXmlDDocument.WriteToStream(Stream: TStream;
    FormattedForPrint: Boolean);
begin
  WritePrologToStream(Stream);
  if FormattedForPrint then
    WriteFormattedSuffix(Stream);
  if FDocumentTypeDefinition <> '' then
  begin
    Stream.WriteBuffer(Pointer(FDocumentTypeDefinition)^,
        Length(FDocumentTypeDefinition));
    if FormattedForPrint then
      WriteFormattedSuffix(Stream);
  end;
  WriteChildrenToStream(Stream, FormattedForPrint);
end;

{ TXmlDElement }

function TXmlDElement.CloneNode(RecurseChildren: Boolean): TXmlDNode;
var
  Clone:  TXmlDElement;
begin
  Clone := TXmlDElement.Create;
  Clone.FNodeName := FNodeName;
  Clone.FAttrList.Assign(FAttrList);
  if RecurseChildren then
    Clone.CloneChildren(Self);
  Result := Clone;
end;

constructor TXmlDElement.Create;
begin
  inherited Create;
  FNodeType := xntElement;
end;

function TXmlDElement.GetNodeName: TXmlName;
begin
  Result := FNodeName;
end;

procedure TXmlDElement.SetNodeName(const Value: TXmlName);
begin
  FNodeName := Value;
end;

procedure TXmlDElement.WriteToStream(Stream: TStream;
    FormattedForPrint: Boolean);
var
  S:  String;
  Formatted: Boolean;
begin
  Formatted := FormattedForPrint;
  if Formatted then
  begin
    if (FFirstChild <> nil) and (FFirstChild = FLastChild) and
        (FFirstChild.NodeType = xntText) and
        (Length(FFirstChild.NodeValue) < 48) then
      Formatted := False;
    WriteFormattedPrefix(Stream);
  end;
  S := '<' + FNodeName;
  Stream.WriteBuffer(Pointer(S)^, Length(S));
  if FAttrList.Count > 0 then
    FAttrList.WriteToStream(Stream);
  if FFirstChild <> nil then
  begin
    S := '>';
    Stream.WriteBuffer(Pointer(S)^, 1);
    if Formatted then
      WriteFormattedSuffix(Stream);
  end;
  if FFirstChild = nil then
    S := '/>'
  else
  begin
    WriteChildrenToStream(Stream, Formatted);
    if Formatted then
      WriteFormattedPrefix(Stream);
    S := '</' + FNodeName + '>';
  end;
  Stream.WriteBuffer(Pointer(S)^, Length(S));
  if FormattedForPrint then
    WriteFormattedSuffix(Stream);
end;

{ TXmlDText }

function TXmlDText.CloneNode(RecurseChildren: Boolean): TXmlDNode;
begin
  Result := TXmlDText.Create;
  Result.NodeValue := NodeValue;
end;

constructor TXmlDText.Create;
begin
  inherited Create;
  FNodeType := xntText;
end;

procedure TXmlDText.WriteToStream(Stream: TStream;
    FormattedForPrint: Boolean);
var
  S:  String;
  Skip: Boolean;
  D:  TXmlDDocument;
begin
  if FormattedForPrint then
    WriteFormattedPrefix(Stream);
  S := FValue;
  Skip := False;
  D := OwnerDocument;
  if Assigned(D.FOnOutputTextValue) then
    D.FOnOutputTextValue(Self, S, Skip);
  if (not Skip) and (D.FTextCharEntities <> []) then
    S := CharEntitiesReplace(S, D.FTextCharEntities);
  Stream.WriteBuffer(Pointer(S)^, Length(S));
  if FormattedForPrint then
    WriteFormattedSuffix(Stream);
end;

{ TXmlDComment }

function TXmlDComment.CloneNode(RecurseChildren: Boolean): TXmlDNode;
begin
  Result := TXmlDComment.Create;
  Result.NodeValue := NodeValue;
end;

constructor TXmlDComment.Create;
begin
  inherited Create;
  FNodeType := xntComment;
end;

procedure TXmlDComment.WriteToStream(Stream: TStream;
  FormattedForPrint: Boolean);
var
  S:  String;
begin
  if FormattedForPrint then
    WriteFormattedPrefix(Stream);
  S := '<!--' + FValue + '-->';
  Stream.WriteBuffer(Pointer(S)^, Length(S));
  if FormattedForPrint then
    WriteFormattedSuffix(Stream);
end;

{ TXmlCDATASection }

function TXmlDCDATASection.CloneNode(RecurseChildren: Boolean): TXmlDNode;
begin
  Result := TXmlDCDATASection.Create;
  Result.NodeValue := NodeValue;
end;

constructor TXmlDCDATASection.Create;
begin
  inherited Create;
  FNodeType := xntCDATASection;
end;

procedure TXmlDCDATASection.WriteToStream(Stream: TStream;
    FormattedForPrint: Boolean);
var
  S:  String;
begin
  if FormattedForPrint then
    WriteFormattedPrefix(Stream);
  S := '<![CDATA[' + FValue + ']]>';
  Stream.WriteBuffer(Pointer(S)^, Length(S));
  if FormattedForPrint then
    WriteFormattedSuffix(Stream);
end;

{ TXmlDAttrList }

function TXmlDAttrList.Add(const S: String): Integer;
begin
  Result := List.Add(S);
end;

procedure TXmlDAttrList.Assign(Source: TPersistent);
begin
  if Source is TXmlDAttrList then
    List.Assign(TXmlDAttrList(Source).List);
end;

procedure TXmlDAttrList.Clear;
begin
  List.Clear;
end;

constructor TXmlDAttrList.Create;
begin
  inherited Create;
  List := TStringList.Create;
end;

destructor TXmlDAttrList.Destroy;
begin
  List.Free;
  inherited Destroy;
end;

function TXmlDAttrList.GetCount: Integer;
begin
  Result := List.Count;
end;

function TXmlDAttrList.GetNames(Index: Integer): TXmlName;
begin
  Result := List.Names[Index];
end;

function TXmlDAttrList.GetValues(const Name: TXmlName): String;
begin
  Result := List.Values[Name];
end;

procedure TXmlDAttrList.SetValues(const Name: TXmlName;
  const Value: String);
begin
  List.Values[Name] := Value;
end;

procedure TXmlDAttrList.WriteToStream(Stream: TStream);
var
  I:  Integer;
  J:  Integer;
  S:  String;
  Val: String;
  Skip: Boolean;
  D:  TXmlDDocument;
begin
  D := FOwnerNode.OwnerDocument;
  for I := 0 to (List.Count - 1) do
  begin
    S := List[I];
    J := Pos('=', S);
    Val := Copy(S, J + 1, $7FFF);
    Skip := False;
    if Assigned(D.FOnOutputAttrValue) then
      D.FOnOutputAttrValue(Self, Val, Skip);
    if (not Skip) and (D.FAttrCharEntities <> []) then
      Val := CharEntitiesReplace(Val, D.FAttrCharEntities);
    S := ' ' + Copy(S, 1, J) + '"' + Val + '"';
    Stream.WriteBuffer(Pointer(S)^, Length(S));
  end;
end;

end.