* fcl-xml, improved TNSSupport class to work directly with hashed strings, reduces amount of hash lookups.

git-svn-id: trunk@20538 -

packages/fcl-xml/src/xmlread.pp

@@ -1409,7 +1409,7 @@ begin
   FCurrAttrIndex := -1;
   if FNamespaces then
   begin
-    FNSHelper := TNSSupport.Create;
+    FNSHelper := TNSSupport.Create(FNameTable);
     FNsAttHash := TDblHashArray.Create;
     FStdPrefix_xml := FNSHelper.GetPrefix(@PrefixDefault, 3);
     FStdPrefix_xmlns := FNSHelper.GetPrefix(@PrefixDefault, 5);
@@ -2946,18 +2946,11 @@ begin
 end;
 
 function TXMLTextReader.LookupNamespace(const APrefix: XMLString): XMLString;
-var
-  prefixatom: PHashItem;
-  b: TBinding;
 begin
-  result := '';
-  if FNamespaces then
-  begin
-    prefixatom := FNSHelper.GetPrefix(PWideChar(APrefix),Length(APrefix));
-    b := TBinding(prefixatom^.Data);
-    if Assigned(b) then
-      result := b.Uri;
-  end;
+  if Assigned(FNSHelper) then
+    result := FNSHelper.LookupNamespace(APrefix)
+  else
+    result := '';
 end;
 
 function TXMLTextReader.MoveToFirstAttribute: Boolean;
@@ -3739,7 +3732,7 @@ begin
 
   if FNamespaces then
   begin
-    FNSHelper.StartElement;
+    FNSHelper.PushScope;
     if FColonPos > 0 then
       FCurrNode^.FPrefix := FNSHelper.GetPrefix(FName.Buffer, FColonPos);
   end;
@@ -3774,15 +3767,15 @@ begin
     if Assigned(FCurrNode^.FPrefix) then
     begin
       b := TBinding(FCurrNode^.FPrefix^.Data);
-      if not (Assigned(b) and (b.uri <> '')) then
+      if not (Assigned(b) and Assigned(b.uri) and (b.uri^.Key <> '')) then
         DoErrorPos(esFatal, 'Unbound element name prefix "%s"', [FCurrNode^.FPrefix^.Key],FCurrNode^.FLoc);
-      FCurrNode^.FNsUri := FNameTable.FindOrAdd(b.uri);
+      FCurrNode^.FNsUri := b.uri;
     end
     else
     begin
       b := FNSHelper.DefaultNSBinding;
       if Assigned(b) then
-        FCurrNode^.FNsUri := FNameTable.FindOrAdd(b.uri);
+        FCurrNode^.FNsUri := b.uri;
     end;
   end;
 
@@ -3990,9 +3983,9 @@ begin
   if (attrData^.FValueStr = '') and not (FXML11 or (Pfx^.Key = '')) then
     DoErrorPos(esFatal, 'Illegal undefining of namespace', attrData^.FLoc2);
 
-  Result := (Pfx^.Data = nil) or (TBinding(Pfx^.Data).uri <> attrData^.FValueStr);
+  Result := (Pfx^.Data = nil) or (TBinding(Pfx^.Data).uri <> nsUri);
   if Result then
-    FNSHelper.BindPrefix(attrData^.FValueStr, Pfx);
+    FNSHelper.BindPrefix(nsUri, Pfx);
 end;
 
 procedure TXMLTextReader.ProcessNamespaceAtts;
@@ -4011,17 +4004,17 @@ begin
 
     Pfx := attrData^.FPrefix;
     b := TBinding(Pfx^.Data);
-    if not (Assigned(b) and (b.uri <> '')) then
+    if not (Assigned(b) and Assigned (b.uri) and (b.uri^.Key <> '')) then
       DoErrorPos(esFatal, 'Unbound attribute name prefix "%s"', [Pfx^.Key], attrData^.FLoc);
 
     { detect duplicates }
     J := attrData^.FColonPos+1;
     AttrName := attrData^.FQName;
 
