+ XML writer now performs the namespace normalization.

git-svn-id: trunk@13789 -

packages/fcl-xml/src/dom.pp

@@ -260,6 +260,7 @@ type
     function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; virtual;
     function FindNode(const ANodeName: DOMString): TDOMNode; virtual;
     function CompareName(const name: DOMString): Integer; virtual;
+    property Flags: TNodeFlags read FFlags;
   end;
 
   TDOMNodeClass = class of TDOMNode;

packages/fcl-xml/src/xmlutils.pp

@@ -20,7 +20,7 @@ unit xmlutils;
 interface
 
 uses
-  SysUtils;
+  SysUtils, Classes;
 
 function IsXmlName(const Value: WideString; Xml11: Boolean = False): Boolean; overload;
 function IsXmlName(Value: PWideChar; Len: Integer; Xml11: Boolean = False): Boolean; overload;
@@ -40,6 +40,7 @@ function WStrLIComp(S1, S2: PWideChar; Len: Integer): Integer;
 type
 {$ifndef fpc}
   PtrInt = LongInt;
+  TFPList = TList;
 {$endif}  
 
   PPHashItem = ^PHashItem;
@@ -100,6 +101,36 @@ type
     destructor Destroy; override;
   end;
 
+  TBinding = class
+  public
+    uri: WideString;
+    next: TBinding;
+    prevPrefixBinding: TObject;
+    Prefix: PHashItem;
+  end;
+
+  TAttributeAction = (aaUnchanged, aaPrefix, aaBoth);
+
+  TNSSupport = class(TObject)
+  private
+    FNesting: Integer;
+    FPrefixSeqNo: Integer;
+    FFreeBindings: TBinding;
+    FBindings: TFPList;
+    FBindingStack: array of TBinding;
+    FPrefixes: THashTable;
+    FDefaultPrefix: THashItem;
+    function GetBinding(const nsURI: WideString; aPrefix: PHashItem): TBinding;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure DefineBinding(const Prefix, nsURI: WideString; out Binding: TBinding);
+    function CheckAttribute(const Prefix, nsURI: WideString;
+      out Binding: TBinding): TAttributeAction;
+    procedure StartElement;
+    procedure EndElement;
+  end;
+
 {$i names.inc}
 
 implementation
@@ -625,6 +656,144 @@ begin
   result := False;
 end;
 
