diff --git a/.gitattributes b/.gitattributes index 372cc32273..e93ed1edfd 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1647,7 +1647,11 @@ packages/fcl-xml/src/xmlutils.pp svneol=native#text/plain packages/fcl-xml/src/xmlwrite.pp svneol=native#text/plain packages/fcl-xml/src/xpath.pp svneol=native#text/plain packages/fcl-xml/tests/README svneol=native#text/plain +packages/fcl-xml/tests/README_DOM svneol=native#text/plain +packages/fcl-xml/tests/api.xml svneol=native#text/plain +packages/fcl-xml/tests/domunit.pp svneol=native#text/plain packages/fcl-xml/tests/template.xml svneol=native#text/plain +packages/fcl-xml/tests/testgen.pp svneol=native#text/plain packages/fcl-xml/tests/xmlts.pp svneol=native#text/plain packages/fftw/Makefile svneol=native#text/plain packages/fftw/Makefile.fpc svneol=native#text/plain diff --git a/packages/fcl-xml/tests/README_DOM b/packages/fcl-xml/tests/README_DOM new file mode 100644 index 0000000000..8cd5923522 --- /dev/null +++ b/packages/fcl-xml/tests/README_DOM @@ -0,0 +1,65 @@ +Testing FCL DOM implementation with official test suite from w3.org +------------------------------------------------------------------- + +*** IMPORTANT: READ CAREFULLY! + +IF YOU ARE ABOUT TO RUN THESE TESTS, CONSIDER DOING SO IN AN ENVIRONMENT +THAT YOU MAY ALLOW TO BE TRASHED. + +As of writing this at 3 June 2008, FCL DOM memory model is +not compatible - at all - with the way that w3.org tests use. In +particular, tests acquire (and use) references to objects that DOM +implementation frees. Therefore, running the tests WILL result in heap +corruption, executing arbitrary code, and any other imaginable kind of +disaster. Be warned. + +*** End of notice +-------------------------------------------------------------------- + + +To test the FCL DOM implementation, follow these steps: + +1) Checkout the DOM test suite from w3.org CVS repository. The project name is +2001/DOM-Test-Suite. Only 'tests' subdirectory is needed, everything else +is irrelevant for our purposes. +Use the following commands: + + CVSROOT=:pserver:anonymous@dev.w3.org:/sources/public + cvs login + (enter the password anonymous when prompted) + cvs checkout 2001/DOM-Test-Suite/tests + +2) Compile the testgen utility. A simple + + fpc testgen.pp + +should do it. + +3) Use testgen to convert DOM test suites into Pascal code. Specify path to the +directory that contains 'alltests.xml' file, and the name of resulting FPC unit. +Testgen expects the API description file 'api.xml' present in its directory. +Successful conversion of the following test modules is possible: + +Level 1 Core (527 tests): + testgen 2001/DOM-Test-Suite/tests/level1/core core1.pp + +Level 2 Core (282 tests): + testgen 2001/DOM-Test-Suite/tests/level2/core core2.pp + +Level 3 Core (partial only, 131 out of 722 tests): + testgen 2001/DOM-Test-Suite/tests/level3/core core3.pp + +In the examples above, output names (core1.pp, etc.) carry no defined meaning, you may +use anything instead. + +Normally, tests that contain properties/methods unsupported by FCL DOM, or +other elements not yet known to testgen, will be skipped. The conversion may be forced +by using -f commandline switch, but in this case the resulting Pascal unit will likely +fail to compile. + +4) Now, pick up your preferred fpcunit test runner, include the generated units into +its uses clause, and compile. During compilation, path to 'domunit.pp' should be added +to the unit search paths. + +5) During runtime, tests must be able to read test files which are located +within CVS source tree ('files' subdirectory of each module directory). diff --git a/packages/fcl-xml/tests/api.xml b/packages/fcl-xml/tests/api.xml new file mode 100644 index 0000000000..4c18ef9d22 --- /dev/null +++ b/packages/fcl-xml/tests/api.xml @@ -0,0 +1,260 @@ + + + + + + +]> + + + + data + + + data + + + data + + + tagName + + + name + + + name + + + target + data + + + + newChild + + + newChild + refChild + + + newChild + oldChild + + + oldChild + + + + + + + + + + + + + + + + + + + + + + name + + + arg + + + name + + + name + + + name + value + + + name + + + + + name + + + newAttr + + + oldAttr + + + + + + + offset + count + + + offset + + + arg + + + offset + count + + + offset + count + arg + + + offset + arg + + + + deep + + + tagname + + + + + + + + + + + + + + + + + + + name + + + + feature + version + + + elementId + + + importedNode + deep + + + namespaceURI + qualifiedName + + + namespaceURI + qualifiedName + + + namespaceURI + qualifiedName + doctype + + + qualifiedName + publicId + systemId + + + namespaceURI + localName + + + namespaceURI + localName + + + namespaceURI + localName + + + newAttr + + + namespaceURI + localName + + + namespaceURI + qualifiedName + value + + + namespaceURI + localName + + + arg + + + namespaceURI + localName + + + namespaceURI + localName + + + + + + + + \ No newline at end of file diff --git a/packages/fcl-xml/tests/domunit.pp b/packages/fcl-xml/tests/domunit.pp new file mode 100644 index 0000000000..3ca10b9cfe --- /dev/null +++ b/packages/fcl-xml/tests/domunit.pp @@ -0,0 +1,272 @@ +{********************************************************************** + + 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, 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: TFPObjectList; + procedure SetUp; override; + procedure TearDown; override; + procedure GC(obj: TObject); + procedure Load(out doc: TDOMDocument; const uri: string); + function getResourceURI(const res: WideString): WideString; + 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 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; + IsAbsolute: Boolean; const Actual: DOMString); + function bad_condition(const TagName: WideString): 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); + +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; + +procedure TDOMTestBase.SetUp; +begin + FParser := TDOMParser.Create; + FParser.Options.PreserveWhitespace := True; + FAutoFree := TFPObjectList.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); + assertEquals(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(exp), Length(act)); + // compare ordered + for I := 0 to High(exp) do + AssertEquals(id, 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.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: WideString): WideString; +var + Base, Level: WideString; +begin + Base := GetTestFilesURI + 'files/'; + if not ResolveRelativeURI(Base, res+'.xml', Result) then + 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: TDOMDocument; const uri: string); +var + t: TXMLDocument; +begin + doc := nil; + FParser.ParseURI(getResourceURI(uri), t); + doc := t; + GC(t); +end; + +procedure TDOMTestBase.assertInstanceOf(const id: string; obj: TObject; const typename: string); +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; + const Actual: DOMString); +var + URI: TURI; +begin + AssertTrue(id, Actual <> ''); + URI := ParseURI(utf8Encode(Actual)); + AssertEquals(id, URI.Document, utf8Encode(file_)); +end; + +function TDOMTestBase.bad_condition(const TagName: WideString): Boolean; +begin + Fail('Unsupported condition: '+ 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; + +end. + diff --git a/packages/fcl-xml/tests/testgen.pp b/packages/fcl-xml/tests/testgen.pp new file mode 100644 index 0000000000..a5e704132e --- /dev/null +++ b/packages/fcl-xml/tests/testgen.pp @@ -0,0 +1,899 @@ +{********************************************************************** + + This file is part of the Free Component Library (FCL) + + Generates fpcunit code from w3.org XML test descriptions + 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. + + **********************************************************************} + +program testgen; +{$mode objfpc}{$H+} + +uses + Classes, SysUtils, DOM, XMLRead, XMLWrite, URIParser; + +var + cntr: Integer = 0; + api: TXMLDocument; + forced: Boolean = False; + TestCount: Integer = 0; + FailCount: Integer = 0; + +function PascalType(const s: WideString): string; +begin + if (s = 'DOMString') or (s = 'boolean') or (s = 'DOMError') then + result := s + else if s = 'int' then + result := 'Integer' + else if s = 'short' then + result := 'SmallInt' + else if s = 'Collection' then + result := '_collection' + else if s = 'List' then + result := '_list' + else if Pos(WideString('DOM'), s) = 1 then + result := 'T' + s + else + result := 'TDOM'+s; +end; + +function ReplaceQuotes(const s: WideString): string; +var + quoted: Boolean; +begin + quoted := (s[1] = '"') and (s[Length(s)] = '"'); + if quoted then + result := UTF8Encode(Copy(s, 2, Length(s)-2)) + else + result := UTF8Encode(s); + + result := StringReplace(result, '\"', '"', [rfReplaceAll]); + result := StringReplace(result, '''', '''''', [rfreplaceAll]); + result := StringReplace(result, '\n', '''#10''', [rfReplaceAll]); + result := StringReplace(result, '\\', '\', [rfreplaceAll]); + + if quoted then + result := '''' + result + ''''; +end; + +procedure AppendParam(var s: string; n: TDOMElement; const attName: DOMString); +begin + if n.HasAttribute(attName) then + s := s + ReplaceQuotes(n[attName]) + else + s := s + ''''''; + s := s + ', '; +end; + +function FirstElement(n: TDOMNode): TDOMElement; +var + child: TDOMNode; +begin + child := n.FirstChild; + while Assigned(child) and (child.nodeType <> ELEMENT_NODE) do + child := child.NextSibling; + result := TDOMElement(child); +end; + +procedure GetChildElements(el: TDOMNode; List: TList); +var + child: TDOMNode; +begin + List.Clear; + child := el.FirstChild; + while Assigned(child) do + begin + if child.NodeType = ELEMENT_NODE then + List.Add(child); + child := child.NextSibling; + end; +end; + +procedure DumpUnprocessed(e: TDOMElement; dest: TStrings); +var + s: TStringStream; +begin + s := TStringStream.Create(''); + try + writeXML(e, s); + dest.Text := dest.Text + '(*****' + s.DataString + sLineBreak + '*)' + sLineBreak; + finally + s.Free; + end; +end; + +function CondToStr(e: TDOMElement; out r: string): Boolean; +var + tmp: string; + child: TDOMNode; +begin + Result := True; + if e.TagName = 'equals' then + r := e['actual'] + ' = ' + ReplaceQuotes(e['expected']) + else if e.TagName = 'notEquals' then + r := e['actual'] + ' <> ' + ReplaceQuotes(e['expected']) + else if e.TagName = 'less' then + r := e['actual'] + ' < ' + ReplaceQuotes(e['expected']) + else if e.TagName = 'greater' then + r := e['actual'] + ' > ' + ReplaceQuotes(e['expected']) + + // casting to Pointer works for both objects and strings + else if e.TagName = 'isNull' then + r := 'Pointer(' + e['obj'] + ') = nil' + else if e.TagName = 'notNull' then + r := 'Assigned(Pointer('+e['obj']+'))' + else if e.TagName = 'isTrue' then + r := e['value'] + else if (e.TagName = 'notTrue') or (e.TagName = 'isFalse') then + r := 'not ' + e['value'] + else if e.TagName = 'contentType' then + r := 'ContentTypeIs('''+e['type']+''')' + else if e.TagName = 'implementationAttribute' then + begin + r := 'implementationAttribute[''' + e['name'] + '''] = ' + e['value']; + end + else if e.TagName = 'contains' then + begin + if e['interface'] = 'DOMString' then + r := 'Pos(WideString(' + replaceQuotes(e['str']) + '), ' + e['obj'] + ') > 0' + else + r := 'bad_condition(''contains intf=' + e['interface'] + ''')'; + end + else if e.TagName = 'not' then + begin + child := e.FirstChild; + while Assigned(child) do + begin + if child.nodeType = ELEMENT_NODE then + begin + if CondToStr(TDOMElement(child), tmp) then + r := 'not ('+tmp+')'; + Break; + end; + child := child.NextSibling; + end; + end + else if (e.TagName = 'and') or (e.TagName = 'or') then + begin + r := ''; + child := e.FirstChild; + while Assigned(child) do + begin + if child.nodeType = ELEMENT_NODE then + begin + if CondToStr(TDOMElement(child), tmp) then + begin + if r <> '' then r := r + ' ' + e.TagName + ' '; + r := r + '('+tmp+')'; + end; + end; + child := child.NextSibling; + end; + end + else + begin + r := 'bad_condition(''' + e.TagName + ''')'; + Result := False; + end; +end; + +procedure ConvertTest(rootNode: TDOMElement; rslt: TStrings); +var + child, subchild: TDOMNode; + n: DOMString; + SuccessVarFlag: Boolean; + FailFlag: Boolean; + Inits, VarTypes: TStringList; + +function TypeOfVar(const varname: string): string; +begin + result := VarTypes.Values[varname]; +end; + +function IsCollection(node: TDOMElement): Boolean; +var + s: string; +begin + s := TypeOfVar(node['collection']); + Result := (s = '_collection') or (s = '_list'); +end; + +procedure CastTo(node: TDOMElement; const typename: string); +begin + if (not node.HasAttribute('interface')) and + node.HasAttribute('obj') and + (TypeOfVar(node['obj']) <> PascalType(typename)) then + node['interface'] := typename; +end; + +function getobj(e: TDOMElement): string; +var + s: string; +begin + result := e['obj']; + if e.HasAttribute('interface') then + begin + s := PascalType(e['interface']); + if TypeOfVar(e['obj']) <> s then + result := s+'('+result+')'; + end; +end; + +function prop_call(e: TDOMElement): string; +begin + if e.HasAttribute('var') then + Result := e['var'] + ' := ' + getobj(e) + '.' + e.TagName + ';' + else + Result := getobj(e) + '.' + e.TagName + ' := ' + ReplaceQuotes(e['value']) + ';'; +end; + +function func_call(e: TDOMElement; const args: array of DOMString; const rsltType: string=''): string; +var + I: Integer; +begin + if (rsltType <> '') and (TypeOfVar(e['var']) <> rsltType) then + Result := rsltType + '(' + e['var'] + ')' + else + Result := e['var']; + Result := Result + ' := ' + getobj(e) + '.' + e.TagName; + if Length(args) > 0 then + begin + Result := Result + '('; + for I := 0 to High(args) do + begin + Result := Result + ReplaceQuotes(e[args[I]]); + if I <> High(args) then + Result := Result + ', '; + end; + Result := Result + ')'; + end; + Result := Result + ';'; +end; + +function method_call(e: TDOMElement; args: TDOMNodeList): string; +var + I: Integer; +begin + Result := getobj(e) + '.' + e.TagName; + 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 + ';'; +end; + +procedure FixKeywords(node: TDOMElement; const AttrName: DOMString); +var + v: DOMString; +begin + v := node[AttrName]; + if v = 'testName' then // clash with TTest.TestName property + node[AttrName] := 'test_Name' + else if v = 'implementation' then + node[AttrName] := 'DOMImpl' + else if v = 'type' then + node[AttrName] := 'type_'; +end; + +procedure ConvertStatement(node: TDOMElement; const indent: string); +var + s: DOMString; + cond: string; + apinode: TDOMElement; + arglist: TDOMNodeList; + args: array of DOMString; + I: Integer; +begin + FixKeywords(node, 'var'); + FixKeywords(node, 'obj'); + + s := node.TagName; + apinode := api.GetElementById(s); + if assigned(apinode) then + begin + // handle most of DOM API in consistent way + arglist := apinode.GetElementsByTagName('arg'); + SetLength(args, arglist.Length); + for I := 0 to arglist.Length-1 do + args[I] := arglist[I].TextContent; + 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 + begin + if apinode.HasAttribute('result') then + cond := PascalType(apinode['result']) + else + cond := ''; + if apinode.HasAttribute('objtype') then + CastTo(node, apinode['objtype']); + rslt.Add(indent + func_call(node, args, cond)); + if apinode['gc'] = 'yes' then + rslt.Add(indent + 'GC(' + node['var'] + ');'); + end; + Exit; + end; + + // now, various hacks and workarounds + + // TODO: modify DOM to expose item() as function + if s = 'item' then + rslt.Add(indent + 'TDOMNode('+node['var'] + ') := ' + node['obj'] + '['+node['index']+'];') + else if s = 'length' then + begin + if node['interface'] = 'DOMString' then + rslt.Add(indent + node['var'] + ' := system.length(' + node['obj'] + ');') + else + rslt.Add(indent + func_call(node, [])); + end + else if s = 'implementation' then + begin + if node.HasAttribute('obj') then + rslt.Add(indent + node['var'] + ' := ' + node['obj'] + '.impl;') + else + rslt.Add(indent + node['var'] + ' := GetImplementation;'); + end + else if s = 'hasFeature' then + begin + if node.hasAttribute('var') then + begin + // we don't have null strings, replace with an empty one + if not node.hasAttribute('version') then + node['version'] := '""'; + rslt.Add(indent + func_call(node, ['feature', 'version'])) + end + else + rslt.Add(indent + 'CheckFeature(' + ReplaceQuotes(node['feature']) + ');') + end + + // service (non-DOM) statements follow + + else if s = 'append' then + rslt.Add(indent + '_append(' + node['collection'] + ', ' + node['item'] + ');') + else if s = 'assign' then + rslt.Add(indent + '_assign(' + node['var'] + ', ' + node['value'] + ');') + else if s = 'increment' then + rslt.Add(indent + 'Inc(' + node['var'] + ', ' + node['value'] + ');') + else if s = 'decrement' then + rslt.Add(indent + 'Dec(' + node['var'] + ', ' + node['value'] + ');') + else if s = 'plus' then + rslt.Add(indent + node['var'] + ' := ' + ReplaceQuotes(node['op1']) + ' + ' + ReplaceQuotes(node['op2'])) + + else if s = 'fail' then + rslt.Add(indent + s + '(''' + node['id'] + ''');') + else if s = 'assertEquals' then + begin + cond := TypeOfVar(node['actual']); + if cond = '_collection' then + 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 + rslt.Add(indent + s + '(''' + node['id'] + ''', ' + ReplaceQuotes(node['expected']) + ', ' + node['actual'] + ');'); + end + else if s = 'assertSame' then + rslt.Add(indent + s + '(''' + node['id'] + ''', ' + ReplaceQuotes(node['expected']) + ', ' + node['actual'] + ');') + else if (s = 'assertNull') or (s = 'assertNotNull') {or (s='assertFalse')} then + rslt.Add(indent + s + '(''' + node['id'] + ''', ' + node['actual'] + ');') + else if s = 'assertSize' then + rslt.Add(indent + s + '(''' + node['id'] + ''', ' + node['size'] + ', ' + node['collection']+');') + else if s = 'assertInstanceOf' then + rslt.Add(indent + s + '(''' + node['id'] + ''', ' + node['obj'] + ', ''' + PascalType(node['type'])+''');') + else if (s = 'assertTrue') or (s='assertFalse') then + if node.HasChildNodes then + begin + child := FirstElement(node); + CondToStr(TDOMElement(child), cond); + rslt.Add(indent + s + '(''' + node['id'] + ''', ' + cond + ');'); + end + else + rslt.Add(indent + s + '(''' + node['id'] + ''', ' + node['actual'] + ');') + else if s = 'assertURIEquals' then + begin + // TODO: maybe add 'flags' argument to specify which strings are non-NULL + cond := '''' + node['id'] + ''', '; + AppendParam(cond, node, 'scheme'); + AppendParam(cond, node, 'path'); + AppendParam(cond, node, 'host'); + AppendParam(cond, node, 'file'); + AppendParam(cond, node, 'name'); + AppendParam(cond, node, 'query'); + AppendParam(cond, node, 'fragment'); + + if node.HasAttribute('isAbsolute') then + cond := cond + node['isAbsolute'] + else + cond := cond + 'False'; + cond := cond + ', '; + + cond := cond + node['actual']; + rslt.Add(indent + s + '(' + cond + ');'); + end + else if n = 'load' then + rslt.Add(indent + 'Load('+node['var']+', '''+ node['href']+''');') + else if s = 'implementationAttribute' then + rslt.Add(indent + s + '[''' + node['name'] + '''] := ' + node['value'] + ';') + else + begin + if not FailFlag then + rslt.Add(indent + 'Fail(''This test is not completely converted'');'); + FailFlag := True; + DumpUnprocessed(node, rslt); + end; +end; + +procedure ConvertBlock(el: TDOMNode; indent: string); +var + curr: TDOMNode; + element: TDOMElement; + List: TList; + cond, excode: string; + Frag: TDOMDocumentFragment; + I: Integer; + ElseNode: TDOMNode; + IsColl: Boolean; +begin + List := TList.Create; + curr := el.FirstChild; + indent := indent + ' '; + while Assigned(curr) do + begin + if (curr.NodeType <> ELEMENT_NODE) or + (curr.NodeName = 'var') or (curr.NodeName = 'metadata') then + begin + curr := curr.NextSibling; + Continue; + end; + 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 + else if n = 'try' then + begin + GetChildElements(curr, List); + rslt.Add(indent+'try'); + I := 0; + while I < List.Count do + begin + Child := TDOMNode(List[I]); + if Child.NodeName = 'catch' then + break; + ConvertStatement(TDOMElement(child), indent + ' '); + Inc(I); + end; + if (child.NodeName <> 'catch') or (Pointer(Child) <> List.Last) then + rslt.Add('{ ERROR: misplaced "catch" tag }'); + GetChildElements(child, List); + cond := ''; + for I := 0 to List.Count-1 do + begin + if TDOMElement(List[I]).TagName <> 'DOMException' then + begin + rslt.Add('{ ERROR: unhandled: ' + TDOMElement(List[I]).TagName +' }'); + Break; + end; + if cond <> '' then cond := cond + ', '; + cond := cond + TDOMElement(List[I])['code']; + end; + + rslt.Add(indent+'except'); + rslt.Add(indent+' on E: EDOMError do'); + rslt.Add(indent+' if not (E.code in ['+cond+']) then raise;'); + rslt.Add(indent+'end;'); + end + else if n = 'if' then + begin + ElseNode := nil; + GetChildElements(curr, List); + if (List.Count > 1) and CondToStr(TDOMElement(List[0]), cond) then + begin + rslt.Add(indent+ 'if '+cond+' then'); + frag := curr.OwnerDocument.CreateDocumentFragment; + try + // first node is the condition; skip it + for I := 1 to List.Count-1 do + begin + child := TDOMNode(List[I]); + if child.NodeName = 'else' then + begin + ElseNode := child; + Break; + end; + frag.AppendChild(child.CloneNode(True)); + end; + rslt.add(indent+'begin'); + ConvertBlock(frag, indent); + if Assigned(ElseNode) then + begin + rslt.add(indent+'end'); + rslt.Add(indent+'else'); + rslt.Add(indent+'begin'); + ConvertBlock(ElseNode, indent); + end; + rslt.add(indent+'end;'); + finally + frag.Free; + end; + end + else + begin + rslt.Add('{ ERROR: malformed "if" tag }'); + dumpunprocessed(element, rslt); + end; + end + else if n = 'for-each' then + begin + // having loop var name globally unique isn't a must. + cond := 'loop'+IntToStr(cntr); + Inc(cntr); + rslt.Insert(2, ' ' + cond + ': Integer;'); + IsColl := IsCollection(element); + if IsColl then + rslt.Add(indent+'for '+cond+' := 0 to ' + 'High(' + element['collection'] + ') do') + else + rslt.Add(indent+'for '+cond+' := 0 to ' + element['collection'] + '.Length-1 do'); + rslt.Add(indent+'begin'); + if IsColl then + rslt.Add(indent+' ' + element['member'] + ' := '+element['collection']+'['+cond+'];') + else + rslt.Add(indent+' ' + 'TDOMNode('+element['member'] + ') := '+element['collection']+'['+cond+'];'); + ConvertBlock(element, indent); + rslt.Add(indent+'end;'); + end + else if n = 'while' then + begin + GetChildElements(curr, List); + if (List.Count > 1) and CondToStr(TDOMElement(List[0]), cond) then + begin + rslt.Add(indent+ 'while '+cond+' do'); + frag := curr.OwnerDocument.CreateDocumentFragment; + try + for I := 1 to List.Count-1 do // skip first node which is the condition + begin + child := TDOMNode(List[I]); + frag.AppendChild(child.CloneNode(True)); + end; + rslt.add(indent+'begin'); + ConvertBlock(frag, indent); + rslt.add(indent+'end;'); + finally + frag.Free; + end; + end + else + begin + rslt.Add('{ ERROR: malformed "while" tag }'); + DumpUnprocessed(element, rslt); + end; + end + else + ConvertStatement(element, indent); + curr := curr.NextSibling; + end; + List.Free; +end; + +procedure ConvertVars; +var + TypedConsts: TStrings; + I, J: Integer; + vars, subvars: TDOMNodeList; + node: TDOMElement; + hs: string; +begin + TypedConsts := TStringList.Create; + vars := rootNode.GetElementsByTagName('var'); + if vars.Count > 0 then + begin + rslt.Add('var'); + for I := 0 to vars.Count-1 do + begin + node := TDOMElement(vars[I]); + FixKeywords(node, 'name'); + if node.hasAttribute('isNull') or node.hasAttribute('value') then + begin + // TODO: isNull is identified by 'yes' value, not by mere attr presence? + // TODO: consider putting isNull things to constants + if node.hasAttribute('value') then + hs := ReplaceQuotes(Node['value']) + else + begin + if node['type'] = 'DOMString' then + hs := '''''' + else + hs := 'nil'; + end; + Inits.Add(' ' + node['name'] + ' := ' + hs + ';'); + end; + if Node.HasChildNodes then + begin + subvars := Node.GetElementsByTagName('member'); + try + if subvars.Count > 0 then + begin + TypedConsts.Add(' ' + Node['name'] + ': array[0..' + IntToStr(subvars.Count-1) + '] of DOMString = ('); + for J := 0 to subvars.Count-1 do + begin + hs := ' ' + ReplaceQuotes(subvars[J].TextContent); + if J = subvars.Count-1 then + TypedConsts.Add(hs + ');') + else + TypedConsts.Add(hs + ','); + end; + end + else + DumpUnprocessed(Node, rslt); + finally + subvars.Free; + end; + end + else + rslt.Add(' ' + Node['name'] +': '+ PascalType(Node['type'])+';'); + VarTypes.Add(Node['name'] + '=' + PascalType(Node['type'])); + end; + if TypedConsts.Count > 0 then + begin + rslt.add('const'); + rslt.AddStrings(TypedConsts); + end; + end; + vars.Free; + TypedConsts.Free; +end; + +// ConvertTest() itself +begin + SuccessVarFlag := False; + FailFlag := False; + VarTypes := TStringList.Create; + Inits := TStringList.Create; + ConvertVars; + rslt.add('begin'); + rslt.AddStrings(Inits); + Inits.Free; + ConvertBlock(rootNode, ''); + VarTypes.Free; + rslt.add('end;'); + rslt.Add(''); + + if FailFlag then + begin + if not forced then + rslt.Clear; + Inc(FailCount); + end; +end; + +// Intercepting validation errors while loading API +type + TErrHandler = class(TObject) + public + procedure HandleError(E: EXMLReadError); + end; + +procedure TErrHandler.HandleError(E: EXMLReadError); +begin + raise E; +end; + +const + UnitHeader = + +'{ AUTOGENERATED FILE - DO NOT EDIT'#10+ +' This Pascal source file was generated by testgen program'#10 + +' and is a derived work from the source document.'#10 + +' The source document contained the following notice:'#10+ +'%s}'#10+ +'unit %s;'#10 + +'{$mode objfpc}{$h+}'#10 + +'{$notes off}'#10 + +'{$codepage utf8}'#10 + +'interface'#10 + +#10 + +'uses'#10 + +' SysUtils, Classes, DOM, xmlread, fpcunit, contnrs, domunit, testregistry;'#10 + +#10 + +'type'#10 + +' %s = class(TDOMTestBase)'#10 + +' protected'#10 + +' function GetTestFilesURI: string; override;'#10 + +' published'#10; + +procedure ConvertSuite(const BaseURI: DOMString; const UnitFileName: string); +var + suite, testdoc: TXMLDocument; + testlist: TDOMNodeList; + root: TDOMElement; + href, testuri: DOMString; + I: Integer; + sl, all, impl: TStringList; + Pars: TDOMParser; + eh: TErrHandler; + class_name, unit_name, notice: string; + comment: TDOMNode; +begin + Pars := TDOMParser.Create; + eh := TErrHandler.Create; + Pars.Options.Validate := True; + Pars.OnError := @eh.HandleError; + // API database must be loaded in validating mode + Pars.ParseURI('file:api.xml', api); + + sl := TStringList.Create; + all := TStringList.Create; + impl := TStringList.Create; + + Pars.OnError := nil; + Pars.Options.ExpandEntities := True; + Pars.ParseURI(BaseURI + 'alltests.xml', suite); + // extract the copyright notice + notice := ''; + comment := suite.FirstChild; + while Assigned(comment) do + begin + if (comment.nodeType = COMMENT_NODE) and + (Pos(DOMString('Copyright'), comment.nodeValue) > 0) then + begin + notice := comment.nodeValue; + Break; + end; + comment := comment.nextSibling; + end; + + unit_name := ChangeFileExt(ExtractFileName(UnitFileName), ''); + class_name := 'TTest' + UpperCase(unit_name[1]) + copy(unit_name, 2, MaxInt); + // provide unit header + all.Text := Format(UnitHeader, [notice, unit_name, class_name]); + // emit the 'GetPathToModuleFiles' function body + impl.Add('implementation'); + impl.Add(''); + impl.Add('function '+class_name+'.GetTestFilesURI: string;'); + impl.Add('begin'); + impl.Add(' result := ''' + BaseURI + ''';'); + impl.Add('end;'); + impl.Add(''); + + testlist := suite.GetElementsByTagName('suite.member'); + testcount := testlist.Count; + writeln; + writeln(testcount, ' test cases found'); + 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 + sl.Clear; + root := testdoc.DocumentElement; + // fix clash with local vars having the same name + if root['name'] = 'attrname' then + root['name'] := 'attr_name'; + sl.Add('procedure ' + class_name + '.' + root['name'] + ';'); + ConvertTest(root, sl); + if sl.Count > 0 then + begin + all.add(' procedure '+root['name']+';'); + impl.AddStrings(sl) + end; + finally + testdoc.Free; + end; + end; + testlist.Free; + suite.Free; + + // terminate class declaration + all.Add(' end;'); + all.Add(''); + // append all procedure bodies + all.AddStrings(impl); + + all.Add('initialization'); + all.Add(' RegisterTest('+class_name+');'); + all.Add('end.'); + all.SaveToFile(UnitFileName); + impl.Free; + all.Free; + sl.Free; + eh.Free; + Pars.Free; +end; + +var + SuiteName: string; + OutputUnit: string; + s: string; + I: Integer; + +begin + writeln('testgen - w3.org DOM test suite to Pascal converter'); + writeln('Copyright (c) 2008 by Sergei Gorelkin'); + + if ParamCount < 2 then + begin + writeln; + writeln('Usage: ', ParamStr(0), ' [-f]'); + writeln(' -f: force conversion of tests which contain unknown tags'); + Exit; + end; + + SuiteName := ExpandFilename(ParamStr(1)); + OutputUnit := ExpandFilename(ParamStr(2)); + i := 3; + while i <= ParamCount do + begin + s := Lowercase(ParamStr(i)); + if s = '-f' then + forced := True; + Inc(i); + end; + // strip filename if present, we're going to read all dir + if not DirectoryExists(SuiteName) then + SuiteName := ExtractFilePath(SuiteName) + else + SuiteName := IncludeTrailingPathDelimiter(SuiteName); + + ConvertSuite(FilenameToURI(SuiteName), OutputUnit); + + writeln(testcount - FailCount, ' tests converted successfully'); + if FailCount > 0 then + begin + writeln(FailCount, ' tests contain tags that are not supported yet'); + if forced then + begin + writeln('Conversion of these tests was forced,'); + writeln('the resulting file may not compile!'); + end + else + writeln('These tests were skipped'); + end; +end. +