* Patch from Sergei Gorelkin:

  src/xmlread.pp, src/dom.pp
  * Improvements to attribute processing: attributes are now validated as
    they come. This enables reporting of the corresponding validation
    errors at correct positions (previously everything was reported at the
    end of element start-tag).
  * Search for a declaration for attribute, not for an attribute
    corresponding to the declaration. This reduces number of lookups
    (because unspecified attributes are not searched) and obsoletes the
    need in FDeclared field on every attribute.

  tests/domunit.pp, tests/testgen.pp:

  * Various improvements required to support converting of the
    DOM level 3 XPath module.

git-svn-id: trunk@12026 -

packages/fcl-xml/src/dom.pp

@@ -501,8 +501,7 @@ type
   protected
     FName: DOMString;
     FOwnerElement: TDOMElement;
-    // TODO: following 2 - replace with a link to AttDecl ??    
-    FDeclared: Boolean;
+    // TODO: replace with a link to AttDecl ??    
     FDataType: TAttrDataType;
     function  GetNodeValue: DOMString; override;
     function GetNodeType: Integer; override;
@@ -2016,7 +2015,6 @@ begin
   // Cloned attribute is always specified and carries its children
   Result := ACloneOwner.CreateAttribute(FName);
   TDOMAttr(Result).FDataType := FDataType;
-  // Declared = ?
   CloneChildren(Result, ACloneOwner);
 end;
 

packages/fcl-xml/src/xmlread.pp

@@ -318,6 +318,7 @@ type
     FSaViolation: Boolean;
     FDTDStartPos: PWideChar;
     FIntSubset: TWideCharBuf;
+    FAttrTag: Cardinal;
 
     FColonPos: Integer;
     FValidate: Boolean;            // parsing options, copy of FCtrl.Options
@@ -340,6 +341,7 @@ type
     procedure ParseQuantity(CP: TContentParticle);
     procedure StoreLocation(out Loc: TLocation);
     function ValidateAttrSyntax(AttrDef: TDOMAttrDef; const aValue: WideString): Boolean;
+    procedure ValidateAttrValue(Attr: TDOMAttr; const aValue: WideString);
     procedure AddForwardRef(aList: TFPList; Buf: PWideChar; Length: Integer);
     procedure ClearRefs(aList: TFPList);
     procedure ValidateIdRefs;
@@ -425,6 +427,8 @@ type
   // Attribute/Element declarations
 
   TDOMAttrDef = class(TDOMAttr)
+  private
+    FTag: Cardinal;
   protected
     FExternallyDeclared: Boolean;
     FDefault: TAttrDefault;
@@ -432,6 +436,8 @@ type
     function AddEnumToken(Buf: DOMPChar; Len: Integer): Boolean;
     function HasEnumToken(const aValue: WideString): Boolean;
     function Clone(AElement: TDOMElement): TDOMAttr;
+  public
+    property Tag: Cardinal read FTag write FTag;
   end;
 
   TDOMElementDef = class(TDOMElement)
@@ -2625,6 +2631,8 @@ begin
 
   NewElem := doc.CreateElementBuf(FName.Buffer, FName.Length);
   FCursor.AppendChild(NewElem);
+  // we're about to process a new set of attributes
+  Inc(FAttrTag);
 
   // Find declaration for this element
   ElDef := nil;
@@ -2697,10 +2705,49 @@ end;
 procedure TXMLReader.ParseAttribute(Elem: TDOMElement; ElDef: TDOMElementDef);
 var
   attr: TDOMAttr;
+  AttDef: TDOMAttrDef;
   OldAttr: TDOMNode;
+
+procedure CheckValue;
+var
+  AttValue, OldValue: WideString;
+begin
+  if FStandalone and AttDef.FExternallyDeclared then
+  begin
+    OldValue := Attr.Value;
+    TDOMAttrDef(Attr).FDataType := AttDef.FDataType;
+    AttValue := Attr.Value;
+    if AttValue <> OldValue then
+      StandaloneError(-1);
+  end
+  else
+  begin
+    TDOMAttrDef(Attr).FDataType := AttDef.FDataType;
+    AttValue := Attr.Value;
+  end;
+  // TODO: what about normalization of AttDef.Value? (Currently it IS normalized)
+  if (AttDef.FDefault = adFixed) and (AttDef.Value <> AttValue) then
+    ValidationError('Value of attribute ''%s'' does not match its #FIXED default',[AttDef.Name], -1);
+  if not ValidateAttrSyntax(AttDef, AttValue) then
+    ValidationError('Attribute ''%s'' type mismatch', [AttDef.Name], -1);
+  ValidateAttrValue(Attr, AttValue);
+end;
+
 begin
   CheckName;
   attr := doc.CreateAttributeBuf(FName.Buffer, FName.Length);