+{ TNSSupport }
+
+constructor TNSSupport.Create;
+begin
+  inherited Create;
+  FPrefixes := THashTable.Create(16, False);
+  FBindings := TFPList.Create;
+  SetLength(FBindingStack, 16);
+end;
+
+destructor TNSSupport.Destroy;
+var
+  I: Integer;
+begin
+  for I := FBindings.Count-1 downto 0 do
+    TObject(FBindings.List^[I]).Free;
+  FBindings.Free;
+  FPrefixes.Free;
+  inherited Destroy;
+end;
+
+function TNSSupport.GetBinding(const nsURI: WideString; aPrefix: PHashItem): TBinding;
+begin
+  { try to reuse an existing binding }
+  result := FFreeBindings;
+  if Assigned(result) then
+    FFreeBindings := result.Next
+  else { no free bindings, create a new one }
+  begin
+    result := TBinding.Create;
+    FBindings.Add(result);
+  end;
+
+  { link it into chain of bindings at the current element level }
+  result.Next := FBindingStack[FNesting];
+  FBindingStack[FNesting] := result;
+
+  { bind }
+  result.uri := nsURI;
+  result.Prefix := aPrefix;
+  result.PrevPrefixBinding := aPrefix^.Data;
+  aPrefix^.Data := result; // ** null binding not used here **
+end;
+
+procedure TNSSupport.DefineBinding(const Prefix, nsURI: WideString;
+  out Binding: TBinding);
+var
+  Pfx: PHashItem;
+begin
+  Pfx := @FDefaultPrefix;
+  if (nsURI <> '') and (Prefix <> '') then
+    Pfx := FPrefixes.FindOrAdd(PWideChar(Prefix), Length(Prefix));
+  if (Pfx^.Data = nil) or (TBinding(Pfx^.Data).uri <> nsURI) then
+    Binding := GetBinding(nsURI, Pfx)
+  else
+    Binding := nil;
+end;
+
+function TNSSupport.CheckAttribute(const Prefix, nsURI: WideString;
+  out Binding: TBinding): TAttributeAction;
+var
+  Pfx: PHashItem;
+  I: Integer;
+  b: TBinding;
+  buf: array[0..31] of WideChar;
+  p: PWideChar;
+begin
+  Binding := nil;
+  Pfx := nil;
+  if Prefix <> '' then
+    Pfx := FPrefixes.FindOrAdd(PWideChar(Prefix), Length(Prefix));
+  Result := aaUnchanged;
+  // no prefix, not bound, or bound to wrong URI
+  if (Pfx = nil) or (Pfx^.Data = nil) or (TBinding(Pfx^.Data).uri <> nsURI) then
+  begin
+    // see if there's another prefix bound to the target URI
+    // TODO: should use something faster than linear search
+    for i := FNesting downto 0 do
+    begin
+      b := FBindingStack[i];
+      while Assigned(b) do
+      begin
+        if (b.uri = nsURI) and (b.Prefix <> @FDefaultPrefix) then
+        begin
+          Binding := b;   // found one -> override the attribute's prefix
+          Result := aaPrefix;
+          Exit;
+        end;
+        b := b.Next;
+      end;
+    end;
+    // no prefix, or bound (to wrong URI) -> must use generated prefix instead
+    if (Pfx = nil) or Assigned(Pfx^.Data) then
+    repeat
+      Inc(FPrefixSeqNo);
+      i := FPrefixSeqNo;    // This is just 'NS'+IntToStr(FPrefixSeqNo);
+      p := @Buf[high(Buf)]; // done without using strings
+      while i <> 0 do
+      begin
+        p^ := WideChar(i mod 10+ord('0'));
+        dec(p);
+        i := i div 10;
+      end;
+      p^ := 'S'; dec(p);
+      p^ := 'N';
+      Pfx := FPrefixes.FindOrAdd(p, @Buf[high(Buf)]-p+1);
+    until Pfx^.Data = nil;
+    Binding := GetBinding(nsURI, Pfx);
+    Result := aaBoth;
+  end;
+end;
+
+procedure TNSSupport.StartElement;
+begin
+  Inc(FNesting);
+  if FNesting >= Length(FBindingStack) then
+    SetLength(FBindingStack, FNesting * 2);
+end;
+
+procedure TNSSupport.EndElement;
+var
+  b, temp: TBinding;
+begin
+  temp := FBindingStack[FNesting];
+  while Assigned(temp) do
+  begin
+    b := temp;
+    temp := b.next;
+    b.next := FFreeBindings;
+    FFreeBindings := b;
+    b.Prefix^.Data := b.prevPrefixBinding;
+  end;
+  FBindingStack[FNesting] := nil;
+  if FNesting > 0 then
+    Dec(FNesting);
+end;
+
+
 initialization
 
 finalization

packages/fcl-xml/src/xmlwrite.pp

@@ -37,7 +37,7 @@ procedure WriteXML(Element: TDOMNode; AStream: TStream); overload;
 
 implementation
 
-uses SysUtils;
+uses SysUtils, xmlutils;
 
 type
   TSpecialCharCallback = procedure(c: WideChar) of object;
@@ -51,6 +51,8 @@ type
     FBufPos: PChar;
     FCapacity: Integer;
     FLineBreak: string;
+    FNSHelper: TNSSupport;
+    FScratch: TFPList;
     procedure wrtChars(Src: PWideChar; Length: Integer);
     procedure IncIndent;
     procedure DecIndent; {$IFDEF HAS_INLINE} inline; {$ENDIF}
@@ -62,6 +64,8 @@ type
       const SpecialCharCallback: TSpecialCharCallback);
     procedure AttrSpecialCharCallback(c: WideChar);
     procedure TextNodeSpecialCharCallback(c: WideChar);
+    procedure WriteNSDef(B: TBinding);
+    procedure NamespaceFixup(Element: TDOMElement);
   protected
     procedure Write(const Buffer; Count: Longint); virtual; abstract;
     procedure WriteNode(Node: TDOMNode);
