diff --git a/packages/fcl-xml/src/dom.pp b/packages/fcl-xml/src/dom.pp index 2d9345ebb6..a742920dfd 100644 --- a/packages/fcl-xml/src/dom.pp +++ b/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; diff --git a/packages/fcl-xml/src/xmlread.pp b/packages/fcl-xml/src/xmlread.pp index 4f2ce8f84b..e90837079e 100644 --- a/packages/fcl-xml/src/xmlread.pp +++ b/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; diff --git a/packages/fcl-xml/tests/domunit.pp b/packages/fcl-xml/tests/domunit.pp index 3ca10b9cfe..5ddabe9770 100644 --- a/packages/fcl-xml/tests/domunit.pp +++ b/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; diff --git a/packages/fcl-xml/tests/testgen.pp b/packages/fcl-xml/tests/testgen.pp index cb74d35d92..aaffb536b6 100644 --- a/packages/fcl-xml/tests/testgen.pp +++ b/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']+';');