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

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

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

    fpcunit extensions required to run w3.org DOM test suites
    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.

 **********************************************************************}
unit domunit;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, xmlutils, DOM, XMLRead, contnrs, fpcunit;

type
{ these two types are separated for the purpose of readability }
  _collection = array of DOMString;   // unordered
  _list = _collection;                // ordered

  TDOMTestBase = class(TTestCase)
  private
    procedure setImplAttr(const name: string; value: Boolean);
    function getImplAttr(const name: string): Boolean;
  protected
    // override for this one is generated by testgen for each descendant
    function GetTestFilesURI: string; virtual;
  protected
    FParser: TDOMParser;
    FAutoFree: TObjectList;
    procedure SetUp; override;
    procedure TearDown; override;
    procedure GC(obj: TObject);
    procedure Load(out doc; const uri: string);
    procedure LoadStringData(out Doc; const data: string);
    function getResourceURI(const res: XMLString): XMLString;
    function ContentTypeIs(const t: string): Boolean;
    function GetImplementation: TDOMImplementation;
    procedure CheckFeature(const name: string);
    procedure assertNull(const id: string; const ws: DOMString); overload;
    procedure assertEquals(const id: string; exp, act: TObject); overload;
    procedure assertEqualsList(const id: string; const exp: array of DOMString; const act: _list);
    procedure assertEqualsCollection(const id: string; const exp: array of DOMString; const act: _collection);
    procedure assertEqualsW(const id: string; const exp, act: DOMString);
    procedure assertEqualsNoCase(const id: string; const exp, act: DOMString);
    procedure assertSame(const id: string; exp, act: TDOMNode);
    procedure assertSize(const id: string; size: Integer; obj: TDOMNodeList);
    procedure assertSize(const id: string; size: Integer; obj: TDOMNamedNodeMap);
    procedure assertInstanceOf(const id: string; obj: TObject; const typename: string);
    procedure assertURIEquals(const id: string;
      scheme, path, host, file_, name, query, fragment: PChar;
      IsAbsolute: Boolean; const Actual: DOMString);
    function bad_condition(const TagName: XMLString): Boolean;
    property implementationAttribute[const name: string]: Boolean read getImplAttr write setImplAttr;
  end;

procedure _append(var coll: _collection; const Value: DOMString);
procedure _assign(out rslt: _collection; const value: array of DOMString);
function IsSame(exp, act: TDOMNode): Boolean;

implementation

uses
  URIParser;

procedure _append(var coll: _collection; const Value: DOMString);
var
  L: Integer;
begin
  L := Length(coll);
  SetLength(coll, L+1);
  coll[L] := Value;
end;

procedure _assign(out rslt: _collection; const value: array of DOMString);
var
  I: Integer;
begin
  SetLength(rslt, Length(value));
  for I := 0 to High(value) do
    rslt[I] := value[I];
end;

function IsSame(exp, act: TDOMNode): Boolean;
begin
  Result := exp = act;
end;

procedure TDOMTestBase.SetUp;
begin
  FParser := TDOMParser.Create;
  FParser.Options.PreserveWhitespace := True;
  //FParser.Options.ExpandEntities := True;
  FAutoFree := TObjectList.Create(True);
end;

procedure TDOMTestBase.TearDown;
begin
  FreeAndNil(FAutoFree);
  FreeAndNil(FParser);
end;

procedure TDOMTestBase.GC(obj: TObject);
begin
  FAutoFree.Add(obj);
end;

procedure TDOMTestBase.assertSame(const id: string; exp, act: TDOMNode);
begin
  if exp <> act then
  begin
    assertNotNull(id, exp);
    assertNotNull(id, act);
    assertEquals(id, exp.nodeType, act.nodeType);
    assertEqualsW(id, exp.nodeValue, act.nodeValue);
  end;
end;

procedure TDOMTestBase.assertNull(const id: string; const ws: DOMString);
begin
  if ws <> '' then
    Fail(id);
end;

procedure TDOMTestBase.assertEquals(const id: string; exp, act: TObject);
begin
  inherited assertSame(id, exp, act);
end;

procedure TDOMTestBase.assertEqualsList(const id: string;
  const exp: array of DOMString; const act: _list);
var
  I: Integer;
begin
  AssertEquals(id+'(length)', Length(exp), Length(act));
  // compare ordered
  for I := 0 to High(exp) do
    AssertEqualsW(id+'['+IntToStr(I)+']', exp[I], act[I]);
end;

procedure TDOMTestBase.assertEqualsCollection(const id: string; const exp: array of DOMString; const act: _collection);
var
  I, J, matches: Integer;
begin
  AssertEquals(id, Length(exp), Length(act));
  // compare unordered
  for I := 0 to High(exp) do
  begin
    matches := 0;
    for J := 0 to High(act) do
      if act[J] = exp[I] then
        Inc(matches);
    AssertTrue(id+': no match found for <'+exp[I]+'>', matches <> 0);
    AssertTrue(id+': multiple matches for <'+exp[I]+'>', matches = 1);
  end;
end;

procedure TDOMTestBase.assertEqualsW(const id: string; const exp, act: DOMString);
begin
  AssertTrue(id + ComparisonMsg(exp, act), exp = act);
end;