-    if FNsAttHash.Locate(@b.uri, @AttrName^.Key[J], Length(AttrName^.Key) - J+1) then
+    if FNsAttHash.Locate(b.uri, @AttrName^.Key[J], Length(AttrName^.Key) - J+1) then
       DoErrorPos(esFatal, 'Duplicate prefixed attribute', attrData^.FLoc);
 
-    attrData^.FNsUri := FNameTable.FindOrAdd(b.uri);
+    attrData^.FNsUri := b.uri;
   end;
 end;
 
@@ -4256,7 +4249,7 @@ end;
 procedure TXMLTextReader.PopElement;
 begin
   if FNamespaces then
-    FNSHelper.EndElement;
+    FNSHelper.PopScope;
 
   if (FNesting = 0) and (not FFragmentMode) then
     FState := rsEpilog;

packages/fcl-xml/src/xmlutils.pp

@@ -123,7 +123,7 @@ type
   TExpHashEntry = record
     rev: LongWord;
     hash: LongWord;
-    uriPtr: PXMLString;
+    uriPtr: Pointer;
     lname: PWideChar;
     lnameLen: Integer;
   end;
@@ -137,7 +137,7 @@ type
     FData: PExpHashEntryArray;
   public  
     procedure Init(NumSlots: Integer);
-    function Locate(uri: PXMLString; localName: PWideChar; localLength: Integer): Boolean;
+    function Locate(uri: Pointer; localName: PWideChar; localLength: Integer): Boolean;
     destructor Destroy; override;
   end;
 
@@ -182,7 +182,7 @@ type
 
   TBinding = class
   public
-    uri: XMLString;
+    uri: PHashItem;
     next: TBinding;
     prevPrefixBinding: TObject;
     Prefix: PHashItem;
@@ -196,6 +196,7 @@ type
 
   TNSSupport = class(TObject)
   private
+    FNameTable: THashTable;
     FNesting: Integer;
     FPrefixSeqNo: Integer;
     FFreeBindings: TBinding;
@@ -204,17 +205,17 @@ type
     FPrefixes: THashTable;
     FDefaultPrefix: THashItem;
   public
-    constructor Create;
+    constructor Create(aNameTable: THashTable);
     destructor Destroy; override;
     procedure DefineBinding(const Prefix, nsURI: XMLString; out Binding: TBinding);
     function CheckAttribute(const Prefix, nsURI: XMLString;
       out Binding: TBinding): TAttributeAction;
-    function IsPrefixBound(P: PWideChar; Len: Integer; out Prefix: PHashItem): Boolean;
     function GetPrefix(P: PWideChar; Len: Integer): PHashItem;
-    function BindPrefix(const nsURI: XMLString; aPrefix: PHashItem): TBinding;
+    function BindPrefix(nsURI, aPrefix: PHashItem): TBinding;
     function DefaultNSBinding: TBinding;
-    procedure StartElement;
-    procedure EndElement;
+    function LookupNamespace(const APrefix: XMLString): XMLString;
+    procedure PushScope;
+    function PopScope: Boolean;
   end;
 
 { Buffer builder, used to compose long strings without too much memory allocations }
@@ -685,15 +686,14 @@ begin
   Dec(FRevision);
 end;
 
-function TDblHashArray.Locate(uri: PXMLString; localName: PWideChar; localLength: Integer): Boolean;
+function TDblHashArray.Locate(uri: Pointer; localName: PWideChar; localLength: Integer): Boolean;
 var
   step: Byte;
   mask: LongWord;
   idx: Integer;
   HashValue: LongWord;
 begin
-  HashValue := Hash(0, PWideChar(uri^), Length(uri^));
-  HashValue := Hash(HashValue, localName, localLength);
+  HashValue := Hash(PtrUInt(uri), localName, localLength);
 
   mask := (1 shl FSizeLog) - 1;
   step := (HashValue and (not mask)) shr (FSizeLog-1) and (mask shr 2) or 1;
@@ -701,7 +701,7 @@ begin
   result := True;
   while FData^[idx].rev = FRevision do
   begin
