From 6049600ccb79d2a7e95b69fabdbe6d8249b88a50 Mon Sep 17 00:00:00 2001
From: sergei <gorelkin@nanoreflex.ru>
Date: Sun, 17 May 2009 22:56:51 +0000
Subject: [PATCH] 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 -
---
 packages/fcl-xml/tests/api.xml    |  27 +++++---
 packages/fcl-xml/tests/testgen.pp | 110 +++++++++++++++++++++++-------
 2 files changed, 105 insertions(+), 32 deletions(-)

diff --git a/packages/fcl-xml/tests/api.xml b/packages/fcl-xml/tests/api.xml
index 63bd9a6275..60be75c0b9 100644
--- a/packages/fcl-xml/tests/api.xml
+++ b/packages/fcl-xml/tests/api.xml
@@ -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>
\ No newline at end of file
+</api>
+</test-data>
\ No newline at end of file
diff --git a/packages/fcl-xml/tests/testgen.pp b/packages/fcl-xml/tests/testgen.pp
index 4748729473..e1a3b7d911 100644
--- a/packages/fcl-xml/tests/testgen.pp
+++ b/packages/fcl-xml/tests/testgen.pp
@@ -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.