@@ -159,10 +163,14 @@ begin
   // Later on, this may be put under user control
   // for now, take OS setting
   FLineBreak := sLineBreak;
+  FNSHelper := TNSSupport.Create;
+  FScratch := TFPList.Create;
 end;
 
 destructor TXMLWriter.Destroy;
 begin
+  FScratch.Free;
+  FNSHelper.Free;
   if FBufPos > FBuffer then
     write(FBuffer^, FBufPos-FBuffer);
 
@@ -362,6 +370,80 @@ begin
   end;
 end;
 
+procedure TXMLWriter.WriteNSDef(B: TBinding);
+begin
+  wrtChars(' xmlns', 6);
+  if B.Prefix^.Key <> '' then
+  begin
+    wrtChr(':');
+    wrtStr(B.Prefix^.Key);
+  end;
+  wrtChars('="', 2);
+  ConvWrite(B.uri, AttrSpecialChars, {$IFDEF FPC}@{$ENDIF}AttrSpecialCharCallback);
+  wrtChr('"');
+end;
+
+procedure TXMLWriter.NamespaceFixup(Element: TDOMElement);
+var
+  B: TBinding;
+  i: Integer;
+  attr: TDOMNode;
+  s: DOMString;
+  action: TAttributeAction;
+begin
+  FScratch.Count := 0;
+  if Element.hasAttributes then
+  begin
+    for i := 0 to Element.Attributes.Length-1 do
+    begin
+      attr := Element.Attributes[i];
+      if nfLevel2 in attr.Flags then
+      begin
+        if TDOMNode_NS(attr).NSI.NSIndex = 2 then
+        begin
+          if TDOMNode_NS(attr).NSI.PrefixLen = 0 then
+            s := ''
+          else
+            s := attr.localName;
+          FNSHelper.DefineBinding(s, attr.nodeValue, B);
+          if Assigned(B) then  // drop redundant namespace declarations
+            VisitAttribute(attr);
+        end
+        else
+          FScratch.Add(attr);
+      end
+      else if TDOMAttr(attr).Specified then // Level 1 attribute
+        VisitAttribute(attr);
+    end;
+  end;
+
+  FNSHelper.DefineBinding(Element.Prefix, Element.namespaceURI, B);
+  if Assigned(B) then
+    WriteNSDef(B);
+
+  for i := 0 to FScratch.Count-1 do
+  begin
+    attr := TDOMNode(FScratch[i]);
+    action := FNSHelper.CheckAttribute(attr.Prefix, attr.namespaceURI, B);
+    if action = aaBoth then
+      WriteNSDef(B);
+
+    if action in [aaPrefix, aaBoth] then
+    begin
+      // use prefix from the binding, it might have been changed
+      wrtChr(' ');
+      wrtStr(B.Prefix^.Key);
+      wrtChr(':');
+      wrtStr(attr.localName);
+      wrtChars('="', 2);
+      // TODO: not correct w.r.t. entities
+      ConvWrite(attr.nodeValue, AttrSpecialChars, {$IFDEF FPC}@{$ENDIF}AttrSpecialCharCallback);
+      wrtChr('"');
+    end
+    else   // action = aaUnchanged, output unmodified
+      VisitAttribute(attr);
+  end;
+end;
 
 procedure TXMLWriter.VisitElement(node: TDOMNode);
 var
@@ -371,10 +453,13 @@ var
 begin
   if not FInsideTextNode then
     wrtIndent;
+  FNSHelper.StartElement;
   wrtChr('<');
   wrtStr(TDOMElement(node).TagName);
-  // FIX: Accessing Attributes was causing them to be created for every element :(
-  if node.HasAttributes then
+
+  if nfLevel2 in node.Flags then
+    NamespaceFixup(TDOMElement(node))
+  else if node.HasAttributes then
     for i := 0 to node.Attributes.Length - 1 do
     begin
       child := node.Attributes.Item[i];
@@ -402,6 +487,7 @@ begin
     wrtStr(TDOMElement(Node).TagName);
     wrtChr('>');
   end;
+  FNSHelper.EndElement;
 end;
 
 procedure TXMLWriter.VisitText(node: TDOMNode);