From 78b41cd8f6aebe46cd67f2e9fc57da283d43b900 Mon Sep 17 00:00:00 2001 From: sergei Date: Thu, 1 Oct 2009 19:29:13 +0000 Subject: [PATCH] + XML writer now performs the namespace normalization. git-svn-id: trunk@13789 - --- packages/fcl-xml/src/dom.pp | 1 + packages/fcl-xml/src/xmlutils.pp | 171 ++++++++++++++++++++++++++++++- packages/fcl-xml/src/xmlwrite.pp | 92 ++++++++++++++++- 3 files changed, 260 insertions(+), 4 deletions(-) diff --git a/packages/fcl-xml/src/dom.pp b/packages/fcl-xml/src/dom.pp index 4c2e791caf..ff1e9302cb 100644 --- a/packages/fcl-xml/src/dom.pp +++ b/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; diff --git a/packages/fcl-xml/src/xmlutils.pp b/packages/fcl-xml/src/xmlutils.pp index 4280bc4f92..d8c5c1a6ab 100644 --- a/packages/fcl-xml/src/xmlutils.pp +++ b/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 diff --git a/packages/fcl-xml/src/xmlwrite.pp b/packages/fcl-xml/src/xmlwrite.pp index 7ca4e9f1ef..9ff777ce23 100644 --- a/packages/fcl-xml/src/xmlwrite.pp +++ b/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);