+
+  if Assigned(ElDef) then
+  begin
+    AttDef := TDOMAttrDef(ElDef.GetAttributeNode(attr.Name));
+    if AttDef = nil then
+      ValidationError('Using undeclared attribute ''%s'' on element ''%s''',[attr.Name, Elem.TagName], FName.Length)
+    else
+      AttDef.Tag := FAttrTag;  // indicates that this one is specified
+  end
+  else
+    AttDef := nil;
+
   // !!cannot use TDOMElement.SetAttributeNode because it will free old attribute
   OldAttr := Elem.Attributes.SetNamedItem(Attr);
   if Assigned(OldAttr) then
@@ -2711,6 +2758,9 @@ begin
   ExpectEq;
   FCursor := attr;
   ExpectAttValue;
+
+  if Assigned(AttDef) and ((AttDef.FDataType <> dtCdata) or (AttDef.FDefault = adFixed)) then
+    CheckValue;
 end;
 
 procedure TXMLReader.AddForwardRef(aList: TFPList; Buf: PWideChar; Length: Integer);
@@ -2719,9 +2769,13 @@ var
 begin
   New(w);
   SetString(w^.Value, Buf, Abs(Length));
-  StoreLocation(w^.Loc);
   if Length > 0 then
+  begin
+    StoreLocation(w^.Loc);
     Dec(w^.Loc.LinePos, Length);
+  end
+  else
+    w^.Loc := FTokenStart;
   aList.Add(w);
 end;
 
@@ -2752,9 +2806,7 @@ var
 
 procedure DoDefaulting;
 var
-  AttValue: WideString;
-  I, L, StartPos, EndPos: Integer;
-  Entity: TDOMEntity;
+  I: Integer;
   AttDef: TDOMAttrDef;
 begin
   Map := ElDef.FAttributes;
@@ -2763,96 +2815,25 @@ begin
   begin
     AttDef := Map[I] as TDOMAttrDef;
 
-    Attr := Element.GetAttributeNode(AttDef.Name);
-    if Attr = nil then
+    if AttDef.Tag <> FAttrTag then  // this one wasn't specified
     begin
-      // attribute needs defaulting
       case AttDef.FDefault of
         adDefault, adFixed: begin
           if FStandalone and AttDef.FExternallyDeclared then
             StandaloneError;
           Attr := AttDef.Clone(Element);
           Element.SetAttributeNode(Attr);
+          ValidateAttrValue(Attr, Attr.Value);
         end;
         adRequired:  ValidationError('Required attribute ''%s'' of element ''%s'' is missing',[AttDef.Name, Element.TagName], 0)
       end;