-    if (HashValue = FData^[idx].hash) and (FData^[idx].uriPtr^ = uri^) and
+    if (HashValue = FData^[idx].hash) and (FData^[idx].uriPtr = uri) and
       (FData^[idx].lnameLen = localLength) and
        CompareMem(FData^[idx].lname, localName, localLength * sizeof(WideChar)) then
       Exit;
@@ -723,11 +723,12 @@ end;
 
 { TNSSupport }
 
-constructor TNSSupport.Create;
+constructor TNSSupport.Create(aNameTable: THashTable);
 var
   b: TBinding;
 begin
   inherited Create;
+  FNameTable := aNameTable;
   FPrefixes := THashTable.Create(16, False);
   FBindings := TFPList.Create;
   SetLength(FBindingStack, 16);
@@ -747,7 +748,7 @@ begin
   inherited Destroy;
 end;
 
-function TNSSupport.BindPrefix(const nsURI: XMLString; aPrefix: PHashItem): TBinding;
+function TNSSupport.BindPrefix(nsURI, aPrefix: PHashItem): TBinding;
 begin
   { try to reuse an existing binding }
   result := FFreeBindings;
@@ -778,13 +779,14 @@ end;
 procedure TNSSupport.DefineBinding(const Prefix, nsURI: XMLString;
   out Binding: TBinding);
 var
-  Pfx: PHashItem;
+  Pfx, uri: 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 := BindPrefix(nsURI, Pfx)
+  uri := FNameTable.FindOrAdd(PWideChar(nsURI),Length(nsURI));
+  if (Pfx^.Data = nil) or (TBinding(Pfx^.Data).uri <> uri) then
+    Binding := BindPrefix(uri, Pfx)
   else
     Binding := nil;
 end;
@@ -797,6 +799,7 @@ var
   b: TBinding;
   buf: array[0..31] of WideChar;
   p: PWideChar;
+  uri: PHashItem;
 begin
   Binding := nil;
   Pfx := nil;
@@ -805,8 +808,9 @@ begin
     Pfx := FPrefixes.FindOrAdd(PWideChar(Prefix), Length(Prefix))
   else if nsURI = '' then
     Exit;
