mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-27 19:13:44 +02:00
1022 lines
30 KiB
ObjectPascal
1022 lines
30 KiB
ObjectPascal
{**********************************************************************
|
|
|
|
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;
|
|
IgnoreCount: Integer = 0;
|
|
|
|
function PascalType(const s: WideString): string;
|
|
begin
|
|
if (s = 'DOMString') or (s = 'boolean') or (s = 'DOMError') or (s = 'double') 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) or (Pos(WideString('XPath'), s) = 1) or
|
|
(Pos(WideString('HTML'), 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 + 'nil';
|
|
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 = 'same' then
|
|
begin
|
|
// maybe it would be sufficient to just compare pointers, but let's emit a helper for now
|
|
r := 'IsSame('+ e['expected'] + ', ' + e['actual'] + ')';
|
|
end
|
|
else if e.TagName = 'not' then
|
|
begin
|
|
child := e.FirstChild;
|
|
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, IgnoreFlag: 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 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) + '.' + fixname(e) + ';'
|
|
else
|
|
Result := getobj(e) + '.' + fixname(e) + ' := ' + ReplaceQuotes(e['value']) + ';';
|
|
end;
|
|
|
|
function func_call(e: TDOMElement; args: TDOMNodeList; const rsltType: string=''; IsDefProp: Boolean=False): string;
|
|
begin
|
|
if (rsltType <> '') and (TypeOfVar(e['var']) <> rsltType) then
|
|
Result := rsltType + '(' + e['var'] + ')'
|
|
else
|
|
Result := e['var'];
|
|
if IsDefProp then
|
|
Result := Result + ' := ' + getobj(e) + '[' + argstring(e, args) + ']'
|
|
else
|
|
begin
|
|
Result := Result + ' := ' + getobj(e) + '.' + fixname(e);
|
|
if args.Length > 0 then
|
|
Result := Result + '(' + argstring(e, args) + ')';
|
|
end;
|
|
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 + '(';
|
|
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;
|
|
begin
|
|
Result := getobj(e) + '.' + fixname(e);
|
|
if args.Length > 0 then
|
|
Result := Result + '(' + argstring(e, args) + ')';
|
|
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;
|
|
begin
|
|
FixKeywords(node, 'var');
|
|
FixKeywords(node, 'obj');
|
|
|
|
s := node.TagName;
|
|
apinode := api.GetElementById(s);
|
|
// If not found by name only, try prepending the interface name.
|
|
// This enables support of same-named methods with different param lists on different objects
|
|
if (apinode = nil) and node.HasAttribute('interface') then
|
|
apinode := api.GetElementById(node['interface'] + '.' + s);
|
|
if assigned(apinode) then
|
|
begin
|
|
// handle most of DOM API in consistent way
|
|
|
|
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');
|
|
|
|
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
|
|
rslt.Add(indent + method_call(node, arglist));
|
|
end
|
|
else
|
|
begin
|
|
if apinode.HasAttribute('result') then
|
|
cond := PascalType(apinode['result'])
|
|
else
|
|
cond := '';
|
|
rslt.Add(indent + func_call(node, arglist, cond, apinode['type']='defprop'));
|
|
if apinode['gc'] = 'yes' then
|
|
rslt.Add(indent + 'GC(' + node['var'] + ');');
|
|
end;
|
|
Exit;
|
|
end;
|
|
|
|
// now, various hacks and workarounds
|
|
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'] + ', ' + ReplaceQuotes(node['item']) + ');')
|
|
else if s = 'assign' then
|
|
begin
|
|
cond := TypeOfVar(node['var']);
|
|
if (cond = '_collection') or (cond = '_list') then
|
|
rslt.Add(indent + '_assign(' + node['var'] + ', ' + node['value'] + ');')
|
|
else // emit an assignment operator. Force type for the case where they assign Document to Element.
|
|
rslt.Add(indent + node['var'] + ' := ' + TypeOfVar(node['var']) + '(' + ReplaceQuotes(node['value']) + ');');
|
|
end
|
|
else if s = 'increment' then
|
|
rslt.Add(indent + 'Inc(' + node['var'] + ', ' + node['value'] + ');')
|
|
else if s = 'decrement' then
|
|
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 if cond = 'DOMString' then
|
|
rslt.Add(indent + 'AssertEqualsW(''' + 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
|
|
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
|
|
begin
|
|
if (node['name']='signed') and (node['value']='true') then
|
|
IgnoreFlag := True;
|
|
rslt.Add(indent + s + '[''' + node['name'] + '''] := ' + node['value'] + ';')
|
|
end
|
|
else if s = 'createXPathEvaluator' then
|
|
rslt.Add(indent + node['var'] + ' := CreateXPathEvaluator(' + node['document'] + ');')
|
|
else if s = 'comment' then
|
|
rslt.Add(indent + '{ Source comment: ' + node.TextContent + ' }')
|
|
else
|
|
begin
|
|
if not FailFlag then
|
|
rslt.Add(indent + 'Fail(''This test is not completely converted'');');
|
|
FailFlag := True;
|
|
DumpUnprocessed(node, rslt);
|
|
end;
|
|
end;
|
|
|
|
procedure ConvertException(el: TDOMElement; const ExceptClass: string; indent: string);
|
|
var
|
|
excode: string;
|
|
begin
|
|
if not SuccessVarFlag then
|
|
rslt.Insert(2, ' success: Boolean;');
|
|
SuccessVarFlag := True;
|
|
rslt.Add(indent+'success := False;');
|
|
rslt.Add(indent+'try');
|
|
child := el.FirstChild;
|
|
while assigned(child) do
|
|
begin
|
|
if child.nodeType = ELEMENT_NODE then
|
|
begin
|
|
excode := child.nodeName;
|
|
subchild := child.FirstChild;
|
|
while Assigned(subchild) do
|
|
begin
|
|
if subchild.nodeType = ELEMENT_NODE then
|
|
ConvertStatement(TDOMElement(subchild), indent + ' ');
|
|
subchild := subchild.NextSibling;
|
|
end;
|
|
end;
|
|
child := child.NextSibling;
|
|
end;
|
|
rslt.Add(indent+'except');
|
|
rslt.Add(indent+' on E: Exception do');
|
|
rslt.Add(indent+' success := (E is ' + ExceptClass +') and (' + ExceptClass + '(E).Code = ' + excode + ');');
|
|
rslt.Add(indent+'end;');
|
|
rslt.Add(indent+'AssertTrue('''+el['id']+''', success);');
|
|
end;
|
|
|
|
procedure ConvertBlock(el: TDOMNode; indent: string);
|
|
var
|
|
curr: TDOMNode;
|
|
element: TDOMElement;
|
|
List: TList;
|
|
cond: 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
|
|
ConvertException(element, 'EDOMError', indent)
|
|
else if n = 'assertXPathException' then
|
|
ConvertException(element, 'EXPathException', indent)
|
|
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(rslt.IndexOf('var')+1, ' ' + 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
|
|
if TDOMElement(subvars[0]).HasAttribute('type') then
|
|
hs := PascalType(TDOMElement(subvars[0]).GetAttribute('type'))
|
|
else
|
|
hs := 'DOMString';
|
|
TypedConsts.Add(' ' + Node['name'] + ': array[0..' + IntToStr(subvars.Count-1) + '] of ' + hs + ' = (');
|
|
for J := 0 to subvars.Count-1 do
|
|
begin
|
|
hs := ' ' + ReplaceQuotes(subvars[J].TextContent);
|
|
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;
|
|
IgnoreFlag := 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;
|
|
if IgnoreFlag then
|
|
begin
|
|
rslt.Clear;
|
|
Inc(IgnoreCount);
|
|
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;
|
|
|
|
function IsBlacklisted(const s: string; const list: array of string): Boolean;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := True;
|
|
for I := Low(list) to High(list) do
|
|
begin
|
|
if s = list[I] then
|
|
Exit;
|
|
end;
|
|
Result := False;
|
|
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+
|
|
'%0:s}'#10+
|
|
'unit %1: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%3:s;'#10 +
|
|
#10 +
|
|
'type'#10 +
|
|
' %2: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, casename, add_units: string;
|
|
comment: TDOMNode;
|
|
blacklist: array of string;
|
|
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);
|
|
|
|
// Prepare the array of blacklisted test names
|
|
testlist := api.GetElementsByTagName('blacklist');
|
|
try
|
|
SetLength(blacklist, testlist.length);
|
|
for I := 0 to testlist.length-1 do
|
|
blacklist[I] := testlist[I].TextContent;
|
|
finally
|
|
testlist.Free;
|
|
end;
|
|
|
|
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;
|
|
|
|
// Check if we need the additional units to use
|
|
add_units := '';
|
|
testlist := api.GetElementsByTagName('uses');
|
|
try
|
|
for I := 0 to testlist.Length-1 do
|
|
begin
|
|
root := TDOMElement(testlist[I]);
|
|
if Pos(root['pattern'], BaseURI) <> 0 then
|
|
add_units := add_units + ', ' + root['unit'];
|
|
end;
|
|
finally
|
|
testlist.Free;
|
|
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, add_units]);
|
|
// 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'];
|
|
ResolveRelativeURI(BaseURI, href, testuri);
|
|
|
|
Pars.ParseURI(testuri, testdoc);
|
|
try
|
|
sl.Clear;
|
|
root := testdoc.DocumentElement;
|
|
// fix clash with local vars having the same name
|
|
casename := root['name'];
|
|
if casename = 'attrname' then
|
|
casename := 'attr_name';
|
|
if IsBlacklisted(casename, blacklist) then
|
|
begin
|
|
writeln('Test case "', casename, '" is blacklisted, skipping');
|
|
Continue;
|
|
end;
|
|
sl.Add('procedure ' + class_name + '.' + casename + ';');
|
|
try
|
|
ConvertTest(root, sl);
|
|
except
|
|
Writeln('An exception occured while converting ', casename);
|
|
raise;
|
|
end;
|
|
if sl.Count > 0 then
|
|
begin
|
|
all.add(' procedure '+casename+';');
|
|
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 Object Pascal converter');
|
|
writeln('Copyright (c) 2008 by Sergei Gorelkin');
|
|
|
|
if ParamCount < 2 then
|
|
begin
|
|
writeln;
|
|
writeln('Usage: ', ExtractFileName(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 - IgnoreCount, ' 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;
|
|
if IgnoreCount > 0 then
|
|
begin
|
|
writeln(IgnoreCount, ' tests were skipped because they are not');
|
|
writeln(' applicable to our DOM implementation.');
|
|
end;
|
|
end.
|
|
|