Email服务器

开发平台：
Delphi

TestFramework.pas：源码内容
							{#(@)$Id: TestFramework.pas,v 1.117 2006/07/19 02:45:55 judc Exp $ }
{  DUnit: An XTreme testing framework for Delphi programs. }
(*
 * The contents of this file are subject to the Mozilla Public
 * License Version 1.1 (the "License"); you may not use this file
 * except in compliance with the License. You may obtain a copy of
 * the License at http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS
 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 * implied. See the License for the specific language governing
 * rights and limitations under the License.
 *
 * The Original Code is DUnit.
 *
 * The Initial Developers of the Original Code are Kent Beck, Erich Gamma,
 * and Juancarlo A馿z.
 * Portions created The Initial Developers are Copyright (C) 1999-2000.
 * Portions created by The DUnit Group are Copyright (C) 2000-2004.
 * All rights reserved.
 *
 * Contributor(s):
 * Kent Beck <kentbeck@csi.com>
 * Erich Gamma <Erich_Gamma@oti.com>
 * Juanco A馿z <juanco@users.sourceforge.net>
 * Chris Morris <chrismo@users.sourceforge.net>
 * Jeff Moore <JeffMoore@users.sourceforge.net>
 * Uberto Barbini <uberto@usa.net>
 * Brett Shearer <BrettShearer@users.sourceforge.net>
 * Kris Golko <neuromancer@users.sourceforge.net>
 * The DUnit group at SourceForge <http://dunit.sourceforge.net>
 *
 *)
{$IFDEF CLR}
  {$UNSAFECODE ON}
{$ENDIF}
{$BOOLEVAL OFF}
unit TestFramework;
interface
uses
{$IFDEF CLR}
  System.Reflection,
{$ENDIF}
  SysUtils,
  Classes,
  IniFiles;
const
  rcs_id: string = '#(@)$Id: TestFramework.pas,v 1.117 2006/07/19 02:45:55 judc Exp $';
  rcs_version : string = '$Revision: 1.117 $';
type
{$IFDEF CLR}
//  Pointer = Borland.Delphi.System.Pointer;
  IUnknown = interface(IInterface)
  end;
  TestAttribute = class(TCustomAttribute)
  end;
{$ENDIF}
{$IFDEF CLR}
  TTestMethod  = string;
{$ELSE}
  TTestMethod  = procedure of object;
{$ENDIF}
  TTestProc    = procedure;
  TTestCaseClass  = class of TTestCase;
  ITestListener   = interface;
  IStatusListener = interface;
  TTestResult   = class;
  TAbstractTest = class;
  TTestCase     = class;
  TTestSuite    = class;
  TTestFailure  = class;
  ExceptionClass = class of Exception;
  ETestFailure = class(EAbort)
     constructor Create;               overload;
     constructor Create(msg :string);  overload;
  end;
  EDunitException = class(Exception);
  ETestError = class(EDunitException);
  EStopTestsFailure = class(ETestFailure);
  EPostTestFailure = class(ETestFailure);
  TAllowedLeakArray = array[0..3] of integer;
  TListIterator = function: integer of object;
  IMemLeakMonitor = interface(IUnknown)
  ['{041368CC-5B04-4111-9E2E-05A5908B3A58}']
    function MemLeakDetected(out LeakSize: Integer): Boolean;
  end;
  IDUnitMemLeakMonitor = interface(IMemLeakMonitor)
  ['{45466FCA-1ADC-4457-A41C-88FA3F8D23F7}']
    function MemLeakDetected(const AllowedLeakSize: Integer;
                             const FailOnMemoryRecovery: Boolean;
                             out   LeakSize: Integer): Boolean; overload;
    function MemLeakDetected(const AllowedValuesGetter: TListIterator;
                             const FailOnMemoryRecovery: Boolean;
                             out   LeakIndex: integer;
                             out   LeakSize: Integer): Boolean; overload;
    function GetMemoryUseMsg(const FailOnMemoryRecovery: Boolean;
                             const TestProcChangedMem: Integer;
                             out   ErrorMsg: string): Boolean; overload;
    function GetMemoryUseMsg(const FailOnMemoryRecovery: boolean;
                             const TestSetupChangedMem: Integer;
                             const TestProcChangedMem: Integer;
                             const TestTearDownChangedMem: Integer;
                             const TestCaseChangedMem: Integer;
                             out   ErrorMsg: string): boolean; overload;
    procedure MarkMemInUse;
  end;
  { thrown to force a debugger break on a test failure }
  EBreakingTestFailure = class(EDunitException)
     constructor Create;               overload;
     constructor Create(msg :string);  overload;
  end;
  ITest = interface(IUnknown)
    ['{89CCD557-7DE1-4814-B033-ABAFE0870EC7}']
    function GetName: string;
    function  CountTestCases: integer;
    function  CountEnabledTestCases: integer;
    function  Tests: IInterfaceList;
    procedure SetUp;
    procedure TearDown;
    function  Run : TTestResult;  overload;
    procedure Run(testResult: TTestResult); overload;
    procedure RunWithFixture(testResult: TTestResult);
    procedure RunTest(testResult: TTestResult);
    function  GetTestMethodInvoked: Boolean;
    procedure SetTestMethodInvoked(const Value: Boolean);
    property  TestMethodInvoked: Boolean read  GetTestMethodInvoked
                                         write SetTestMethodInvoked;
    function  GetEnabled: Boolean;
    procedure SetEnabled(Value: Boolean);
    procedure SetStartTime(Value :Int64);
    function  GetStartTime : Int64;
    procedure SetStopTime(Value :Int64);
    function  GetStopTime : Int64;
    function  ElapsedTestTime: Cardinal;
    procedure SetStatusListener(Listener :IStatusListener);
    function  GetStatus :string;
    procedure LoadConfiguration(const iniFile :TCustomIniFile; const section :string);  overload;
    procedure LoadConfiguration(const fileName: string; const useRegistry, useMemIni: Boolean); overload;
    procedure SaveConfiguration(const iniFile :TCustomIniFile; const section :string);  overload;
    procedure SaveConfiguration(const fileName: string; const useRegistry, useMemIni: Boolean); overload;
    procedure SetGUIObject(const guiObject: TObject);
    function  GetGUIObject: TObject;
    property Name:    string  read GetName;
    property Enabled: Boolean read GetEnabled write SetEnabled;
    property GUIObject: TObject read GetGUIObject write SetGUIObject;
    property Status:  string  read GetStatus;
    property StartTime: Int64 read GetStartTime write SetStartTime;
    property StopTime:  Int64 read GetStopTime  write SetStopTime;
    procedure SetFailsOnNoChecksExecuted(const Value: Boolean);
    function  GetFailsOnNoChecksExecuted: Boolean;
    property  FailsOnNoChecksExecuted: Boolean
                read GetFailsOnNoChecksExecuted
                write SetFailsOnNoChecksExecuted;
    function  GetFailsOnMemoryLeak: Boolean;
    procedure SetFailsOnMemoryLeak(const Value: Boolean);
    property  FailsOnMemoryLeak: Boolean
                read GetFailsOnMemoryLeak
                write SetFailsOnMemoryLeak;
    function  GetAllowedMemoryLeakSize: Integer;
    procedure SetAllowedMemoryLeakSize(const NewSize: Integer);
    property  AllowedMemoryLeakSize: Integer read GetAllowedMemoryLeakSize
                                           write SetAllowedMemoryLeakSize;
    function  GetFailsOnMemoryRecovery: Boolean;
    procedure SetFailsOnMemoryRecovery(const Value: Boolean);
    property  FailsOnMemoryRecovery: Boolean
                read GetFailsOnMemoryRecovery
                write SetFailsOnMemoryRecovery;
    procedure SetAllowedLeakArray(AllowedList: array of Integer);
    function  GetIgnoreSetUpTearDownLeaks: Boolean;
    procedure SetIgnoreSetUpTearDownLeaks(const Value: Boolean);
    property  IgnoreSetUpTearDownLeaks: Boolean
                read GetIgnoreSetUpTearDownLeaks
                write SetIgnoreSetUpTearDownLeaks;
    function  GetAllowedLeak: Integer;
    function  GetAllowedLeaksIterator: TListIterator;
    property  AllowedLeaksIterator: TListIterator read GetAllowedLeaksIterator;
  end;
  {: General interface for test decorators}
  ITestDecorator = interface(ITest)
    ['{8B3FC229-3033-4590-AD5C-01914C6E2C9F}']
    {: Get the decorated test
    @return The decorated test }
    function GetTest: ITest;
    property Test: ITest read GetTest;
  end;
  { IStatusListeners are notified of test status messages }
  IStatusListener = interface
  ['{8681DC88-033C-4A42-84F4-4C52EF9ABAC0}']
    procedure Status(test :ITest; const Msg :string);
  end;
  { ITestListeners get notified of testing events.
    See TTestResult.AddListener()
  }
  ITestListener = interface(IStatusListener)
    ['{114185BC-B36B-4C68-BDAB-273DBD450F72}']
    procedure TestingStarts;
    procedure StartTest(test: ITest);
    procedure AddSuccess(test: ITest);
    procedure AddError(error: TTestFailure);
    procedure AddFailure(Failure: TTestFailure);
    procedure EndTest(test: ITest);
    procedure TestingEnds(testResult :TTestResult);
    function  ShouldRunTest(test :ITest):Boolean;
  end;
  ITestListenerX = interface(ITestListener)
    ['{5C28B1BE-38B5-4D6F-AA96-A04E9302C317}']
    procedure StartSuite(suite: ITest);
    procedure EndSuite(suite: ITest);
  end;
  // a named collection of tests
  ITestSuite = interface(ITest)
    ['{C20E38EF-7369-44D9-9D84-08E84EC1DCF0}']
    procedure AddTest(test: ITest);
    procedure AddSuite(suite : ITestSuite);
  end;
  {  Adapter to allow a TTestResult to receive status messages
     from the running test }
  TStatusToResultAdapter = class(TInterfacedObject, IStatusListener)
  protected
    FTestResult :TTestResult;
  public
    constructor Create(TestResult :TTestResult);
    procedure   Status(Test :ITest; const Msg :string);
  end;
  { A TTestResult collects the results of executing a test case.
  And notifies registered ITestListener of testing events. }
  TTestResult = class(TObject)
  private
    FTotalTime: Int64;
  protected
    FFailures: TList;
    FErrors: TList;
    FOverRides: Integer;
    FListeners: IInterfaceList;
    FRootTest: ITest;
    FRunTests: integer;
    FStop: Boolean;
    FBreakOnFailures :Boolean;
    FFailsIfNoChecksExecuted: Boolean;
    FIgnoresMemoryLeakInSetUpTearDown: Boolean;
    FMemoryLeakIgnoredInSetupOrTearDown: boolean;
    FFailsIfMemoryLeaked: Boolean;
    FMethodPtr: Pointer;
    FStatusAdapter :IStatusListener;
    procedure Run(test: ITest); virtual;
    function  RunTestSetup(test: ITest):Boolean; virtual;
    procedure RunTestTearDown(test: ITest); virtual;
    function  RunTestRun(test: ITest) : Boolean; virtual;
    procedure TestingStarts;                           virtual;
    procedure StartSuite(suite: ITest);                virtual;
    procedure StartTest(test: ITest);                  virtual;
    function  ShouldRunTest(test :ITest) :Boolean;     virtual;
    procedure Status(test :ITest; const Msg :string);  virtual;
    procedure EndSuite(suite: ITest);                  virtual;
    procedure EndTest(test: ITest);                    virtual;
    procedure TestingEnds;                             virtual;
  public
    constructor Create;
    destructor  Destroy; override;
    procedure AddListener(listener: ITestListener); virtual;
    procedure RunSuite(test: ITest);  overload;
    procedure AddSuccess(test: ITest); virtual;
    function  AddFailure(test: ITest; e: Exception; Addrs :Pointer): TTestFailure; overload;
    function  AddFailure(test: ITest; Addrs :Pointer; msg :string = ''): TTestFailure; overload;
    function  AddError(test: ITest; e: Exception; Addrs :Pointer; msg :string = ''): TTestFailure; virtual;
    procedure Stop; virtual;
    function  ShouldStop: Boolean; virtual;
    function RunCount: integer;     virtual;
    function ErrorCount: integer;   virtual;
    function FailureCount: integer; virtual;
    function  GetError(idx :Integer) :TTestFailure;
    function  GetFailure(idx :Integer) :TTestFailure;
    function  WasStopped :Boolean; virtual;
    function  WasSuccessful: Boolean; virtual;
    property  BreakOnFailures :Boolean read  FBreakOnFailures write FBreakOnFailures;
    property  FailsIfNoChecksExecuted :Boolean read  fFailsIfNoChecksExecuted
                                               write fFailsIfNoChecksExecuted;
    property  FailsIfMemoryLeaked :Boolean read  fFailsIfMemoryLeaked
                                           write fFailsIfMemoryLeaked;
    property  IgnoresMemoryLeakInSetUpTearDown: Boolean
                read FIgnoresMemoryLeakInSetUpTearDown
                write FIgnoresMemoryLeakInSetUpTearDown;
    property  MemoryLeakIgnoredInSetupOrTearDown: Boolean
                read FMemoryLeakIgnoredInSetupOrTearDown
                write FMemoryLeakIgnoredInSetupOrTearDown;
    property  TotalTime: Int64 read FTotalTime;
    property Errors[i :Integer] :TTestFailure read GetError;
    property Failures[i :Integer] :TTestFailure read GetFailure;
    property OverRides: integer read FOverRides write FOverRides;
  end;
  TAbstractTest = class(TInterfacedObject, ITest)
  protected
    FTestName: string;
    FEnabled: Boolean;
    FStartTime: Int64;
    FStopTime:  Int64;
    FStatusListener :IStatusListener;
    FStatusStrings  :TStrings;
    FExpectedException: ExceptionClass;
    FCheckCalled: Boolean;
    FFailsOnNoChecksExecuted: Boolean;
    FFailsOnMemoryLeak: Boolean;
    FTestMethodInvoked: Boolean;
    FFailsOnMemoryRecovery: Boolean;
    FIgnoreSetUpTearDownLeaks: Boolean;
    FMemoryLeakIgnoredInSetupTearDown: boolean;
    FAllowedLeakList: TAllowedLeakArray;
    FAllowedLeakListIndex: Word;
    // Object used by the GUI to map the test onto a GUI object such as a tree node
    FGUIObject: TObject;
    procedure Invoke(AMethod: TTestMethod); virtual;
    procedure RunWithFixture(testResult: TTestResult); virtual;
    procedure RunTest(testResult: TTestResult); virtual;
    procedure SetUp; virtual;
    procedure TearDown; virtual;
    procedure SetStartTime(Value :Int64); virtual;
    function  GetStartTime : Int64;       virtual;
    procedure SetStopTime(Value :Int64);  virtual;
    function  GetStopTime : Int64;        virtual;
    procedure SetGUIObject(const guiObject: TObject);
    function  GetGUIObject: TObject;
    procedure SetFailsOnNoChecksExecuted(const Value: Boolean);
    function  GetFailsOnNoChecksExecuted: Boolean;
    function  GetFailsOnMemoryLeak: Boolean;
    procedure SetFailsOnMemoryLeak(const Value: Boolean);
    {$IFNDEF CLR} // related to Check(Not)EqualsMem, pointer based, unsuitable for .NET
    function GetMemDiffStr(expected, actual: pointer; size:longword; msg:string):string;
    {$ENDIF}
    function  GetAllowedMemoryLeakSize: Integer;
    procedure SetAllowedMemoryLeakSize(const NewSize: Integer);
    function  GetFailsOnMemoryRecovery: Boolean;
    procedure SetFailsOnMemoryRecovery(const Value: Boolean);
    function  GetIgnoreSetUpTearDownLeaks: Boolean;
    procedure SetIgnoreSetUpTearDownLeaks(const Value: Boolean);
    function  GetMemoryLeakIgnoredInSetupTearDown: Boolean;
    procedure SetMemoryLeakIgnoredInSetupTearDown(const Value: Boolean);
    procedure SetAllowedLeakArray(AllowedList: array of Integer);
    function  GetAllowedLeak: Integer; // Is the iterator returned below
    function  GetAllowedLeaksIterator: TListIterator;
  public
    constructor Create(AName: string);
    destructor Destroy; override;
    function  GetName: string; virtual;
    function  GetEnabled: Boolean; virtual;
    procedure SetEnabled(value: Boolean); virtual;
    function  Tests: IInterfaceList; virtual;
    function  CountTestCases: integer; virtual;
    function  CountEnabledTestCases: integer; virtual;
    function  Run: TTestResult; overload;
    procedure Run(testResult: TTestResult); overload;
    function  GetTestMethodInvoked: Boolean;
    procedure SetTestMethodInvoked(const Value: Boolean);
    function  ElapsedTestTime: Cardinal; virtual;
    procedure SetStatusListener(Listener :IStatusListener);
    procedure Status(const Msg :string);
    function  GetStatus :string;
    procedure LoadConfiguration(const fileName: string; const useRegistry, useMemIni: Boolean); overload;
    procedure LoadConfiguration(const iniFile :TCustomIniFile; const section :string);  overload; virtual;
    procedure SaveConfiguration(const fileName: string; const useRegistry, useMemIni: Boolean); overload;
    procedure SaveConfiguration(const iniFile :TCustomIniFile; const section :string);  overload; virtual;
    property Name:    string  read GetName;
    property Enabled: Boolean read GetEnabled write SetEnabled;
    function  BoolToStr(ABool: Boolean): string;
    procedure Check(condition: Boolean; msg: string = ''); virtual;
    procedure CheckTrue(condition: Boolean; msg: string = ''); virtual;
    procedure CheckFalse(condition: Boolean; msg: string = ''); virtual;
    procedure CheckEquals(expected, actual: extended; msg: string = ''); overload; virtual;
    procedure CheckEquals(expected, actual: extended; delta: extended; msg: string = ''); overload; virtual;
    procedure CheckEquals(expected, actual: integer; msg: string = ''); overload; virtual;
    procedure CheckEquals(expected, actual: string; msg: string = ''); overload; virtual;
    procedure CheckEqualsString(expected, actual: string; msg: string = ''); virtual;
{$IFNDEF CLR}
    procedure CheckEquals(expected, actual: WideString; msg: string = ''); overload; virtual;
    procedure CheckEqualsWideString(expected, actual: WideString; msg: string = ''); virtual;
    procedure CheckEqualsMem(expected, actual: pointer; size:longword; msg:string=''); virtual;
{$ENDIF}
    procedure CheckEquals(expected, actual: Boolean; msg: string = ''); overload; virtual;
    procedure CheckEqualsBin(expected, actual: longword; msg: string = ''; digits: integer=32); virtual;
    procedure CheckEqualsHex(expected, actual: longword; msg: string = ''; digits: integer=8); virtual;
    procedure CheckNotEquals(expected, actual: integer; msg: string = ''); overload; virtual;
    procedure CheckNotEquals(expected: extended; actual: extended; delta: extended = 0; msg: string = ''); overload; virtual;
    procedure CheckNotEquals(expected, actual: string; msg: string = ''); overload; virtual;
    procedure CheckNotEqualsString(expected, actual: string; msg: string = ''); virtual;
{$IFNDEF CLR}
    procedure CheckNotEquals(const expected, actual: WideString; msg: string = ''); overload; virtual;
    procedure CheckNotEqualsWideString(const expected, actual: WideString; msg: string = ''); virtual;
    procedure CheckNotEqualsMem(expected, actual: pointer; size:longword; msg:string=''); virtual;
{$ENDIF}
    procedure CheckNotEquals(expected, actual: Boolean; msg: string = ''); overload; virtual;
    procedure CheckNotEqualsBin(expected, actual: longword; msg: string = ''; digits: integer=32); virtual;
    procedure CheckNotEqualsHex(expected, actual: longword; msg: string = ''; digits: integer=8); virtual;
    procedure CheckNotNull(obj :IUnknown; msg :string = ''); overload; virtual;
    procedure CheckNull(obj: IUnknown; msg: string = ''); overload; virtual;
    procedure CheckSame(expected, actual: IUnknown; msg: string = ''); overload; virtual;
    procedure CheckSame(expected, actual: TObject; msg: string = ''); overload; virtual;
    procedure CheckNotNull(obj: TObject; msg: string = ''); overload; virtual;
    procedure CheckNull(obj: TObject; msg: string = ''); overload; virtual;
    procedure CheckException(AMethod: TTestMethod; AExceptionClass: TClass; msg :string = '');
    procedure CheckEquals(  expected, actual: TClass; msg: string = ''); overload; virtual;
    procedure CheckInherits(expected, actual: TClass; msg: string = ''); overload; virtual;
    procedure CheckIs(AObject :TObject; AClass: TClass; msg: string = ''); overload; virtual;
    procedure Fail(msg: sTring; ErrorAddrs: Pointer = nil); overload; virtual;
    procedure FailEquals(expected, actual: WideString; msg: string = ''; ErrorAddrs: Pointer = nil); virtual;
    procedure FailNotEquals(expected, actual: WideString; msg: string = ''; ErrorAddrs: Pointer = nil); virtual;
    procedure FailNotSame(expected, actual: WideString; msg: string = ''; ErrorAddrs: Pointer = nil); virtual;
    function EqualsErrorMessage(expected, actual :WideString; msg: string): WideString;
    function NotEqualsErrorMessage(expected, actual :WideString; msg: string): WideString;
    function NotSameErrorMessage(expected, actual, msg: string): WideString;
    procedure StopTests(msg: string = ''); virtual;
{$IFNDEF CLR}
    procedure CheckMethodIsNotEmpty(MethodPointer: pointer);
{$ENDIF}
    procedure StartExpectingException(e: ExceptionClass);
    procedure StopExpectingException(msg :string = '');
    property ExpectedException :ExceptionClass
      read  fExpectedException
      write StartExpectingException;
  published
    property FailsOnNoChecksExecuted: Boolean
      read GetFailsOnNoChecksExecuted
      write SetFailsOnNoChecksExecuted;
    property FailsOnMemoryLeak: Boolean
      read GetFailsOnMemoryLeak
      write SetFailsOnMemoryLeak;
    property TestMethodInvoked: Boolean
      read GetTestMethodInvoked
      write SetTestMethodInvoked;
    property AllowedMemoryLeakSize: Integer
      read GetAllowedMemoryLeakSize
      write SetAllowedMemoryLeakSize;
    property AllowedLeaksIterator: TListIterator read GetAllowedLeaksIterator;
    property FailsOnMemoryRecovery: Boolean
      read GetFailsOnMemoryRecovery
      write SetFailsOnMemoryRecovery;
    property IgnoreSetUpTearDownLeaks: Boolean
      read GetIgnoreSetUpTearDownLeaks
      write SetIgnoreSetUpTearDownLeaks;
  end;
  TTestCase = class(TAbstractTest, ITest)
  protected
    fMethod:    TTestMethod;
    procedure Invoke(AMethod: TTestMethod); override;
    procedure RunWithFixture(testResult: TTestResult); override;
    procedure RunTest(testResult: TTestResult); override;
  public
    constructor Create(MethodName: string); virtual;
    class function Suite: ITestSuite; virtual;
    procedure Run(testResult: TTestResult); overload;
  published
  end;
  TTestSuite = class(TAbstractTest, ITestSuite, ITest)
  protected
    FTests: IInterfaceList;
    procedure RunTest(testResult: TTestResult); override;
  public
    constructor Create; overload;
    constructor Create(AName: string); overload;
    constructor Create(TestClass: TTestCaseClass); overload;
    constructor Create(AName: string; const Tests: array of ITest); overload;
    function CountTestCases: integer;         override;
    function CountEnabledTestCases: integer;  override;
    function Tests: IInterfaceList;                 override;
    procedure AddTest(ATest: ITest);                virtual;
    procedure AddTests(testClass: TTestCaseClass);  virtual;
    procedure AddSuite(suite:  ITestSuite);         virtual;
    procedure LoadConfiguration(const iniFile: TCustomIniFile; const section: string);  override;
    procedure SaveConfiguration(const iniFile: TCustomIniFile; const section: string);  override;
  end;
  TTestFailure = class(TObject)
  protected
    FFailedTest: ITest;
    FThrownExceptionClass: TClass;
    FThrownExceptionMessage: string;
    FThrownExceptionAddress: Pointer;
    FStackTrace:             string;
    procedure CaptureStackTrace;
  public
    constructor Create(FailedTest: ITest; thrownException: Exception; Addrs: Pointer; msg: string = ''); overload;
    constructor Create(FailedTest: ITest; Addrs: Pointer; msg: string); overload;
    function FailedTest: ITest; virtual;
    function ThrownExceptionClass: TClass; virtual;
    function ThrownExceptionName: string; virtual;
    function ThrownExceptionMessage: string; virtual;
    function ThrownExceptionAddress: pointer; virtual;
    function LocationInfo: string; virtual;
    function AddressInfo:  string; virtual;
    function StackTrace:   string; virtual;
  end;
  TMethodEnumerator = class
  protected
    FMethodNameList:  array of string;
    function GetNameOfMethod(idx: integer):  string;
    function GetMethodCount: Integer;
  public
    constructor Create(AClass: TClass);
    property MethodCount: integer read GetMethodCount;
    property NameOfMethod[idx:  integer]: string read GetNameOfMethod;
  end;
// creating suites
function  TestSuite(AName: string; const Tests: array of ITest): ITestSuite;
// test registry
procedure RegisterTest(SuitePath: string; test: ITest); overload;
procedure RegisterTest(test: ITest);                    overload;
procedure RegisterTests(SuitePath: string; const Tests: array of ITest);  overload;
procedure RegisterTests(const Tests: array of ITest);                     overload;
function  RegisteredTests: ITestSuite;
procedure ClearRegistry;
// running tests
function RunTest(suite: ITest; listeners: array of ITestListener): TTestResult; overload;
function RunRegisteredTests(listeners: array of ITestListener): TTestResult;
// utility routines
function CallerAddr: Pointer; {$IFNDEF CLR} assembler; {$ENDIF}
function PtrToStr(p: Pointer): string;
function PointerToLocationInfo(Addrs: Pointer): string;
function PointerToAddressInfo(Addrs: Pointer):  string;
function IsTestMethod(aTest: ITest): Boolean;
function IsDecorator(aTest: ITest): Boolean;
function GetDUnitRegistryKey: string;
procedure SetDUnitRegistryKey(const NewKey: string);
{$IFNDEF CLR}  // - unsuitable for .NET, pointer magic
function FirstByteDiff(p1, p2: pointer; size: longword; out b1, b2: byte): integer;
{$ENDIF}
function MemLeakMonitor: IMemLeakMonitor;
//  strings, used in TAbstractTestCase.EqualsErrorMessage etc.:
const sExpButWasFmt    = '%sexpected: <%s> but was: <%s>';
      sExpAndActualFmt = '%sexpected and actual were: <%s>';
{$UNDEF DETECTMEMLEAKS}
{$IFDEF VER180}
  {$IFNDEF CLR}
    {$DEFINE DETECTMEMLEAKS}
  {$ENDIF}
{$ENDIF}
{$IFDEF FASTMM}
  {$DEFINE DETECTMEMLEAKS}
{$ENDIF}
///////////////////////////////////////////////////////////////////////////
implementation
uses
{$IFDEF LINUX}
  Libc,
{$ELSE}
  Windows,
  Registry,
{$ENDIF}
{$IFDEF USE_JEDI_JCL}
  JclDebug,
{$ENDIF}
{$IFDEF DETECTMEMLEAKS}
  FastMMMemLeakMonitor,
{$ENDIF}
{$IFDEF madExcept}
  madStackTrace,
{$ENDIF}
  TypInfo;
{$STACKFRAMES ON} // Required to retrieve caller's address
{$IFNDEF DETECTMEMLEAKS}
// Stub code for use when Memory Leak detection is disabled.
// See FastMM MemLeakMonitor.pas notes for invoking memory leak detection.
type
  TMemLeakMonitor = class(TInterfacedObject, IMemLeakMonitor)
  private
    function MemLeakDetected(out LeakSize: Integer): Boolean; overload;
  end;
{ TMemMonitor }
function TMemLeakMonitor.MemLeakDetected(out LeakSize: Integer): Boolean;
begin
  LeakSize := 0;
  Result := False;
end;
type
  TDUnitMemLeakMonitor = class(TMemLeakMonitor, IDUnitMemLeakMonitor)
    function MemLeakDetected(const AllowedLeakSize: Integer;
                             const FailOnMemoryRecovery: Boolean;
                             out   LeakSize: Integer): Boolean; overload;
    function MemLeakDetected(const AllowedValuesGetter: TListIterator;
                             const FailOnMemoryRecovery: Boolean;
                             out   LeakIndex: integer;
                             out   LeakSize: Integer): Boolean; overload;
    function GetMemoryUseMsg(const FailOnMemoryRecovery: Boolean;
                             const TestProcChangedMem: Integer;
                             out   ErrorMsg: string): Boolean; overload;
    function GetMemoryUseMsg(const FailOnMemoryRecovery: boolean;
                             const TestSetupChangedMem: Integer;
                             const TestProcChangedMem: Integer;
                             const TestTearDownChangedMem: Integer;
                             const TestCaseChangedMem: Integer;
                             out   ErrorMsg: string): boolean; overload;
    procedure MarkMemInUse;
  end;
{ TDUnitMemMonitor }
procedure TDUnitMemLeakMonitor.MarkMemInUse;
begin
// Do Nothing
end;
function TDUnitMemLeakMonitor.MemLeakDetected(const AllowedLeakSize: Integer;
                                              const FailOnMemoryRecovery: Boolean;
                                              out   LeakSize: Integer): Boolean;
begin
  inherited MemLeakDetected(LeakSize);
  Result := (AllowedLeakSize <> 0);
end;
function TDUnitMemLeakMonitor.MemLeakDetected(const AllowedValuesGetter: TListIterator;
                                              const FailOnMemoryRecovery: Boolean;
                                              out   LeakIndex: integer;
                                              out   LeakSize: Integer): Boolean;
begin
  inherited MemLeakDetected(LeakSize);
  LeakIndex := 0;
  Result := (AllowedValuesGetter <> 0);
end;
function TDUnitMemLeakMonitor.GetMemoryUseMsg(const FailOnMemoryRecovery: Boolean;
                                              const TestProcChangedMem: Integer;
                                              out   ErrorMsg: string): Boolean;
begin
  ErrorMsg := '';
  Result := True;
end;
function TDUnitMemLeakMonitor.GetMemoryUseMsg(const FailOnMemoryRecovery: boolean;
                                              const TestSetupChangedMem: Integer;
                                              const TestProcChangedMem: Integer;
                                              const TestTearDownChangedMem: Integer;
                                              const TestCaseChangedMem: Integer;
                                              out   ErrorMsg: string): boolean;
begin
  ErrorMsg := '';
  Result := True;
end;
{$ENDIF}
function MemLeakMonitor: IMemLeakMonitor;
begin
  Result := TMemLeakMonitor.Create;
end;
type
  TMemIniFileTrimmed = class(TMemIniFile)
  public
    // Override the read string method to trim the string for compatibility with TIniFile
    function ReadString(const Section, Ident, DefaultStr: string): string; override;
  end;
var
  // SubKey of HKEY_CURRENT_USER for storing configurations in the registry (end with )
  DUnitRegistryKey: string = ''; // How about 'SoftwareDUnitTests';
{$IFDEF LINUX}
var
  PerformanceCounterInitValue: Int64;
procedure InitPerformanceCounter;
var
  TV : TTimeVal;
  TZ : TTimeZone;
begin
  gettimeofday(TV, TZ);
  PerformanceCounterInitValue :=
    LongWord(TV.tv_sec mod (24*60*60) * 1000) + (LongWord(TV.tv_usec) div 1000);
end;
function QueryPerformanceCounter(var PerformanceCounter: Int64): LongBool;
var
  TV : TTimeVal;
  TZ : TTimeZone;
begin
  gettimeofday(TV, TZ);
  PerformanceCounter := (TV.tv_sec mod (24*60*60) * 1000) +
            (TV.tv_usec div 1000);
  PerformanceCounter := PerformanceCounter - PerformanceCounterInitValue;
  Result := true;
end;
function QueryPerformanceFrequency(var Frequency: Int64): LongBool;
begin
  Frequency := 1000;
  Result := true;
end;
{$ENDIF}
{: Convert a pointer into its string representation }
function PtrToStr(p: Pointer): string;
begin
   Result := Format('%p', [p])
end;
function IsBadPointer(P: Pointer):Boolean; {$IFNDEF CLR} register; {$ENDIF}
begin
  try
    Result  := (p = nil)
{$IFNDEF CLR}
              or ((Pointer(P^) <> P) and (Pointer(P^) = P));
{$ENDIF}
  except
    Result := true;
  end
end;
function CallerAddr: Pointer; {$IFNDEF CLR} assembler; {$ENDIF}
{$IFDEF CLR}
begin
  Result := nil;
end;
{$ELSE}
const
  CallerIP = $4;
asm
   mov   eax, ebp
   call  IsBadPointer
   test  eax,eax
   jne   @@Error
   mov   eax, [ebp].CallerIP
   sub   eax, 5   // 5 bytes for call
   push  eax
   call  IsBadPointer
   test  eax,eax
   pop   eax
   je    @@Finish
@@Error:
   xor eax, eax
@@Finish:
end;
{$ENDIF}
{$IFNDEF USE_JEDI_JCL}
{$IFNDEF madExcept}
function PointerToLocationInfo(Addrs: Pointer): string;
begin
 Result := ''
end;
function PointerToAddressInfo(Addrs: Pointer): string;
begin
 Result := '$'+PtrToStr(Addrs);
end;
{$ELSE}
function PointerToLocationInfo(Addrs: Pointer): string;
begin
 Result := StackAddrToStr( Addrs );
end;
function PointerToAddressInfo(Addrs: Pointer): string;
begin
 Result := StackAddrToStr( Addrs );
end;
{$ENDIF}
{$ELSE}
function PointerToLocationInfo(Addrs: Pointer): string;
var
  _file,
  _module,
  _proc: AnsiString;
  _line: integer;
begin
  JclDebug.MapOfAddr(Addrs, _file, _module, _proc, _line);
  if _file <> '' then
    Result   := Format('%s:%d', [_file, _line])
  else
    Result   := _module;
end;
function PointerToAddressInfo(Addrs: Pointer): string;
var
  _file,
  _module,
  _proc: AnsiString;
  _line: integer;
begin
  JclDebug.MapOfAddr(Addrs, _file, _module, _proc, _line);
  Result := Format('%s$%p', [_proc, Addrs]);
end;
{$ENDIF}
function IsTestMethod(aTest: ITest): Boolean;
var
  aTestSuite: ITestSuite;
  aTestDecorator: ITestDecorator;
begin
  Assert(Assigned(aTest));
  // Initialize to be sure
  aTestSuite := nil;
  aTestDecorator := nil;
  { The test should be a normal testmethod
    when the testcount = 1 }
  Result := (aTest.CountTestCases = 1);
  // But not when the test is a suite? (It could have one test.)
{$IFDEF CLR}
  if Supports(aTest, ITestSuite) or Supports(aTest, ITestDecorator) then
    Result := false;
{$ELSE}
  aTest.QueryInterface(ITestSuite, aTestSuite);
  if Assigned(aTestSuite) then
    Result := false;
  // And not when the test is a decorator?
  aTest.QueryInterface(ITestDecorator, aTestDecorator);
  if Assigned(aTestDecorator) then
    Result := false;
{$ENDIF}
end;
function IsDecorator(aTest: ITest): Boolean;
var
  aTestDecorator: ITestDecorator;
begin
  Assert(Assigned(aTest));
  // Initialize to be sure
  aTestDecorator := nil;
{$IFDEF CLR}
  Result := Supports(aTest, ItestDecorator);
{$ELSE}
  aTest.QueryInterface(ITestDecorator, aTestDecorator);
  Result := Assigned(aTestDecorator);
{$ENDIF}
end;
function GetDUnitRegistryKey: string;
begin
  Result := DUnitRegistryKey;
end;
procedure SetDUnitRegistryKey(const NewKey: string);
begin
  DUnitRegistryKey := NewKey;
end;
{$IFNDEF CLR} // KGS: not expected to work in .NET, pointer magic follows
function ByteAt(p: pointer; const Offset: integer): byte;
begin
  Result:=pByte(integer(p)+Offset)^;
end;
function FirstByteDiff(p1, p2: pointer; size: longword; out b1, b2: byte): integer;
// Returns offset of first byte pair (left to right, incrementing address) that is unequal
// Returns -1 if no difference found, or if size=0
var
  i: integer;
begin
  Result:=-1;
  if size>0 then
  for i:=0 to size-1 do // Subject to optimisation for sure:
    if ByteAt(p1,i)<>ByteAt(p2,i) then
    begin
      Result:=i;
      b1:=ByteAt(p1,i);
      b2:=ByteAt(p2,i);
      break;
    end;
end;
{$ENDIF}
{ TTestResult }
constructor TTestResult.Create;
begin
  inherited Create;
  FFailures := TList.Create;
  FErrors := TList.Create;
  FListeners := TInterfaceList.Create;
  FRunTests := 0;
  FStop := false;
  FStatusAdapter := TStatusToResultAdapter.Create(Self);
end;
destructor TTestResult.destroy;
var
  i: Integer;
begin
  for i := 0 to fErrors.Count - 1 do
  begin
    TTestFailure(fErrors[i]).Free;
  end;
  FErrors.Free;
  for i := 0 to fFailures.Count - 1 do
  begin
    TTestFailure(fFailures[i]).Free;
  end;
  FFailures.Free;
  inherited;
end;
procedure TTestResult.AddSuccess(test: ITest);
var
  i: integer;
begin
  assert(assigned(test));
  for i := 0 to fListeners.count - 1 do
  begin
    (fListeners[i] as ITestListener).AddSuccess(test);
  end;
end;
function TTestResult.AddError(test: ITest; e: Exception; Addrs: Pointer; msg: string): TTestFailure;
var
  i: integer;
  TestFailureError:  TTestFailure;
begin
  assert(assigned(test));
  assert(assigned(e));
  assert(assigned(fErrors));
  TestFailureError := TTestFailure.Create(test, e, Addrs, msg);
  FErrors.add(TestFailureError);
  for i := 0 to FListeners.count - 1 do
  begin
    (FListeners[i] as ITestListener).AddError(TestFailureError);
  end;
  assert(assigned(TestFailureError));
  Result := TestFailureError;
end;
function TTestResult.AddFailure(test: ITest; e: Exception; Addrs: Pointer): TTestFailure;
var
  i: integer;
  Failure:  TTestFailure;
begin
  assert(assigned(test));
  assert(assigned(e));
  assert(assigned(fFailures));
  Failure := TTestFailure.Create(test, e, Addrs);
  FFailures.add(Failure);
  for i := 0 to FListeners.count - 1 do
  begin
    (FListeners[i] as ITestListener).AddFailure(Failure);
  end;
  assert(assigned(Failure));
  Result := Failure;
end;
procedure TTestResult.addListener(listener: ITestListener);
begin
  assert(assigned(listener), 'listener is nil');
  FListeners.add(listener);
end;
procedure TTestResult.EndTest(test: ITest);
var
  i: integer;
begin
  assert(assigned(FListeners));
  try
    for i := 0 to FListeners.count - 1 do
    begin
      (FListeners[i] as ITestListener).EndTest(test);
    end;
  finally
    test.SetStatusListener(nil);
  end;
end;
procedure TTestResult.Status(test: ITest; const Msg: string);
var
  i: integer;
begin
  assert(assigned(FListeners));
  for i := 0 to FListeners.count - 1 do
  begin
    (FListeners[i] as ITestListener).Status(test, Msg);
  end;
end;
function TTestResult.GetError(idx :Integer): TTestFailure;
begin
  Result := TObject(FErrors[idx]) as TTestFailure;
end;
function TTestResult.GetFailure(idx :Integer): TTestFailure;
begin
  Result := TObject(FFailures[idx]) as TTestFailure;
end;
function TTestResult.RunTestSetup(test: ITest):Boolean;
var
  LTime :Int64;
begin
  Result := false;
  try
    test.StopTime := 0;
    QueryPerformanceCounter(LTime);
    test.StartTime := LTime;
    test.FailsOnNoChecksExecuted := FFailsIfNoChecksExecuted;
    test.FailsOnMemoryLeak := FFailsIfMemoryLeaked;
    test.IgnoreSetUpTearDownLeaks:= FIgnoresMemoryLeakInSetUpTearDown;
    test.SetUp;
    Result := true;
  except
    on e: Exception do
    begin
      AddError(test, e, ExceptAddr, 'SetUp FAILED: ');
    end;
  end;
end;
procedure TTestResult.RunTestTearDown(test: ITest);
var
  LTime :Int64;
begin
  try
    test.TearDown;
  except
    on e: Exception do
      AddError(test, e, ExceptAddr, 'TearDown FAILED: ');
  end;
  QueryPerformanceCounter(LTime);
  test.StopTime := LTime;
end;
function TTestResult.RunTestRun(test: ITest) : Boolean;
var
  failure: TTestFailure;
begin
  Result := false;
  test.TestMethodInvoked := False;
  failure := nil;
  {$IFDEF USE_JEDI_JCL}
  try
    JclStartExceptionTracking;
  {$ENDIF}
    try
      test.RunTest(self);
      if not Assigned(FRootTest) then
        FRootTest := test;
      FTotalTime := FRootTest.ElapsedTestTime;
      Result := true;
    except
      on e: EStopTestsFailure do
      begin
        failure := AddFailure(test, e, ExceptAddr);
        FStop := True;
      end;
      on e: ETestFailure do
      begin
        failure := AddFailure(test, e, ExceptAddr);
      end;
      on e: EBreakingTestFailure do
      begin
        failure := AddFailure(test, e, ExceptAddr);
      end;
      on e: Exception do
      begin
        failure := AddError(test, e, ExceptAddr);
      end;
    end;
  {$IFDEF USE_JEDI_JCL}
  finally
    JclStopExceptionTracking;
  end;
  {$ENDIF}
  if BreakOnFailures
  and (failure <> nil)
  and (failure.FThrownExceptionClass.InheritsFrom(ETestFailure))
  then
  begin
    try
       raise EBreakingTestFailure.Create(failure.ThrownExceptionMessage)
          {$IFNDEF CLR}at failure.ThrownExceptionAddress{$ENDIF};
    except
    end;
  end;
end;
procedure TTestResult.Run(test: ITest);
var
  TestProcExecuted: Boolean;
  TestCaseMemLeakMonitor : IDUnitMemLeakMonitor;
  TestProcMemLeakMonitor : IDUnitMemLeakMonitor;
  TestProcMemdiff        : Integer;
  TestCaseMemdiff        : Integer;
  TestCasePassed         : Boolean;
  ErrorMessage           : string;
  MemImbalance           : Boolean;
  SetupMemDiff           : Integer;
  TearDownMemDiff        : Integer;
  LeakIndex              : Integer;
begin
  assert(assigned(test));
  if not ShouldStop and ShouldRunTest(test) then
  begin
    StartTest(test);
    test.AllowedMemoryLeakSize := 0;
    try
      TestProcExecuted := False;
      TestCasePassed := False;
      TestCaseMemdiff := 0;
      TestProcMemdiff := 0;
      ErrorMessage := '';
      // Start monitoring memory allocation before Setup.
      TestProcMemLeakMonitor := TDUnitMemLeakMonitor.Create;
      TestCaseMemLeakMonitor := TDUnitMemLeakMonitor.Create;
      if RunTestSetUp(test) then
      begin
        // See if Setup Leaked.
        (TestCaseMemLeakMonitor as IMemLeakMonitor).MemLeakDetected(SetupMemDiff);
        TestProcMemLeakMonitor.MarkMemInUse;
        TestCasePassed := RunTestRun(test);
        //Not all calls to RunTestRun call Test Procedures so check if this was.
        TestProcExecuted := isTestMethod(test);
        if TestProcExecuted and test.FailsOnMemoryLeak then
          (TestProcMemLeakMonitor as IMemLeakMonitor).MemLeakDetected(TestProcMemdiff);
      end;
      TestProcMemLeakMonitor.MarkMemInUse;
      RunTestTearDown(test);
      (TestProcMemLeakMonitor as IMemLeakMonitor).MemLeakDetected(TearDownMemDiff);
      // Reporting of test success is delayed from within RunTestRun so mem leak
      // can be flagged as failure at testcase level encompasing all of
      // SetUp, Run and TearDown.
      if TestCasePassed then
      begin
        if not TestProcExecuted or not test.FailsOnMemoryLeak then
          // Show non Test Procedure call success or TestCase success if not
          // showing failure on memory status change
          AddSuccess(test)
        else
        begin
          MemImbalance := TestCaseMemLeakMonitor.MemLeakDetected(test.AllowedLeaksIterator,
                                                                 test.FailsOnMemoryRecovery,
                                                                 LeakIndex,
                                                                 TestCaseMemdiff);
          FMemoryLeakIgnoredInSetupOrTearDown := IgnoresMemoryLeakInSetUpTearDown and
            (TestProcMemdiff = 0) and MemImbalance;
          if not FMemoryLeakIgnoredInSetupOrTearDown and (MemImbalance and
            (not TestCaseMemLeakMonitor.GetMemoryUseMsg(test.FailsOnMemoryRecovery,
                                                        SetupMemDiff,
                                                        TestProcMemdiff,
                                                        TearDownMemDiff,
                                                        TestCaseMemdiff,
                                                        ErrorMessage))) then
            AddFailure(test, FMethodPtr, ErrorMessage)
          else
          begin
            AddSuccess(test);
            //Report back allowed leak size actually used from list of sizes
            if (TestCaseMemdiff <> 0) then
             Test.AllowedMemoryLeakSize := TestCaseMemdiff;
          end;
        end;
      end;
    finally
      EndTest(test);
      TestProcMemLeakMonitor := nil;
      TestCaseMemLeakMonitor := nil;
    end;
  end;
end;
function TTestResult.RunCount: integer;
begin
  Result := FRunTests;
end;
function TTestResult.ShouldStop: Boolean;
begin
  Result := FStop;
end;
procedure TTestResult.StartTest(test: ITest);
var
  i: integer;
begin
  assert(assigned(test));
  assert(assigned(FListeners));
  test.SetStatusListener(FStatusAdapter);
  for i := 0 to FListeners.count - 1 do
  begin
    (FListeners[i] as ITestListener).StartTest(test);
  end;
end;
procedure TTestResult.Stop;
begin
  FStop := true;
end;
function TTestResult.ErrorCount: integer;
begin
  assert(assigned(FErrors));
  Result := FErrors.count;
end;
function TTestResult.FailureCount: integer;
begin
  assert(assigned(FFailures));
  Result := FFailures.count;
end;
function TTestResult.WasSuccessful: Boolean;
begin
  Result := (FailureCount = 0) and (ErrorCount() = 0) and not WasStopped;
end;
procedure TTestResult.TestingStarts;
var
  i: Integer;
begin
  for i := 0 to FListeners.count - 1 do
  begin
    (FListeners[i] as ITestListener).TestingStarts;
  end;
end;
procedure TTestResult.TestingEnds;
var
  i: Integer;
begin
  for i := 0 to FListeners.count - 1 do
  begin
    (FListeners[i] as ITestListener).TestingEnds(self);
  end;
end;
function TTestResult.ShouldRunTest(test: ITest): Boolean;
var
  i: Integer;
begin
  Result := True;
  for i := 0 to FListeners.count - 1 do
  begin
    if not (FListeners[i] as ITestListener).ShouldRunTest(test) then
    begin
      Result := false;
      break;
    end;
  end;
end;
function TTestResult.WasStopped: Boolean;
begin
  Result := FStop;
end;
procedure TTestResult.RunSuite(test: ITest);
begin
  TestingStarts;
  try
    FRootTest := test;
    test.RunWithFixture(self);
  finally
    TestingEnds
  end
end;
procedure TTestResult.EndSuite(suite: ITest);
var
  i: Integer;
  l: ITestListenerX;
begin
  for i := 0 to FListeners.count - 1 do
  begin
{$IFDEF CLR}
    if Supports(FListeners[i], ITestListenerX, l) then
{$ELSE}
    if FListeners[i].QueryInterface(ITestListenerX, l) = 0 then
{$ENDIF}
       l.EndSuite(suite);
  end;
end;
procedure TTestResult.StartSuite(suite: ITest);
var
  i: Integer;
  l: ITestListenerX;
begin
  for i := 0 to FListeners.count - 1 do
  begin
{$IFDEF CLR}
    if Supports(FListeners[i], ITestListenerX, l) then
{$ELSE}
    if FListeners[i].QueryInterface(ITestListenerX, l) = 0 then
{$ENDIF}
      l.StartSuite(suite);
  end;
end;
function TTestResult.AddFailure(test: ITest; Addrs: Pointer; msg :string = ''): TTestFailure;
var
  i: integer;
  Failure:  TTestFailure;
begin
  assert(assigned(test));
  assert(assigned(FFailures));
  Failure := TTestFailure.Create(test, Addrs, msg);
  FFailures.add(Failure);
  for i := 0 to FListeners.count - 1 do
  begin
    (FListeners[i] as ITestListener).AddFailure(Failure);
  end;
  assert(assigned(Failure));
  Result := Failure;
end;
{ TStatusToResultAdapter }
constructor TStatusToResultAdapter.Create(TestResult: TTestResult);
begin
  Assert(TestResult <> nil, 'Expected non nil TestResult');
  inherited Create;
  FTestResult := TestResult;
end;
procedure TStatusToResultAdapter.Status(Test: ITest; const Msg: string);
begin
  FTestResult.Status(Test, Msg);
end;
{ TAbstractTest }
constructor TAbstractTest.Create(AName: string);
var
  I: Integer;
begin
  inherited Create;
  FTestName := AName;
  FEnabled  := true;
  for I := 0 to Length(FAllowedLeakList) - 1 do    // Iterate
    FAllowedLeakList[I] := 0;
end;
destructor TAbstractTest.Destroy;
begin
  FStatusStrings.Free;
  FStatusListener := nil;
  inherited;
end;
procedure TAbstractTest.Invoke(AMethod: TTestMethod);
begin
  FTestMethodInvoked := False;
end;
procedure TAbstractTest.Run(testResult: TTestResult);
begin
  FailsOnNoChecksExecuted := testResult.FailsIfNoChecksExecuted;
  FailsOnMemoryLeak := testResult.FailsIfMemoryLeaked;
  IgnoreSetUpTearDownLeaks := testResult.IgnoresMemoryLeakInSetUpTearDown;
  testResult.RunSuite(self);
end;
function TAbstractTest.CountEnabledTestCases: integer;
begin
  if GetEnabled then
    Result := 1
  else
    Result := 0
end;
function TAbstractTest.CountTestCases: integer;
begin
  Result := 1;
end;
function TAbstractTest.getEnabled: Boolean;
begin
  Result := FEnabled
end;
function TAbstractTest.GetName: string;
begin
  Result := FTestName
end;
procedure TAbstractTest.LoadConfiguration(const fileName: string; const useRegistry, useMemIni: Boolean);
var
  f: TCustomIniFile;
begin
{$IFNDEF LINUX}
  if useRegistry then
    f := TRegistryIniFile.Create(DUnitRegistryKey + fileName)
  else
{$ENDIF}
    if useMemIni then
      f := TMemIniFileTrimmed.Create(fileName)
    else
      f := TIniFile.Create(fileName);
  try
    LoadConfiguration(f, 'Tests')
  finally
    f.free
  end
end;
procedure TAbstractTest.LoadConfiguration(const iniFile: TCustomIniFile; const section: string);
begin
  self.setEnabled(iniFile.readBool(section, self.GetName, True));
end;
procedure TAbstractTest.SaveConfiguration(const fileName: string; const useRegistry, useMemIni: Boolean);
var
  f: TCustomIniFile;
begin
{$IFNDEF LINUX}
  if useRegistry then
    f := TRegistryIniFile.Create(DUnitRegistryKey + fileName)
  else
{$ENDIF}
    if useMemIni then
      f := TMemIniFileTrimmed.Create(fileName)
    else
      f := TIniFile.Create(fileName);
  try
    SaveConfiguration(f, 'Tests');
    f.UpdateFile;
  finally
    f.free
  end
end;
procedure TAbstractTest.SaveConfiguration(const iniFile: TCustomIniFile; const section: string);
begin
  if self.GetEnabled then
    iniFile.deleteKey(section, self.GetName)
  else
    iniFile.writeBool(section, self.GetName, False);
end;
function TAbstractTest.Run: TTestResult;
var
  testResult:  TTestResult;
begin
  testResult := TTestResult.Create;
  try
    testResult.FailsIfNoChecksExecuted := self.FailsOnNoChecksExecuted;
    testResult.FailsIfMemoryLeaked := self.FailsOnMemoryLeak;
    testResult.IgnoresMemoryLeakInSetUpTearDown := IgnoreSetUpTearDownLeaks;
    testResult.RunSuite(self);
  except
    testResult.Free;
    raise;
  end;
  Result := testResult;
end;
procedure TAbstractTest.setEnabled(value: Boolean);
begin
  FEnabled := value;
end;
var
  EmptyTestList: IInterfaceList = nil;
function TAbstractTest.Tests: IInterfaceList;
begin
   if EmptyTestList = nil then
     EmptyTestList := TInterfaceList.Create;
   Result := EmptyTestList;
end;
function TAbstractTest.GetStartTime: Int64;
begin
  Result := FStartTime
end;
procedure TAbstractTest.SetStartTime(Value: Int64);
begin
  FStartTime := Value;
end;
procedure TAbstractTest.SetStopTime(Value: Int64);
begin
  FStopTime := Value;
end;
function TAbstractTest.GetStopTime: Int64;
begin
  Result := FStopTime;
end;
procedure TAbstractTest.SetUp;
begin
 // do nothing
end;
procedure TAbstractTest.TearDown;
begin
  // do nothing
end;
procedure TAbstractTest.RunTest(testResult: TTestResult);
begin
  // do nothing
end;
function TAbstractTest.ElapsedTestTime: Cardinal;
var
  Freq, LTime: Int64;
begin
  // returns TestTime in millisecs
  if fStopTime > 0 then
    LTime := FStopTime
  else if FStartTime > 0 then
    QueryPerformanceCounter(LTime)
  else
    LTime := 0;
  LTime := LTime - FStartTime;
  if QueryPerformanceFrequency(Freq) then
    Result := (1000*LTime) div Freq
  else
    Result := 0;
end;
procedure TAbstractTest.SetStatusListener(Listener: IStatusListener);
begin
  FStatusListener := Listener;
end;
function TAbstractTest.GetStatus: string;
begin
  if FStatusStrings = nil then
    Result := ''
  else
    Result := FStatusStrings.Text;
end;
procedure TAbstractTest.Status(const Msg: string);
begin
  if FStatusStrings = nil then
    FStatusStrings := TStringList.Create;
  FStatusStrings.Add(Msg);
  if FStatusListener <> nil then
    FStatusListener.Status(self, Msg);
end;
procedure TAbstractTest.RunWithFixture(testResult: TTestResult);
begin
  assert(assigned(testResult));
  if testResult.ShouldRunTest(self) then
    testResult.Run(self);
end;
procedure TAbstractTest.Check(condition: Boolean; msg: string);
begin
  FCheckCalled := True;
    if (not condition) then
        Fail(msg, CallerAddr);
end;
procedure TAbstractTest.CheckTrue(condition: Boolean; msg: string);
begin
  FCheckCalled := True;
  if (not condition) then
      FailNotEquals(BoolToStr(true), BoolToStr(false), msg, CallerAddr);
end;
procedure TAbstractTest.CheckFalse(condition: Boolean; msg: string);
begin
  FCheckCalled := True;
  if (condition) then
      FailNotEquals(BoolToStr(false), BoolToStr(true), msg, CallerAddr);
end;
procedure TAbstractTest.Fail(msg: string; ErrorAddrs: Pointer = nil);
begin
{$IFDEF CLR}
  raise ETestFailure.Create(msg);
{$ELSE}
  if ErrorAddrs = nil then
    raise ETestFailure.Create(msg) at CallerAddr
  else
    raise ETestFailure.Create(msg) at ErrorAddrs;
{$ENDIF}
end;
procedure TAbstractTest.StopTests(msg: string);
begin
  raise EStopTestsFailure.Create(msg);
end;
procedure TAbstractTest.FailNotEquals( expected,
                                       actual   : WideString;
                                       msg      : string = '';
                                       ErrorAddrs: Pointer = nil);
begin
    Fail(notEqualsErrorMessage(expected, actual, msg), ErrorAddrs);
end;
procedure TAbstractTest.FailEquals(       expected,
                                          actual   : WideString;
                                          msg      : string = '';
                                          ErrorAddrs: Pointer = nil);
begin
    Fail(EqualsErrorMessage(expected, actual, msg), ErrorAddrs);
end;
procedure TAbstractTest.FailNotSame( expected,
                                     actual   : WideString;
                                     msg      : string = '';
                                     ErrorAddrs: Pointer = nil);
begin
    Fail(NotSameErrorMessage(expected, actual, msg), ErrorAddrs);
end;
procedure TAbstractTest.CheckEquals( expected,
                                     actual   : extended;
                                     delta    : extended;
                                     msg      : string = '');
begin
  FCheckCalled := True;
    if (abs(expected-actual) > delta) then
        FailNotEquals(FloatToStr(expected), FloatToStr(actual), msg, CallerAddr);
end;
procedure TAbstractTest.CheckEquals(expected, actual: extended; msg: string);
begin
  CheckEquals(expected, actual, 0, msg);
end;
procedure TAbstractTest.CheckNotNull(obj: IUnknown; msg: string);
begin
  FCheckCalled := True;
    if obj = nil then
      Fail(msg, CallerAddr);
end;
procedure TAbstractTest.CheckNull(obj: IUnknown; msg: string);
begin
  FCheckCalled := True;
    if obj <>  nil then
      Fail(msg, CallerAddr);
end;
procedure TAbstractTest.CheckSame(expected, actual: IUnknown; msg: string = '');
begin
  FCheckCalled := True;
    if (expected <> actual) then
      FailNotSame(PtrToStr(Pointer(expected)), PtrToStr(Pointer(actual)), msg, CallerAddr);
end;
procedure TAbstractTest.CheckEquals(expected, actual: string; msg: string = '');
begin
  FCheckCalled := True;
  if expected <> actual then
    FailNotEquals(expected, actual, msg, CallerAddr);
end;
procedure TAbstractTest.CheckEqualsString(expected, actual: string; msg: string = '');
begin
  FCheckCalled := True;
  if expected <> actual then
    FailNotEquals(expected, actual, msg, CallerAddr);
end;
{$IFNDEF CLR}
procedure TAbstractTest.CheckEquals(expected, actual: WideString; msg: string = '');
begin
  FCheckCalled := True;
  if expected <> actual then
    FailNotEquals(expected, actual, msg, CallerAddr);
end;
procedure TAbstractTest.CheckEqualsWideString(expected, actual: WideString; msg: string = '');
begin
  FCheckCalled := True;
  if expected <> actual then
    FailNotEquals(expected, actual, msg, CallerAddr);
end;
function TAbstractTest.GetMemDiffStr(expected, actual: pointer; size:longword; msg:string):string;
var
  db1, db2: byte;
  Offset: integer;
begin
  Offset:=FirstByteDiff(expected,actual,size,db1,db2);
  Result:=NotEqualsErrorMessage(IntToHex(db1,2),IntToHex(db2,2),msg);
  Result:=Result+' at Offset = '+IntToHex(Offset,4)+'h';
end;
procedure TAbstractTest.CheckEqualsMem(expected, actual: pointer; size:longword; msg:string='');
begin
  FCheckCalled := True;
  if not CompareMem(expected, actual, size) then
    Fail(GetMemDiffStr(expected, actual, size, msg), CallerAddr);
end;
{$ENDIF}
procedure TAbstractTest.CheckNotEquals(expected, actual: string; msg: string = '');
begin
  FCheckCalled := True;
  if expected = actual then
    FailEquals(expected, actual, msg, CallerAddr);
end;
procedure TAbstractTest.CheckNotEqualsString(expected, actual: string; msg: string = '');
begin
  FCheckCalled := True;
  if expected = actual then
    FailEquals(expected, actual, msg, CallerAddr);
end;
{$IFNDEF CLR}
procedure TAbstractTest.CheckNotEquals(const expected, actual: WideString; msg: string = '');
begin
  FCheckCalled := True;
  if expected = actual then
    FailEquals(expected, actual, msg, CallerAddr);
end;
procedure TAbstractTest.CheckNotEqualsWideString(const expected, actual: WideString; msg: string = '');
begin
  FCheckCalled := True;
  if expected = actual then
    FailEquals(expected, actual, msg, CallerAddr);
end;
// Expected not to work under CLR (pointer based) - KGS
procedure TAbstractTest.CheckNotEqualsMem(expected, actual: pointer; size:longword; msg:string='');
begin
  FCheckCalled := True;
  if CompareMem(expected, actual, size) then
  begin
    if msg <>'' then msg := msg + ', ';
    Fail(msg+'Memory content was identical', CallerAddr);
  end;
end;
{$ENDIF}
procedure TAbstractTest.CheckEquals(expected, actual: integer; msg: string);
begin
  FCheckCalled := True;
  if (expected <> actual) then
    FailNotEquals(IntToStr(expected), IntToStr(actual), msg, CallerAddr);
end;
procedure TAbstractTest.CheckNotEquals(expected, actual: integer; msg: string = '');
begin
  FCheckCalled := True;
  if expected = actual then
    FailEquals(IntToStr(expected), IntToStr(actual), msg, CallerAddr);
end;
procedure TAbstractTest.CheckNotEquals(expected: extended; actual: extended; delta: extended = 0; msg: string = '');
begin
  FCheckCalled := True;
    if (abs(expected-actual) <= delta) then
        FailNotEquals(FloatToStr(expected), FloatToStr(actual), msg, CallerAddr);
end;
procedure TAbstractTest.CheckEquals(expected, actual: Boolean; msg: string);
begin
  FCheckCalled := True;
  if (expected <> actual) then
    FailNotEquals(BoolToStr(expected), BoolToStr(actual), msg, CallerAddr);
end;
procedure TAbstractTest.CheckNotEquals(expected, actual: Boolean; msg: string);
begin
  FCheckCalled := True;
  if (expected = actual) then
    FailEquals(BoolToStr(expected), BoolToStr(actual), msg, CallerAddr);
end;
{ [KGS] IntToBin: Elected not to add to TestFrameWork interface,
        many people already have a self made version: }
function IntToBin(const value, digits: longword): string;
const
  ALL_32_BIT_0 = '00000000000000000000000000000000';
var
  counter: integer;
  pow:     integer;
begin
  Result := ALL_32_BIT_0;
  SetLength(Result, digits);
  pow := 1 shl (digits - 1);
  if value <> 0 then
  for counter := 0 to digits - 1 do
  begin
    if (value and (pow shr counter)) <> 0 then
      Result[counter+1] := '1';
  end;
end;
procedure TAbstractTest.CheckEqualsBin(expected, actual: longword;
                                       msg: string = ''; digits: integer=32);
begin
  FCheckCalled := True;
  if expected <> actual then
    FailNotEquals(IntToBin(expected, digits), IntToBin(actual, digits), msg, CallerAddr);
end;
procedure TAbstractTest.CheckNotEqualsBin(expected, actual: longword;
                                       msg: string = ''; digits: integer=32);
begin
  FCheckCalled := True;
  if (expected = actual) then
    FailEquals(IntToBin(expected, digits), IntToBin(actual, digits), msg, CallerAddr);
end;
procedure TAbstractTest.CheckEqualsHex(expected, actual: longword;
                                       msg: string = ''; digits: integer=8);
begin
  FCheckCalled := True;
  if expected <> actual then
    FailNotEquals(IntToHex(expected, digits), IntToHex(actual, digits), msg, CallerAddr);
end;
procedure TAbstractTest.CheckNotEqualsHex(expected, actual: longword;
                                       msg: string = ''; digits: integer=8);
begin
  FCheckCalled := True;
  if (expected = actual) then
    FailEquals(IntToHex(expected, digits), IntToHex(actual, digits), msg, CallerAddr);
end;
procedure TAbstractTest.CheckSame(expected, actual: TObject; msg: string);
begin
  FCheckCalled := True;
    if (expected <> actual) then
      FailNotSame(PtrToStr(Pointer(expected)), PtrToStr(Pointer(actual)), msg, CallerAddr);
end;
procedure TAbstractTest.CheckNotNull(obj: TObject; msg: string);
begin
  FCheckCalled := True;
    if obj = nil then
       FailNotSame('object', PtrToStr(Pointer(obj)), msg, CallerAddr);
end;
procedure TAbstractTest.CheckNull(obj: TObject; msg: string);
begin
  FCheckCalled := True;
    if obj <> nil then
       FailNotSame('nil', PtrToStr(Pointer(obj)), msg, CallerAddr);
end;
function TAbstractTest.NotEqualsErrorMessage(expected, actual: WideString; msg: string): WideString;
begin
    if (msg <> '') then
        msg := msg + ', ';
    Result := Format( sExpButWasFmt , [msg, expected, actual])
end;
function TAbstractTest.EqualsErrorMessage(expected, actual: WideString; msg: string): WideString;
begin
    if (msg <> '') then
        msg := msg + ', ';
    Result := Format( sExpAndActualFmt, [msg, expected])
end;
function TAbstractTest.NotSameErrorMessage(expected, actual, msg: string): WideString;
begin
    if (msg <> '') then
        msg := msg + ', ';
    Result := Format( sExpButWasFmt, [msg, expected, actual])
end;
function TAbstractTest.BoolToStr(ABool: Boolean): string;
begin
  Result := BooleanIdents[aBool];
end;
procedure TAbstractTest.StartExpectingException(e: ExceptionClass);
begin
  StopExpectingException;
  FExpectedException := e;
end;
procedure TAbstractTest.StopExpectingException(msg :string);
begin
  try
    if FExpectedException <> nil then
    begin
      Fail( Format( 'Expected exception "%s" but there was none. %s',
                                        [FExpectedException.ClassName,
                                        Msg]),
                                        CallerAddr);
    end;
  finally
    FExpectedException := nil;
  end;
end;
{$IFNDEF CLR}
procedure TAbstractTest.CheckMethodIsNotEmpty(MethodPointer: pointer);
const
  AssemblerRet = $C3;
begin
  if byte(MethodPointer^) = AssemblerRet then
    Fail('Empty test', MethodPointer);
end;
{$ENDIF}
procedure TAbstractTest.CheckException(AMethod: TTestMethod; AExceptionClass: TClass; msg :string);
begin
  FCheckCalled := True;
  try
    Invoke(AMethod);
  except
    on e :Exception do
    begin
      if  not Assigned(AExceptionClass) then
        raise
      else if not e.ClassType.InheritsFrom(AExceptionClass) then
        FailNotEquals(AExceptionClass.ClassName, e.ClassName, msg, CallerAddr)
      else
        AExceptionClass := nil;
    end;
  end;
  if Assigned(AExceptionClass) then
    FailNotEquals(AExceptionClass.ClassName, 'nothing', msg, CallerAddr)
end;
procedure TAbstractTest.CheckEquals(expected, actual: TClass; msg: string);
begin
  FCheckCalled := True;
 if expected <> actual then
 begin
   if expected = nil then
     FailNotEquals('nil', actual.ClassName, msg, CallerAddr)
   else if actual = nil then
     FailNotEquals(expected.ClassName, 'nil', msg, CallerAddr)
   else
     FailNotEquals(expected.ClassName, actual.ClassName, msg, CallerAddr)
 end;
end;
procedure TAbstractTest.CheckInherits(expected, actual: TClass; msg: string);
begin
  FCheckCalled := True;
  if expected = nil then
    FailNotEquals('nil', actual.ClassName, msg, CallerAddr)
  else if actual = nil then
    FailNotEquals(expected.ClassName, 'nil', msg, CallerAddr)
  else if not actual.InheritsFrom(expected) then
    FailNotEquals(expected.ClassName, actual.ClassName, msg, CallerAddr)
end;
procedure TAbstractTest.CheckIs(AObject: TObject; AClass: TClass; msg: string);
begin
  FCheckCalled := True;
  Assert(AClass <> nil);
  if AObject = nil then
    FailNotEquals(AClass.ClassName, 'nil', msg, CallerAddr)
  else if not AObject.ClassType.InheritsFrom(AClass) then
    FailNotEquals(AClass.ClassName, AObject.ClassName, msg, CallerAddr)
end;
function TAbstractTest.GetGUIObject: TObject;
begin
  Result := FGUIObject;
end;
procedure TAbstractTest.SetGUIObject(const guiObject: TObject);
begin
  FGUIObject := guiObject;
end;
function TAbstractTest.GetFailsOnNoChecksExecuted: Boolean;
begin
  Result := FFailsOnNoChecksExecuted;
end;
procedure TAbstractTest.SetFailsOnNoChecksExecuted(const Value: Boolean);
begin
  FFailsOnNoChecksExecuted := Value;
end;
function TAbstractTest.GetFailsOnMemoryLeak: Boolean;
begin
  Result := FFailsOnMemoryLeak;
end;
procedure TAbstractTest.SetFailsOnMemoryLeak(const Value: Boolean);
begin
  FFailsOnMemoryLeak := Value;
end;
function TAbstractTest.GetTestMethodInvoked: Boolean;
begin
  Result := FTestMethodInvoked;
end;
procedure TAbstractTest.SetTestMethodInvoked(const Value: Boolean);
begin
  FTestMethodInvoked := True;
end;
function TAbstractTest.GetAllowedMemoryLeakSize: Integer;
// Array[0] reserved for property AllowedLeakSize and remainder for values entered by SetAllowedLeakArray
var
  i: Integer;
begin
  Result := FAllowedLeakList[0];
  if (result = 0) then
  begin   // The user may have set the values using SetAllowedLeakArray
    for I := 0 to Length(FAllowedLeakList) - 1 do    // Iterate
    begin
      if FAllowedLeakList[0] <> 0 then
      begin
        result := FAllowedLeakList[i];
        break;
      end;
    end;    // for
  end;
end;
procedure TAbstractTest.SetAllowedMemoryLeakSize(const NewSize: Integer);
begin
  FAllowedLeakList[0] := NewSize;
end;
function TAbstractTest.GetFailsOnMemoryRecovery: Boolean;
begin
  Result := FFailsOnMemoryRecovery;
end;
procedure TAbstractTest.SetFailsOnMemoryRecovery(const Value: Boolean);
begin
  FFailsOnMemoryRecovery := Value;
end;
procedure TAbstractTest.SetAllowedLeakArray(AllowedList: array of Integer);
var
  I: Integer;
begin // Note the 0th element is reserved for old code value.
  if Length(AllowedList) >= Length(FAllowedLeakList) then
    fail('Too many values in for AllowedLeakArray. Limit = ' +
      IntToStr(Length(FAllowedLeakList) - 1));
  for I := 1 to Length(FAllowedLeakList) - 1 do
  begin
    if I <= Length(AllowedList) then
      FAllowedLeakList[I] := AllowedList[I-1]
    else
      FAllowedLeakList[I] := 0;
  end;
end;
function  TAbstractTest.GetAllowedLeaksIterator: TListIterator;
begin
  FAllowedLeakListIndex := 0;
  result := GetAllowedLeak;
end;
function TAbstractTest.GetAllowedLeak: Integer;
begin // Auto Iterator
  if FAllowedLeakListIndex >= Length(FAllowedLeakList) then
    Result := 0
  else
  begin
    Result := FAllowedLeakList[FAllowedLeakListIndex];
    Inc(FAllowedLeakListIndex);
  end;
end;
function TAbstractTest.GetIgnoreSetUpTearDownLeaks: Boolean;
begin
  Result := FIgnoreSetUpTearDownLeaks;
end;
procedure TAbstractTest.SetIgnoreSetUpTearDownLeaks(const Value: Boolean);
begin
  FIgnoreSetUpTearDownLeaks := Value;
end;
function TAbstractTest.GetMemoryLeakIgnoredInSetupTearDown: Boolean;
begin
  Result := FMemoryLeakIgnoredInSetupTearDown;
end;
procedure TAbstractTest.SetMemoryLeakIgnoredInSetupTearDown(
  const Value: Boolean);
begin
  FMemoryLeakIgnoredInSetupTearDown := Value;
end;
{ TTestCase }
constructor TTestCase.Create(MethodName: string);
{$IFNDEF CLR}
var
  RunMethod: TMethod;
{$ENDIF}
begin
  assert(length(MethodName) >0);
{$IFNDEF CLR}
  assert(assigned(MethodAddress(MethodName)));
{$ELSE}
  assert(MethodName <> '');
{$ENDIF}
  inherited Create(MethodName);
{$IFDEF CLR}
  FMethod := MethodName;
{$ELSE}
  RunMethod.code := MethodAddress(MethodName);
  RunMethod.Data := self;
  FMethod := TTestMethod(RunMethod);
  assert(assigned(FMethod));
{$ENDIF}
end;
procedure TTestCase.Invoke(AMethod: TTestMethod);
{$IFDEF CLR}
var
  Args: array of System.Object;
{$ENDIF}
begin
  FTestMethodInvoked := True;
{$IFDEF CLR}
  Args := nil;
  try
    GetType.InvokeMember(AMethod, BindingFlags.Public or BindingFlags.Instance or BindingFlags.InvokeMethod, nil, Self, Args);
  except
    on E:TargetInvocationException do
      raise E.InnerException;
  end;
{$ELSE}
  AMethod;
{$ENDIF}
end;
procedure TTestCase.RunWithFixture(testResult: TTestResult);
begin
  assert(assigned(testResult));
  FFailsOnNoChecksExecuted := testResult.FailsIfNoChecksExecuted;
  FFailsOnMemoryLeak := testResult.FailsIfMemoryLeaked;
  FIgnoreSetUpTearDownLeaks := testResult.IgnoresMemoryLeakInSetUpTearDown;
  if testResult.ShouldRunTest(self) then
  begin
    inc(testResult.FRunTests);
    inherited;
  end;
end;
procedure TTestCase.RunTest(testResult: TTestResult);
begin
  assert(assigned(FMethod), 'Method "' + FTestName + '" not found');
  FExpectedException := nil;
  try
    try
{$IFDEF CLR}
      testResult.FMethodPtr := nil;
{$ELSE}
      CheckMethodIsNotEmpty(tMethod(FMethod).Code);
      testResult.FMethodPtr := tMethod(FMethod).Code;
{$ENDIF}
      FCheckCalled := False;
      Invoke(FMethod);
      if FFailsOnNoChecksExecuted and (not FCheckCalled) then
        Fail('No checks executed in TestCase', testResult.FMethodPtr);
      StopExpectingException;
    except
      on E: ETestFailure  do
      begin
        raise;
      end;
      on E: Exception  do
      begin
        if  not Assigned(FExpectedException) then
          raise
        else if not E.ClassType.InheritsFrom(fExpectedException) then
          FailNotEquals(fExpectedException.ClassName, E.ClassName, 'unexpected exception', ExceptAddr);
      end
    end;
  finally
    FExpectedException := nil;
  end;
end;
procedure TTestCase.Run(testResult: TTestResult);
begin
  testResult.RunSuite(self);
end;
class function TTestCase.Suite: ITestSuite;
begin
  Result := TTestSuite.Create(self);
end;
{ TTestFailure }
constructor TTestFailure.Create(FailedTest: ITest; thrownException: Exception; Addrs: Pointer; msg: string);
begin
  assert(assigned(thrownException));
  inherited Create;
  FFailedTest := FailedTest;
  FThrownExceptionClass := thrownException.ClassType;
  FThrownExceptionMessage := msg + thrownException.message;
  FThrownExceptionAddress := Addrs;
  CaptureStackTrace;
end;
constructor TTestFailure.Create(FailedTest: ITest; Addrs: Pointer; msg: string);
begin
  inherited Create;
  FFailedTest := FailedTest;
  FThrownExceptionClass := EPostTestFailure;
  FThrownExceptionMessage := msg;
  FThrownExceptionAddress := Addrs;
  FStackTrace := '';
end;
function TTestFailure.FailedTest: ITest;
begin
  Result := FFailedTest;
end;
function TTestFailure.ThrownExceptionName: string;
begin
  Result := FThrownExceptionClass.ClassName;
end;
function TTestFailure.ThrownExceptionMessage: string;
begin
  Result := FThrownExceptionMessage;
end;
function TTestFailure.ThrownExceptionAddress: pointer;
begin
  Result := FThrownExceptionAddress;
end;
function TTestFailure.ThrownExceptionClass: TClass;
begin
  Result := FThrownExceptionClass;
end;
function TTestFailure.LocationInfo: string;
begin
  Result := PointerToLocationInfo(ThrownExceptionAddress);
end;
function TTestFailure.AddressInfo: string;
begin
  Result := PointerToAddressInfo(ThrownExceptionAddress);
end;
function TTestFailure.StackTrace: string;
begin
  Result := FStackTrace;
end;
procedure TTestFailure.CaptureStackTrace;
{$IFDEF USE_JEDI_JCL}
var
  Trace :TStrings;
{$ENDIF}
begin
{$IFDEF USE_JEDI_JCL}
  Trace := TStringList.Create;
  try
    JclDebug.JclLastExceptStackListToStrings(Trace, true);
    FStackTrace := Trace.Text;
  finally
    Trace.Free;
  end;
{$ELSE}
{$IFDEF madExcept}
  FStackTrace := madStackTrace.StackTrace( false, false, false, nil,
                                           FThrownExceptionAddress, false,
                                           false, 0, 0, nil,
                                           @FThrownExceptionAddress );
{$ELSE}
  FStackTrace := '';
{$ENDIF}
{$ENDIF}
end;
{ TTestSuite }
constructor TTestSuite.Create;
begin
  Create(TObject.ClassName);
end;
constructor TTestSuite.Create(AName: string);
begin
  assert(length(AName) > 0);
  inherited Create(AName);
  FTests := TInterfaceList.Create;
end;
constructor TTestSuite.Create( testClass: TTestCaseClass);
begin
  self.Create(testClass.ClassName);
  AddTests(testClass);
end;
constructor TTestSuite.Create(AName: string; const Tests: array of ITest);
var
  i: Integer;
begin
  self.Create(AName);
  for i := Low(Tests) to High(Tests) do begin
    Self.addTest(Tests[i])
  end;
end;
procedure TTestSuite.AddTest(ATest: ITest);
begin
  Assert(Assigned(ATest));
  FTests.Add(ATest);
end;
procedure TTestSuite.AddSuite(suite: ITestSuite);
begin
  AddTest(suite);
end;
procedure TTestSuite.AddTests(testClass: TTestCaseClass);
var
  MethodIter     :  Integer;
  NameOfMethod   :  string;
  MethodEnumerator:  TMethodEnumerator;
begin
  { call on the method enumerator to get the names of the test
    cases in the testClass }
  MethodEnumerator := nil;
  try
    MethodEnumerator := TMethodEnumerator.Create(testClass);
    { make sure we add each test case  to the list of tests }
    for MethodIter := 0 to MethodEnumerator.Methodcount-1 do
      begin
        NameOfMethod := MethodEnumerator.nameOfMethod[MethodIter];
        self.addTest(testClass.Create(NameOfMethod) as ITest);
      end;
  finally
    MethodEnumerator.free;
  end;
end;
function TTestSuite.CountTestCases: integer;
var
  test: ITest;
  i: Integer;
  Total:  integer;
begin
  assert(assigned(FTests));
  Total := 0;
  for i := 0 to FTests.Count - 1 do
  begin
    test := FTests[i] as ITest;
    Total := Total + test.CountTestCases;
  end;
  Result := Total;
end;
function TTestSuite.CountEnabledTestCases: integer;
var
  i: Integer;
  test: ITest;
  Total:  Integer;
begin
  assert(assigned(FTests));
  Total := 0;
  if getEnabled then
  begin
    for i := 0 to FTests.Count - 1 do
    begin
      test := FTests[i] as ITest;
      Total := Total + test.CountEnabledTestCases;
    end;
  end;
  Result := Total;
end;
procedure TTestSuite.RunTest(testResult: TTestResult);
var
  i: Integer;
  test: ITest;
begin
  assert(assigned(testResult));
  assert(assigned(FTests));
  testResult.StartSuite(self);
  for i := 0 to FTests.Count - 1 do
  begin
    if testResult.ShouldStop then
      BREAK;
    test := FTests[i] as ITest;
    test.RunWithFixture(testResult);
  end;
  testResult.EndSuite(self);
end;
function TTestSuite.Tests: IInterfaceList;
begin
  Result := FTests;
end;
procedure TTestSuite.LoadConfiguration(const iniFile: TCustomIniFile; const section: string);
var
  i    : integer;
  LTests: IInterfaceList;
  TestSection: string;
begin
  inherited LoadConfiguration(iniFile, section);
  LTests := self.Tests;
  TestSection := section + '.' + self.GetName;
  for i := 0 to LTests.count-1 do
    (LTests[i] as ITest).LoadConfiguration(iniFile, TestSection);
end;
procedure TTestSuite.SaveConfiguration(const iniFile: TCustomIniFile; const section: string);
var
  i    : integer;
  LTests: IInterfaceList;
  TestSection: string;
begin
  inherited SaveConfiguration(iniFile, section);
  LTests := self.Tests;
  TestSection := section + '.' + self.GetName;
  for i := 0 to LTests.count-1 do
    (LTests[i] as ITest).SaveConfiguration(iniFile, TestSection);
end;
{ ETestFailure }
constructor ETestFailure.Create;
begin
   inherited Create('')
end;
constructor ETestFailure.Create(msg: string);
begin
   inherited Create(msg)
end;
{ EBreakingTestFailure }
constructor EBreakingTestFailure.Create;
begin
   inherited Create('')
end;
constructor EBreakingTestFailure.Create(msg: string);
begin
   inherited Create(msg)
end;
{ TMemIniFileTrimmed }
function TMemIniFileTrimmed.ReadString(const Section, Ident,
  DefaultStr: string): string;
begin
  // Trim the result for compatibility with TIniFile
  Result := Trim(inherited ReadString(Section, Ident, DefaultStr));
end;
{ TMethodEnumerator }
constructor TMethodEnumerator.Create(AClass: TClass);
{$IFDEF CLR}
var
  I, L: integer;
  T: System.Type;
  Methods: array of MethodInfo;
  function IsTest(AMethod: MethodInfo): Boolean;
  var
    CustomAttr: array of System.Object;
    I: integer;
  begin
    Result := false;
    if AMethod.IsPublic then
    begin
      CustomAttr := AMethod.GetCustomAttributes(false);
      for I := 0 to System.Array(CustomAttr).Length - 1 do
      begin
        if CustomAttr[I].ClassNameIs('TestAttribute') then
        begin
          Result := true;
          Break;
        end;;
      end;
    end;
  end;
{$ELSE}
type
  TMethodTable = packed record
    count: SmallInt;
  //[...methods...]
  end;
var
  table: ^TMethodTable;
  AName:  ^ShortString;
  i, j:  Integer;
{$ENDIF}
begin
  inherited Create;
{$IFDEF CLR}
  T := AClass.ClassInfo;
  Methods := T.GetMethods();
  L := 0;
  SetLength(FMethodNameList, L);
  for I := 0 to System.Array(Methods).Length - 1 do
    if IsTest(Methods[I]) then
    begin
      L := L + 1;
      SetLength(FMethodNameList, L);
      FMethodNameList[L-1] := Methods[I].Name;
    end;
{$ELSE}
  while aclass <> nil do
  begin
    // *** HACK ALERT *** !!!
    // Review System.MethodName to grok how this method works
    asm
      mov  EAX, [aclass]
      mov  EAX,[EAX].vmtMethodTable { fetch pointer to method table }
      mov  [table], EAX
    end;
    if table <> nil then
    begin
      AName  := Pointer(PChar(table) + 8);
      for i := 1 to table.count do
      begin
        // check if we've seen the method name
        j := Low(FMethodNameList);
        while (j <= High(FMethodNameList))
        and (AName^ <> FMethodNameList[j]) do
          inc(j);
        // if we've seen the name, then the method has probably been overridden
        if j > High(FMethodNameList) then
        begin
          SetLength(FMethodNameList,length(FMethodNameList)+1);
          FMethodNameList[j] := AName^;
        end;
        AName := Pointer(PChar(AName) + length(AName^) + 7)
      end;
    end;
    aclass := aclass.ClassParent;
  end;
{$ENDIF}
end;
function TMethodEnumerator.GetMethodCount: Integer;
begin
  Result := Length(FMethodNameList);
end;
function TMethodEnumerator.GetNameOfMethod(idx: integer): string;
begin
  Result := FMethodNameList[idx];
end;
{ Convenience routines }
function  TestSuite(AName: string; const Tests: array of ITest): ITestSuite;
begin
   Result := TTestSuite.Create(AName, Tests);
end;
{ test registry }
var
  __TestRegistry: ITestSuite = nil;
procedure RegisterTestInSuite(rootSuite: ITestSuite; path: string; test: ITest);
var
  pathRemainder:  string;
  suiteName:  string;
  targetSuite:  ITestSuite;
  suite:  ITestSuite;
  currentTest:  ITest;
  Tests:  IInterfaceList;
  dotPos:  Integer;
  i: Integer;
begin
  if (path = '') then
  begin
    // End any recursion
    rootSuite.addTest(test);
  end
  else
  begin
    // Split the path on the dot (.)
    dotPos := Pos('.', Path);
    if (dotPos <= 0) then dotPos := Pos('', Path);
    if (dotPos <= 0) then dotPos := Pos('/', Path);
    if (dotPos > 0) then
    begin
      suiteName := Copy(path, 1, dotPos - 1);
      pathRemainder := Copy(path, dotPos + 1, length(path) - dotPos);
    end
    else
    begin
      suiteName := path;
      pathRemainder := '';
    end;
    Tests := rootSuite.Tests;
    // Check to see if the path already exists
    targetSuite := nil;
    Tests := rootSuite.Tests;
    for i := 0 to Tests.count -1 do
    begin
      currentTest := Tests[i] as ITest;
{$IFDEF CLR}
      if Supports(currentTest, ITestSuite, suite) then
{$ELSE}
      currentTest.queryInterface(ITestSuite, suite);
      if Assigned(suite) then
{$ENDIF}
      begin
        if (currentTest.GetName = suiteName) then
        begin
          targetSuite := suite;
          break;
        end;
      end;
    end;
    if not assigned(targetSuite) then
    begin
      targetSuite := TTestSuite.Create(suiteName);
      rootSuite.addTest(targetSuite);
    end;
    RegisterTestInSuite(targetSuite, pathRemainder, test);
  end;
end;
procedure CreateRegistry;
var
  MyName :AnsiString;
begin
{$IFDEF CLR}
  MyName := ExtractFileName(ParamStr(0));
{$ELSE}
  SetLength(MyName, 1024);
  GetModuleFileName(hInstance, PChar(MyName), Length(MyName));
  MyName := Trim(PChar(MyName));
  MyName := ExtractFileName(MyName);
{$ENDIF}
  __TestRegistry := TTestSuite.Create(MyName);
end;
procedure RegisterTest(SuitePath: string; test: ITest);
begin
  assert(assigned(test));
  if __TestRegistry = nil then CreateRegistry;
  RegisterTestInSuite(__TestRegistry, SuitePath, test);
end;
procedure RegisterTest(test: ITest);
begin
  RegisterTest('', test);
end;
procedure RegisterTests(SuitePath: string; const Tests: array of ITest);
var
  i: Integer;
begin
  for i := Low(Tests) to High(Tests) do begin
    TestFramework.RegisterTest(SuitePath, Tests[i])
  end
end;
procedure RegisterTests(const Tests: array of ITest);
begin
  RegisterTests('', Tests);
end;
function RegisteredTests: ITestSuite;
begin
  Result := __TestRegistry;
end;
function RunTest(suite: ITest; listeners: array of ITestListener): TTestResult; overload;
var
  i        : Integer;
begin
  Result := TTestResult.Create;
  for i := low(listeners) to high(listeners) do
      result.addListener(listeners[i]);
  if suite <> nil then
    suite.Run(result);
end;
function RunRegisteredTests(listeners: array of ITestListener): TTestResult;
begin
  Result := RunTest(RegisteredTests, listeners);
end;
procedure ClearRegistry;
begin
  __TestRegistry := nil;
end;
initialization
{$IFDEF LINUX}
  InitPerformanceCounter;
{$ENDIF}
finalization
  ClearRegistry;
end.

						