paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 11:29:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Initial testsuite from Sergei Gorelkin

Browse Source 
* testgen.pp - an utility to convert w3.org tests from XML format
      into fpcunit-compatible Pascal source. The official testsuite uses
      xslt for conversion, but, since there is no xslt for Pascal, and no
      xslt support in FCL yet, I wrote an utility.
    * api.xml    - API 'database', needed by testgen.
    * domunit.pp - an fpcunit extension, provides DOM-specific runtime
      support.
    * README_DOM - provides some instructions about putting it all together.

git-svn-id: trunk@11390 -
This commit is contained in:
michael 2008-07-17 14:57:31 +00:00
parent 42601356dd
commit b3d983ce07
5 changed files with 1500 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

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

65
packages/fcl-xml/tests/README_DOM Normal file
View File

@ -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).

260
packages/fcl-xml/tests/api.xml Normal file
View File

@ -0,0 +1,260 @@
<?xml version="1.0" encoding="utf-8"?>
<!--
A free-form description of DOM API, lists properties/methods,
their arguments and result types.
This is used by testgen program to convert w3.org XML test descriptions into
fpcUnit-compatible Pascal code.
-->
<!DOCTYPE api [
<!ELEMENT api (item)+ >
<!ELEMENT item (arg*)>
<!ELEMENT arg (#PCDATA)>
<!ATTLIST item
id ID #REQUIRED
type (func|prop|method) "func"
result CDATA #IMPLIED
objtype CDATA #IMPLIED
gc (yes|no) #IMPLIED>
]>
<api>
<item id="createDocumentFragment"/>
<item id="createTextNode">
<arg>data</arg>
</item>
<item id="createComment">
<arg>data</arg>
</item>
<item id="createCDATASection">
<arg>data</arg>
</item>
<item id="createElement">
<arg>tagName</arg>
</item>
<item id="createAttribute">
<arg>name</arg>
</item>
<item id="createEntityReference">
<arg>name</arg>
</item>
<item id="createProcessingInstruction">
<arg>target</arg>
<arg>data</arg>
</item>
<item id="appendChild" result="Node">
<arg>newChild</arg>
</item>
<item id="insertBefore" result="Node">
<arg>newChild</arg>
<arg>refChild</arg>
</item>
<item id="replaceChild" result="Node">
<arg>newChild</arg>
<arg>oldChild</arg>
</item>
<item id="removeChild" result="Node">
<arg>oldChild</arg>
</item>
<item id="firstChild" result="Node"/>
<item id="lastChild" result="Node"/>
<item id="parentNode" result="Node"/>
<item id="nextSibling" result="Node"/>
<item id="previousSibling" result="Node"/>
<item id="ownerDocument" result="Node"/>
<item id="nodeType"/>
<item id="attributes"/>
<item id="name"/>
<item id="nodeName"/>
<item id="hasChildNodes"/>
<item id="doctype"/>
<item id="documentElement"/>
<item id="entities"/>
<item id="notations"/>
<item id="publicId" type="prop"/> <!-- settable for DOM lvl 3 LSInput -->
<item id="systemId" type="prop"/>
<item id="notationName"/>
<item id="getNamedItem" result="Node">
<arg>name</arg>
</item>
<item id="setNamedItem">
<arg>arg</arg>
</item>
<item id="removeNamedItem">
<arg>name</arg>
</item>
<item id="getAttribute">
<arg>name</arg>
</item>
<item id="setAttribute" objtype="Element" type="method">
<arg>name</arg>
<arg>value</arg>
</item>
<item id="removeAttribute" objtype="Element" type="method">
<arg>name</arg>
</item>
<item id="tagName" objtype="Element"/>
<item id="getAttributeNode">
<arg>name</arg>
</item>
<item id="setAttributeNode">
<arg>newAttr</arg>
</item>
<item id="removeAttributeNode">
<arg>oldAttr</arg>
</item>
<item id="specified" objtype="Attr"/>
<item id="normalize" type="method"/>
<item id="substringData">
<arg>offset</arg>
<arg>count</arg>
</item>
<item id="splitText" objtype="Text">
<arg>offset</arg>
</item>
<item id="appendData" objtype="CharacterData" type="method">
<arg>arg</arg>
</item>
<item id="deleteData" objtype="CharacterData" type="method">
<arg>offset</arg>
<arg>count</arg>
</item>
<item id="replaceData" objtype="CharacterData" type="method">
<arg>offset</arg>
<arg>count</arg>
<arg>arg</arg>
</item>
<item id="insertData" objtype="CharacterData" type="method">
<arg>offset</arg>
<arg>arg</arg>
</item>
<item id="cloneNode" result="Node">
<arg>deep</arg>
</item>
<item id="getElementsByTagName" gc="yes">
<arg>tagname</arg>
</item>
<item id="childNodes" gc="yes"/>
<item id="value" type="prop"/>
<item id="nodeValue" type="prop"/>
<item id="data" type="prop"/>
<item id="target" type="prop"/>
<!-- Level 2 -->
<item id="namespaceURI"/>
<item id="localName"/>
<item id="internalSubset"/>
<item id="hasAttributes"/>
<item id="prefix" type="prop"/>
<item id="ownerElement" objtype="Attr"/>
<item id="hasAttribute">
<arg>name</arg>
</item>
<item id="isSupported">
<arg>feature</arg>
<arg>version</arg>
</item>
<item id="getElementById">
<arg>elementId</arg>
</item>
<item id="importNode" result="Node">
<arg>importedNode</arg>
<arg>deep</arg>
</item>
<item id="createAttributeNS">
<arg>namespaceURI</arg>
<arg>qualifiedName</arg>
</item>
<item id="createElementNS">
<arg>namespaceURI</arg>
<arg>qualifiedName</arg>
</item>
<item id="createDocument">
<arg>namespaceURI</arg>
<arg>qualifiedName</arg>
<arg>doctype</arg>
</item>
<item id="createDocumentType">
<arg>qualifiedName</arg>
<arg>publicId</arg>
<arg>systemId</arg>
</item>
<item id="getAttributeNodeNS" objtype="Element">
<arg>namespaceURI</arg>
<arg>localName</arg>
</item>
<item id="getAttributeNS" objtype="Element">
<arg>namespaceURI</arg>
<arg>localName</arg>
</item>
<item id="hasAttributeNS" objtype="Element">
<arg>namespaceURI</arg>
<arg>localName</arg>
</item>
<item id="setAttributeNodeNS" objtype="Element">
<arg>newAttr</arg>
</item>
<item id="removeAttributeNS" objtype="Element" type="method">
<arg>namespaceURI</arg>
<arg>localName</arg>
</item>
<item id="setAttributeNS" objtype="Element" type="method">
<arg>namespaceURI</arg>
<arg>qualifiedName</arg>
<arg>value</arg>
</item>
<item id="getNamedItemNS" result="Node">
<arg>namespaceURI</arg>
<arg>localName</arg>
</item>
<item id="setNamedItemNS">
<arg>arg</arg>
</item>
<item id="removeNamedItemNS" result="Node">
<arg>namespaceURI</arg>
<arg>localName</arg>
</item>
<item id="getElementsByTagNameNS" gc="yes">
<arg>namespaceURI</arg>
<arg>localName</arg>
</item>
<!-- Level 3 -->
<item id="textContent" type="prop"/>
<!-- item id="isElementContentWhitespace"/ --><!-- not there yet -->
<!--
<item id="domConfig"/>
<item id="schemaTypeInfo"/>
<item id="typeName"/>
<item id="typeNamespace"/>
<item id="isDerivedFrom"/>
<item id="canSetParameter"/>
<item id="setParameter"/>
<item id="normalizeDocument"/>
<item id="isId"/>
// assertNotEquals
// assertLowerSeverity
<item id="getUserData"/>
<item id="setUserData"/>
<item id="isEqualNode"/>
<item id="isSameNode"/>
<item id="lookupNamespaceURI"/>
<item id="lookupPrefix"/>
<item id="isDefaultNamespace"/>
<item id="adoptNode"/>
<item id="renameNode"/>
<item id="replaceWholeText"/>
<item id="wholeText"/>
-->
</api>

272
packages/fcl-xml/tests/domunit.pp Normal file
View File

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

899
packages/fcl-xml/tests/testgen.pp Normal file
View File

@ -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), ' <suite dir> <outputunit.pp> [-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.