mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-19 07:19:26 +02:00
DOM test suite enhancements:
* Do not convert tests which request implementation attribute 'signed'='true'. Such tests aren't applicable to our unsigned DOM, they only cause compiler warnings and noise in the test report. + Support for default properties (obj.item(x) -> obj[x]). + Support black-listing of testcases. Some of them (in HTML testsuite) are easier to rewrite by hand than to convert. + Support adding certain units to 'uses' clause (e.g. HTML suite must use dom_html). git-svn-id: trunk@13172 -
This commit is contained in:
sergei
parent
501f20c546
commit
6049600ccb
@ -5,20 +5,32 @@
|
||||
This is used by testgen program to convert w3.org XML test descriptions into
|
||||
fpcUnit-compatible Pascal code.
|
||||
-->
|
||||
<!DOCTYPE api [
|
||||
<!DOCTYPE test-data [
|
||||
<!ELEMENT test-data (blacklist*, uses*, api)>
|
||||
<!ELEMENT api (item)+ >
|
||||
<!ELEMENT item (arg*)>
|
||||
<!ELEMENT arg (#PCDATA)>
|
||||
<!ELEMENT blacklist (#PCDATA)>
|
||||
<!ELEMENT uses EMPTY>
|
||||
<!ATTLIST item
|
||||
id ID #REQUIRED
|
||||
type (func|prop|method) "func"
|
||||
type (func|prop|method|defprop) "func"
|
||||
result CDATA #IMPLIED
|
||||
objtype CDATA #IMPLIED
|
||||
rename CDATA #IMPLIED
|
||||
gc (yes|no) #IMPLIED>
|
||||
<!ATTLIST arg
|
||||
type CDATA #IMPLIED>
|
||||
]>
|
||||
<!ATTLIST uses
|
||||
pattern CDATA #REQUIRED
|
||||
unit CDATA #REQUIRED>
|
||||
]>
|
||||
<test-data>
|
||||
<blacklist>HTMLCollection04</blacklist>
|
||||
<blacklist>HTMLTableElement21</blacklist>
|
||||
<blacklist>HTMLTableElement24</blacklist>
|
||||
<uses pattern="/html" unit="dom_html"/>
|
||||
<uses pattern="/xpath" unit="xpath"/>
|
||||
<api>
|
||||
<item id="createDocumentFragment"/>
|
||||
<item id="createTextNode">
|
||||
@ -77,11 +89,9 @@
|
||||
<item id="publicId" type="prop"/> <!-- settable for DOM lvl 3 LSInput -->
|
||||
<item id="systemId" type="prop"/>
|
||||
<item id="notationName"/>
|
||||
<!-- Handled separately because our DOM has it as a default property, not a function
|
||||
<item id="item" result="Node">
|
||||
<item id="item" result="Node" type="defprop">
|
||||
<arg>index</arg>
|
||||
</item>
|
||||
-->
|
||||
<item id="getNamedItem" result="Node">
|
||||
<arg>name</arg>
|
||||
</item>
|
||||
@ -146,7 +156,7 @@
|
||||
<item id="getElementsByTagName" gc="yes">
|
||||
<arg>tagname</arg>
|
||||
</item>
|
||||
<item id="childNodes" gc="yes"/>
|
||||
<item id="childNodes"/>
|
||||
|
||||
<item id="value" type="prop"/>
|
||||
<item id="nodeValue" type="prop"/>
|
||||
@ -692,4 +702,5 @@
|
||||
<item id="HTMLTitleElement.text" type="prop"/>
|
||||
|
||||
|
||||
</api>
|
||||
</api>
|
||||
</test-data>
|
||||
@ -26,6 +26,7 @@ var
|
||||
forced: Boolean = False;
|
||||
TestCount: Integer = 0;
|
||||
FailCount: Integer = 0;
|
||||
IgnoreCount: Integer = 0;
|
||||
|
||||
function PascalType(const s: WideString): string;
|
||||
begin
|
||||
@ -196,7 +197,7 @@ var
|
||||
child, subchild: TDOMNode;
|
||||
n: DOMString;
|
||||
SuccessVarFlag: Boolean;
|
||||
FailFlag: Boolean;
|
||||
FailFlag, IgnoreFlag: Boolean;
|
||||
Inits, VarTypes: TStringList;
|
||||
|
||||
function TypeOfVar(const varname: string): string;
|
||||
@ -266,15 +267,20 @@ begin
|
||||
Result := getobj(e) + '.' + fixname(e) + ' := ' + ReplaceQuotes(e['value']) + ';';
|
||||
end;
|
||||
|
||||
function func_call(e: TDOMElement; args: TDOMNodeList; const rsltType: string=''): string;
|
||||
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'];
|
||||
Result := Result + ' := ' + getobj(e) + '.' + fixname(e);
|
||||
if args.Length > 0 then
|
||||
Result := Result + '(' + argstring(e, args) + ')';
|
||||
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;
|
||||
|
||||
@ -358,7 +364,7 @@ begin
|
||||
cond := PascalType(apinode['result'])
|
||||
else
|
||||
cond := '';
|
||||
rslt.Add(indent + func_call(node, arglist, cond));
|
||||
rslt.Add(indent + func_call(node, arglist, cond, apinode['type']='defprop'));
|
||||
if apinode['gc'] = 'yes' then
|
||||
rslt.Add(indent + 'GC(' + node['var'] + ');');
|
||||
end;
|
||||
@ -366,11 +372,7 @@ begin
|
||||
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
|
||||
if s = 'length' then
|
||||
begin
|
||||
if node['interface'] = 'DOMString' then
|
||||
rslt.Add(indent + node['var'] + ' := system.length(' + node['obj'] + ');')
|
||||
@ -471,7 +473,11 @@ begin
|
||||
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
|
||||
@ -746,6 +752,7 @@ end;
|
||||
begin
|
||||
SuccessVarFlag := False;
|
||||
FailFlag := False;
|
||||
IgnoreFlag := False;
|
||||
VarTypes := TStringList.Create;
|
||||
Inits := TStringList.Create;
|
||||
ConvertVars;
|
||||
@ -763,6 +770,11 @@ begin
|
||||
rslt.Clear;
|
||||
Inc(FailCount);
|
||||
end;
|
||||
if IgnoreFlag then
|
||||
begin
|
||||
rslt.Clear;
|
||||
Inc(IgnoreCount);
|
||||
end;
|
||||
end;
|
||||
|
||||
// Intercepting validation errors while loading API
|
||||
@ -777,6 +789,19 @@ 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 =
|
||||
|
||||
@ -784,18 +809,18 @@ const
|
||||
' 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 +
|
||||
'%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;'#10 +
|
||||
' SysUtils, Classes, DOM, xmlread, fpcunit, contnrs, domunit, testregistry%3:s;'#10 +
|
||||
#10 +
|
||||
'type'#10 +
|
||||
' %s = class(TDOMTestBase)'#10 +
|
||||
' %2:s = class(TDOMTestBase)'#10 +
|
||||
' protected'#10 +
|
||||
' function GetTestFilesURI: string; override;'#10 +
|
||||
' published'#10;
|
||||
@ -810,8 +835,9 @@ var
|
||||
sl, all, impl: TStringList;
|
||||
Pars: TDOMParser;
|
||||
eh: TErrHandler;
|
||||
class_name, unit_name, notice: string;
|
||||
class_name, unit_name, notice, casename, add_units: string;
|
||||
comment: TDOMNode;
|
||||
blacklist: array of string;
|
||||
begin
|
||||
Pars := TDOMParser.Create;
|
||||
eh := TErrHandler.Create;
|
||||
@ -820,6 +846,16 @@ begin
|
||||
// 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;
|
||||
@ -841,10 +877,24 @@ begin
|
||||
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]);
|
||||
all.Text := Format(UnitHeader, [notice, unit_name, class_name, add_units]);
|
||||
// emit the 'GetPathToModuleFiles' function body
|
||||
impl.Add('implementation');
|
||||
impl.Add('');
|
||||
@ -862,23 +912,30 @@ begin
|
||||
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
|
||||
if root['name'] = 'attrname' then
|
||||
root['name'] := 'attr_name';
|
||||
sl.Add('procedure ' + class_name + '.' + root['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 '+root['name']);
|
||||
Writeln('An exception occured while converting ', casename);
|
||||
raise;
|
||||
end;
|
||||
if sl.Count > 0 then
|
||||
begin
|
||||
all.add(' procedure '+root['name']+';');
|
||||
all.add(' procedure '+casename+';');
|
||||
impl.AddStrings(sl)
|
||||
end;
|
||||
finally
|
||||
@ -912,7 +969,7 @@ var
|
||||
I: Integer;
|
||||
|
||||
begin
|
||||
writeln('testgen - w3.org DOM test suite to Pascal converter');
|
||||
writeln('testgen - w3.org DOM test suite to Object Pascal converter');
|
||||
writeln('Copyright (c) 2008 by Sergei Gorelkin');
|
||||
|
||||
if ParamCount < 2 then
|
||||
@ -941,7 +998,7 @@ begin
|
||||
|
||||
ConvertSuite(FilenameToURI(SuiteName), OutputUnit);
|
||||
|
||||
writeln(testcount - FailCount, ' tests converted successfully');
|
||||
writeln(testcount - FailCount - IgnoreCount, ' tests converted successfully');
|
||||
if FailCount > 0 then
|
||||
begin
|
||||
writeln(FailCount, ' tests contain tags that are not supported yet');
|
||||
@ -953,5 +1010,10 @@ begin
|
||||
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.
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user