Merged revisions 11217,11389-11390,11637,11751,11755,11759,11788,11869 via svnmerge from

svn+ssh://[email protected]/FPC/svn/fpc/trunk

........
  r11217 | michael | 2008-06-11 07:40:49 +0200 (Wed, 11 Jun 2008) | 24 lines
  
  * Patch from Sergei Gorelkin to improve DOM compliance:
  dom.pp:
  * Document.OwnerDocument returns nil.
  * Document.TextContent returns empty string and setting it does nothing.
  * Fixed EntityReference, it now gets its children upon creation and is
    correctly imported between documents.
  + Node.IsSupported()
  * DOM feature name comparison is done case-insensitive.
  * Reworked Node.AppendChild/Node.InsertBefore. Duplicate functionality
    removed. Resolves remaining issues with hierarchy/ownership checks
    (except for Document nodes which is a different story altogether).
    The same code is now executed for nodes attached to a Fragment as
    well as for regular nodes.
  + Text.SplitText checks for valid ParentNode.
  
  xmlread.pp:
  + Implemented TDOMParser.ParseWithContext (except the case of replacing
    the whole document)
  * Fixed AV when calling ParseXXX methods with input source that could
    not be resolved.
  * Completely ignore comments in external DTD subset, it fixes a couple
    of DOM tests and has no effect on XML testsuite.
........
  r11389 | michael | 2008-07-17 16:55:07 +0200 (Thu, 17 Jul 2008) | 1 line
  
  * Patch from Sergei Gorelkin: * Makes TDOMParser.ParseURI throw EXMLReadError when URI is not resolvable (consistent with the Parse method).
........
  r11390 | michael | 2008-07-17 16:57:31 +0200 (Thu, 17 Jul 2008) | 11 lines
  
  * Initial testsuite from Sergei Gorelkin
      * testgen.pp - an utility to convert w3.org tests from XML format
        into fpcunit-compatible Pascal source. The official testsuite uses
        xslt for conversion, but, since there is no xslt for Pascal, and no
        xslt support in FCL yet, I wrote an utility.
      * api.xml    - API 'database', needed by testgen.
      * domunit.pp - an fpcunit extension, provides DOM-specific runtime
        support.
      * README_DOM - provides some instructions about putting it all together.
........
  r11637 | michael | 2008-08-23 13:34:47 +0200 (Sat, 23 Aug 2008) | 1 line
  
  * Patch from Sergei Gorelkin to handle unicode
........
  r11751 | marco | 2008-09-12 18:59:56 +0200 (Fri, 12 Sep 2008) | 2 lines
  
   * committed fix for unaligned access from id 12079
........
  r11755 | florian | 2008-09-13 10:42:35 +0200 (Sat, 13 Sep 2008) | 1 line
  
  * use unaligned instead some hacking :)
........
  r11759 | marco | 2008-09-13 11:54:13 +0200 (Sat, 13 Sep 2008) | 2 lines
  
   * more unaligned fixes for xmlread. Mantis 12137
........
  r11788 | joost | 2008-09-15 10:17:35 +0200 (Mon, 15 Sep 2008) | 1 line
  
   * Removed unnessesary var-keyword in declaration of ReadXMLFile (Fixes compilation)
........
  r11869 | michael | 2008-10-08 20:06:52 +0200 (Wed, 08 Oct 2008) | 49 lines
  
  * Large patch from Sergei Gorelkin:
    xmlutils.pp, names.inc:
      * exclude colon from the NameChar bitmap and handle it in code.
  
    dom.pp:
      + TDOMText.IsElementContentWhitespace now implemented completely.
      * Attributes created by TDOMElement.SetAttribute get their
       OwnerElement property assigned properly
      * Attribute replaced by TDOMNamedNodeMap.SetNamedItem get their
       OwnerElement reset to nil
      * TDOMElement.SetAttributeNode does not destroy the attribute when it
       is being replaced by itself
      * Most node boolean properties collected into a single FFlags field
       to reduce memory requirements.
  
    xmlread.pp:
      + Syntax-level support of namespaces: handle colons in names, check
       correct qualified name syntax, prohibit colons in entity/notation/PI
       names and ID/IDREF attribute values (all this only happens when
       Options.Namespaces is set to True - not by default).
      * Reaching end of input while parsing the Ignore Section is a fatal
       error because parameter entities are not recognized there.
      * Reaching end of input while parsing entity value literal that was
       started in a parameter entity aborts immediately instead of hopelessly
       scanning the whole document up to its end.
      * Fixed parsing duplicate Element declarations. The content models of
       subsequent declarations are now discarded as they should - not
       appended to the existing model.
      * Fixed parsing duplicate Attlist declarations. In addition to dropping
       the attribute declaration itself, do not modify the corresponding
       element declaration and suppress 'Duplicate ID attribute' and
       'Duplicate NOTATION attribute' validation errors.
      * Fixed error position in cases when attribute value lacks the closing
       quote.
      * Some refactoring in order to reduce number of WideString vars and code
       size (some SkipX and ExpectX merged into SkipX(required: Boolean)).
      * TXMLCharSource.FLocation record replaced by single integer FLineNo
       because LinePosition is always calculated.
      * TXMLCharSource.FCursor replaced by local var.
      * TXMLReader.NameIs changed to a more general BufEquals(), it eliminates
       TXMLReader.GetString and some WideString variables.
  
    tests/xmlts.pp:
      * Ignored tests do not change suite conformance state.
  
    tests/testgen.pp
      * Added a forgotten semicolon.
........

git-svn-id: branches/fixes_2_2@11921 -

.gitattributes

@@ -1527,7 +1527,11 @@ packages/fcl-xml/src/xmlutils.pp svneol=native#text/plain
 packages/fcl-xml/src/xmlwrite.pp svneol=native#text/plain
 packages/fcl-xml/src/xpath.pp svneol=native#text/plain
 packages/fcl-xml/tests/README svneol=native#text/plain
+packages/fcl-xml/tests/README_DOM svneol=native#text/plain
+packages/fcl-xml/tests/api.xml svneol=native#text/plain
+packages/fcl-xml/tests/domunit.pp svneol=native#text/plain
 packages/fcl-xml/tests/template.xml svneol=native#text/plain
+packages/fcl-xml/tests/testgen.pp svneol=native#text/plain
 packages/fcl-xml/tests/xmlts.pp svneol=native#text/plain
 packages/fftw/Makefile svneol=native#text/plain
 packages/fftw/Makefile.fpc svneol=native#text/plain

packages/fcl-xml/src/dom.pp

@@ -191,8 +191,17 @@ type
   accessible via fields using specialized properties of descendant classes,
   e.g. TDOMElement.TagName, TDOMCharacterData.Data etc.}
 
+  TNodeFlagEnum = (
+    nfReadonly,
+    nfRecycled,
+    nfIgnorableWS,
+    nfSpecified
+  );
+  TNodeFlags = set of TNodeFlagEnum;
+
   TDOMNode = class
   protected
+    FFlags: TNodeFlags;
     FParentNode: TDOMNode;
     FPreviousSibling, FNextSibling: TDOMNode;
     FOwnerDocument: TDOMDocument;
@@ -211,6 +220,7 @@ type
     function GetNamespaceURI: DOMString; virtual;
     function GetPrefix: DOMString; virtual;
     procedure SetPrefix(const Value: DOMString); virtual;
+    function GetOwnerDocument: TDOMDocument; virtual;
   public
     constructor Create(AOwner: TDOMDocument);
     destructor Destroy; override;
@@ -228,21 +238,18 @@ type
     property PreviousSibling: TDOMNode read FPreviousSibling;
     property NextSibling: TDOMNode read FNextSibling;
     property Attributes: TDOMNamedNodeMap read GetAttributes;
-    // DOM 2: is now nil for documents and unused DocTypes
-    property OwnerDocument: TDOMDocument read FOwnerDocument;
+    property OwnerDocument: TDOMDocument read GetOwnerDocument;
 
     function InsertBefore(NewChild, RefChild: TDOMNode): TDOMNode; virtual;
     function ReplaceChild(NewChild, OldChild: TDOMNode): TDOMNode; virtual;
     function DetachChild(OldChild: TDOMNode): TDOMNode; virtual;
     function RemoveChild(OldChild: TDOMNode): TDOMNode;
-    function AppendChild(NewChild: TDOMNode): TDOMNode; virtual;
+    function AppendChild(NewChild: TDOMNode): TDOMNode;
     function HasChildNodes: Boolean; virtual;
     function CloneNode(deep: Boolean): TDOMNode; overload;
 
     // DOM level 2
-    (*
-    function Supports(const Feature, Version: DOMString): Boolean;
-    *)
+    function IsSupported(const Feature, Version: DOMString): Boolean;
     function HasAttributes: Boolean; virtual;
     procedure Normalize; virtual;
 
@@ -279,7 +286,6 @@ type
     function InsertBefore(NewChild, RefChild: TDOMNode): TDOMNode; override;
     function ReplaceChild(NewChild, OldChild: TDOMNode): TDOMNode; override;
     function DetachChild(OldChild: TDOMNode): TDOMNode; override;
-    function AppendChild(NewChild: TDOMNode): TDOMNode; override;
     function HasChildNodes: Boolean; override;
     function FindNode(const ANodeName: DOMString): TDOMNode; override;
   end;
@@ -302,6 +308,7 @@ type
     destructor Destroy; override;
     property Item[index: LongWord]: TDOMNode read GetItem; default;
     property Count: LongWord read GetCount;
+    property Length: LongWord read GetCount;
   end;
 
   { an extension to DOM interface, used to build recursive lists of elements }
@@ -362,7 +369,7 @@ type
     function GetNodeValue: DOMString; override;
     procedure SetNodeValue(const AValue: DOMString); override;
   public
-    property Data: DOMString read FNodeValue write FNodeValue;
+    property Data: DOMString read FNodeValue write SetNodeValue;
     property Length: LongWord read GetLength;
     function SubstringData(offset, count: LongWord): DOMString;
     procedure AppendData(const arg: DOMString);
@@ -416,6 +423,9 @@ type
     function GetDocType: TDOMDocumentType;
     function GetNodeType: Integer; override;
     function GetNodeName: DOMString; override;
+    function GetTextContent: DOMString; override;
+    function GetOwnerDocument: TDOMDocument; override;
+    procedure SetTextContent(const value: DOMString); override;
     function IndexOfNS(const nsURI: DOMString): Integer;
     function FindID(const aID: DOMString; out Index: LongWord): Boolean;
     procedure ClearIDList;
@@ -429,7 +439,7 @@ type
     function CreateElementBuf(Buf: DOMPChar; Length: Integer): TDOMElement;
     function CreateDocumentFragment: TDOMDocumentFragment;
     function CreateTextNode(const data: DOMString): TDOMText;
-    function CreateTextNodeBuf(Buf: DOMPChar; Length: Integer): TDOMText;
+    function CreateTextNodeBuf(Buf: DOMPChar; Length: Integer; IgnWS: Boolean): TDOMText;
     function CreateComment(const data: DOMString): TDOMComment;
     function CreateCommentBuf(Buf: DOMPChar; Length: Integer): TDOMComment;
     function CreateCDATASection(const data: DOMString): TDOMCDATASection;
@@ -491,18 +501,18 @@ type
   protected
     FName: DOMString;
     FOwnerElement: TDOMElement;
-    FSpecified: Boolean;
     // TODO: following 2 - replace with a link to AttDecl ??    
     FDeclared: Boolean;
     FDataType: TAttrDataType;
     function  GetNodeValue: DOMString; override;
     function GetNodeType: Integer; override;
     function GetNodeName: DOMString; override;
+    function GetSpecified: Boolean;
     procedure SetNodeValue(const AValue: DOMString); override;
   public
     function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; override;
     property Name: DOMString read FName;
-    property Specified: Boolean read FSpecified;
+    property Specified: Boolean read GetSpecified;
     property Value: DOMString read GetNodeValue write SetNodeValue;
     property OwnerElement: TDOMElement read FOwnerElement;
     // extensions
@@ -560,16 +570,13 @@ type
 
   TDOMText = class(TDOMCharacterData)
   protected
-    // set by parser if text contains only literal whitespace (i.e. not coming from CharRefs) 
-    FMayBeIgnorable: Boolean;
     function GetNodeType: Integer; override;
     function GetNodeName: DOMString; override;
     procedure SetNodeValue(const aValue: DOMString); override;
   public
     function  CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; override;
     function SplitText(offset: LongWord): TDOMText;
-    // Extension
-    property MayBeIgnorable: Boolean read FMayBeIgnorable write FMayBeIgnorable;
+    function IsElementContentWhitespace: Boolean;
   end;
 
 
@@ -695,7 +702,7 @@ type
   public
     function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; override;
     property Target: DOMString read FTarget;
-    property Data: DOMString read FNodeValue write FNodeValue;
+    property Data: DOMString read FNodeValue write SetNodeValue;
   end;
 
 
@@ -877,8 +884,7 @@ end;
 
 function TDOMNode.AppendChild(NewChild: TDOMNode): TDOMNode;
 begin
-  raise EDOMHierarchyRequest.Create('Node.AppendChild');
-  Result:=nil;
+  Result := InsertBefore(NewChild, nil);
 end;
 
 function TDOMNode.HasChildNodes: Boolean;
@@ -909,6 +915,11 @@ begin
   Result := FOwnerDocument.FRevision;
 end;
 
+function TDOMNode.IsSupported(const Feature, Version: DOMString): Boolean;
+begin
+  Result := FOwnerDocument.Impl.HasFeature(Feature, Version);
+end;
+
 function TDOMNode.HasAttributes: Boolean;
 begin
   Result := False;
@@ -932,7 +943,8 @@ begin
         if Assigned(Txt) then
         begin
           Txt.AppendData(TDOMText(Child).Data);
-          Txt.FMayBeIgnorable := Txt.FMayBeIgnorable and TDOMText(Child).FMayBeIgnorable;
+          // TODO: maybe should be smarter
+          Exclude(Txt.FFlags, nfIgnorableWS);
         end
         else
         begin
