+ Processing of prefixed attributes and prefix bindings. This completes namespace support at

  the XML reader side.

git-svn-id: trunk@13214 -

packages/fcl-xml/src/dom.pp

@@ -522,6 +522,8 @@ type
     function GetPrefix: DOMString; override;
     procedure SetPrefix(const Value: DOMString); override;
   public
+    { Used by parser }
+    procedure SetNSI(const nsUri: DOMString; ColonPos: Integer);
     function CompareName(const AName: DOMString): Integer; override;
     property NSI: TNamespaceInfo read FNSI;
   end;
@@ -2324,6 +2326,13 @@ begin
   Result := CompareDOMStrings(DOMPChar(AName), DOMPChar(NodeName), Length(AName), Length(NodeName));
 end;
 
+procedure TDOMNode_NS.SetNSI(const nsUri: DOMString; ColonPos: Integer);
+begin
+  FNSI.NSIndex := FOwnerDocument.IndexOfNS(nsURI, True);
+  FNSI.PrefixLen := ColonPos;
+  Include(FFlags, nfLevel2);
+end;
+
 // -------------------------------------------------------
 //   Attr
 // -------------------------------------------------------

packages/fcl-xml/src/xmlread.pp

@@ -296,6 +296,19 @@ type
   );
 
   TCheckNameFlags = set of (cnOptional, cnToken);
+  
+  TBinding = class
+  public
+    uri: WideString;
+    next: TBinding;
+    prevPrefixBinding: TObject;
+    Prefix: PHashItem;
+  end;
+
+  TPrefixedAttr = record
+    Attr: TDOMAttr;
+    PrefixLen: Integer;  // to avoid recalculation
+  end;
 
   TXMLReader = class
   private
@@ -322,6 +335,15 @@ type
     FDTDStartPos: PWideChar;
     FIntSubset: TWideCharBuf;
     FAttrTag: Cardinal;
+    FPrefixes: THashTable;
+    FBindings: TFPList;
+    FDefaultPrefix: THashItem;
+    FWorkAtts: array of TPrefixedAttr;
+    FBindingStack: array of TBinding;
+    FFreeBindings: TBinding;
+    FNsAttHash: TDblHashArray;
+    FStdPrefix_xml: PHashItem;
+    FStdPrefix_xmlns: PHashItem;
 
     FColonPos: Integer;
     FValidate: Boolean;            // parsing options, copy of FCtrl.Options
@@ -402,6 +424,9 @@ type
     procedure ParseNotationDecl;
     function ResolveEntity(const SystemID, PublicID: WideString; out Source: TXMLCharSource): Boolean;
     procedure ProcessDefaultAttributes(Element: TDOMElement; Map: TDOMNamedNodeMap);
+    procedure ProcessNamespaceAtts(Element: TDOMElement);
+    procedure AddBinding(Attr: TDOMAttr; Prefix: PHashItem; var Chain: TBinding);
+    procedure EndNamespaceScope(var Chain: TBinding);
 
     procedure PushVC(aElDef: TDOMElementDef);
     procedure PopVC;
@@ -1338,7 +1363,12 @@ begin
   end;  
 end;
 
+const
+  PrefixDefault: array[0..4] of WideChar = ('x','m','l','n','s');
+
 constructor TXMLReader.Create;
+var
+  b: TBinding;
 begin
   inherited Create;
   BufAllocate(FName, 128);
@@ -1346,6 +1376,20 @@ begin
   FIDRefs := TFPList.Create;
   FNotationRefs := TFPList.Create;
 
+  FPrefixes := THashTable.Create(16, False);
+  FBindings := TFPList.Create;
+  FNsAttHash := TDblHashArray.Create;
+  SetLength(FWorkAtts, 16);
+  SetLength(FBindingStack, 16);
+  FStdPrefix_xml := FPrefixes.FindOrAdd(@PrefixDefault, 3);
+  FStdPrefix_xmlns := FPrefixes.FindOrAdd(@PrefixDefault, 5);
+  { implicit binding for the 'xml' prefix }
+  b := TBinding.Create;
+  FBindings.Add(b);
+  FStdPrefix_xml^.Data := b;
+  b.uri := stduri_xml;
+  b.Prefix := FStdPrefix_xml;
+
   // Set char rules to XML 1.0
   FNamePages := @NamePages;
   SetLength(FValidator, 16);
@@ -1365,6 +1409,8 @@ begin
 end;
 
 destructor TXMLReader.Destroy;
+var
+  I: Integer;
 begin
   if Assigned(FEntityValue.Buffer) then
     FreeMem(FEntityValue.Buffer);
@@ -1376,6 +1422,11 @@ begin
   FPEMap.Free;
   ClearRefs(FNotationRefs);
   ClearRefs(FIDRefs);