-    end
-    else
-    begin
-      TDOMAttrDef(Attr).FDeclared := True;
-      // bypass heavyweight operations if possible
-      if (AttDef.DataType <> dtCdata) or (AttDef.FDefault = adFixed) then
-      begin
-        AttValue := Attr.Value; // unnormalized
-        // now assign DataType so that value is correctly normalized
-        TDOMAttrDef(Attr).FDataType := AttDef.FDataType;
-        if FStandalone and AttDef.FExternallyDeclared and (Attr.Value <> AttValue) then
-          StandaloneError;
-        AttValue := Attr.Value; // recalculate
-        // TODO: what about normalization of AttDef.Value? (Currently it IS normalized)
-        if (AttDef.FDefault = adFixed) and (AttDef.Value <> AttValue) then
-          ValidationError('Value of attribute ''%s'' does not match its #FIXED default',[AttDef.Name], 0);
-        if not ValidateAttrSyntax(AttDef, AttValue) then
-          ValidationError('Attribute ''%s'' type mismatch', [AttDef.Name], 0);
-      end;
-    end;
-
-    if Attr = nil then
-      Continue;
-    L := Length(AttValue);
-    case Attr.DataType of
-      dtId: if not Doc.AddID(Attr) then
-              ValidationError('The ID ''%s'' is not unique', [AttValue], 0);
-
-      dtIdRef, dtIdRefs: begin
-        StartPos := 1;
-        while StartPos <= L do
-        begin
-          EndPos := StartPos;
-          while (EndPos <= L) and (AttValue[EndPos] <> #32) do
-            Inc(EndPos);
-          // pass negative Length, so current location is not altered
-          AddForwardRef(FIDRefs, @AttValue[StartPos], StartPos-EndPos);
-          StartPos := EndPos + 1;
-        end;
-      end;
-
-      dtEntity, dtEntities: begin
-        StartPos := 1;
-        while StartPos <= L do
-        begin
-          EndPos := StartPos;
-          while (EndPos <= L) and (AttValue[EndPos] <> #32) do
-            Inc(EndPos);
-          Entity := TDOMEntity(FDocType.Entities.GetNamedItem(Copy(AttValue, StartPos, EndPos-StartPos)));
-          if (Entity = nil) or (Entity.NotationName = '') then
-            ValidationError('Attribute ''%s'' type mismatch', [Attr.Name], 0);
-          StartPos := EndPos + 1;
-        end;
-      end;
     end;
   end;
 end;
 
-procedure ReportUndeclared;
-var
-  I: Integer;
-begin
-  Map := Element.Attributes;
-  for I := 0 to Map.Length-1 do
-  begin
-    Attr := TDOMAttr(Map[I]);
-    if not TDOMAttrDef(Attr).FDeclared then
-      ValidationError('Using undeclared attribute ''%s'' on element ''%s''',[Attr.Name, Element.TagName], 0);
-  end;
-end;
-
 begin
   if Assigned(ElDef) and Assigned(ElDef.FAttributes) then
     DoDefaulting;
-  // Now report undeclared attributes
-  if Assigned(FDocType) and Element.HasAttributes then
-    ReportUndeclared;
 end;
 
 function TXMLReader.ParseExternalID(out SysID, PubID: WideString;     // [75]
@@ -2895,6 +2876,45 @@ begin
   end;
 end;
 
+procedure TXMLReader.ValidateAttrValue(Attr: TDOMAttr; const aValue: WideString);
+var
+  L, StartPos, EndPos: Integer;
+  Entity: TDOMEntity;
+begin
+  L := Length(aValue);
+  case Attr.DataType of
+    dtId: if not Doc.AddID(Attr) then
+            ValidationError('The ID ''%s'' is not unique', [aValue], -1);
+
+    dtIdRef, dtIdRefs: begin
+      StartPos := 1;
+      while StartPos <= L do
+      begin
+        EndPos := StartPos;
+        while (EndPos <= L) and (aValue[EndPos] <> #32) do
+          Inc(EndPos);
+        // pass negative length, so uses FTokenStart as location
+        AddForwardRef(FIDRefs, @aValue[StartPos], StartPos-EndPos);
+        StartPos := EndPos + 1;
+      end;
+    end;
+
+    dtEntity, dtEntities: begin
+      StartPos := 1;
+      while StartPos <= L do
+      begin
+        EndPos := StartPos;
+        while (EndPos <= L) and (aValue[EndPos] <> #32) do
+          Inc(EndPos);
+        Entity := TDOMEntity(FDocType.Entities.GetNamedItem(Copy(aValue, StartPos, EndPos-StartPos)));
+        if (Entity = nil) or (Entity.NotationName = '') then
+          ValidationError('Attribute ''%s'' type mismatch', [Attr.Name], -1);
+        StartPos := EndPos + 1;
+      end;
+    end;
+  end;
+end;
+
 procedure TXMLReader.ValidateRoot;
 begin
   if Assigned(FDocType) then
@@ -3068,7 +3088,6 @@ begin
   Result := TDOMAttr.Create(FOwnerDocument);
   TDOMAttrEx(Result).FName := Self.FName;
   TDOMAttrEx(Result).FDataType := FDataType;
-  TDOMAttrEx(Result).FDeclared := True;
   CloneChildren(Result, FOwnerDocument);
 end;
 

packages/fcl-xml/tests/domunit.pp

@@ -62,6 +62,7 @@ type
 
 procedure _append(var coll: _collection; const Value: DOMString);
 procedure _assign(out rslt: _collection; const value: array of DOMString);
+function IsSame(exp, act: TDOMNode): Boolean;
 
 implementation
 
@@ -86,6 +87,11 @@ begin
     rslt[I] := value[I];
 end;
 
+function IsSame(exp, act: TDOMNode): Boolean;
+begin
+  Result := exp = act;
+end;
+
 procedure TDOMTestBase.SetUp;
 begin
   FParser := TDOMParser.Create;

packages/fcl-xml/tests/testgen.pp

@@ -29,7 +29,7 @@ var
 
 function PascalType(const s: WideString): string;
 begin
-  if (s = 'DOMString') or (s = 'boolean') or (s = 'DOMError') then
+  if (s = 'DOMString') or (s = 'boolean') or (s = 'DOMError') or (s = 'double') then
     result := s
   else if s = 'int' then
     result := 'Integer'
@@ -39,7 +39,7 @@ begin
     result := '_collection'
   else if s = 'List' then
     result := '_list'
-  else if Pos(WideString('DOM'), s) = 1 then
+  else if (Pos(WideString('DOM'), s) = 1) or (Pos(WideString('XPath'), s) = 1) then
     result := 'T' + s
   else
     result := 'TDOM'+s;
@@ -147,6 +147,11 @@ begin
     else
       r := 'bad_condition(''contains intf=' + e['interface'] + ''')';
   end
+  else if e.TagName = 'same' then
+  begin
+  // maybe it would be sufficient to just compare pointers, but let's emit a helper for now
+    r := 'IsSame('+ e['expected'] + ', ' + e['actual'] + ')';
+  end
   else if e.TagName = 'not' then
   begin
     child := e.FirstChild;
@@ -304,6 +309,10 @@ begin
 
   s := node.TagName;
   apinode := api.GetElementById(s);
+  // If not found by name only, try prepending the interface name.
+  // This enables support of same-named methods with different param lists on different objects
+  if (apinode = nil) and node.HasAttribute('interface') then
+    apinode := api.GetElementById(node['interface'] + '.' + s);
   if assigned(apinode) then
   begin
     // handle most of DOM API in consistent way
@@ -369,9 +378,15 @@ begin
   // service (non-DOM) statements follow
   
   else if s = 'append' then
-    rslt.Add(indent + '_append(' + node['collection'] + ', ' + node['item'] + ');')
+    rslt.Add(indent + '_append(' + node['collection'] + ', ' + ReplaceQuotes(node['item']) + ');')
   else if s = 'assign' then
-    rslt.Add(indent + '_assign(' + node['var'] + ', ' + node['value'] + ');')
+  begin
+    cond := TypeOfVar(node['var']);
+    if (cond = '_collection') or (cond = '_list') then
+      rslt.Add(indent + '_assign(' + node['var'] + ', ' + node['value'] + ');')
+    else // emit an assignment operator. Force type for the case where they assign Document to Element.
+      rslt.Add(indent + node['var'] + ' := ' + TypeOfVar(node['var']) + '(' + ReplaceQuotes(node['value']) + ');');
+  end  
   else if s = 'increment' then
     rslt.Add(indent + 'Inc(' + node['var'] + ', ' + node['value'] + ');')
   else if s = 'decrement' then
@@ -433,6 +448,10 @@ begin
     rslt.Add(indent + 'Load('+node['var']+', '''+ node['href']+''');')
   else if s = 'implementationAttribute' then
     rslt.Add(indent + s + '[''' + node['name'] + '''] := ' + node['value'] + ';')
+  else if s = 'createXPathEvaluator' then
+    rslt.Add(indent + node['var'] + ' := CreateXPathEvaluator(' + node['document'] + ');')
+  else if s = 'comment' then
+    rslt.Add(indent + '{ Source comment: ' + node.TextContent + ' }')
   else
   begin
     if not FailFlag then
@@ -442,12 +461,44 @@ begin
   end;
 end;
 
+procedure ConvertException(el: TDOMElement; const ExceptClass: string; indent: string);
+var
+  excode: string;
+begin
+  if not SuccessVarFlag then
+    rslt.Insert(2, '  success: Boolean;');
+  SuccessVarFlag := True;
+  rslt.Add(indent+'success := False;');
+  rslt.Add(indent+'try');
+  child := el.FirstChild;
+  while assigned(child) do
+  begin
+    if child.nodeType = ELEMENT_NODE then
+    begin
+      excode := child.nodeName;
+      subchild := child.FirstChild;
+      while Assigned(subchild) do
+      begin
+        if subchild.nodeType = ELEMENT_NODE then
+          ConvertStatement(TDOMElement(subchild), indent + '  ');
+        subchild := subchild.NextSibling;
+      end;
+    end;
+    child := child.NextSibling;
+  end;
+  rslt.Add(indent+'except');
+  rslt.Add(indent+'  on E: Exception do');
+  rslt.Add(indent+'    success := (E is ' + ExceptClass +') and (' + ExceptClass + '(E).Code = ' + excode + ');');
+  rslt.Add(indent+'end;');
+  rslt.Add(indent+'AssertTrue('''+el['id']+''', success);');
+end;
+
 procedure ConvertBlock(el: TDOMNode; indent: string);
 var
   curr: TDOMNode;
   element: TDOMElement;
   List: TList;
-  cond, excode: string;
+  cond: string;
   Frag: TDOMDocumentFragment;
   I: Integer;
   ElseNode: TDOMNode;
@@ -467,34 +518,9 @@ begin
     element := TDOMElement(curr);
     n := element.TagName;
     if n = 'assertDOMException' then
-    begin
-      if not SuccessVarFlag then
-        rslt.Insert(2, '  success: Boolean;');
-      SuccessVarFlag := True;
-      rslt.Add(indent+'success := False;');
-      rslt.Add(indent+'try');
-      child := curr.FirstChild;
-      while assigned(child) do
-      begin
-        if child.nodeType = ELEMENT_NODE then
-        begin
-          excode := child.nodeName;
-          subchild := child.FirstChild;
-          while Assigned(subchild) do
-          begin
-            if subchild.nodeType = ELEMENT_NODE then
-              ConvertStatement(TDOMElement(subchild), indent + '  ');
-            subchild := subchild.NextSibling;
-          end;
-        end;
-        child := child.NextSibling;
-      end;
-      rslt.Add(indent+'except');
-      rslt.Add(indent+'  on E: Exception do');
-      rslt.Add(indent+'    success := (E is EDOMError) and (EDOMError(E).Code = ' + excode + ');');
-      rslt.Add(indent+'end;');
-      rslt.Add(indent+'AssertTrue('''+element['id']+''', success);');
-    end
+      ConvertException(element, 'EDOMError', indent)
+    else if n = 'assertXPathException' then
+      ConvertException(element, 'EXPathException', indent)
     else if n = 'try' then
     begin
       GetChildElements(curr, List);
@@ -658,7 +684,11 @@ begin
         try
           if subvars.Count > 0 then
           begin
-            TypedConsts.Add('  ' + Node['name'] + ': array[0..' + IntToStr(subvars.Count-1) + '] of DOMString = (');
+            if TDOMElement(subvars[0]).HasAttribute('type') then
+              hs := PascalType(TDOMElement(subvars[0]).GetAttribute('type'))
+            else
+              hs := 'DOMString';
+            TypedConsts.Add('  ' + Node['name'] + ': array[0..' + IntToStr(subvars.Count-1) + '] of ' + hs + ' = (');
             for J := 0 to subvars.Count-1 do
             begin
               hs := '    ' + ReplaceQuotes(subvars[J].TextContent);
@@ -817,7 +847,12 @@ begin
       if root['name'] = 'attrname' then
         root['name'] := 'attr_name';
       sl.Add('procedure ' + class_name + '.' + root['name'] + ';');
+      try
       ConvertTest(root, sl);
+      except
+        Writeln('An exception occured while converting '+root['name']);
+        raise;
+      end;
       if sl.Count > 0 then
       begin
         all.add('    procedure '+root['name']+';');