paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-06-03 15:39:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Patch from Sergei Gorelkin:

Browse Source 
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 -
This commit is contained in:
michael 2008-11-04 18:33:05 +00:00
parent e5920bc2b8
commit 67f56b7adf
4 changed files with 173 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
packages/fcl-xml/src/dom.pp
View File

@ -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;

175
packages/fcl-xml/src/xmlread.pp
View File

@ -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;

6
packages/fcl-xml/tests/domunit.pp
View File

@ -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;

103
packages/fcl-xml/tests/testgen.pp
View File

@ -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']+';');