+  FNsAttHash.Free;
+  for I := FBindings.Count-1 downto 0 do
+    TObject(FBindings.List^[I]).Free;
+  FPrefixes.Free;
+  FBindings.Free;
   FNotationRefs.Free;
   FIDRefs.Free;
   inherited Destroy;
@@ -2869,6 +2920,8 @@ begin
   if Assigned(ElDef) and Assigned(ElDef.FAttributes) then
     ProcessDefaultAttributes(NewElem, ElDef.FAttributes);
   PushVC(ElDef);  // this increases FNesting
+  if FNamespaces then
+    ProcessNamespaceAtts(NewElem);
 
   // SAX: ContentHandler.StartElement(...)
   // SAX: ContentHandler.StartPrefixMapping(...)
@@ -2914,6 +2967,8 @@ begin
   if FValidate and FValidator[FNesting].Incomplete then
     ValidationError('Element ''%s'' is missing required sub-elements', [ElName^.Key], ErrOffset);
 
+  if FNamespaces then
+    EndNamespaceScope(FBindingStack[FNesting]);
   PopVC;
 end;
 
@@ -3040,6 +3095,153 @@ begin
   end;
 end;
 
+
+procedure TXMLReader.AddBinding(Attr: TDOMAttr; Prefix: PHashItem; var Chain: TBinding);
+var
+  nsUri: DOMString;
+  b: TBinding;
+begin
+  nsUri := Attr.NodeValue;
+  { 'xml' is allowed to be bound to the correct namespace }
+  if ((nsUri = stduri_xml) <> (Prefix = FStdPrefix_xml)) or
+   (Prefix = FStdPrefix_xmlns) or
+   (nsUri = stduri_xmlns) then
+  begin
+    if (Prefix = FStdPrefix_xml) or (Prefix = FStdPrefix_xmlns) then
+      FatalError('Illegal usage of reserved prefix ''%s''', [Prefix^.Key])
+    else
+      FatalError('Illegal usage of reserved namespace URI ''%s''', [nsUri]);
+  end;
+
+  { try reusing an existing binding }
+  b := FFreeBindings;
+  if Assigned(b) then
+    FFreeBindings := b.Next
+  else { no free bindings, create a new one }
+  begin
+    b := TBinding.Create;
+    FBindings.Add(b);
+  end;
+
+  b.uri := nsUri;
+  b.prefix := Prefix;
+  b.PrevPrefixBinding := Prefix^.Data;
+  if nsUri = '' then
+  begin
+    if (FXML11 or (Prefix = @FDefaultPrefix)) then // prefix being unbound
+      Prefix^.Data := nil
+    else
+      FatalError('Illegal undefining of namespace');  { position - ? }
+  end
+  else
+    Prefix^.Data := b;
+
+  b.Next := Chain;
+  Chain := b;
+end;
+
+procedure TXMLReader.EndNamespaceScope(var Chain: TBinding);
+var
+  b: TBinding;
+begin
+  while Assigned(Chain) do
+  begin
+    b := Chain;
+    Chain := b.next;
+    b.next := FFreeBindings;
+    FFreeBindings := b;
+    b.Prefix^.Data := b.prevPrefixBinding;
+  end;  
+end;
+
+procedure TXMLReader.ProcessNamespaceAtts(Element: TDOMElement);
+var
+  I, J: Integer;
+  Map: TDOMNamedNodeMap;
+  Prefix, AttrName: PHashItem;
+  Attr: TDOMAttr;
+  PrefixCount: Integer;
+  b: TBinding;
+begin
+  if FNesting = Length(FBindingStack) then
+    SetLength(FBindingStack, FNesting * 2);
+  PrefixCount := 0;
+  if Element.HasAttributes then
+  begin
+    Map := Element.Attributes;
+    if Map.Length > LongWord(Length(FWorkAtts)) then
+      SetLength(FWorkAtts, Map.Length+10);
+    { Pass 1, identify prefixed attrs and assign prefixes }
+    for I := 0 to Map.Length-1 do
+    begin
+      Attr := TDOMAttr(Map[I]);
+      AttrName := Attr.NSI.QName;
+      if Pos(WideString('xmlns'), AttrName^.Key) = 1 then
+      begin
+        { this is a namespace declaration }
+        if Length(AttrName^.Key) = 5 then
+        begin
+          // TODO: check all consequences of having zero PrefixLength
+          Attr.SetNSI(stduri_xmlns, 0);
+          AddBinding(Attr, @FDefaultPrefix, FBindingStack[FNesting]);
+        end
+        else if AttrName^.Key[6] = ':' then
+        begin
+          Prefix := FPrefixes.FindOrAdd(@AttrName^.Key[7], Length(AttrName^.Key)-6);
+          Attr.SetNSI(stduri_xmlns, 6);
+          AddBinding(Attr, Prefix, FBindingStack[FNesting]);
+        end;
+      end
+      else
+      begin
+        J := Pos(WideChar(':'), AttrName^.Key);
+        if J > 1 then
+        begin
+          FWorkAtts[PrefixCount].Attr := Attr;
+          FWorkAtts[PrefixCount].PrefixLen := J;
+          Inc(PrefixCount);
+        end;
+      end;
+    end;
+  end;
+  { Pass 2, now all bindings are known, handle remaining prefixed attributes }
+  if PrefixCount > 0 then
+  begin
+    FNsAttHash.Init(PrefixCount);
+    for I := 0 to PrefixCount-1 do
+    begin
+      AttrName := FWorkAtts[I].Attr.NSI.QName;    
+      Prefix := FPrefixes.FindOrAdd(PWideChar(AttrName^.Key), FWorkAtts[I].PrefixLen-1);
+      b := TBinding(Prefix^.Data);
+      if b = nil then
+        FatalError('Unbound prefix "%s"', [Prefix^.Key]);
+      { detect duplicates }
+      J := FWorkAtts[I].PrefixLen+1;
+
+      if FNsAttHash.Locate(@b.uri, @AttrName^.Key[J], Length(AttrName^.Key) - J) then
+        FatalError('Duplicate prefixed attribute');
+
+      // convert Attr into namespaced one (by hack for the time being)
+      FWorkAtts[I].Attr.SetNSI(b.uri, J-1);
+    end;
+  end;
+  { Finally, expand the element name }
+  J := Pos(WideChar(':'), Element.NSI.QName^.Key);
+  if J > 1 then
+  begin
+    Prefix := FPrefixes.FindOrAdd(PWideChar(Element.NSI.QName^.Key), J-1);
+    if Prefix^.Data = nil then
+      FatalError('Unbound prefix "%s"', [Prefix^.Key]);
+    b := TBinding(Prefix^.Data);
+  end
+  else if Assigned(FDefaultPrefix.Data) then
+    b := TBinding(FDefaultPrefix.Data)
+  else
+    Exit;
+  // convert Element into namespaced one (by hack for the time being)
+  Element.SetNSI(b.uri, J);
+end;
+
 function TXMLReader.ParseExternalID(out SysID, PubID: WideString;     // [75]
   SysIdOptional: Boolean): Boolean;
 begin

