* TDOMDocument now checks its children and allows only a single Element/DocType child. This fixes about 8 test cases at Level 3.

+ Initial moves to implement TDOMNode.BaseURI (not yet functional)

git-svn-id: trunk@13809 -

packages/fcl-xml/src/dom.pp

@@ -216,6 +216,7 @@ type
     function GetPrefix: DOMString; virtual;
     procedure SetPrefix(const Value: DOMString); virtual;
     function GetOwnerDocument: TDOMDocument; virtual;
+    function GetBaseURI: DOMString;
     procedure SetReadOnly(Value: Boolean);
     procedure Changing;
   public
@@ -258,6 +259,7 @@ type
     function LookupPrefix(const nsURI: DOMString): DOMString;
     function LookupNamespaceURI(const APrefix: DOMString): DOMString;
     function IsDefaultNamespace(const nsURI: DOMString): Boolean;
+    property baseURI: DOMString read GetBaseURI;
     // Extensions to DOM interface:
     function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; virtual;
     function FindNode(const ANodeName: DOMString): TDOMNode; virtual;
@@ -453,6 +455,8 @@ type
     function Alloc(AClass: TDOMNodeClass): TDOMNode;
   public
     function IndexOfNS(const nsURI: DOMString; AddIfAbsent: Boolean = False): Integer;
+    function InsertBefore(NewChild, RefChild: TDOMNode): TDOMNode; override;
+    function ReplaceChild(NewChild, OldChild: TDOMNode): TDOMNode; override;
     property DocType: TDOMDocumentType read GetDocType;
     property Impl: TDOMImplementation read FImplementation;
     property DocumentElement: TDOMElement read GetDocumentElement;
@@ -1239,6 +1243,22 @@ begin
   result := GetAncestorElement(Self).IsDefaultNamespace(nsURI);
 end;
 
+function TDOMNode.GetBaseURI: DOMString;
+begin
+  case NodeType of
+  // !! Incomplete !!
+    DOCUMENT_NODE:
+      result := TDOMDocument(Self).FDocumentURI;
+    PROCESSING_INSTRUCTION_NODE:
+      if Assigned(ParentNode) then
+        result := ParentNode.GetBaseURI
+      else
+        result := OwnerDocument.DocumentURI;
+  else
+    result := '';
+  end;
+end;
+
 //------------------------------------------------------------------------------
 
 function CompareDOMNodeWithDOMNode(Node1, Node2: Pointer): integer;
@@ -2212,6 +2232,32 @@ begin
   Result := nil;
 end;
 
+function TDOMDocument.InsertBefore(NewChild, RefChild: TDOMNode): TDOMNode;
+var
+  nType: Integer;
+begin
+  nType := NewChild.NodeType;
+  if ((nType = ELEMENT_NODE) and Assigned(DocumentElement)) or
+     ((nType = DOCUMENT_TYPE_NODE) and Assigned(DocType)) then
+       raise EDOMHierarchyRequest.Create('Document.InsertBefore');
+  Result := inherited InsertBefore(NewChild, RefChild);
+end;
+
+function TDOMDocument.ReplaceChild(NewChild, OldChild: TDOMNode): TDOMNode;
+var
+  nType: Integer;
+begin
+  nType := NewChild.NodeType;
+  if ((nType = ELEMENT_NODE) and (OldChild = DocumentElement)) or   // root can be replaced by another element
+     ((nType = DOCUMENT_TYPE_NODE) and (OldChild = DocType)) then   // and so can be DTD
+  begin
+    inherited InsertBefore(NewChild, OldChild);
+    Result := RemoveChild(OldChild);
+  end
+  else
+    Result := inherited ReplaceChild(NewChild, OldChild);
+end;
+
 function TDOMDocument.GetDocumentElement: TDOMElement;
 var
   node: TDOMNode;

packages/fcl-xml/src/xmlread.pp

@@ -94,7 +94,7 @@ type
   private
     FStream: TStream;
     FStringData: string;
-//    FBaseURI: WideString;
+    FBaseURI: WideString;
     FSystemID: WideString;
     FPublicID: WideString;
 //    FEncoding: string;
@@ -103,7 +103,7 @@ type
     constructor Create(const AStringData: string); overload;
     property Stream: TStream read FStream;
     property StringData: string read FStringData;
-//    property BaseURI: WideString read FBaseURI write FBaseURI;
+    property BaseURI: WideString read FBaseURI write FBaseURI;
     property SystemID: WideString read FSystemID write FSystemID;
     property PublicID: WideString read FPublicID write FPublicID;
 //    property Encoding: string read FEncoding write FEncoding;
@@ -435,7 +435,7 @@ type
     procedure ExpectChoiceOrSeq(CP: TContentParticle);
     procedure ParseElementDecl;
     procedure ParseNotationDecl;
-    function ResolveEntity(const AbsSysID, PublicID: WideString; out Source: TXMLCharSource): Boolean;
+    function ResolveEntity(const AbsSysID, PublicID, BaseURI: WideString; out Source: TXMLCharSource): Boolean;
     procedure ProcessDefaultAttributes(Element: TDOMElement; Map: TDOMNamedNodeMap);
     procedure ProcessNamespaceAtts(Element: TDOMElement);
     procedure AddBinding(Attr: TDOMAttr; Prefix: PHashItem; var Chain: TBinding);
@@ -744,7 +744,7 @@ begin
   ADoc := nil;
   with TXMLReader.Create(Self) do
   try
-    if ResolveEntity(URI, '', Src) then
+    if ResolveEntity(URI, '', '', Src) then
       ProcessXML(Src)
     else
       DoErrorPos(esFatal, 'The specified URI could not be resolved', NullLocation);
@@ -1164,7 +1164,7 @@ begin
     else if SrcIn.FStringData <> '' then
       SrcOut := TXMLStreamInputSource.Create(TStringStream.Create(SrcIn.FStringData), True)
     else if (SrcIn.SystemID <> '') then
-      ResolveEntity(SrcIn.SystemID, SrcIn.PublicID, SrcOut);
+      ResolveEntity(SrcIn.SystemID, SrcIn.PublicID, SrcIn.BaseURI, SrcOut);
   end;
   if (SrcOut = nil) and (FSource = nil) then
     DoErrorPos(esFatal, 'No input source specified', NullLocation);
@@ -1176,7 +1176,7 @@ begin
   Loc.LinePos := FSource.FBuf-FSource.LFPos;
 end;
 
-function TXMLReader.ResolveEntity(const AbsSysID, PublicID: WideString; out Source: TXMLCharSource): Boolean;
+function TXMLReader.ResolveEntity(const AbsSysID, PublicID, BaseURI: WideString; out Source: TXMLCharSource): Boolean;
 var
   Filename: string;
   Stream: TStream;
@@ -1732,7 +1732,7 @@ var
 begin
   if (AEntity.SystemID <> '') and not AEntity.FResolved then
   begin
-    Result := ResolveEntity(AEntity.FURI, AEntity.PublicID, Src);
+    Result := ResolveEntity(AEntity.FURI, AEntity.PublicID, '', Src);
     if not Result then
     begin
       // TODO: a detailed message like SysErrorMessage(GetLastError) would be great here 
@@ -2180,7 +2180,7 @@ begin
   if (FDocType.SystemID <> '') then
   begin
     ResolveRelativeURI(FSource.SystemID, FDocType.SystemID, DoctypeURI);
-    if ResolveEntity(DocTypeURI, FDocType.PublicID, Src) then
+    if ResolveEntity(DocTypeURI, FDocType.PublicID, '', Src) then
     begin
       Initialize(Src);
       try