@@ -960,7 +972,7 @@ end;
 
 procedure TDOMNode.SetTextContent(const AValue: DOMString);
 begin
-  NodeValue := AValue;
+  SetNodeValue(AValue);
 end;
 
 function TDOMNode.GetNamespaceURI: DOMString;
@@ -983,6 +995,11 @@ begin
   // do nothing, override for Elements and Attributes
 end;
 
+function TDOMNode.GetOwnerDocument: TDOMDocument;
+begin
+  Result := FOwnerDocument;
+end;
+
 function CompareDOMStrings(const s1, s2: DOMPChar; l1, l2: integer): integer;
 var i: integer;
 begin
@@ -1063,20 +1080,19 @@ var
   NewChildType: Integer;
 begin
   Result := NewChild;
+  NewChildType := NewChild.NodeType;
 
-  if not Assigned(RefChild) then
+  if NewChild.FOwnerDocument <> FOwnerDocument then
   begin
-    AppendChild(NewChild);
-    exit;
+    if (NewChildType <> DOCUMENT_TYPE_NODE) or
+    (NewChild.FOwnerDocument <> nil) then
+      raise EDOMWrongDocument.Create('NodeWC.InsertBefore');
   end;
 
-  if NewChild.FOwnerDocument <> FOwnerDocument then
-    raise EDOMWrongDocument.Create('NodeWC.InsertBefore');
-
-  if RefChild.ParentNode <> Self then
+  if Assigned(RefChild) and (RefChild.ParentNode <> Self) then
     raise EDOMNotFound.Create('NodeWC.InsertBefore');
 
-  NewChildType := NewChild.NodeType;
+  // TODO: skip checking Fragments as well? (Fragment itself cannot be in the tree)  
   if not (NewChildType in [TEXT_NODE, CDATA_SECTION_NODE, COMMENT_NODE, PROCESSING_INSTRUCTION_NODE]) and (NewChild.FirstChild <> nil) then
   begin
     Tmp := Self;
@@ -1087,45 +1103,26 @@ begin
       Tmp := Tmp.ParentNode;
     end;
   end;
+  if NewChild = RefChild then    // inserting node before itself is a no-op
+    Exit;
 
   Inc(FOwnerDocument.FRevision); // invalidate nodelists
 
-  // DONE: Implemented InsertBefore for DocumentFragments (except ChildNodeTree)
   if NewChildType = DOCUMENT_FRAGMENT_NODE then
   begin
-    // Is fragment empty?
     Tmp := NewChild.FirstChild;
-    if not Assigned(Tmp) then
-      Exit;
-    // reparent nodes
-    while Assigned(Tmp) do
-    begin
-      Tmp.FParentNode := Self;
-      Tmp := Tmp.NextSibling;
-    end;
-
-    // won't get here if RefChild = nil...
-    if (RefChild = nil) or (RefChild.FPreviousSibling = nil) then
-    begin  // insert at the beginning  <- AppendChild ??? ->
-      // no, AppendChild will insert after RefChild and we need it before
-      if Assigned(FFirstChild) then
-        FFirstChild.FPreviousSibling := NewChild.LastChild;
-      NewChild.LastChild.FNextSibling := FirstChild;
-      if not Assigned(FLastChild) then
-        FLastChild := NewChild.LastChild;
-      FFirstChild := NewChild.FirstChild;
-    end
-    else  // insert to the middle
+    if Assigned(Tmp) then
     begin
-      NewChild.LastChild.FNextSibling := RefChild;
-      NewChild.FirstChild.FPreviousSibling := RefChild.FPreviousSibling;
-      RefChild.FPreviousSibling.FNextSibling := NewChild.FirstChild;
-      RefChild.FPreviousSibling := NewChild.LastChild;
+      while Assigned(Tmp) do
+      begin
+        if not (Tmp.NodeType in ValidChildren[NodeType]) then
+          raise EDOMHierarchyRequest.Create('NodeWC.InsertBefore');
+        Tmp := Tmp.NextSibling;
+      end;
+    
+      while Assigned(TDOMDocumentFragment(NewChild).FFirstChild) do
+        InsertBefore(TDOMDocumentFragment(NewChild).FFirstChild, RefChild);
     end;
-    // finally, detach nodes from the fragment
-    TDOMDocumentFragment(NewChild).FFirstChild := nil;
-    TDOMDocumentFragment(NewChild).FLastChild := nil;
-    // TODO: ChildNodeTree...
     Exit;
   end;
 
@@ -1136,15 +1133,27 @@ begin
     NewChild.FParentNode.DetachChild(NewChild);
 
   NewChild.FNextSibling := RefChild;
-  if RefChild = FFirstChild then
-    FFirstChild := NewChild
-  else
+  if RefChild = nil then  // append to the end
+  begin
+    if Assigned(FFirstChild) then
+    begin
+      FLastChild.FNextSibling := NewChild;
+      NewChild.FPreviousSibling := FLastChild;
+    end else
+      FFirstChild := NewChild;
+    FLastChild := NewChild;
+  end
+  else   // insert before RefChild
   begin
-    RefChild.FPreviousSibling.FNextSibling := NewChild;
-    NewChild.FPreviousSibling := RefChild.FPreviousSibling;
+    if RefChild = FFirstChild then
+      FFirstChild := NewChild
+    else
+    begin
+      RefChild.FPreviousSibling.FNextSibling := NewChild;
+      NewChild.FPreviousSibling := RefChild.FPreviousSibling;
+    end;
+    RefChild.FPreviousSibling := NewChild;
   end;
-
-  RefChild.FPreviousSibling := NewChild;
   NewChild.FParentNode := Self;
   AddToChildNodeTree(NewChild);
 end;
@@ -1185,76 +1194,6 @@ begin
   Result := OldChild;
 end;
 
-function TDOMNode_WithChildren.AppendChild(NewChild: TDOMNode): TDOMNode;
-var
-  Tmp: TDOMNode;
-  NewChildType: Integer;
-begin
-  if NewChild.FOwnerDocument <> FOwnerDocument then
-    raise EDOMWrongDocument.Create('NodeWC.AppendChild');
-
-  // Don't walk the tree if NewChild apriori cannot be our parent.
-  // This saves a lot of CPU cache misses.
-  NewChildType := NewChild.NodeType;
-  if not (NewChildType in [TEXT_NODE, CDATA_SECTION_NODE, COMMENT_NODE, PROCESSING_INSTRUCTION_NODE]) and (NewChild.FirstChild <> nil) then
-  begin
-    Tmp := Self;
-    while Assigned(Tmp) do
-    begin
-      if Tmp = NewChild then
-        raise EDOMHierarchyRequest.Create('NodeWC.AppendChild (cycle in tree)');
-      Tmp := Tmp.ParentNode;
-    end;
-  end;
-  Inc(FOwnerDocument.FRevision); // invalidate nodelists
-
-  // DONE: supported AppendChild for DocumentFragments (except ChildNodeTree)
-  if NewChildType = DOCUMENT_FRAGMENT_NODE then
-  begin
-    Tmp := NewChild.FirstChild;
-    // Is fragment empty?
-    if Assigned(Tmp) then
-    begin
-      // reparent nodes
-      while Assigned(Tmp) do
-      begin
-        Tmp.FParentNode := Self;
-        Tmp := Tmp.NextSibling;
-      end;
-
-      if Assigned(FLastChild) then
-        FLastChild.FNextSibling := NewChild.FirstChild;
-      NewChild.FirstChild.FPreviousSibling := LastChild;
-      if not Assigned(FFirstChild) then
-        FFirstChild := NewChild.FirstChild;
-      FLastChild := NewChild.LastChild;
-      // detach nodes from fragment
-      TDOMDocumentFragment(NewChild).FFirstChild := nil;
-      TDOMDocumentFragment(NewChild).FLastChild := nil;
-      // TODO: ChildNodeTree...
-    end;
-  end
-  else
-  begin
-    if not (NewChildType in ValidChildren[NodeType]) then
-      raise EDOMHierarchyRequest.Create('NodeWC.AppendChild');
-
-    if Assigned(NewChild.FParentNode) then
-      NewChild.FParentNode.DetachChild(NewChild);
-
-    if Assigned(FFirstChild) then
-    begin
-      FLastChild.FNextSibling := NewChild;
-      NewChild.FPreviousSibling := FLastChild;
-    end else
-      FFirstChild := NewChild;
-    FLastChild := NewChild;
-    NewChild.FParentNode := Self;
-    AddToChildNodeTree(NewChild);
-  end;
-  Result := NewChild;
-end;
-
 function TDOMNode_WithChildren.HasChildNodes: Boolean;
 begin
   Result := Assigned(FFirstChild);
@@ -1312,11 +1251,15 @@ begin
   Result := '';
   child := FFirstChild;
   // TODO: probably very slow, optimization needed
-  // TODO: must ignore whitespace nodes
   while Assigned(child) do
   begin
-    if not (child.NodeType in [COMMENT_NODE, PROCESSING_INSTRUCTION_NODE]) then
+    case child.NodeType of
+      TEXT_NODE: if not (nfIgnorableWS in child.FFlags) then
+        Result := Result + TDOMText(child).Data;
+      COMMENT_NODE, PROCESSING_INSTRUCTION_NODE: ; // ignored
+    else
       Result := Result + child.TextContent;
+    end;
     child := child.NextSibling;
   end;
 end;
@@ -1557,6 +1500,8 @@ begin
   if Exists then
   begin
     Result := TDOMNode(FList.List^[i]);
+    if FNodeType = ATTRIBUTE_NODE then
+      TDOMAttr(Result).FOwnerElement := nil;
     FList.List^[i] := arg;
     exit;
   end;
@@ -1625,7 +1570,7 @@ end;
 
 function TDOMCharacterData.SubstringData(offset, count: LongWord): DOMString;
 begin
-  if (offset > Length) then
+  if offset > Length then
     raise EDOMIndexSize.Create('CharacterData.SubstringData');
   Result := Copy(FNodeValue, offset + 1, count);
 end;
@@ -1637,20 +1582,16 @@ end;
 
 procedure TDOMCharacterData.InsertData(offset: LongWord; const arg: DOMString);
 begin
-  if (offset > Length) then
+  if offset > Length then
     raise EDOMIndexSize.Create('CharacterData.InsertData');
-  // TODO: use System.Insert?
-  FNodeValue := Copy(FNodeValue, 1, offset) + arg +
-    Copy(FNodeValue, offset + 1, Length);
+  Insert(arg, FNodeValue, offset+1);
 end;
 
 procedure TDOMCharacterData.DeleteData(offset, count: LongWord);
 begin
-  if (offset > Length) then
+  if offset > Length then
     raise EDOMIndexSize.Create('CharacterData.DeleteData');
-  // TODO: use System.Delete?
-  FNodeValue := Copy(FNodeValue, 1, offset) +
-    Copy(FNodeValue, offset + count + 1, Length);
+  Delete(FNodeValue, offset+1, count);
 end;
 
 procedure TDOMCharacterData.ReplaceData(offset, count: LongWord; const arg: DOMString);
@@ -1687,17 +1628,11 @@ end;
 
 function TDOMImplementation.HasFeature(const feature, version: DOMString):
   Boolean;
+var
+  s: string;
 begin