packages/fcl-xml/src/xmlutils.pp

@@ -71,6 +71,29 @@ type
     property Count: LongWord read FCount;
   end;
 
+{ another hash, for detecting duplicate namespaced attributes without memory allocations }
+
+  PWideString = ^WideString;
+  PExpHashEntry = ^TExpHashEntry;
+  TExpHashEntry = record
+    rev: LongWord;
+    hash: LongWord;
+    uriPtr: PWideString;
+    lname: PWideChar;
+    lnameLen: Integer;
+  end;
+
+  TDblHashArray = class(TObject)
+  private
+    FSizeLog: Integer;
+    FRevision: LongWord;
+    FData: PExpHashEntry;
+  public  
+    procedure Init(NumSlots: Integer);
+    function Locate(uri: PWideString; localName: PWideChar; localLength: Integer): Boolean;
+    destructor Destroy; override;
+  end;
+
 {$i names.inc}
 
 implementation
@@ -526,6 +549,71 @@ begin
   end;
 end;
 
+{ TDblHashArray }
+
+destructor TDblHashArray.Destroy;
+begin
+  FreeMem(FData);
+  inherited Destroy;
+end;
+
+procedure TDblHashArray.Init(NumSlots: Integer);
+var
+  i: Integer;
+begin
+  if ((NumSlots * 2) shr FSizeLog) <> 0 then   // need at least twice more entries, and no less than 8
+  begin
+    FSizeLog := 3;
+    while (NumSlots shr FSizeLog) <> 0 do
+      Inc(FSizeLog);
+    ReallocMem(FData, (1 shl FSizeLog) * sizeof(TExpHashEntry));
+    FRevision := 0;
+  end;
+  if FRevision = 0 then
+  begin
+    FRevision := $FFFFFFFF;
+    for i := (1 shl FSizeLog)-1 downto 0 do
+      FData[i].rev := FRevision;
+  end;
+  Dec(FRevision);
+end;
+
+function TDblHashArray.Locate(uri: PWideString; 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);
+
+  mask := (1 shl FSizeLog) - 1;
+  step := (HashValue and (not mask)) shr (FSizeLog-1) and (mask shr 2) or 1;
+  idx := HashValue and mask;
+  result := True;
+  while FData[idx].rev = FRevision do
+  begin
+    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;
+    if idx < step then
+      Inc(idx, (1 shl FSizeLog) - step)
+    else
+      Dec(idx, step);
+  end;
+  with FData[idx] do
+  begin
+    rev := FRevision;
+    hash := HashValue;
+    uriPtr := uri;
+    lname := localName;
+    lnameLen := localLength;
+  end;
+  result := False;
+end;
+
 initialization
 
 finalization