procedure TDOMTestBase.assertEqualsNoCase(const id: string; const exp, act: DOMString);
begin
// TODO: could write custom comparison because range is limited to ASCII
  AssertTrue(id + ComparisonMsg(exp, act), WideSameText(exp, act));
end;

procedure TDOMTestBase.assertSize(const id: string; size: Integer; obj: TDOMNodeList);
begin
  AssertNotNull(id, obj);
  AssertEquals(id, size, obj.Length);
end;

procedure TDOMTestBase.assertSize(const id: string; size: Integer; obj: TDOMNamedNodeMap);
begin
  AssertNotNull(id, obj);
  AssertEquals(id, size, obj.Length);
end;

function TDOMTestBase.getResourceURI(const res: XMLString): XMLString;
var
  Base, Base2: XMLString;

function CheckFile(const uri: XMLString; out name: XMLString): Boolean;
var
  filename: string;
begin
  Result := ResolveRelativeURI(uri + 'files/', res + '.xml', name) and
    URIToFilename(name, filename) and
    FileExists(filename);
end;

begin
  Base := GetTestFilesURI;
  if Pos(XMLString('level2/html'), Base) <> 0 then
  begin
    // This is needed to run HTML testsuite off the CVS snapshot.
    // Web version simply uses all level1 files copied to level2.
    if ResolveRelativeURI(Base, '../../level1/html/', Base2) and
      CheckFile(Base2, Result) then
        Exit;
  end;
  CheckFile(Base, Result);
end;

function TDOMTestBase.getImplAttr(const name: string): Boolean;
begin
  if name = 'expandEntityReferences' then
    result := FParser.Options.ExpandEntities
  else if name = 'validating' then
    result := FParser.Options.Validate
  else if name = 'namespaceAware' then
    result := FParser.Options.Namespaces
  else if name = 'ignoringElementContentWhitespace' then
    result := not FParser.Options.PreserveWhitespace
  else
  begin
    Fail('Unknown implementation attribute: ''' + name + '''');
    result := False;
  end;
end;

procedure TDOMTestBase.setImplAttr(const name: string; value: Boolean);
begin
  if name = 'validating' then
    FParser.Options.Validate := value
  else if name = 'expandEntityReferences' then
    FParser.Options.ExpandEntities := value
  else if name = 'coalescing' then
  // TODO: action unknown yet
  else if (name = 'signed') and value then
    Ignore('Setting implementation attribute ''signed'' to ''true'' is not supported')
  else if name = 'hasNullString' then
  // TODO: probably we cannot support this
  else if name = 'namespaceAware' then
    FParser.Options.Namespaces := value
  else if name = 'ignoringElementContentWhitespace' then
    FParser.Options.PreserveWhitespace := not value
  else
    Fail('Unknown implementation attribute: ''' + name + '''');
end;

procedure TDOMTestBase.Load(out doc; const uri: string);
var
  t: TXMLDocument;
begin
  TObject(doc) := nil;
  FParser.ParseURI(getResourceURI(uri), t);
  TObject(doc) := t;
  GC(t);
end;

procedure TDOMTestBase.assertInstanceOf(const id: string; obj: TObject; const typename: string);
begin
  AssertTrue(id, obj.ClassNameIs(typename));
end;

{ expected args already UTF-8 encoded }
procedure TDOMTestBase.assertURIEquals(const id: string; scheme, path,
  host, file_, name, query, fragment: PChar; IsAbsolute: Boolean;
  const Actual: DOMString);
var
  URI: TURI;
begin
  AssertTrue(id+'#0', Actual <> '');
  URI := ParseURI(utf8Encode(Actual));
  if fragment <> nil then
    AssertEquals(id+'#1', string(fragment), URI.Bookmark);
  if query <> nil then
    AssertEquals(id+'#2', string(query), URI.Params);
  if scheme <> nil then
    AssertEquals(id+'#3', string(scheme), URI.Protocol);
  if host <> nil then
  begin
    AssertTrue(id+'#4', URI.HasAuthority);
    AssertEquals(id+'#5', string(host), URI.Host);
  end;
  if path <> nil then
    AssertEquals(id+'#6', string(path), '//' + Uri.Host + URI.Path + URI.Document);
  if file_ <> nil then
    AssertEquals(id+'#7', string(file_), URI.Document);
  if name <> nil then
    AssertEquals(id+'#8', string(name), ChangeFileExt(URI.Document, ''));
end;

function TDOMTestBase.bad_condition(const TagName: XMLString): Boolean;
begin
  Fail('Unsupported condition: '+ AnsiString(TagName));
  Result := False;
end;

function TDOMTestBase.ContentTypeIs(const t: string): Boolean;
begin
{ For now, claim only xml as handled content.
  This may be extended with html and svg.
}
  result := (t = 'text/xml');
end;

function TDOMTestBase.GetImplementation: TDOMImplementation;
begin
  result := nil;
end;

procedure TDOMTestBase.CheckFeature(const name: string);
begin
  // purpose/action is currently unknown
end;

function TDOMTestBase.GetTestFilesURI: string;
begin
  result := '';
end;

procedure TDOMTestBase.LoadStringData(out Doc; const data: string);
var
  src: TXMLInputSource;
begin
  src := TXMLInputSource.Create(data);
  try
    FParser.Parse(src, TXMLDocument(Doc));
    GC(TObject(Doc));
  finally
    src.Free;
  end;
end;

end.