fpc/packages/fcl-xml/tests/testgen.pp

{**********************************************************************

    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, [email protected]

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