{********************************************************************** This file is part of the Free Component Library (FCL) fpcunit extensions required to run w3.org DOM test suites Copyright (c) 2008 by Sergei Gorelkin, sergei_gorelkin@mail.ru See the file COPYING.FPC, included in this distribution, for details about the copyright. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} unit domunit; {$mode objfpc}{$H+} interface uses Classes, SysUtils, xmlutils, DOM, XMLRead, contnrs, fpcunit; type { these two types are separated for the purpose of readability } _collection = array of DOMString; // unordered _list = _collection; // ordered TDOMTestBase = class(TTestCase) private procedure setImplAttr(const name: string; value: Boolean); function getImplAttr(const name: string): Boolean; protected // override for this one is generated by testgen for each descendant function GetTestFilesURI: string; virtual; protected FParser: TDOMParser; FAutoFree: TObjectList; procedure SetUp; override; procedure TearDown; override; procedure GC(obj: TObject); procedure Load(out doc; const uri: string); procedure LoadStringData(out Doc; const data: string); function getResourceURI(const res: XMLString): XMLString; function ContentTypeIs(const t: string): Boolean; function GetImplementation: TDOMImplementation; procedure CheckFeature(const name: string); procedure assertNull(const id: string; const ws: DOMString); overload; 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 assertEqualsW(const id: string; const exp, act: DOMString); 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; scheme, path, host, file_, name, query, fragment: PChar; IsAbsolute: Boolean; const Actual: DOMString); function bad_condition(const TagName: XMLString): Boolean; property implementationAttribute[const name: string]: Boolean read getImplAttr write setImplAttr; end; 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 uses URIParser; procedure _append(var coll: _collection; const Value: DOMString); var L: Integer; begin L := Length(coll); SetLength(coll, L+1); coll[L] := Value; end; procedure _assign(out rslt: _collection; const value: array of DOMString); var I: Integer; begin SetLength(rslt, Length(value)); for I := 0 to High(value) do rslt[I] := value[I]; end; function IsSame(exp, act: TDOMNode): Boolean; begin Result := exp = act; end; procedure TDOMTestBase.SetUp; begin FParser := TDOMParser.Create; FParser.Options.PreserveWhitespace := True; //FParser.Options.ExpandEntities := True; FAutoFree := TObjectList.Create(True); end; procedure TDOMTestBase.TearDown; begin FreeAndNil(FAutoFree); FreeAndNil(FParser); end; procedure TDOMTestBase.GC(obj: TObject); begin FAutoFree.Add(obj); end; procedure TDOMTestBase.assertSame(const id: string; exp, act: TDOMNode); begin if exp <> act then begin assertNotNull(id, exp); assertNotNull(id, act); assertEquals(id, exp.nodeType, act.nodeType); assertEqualsW(id, exp.nodeValue, act.nodeValue); end; end; procedure TDOMTestBase.assertNull(const id: string; const ws: DOMString); begin if ws <> '' then Fail(id); end; procedure TDOMTestBase.assertEquals(const id: string; exp, act: TObject); begin inherited assertSame(id, exp, act); end; procedure TDOMTestBase.assertEqualsList(const id: string; const exp: array of DOMString; const act: _list); var I: Integer; begin AssertEquals(id+'(length)', Length(exp), Length(act)); // compare ordered for I := 0 to High(exp) do AssertEqualsW(id+'['+IntToStr(I)+']', exp[I], act[I]); end; procedure TDOMTestBase.assertEqualsCollection(const id: string; const exp: array of DOMString; const act: _collection); var I, J, matches: Integer; begin AssertEquals(id, Length(exp), Length(act)); // compare unordered for I := 0 to High(exp) do begin matches := 0; for J := 0 to High(act) do if act[J] = exp[I] then Inc(matches); AssertTrue(id+': no match found for <'+exp[I]+'>', matches <> 0); AssertTrue(id+': multiple matches for <'+exp[I]+'>', matches = 1); end; end; procedure TDOMTestBase.assertEqualsW(const id: string; const exp, act: DOMString); begin AssertTrue(id + ComparisonMsg(exp, act), exp = act); 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); AssertEquals(id, size, obj.Length); end; procedure TDOMTestBase.assertSize(const id: string; size: Integer; obj: TDOMNamedNodeMap); begin AssertNotNull(id, obj); AssertEquals(id, size, obj.Length); end; function TDOMTestBase.getResourceURI(const res: XMLString): XMLString; var Base, Base2: XMLString; function CheckFile(const uri: XMLString; out name: XMLString): Boolean; var filename: string; begin Result := ResolveRelativeURI(uri + 'files/', res + '.xml', name) and URIToFilename(name, filename) and FileExists(filename); end; begin Base := GetTestFilesURI; if Pos(XMLString('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; CheckFile(Base, Result); end; function TDOMTestBase.getImplAttr(const name: string): Boolean; begin if name = 'expandEntityReferences' then result := FParser.Options.ExpandEntities else if name = 'validating' then result := FParser.Options.Validate else if name = 'namespaceAware' then result := FParser.Options.Namespaces else if name = 'ignoringElementContentWhitespace' then result := not FParser.Options.PreserveWhitespace else begin Fail('Unknown implementation attribute: ''' + name + ''''); result := False; end; end; procedure TDOMTestBase.setImplAttr(const name: string; value: Boolean); begin if name = 'validating' then FParser.Options.Validate := value else if name = 'expandEntityReferences' then FParser.Options.ExpandEntities := value else if name = 'coalescing' then // TODO: action unknown yet else if (name = 'signed') and value then Ignore('Setting implementation attribute ''signed'' to ''true'' is not supported') else if name = 'hasNullString' then // TODO: probably we cannot support this else if name = 'namespaceAware' then FParser.Options.Namespaces := value else if name = 'ignoringElementContentWhitespace' then FParser.Options.PreserveWhitespace := not value else Fail('Unknown implementation attribute: ''' + name + ''''); end; procedure TDOMTestBase.Load(out doc; const uri: string); var t: TXMLDocument; begin TObject(doc) := nil; FParser.ParseURI(getResourceURI(uri), t); TObject(doc) := t; GC(t); end; procedure TDOMTestBase.assertInstanceOf(const id: string; obj: TObject; const typename: string); begin AssertTrue(id, obj.ClassNameIs(typename)); end; { 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+'#0', Actual <> ''); URI := ParseURI(utf8Encode(Actual)); if fragment <> nil then AssertEquals(id+'#1', string(fragment), URI.Bookmark); if query <> nil then AssertEquals(id+'#2', string(query), URI.Params); if scheme <> nil then AssertEquals(id+'#3', string(scheme), URI.Protocol); if host <> nil then begin AssertTrue(id+'#4', URI.HasAuthority); AssertEquals(id+'#5', string(host), URI.Host); end; if path <> nil then AssertEquals(id+'#6', string(path), '//' + Uri.Host + URI.Path + URI.Document); if file_ <> nil then AssertEquals(id+'#7', string(file_), URI.Document); if name <> nil then AssertEquals(id+'#8', string(name), ChangeFileExt(URI.Document, '')); end; function TDOMTestBase.bad_condition(const TagName: XMLString): Boolean; begin Fail('Unsupported condition: '+ AnsiString(TagName)); Result := False; end; function TDOMTestBase.ContentTypeIs(const t: string): Boolean; begin { For now, claim only xml as handled content. This may be extended with html and svg. } result := (t = 'text/xml'); end; function TDOMTestBase.GetImplementation: TDOMImplementation; begin result := nil; end; procedure TDOMTestBase.CheckFeature(const name: string); begin // purpose/action is currently unknown end; function TDOMTestBase.GetTestFilesURI: string; begin result := ''; end; procedure TDOMTestBase.LoadStringData(out Doc; const data: string); var src: TXMLInputSource; begin src := TXMLInputSource.Create(data); try FParser.Parse(src, TXMLDocument(Doc)); GC(TObject(Doc)); finally src.Free; end; end; end.