diff --git a/packages/fcl-xml/tests/api.xml b/packages/fcl-xml/tests/api.xml index 4c18ef9d22..63bd9a6275 100644 --- a/packages/fcl-xml/tests/api.xml +++ b/packages/fcl-xml/tests/api.xml @@ -14,7 +14,10 @@ type (func|prop|method) "func" result CDATA #IMPLIED objtype CDATA #IMPLIED + rename CDATA #IMPLIED gc (yes|no) #IMPLIED> + ]> @@ -74,6 +77,11 @@ + name @@ -230,7 +238,7 @@ - + + + + + nodeResolver + + + + expression + contextNode + resolver + type + result + + + contextNode + type + result + + + expression + resolver + + + + + + + + + + index + + + + + + + + name + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + elementName + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + index + + + element + before + + + + + + + + + + + + + + + index + + + index + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + index + + + index + + + + + + + + + + + + + + + + + + index + + + index + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/packages/fcl-xml/tests/domunit.pp b/packages/fcl-xml/tests/domunit.pp index 5ddabe9770..7dc6c0df52 100644 --- a/packages/fcl-xml/tests/domunit.pp +++ b/packages/fcl-xml/tests/domunit.pp @@ -40,7 +40,7 @@ type procedure SetUp; override; procedure TearDown; override; procedure GC(obj: TObject); - procedure Load(out doc: TDOMDocument; const uri: string); + procedure Load(out doc; const uri: string); function getResourceURI(const res: WideString): WideString; function ContentTypeIs(const t: string): Boolean; function GetImplementation: TDOMImplementation; @@ -49,12 +49,13 @@ type procedure assertEquals(const id: string; exp, act: TObject); overload; procedure assertEqualsList(const id: string; const exp: array of DOMString; const act: _list); procedure assertEqualsCollection(const id: string; const exp: array of DOMString; const act: _collection); + procedure assertEqualsNoCase(const id: string; const exp, act: DOMString); procedure assertSame(const id: string; exp, act: TDOMNode); procedure assertSize(const id: string; size: Integer; obj: TDOMNodeList); procedure assertSize(const id: string; size: Integer; obj: TDOMNamedNodeMap); procedure assertInstanceOf(const id: string; obj: TObject; const typename: string); procedure assertURIEquals(const id: string; - const scheme, path, host, file_, name, query, fragment: DOMString; + scheme, path, host, file_, name, query, fragment: PChar; IsAbsolute: Boolean; const Actual: DOMString); function bad_condition(const TagName: WideString): Boolean; property implementationAttribute[const name: string]: Boolean read getImplAttr write setImplAttr; @@ -160,6 +161,12 @@ begin end; end; +procedure TDOMTestBase.assertEqualsNoCase(const id: string; const exp, act: DOMString); +begin +// TODO: could write custom comparison because range is limited to ASCII + AssertTrue(id + ComparisonMsg(exp, act), WideSameText(exp, act)); +end; + procedure TDOMTestBase.assertSize(const id: string; size: Integer; obj: TDOMNodeList); begin AssertNotNull(id, obj); @@ -174,10 +181,28 @@ end; function TDOMTestBase.getResourceURI(const res: WideString): WideString; var - Base, Level: WideString; + Base, Base2: WideString; + +function CheckFile(const uri: WideString; out name: WideString): Boolean; +var + filename: string; begin - Base := GetTestFilesURI + 'files/'; - if not ResolveRelativeURI(Base, res+'.xml', Result) then + Result := ResolveRelativeURI(uri + 'files/', res + '.xml', name) and + URIToFilename(name, filename) and + FileExists(filename); +end; + +begin + Base := GetTestFilesURI; + if Pos(WideString('level2/html'), Base) <> 0 then + begin + // This is needed to run HTML testsuite off the CVS snapshot. + // Web version simply uses all level1 files copied to level2. + if ResolveRelativeURI(Base, '../../level1/html/', Base2) and + CheckFile(Base2, Result) then + Exit; + end; + if not CheckFile(Base, Result) then Result := ''; end; @@ -218,13 +243,13 @@ begin Fail('Unknown implementation attribute: ''' + name + ''''); end; -procedure TDOMTestBase.Load(out doc: TDOMDocument; const uri: string); +procedure TDOMTestBase.Load(out doc; const uri: string); var t: TXMLDocument; begin - doc := nil; + TObject(doc) := nil; FParser.ParseURI(getResourceURI(uri), t); - doc := t; + TObject(doc) := t; GC(t); end; @@ -233,16 +258,32 @@ begin AssertTrue(id, obj.ClassNameIs(typename)); end; -// TODO: This is a very basic implementation, needs to be completed. -procedure TDOMTestBase.assertURIEquals(const id: string; const scheme, path, - host, file_, name, query, fragment: DOMString; IsAbsolute: Boolean; +{ expected args already UTF-8 encoded } +procedure TDOMTestBase.assertURIEquals(const id: string; scheme, path, + host, file_, name, query, fragment: PChar; IsAbsolute: Boolean; const Actual: DOMString); var URI: TURI; begin AssertTrue(id, Actual <> ''); URI := ParseURI(utf8Encode(Actual)); - AssertEquals(id, URI.Document, utf8Encode(file_)); + if fragment <> nil then + AssertEquals(id, string(fragment), URI.Bookmark); + if query <> nil then + AssertEquals(id, string(query), URI.Params); + if scheme <> nil then + AssertEquals(id, string(scheme), URI.Protocol); + if host <> nil then + begin + AssertTrue(id, URI.HasAuthority); + AssertEquals(id, string(host), URI.Host); + end; + if path <> nil then + AssertEquals(id, string(path), '//' + Uri.Host + URI.Path + URI.Document); + if file_ <> nil then + AssertEquals(id, string(file_), URI.Document); + if name <> nil then + AssertEquals(id, string(name), ChangeFileExt(URI.Document, '')); end; function TDOMTestBase.bad_condition(const TagName: WideString): Boolean; diff --git a/packages/fcl-xml/tests/testgen.pp b/packages/fcl-xml/tests/testgen.pp index aaffb536b6..4748729473 100644 --- a/packages/fcl-xml/tests/testgen.pp +++ b/packages/fcl-xml/tests/testgen.pp @@ -39,7 +39,8 @@ begin result := '_collection' else if s = 'List' then result := '_list' - else if (Pos(WideString('DOM'), s) = 1) or (Pos(WideString('XPath'), s) = 1) then + else if (Pos(WideString('DOM'), s) = 1) or (Pos(WideString('XPath'), s) = 1) or + (Pos(WideString('HTML'), s) = 1) then result := 'T' + s else result := 'TDOM'+s; @@ -69,7 +70,7 @@ begin if n.HasAttribute(attName) then s := s + ReplaceQuotes(n[attName]) else - s := s + ''''''; + s := s + 'nil'; s := s + ', '; end; @@ -232,23 +233,56 @@ begin end; end; +function fixname(e: TDOMElement): string; +begin + if e.HasAttribute('_fixup_') then + result := e['_fixup_'] + else + result := e.TagName; +end; + +function argstring(e: TDOMElement; args: TDOMNodeList): string; +var + I: Integer; + argnode: TDOMElement; +begin + Result := ''; + for I := 0 to args.Length-1 do + begin + argnode := args[I] as TDOMElement; + Result := Result + ReplaceQuotes(e[argnode.TextContent]); + if argnode.HasAttribute('type') then + Result := Result + ' as ' + PascalType(argnode['type']); + if I <> args.Length-1 then + Result := Result + ', '; + end; +end; + function prop_call(e: TDOMElement): string; begin if e.HasAttribute('var') then - Result := e['var'] + ' := ' + getobj(e) + '.' + e.TagName + ';' + Result := e['var'] + ' := ' + getobj(e) + '.' + fixname(e) + ';' else - Result := getobj(e) + '.' + e.TagName + ' := ' + ReplaceQuotes(e['value']) + ';'; + Result := getobj(e) + '.' + fixname(e) + ' := ' + ReplaceQuotes(e['value']) + ';'; end; -function func_call(e: TDOMElement; const args: array of DOMString; const rsltType: string=''): string; -var - I: Integer; +function func_call(e: TDOMElement; args: TDOMNodeList; const rsltType: string=''): string; begin if (rsltType <> '') and (TypeOfVar(e['var']) <> rsltType) then Result := rsltType + '(' + e['var'] + ')' else Result := e['var']; - Result := Result + ' := ' + getobj(e) + '.' + e.TagName; + Result := Result + ' := ' + getobj(e) + '.' + fixname(e); + if args.Length > 0 then + Result := Result + '(' + argstring(e, args) + ')'; + Result := Result + ';'; +end; + +function func_call(e: TDOMElement; const args: array of DOMString): string; +var + I: Integer; +begin + Result := e['var'] + ' := ' + getobj(e) + '.' + e.TagName; if Length(args) > 0 then begin Result := Result + '('; @@ -264,21 +298,10 @@ begin end; function method_call(e: TDOMElement; args: TDOMNodeList): string; -var - I: Integer; begin - Result := getobj(e) + '.' + e.TagName; + Result := getobj(e) + '.' + fixname(e); if args.Length > 0 then - begin - Result := Result + '('; - for I := 0 to args.Length-1 do - begin - Result := Result + ReplaceQuotes(e[args[I].TextContent]); - if I <> args.Length-1 then - Result := Result + ', '; - end; - Result := Result + ')'; - end; + Result := Result + '(' + argstring(e, args) + ')'; Result := Result + ';'; end; @@ -301,8 +324,6 @@ var cond: string; apinode: TDOMElement; arglist: TDOMNodeList; - args: array of DOMString; - I: Integer; begin FixKeywords(node, 'var'); FixKeywords(node, 'obj'); @@ -316,16 +337,19 @@ begin if assigned(apinode) then begin // handle most of DOM API in consistent way + + if apinode.HasAttribute('rename') then // handles reserved words, e.g 'type' -> 'htmlType' + node['_fixup_'] := apinode['rename']; // use this trick because DOM node cannot be renamed (yet) + arglist := apinode.GetElementsByTagName('arg'); - SetLength(args, arglist.Length); - for I := 0 to arglist.Length-1 do - args[I] := arglist[I].TextContent; + + if apinode.HasAttribute('objtype') then + CastTo(node, apinode['objtype']); + if apinode['type'] = 'prop' then rslt.Add(indent + prop_call(node)) else if apinode['type'] = 'method' then begin - if apinode.HasAttribute('objtype') then - CastTo(node, apinode['objtype']); rslt.Add(indent + method_call(node, arglist)); end else @@ -334,9 +358,7 @@ begin cond := PascalType(apinode['result']) else cond := ''; - if apinode.HasAttribute('objtype') then - CastTo(node, apinode['objtype']); - rslt.Add(indent + func_call(node, args, cond)); + rslt.Add(indent + func_call(node, arglist, cond)); if apinode['gc'] = 'yes' then rslt.Add(indent + 'GC(' + node['var'] + ');'); end; @@ -403,6 +425,8 @@ begin rslt.Add(indent + 'AssertEqualsCollection(''' + node['id'] + ''', ' + ReplaceQuotes(node['expected']) + ', ' + node['actual'] + ');') else if cond = '_list' then rslt.Add(indent + 'AssertEqualsList(''' + node['id'] + ''', ' + ReplaceQuotes(node['expected']) + ', ' + node['actual'] + ');') + else if node['ignoreCase'] = 'true' then + rslt.Add(indent + 'AssertEqualsNoCase(''' + node['id'] + ''', ' + ReplaceQuotes(node['expected']) + ', ' + node['actual'] + ');') else rslt.Add(indent + s + '(''' + node['id'] + ''', ' + ReplaceQuotes(node['expected']) + ', ' + node['actual'] + ');'); end @@ -599,7 +623,7 @@ begin // having loop var name globally unique isn't a must. cond := 'loop'+IntToStr(cntr); Inc(cntr); - rslt.Insert(2, ' ' + cond + ': Integer;'); + rslt.Insert(rslt.IndexOf('var')+1, ' ' + cond + ': Integer;'); IsColl := IsCollection(element); if IsColl then rslt.Add(indent+'for '+cond+' := 0 to ' + 'High(' + element['collection'] + ') do') @@ -837,7 +861,6 @@ begin for I := 0 to testcount-1 do begin href := TDOMElement(testlist[I])['href']; - // simple concatenation should suffice, but be paranoid ResolveRelativeURI(BaseURI, href, testuri); Pars.ParseURI(testuri, testdoc); try @@ -848,7 +871,7 @@ begin root['name'] := 'attr_name'; sl.Add('procedure ' + class_name + '.' + root['name'] + ';'); try - ConvertTest(root, sl); + ConvertTest(root, sl); except Writeln('An exception occured while converting '+root['name']); raise;