-  // very basic
-  if (feature = 'XML') then
-  begin
-    if (version = '') or (version = '1.0') then
-      Result := True
-    else
-      Result := False;
-  end
-  else
-    Result := False;
+  s := feature;   // force Ansi, features do not contain non-ASCII chars
+  Result := SameText(s, 'XML') and ((version = '') or (version = '1.0'));
 end;
 
 function TDOMImplementation.CreateDocumentType(const QualifiedName, PublicID,
@@ -1707,12 +1642,9 @@ begin
   Result := TDOMDocumentType.Create(nil);
   Result.FName := QualifiedName;
 
-  // cannot have PublicID without SystemID
-  if SystemID <> '' then
-  begin
-    Result.FPublicID := PublicID;
-    Result.FSystemID := SystemID;
-  end;
+  // DOM does not restrict PublicID without SystemID (unlike XML spec)
+  Result.FPublicID := PublicID;
+  Result.FSystemID := SystemID;
 end;
 
 function TDOMImplementation.CreateDocument(const NamespaceURI,
@@ -1845,6 +1777,21 @@ begin
   Result := '#document';
 end;
 
+function TDOMDocument.GetTextContent: DOMString;
+begin
+  Result := '';
+end;
+
+procedure TDOMDocument.SetTextContent(const value: DOMString);
+begin
+  // Document ignores setting TextContent
+end;
+
+function TDOMDocument.GetOwnerDocument: TDOMDocument;
+begin
+  Result := nil;
+end;
+
 function TDOMDocument.GetDocumentElement: TDOMElement;
 var
   node: TDOMNode;
@@ -1892,10 +1839,12 @@ begin
   Result.FNodeValue := data;
 end;
 
-function TDOMDocument.CreateTextNodeBuf(Buf: DOMPChar; Length: Integer): TDOMText;
+function TDOMDocument.CreateTextNodeBuf(Buf: DOMPChar; Length: Integer; IgnWS: Boolean): TDOMText;
 begin
   Result := TDOMText.Create(Self);
   SetString(Result.FNodeValue, Buf, Length);
+  if IgnWS then
+    Include(Result.FFlags, nfIgnorableWS);
 end;
 
 
@@ -1931,13 +1880,14 @@ begin
     raise EDOMError.Create(INVALID_CHARACTER_ERR, 'DOMDocument.CreateAttribute');
   Result := TDOMAttr.Create(Self);
   Result.FName := name;
+  Include(Result.FFlags, nfSpecified);
 end;
 
 function TDOMDocument.CreateAttributeBuf(Buf: DOMPChar; Length: Integer): TDOMAttr;
 begin
   Result := TDOMAttr.Create(Self);
   SetString(Result.FName, Buf, Length);
-  Result.FSpecified := True;
+  Include(Result.FFlags, nfSpecified);
 end;
 
 function TDOMDocument.CreateEntityReference(const name: DOMString):
@@ -2015,12 +1965,21 @@ end;
 
 function TXMLDocument.CreateEntityReference(const name: DOMString):
   TDOMEntityReference;
+var
+  dType: TDOMDocumentType;
+  ent: TDOMEntity;
 begin
   if not IsXmlName(name, FXML11) then
     raise EDOMError.Create(INVALID_CHARACTER_ERR, 'XMLDocument.CreateEntityReference');
   Result := TDOMEntityReference.Create(Self);
   Result.FName := name;
-  // TODO: if entity is known, its child list must be cloned or so.
+  dType := DocType;
+  if Assigned(dType) then
+  begin
+    TDOMNode(ent) := dType.Entities.GetNamedItem(name);
+    if Assigned(ent) then
+      ent.CloneChildren(Result, Self);
+  end;
 end;
 
 procedure TXMLDocument.SetXMLVersion(const aValue: DOMString);
@@ -2047,7 +2006,6 @@ function TDOMAttr.CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode;
 begin
   // Cloned attribute is always specified and carries its children
   Result := ACloneOwner.CreateAttribute(FName);
-  TDOMAttr(Result).FSpecified := True;
   TDOMAttr(Result).FDataType := FDataType;
   // Declared = ?
   CloneChildren(Result, ACloneOwner);
@@ -2062,8 +2020,8 @@ end;
 
 procedure TDOMAttr.SetNodeValue(const AValue: DOMString);
 begin
-  FSpecified := True;
   SetTextContent(AValue);
+  Include(FFlags, nfSpecified);
 end;
 
 function TDOMAttr.CompareName(const AName: DOMString): Integer;
@@ -2071,6 +2029,11 @@ begin
   Result := CompareDOMStrings(DOMPChar(AName), DOMPChar(FName), Length(AName), Length(FName));
 end;
 
+function TDOMAttr.GetSpecified: Boolean;
+begin
+  Result := nfSpecified in FFlags;
+end;
+
 // -------------------------------------------------------
 //   Element
 // -------------------------------------------------------
@@ -2161,6 +2124,7 @@ begin
   else
   begin
     Attr := FOwnerDocument.CreateAttribute(name);
+    Attr.FOwnerElement := Self;
     FAttributes.FList.Insert(I, Attr);
   end;
   attr.NodeValue := value;
@@ -2197,7 +2161,6 @@ end;
 
 function TDOMElement.GetAttributeNode(const name: DOMString): TDOMAttr;
 begin
-  // DONE: delegated to TNamedNodeMap.GetNamedItem
   if Assigned(FAttributes) then
     Result := FAttributes.GetNamedItem(name) as TDOMAttr
   else
@@ -2217,8 +2180,11 @@ begin
   Result := Attributes.SetNamedItem(NewAttr) as TDOMAttr;
 
   // TODO -cConformance: here goes inconsistency with DOM 2 - same as in TDOMNode.RemoveChild
-  Result.Free;
-  Result := nil;
+  if Assigned(Result) and (Result <> NewAttr) then
+  begin
+    Result.Free;
+    Result := nil;
+  end;  
 end;
 
 function TDOMElement.SetAttributeNodeNS(NewAttr: TDOMAttr): TDOMAttr;
@@ -2226,8 +2192,11 @@ begin
   Result := Attributes.SetNamedItemNS(NewAttr) as TDOMAttr;
 
   // TODO -cConformance: here goes inconsistency with DOM 2 - same as in TDOMNode.RemoveChild
-  Result.Free;
-  Result := nil;
+  if Assigned(Result) and (Result <> NewAttr) then
+  begin
+    Result.Free;
+    Result := nil;
+  end;  
 end;
 
 
@@ -2291,15 +2260,14 @@ end;
 
 procedure TDOMText.SetNodeValue(const aValue: DOMString);
 begin
+  inherited SetNodeValue(aValue);
   // TODO: may analyze aValue, but this will slow things down...
-  FMayBeIgnorable := False;
-  FNodeValue := aValue;
+  Exclude(FFlags, nfIgnorableWS);
 end;
 
 function TDOMText.CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode;
 begin
   Result := ACloneOwner.CreateTextNode(FNodeValue);
-  TDOMText(Result).FMayBeIgnorable := FMayBeIgnorable;
 end;
 
 function TDOMText.SplitText(offset: LongWord): TDOMText;
@@ -2309,11 +2277,16 @@ begin
 
   Result := TDOMText.Create(FOwnerDocument);
   Result.FNodeValue := Copy(FNodeValue, offset + 1, Length);
-  Result.FMayBeIgnorable := FMayBeIgnorable;
+  Result.FFlags := FFlags * [nfIgnorableWS];
   FNodeValue := Copy(FNodeValue, 1, offset);
-  FParentNode.InsertBefore(Result, FNextSibling);
+  if Assigned(FParentNode) then
+    FParentNode.InsertBefore(Result, FNextSibling);
 end;
 
+function TDOMText.IsElementContentWhitespace: Boolean;
+begin
+  Result := nfIgnorableWS in FFlags;
+end;
 
 // -------------------------------------------------------
 //   Comment
@@ -2442,7 +2415,9 @@ begin
   TDOMEntity(Result).FName := FName;
   TDOMEntity(Result).FSystemID := FSystemID;
   TDOMEntity(Result).FPublicID := FPublicID;
-  TDOMEntity(Result).FNotationName := FNotationName;  
+  TDOMEntity(Result).FNotationName := FNotationName;
+  if deep then
+    CloneChildren(Result, aCloneOwner);
 end;
 
 // -------------------------------------------------------
@@ -2462,8 +2437,6 @@ end;
 function TDOMEntityReference.CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode;
 begin
   Result := ACloneOwner.CreateEntityReference(FName);
-  // TODO -cConformance: this is done in CreateEntityReference?
-  CloneChildren(Result, ACloneOwner);
 end;
 
 // -------------------------------------------------------

packages/fcl-xml/src/htmwrite.pp

@@ -28,9 +28,9 @@ procedure WriteHTMLFile(doc: TXMLDocument; const AFileName: String);
 procedure WriteHTMLFile(doc: TXMLDocument; var AFile: Text);
 procedure WriteHTMLFile(doc: TXMLDocument; AStream: TStream);
 
-procedure WriteHTML(Element: TDOMElement; const AFileName: String);
-procedure WriteHTML(Element: TDOMElement; var AFile: Text);
-procedure WriteHTML(Element: TDOMElement; AStream: TStream);
+procedure WriteHTML(Element: TDOMNode; const AFileName: String);
+procedure WriteHTML(Element: TDOMNode; var AFile: Text);
+procedure WriteHTML(Element: TDOMNode; AStream: TStream);
 
 
 // ===================================================================
@@ -39,91 +39,226 @@ implementation
 
 uses SysUtils, HTMLDefs;
 
-// -------------------------------------------------------------------
-//   Writers for the different node types
-// -------------------------------------------------------------------
+type
+  TSpecialCharCallback = procedure(c: WideChar) of object;
+
+  THTMLWriter = class(TObject)
+  private
+    FInsideTextNode: Boolean;
+    FBuffer: PChar;
+    FBufPos: PChar;
+    FCapacity: Integer;
+    FLineBreak: string;
+    procedure wrtChars(Src: PWideChar; Length: Integer);
+    procedure wrtStr(const ws: WideString); {$IFDEF HAS_INLINE} inline; {$ENDIF}
+    procedure wrtChr(c: WideChar); {$IFDEF HAS_INLINE} inline; {$ENDIF}
+    procedure wrtIndent; {$IFDEF HAS_INLINE} inline; {$ENDIF}
+    procedure wrtQuotedLiteral(const ws: WideString);
+    procedure ConvWrite(const s: WideString; const SpecialChars: TSetOfChar;
+      const SpecialCharCallback: TSpecialCharCallback);
+    procedure AttrSpecialCharCallback(c: WideChar);
+    procedure TextNodeSpecialCharCallback(c: WideChar);
+  protected
+    procedure Write(const Buffer; Count: Longint); virtual; abstract;
+    procedure WriteNode(Node: TDOMNode);
+    procedure VisitDocument(Node: TDOMNode);
+    procedure VisitElement(Node: TDOMNode);
+    procedure VisitText(Node: TDOMNode);
+    procedure VisitCDATA(Node: TDOMNode);
+    procedure VisitComment(Node: TDOMNode);
+    procedure VisitFragment(Node: TDOMNode);
+    procedure VisitAttribute(Node: TDOMNode);
+    procedure VisitEntityRef(Node: TDOMNode);
+    procedure VisitDocumentType(Node: TDOMNode);
+    procedure VisitPI(Node: TDOMNode);
+  public
+    constructor Create;
+    destructor Destroy; override;
+  end;
 
-procedure WriteElement(node: TDOMNode); forward;
-procedure WriteAttribute(node: TDOMNode); forward;
-procedure WriteText(node: TDOMNode); forward;
-procedure WriteCDATA(node: TDOMNode); forward;
-procedure WriteEntityRef(node: TDOMNode); forward;
-procedure WriteEntity(node: TDOMNode); forward;
-procedure WritePI(node: TDOMNode); forward;
-procedure WriteComment(node: TDOMNode); forward;
-procedure WriteDocument(node: TDOMNode); forward;
-procedure WriteDocumentType(node: TDOMNode); forward;
-procedure WriteDocumentFragment(node: TDOMNode); forward;
-procedure WriteNotation(node: TDOMNode); forward;
+  TTextHTMLWriter = Class(THTMLWriter)
+  Private
+    F : ^Text;
+  Protected
+    Procedure Write(Const Buffer; Count : Longint);override;
+  Public
+    constructor Create(var AFile: Text);
+  end;
 
+  TStreamHTMLWriter = Class(THTMLWriter)
+  Private
+    F : TStream;
+  Protected
+    Procedure Write(Const Buffer; Count : Longint);override;
+  Public
+    constructor Create(AStream: TStream);
+  end;
 
-type
-  TWriteNodeProc = procedure(node: TDOMNode);
+{ ---------------------------------------------------------------------
+    TTextHTMLWriter
+  ---------------------------------------------------------------------}
 
-const
-  WriteProcs: array[ELEMENT_NODE..NOTATION_NODE] of TWriteNodeProc =
-    (@WriteElement, @WriteAttribute, @WriteText, @WriteCDATA, @WriteEntityRef,
-     @WriteEntity, @WritePI, @WriteComment, @WriteDocument, @WriteDocumentType,
-     @WriteDocumentFragment, @WriteNotation);
 
-procedure WriteNode(node: TDOMNode);
+constructor TTextHTMLWriter.Create(var AFile: Text);
 begin
-  WriteProcs[node.NodeType](node);
+  inherited Create;
+  f := @AFile;
 end;
 
+procedure TTextHTMLWriter.Write(const Buffer; Count: Longint);
+var
+  s: string;
+begin
+  if Count>0 then
+  begin
+    SetString(s, PChar(@Buffer), Count);
+    system.Write(f^, s);
+  end;
+end;
 
-// -------------------------------------------------------------------
-//   Text file and TStream support
-// -------------------------------------------------------------------
+{ ---------------------------------------------------------------------
+    TStreamHTMLWriter
+  ---------------------------------------------------------------------}
 
-type
-  TOutputProc = procedure(s: String);
+constructor TStreamHTMLWriter.Create(AStream: TStream);
+begin
+  inherited Create;
+  F := AStream;
+end;
+
+
+procedure TStreamHTMLWriter.Write(const Buffer; Count: Longint);
+begin
+  if Count > 0 then
+    F.Write(Buffer, Count);
+end;
 
-var
-  f: ^Text;
-  stream: TStream;
-  wrt, wrtln: TOutputProc;
-  InsideTextNode: Boolean;
 
+{ ---------------------------------------------------------------------
+    THTMLWriter
+  ---------------------------------------------------------------------}
 
-procedure Text_Write(s: String);
+constructor THTMLWriter.Create;
+var
+  I: Integer;
 begin
-  Write(f^, s);
+  inherited Create;
+  // some overhead - always be able to write at least one extra UCS4
+  FBuffer := AllocMem(512+32);
+  FBufPos := FBuffer;
+  FCapacity := 512;
+  // Later on, this may be put under user control
+  // for now, take OS setting
+  FLineBreak := sLineBreak;
 end;
 
-procedure Text_WriteLn(s: String);
+destructor THTMLWriter.Destroy;
 begin
-  WriteLn(f^, s);
+  if FBufPos > FBuffer then
+    write(FBuffer^, FBufPos-FBuffer);
+
+  FreeMem(FBuffer);
+  inherited Destroy;
 end;
 
-procedure Stream_Write(s: String);
+procedure THTMLWriter.wrtChars(Src: PWideChar; Length: Integer);
+var
+  pb: PChar;
+  wc: Cardinal;
+  SrcEnd: PWideChar;
 begin
-  if Length(s) > 0 then
-    stream.Write(s[1], Length(s));
+  pb := FBufPos;
+  SrcEnd := Src + Length;
+  while Src < SrcEnd do
+  begin
+    if pb >= @FBuffer[FCapacity] then
+    begin
+      write(FBuffer^, FCapacity);
+      Dec(pb, FCapacity);
+      if pb > FBuffer then
+        Move(FBuffer[FCapacity], FBuffer^, pb - FBuffer);
+    end;
+
+    wc := Cardinal(Src^);  Inc(Src);
+    case wc of
+      $0A: pb := StrECopy(pb, PChar(FLineBreak));
+
+      0..$09, $0B..$7F:  begin
+        pb^ := char(wc); Inc(pb);
+      end;
+
+      $80..$7FF: begin
+        pb^ := Char($C0 or (wc shr 6));
+        pb[1] := Char($80 or (wc and $3F));
+        Inc(pb,2);
+      end;
+
+      $D800..$DBFF: begin
+        if (Src < SrcEnd) and (Src^ >= #$DC00) and (Src^ <= #$DFFF) then
+        begin
+          wc := ((LongInt(wc) - $D7C0) shl 10) + LongInt(word(Src^) xor $DC00);
+          Inc(Src);
+
+          pb^ := Char($F0 or (wc shr 18));
+          pb[1] := Char($80 or ((wc shr 12) and $3F));
+          pb[2] := Char($80 or ((wc shr 6) and $3F));
+          pb[3] := Char($80 or (wc and $3F));
+          Inc(pb,4);
+        end
+        else
+          raise EConvertError.Create('High surrogate without low one');
+      end;
+      $DC00..$DFFF:
+        raise EConvertError.Create('Low surrogate without high one');
+      else   // $800 >= wc > $FFFF, excluding surrogates
+      begin
+        pb^ := Char($E0 or (wc shr 12));
+        pb[1] := Char($80 or ((wc shr 6) and $3F));
+        pb[2] := Char($80 or (wc and $3F));
+        Inc(pb,3);
+      end;
+    end;
+  end;
+  FBufPos := pb;
 end;
 
-procedure Stream_WriteLn(s: String);
+procedure THTMLWriter.wrtStr(const ws: WideString); { inline }
 begin
-  if Length(s) > 0 then
-    stream.Write(s[1], Length(s));
-  stream.WriteByte(10);
+  wrtChars(PWideChar(ws), Length(ws));
 end;
 
+{ No checks here - buffer always has 32 extra bytes }
+procedure THTMLWriter.wrtChr(c: WideChar); { inline }
+begin
+  FBufPos^ := char(ord(c));
+  Inc(FBufPos);
+end;
 
-// -------------------------------------------------------------------
-//   String conversion
-// -------------------------------------------------------------------
+procedure THTMLWriter.wrtIndent; { inline }
+begin
+  wrtChars(#10, 1);
+end;
 
-type
-  TCharacters = set of Char;
-  TSpecialCharCallback = procedure(c: Char);
+procedure THTMLWriter.wrtQuotedLiteral(const ws: WideString);
+var
+  Quote: WideChar;
+begin
+  // TODO: need to check if the string also contains single quote
+  // both quotes present is a error
+  if Pos('"', ws) > 0 then
+    Quote := ''''
+  else
+    Quote := '"';
+  wrtChr(Quote);
+  wrtStr(ws);
+  wrtChr(Quote);
+end;
 
 const
-  AttrSpecialChars = ['"', '&'];
+  AttrSpecialChars = ['<', '"', '&'];
   TextSpecialChars = ['<', '>', '&'];
 
-
-procedure ConvWrite(const s: String; const SpecialChars: TCharacters;
+procedure THTMLWriter.ConvWrite(const s: WideString; const SpecialChars: TSetOfChar;
   const SpecialCharCallback: TSpecialCharCallback);
 var
   StartPos, EndPos: Integer;
@@ -132,59 +267,76 @@ begin
   EndPos := 1;
   while EndPos <= Length(s) do
   begin
-    if s[EndPos] in SpecialChars then
+    if (s[EndPos] < #255) and (Char(ord(s[EndPos])) in SpecialChars) then
     begin
-      wrt(Copy(s, StartPos, EndPos - StartPos));
+      wrtChars(@s[StartPos], EndPos - StartPos);
       SpecialCharCallback(s[EndPos]);
       StartPos := EndPos + 1;
     end;
     Inc(EndPos);
   end;
-  if EndPos > StartPos then
-    wrt(Copy(s, StartPos, EndPos - StartPos));
+  if StartPos <= length(s) then
+    wrtChars(@s[StartPos], EndPos - StartPos);
 end;
 
-procedure AttrSpecialCharCallback(c: Char);
+const
+  QuotStr = '&quot;';
+  AmpStr = '&amp;';
+  ltStr = '&lt;';
+  gtStr = '&gt;';
+
+procedure THTMLWriter.AttrSpecialCharCallback(c: WideChar);
 begin
-  if c = '"' then
-    wrt('&quot;')
-  else if c = '&' then
-    wrt('&amp;')
+  case c of
+    '"': wrtStr(QuotStr);
+    '&': wrtStr(AmpStr);
+    '<': wrtStr(ltStr);
   else
-    wrt(c);
+    wrtChr(c);
+  end;
 end;
 
-procedure TextnodeSpecialCharCallback(c: Char);
+procedure THTMLWriter.TextnodeSpecialCharCallback(c: WideChar);
 begin
-  if c = '<' then
-    wrt('&lt;')
-  else if c = '>' then
-    wrt('&gt;')
-  else if c = '&' then
-    wrt('&amp;')
+  case c of
+    '<': wrtStr(ltStr);
+    '>': wrtStr(gtStr); // Required only in ']]>' literal, otherwise optional
+    '&': wrtStr(AmpStr);
   else
-    wrt(c);
+    wrtChr(c);
+  end;
 end;
 
-function IsTextNode(Node: TDOMNode): Boolean;
+procedure THTMLWriter.WriteNode(node: TDOMNode);
 begin
-  Result := Node.NodeType in [TEXT_NODE, ENTITY_REFERENCE_NODE];
+  case node.NodeType of
+    ELEMENT_NODE:                VisitElement(node);
+    ATTRIBUTE_NODE:              VisitAttribute(node);
+    TEXT_NODE:                   VisitText(node);
+    CDATA_SECTION_NODE:          VisitCDATA(node);
+    ENTITY_REFERENCE_NODE:       VisitEntityRef(node);
+    PROCESSING_INSTRUCTION_NODE: VisitPI(node);
+    COMMENT_NODE:                VisitComment(node);
+    DOCUMENT_NODE:               VisitDocument(node);
+    DOCUMENT_TYPE_NODE:          VisitDocumentType(node);
+    ENTITY_NODE,
+    DOCUMENT_FRAGMENT_NODE:      VisitFragment(node);
+  end;
 end;
 
 
-// -------------------------------------------------------------------
-//   Node writers implementations
-// -------------------------------------------------------------------
-
-procedure WriteElement(node: TDOMNode);
+procedure THTMLWriter.VisitElement(node: TDOMNode);
 var
   i: Integer;
-  J : THTMLElementTag;
-  attr, child: TDOMNode;
-  s: String;
+  child: TDOMNode;
   SavedInsideTextNode: Boolean;
+  s: string;
   ElFlags: THTMLElementFlags;
+  j: THTMLElementTag;
 begin
+  if not FInsideTextNode then
+    wrtIndent;
+    
   s := LowerCase(node.NodeName);
   ElFlags := [efSubelementContent, efPCDATAContent];    // default flags
   for j := Low(THTMLElementTag) to High(THTMLElementTag) do
@@ -194,121 +346,141 @@ begin
       break;
     end;
 
-  wrt('<' + node.NodeName);
-  for i := 0 to node.Attributes.Length - 1 do
-  begin
-    attr := node.Attributes.Item[i];
-    wrt(' ' + attr.NodeName + '=');
-    s := attr.NodeValue;
-    // !!!: Replace special characters in "s" such as '&', '<', '>'
-    wrt('"');
-    ConvWrite(s, AttrSpecialChars, @AttrSpecialCharCallback);
-    wrt('"');
-  end;
-  wrt('>');
-  if (not InsideTextNode) and not (efPCDATAContent in ElFlags) then
-    wrtln('');
-
+  wrtChr('<');
+  wrtStr(TDOMElement(node).TagName);
+  if node.HasAttributes then
+    for i := 0 to node.Attributes.Length - 1 do
+    begin
+      child := node.Attributes.Item[i];
+      VisitAttribute(child);
+    end;
+  wrtChr('>');
   Child := node.FirstChild;
-  if Assigned(Child) then
+  if Child <> nil then
   begin
-    SavedInsideTextNode := InsideTextNode;
+    SavedInsideTextNode := FInsideTextNode;
+    FInsideTextNode := efPCDATAContent in ElFlags;
     repeat
-      InsideTextNode := efPCDATAContent in ElFlags;
       WriteNode(Child);
       Child := Child.NextSibling;
-    until not Assigned(child);
-    InsideTextNode := SavedInsideTextNode;
+    until Child = nil;
+    FInsideTextNode := SavedInsideTextNode;
   end;
-
+  if (not FInsideTextNode) and not (efPCDATAContent in ElFlags) then
+    wrtIndent;
   if ElFlags * [efSubelementContent, efPCDATAContent] <> [] then
   begin
-    wrt('</' + node.NodeName + '>');
-    if not InsideTextNode then
-      wrtln('');
+    wrtChars('</', 2);
+    wrtStr(TDOMElement(Node).TagName);
+    wrtChr('>');
   end;
 end;
 
-procedure WriteAttribute(node: TDOMNode);
+procedure THTMLWriter.VisitText(node: TDOMNode);
 begin
-  WriteLn('WriteAttribute');
+  ConvWrite(TDOMCharacterData(node).Data, TextSpecialChars, {$IFDEF FPC}@{$ENDIF}TextnodeSpecialCharCallback);
 end;
 
-procedure WriteText(node: TDOMNode);
+procedure THTMLWriter.VisitCDATA(node: TDOMNode);
 begin
-  ConvWrite(node.NodeValue, TextSpecialChars, @TextnodeSpecialCharCallback);
+  if not FInsideTextNode then
+    wrtIndent;
+  wrtChars('<![CDATA[', 9);
+  wrtStr(TDOMCharacterData(node).Data);
+  wrtChars(']]>', 3);
 end;
 
-procedure WriteCDATA(node: TDOMNode);
+procedure THTMLWriter.VisitEntityRef(node: TDOMNode);
 begin
-  if InsideTextNode then
-    wrt('<![CDATA[' + node.NodeValue + ']]>')
-  else
-    wrtln('<![CDATA[' + node.NodeValue + ']]>')
+  wrtChr('&');
+  wrtStr(node.NodeName);
+  wrtChr(';');
 end;
 
-procedure WriteEntityRef(node: TDOMNode);
+procedure THTMLWriter.VisitPI(node: TDOMNode);
 begin
-  wrt('&' + node.NodeName + ';');
+  if not FInsideTextNode then wrtIndent;
+  wrtStr('<?');
+  wrtStr(TDOMProcessingInstruction(node).Target);
+  wrtChr(' ');
+  wrtStr(TDOMProcessingInstruction(node).Data);
+  wrtStr('?>');
 end;
 
-procedure WriteEntity(node: TDOMNode);
+procedure THTMLWriter.VisitComment(node: TDOMNode);
 begin
-  WriteLn('WriteEntity');
+  if not FInsideTextNode then wrtIndent;
+  wrtChars('<!--', 4);
+  wrtStr(TDOMCharacterData(node).Data);
+  wrtChars('-->', 3);
 end;
 
-procedure WritePI(node: TDOMNode);
+procedure THTMLWriter.VisitDocument(node: TDOMNode);
 var
-  s: String;
+  child: TDOMNode;
 begin
-  s := '<!' + TDOMProcessingInstruction(node).Target + ' ' +
-    TDOMProcessingInstruction(node).Data + '>';
-  if InsideTextNode then
-    wrt(s)
-  else
-    wrtln( s);
-end;
-
-procedure WriteComment(node: TDOMNode);
-begin
-  if InsideTextNode then
-    wrt('<!--' + node.NodeValue + '-->')
-  else
-    wrtln('<!--' + node.NodeValue + '-->')
-end;
-
-procedure WriteDocument(node: TDOMNode);
-begin
-  WriteLn('WriteDocument');
-end;
-
-procedure WriteDocumentType(node: TDOMNode);
-begin
-  WriteLn('WriteDocumentType');
-end;
-
-procedure WriteDocumentFragment(node: TDOMNode);
-begin
-  WriteLn('WriteDocumentFragment');
+  child := node.FirstChild;
+  while Assigned(Child) do
+  begin
+    WriteNode(Child);
+    Child := Child.NextSibling;
+  end;
+  wrtChars(#10, 1);
 end;
 
-procedure WriteNotation(node: TDOMNode);
+procedure THTMLWriter.VisitAttribute(Node: TDOMNode);
+var
+  Child: TDOMNode;
 begin
-  WriteLn('WriteNotation');
+  wrtChr(' ');
+  wrtStr(TDOMAttr(Node).Name);
+  wrtChars('="', 2);
+  Child := Node.FirstChild;
+  while Assigned(Child) do
+  begin
+    case Child.NodeType of
+      ENTITY_REFERENCE_NODE:
+        VisitEntityRef(Child);
+      TEXT_NODE:
+        ConvWrite(TDOMCharacterData(Child).Data, AttrSpecialChars, {$IFDEF FPC}@{$ENDIF}AttrSpecialCharCallback);
+    end;
+    Child := Child.NextSibling;
+  end;
+  wrtChr('"');
 end;
 
-
-procedure InitWriter;
+procedure THTMLWriter.VisitDocumentType(Node: TDOMNode);
 begin
-  InsideTextNode := False;
+  wrtStr('<!DOCTYPE ');
+  wrtStr(Node.NodeName);
+  wrtChr(' ');
+  with TDOMDocumentType(Node) do
+  begin
+    if PublicID <> '' then
+    begin
+      wrtStr('PUBLIC ');
+      wrtQuotedLiteral(PublicID);
+      if SystemID <> '' then
+      begin
+        wrtChr(' ');
+        wrtQuotedLiteral(SystemID);
+      end;  
+    end
+    else if SystemID <> '' then
+    begin
+      wrtStr('SYSTEM ');
+      wrtQuotedLiteral(SystemID);
+    end;
+  end;
+  wrtChr('>');
 end;
 
-procedure RootWriter(doc: TXMLDocument);
+procedure THTMLWriter.VisitFragment(Node: TDOMNode);
 var
   Child: TDOMNode;
 begin
-  InitWriter;
-  child := doc.FirstChild;
+  // Fragment itself should not be written, only its children should...
+  Child := Node.FirstChild;
   while Assigned(Child) do
   begin
     WriteNode(Child);
@@ -322,57 +494,50 @@ end;
 // -------------------------------------------------------------------
 
 procedure WriteHTMLFile(doc: TXMLDocument; const AFileName: String);
+var
+  fs: TFileStream;
 begin
-  Stream := TFileStream.Create(AFileName, fmCreate);
-  wrt := @Stream_Write;
-  wrtln := @Stream_WriteLn;
-  RootWriter(doc);
-  Stream.Free;
+  fs := TFileStream.Create(AFileName, fmCreate);
+  try
+    WriteHTMLFile(doc, fs);
+  finally
+    fs.Free;
+  end;
 end;
 
 procedure WriteHTMLFile(doc: TXMLDocument; var AFile: Text);
 begin
-  f := @AFile;
-  wrt := @Text_Write;
-  wrtln := @Text_WriteLn;
-  RootWriter(doc);
+  with TTextHTMLWriter.Create(AFile) do
+  try
+    WriteNode(doc);
+  finally
+    Free;
+  end;
 end;
 
 procedure WriteHTMLFile(doc: TXMLDocument; AStream: TStream);
 begin
-  Stream := AStream;
-  wrt := @Stream_Write;
-  wrtln := @Stream_WriteLn;
-  RootWriter(doc);
+  with TStreamHTMLWriter.Create(AStream) do
+  try
+    WriteNode(doc);
+  finally
+    Free;
+  end;
 end;
 
-
-procedure WriteHTML(Element: TDOMElement; const AFileName: String);
+procedure WriteHTML(Element: TDOMNode; const AFileName: String);
 begin
-  Stream := TFileStream.Create(AFileName, fmCreate);
-  wrt := @Stream_Write;
-  wrtln := @Stream_WriteLn;
-  InitWriter;
-  WriteNode(Element);
-  Stream.Free;
+  WriteHTMLFile(TXMLDocument(Element), AFileName);
 end;
 
-procedure WriteHTML(Element: TDOMElement; var AFile: Text);
+procedure WriteHTML(Element: TDOMNode; var AFile: Text);
 begin
-  f := @AFile;
-  wrt := @Text_Write;
-  wrtln := @Text_WriteLn;
-  InitWriter;
-  WriteNode(Element);
+  WriteHTMLFile(TXMLDocument(Element), AFile);
 end;
 
-procedure WriteHTML(Element: TDOMElement; AStream: TStream);
+procedure WriteHTML(Element: TDOMNode; AStream: TStream);
 begin
-  stream := AStream;
-  wrt := @Stream_Write;
-  wrtln := @Stream_WriteLn;
-  InitWriter;
-  WriteNode(Element);
+  WriteHTMLFile(TXMLDocument(Element), AStream);
 end;
 
 

packages/fcl-xml/src/names.inc

@@ -16,7 +16,8 @@ type
   TSetOfByte = set of Byte;
 
 const
-  ns_ASCII = [$3A, $41..$5A, $5F, $61..$7A, $C0..$D6, $D8..$F6, $F8..$FF];
+// colon ($3a) is excluded, it is handled in the code
+  ns_ASCII = [{ $3A,} $41..$5A, $5F, $61..$7A, $C0..$D6, $D8..$F6, $F8..$FF];
   ns_0200  = [0..$17, $50..$A8, $BB..$C1];
   ns_0300  = [$86, $88..$8A, $8C, $8E..$A1,
               $A3..$CE, $D0..$D6, $DA, $DC,

packages/fcl-xml/src/xmlutils.pp

@@ -106,12 +106,14 @@ begin
 
   I := 0;
   if (Len = 0) or not ((Byte(Value[I]) in NamingBitmap[Pages^[hi(Word(Value[I]))]]) or
+    (Value[I] = ':') or
     (Xml11 and IsXml11Char(Value, I))) then
       Exit;
   Inc(I);
   while I < Len do
   begin
     if not ((Byte(Value[I]) in NamingBitmap[Pages^[$100+hi(Word(Value[I]))]]) or
+      (Value[I] = ':') or
       (Xml11 and IsXml11Char(Value, I))) then
         Exit;
     Inc(I);
@@ -137,6 +139,7 @@ begin
   while I <= Length(Value) do
   begin
     if not ((Byte(Value[I]) in NamingBitmap[Pages^[Offset+hi(Word(Value[I]))]]) or
+      (Value[I] = ':') or
       (Xml11 and IsXml11Char(Value, I))) then
     begin
       if (I = Length(Value)) or (Value[I] <> #32) then
@@ -167,6 +170,7 @@ begin
   while I <= Length(Value) do
   begin
     if not ((Byte(Value[I]) in NamingBitmap[Pages^[$100+hi(Word(Value[I]))]]) or
+      (Value[I] = ':') or
       (Xml11 and IsXml11Char(Value, I))) then
         Exit;
     Inc(I);
@@ -190,6 +194,7 @@ begin
   while I <= Length(Value) do
   begin
     if not ((Byte(Value[I]) in NamingBitmap[Pages^[$100+hi(Word(Value[I]))]]) or
+      (Value[I] = ':') or
       (Xml11 and IsXml11Char(Value, I))) then
     begin
       if (I = Length(Value)) or (Value[I] <> #32) then

packages/fcl-xml/tests/README_DOM

@@ -0,0 +1,65 @@
+Testing FCL DOM implementation with official test suite from w3.org
+-------------------------------------------------------------------
+
+*** IMPORTANT: READ CAREFULLY!
+
+IF YOU ARE ABOUT TO RUN THESE TESTS, CONSIDER DOING SO IN AN ENVIRONMENT
+THAT YOU MAY ALLOW TO BE TRASHED.
+
+As of writing this at 3 June 2008, FCL DOM memory model is
+not compatible - at all - with the way that w3.org tests use. In
+particular, tests acquire (and use) references to objects that DOM
+implementation frees. Therefore, running the tests WILL result in heap
+corruption, executing arbitrary code, and any other imaginable kind of
+disaster. Be warned.
+
+*** End of notice
+--------------------------------------------------------------------
+
+
+To test the FCL DOM implementation, follow these steps:
+
+1) Checkout the DOM test suite from w3.org CVS repository. The project name is
+2001/DOM-Test-Suite. Only 'tests' subdirectory is needed, everything else
+is irrelevant for our purposes.
+Use the following commands:
+
+  CVSROOT=:pserver:[email protected]:/sources/public
+  cvs login
+  (enter the password anonymous when prompted)
+  cvs checkout 2001/DOM-Test-Suite/tests
+
+2) Compile the testgen utility. A simple
+
+  fpc testgen.pp
+
+should do it.
+
+3) Use testgen to convert DOM test suites into Pascal code. Specify path to the
+directory that contains 'alltests.xml' file, and the name of resulting FPC unit.
+Testgen expects the API description file 'api.xml' present in its directory.
+Successful conversion of the following test modules is possible:
+
+Level 1 Core (527 tests):
+  testgen 2001/DOM-Test-Suite/tests/level1/core core1.pp
+
+Level 2 Core (282 tests):
+  testgen 2001/DOM-Test-Suite/tests/level2/core core2.pp
+
+Level 3 Core (partial only, 131 out of 722 tests):
+  testgen 2001/DOM-Test-Suite/tests/level3/core core3.pp
+
+In the examples above, output names (core1.pp, etc.) carry no defined meaning, you may
+use anything instead.
+
+Normally, tests that contain properties/methods unsupported by FCL DOM, or
+other elements not yet known to testgen, will be skipped. The conversion may be forced
+by using -f commandline switch, but in this case the resulting Pascal unit will likely
+fail to compile.
+ 
+4) Now, pick up your preferred fpcunit test runner, include the generated units into
+its uses clause, and compile. During compilation, path to 'domunit.pp' should be added
+to the unit search paths.
+
+5) During runtime, tests must be able to read test files which are located
+within CVS source tree ('files' subdirectory of each module directory).

packages/fcl-xml/tests/api.xml

@@ -0,0 +1,260 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!--
+  A free-form description of DOM API, lists properties/methods,
+  their arguments and result types.
+  This is used by testgen program to convert w3.org XML test descriptions into 
+  fpcUnit-compatible Pascal code.
+ -->
+<!DOCTYPE api [
+<!ELEMENT api (item)+ >
+<!ELEMENT item (arg*)>
+<!ELEMENT arg (#PCDATA)>
+<!ATTLIST item
+  id ID #REQUIRED
+  type (func|prop|method) "func"
+  result CDATA #IMPLIED
+  objtype CDATA #IMPLIED
+  gc (yes|no) #IMPLIED>
+]>
+<api>
+<item id="createDocumentFragment"/>
+<item id="createTextNode">
+  <arg>data</arg>
+</item>
+<item id="createComment">
+  <arg>data</arg>
+</item>
+<item id="createCDATASection">
+  <arg>data</arg>
+</item>
+<item id="createElement">
+  <arg>tagName</arg>
+</item>
+<item id="createAttribute">
+  <arg>name</arg>
+</item>
+<item id="createEntityReference">
+  <arg>name</arg>
+</item>
+<item id="createProcessingInstruction">
+  <arg>target</arg>
+  <arg>data</arg>
+</item>
+
+<item id="appendChild" result="Node">
+  <arg>newChild</arg>
+</item>
+<item id="insertBefore" result="Node">
+  <arg>newChild</arg>
+  <arg>refChild</arg>
+</item>
+<item id="replaceChild" result="Node">
+  <arg>newChild</arg>
+  <arg>oldChild</arg>
+</item>
+<item id="removeChild" result="Node">
+  <arg>oldChild</arg>
+</item>
+
+<item id="firstChild" result="Node"/>
+<item id="lastChild" result="Node"/>
+<item id="parentNode" result="Node"/>
+<item id="nextSibling" result="Node"/>
+<item id="previousSibling" result="Node"/>
+<item id="ownerDocument" result="Node"/>
+<item id="nodeType"/>
+<item id="attributes"/>
+<item id="name"/>
+<item id="nodeName"/>
+<item id="hasChildNodes"/>
+<item id="doctype"/>
+<item id="documentElement"/>
+<item id="entities"/>
+<item id="notations"/>
+<item id="publicId" type="prop"/> <!-- settable for DOM lvl 3 LSInput -->
+<item id="systemId" type="prop"/>
+<item id="notationName"/>
+<item id="getNamedItem" result="Node">
+  <arg>name</arg>
+</item>
+<item id="setNamedItem">
+  <arg>arg</arg>
+</item>
+<item id="removeNamedItem">
+  <arg>name</arg>
+</item>
+<item id="getAttribute">
+  <arg>name</arg>
+</item>
+<item id="setAttribute" objtype="Element" type="method">
+  <arg>name</arg>
+  <arg>value</arg>
+</item>
+<item id="removeAttribute" objtype="Element" type="method">
+  <arg>name</arg>
+</item>
+<item id="tagName" objtype="Element"/>
+
+<item id="getAttributeNode">
+  <arg>name</arg>
+</item>
+<item id="setAttributeNode">
+  <arg>newAttr</arg>
+</item>
+<item id="removeAttributeNode">
+  <arg>oldAttr</arg>
+</item>
+
+<item id="specified" objtype="Attr"/>
+
+<item id="normalize" type="method"/>
+<item id="substringData">
+  <arg>offset</arg>
+  <arg>count</arg>
+</item>
+<item id="splitText" objtype="Text">
+  <arg>offset</arg>
+</item>
+<item id="appendData" objtype="CharacterData" type="method">
+  <arg>arg</arg>
+</item>
+<item id="deleteData" objtype="CharacterData" type="method">
+  <arg>offset</arg>
+  <arg>count</arg>
+</item>
+<item id="replaceData" objtype="CharacterData" type="method">
+  <arg>offset</arg>
+  <arg>count</arg>
+  <arg>arg</arg>
+</item>
+<item id="insertData" objtype="CharacterData" type="method">
+  <arg>offset</arg>
+  <arg>arg</arg>
+</item>
+
+<item id="cloneNode" result="Node">
+  <arg>deep</arg>
+</item>
+<item id="getElementsByTagName" gc="yes">
+  <arg>tagname</arg>
+</item>
+<item id="childNodes" gc="yes"/>
+
+<item id="value" type="prop"/>
+<item id="nodeValue" type="prop"/>
+<item id="data" type="prop"/>
+<item id="target" type="prop"/>
+
+<!-- Level 2 -->
+<item id="namespaceURI"/>
+<item id="localName"/>
+<item id="internalSubset"/>
+<item id="hasAttributes"/>
+
+<item id="prefix" type="prop"/>
+<item id="ownerElement" objtype="Attr"/>
+
+<item id="hasAttribute">
+  <arg>name</arg>
+</item>
+
+<item id="isSupported">
+  <arg>feature</arg>
+  <arg>version</arg>
+</item>
+<item id="getElementById">
+  <arg>elementId</arg>
+</item>
+<item id="importNode" result="Node">
+  <arg>importedNode</arg>
+  <arg>deep</arg>
+</item>
+<item id="createAttributeNS">
+  <arg>namespaceURI</arg>
+  <arg>qualifiedName</arg>
+</item>
+<item id="createElementNS">
+  <arg>namespaceURI</arg>
+  <arg>qualifiedName</arg>
+</item>
+<item id="createDocument">
+  <arg>namespaceURI</arg>
+  <arg>qualifiedName</arg>
+  <arg>doctype</arg>
+</item>
+<item id="createDocumentType">
+  <arg>qualifiedName</arg>
+  <arg>publicId</arg>
+  <arg>systemId</arg>
+</item>
+<item id="getAttributeNodeNS" objtype="Element">
+  <arg>namespaceURI</arg>
+  <arg>localName</arg>
+</item>
+<item id="getAttributeNS" objtype="Element">
+  <arg>namespaceURI</arg>
+  <arg>localName</arg>
+</item>
+<item id="hasAttributeNS" objtype="Element">
+  <arg>namespaceURI</arg>
+  <arg>localName</arg>
+</item>
+<item id="setAttributeNodeNS" objtype="Element">
+  <arg>newAttr</arg>
+</item>
+<item id="removeAttributeNS" objtype="Element" type="method">
+  <arg>namespaceURI</arg>
+  <arg>localName</arg>
+</item>
+<item id="setAttributeNS" objtype="Element" type="method">
+  <arg>namespaceURI</arg>
+  <arg>qualifiedName</arg>
+  <arg>value</arg>
+</item>
+<item id="getNamedItemNS" result="Node">
+  <arg>namespaceURI</arg>
+  <arg>localName</arg>
+</item>
+<item id="setNamedItemNS">
+  <arg>arg</arg>
+</item>
+<item id="removeNamedItemNS" result="Node">
+  <arg>namespaceURI</arg>
+  <arg>localName</arg>
+</item>
+<item id="getElementsByTagNameNS" gc="yes">
+  <arg>namespaceURI</arg>
+  <arg>localName</arg>
+</item>
+
+
+<!-- Level 3 -->
+<item id="textContent" type="prop"/>
+<!-- item id="isElementContentWhitespace"/ --><!-- not there yet -->
+<!--
+<item id="domConfig"/>
+<item id="schemaTypeInfo"/>
+<item id="typeName"/>
+<item id="typeNamespace"/>
+<item id="isDerivedFrom"/>
+<item id="canSetParameter"/>
+<item id="setParameter"/>
+<item id="normalizeDocument"/>
+<item id="isId"/>
+
+// assertNotEquals
+// assertLowerSeverity
+
+<item id="getUserData"/>
+<item id="setUserData"/>
+<item id="isEqualNode"/>
+<item id="isSameNode"/>
+<item id="lookupNamespaceURI"/>
+<item id="lookupPrefix"/>
+<item id="isDefaultNamespace"/>
+<item id="adoptNode"/>
+<item id="renameNode"/>
+<item id="replaceWholeText"/>
+<item id="wholeText"/>
+-->
+</api>

packages/fcl-xml/tests/domunit.pp

@@ -0,0 +1,272 @@
+{**********************************************************************
+
+    This file is part of the Free Component Library (FCL)
+
+    fpcunit extensions required to run w3.org DOM test suites
+    Copyright (c) 2008 by Sergei Gorelkin, [email protected]
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit domunit;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, DOM, XMLRead, contnrs, fpcunit;
+
+type
+{ these two types are separated for the purpose of readability }
+  _collection = array of DOMString;   // unordered
+  _list = _collection;                // ordered
+
+  TDOMTestBase = class(TTestCase)
+  private
+    procedure setImplAttr(const name: string; value: Boolean);
+    function getImplAttr(const name: string): Boolean;
+  protected
+    // override for this one is generated by testgen for each descendant
+    function GetTestFilesURI: string; virtual;
+  protected
+    FParser: TDOMParser;
+    FAutoFree: TFPObjectList;
+    procedure SetUp; override;
+    procedure TearDown; override;
+    procedure GC(obj: TObject);
+    procedure Load(out doc: TDOMDocument; const uri: string);
+    function getResourceURI(const res: WideString): WideString;
+    function ContentTypeIs(const t: string): Boolean;
+    function GetImplementation: TDOMImplementation;
+    procedure CheckFeature(const name: string);
+    procedure assertNull(const id: string; const ws: DOMString); overload;
+    procedure assertEquals(const id: string; exp, act: TObject); overload;
+    procedure assertEqualsList(const id: string; const exp: array of DOMString; const act: _list);
+    procedure assertEqualsCollection(const id: string; const exp: array of DOMString; const act: _collection);
+    procedure assertSame(const id: string; exp, act: TDOMNode);
+    procedure assertSize(const id: string; size: Integer; obj: TDOMNodeList);
+    procedure assertSize(const id: string; size: Integer; obj: TDOMNamedNodeMap);
+    procedure assertInstanceOf(const id: string; obj: TObject; const typename: string);
+    procedure assertURIEquals(const id: string;
+      const scheme, path, host, file_, name, query, fragment: DOMString;
+      IsAbsolute: Boolean; const Actual: DOMString);
+    function bad_condition(const TagName: WideString): Boolean;
+    property implementationAttribute[const name: string]: Boolean read getImplAttr write setImplAttr;
+  end;
+
+procedure _append(var coll: _collection; const Value: DOMString);
+procedure _assign(out rslt: _collection; const value: array of DOMString);
+
+implementation
+
+uses
+  URIParser;
+
+procedure _append(var coll: _collection; const Value: DOMString);
+var
+  L: Integer;
+begin
+  L := Length(coll);
+  SetLength(coll, L+1);
+  coll[L] := Value;
+end;
+
+procedure _assign(out rslt: _collection; const value: array of DOMString);
+var
+  I: Integer;
+begin
+  SetLength(rslt, Length(value));
+  for I := 0 to High(value) do
+    rslt[I] := value[I];
+end;
+
+procedure TDOMTestBase.SetUp;
+begin
+  FParser := TDOMParser.Create;
+  FParser.Options.PreserveWhitespace := True;
+  FAutoFree := TFPObjectList.Create(True);
+end;
+
+procedure TDOMTestBase.TearDown;
+begin
+  FreeAndNil(FAutoFree);
+  FreeAndNil(FParser);
+end;
+
+procedure TDOMTestBase.GC(obj: TObject);
+begin
+  FAutoFree.Add(obj);
+end;
+
+procedure TDOMTestBase.assertSame(const id: string; exp, act: TDOMNode);
+begin
+  if exp <> act then
+  begin
+    assertNotNull(id, exp);
+    assertNotNull(id, act);
+    assertEquals(id, exp.nodeType, act.nodeType);
+    assertEquals(id, exp.nodeValue, act.nodeValue);
+  end;
+end;
+
+procedure TDOMTestBase.assertNull(const id: string; const ws: DOMString);
+begin
+  if ws <> '' then
+    Fail(id);
+end;
+
+procedure TDOMTestBase.assertEquals(const id: string; exp, act: TObject);
+begin
+  inherited assertSame(id, exp, act);
+end;
+
+procedure TDOMTestBase.assertEqualsList(const id: string;
+  const exp: array of DOMString; const act: _list);
+var
+  I: Integer;
+begin
+  AssertEquals(id, Length(exp), Length(act));
+  // compare ordered
+  for I := 0 to High(exp) do
+    AssertEquals(id, exp[I], act[I]);
+end;
+
+procedure TDOMTestBase.assertEqualsCollection(const id: string; const exp: array of DOMString; const act: _collection);
+var
+  I, J, matches: Integer;
+begin
+  AssertEquals(id, Length(exp), Length(act));
+  // compare unordered
+  for I := 0 to High(exp) do
+  begin
+    matches := 0;
+    for J := 0 to High(act) do
+      if act[J] = exp[I] then
+        Inc(matches);
+    AssertTrue(id+': no match found for <'+exp[I]+'>', matches <> 0);
+    AssertTrue(id+': multiple matches for <'+exp[I]+'>', matches = 1);
+  end;
+end;
+
+procedure TDOMTestBase.assertSize(const id: string; size: Integer; obj: TDOMNodeList);
+begin
+  AssertNotNull(id, obj);
+  AssertEquals(id, size, obj.Length);
+end;
+
+procedure TDOMTestBase.assertSize(const id: string; size: Integer; obj: TDOMNamedNodeMap);
+begin
+  AssertNotNull(id, obj);
+  AssertEquals(id, size, obj.Length);
+end;
+
+function TDOMTestBase.getResourceURI(const res: WideString): WideString;
+var
+  Base, Level: WideString;
+begin
+  Base := GetTestFilesURI + 'files/';
+  if not ResolveRelativeURI(Base, res+'.xml', Result) then
+    Result := '';
+end;
+
+function TDOMTestBase.getImplAttr(const name: string): Boolean;
+begin
+  if name = 'expandEntityReferences' then
+    result := FParser.Options.ExpandEntities
+  else if name = 'validating' then
+    result := FParser.Options.Validate
+  else if name = 'namespaceAware' then
+    result := FParser.Options.Namespaces
+  else if name = 'ignoringElementContentWhitespace' then
+    result := not FParser.Options.PreserveWhitespace
+  else
+  begin
+    Fail('Unknown implementation attribute: ''' + name + '''');
+    result := False;
+  end;
+end;
+
+procedure TDOMTestBase.setImplAttr(const name: string; value: Boolean);
+begin
+  if name = 'validating' then
+    FParser.Options.Validate := value
+  else if name = 'expandEntityReferences' then
+    FParser.Options.ExpandEntities := value
+  else if name = 'coalescing' then
+  // TODO: action unknown yet
+  else if (name = 'signed') and value then
+    Ignore('Setting implementation attribute ''signed'' to ''true'' is not supported')
+  else if name = 'hasNullString' then
+  // TODO: probably we cannot support this
+  else if name = 'namespaceAware' then
+    FParser.Options.Namespaces := value
+  else if name = 'ignoringElementContentWhitespace' then
+    FParser.Options.PreserveWhitespace := not value
+  else
+    Fail('Unknown implementation attribute: ''' + name + '''');
+end;
+
+procedure TDOMTestBase.Load(out doc: TDOMDocument; const uri: string);
+var
+  t: TXMLDocument;
+begin
+  doc := nil;
+  FParser.ParseURI(getResourceURI(uri), t);
+  doc := t;
+  GC(t);
+end;
+
+procedure TDOMTestBase.assertInstanceOf(const id: string; obj: TObject; const typename: string);
+begin
+  AssertTrue(id, obj.ClassNameIs(typename));
+end;
+
+// TODO: This is a very basic implementation, needs to be completed.
+procedure TDOMTestBase.assertURIEquals(const id: string; const scheme, path,
+  host, file_, name, query, fragment: DOMString; IsAbsolute: Boolean;
+  const Actual: DOMString);
+var
+  URI: TURI;
+begin
+  AssertTrue(id, Actual <> '');
+  URI := ParseURI(utf8Encode(Actual));
+  AssertEquals(id, URI.Document, utf8Encode(file_));
+end;
+
+function TDOMTestBase.bad_condition(const TagName: WideString): Boolean;
+begin
+  Fail('Unsupported condition: '+ TagName);
+  Result := False;
+end;
+
+function TDOMTestBase.ContentTypeIs(const t: string): Boolean;
+begin
+{ For now, claim only xml as handled content.
+  This may be extended with html and svg.
+}
+  result := (t = 'text/xml');
+end;
+
+function TDOMTestBase.GetImplementation: TDOMImplementation;
+begin
+  result := nil;
+end;
+
+procedure TDOMTestBase.CheckFeature(const name: string);
+begin
+  // purpose/action is currently unknown
+end;
+
+function TDOMTestBase.GetTestFilesURI: string;
+begin
+  result := '';
+end;
+
+end.
+

packages/fcl-xml/tests/testgen.pp

@@ -0,0 +1,899 @@
+{**********************************************************************
+
+    This file is part of the Free Component Library (FCL)
+
+    Generates fpcunit code from w3.org XML test descriptions
+    Copyright (c) 2008 by Sergei Gorelkin, [email protected]
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+program testgen;
+{$mode objfpc}{$H+}
+
+uses
+  Classes, SysUtils, DOM, XMLRead, XMLWrite, URIParser;
+
+var
+  cntr: Integer = 0;
+  api: TXMLDocument;
+  forced: Boolean = False;
+  TestCount: Integer = 0;
+  FailCount: Integer = 0;
+
+function PascalType(const s: WideString): string;
+begin
+  if (s = 'DOMString') or (s = 'boolean') or (s = 'DOMError') then
+    result := s
+  else if s = 'int' then
+    result := 'Integer'
+  else if s = 'short' then
+    result := 'SmallInt'
+  else if s = 'Collection' then
+    result := '_collection'
+  else if s = 'List' then
+    result := '_list'
+  else if Pos(WideString('DOM'), s) = 1 then
+    result := 'T' + s
+  else
+    result := 'TDOM'+s;
+end;
+
+function ReplaceQuotes(const s: WideString): string;
+var
+  quoted: Boolean;
+begin
+  quoted := (s[1] = '"') and (s[Length(s)] = '"');
+  if quoted then
+    result := UTF8Encode(Copy(s, 2, Length(s)-2))
+  else
+    result := UTF8Encode(s);
+    
+  result := StringReplace(result, '\"', '"', [rfReplaceAll]);
+  result := StringReplace(result, '''', '''''', [rfreplaceAll]);
+  result := StringReplace(result, '\n', '''#10''', [rfReplaceAll]);
+  result := StringReplace(result, '\\', '\', [rfreplaceAll]);
+
+  if quoted then
+    result := '''' + result + '''';
+end;
+
+procedure AppendParam(var s: string; n: TDOMElement; const attName: DOMString);
+begin
+  if n.HasAttribute(attName) then
+    s := s + ReplaceQuotes(n[attName])
+  else
+    s := s + '''''';
+  s := s + ', ';
+end;
+
+function FirstElement(n: TDOMNode): TDOMElement;
+var
+  child: TDOMNode;
+begin
+  child := n.FirstChild;
+  while Assigned(child) and (child.nodeType <> ELEMENT_NODE) do
+    child := child.NextSibling;
+  result := TDOMElement(child);
+end;
+
+procedure GetChildElements(el: TDOMNode; List: TList);
+var
+  child: TDOMNode;
+begin
+  List.Clear;
+  child := el.FirstChild;
+  while Assigned(child) do
+  begin
+    if child.NodeType = ELEMENT_NODE then
+      List.Add(child);
+    child := child.NextSibling;
+  end;
+end;
+
+procedure DumpUnprocessed(e: TDOMElement; dest: TStrings);
+var
+  s: TStringStream;
+begin
+  s := TStringStream.Create('');
+  try
+    writeXML(e, s);
+    dest.Text := dest.Text + '(*****' + s.DataString + sLineBreak + '*)' + sLineBreak;
+  finally
+    s.Free;
+  end;
+end;
+
+function CondToStr(e: TDOMElement; out r: string): Boolean;
+var
+  tmp: string;
+  child: TDOMNode;
+begin
+  Result := True;
+  if e.TagName = 'equals' then
+    r := e['actual'] + ' = ' + ReplaceQuotes(e['expected'])
+  else if e.TagName = 'notEquals' then
+    r := e['actual'] + ' <> ' + ReplaceQuotes(e['expected'])
+  else if e.TagName = 'less' then
+    r := e['actual'] + ' < ' + ReplaceQuotes(e['expected'])
+  else if e.TagName = 'greater' then
+    r := e['actual'] + ' > ' + ReplaceQuotes(e['expected'])
+    
+  // casting to Pointer works for both objects and strings
+  else if e.TagName = 'isNull' then
+    r := 'Pointer(' + e['obj'] + ') = nil'
+  else if e.TagName = 'notNull' then
+    r := 'Assigned(Pointer('+e['obj']+'))'
+  else if e.TagName = 'isTrue' then
+    r := e['value']
+  else if (e.TagName = 'notTrue') or (e.TagName = 'isFalse') then
+    r := 'not ' + e['value']
+  else if e.TagName = 'contentType' then
+    r := 'ContentTypeIs('''+e['type']+''')'
+  else if e.TagName = 'implementationAttribute' then
+  begin
+    r := 'implementationAttribute[''' + e['name'] + '''] = ' + e['value'];
+  end
+  else if e.TagName = 'contains' then
+  begin
+    if e['interface'] = 'DOMString' then
+      r := 'Pos(WideString(' +  replaceQuotes(e['str']) + '), ' + e['obj'] + ') > 0'
+    else
+      r := 'bad_condition(''contains intf=' + e['interface'] + ''')';
+  end
+  else if e.TagName = 'not' then
+  begin
+    child := e.FirstChild;
+    while Assigned(child) do
+    begin
+      if child.nodeType = ELEMENT_NODE then
+      begin
+        if CondToStr(TDOMElement(child), tmp) then
+          r := 'not ('+tmp+')';
+        Break;
+      end;
+      child := child.NextSibling;
+    end;
+  end
+  else if (e.TagName = 'and') or (e.TagName = 'or') then
+  begin
+    r := '';
+    child := e.FirstChild;
+    while Assigned(child) do
+    begin
+      if child.nodeType = ELEMENT_NODE then
+      begin
+        if CondToStr(TDOMElement(child), tmp) then
+        begin
+          if r <> '' then r := r + ' ' + e.TagName + ' ';
+          r := r + '('+tmp+')';
+        end;
+      end;
+      child := child.NextSibling;
+    end;
+  end
+  else
+  begin
+    r := 'bad_condition(''' + e.TagName + ''')';
+    Result := False;
+  end;
+end;
+
+procedure ConvertTest(rootNode: TDOMElement; rslt: TStrings);
+var
+  child, subchild: TDOMNode;
+  n: DOMString;
+  SuccessVarFlag: Boolean;
+  FailFlag: Boolean;
+  Inits, VarTypes: TStringList;
+
+function TypeOfVar(const varname: string): string;
+begin
+  result := VarTypes.Values[varname];
+end;
+
+function IsCollection(node: TDOMElement): Boolean;
+var
+  s: string;
+begin
+  s := TypeOfVar(node['collection']);
+  Result := (s = '_collection') or (s = '_list');
+end;
+
+procedure CastTo(node: TDOMElement; const typename: string);
+begin
+  if (not node.HasAttribute('interface')) and
+    node.HasAttribute('obj') and
+    (TypeOfVar(node['obj']) <> PascalType(typename)) then
+  node['interface'] := typename;
+end;
+
+function getobj(e: TDOMElement): string;
+var
+  s: string;
+begin
+  result := e['obj'];
+  if e.HasAttribute('interface') then
+  begin
+    s := PascalType(e['interface']);
+    if TypeOfVar(e['obj']) <> s then
+      result := s+'('+result+')';
+  end;
+end;
+
+function prop_call(e: TDOMElement): string;
+begin
+  if e.HasAttribute('var') then
+    Result := e['var'] + ' := ' + getobj(e) + '.' + e.TagName + ';'
+  else
+    Result := getobj(e) + '.' + e.TagName + ' := ' + ReplaceQuotes(e['value']) + ';';
+end;
+
+function func_call(e: TDOMElement; const args: array of DOMString; const rsltType: string=''): string;
+var
+  I: Integer;
+begin
+  if (rsltType <> '') and (TypeOfVar(e['var']) <> rsltType) then
+    Result := rsltType + '(' + e['var'] + ')'
+  else
+    Result := e['var'];
+  Result := Result + ' := ' + getobj(e) + '.' + e.TagName;
+  if Length(args) > 0 then
+  begin
+    Result := Result + '(';
+    for I := 0 to High(args) do
+    begin
+      Result := Result + ReplaceQuotes(e[args[I]]);
+      if I <> High(args) then
+        Result := Result + ', ';
+    end;
+    Result := Result + ')';
+  end;
+  Result := Result + ';';
+end;
+
+function method_call(e: TDOMElement; args: TDOMNodeList): string;
+var
+  I: Integer;
+begin
+  Result := getobj(e) + '.' + e.TagName;
+  if args.Length > 0 then
+  begin
+    Result := Result + '(';
+    for I := 0 to args.Length-1 do
+    begin
+      Result := Result + ReplaceQuotes(e[args[I].TextContent]);
+      if I <> args.Length-1 then
+        Result := Result + ', ';
+    end;
+    Result := Result + ')';
+  end;
+  Result := Result + ';';
+end;
+
+procedure FixKeywords(node: TDOMElement; const AttrName: DOMString);
+var
+  v: DOMString;
+begin
+  v := node[AttrName];
+  if v = 'testName' then              // clash with TTest.TestName property
+    node[AttrName] := 'test_Name'
+  else if v = 'implementation' then
+    node[AttrName] := 'DOMImpl'
+  else if v = 'type' then
+    node[AttrName] := 'type_';
+end;
+
+procedure ConvertStatement(node: TDOMElement; const indent: string);
+var
+  s: DOMString;
+  cond: string;
+  apinode: TDOMElement;
+  arglist: TDOMNodeList;
+  args: array of DOMString;
+  I: Integer;
+begin
+  FixKeywords(node, 'var');
+  FixKeywords(node, 'obj');
+
+  s := node.TagName;
+  apinode := api.GetElementById(s);
+  if assigned(apinode) then
+  begin
+    // handle most of DOM API in consistent way
+    arglist := apinode.GetElementsByTagName('arg');
+    SetLength(args, arglist.Length);
+    for I := 0 to arglist.Length-1 do
+      args[I] := arglist[I].TextContent;
+    if apinode['type'] = 'prop' then
+      rslt.Add(indent + prop_call(node))
+    else if apinode['type'] = 'method' then
+    begin
+      if apinode.HasAttribute('objtype') then
+        CastTo(node, apinode['objtype']);
+      rslt.Add(indent + method_call(node, arglist));
+    end
+    else
+    begin
+      if apinode.HasAttribute('result') then
+        cond := PascalType(apinode['result'])
+      else
+        cond := '';
+      if apinode.HasAttribute('objtype') then
+        CastTo(node, apinode['objtype']);
+      rslt.Add(indent + func_call(node, args, cond));
+      if apinode['gc'] = 'yes' then
+        rslt.Add(indent + 'GC(' + node['var'] + ');');
+    end;
+    Exit;
+  end;
+
+  // now, various hacks and workarounds
+
+  // TODO: modify DOM to expose item() as function
+  if s = 'item' then
+    rslt.Add(indent + 'TDOMNode('+node['var'] + ') := ' + node['obj'] + '['+node['index']+'];')
+  else if s = 'length' then
+  begin
+    if node['interface'] = 'DOMString' then
+      rslt.Add(indent + node['var'] + ' := system.length(' + node['obj'] + ');')
+    else
+      rslt.Add(indent + func_call(node, []));
+  end
+  else if s = 'implementation' then
+  begin
+    if node.HasAttribute('obj') then
+      rslt.Add(indent + node['var'] + ' := ' + node['obj'] + '.impl;')
+    else
+      rslt.Add(indent + node['var'] + ' := GetImplementation;');
+  end
+  else if s = 'hasFeature' then
+  begin
+    if node.hasAttribute('var') then
+    begin
+      // we don't have null strings, replace with an empty one
+      if not node.hasAttribute('version') then
+        node['version'] := '""';
+      rslt.Add(indent + func_call(node, ['feature', 'version']))
+    end
+    else
+      rslt.Add(indent + 'CheckFeature(' + ReplaceQuotes(node['feature']) + ');')
+  end
+  
+  // service (non-DOM) statements follow
+  
+  else if s = 'append' then
+    rslt.Add(indent + '_append(' + node['collection'] + ', ' + node['item'] + ');')
+  else if s = 'assign' then
+    rslt.Add(indent + '_assign(' + node['var'] + ', ' + node['value'] + ');')
+  else if s = 'increment' then
+    rslt.Add(indent + 'Inc(' + node['var'] + ', ' + node['value'] + ');')
+  else if s = 'decrement' then
+    rslt.Add(indent + 'Dec(' + node['var'] + ', ' + node['value'] + ');')
+  else if s = 'plus' then
+    rslt.Add(indent + node['var'] + ' := ' + ReplaceQuotes(node['op1']) + ' + ' + ReplaceQuotes(node['op2']) + ';')
+
+  else if s = 'fail' then
+    rslt.Add(indent + s + '(''' + node['id'] + ''');')
+  else if s = 'assertEquals' then
+  begin
+    cond := TypeOfVar(node['actual']);
+    if cond = '_collection' then
+      rslt.Add(indent + 'AssertEqualsCollection(''' + node['id'] + ''', ' + ReplaceQuotes(node['expected']) + ', ' + node['actual'] + ');')
+    else if cond = '_list' then
+      rslt.Add(indent + 'AssertEqualsList(''' + node['id'] + ''', ' + ReplaceQuotes(node['expected']) + ', ' + node['actual'] + ');')
+    else
+      rslt.Add(indent + s + '(''' + node['id'] + ''', ' + ReplaceQuotes(node['expected']) + ', ' + node['actual'] + ');');
+  end
+  else if s = 'assertSame' then
+    rslt.Add(indent + s + '(''' + node['id'] + ''', ' + ReplaceQuotes(node['expected']) + ', ' + node['actual'] + ');')
+  else if (s = 'assertNull') or (s = 'assertNotNull') {or (s='assertFalse')} then
+    rslt.Add(indent + s + '(''' + node['id'] + ''', ' + node['actual'] + ');')
+  else if s = 'assertSize' then
+    rslt.Add(indent + s + '(''' + node['id'] + ''', ' + node['size'] + ', ' + node['collection']+');')
+  else if s = 'assertInstanceOf' then
+    rslt.Add(indent + s + '(''' + node['id'] + ''', ' + node['obj'] + ', ''' + PascalType(node['type'])+''');')
+  else if (s = 'assertTrue') or (s='assertFalse') then
+    if node.HasChildNodes then
+    begin
+      child := FirstElement(node);
+      CondToStr(TDOMElement(child), cond);
+      rslt.Add(indent + s + '(''' + node['id'] + ''', ' + cond + ');');
+    end
+    else
+      rslt.Add(indent + s + '(''' + node['id'] + ''', ' + node['actual'] + ');')
+  else if s = 'assertURIEquals' then
+  begin
+    // TODO: maybe add 'flags' argument to specify which strings are non-NULL
+    cond := '''' + node['id'] + ''', ';
+    AppendParam(cond, node, 'scheme');
+    AppendParam(cond, node, 'path');
+    AppendParam(cond, node, 'host');
+    AppendParam(cond, node, 'file');
+    AppendParam(cond, node, 'name');
+    AppendParam(cond, node, 'query');
+    AppendParam(cond, node, 'fragment');
+
+    if node.HasAttribute('isAbsolute') then
+      cond := cond + node['isAbsolute']
+    else
+      cond := cond + 'False';
+    cond := cond + ', ';
+
+    cond := cond + node['actual'];
+    rslt.Add(indent + s + '(' + cond + ');');
+  end
+  else if n = 'load' then
+    rslt.Add(indent + 'Load('+node['var']+', '''+ node['href']+''');')
+  else if s = 'implementationAttribute' then
+    rslt.Add(indent + s + '[''' + node['name'] + '''] := ' + node['value'] + ';')
+  else
+  begin
+    if not FailFlag then
+      rslt.Add(indent + 'Fail(''This test is not completely converted'');');
+    FailFlag := True;
+    DumpUnprocessed(node, rslt);
+  end;
+end;
+
+procedure ConvertBlock(el: TDOMNode; indent: string);
+var
+  curr: TDOMNode;
+  element: TDOMElement;
+  List: TList;
+  cond, excode: string;
+  Frag: TDOMDocumentFragment;
+  I: Integer;
+  ElseNode: TDOMNode;
+  IsColl: Boolean;
+begin
+  List := TList.Create;
+  curr := el.FirstChild;
+  indent := indent + '  ';
+  while Assigned(curr) do
+  begin
+    if (curr.NodeType <> ELEMENT_NODE) or
+      (curr.NodeName = 'var') or (curr.NodeName = 'metadata') then
+    begin
+      curr := curr.NextSibling;
+      Continue;
+    end;
+    element := TDOMElement(curr);
+    n := element.TagName;
+    if n = 'assertDOMException' then
+    begin
+      if not SuccessVarFlag then
+        rslt.Insert(2, '  success: Boolean;');
+      SuccessVarFlag := True;
+      rslt.Add(indent+'success := False;');
+      rslt.Add(indent+'try');
+      child := curr.FirstChild;
+      while assigned(child) do
+      begin
+        if child.nodeType = ELEMENT_NODE then
+        begin
+          excode := child.nodeName;
+          subchild := child.FirstChild;
+          while Assigned(subchild) do
+          begin
+            if subchild.nodeType = ELEMENT_NODE then
+              ConvertStatement(TDOMElement(subchild), indent + '  ');
+            subchild := subchild.NextSibling;
+          end;
+        end;
+        child := child.NextSibling;
+      end;
+      rslt.Add(indent+'except');
+      rslt.Add(indent+'  on E: Exception do');
+      rslt.Add(indent+'    success := (E is EDOMError) and (EDOMError(E).Code = ' + excode + ');');
+      rslt.Add(indent+'end;');
+      rslt.Add(indent+'AssertTrue('''+element['id']+''', success);');
+    end
+    else if n = 'try' then
+    begin
+      GetChildElements(curr, List);
+      rslt.Add(indent+'try');
+      I := 0;
+      while I < List.Count do
+      begin
+        Child := TDOMNode(List[I]);
+        if Child.NodeName = 'catch' then
+          break;
+        ConvertStatement(TDOMElement(child), indent + '  ');
+        Inc(I);
+      end;
+      if (child.NodeName <> 'catch') or (Pointer(Child) <> List.Last) then
+        rslt.Add('{ ERROR: misplaced "catch" tag }');
+      GetChildElements(child, List);
+      cond := '';
+      for I := 0 to List.Count-1 do
+      begin
+        if TDOMElement(List[I]).TagName <> 'DOMException' then
+        begin
+          rslt.Add('{ ERROR: unhandled: ' + TDOMElement(List[I]).TagName +' }');
+          Break;
+        end;
+        if cond <> '' then cond := cond + ', ';
+        cond := cond + TDOMElement(List[I])['code'];
+      end;
+      
+      rslt.Add(indent+'except');
+      rslt.Add(indent+'  on E: EDOMError do');
+      rslt.Add(indent+'    if not (E.code in ['+cond+']) then raise;');
+      rslt.Add(indent+'end;');
+    end
+    else if n = 'if' then
+    begin
+      ElseNode := nil;
+      GetChildElements(curr, List);
+      if (List.Count > 1) and CondToStr(TDOMElement(List[0]), cond) then
+      begin
+        rslt.Add(indent+ 'if '+cond+' then');
+        frag := curr.OwnerDocument.CreateDocumentFragment;
+        try
+          // first node is the condition; skip it
+          for I := 1 to List.Count-1 do
+          begin
+            child := TDOMNode(List[I]);
+            if child.NodeName = 'else' then
+            begin
+              ElseNode := child;
+              Break;
+            end;
+            frag.AppendChild(child.CloneNode(True));
+          end;
+          rslt.add(indent+'begin');
+          ConvertBlock(frag, indent);
+          if Assigned(ElseNode) then
+          begin
+            rslt.add(indent+'end');
+            rslt.Add(indent+'else');
+            rslt.Add(indent+'begin');
+            ConvertBlock(ElseNode, indent);
+          end;
+          rslt.add(indent+'end;');
+        finally
+          frag.Free;
+        end;
+      end
+      else
+      begin
+        rslt.Add('{ ERROR: malformed "if" tag }');
+        dumpunprocessed(element, rslt);
+      end;
+    end
+    else if n = 'for-each' then
+    begin
+      // having loop var name globally unique isn't a must.
+      cond := 'loop'+IntToStr(cntr);
+      Inc(cntr);
+      rslt.Insert(2, '  ' + cond + ': Integer;');
+      IsColl := IsCollection(element);
+      if IsColl then
+        rslt.Add(indent+'for '+cond+' := 0 to ' + 'High(' + element['collection'] + ') do')
+      else
+        rslt.Add(indent+'for '+cond+' := 0 to ' + element['collection'] + '.Length-1 do');
+      rslt.Add(indent+'begin');
+      if IsColl then
+        rslt.Add(indent+'  ' + element['member'] + ' := '+element['collection']+'['+cond+'];')
+      else
+        rslt.Add(indent+'  ' + 'TDOMNode('+element['member'] + ') := '+element['collection']+'['+cond+'];');
+      ConvertBlock(element, indent);
+      rslt.Add(indent+'end;');
+    end
+    else if n = 'while' then
+    begin
+      GetChildElements(curr, List);
+      if (List.Count > 1) and CondToStr(TDOMElement(List[0]), cond) then
+      begin
+        rslt.Add(indent+ 'while '+cond+' do');
+        frag := curr.OwnerDocument.CreateDocumentFragment;
+        try
+          for I := 1 to List.Count-1 do  // skip first node which is the condition
+          begin
+            child := TDOMNode(List[I]);
+            frag.AppendChild(child.CloneNode(True));
+          end;
+          rslt.add(indent+'begin');
+          ConvertBlock(frag, indent);
+          rslt.add(indent+'end;');
+        finally
+          frag.Free;
+        end;
+      end
+      else
+      begin
+        rslt.Add('{ ERROR: malformed "while" tag }');
+        DumpUnprocessed(element, rslt);
+      end;
+    end
+    else
+      ConvertStatement(element, indent);
+    curr := curr.NextSibling;
+  end;
+  List.Free;
+end;
+
+procedure ConvertVars;
+var
+  TypedConsts: TStrings;
+  I, J: Integer;
+  vars, subvars: TDOMNodeList;
+  node: TDOMElement;
+  hs: string;
+begin
+  TypedConsts := TStringList.Create;
+  vars := rootNode.GetElementsByTagName('var');
+  if vars.Count > 0 then
+  begin
+    rslt.Add('var');
+    for I := 0 to vars.Count-1 do
+    begin
+      node := TDOMElement(vars[I]);
+      FixKeywords(node, 'name');
+      if node.hasAttribute('isNull') or node.hasAttribute('value') then
+      begin
+        // TODO: isNull is identified by 'yes' value, not by mere attr presence?
+        // TODO: consider putting isNull things to constants
+        if node.hasAttribute('value') then
+          hs := ReplaceQuotes(Node['value'])
+        else
+        begin
+          if node['type'] = 'DOMString' then
+            hs := ''''''
+          else
+            hs := 'nil';
+        end;
+        Inits.Add('  ' + node['name'] + ' := ' + hs + ';');
+      end;
+      if Node.HasChildNodes then
+      begin
+        subvars := Node.GetElementsByTagName('member');
+        try
+          if subvars.Count > 0 then
+          begin
+            TypedConsts.Add('  ' + Node['name'] + ': array[0..' + IntToStr(subvars.Count-1) + '] of DOMString = (');
+            for J := 0 to subvars.Count-1 do
+            begin
+              hs := '    ' + ReplaceQuotes(subvars[J].TextContent);
+              if J = subvars.Count-1 then
+                TypedConsts.Add(hs + ');')
+              else
+                TypedConsts.Add(hs + ',');
+            end;
+          end
+          else
+            DumpUnprocessed(Node, rslt);
+        finally
+          subvars.Free;
+        end;
+      end
+      else
+        rslt.Add('  ' + Node['name'] +': '+ PascalType(Node['type'])+';');
+      VarTypes.Add(Node['name'] + '=' + PascalType(Node['type']));
+    end;
+    if TypedConsts.Count > 0 then
+    begin
+      rslt.add('const');
+      rslt.AddStrings(TypedConsts);
+    end;
+  end;
+  vars.Free;
+  TypedConsts.Free;
+end;
+
+// ConvertTest() itself
+begin
+  SuccessVarFlag := False;
+  FailFlag := False;
+  VarTypes := TStringList.Create;
+  Inits := TStringList.Create;
+  ConvertVars;
+  rslt.add('begin');
+  rslt.AddStrings(Inits);
+  Inits.Free;
+  ConvertBlock(rootNode, '');
+  VarTypes.Free;
+  rslt.add('end;');
+  rslt.Add('');
+  
+  if FailFlag then
+  begin
+    if not forced then
+      rslt.Clear;
+    Inc(FailCount);
+  end;
+end;
+
+// Intercepting validation errors while loading API
+type
+  TErrHandler = class(TObject)
+  public
+    procedure HandleError(E: EXMLReadError);
+  end;
+
+procedure TErrHandler.HandleError(E: EXMLReadError);
+begin
+  raise E;
+end;
+
+const
+  UnitHeader =
+
+'{ AUTOGENERATED FILE - DO NOT EDIT'#10+
+'  This Pascal source file was generated by testgen program'#10 +
+'  and is a derived work from the source document.'#10 +
+'  The source document contained the following notice:'#10+
+'%s}'#10+
+'unit %s;'#10 +
+'{$mode objfpc}{$h+}'#10 +
+'{$notes off}'#10 +
+'{$codepage utf8}'#10 +
+'interface'#10 +
+#10 +
+'uses'#10 +
+'  SysUtils, Classes, DOM, xmlread, fpcunit, contnrs, domunit, testregistry;'#10 +
+#10 +
+'type'#10 +
+'  %s = class(TDOMTestBase)'#10 +
+'  protected'#10 +
+'    function GetTestFilesURI: string; override;'#10 +
+'  published'#10;
+
+procedure ConvertSuite(const BaseURI: DOMString; const UnitFileName: string);
+var
+  suite, testdoc: TXMLDocument;
+  testlist: TDOMNodeList;
+  root: TDOMElement;
+  href, testuri: DOMString;
+  I: Integer;
+  sl, all, impl: TStringList;
+  Pars: TDOMParser;
+  eh: TErrHandler;
+  class_name, unit_name, notice: string;
+  comment: TDOMNode;
+begin
+  Pars := TDOMParser.Create;
+  eh := TErrHandler.Create;
+  Pars.Options.Validate := True;
+  Pars.OnError := @eh.HandleError;
+  // API database must be loaded in validating mode
+  Pars.ParseURI('file:api.xml', api);
+
+  sl := TStringList.Create;
+  all := TStringList.Create;
+  impl := TStringList.Create;
+
+  Pars.OnError := nil;
+  Pars.Options.ExpandEntities := True;
+  Pars.ParseURI(BaseURI + 'alltests.xml', suite);
+  // extract the copyright notice
+  notice := '';
+  comment := suite.FirstChild;
+  while Assigned(comment) do
+  begin
+    if (comment.nodeType = COMMENT_NODE) and
+      (Pos(DOMString('Copyright'), comment.nodeValue) > 0) then
+    begin
+      notice := comment.nodeValue;
+      Break;
+    end;
+    comment := comment.nextSibling;
+  end;
+
+  unit_name := ChangeFileExt(ExtractFileName(UnitFileName), '');
+  class_name := 'TTest' + UpperCase(unit_name[1]) + copy(unit_name, 2, MaxInt);
+  // provide unit header
+  all.Text := Format(UnitHeader, [notice, unit_name, class_name]);
+  // emit the 'GetPathToModuleFiles' function body
+  impl.Add('implementation');
+  impl.Add('');
+  impl.Add('function '+class_name+'.GetTestFilesURI: string;');
+  impl.Add('begin');
+  impl.Add('  result := ''' + BaseURI + ''';');
+  impl.Add('end;');
+  impl.Add('');
+  
+  testlist := suite.GetElementsByTagName('suite.member');
+  testcount := testlist.Count;
+  writeln;
+  writeln(testcount, ' test cases found');
+  for I := 0 to testcount-1 do
+  begin
+    href := TDOMElement(testlist[I])['href'];
+    // simple concatenation should suffice, but be paranoid
+    ResolveRelativeURI(BaseURI, href, testuri);
+    Pars.ParseURI(testuri, testdoc);
+    try
+      sl.Clear;
+      root := testdoc.DocumentElement;
+      // fix clash with local vars having the same name
+      if root['name'] = 'attrname' then
+        root['name'] := 'attr_name';
+      sl.Add('procedure ' + class_name + '.' + root['name'] + ';');
+      ConvertTest(root, sl);
+      if sl.Count > 0 then
+      begin
+        all.add('    procedure '+root['name']+';');
+        impl.AddStrings(sl)
+      end;
+    finally
+      testdoc.Free;
+    end;
+  end;
+  testlist.Free;
+  suite.Free;
+
+  // terminate class declaration
+  all.Add('  end;');
+  all.Add('');
+  // append all procedure bodies
+  all.AddStrings(impl);
+
+  all.Add('initialization');
+  all.Add('  RegisterTest('+class_name+');');
+  all.Add('end.');
+  all.SaveToFile(UnitFileName);
+  impl.Free;
+  all.Free;
+  sl.Free;
+  eh.Free;
+  Pars.Free;
+end;
+
+var
+  SuiteName: string;
+  OutputUnit: string;
+  s: string;
+  I: Integer;
+
+begin
+  writeln('testgen - w3.org DOM test suite to Pascal converter');
+  writeln('Copyright (c) 2008 by Sergei Gorelkin');
+  
+  if ParamCount < 2 then
+  begin
+    writeln;
+    writeln('Usage: ', ParamStr(0), ' <suite dir> <outputunit.pp> [-f]');
+    writeln('  -f: force conversion of tests which contain unknown tags');
+    Exit;
+  end;
+
+  SuiteName := ExpandFilename(ParamStr(1));
+  OutputUnit := ExpandFilename(ParamStr(2));
+  i := 3;
+  while i <= ParamCount do
+  begin
+    s := Lowercase(ParamStr(i));
+    if s = '-f' then
+      forced := True;
+    Inc(i);
+  end;
+  // strip filename if present, we're going to read all dir
+  if not DirectoryExists(SuiteName) then
+    SuiteName := ExtractFilePath(SuiteName)
+  else
+    SuiteName := IncludeTrailingPathDelimiter(SuiteName);
+
+  ConvertSuite(FilenameToURI(SuiteName), OutputUnit);
+
+  writeln(testcount - FailCount, ' tests converted successfully');
+  if FailCount > 0 then
+  begin
+    writeln(FailCount, ' tests contain tags that are not supported yet');
+    if forced then
+    begin
+      writeln('Conversion of these tests was forced,');
+      writeln('the resulting file may not compile!');
+    end
+    else
+      writeln('These tests were skipped');
+  end;
+end.
+

packages/fcl-xml/tests/xmlts.pp

@@ -333,7 +333,7 @@ begin
 
   if FPassed = 0 then
     FState := 'N/A'
-  else if FPassed = FTotal then
+  else if FPassed = FTotal - FSkipped then
     FState := 'CONFORMS (provisionally)'
   else
     FState := 'DOES NOT CONFORM';