freepascal.compiler/packages/fcl-xml/tests/xmlts.pp

{
    This file is part of the Free Component Library (FCL)

    FCL test runner for OASIS/NIST XML test suite
    It is somewhat based on 'harness.js' script
    (see http://xmlconf.sourceforge.net)
    Copyright (c) 2006 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 xmlts;

{$IFDEF FPC}
{$MODE OBJFPC}{$H+}
{$ENDIF}
{$APPTYPE CONSOLE}

uses
  SysUtils,
  Classes,
  DOM,
  XMLRead,
  XMLWrite,
  UriParser;

const
  harness = 'Pascal version';
  version = '0.0.1 alpha :)';
  parser = 'FCL XML parser';
  parserName = parser;
  os = 'Unknown OS';
  runtime = 'FPC RTL';


type
  TDiagCategory = (dcInfo, dcNegfail, dcFail, dcPass);

  TTestSuite = class
  private
    FTemplate: TXMLDocument;
    FParser: TDOMParser;
    FPassed, FFailCount: Integer;
    FFalsePasses: Integer;
    FRootUri: string;
    FSuiteName: string;
    FDoc: TXMLDocument;
    FValidating: Boolean;
    FSuiteTitle: DOMString;
    FState: DOMString;
    FSkipped: Integer;
    FTotal: Integer;
    table_valid: TDOMNode;
    table_output: TDOMNode;
    table_invalid: TDOMNode;
    table_not_wf: TDOMNode;
    table_informative: TDOMNode;
    FValError: string;
    FTestID: DOMString;
    FErrLine, FErrCol: Integer;
    procedure LoadTemplate(const Name: string);
    procedure HandleTemplatePIs(Element: TDOMNode);
    procedure Diagnose(Element, Table: TDOMNode; Category: TDiagCategory; const Error: DOMString);
    procedure DiagnoseOut(const ErrorMsg: DOMString);
    function CompareNodes(actual, correct: TDOMNode; out Msg: string): Boolean;
    procedure ErrorHandler(Error: EXMLReadError);
  public
    constructor Create;
    procedure Run(const Tests: string);
    procedure RunTest(Element: TDOMElement);
    destructor Destroy; override;
  end;

function GetBaseURI(Element: TDOMNode; const DocumentURI: string): string;
var
  Ent: TDOMNode;
  Uri1, Uri2, s: WideString;
begin
  case Element.NodeType of
  ELEMENT_NODE, TEXT_NODE, CDATA_SECTION_NODE,
  PROCESSING_INSTRUCTION_NODE, COMMENT_NODE, DOCUMENT_TYPE_NODE:
    if Assigned(Element.ParentNode)
      then Result := GetBaseURI(Element.ParentNode, DocumentURI)
      else Result := '';

  ATTRIBUTE_NODE: begin
    Result := '';
    if Assigned(TDomAttr(Element).OwnerElement) then
    begin
      Result := GetBaseURI(TDomAttr(Element).OwnerElement, DocumentURI);
    end;
  end;

  ENTITY_REFERENCE_NODE: begin
    Ent := Element.OwnerDocument.DocType.Entities.GetNamedItem(Element.NodeName);
    if Assigned(Ent) and (TDOMEntity(Ent).SystemID <> '') then
    begin
      Uri1 := TDOMEntity(Ent).SystemID;
      if IsAbsoluteURI(Uri1) then
      begin
        Result := Uri1;
      end else begin
        Uri2 := GetBaseURI(Element.ParentNode, DocumentUri);
        ResolveRelativeUri(Uri2, Uri1, s);
        Result := s;
      end;
    end
    else
    begin
      if Assigned(Element.ParentNode)
        then Result := GetBaseURI(Element.ParentNode, DocumentURI)
        else Result := '';
    end;
  end;

  DOCUMENT_NODE: Result := DocumentURI;
  else
    Result := '';
  end;
end;

{ TTestSuite }

constructor TTestSuite.Create;
begin
  inherited Create;
  FParser := TDOMParser.Create;
  FParser.Options.PreserveWhitespace := True;
  FParser.Options.ExpandEntities := True;
  FParser.Options.IgnoreComments := True;
  FParser.Options.CDSectionsAsText := True;
end;

procedure TTestSuite.ErrorHandler(Error: EXMLReadError);
begin
  // allow fatal error position to override that of validation error
  if (FErrLine < 0) or (Error.Severity = esFatal) then
  begin
    FErrLine := Error.Line;
    FErrCol := Error.LinePos;
  end;  

  if Error.Severity = esError then
  begin
    if FValError = '' then // fetch the _first_ message
      FValError := Error.Message;
{ uncomment the line below to verify that the suite correctly handles
  exception raised from the handler }    
//  Abort;  
  end;
end;

procedure TTestSuite.LoadTemplate(const Name: string);
var
  tables: TDOMNodeList;
  I: Integer;
  id: DOMString;
  el: TDOMElement;
begin
  ReadXMLFile(FTemplate, Name);
  tables := FTemplate.DocumentElement.GetElementsByTagName('table');
  try
    for I := 0 to tables.Count-1 do
    begin
      el := TDOMElement(tables.Item[I]);
      id := el['id'];
      if id = 'valid' then
        table_valid := el
      else if ((id = 'invalid-negative') and FValidating) or ((id = 'invalid-positive') and not FValidating) then
        table_invalid := el
      else if id = 'valid-output' then
        table_output := el
      else if id = 'not-wf' then
        table_not_wf := el
      else if id = 'error' then
        table_informative := el;
    end;
  finally
    tables.Free;
  end;
end;

destructor TTestSuite.Destroy;
begin
  FDoc.Free;
  FTemplate.Free;
  FParser.Free;
  inherited;
end;

procedure TTestSuite.HandleTemplatePIs(Element: TDOMNode);
var
  Children: TDOMNodeList;
  Child: TDOMNode;
  NewChild: TDOMNode;
  Remove: Boolean;
  Index: Integer;
  Data: DOMString;
begin
  Children := element.childNodes;
  Remove := False;
  Index := 0;

  repeat
    Child := Children.Item[Index];
    if Child = nil then Break;
    Inc(index);

    // inside a rejected <?if ...?>...<?endif?>
    if Remove and (child.nodeType <> PROCESSING_INSTRUCTION_NODE) then
    begin
      Element.removeChild(child);
      Dec(Index);
      Continue;
    end;
    if Child.hasChildNodes then
    begin
      HandleTemplatePIs(Child);
      Continue;
    end;

    if Child.nodeType <> PROCESSING_INSTRUCTION_NODE then
      Continue;

    Data := Child.NodeValue;

    if Child.NodeName = 'run-id' then
    begin
      if Data = 'name' then
        newChild := FTemplate.createTextNode(parser)
      else if Data = 'description' then
        newChild := FTemplate.createTextNode (parserName)
      else if Data = 'general-entities' then
        newChild := FTemplate.createTextNode('included')
      else if Data = 'parameter-entities' then
        newChild := FTemplate.createTextNode ('included')
      else if Data = 'type' then
      begin
        if FValidating then
           Data := 'Validating'
        else
           Data := 'Non-Validating';
        newChild := FTemplate.createTextNode(Data);
      end
      // ... test run description
      else if Data = 'date' then
        newChild := FTemplate.createTextNode(DateTimeToStr(Now))
      else if Data = 'harness' then
        newChild := FTemplate.createTextNode(harness)
      else if Data = 'java' then
        newChild := FTemplate.createTextNode(runtime)
      else if Data = 'os' then
        newChild := FTemplate.createTextNode(os)
      else if Data = 'testsuite' then
        newChild := FTemplate.createTextNode(FSuiteTitle)
      else if Data = 'version' then
        newChild := FTemplate.createTextNode(version)
      // ... test result info
      else if Data = 'failed' then
        newChild := FTemplate.createTextNode(IntToStr(FFailCount))
      else if Data = 'passed' then
        newChild := FTemplate.createTextNode(IntToStr(FPassed))
      else if Data = 'passed-negative' then
        newChild := FTemplate.createTextNode(IntToStr(FFalsePasses))
      else if Data = 'skipped' then
        newChild := FTemplate.createTextNode(IntToStr(FSkipped))
      else if Data = 'status' then
        newChild := FTemplate.createTextNode (FState);

      Element.replaceChild (newChild, child);
      Continue;
    end

    // if/endif don't nest, and always have the same parent
    // we rely on those facts here!
    else if Child.NodeName = 'if' then
    begin
      Remove := not (((Data = 'validating') and FValidating) or
                   ((Data = 'nonvalidating') and not FValidating));
      element.removeChild(child);
      Dec(Index);
      Continue;
    end
    else if Child.NodeName = 'endif' then
    begin
      Remove := False;
      element.removeChild(child);
      Dec(Index);
      Continue;
    end;
  until False;
  Children.Free;
end;


procedure TTestSuite.Run(const Tests: string);
var
  Cases: TDOMNodeList;
  I: Integer;
begin
  FRootURI := FilenameToURI(Tests);
  ReadXMLFile(FDoc, Tests);
  FSuiteTitle := FDoc.DocumentElement['PROFILE'];
  Cases := FDoc.DocumentElement.GetElementsByTagName('TEST');
  writeln('Using test suite: ', Tests);
  writeln;
  writeln('Testing, validation = ', FValidating);
  try
    for I := 0 to Cases.Count-1 do
      RunTest(Cases.Item[I] as TDOMElement);
    I := Cases.Count;
  finally
    Cases.Free;
  end;

  FPassed := FTotal-FFailCount;
  Dec(FPassed, FSkipped);

  writeln('Found ', I, ' basic test cases.');
  writeln('Found ', FTotal, ' overall test cases.');
  writeln('Skipped: ', FSkipped);
  writeln('Passed: ', FPassed);
  writeln('Failed: ', FFailCount);
  writeln('Negative passes: ', FFalsePasses, ' (need examination).');
  writeln;

  if FPassed = 0 then
    FState := 'N/A'
  else if FPassed = FTotal then
    FState := 'CONFORMS (provisionally)'
  else
    FState := 'DOES NOT CONFORM';

end;

procedure TTestSuite.RunTest(Element: TDOMElement);
var
  s: UTF8string;
  TestType: DOMString;
  TempDoc, RefDoc: TXMLDocument;
  table: TDOMNode;
  Positive: Boolean;
  outURI: UTF8string;
  FailMsg: string;
  docNode, refNode: TDOMNode;
  docMap, refMap: TDOMNamedNodeMap;
  docN, refN: TDOMNotation;
  I: Integer;
  root: UTF8String;
begin
  FErrLine := -1;
  FErrCol := -1;
  FTestID := Element['ID'];
  TestType := Element['TYPE'];
  root := GetBaseURI(Element, FRootUri);
  ResolveRelativeURI(root, UTF8Encode(Element['URI']), s);

  table := nil;
  outURI := '';
  Positive := False;
  if TestType = 'not-wf' then
    table := table_not_wf
  else if TestType = 'error' then
    table := table_informative
  else if TestType = 'valid' then
  begin
    if Element.hasAttribute('OUTPUT') then
      ResolveRelativeURI(root, UTF8Encode(Element['OUTPUT']), outURI);
    table := table_valid;
    Positive := True;
  end
  else if TestType = 'invalid' then
  begin
    table := table_invalid;
    Positive := not FValidating;
  end;

  if TestType <> 'error' then
  begin
    Inc(FTotal);
    if outURI <> '' then Inc(FTotal);
  end;

  FailMsg := '';
  FValError := '';
  TempDoc := nil;
  try
    try
      FParser.Options.Validate := FValidating;
//      FParser.Options.Namespaces := (Element['NAMESPACE'] <> 'no');
      FParser.OnError := {$IFDEF FPC}@{$ENDIF}ErrorHandler;
      FParser.ParseUri(s, TempDoc);
    except
      on E: Exception do
        if E.ClassType <> EAbort then
        begin
          FailMsg := E.Message;
          FValError := '';
        end;
    end;

    if table = table_informative then
    begin
      if FailMsg <> '' then
        Diagnose(element, table, dcInfo, '(fatal) ' + FailMsg)
      else if FValError <> '' then
        Diagnose(element, table, dcInfo, '(error) ' + FValError)
      else
        Diagnose(Element, table, dcInfo, '');
      Exit;
    end;

    if not Positive then  // must have been failed
    begin
      if (FailMsg = '') and (FValError = '') then
      begin
        Inc(FFailCount);
        Diagnose(element, table, dcNegfail, '');
      end
      else // FailMsg <> '' or FValError <> '' -> actually failed
      begin
        if FailMsg <> '' then  // Fatal error
        begin
          { outside not-wf category it is a test failure }
          if table <> table_not_wf then
          begin
            Inc(FFailCount);
            Diagnose(Element, table, dcFail, FailMsg);
          end
          else
          begin
            Inc(FFalsePasses);
            Diagnose(Element, table, dcPass, FailMsg);
          end;
        end
        else
        begin
          { outside invalid category it is a test failure }
          if table = table_not_wf then
          begin
            Inc(FFailCount);
            Diagnose(Element, table, dcFail, FValError);
          end
          else
          begin
            Inc(FFalsePasses);
            Diagnose(Element, table, dcPass, FValError);
          end;
        end;
      end;
      Exit;
    end
    else   // must have been succeeded
      if (FailMsg <> '') or (FValError <> '') then
      begin
        Inc(FFailCount);
        if FailMsg <> '' then
          Diagnose(Element, table, dcFail, FailMsg)
        else
          Diagnose(Element, table, dcFail, FValError);
        if (outURI <> '') and (FailMsg <> '') then
        begin
          Inc(FFailCount);
          DiagnoseOut('[ input failed, no output to test ]');
        end;
        Exit;
      end;

    if outURI = '' then Exit;
    TempDoc.DocumentElement.Normalize;
    try
      // reference data must be parsed in non-validating mode because it contains DTDs
      // only when Notations need to be reported
      FParser.Options.Validate := False;
      FParser.ParseUri(outURI, RefDoc);
      try
        docNode := TempDoc.FirstChild;
        refNode := RefDoc.FirstChild;
        repeat
          if refNode = nil then
          begin
            if docNode <> nil then
            begin
              Inc(FFailCount);
              DiagnoseOut('Extra data: ' + docNode.NodeName + ' / ' + docNode.NodeValue);
            end;
            Exit;
          end;
          if docNode = nil then
          begin
            Inc(FFailCount);
            DiagnoseOut('Missing data: ' + refNode.NodeName + ' / ' + refNode.NodeValue);
            Exit;
          end;

          if refNode.NodeType = DOCUMENT_TYPE_NODE then
          begin
            if docNode.NodeType <> DOCUMENT_TYPE_NODE then
            begin
              Inc(FFailCount);
              DiagnoseOut('[ no doctype from parsing testcase ]');
              Exit;
            end;

            refMap := TDOMDocumentType(refNode).Notations;
            docMap := TDOMDocumentType(docNode).Notations;

            for I := 0 to refMap.Length-1 do
            begin
              refN := TDOMNotation(refMap[I]);
              docN := TDOMNotation(docMap.GetNamedItem(refMap[I].NodeName));
              if not Assigned(docN) then
              begin
                Inc(FFailCount);
                DiagnoseOut('missing notation declaration: ' + refN.NodeName);
                Exit;
              end;
              if (refN.PublicID <> docN.PublicID) or (refN.SystemID <> docN.SystemID) then
              begin
                Inc(FFailCount);
                DiagnoseOut('incorrect notation declaration: ' + refN.NodeName);
                Exit;
              end;
            end;

            refNode := refNode.NextSibling;
            docNode := docNode.NextSibling;
            Continue;
          end;

          if docNode.NodeType = DOCUMENT_TYPE_NODE then  // skip DocType
            docNode := docNode.NextSibling;

          if not CompareNodes(docNode, refNode, FailMsg) then
          begin
            Inc(FFailCount);
            DiagnoseOut(FailMsg);
            Exit;
          end;

          docNode := docNode.NextSibling;
          refNode := refNode.NextSibling;
        until False;
      finally
        RefDoc.Free;
      end;
    except
      on E: Exception do
      begin
        Inc(FFailCount);
        DiagnoseOut('[ can''t read reference data: '+E.Message+' ]');
      end;
    end;
  finally
    TempDoc.Free;
  end;
end;


procedure TTestSuite.Diagnose(Element, Table: TDOMNode; Category: TDiagCategory;
  const Error: DOMString);
var
  tr, td, txt, tmp: TDOMNode;
  s: DOMString;
begin
  tr := FTemplate.CreateElement('tr');
  if Assigned(Element) then              // column 1: section/chapter, if known
  begin
    s := TDOMElement(Element)['SECTIONS'];
    td := FTemplate.CreateElement('td');
    td.AppendChild(FTemplate.CreateTextNode(s));
    tr.AppendChild(td);
  end;

  td := FTemplate.CreateElement('td');   // column 2: test ID
  td.AppendChild(FTemplate.CreateTextNode(FTestID));
  tr.AppendChild(td);
  // third column is description
  if Assigned(Element) then
  begin
    td := FTemplate.CreateElement('td');
    txt := Element.FirstChild;
    while Assigned(txt) do
    begin
      td.AppendChild(txt.CloneNode(true, FTemplate));
      txt := txt.NextSibling;
    end;
    tr.AppendChild(td);
  end;
  // fourth column is reason
  td := FTemplate.CreateElement('td');
  if Element = nil then
    s := Error
  else if Category <> dcInfo then
  begin
    if Error <> '' then
    begin
      if FValError <> '' then
        s := '(error) ' + Error
      else
        s := '(fatal) ' + Error;
    end
    else
      s := '[wrongly accepted]';
  end
  else // informative
  begin
    if Error <> '' then
      s := Error
    else
      s := '[accepted]';
  end;
  // TODO: use &nbsp if text is empty
  txt := FTemplate.CreateTextNode(s);

  if (Category <> dcPass) and (Category <> dcInfo) then
  begin
    tmp := FTemplate.CreateElement('em');
    tmp.AppendChild(txt);
    txt := tmp;
    TDOMElement(td)['bgcolor'] := '#ffaacc';
  end;
  td.AppendChild(txt);
  tr.AppendChild(td);

  table.AppendChild(tr);
end;

procedure TTestSuite.DiagnoseOut(const ErrorMsg: DOMString);
var
  tr, td, txt: TDOMNode;
begin
  tr := FTemplate.CreateElement('tr');

  td := FTemplate.CreateElement('td');
  td.AppendChild(FTemplate.CreateTextNode(FTestID));
  tr.AppendChild(td);

  td := FTemplate.CreateElement('td');
  txt := FTemplate.CreateElement('em');
  txt.AppendChild(FTemplate.CreateTextNode(ErrorMsg));
  td.AppendChild(txt);
  TDOMElement(td)['bgcolor'] := '#ffaacc';
  tr.AppendChild(td);
  table_output.AppendChild(tr);
end;

procedure Canonicalize(node: TDOMNode);
var
  child, work: TDOMNode;
  Frag: TDOMDocumentFragment;
begin
  child := node.FirstChild;
  while Assigned(child) do
  begin
    if child.NodeType = CDATA_SECTION_NODE then
    begin
      work := node.OwnerDocument.CreateTextNode(child.NodeValue);
      node.ReplaceChild(work, child);
      child := work;
    end
    else if child.NodeType = COMMENT_NODE then
    begin
      work := child.NextSibling;
      node.RemoveChild(child);
      child := work;
      Continue;
    end
    else if child.NodeType = ENTITY_REFERENCE_NODE then
    begin
      Frag := node.OwnerDocument.CreateDocumentFragment;
      try
        work := child.FirstChild;
        while Assigned(work) do
        begin
          Frag.AppendChild(work.CloneNode(true));
          work := work.NextSibling;
        end;
        work := Frag.FirstChild;     // references may be nested
        if work = nil then
          work := Child.PreviousSibling;

        node.ReplaceChild(Frag, child);
        child := work;
      finally
        Frag.Free;
      end;
      Continue;
    end;
    if child.HasChildNodes then
      Canonicalize(child);
    child := child.NextSibling;
  end;
end;

function TTestSuite.CompareNodes(actual, correct: TDOMNode;
  out Msg: string): Boolean;
var
  actAtts, refAtts: TDOMNamedNodeMap;
  actList, refList: TDOMNodeList;
  I: Integer;
  s1, s2: DOMString;
begin
  Msg := '';
  Result := False;
  if actual.NodeType <> correct.NodeType then
    FmtStr(Msg, 'actual.NodeType (%d) != correct.NodeType (%d)', [actual.NodeType, correct.NodeType])
  else if actual.NodeName <> correct.NodeName then
    FmtStr(Msg, 'actual.NodeName (%s) != correct.NodeName (%s)', [actual.NodeName, correct.NodeName])
  else if actual.NodeValue <> correct.NodeValue then
    FmtStr(Msg, 'actual.NodeValue (%s) != correct.NodeValue (%s)', [actual.NodeValue, correct.NodeValue]);
  if Msg <> '' then
    Exit;

  if actual.NodeType = ELEMENT_NODE then
  begin
    // first, compare attributes
    actAtts := actual.Attributes;
    refAtts := correct.Attributes;
    if actAtts.Length <> refAtts.Length then
    begin
      FmtStr(Msg, 'Element ''%s'': attributes.length (%d) != %d', [actual.NodeName, actAtts.Length, refAtts.Length]);
      Exit;
    end;
    for I := 0 to actAtts.Length -1 do
    begin
      s1 := refAtts.GetNamedItem(actAtts[I].NodeName).NodeValue;
      s2 := actAtts[I].NodeValue;
      if s1 <> s2 then
      begin
        FmtStr(Msg, 'Element ''%s'', attribute ''%s'': actual.AttValue (%s) != correct.AttValue (%s)', [actual.NodeName, actAtts[I].NodeName, s2, s1]);
        Exit;
      end;
    end;
    // next, compare children
    actList := actual.ChildNodes;
    refList := correct.ChildNodes;
    try
      if actList.Count <> refList.Count then
      begin
        FmtStr(Msg, 'Element ''%s'': actual.ChildNodeCount (%d) != correct.ChildNodeCount (%d)', [actual.NodeName, actList.Count, refList.Count]);
        Exit;
      end;
      for I := 0 to actList.Count -1 do
        if not CompareNodes(actList[I], refList[I], Msg) then
          Exit;
    finally
      actList.Free;
      refList.Free;
    end;
  end;
  Result := True;
end;



var
  i: Integer;
  s: string;
  SuiteName, ReportName, TemplateName: string;
  Validation: Boolean;
begin
  writeln('FCL driver for OASIS/NIST XML Test Suite');
  writeln('Copyright (c) 2006 by Sergei Gorelkin');
  TemplateName := ExtractFilePath(ParamStr(0)) + 'template.xml';
  if ParamCount < 2 then
  begin
    writeln;
    writeln('Usage: ', ParamStr(0), ' <suite> <report> [-t template][-v]');
    writeln('  -t: specify report template');
    writeln('  -v: validating mode');
    Exit;
  end;

  SuiteName := ExpandFilename(ParamStr(1));
  ReportName := ExpandFilename(ParamStr(2));
  i := 3;
  Validation := False;
  while i <= ParamCount do
  begin
    s := Lowercase(ParamStr(i));
    if s = '-v' then
      Validation := True
    else if s = '-t' then
      TemplateName := ExpandFileName(ParamStr(i+1));
    Inc(i);
  end;

  with TTestSuite.Create do
  try
    FSuiteName := SuiteName;
    FValidating := Validation;
    LoadTemplate(TemplateName);
    if Assigned(FTemplate) then
    begin
      Run(FSuiteName);
      HandleTemplatePIs(FTemplate.DocumentElement);
      writeln('Writing report to: ', ReportName);
      WriteXMLFile(FTemplate, ReportName);
    end;
  finally
    Free;
  end;

end.