+  uri := FNameTable.FindOrAdd(PWideChar(nsURI), Length(nsURI));
   { if the prefix is already bound to correct URI, we're done }
-  if Assigned(Pfx) and Assigned(Pfx^.Data) and (TBinding(Pfx^.Data).uri = nsURI) then
+  if Assigned(Pfx) and Assigned(Pfx^.Data) and (TBinding(Pfx^.Data).uri = uri) then
     Exit;
 
   { see if there's another prefix bound to the target URI }
@@ -816,7 +820,7 @@ begin
     b := FBindingStack[i];
     while Assigned(b) do
     begin
-      if (b.uri = nsURI) and (b.Prefix <> @FDefaultPrefix) then
+      if (b.uri = uri) and (b.Prefix <> @FDefaultPrefix) then
       begin
         Binding := b;   // found one -> override the attribute's prefix
         Result := aaPrefix;
@@ -841,17 +845,10 @@ begin
     p^ := 'N';
     Pfx := FPrefixes.FindOrAdd(p, @Buf[high(Buf)]-p+1);
   until Pfx^.Data = nil;
-  Binding := BindPrefix(nsURI, Pfx);
+  Binding := BindPrefix(uri, Pfx);
   Result := aaBoth;
 end;
 
-function TNSSupport.IsPrefixBound(P: PWideChar; Len: Integer; out
-  Prefix: PHashItem): Boolean;
-begin
-  Prefix := FPrefixes.FindOrAdd(P, Len);
-  Result := Assigned(Prefix^.Data) and (TBinding(Prefix^.Data).uri <> '');
-end;
-
 function TNSSupport.GetPrefix(P: PWideChar; Len: Integer): PHashItem;
 begin
   if Assigned(P) and (Len > 0) then
@@ -860,17 +857,34 @@ begin
     Result := @FDefaultPrefix;
 end;
 
-procedure TNSSupport.StartElement;
+function TNSSupport.LookupNamespace(const APrefix: XMLString): XMLString;
+var
+  prefixatom: PHashItem;
+  b: TBinding;
+begin
+  prefixatom := GetPrefix(PWideChar(APrefix),Length(APrefix));
+  b := TBinding(prefixatom^.Data);
+  if Assigned(b) and Assigned(b.Uri) then
+    result := b.Uri^.Key
+  else
+    result := '';
+end;
+
+procedure TNSSupport.PushScope;
 begin
   Inc(FNesting);
   if FNesting >= Length(FBindingStack) then
     SetLength(FBindingStack, FNesting * 2);
 end;
 
-procedure TNSSupport.EndElement;
+function TNSSupport.PopScope: Boolean;
 var
   b, temp: TBinding;
 begin
+  { don't unbind prefixes declared before the first call to PushScope }
+  Result := FNesting > 0;
+  if not Result then
+    Exit;
   temp := FBindingStack[FNesting];
   while Assigned(temp) do
   begin
@@ -881,8 +895,7 @@ begin
     b.Prefix^.Data := b.prevPrefixBinding;
   end;
   FBindingStack[FNesting] := nil;
-  if FNesting > 0 then
-    Dec(FNesting);
+  Dec(FNesting);
 end;
 
 { Buffer builder utils }

packages/fcl-xml/src/xmlwrite.pp

@@ -90,7 +90,7 @@ type
     procedure VisitDocumentType(Node: TDOMNode);
     procedure VisitPI(Node: TDOMNode);
   public
-    constructor Create(AStream: TStream);
+    constructor Create(AStream: TStream; ANameTable: THashTable);
     destructor Destroy; override;
   end;
 
@@ -139,7 +139,7 @@ const
   ltStr = '<';
   gtStr = '>';
 
-constructor TXMLWriter.Create(AStream: TStream);
+constructor TXMLWriter.Create(AStream: TStream; ANameTable: THashTable);
 var
   I: Integer;
 begin
@@ -165,7 +165,7 @@ begin
     FIndent[2] := ' ';
   for I := 3 to 100 do FIndent[I] := ' ';
   FIndentCount := 0;
-  FNSHelper := TNSSupport.Create;
+  FNSHelper := TNSSupport.Create(ANameTable);
   FScratch := TFPList.Create;
   FNSDefs := TFPList.Create;
   FAttrFixups := TFPList.Create;
@@ -426,7 +426,8 @@ begin
     wrtStr(B.Prefix^.Key);
   end;
   wrtChars('="', 2);
-  ConvWrite(B.uri, AttrSpecialChars, @AttrSpecialCharCallback);
+  if Assigned(B.uri) then
+    ConvWrite(B.uri^.Key, AttrSpecialChars, @AttrSpecialCharCallback);
   wrtChr('"');
 end;
 
@@ -575,7 +576,7 @@ var
 begin
   if not FInsideTextNode then
     wrtIndent;
-  FNSHelper.StartElement;
+  FNSHelper.PushScope;
   wrtChr('<');
   wrtStr(TDOMElement(node).TagName);
 
@@ -611,7 +612,7 @@ begin
     wrtStr(TDOMElement(Node).TagName);
     wrtChr('>');
   end;
-  FNSHelper.EndElement;
+  FNSHelper.PopScope;
 end;
 
 procedure TXMLWriter.VisitText(node: TDOMNode);
@@ -825,7 +826,7 @@ var
 begin
   s := TTextStream.Create(AFile);
   try
-    with TXMLWriter.Create(s) do
+    with TXMLWriter.Create(s, doc.Names) do
     try
       WriteNode(doc);
     finally
@@ -838,7 +839,7 @@ end;
 
 procedure WriteXMLFile(doc: TXMLDocument; AStream: TStream);
 begin
-  with TXMLWriter.Create(AStream) do
+  with TXMLWriter.Create(AStream, doc.Names) do
   try
     WriteNode(doc);
   finally