{ This file is part of the Free Pascal run time library. Copyright (c) 2014 by Michael Van Canneyt, member of the Free Pascal development team. Complete Test unit framework relying only on system unit. 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. **********************************************************************} {$mode objfpc} // needed for exceptions {$IFDEF UNICODERTL} {$DEFINE USEUNICODE} // define this if you want to use unicode. {$ENDIF} unit punit; interface Type {$IFDEF USEUNICODE} TTestString = UnicodeString; {$ELSE} TTestString = AnsiString; {$ENDIF} {$IF NOT DECLARED(RTLString)} RTLString = TTestString; {$endif} { --------------------------------------------------------------------- Some configuration ---------------------------------------------------------------------} Var InitListLength : Integer = 10; // Initial length of test/suite lists GrowFactor : Double = 3/2; // Grow factor when list needs to be grown. DefaultSuiteName : Shortstring = 'Globals'; // Default name to use RequirePassed : Boolean = False; // If set to true, tests must explicitly call passed. DefaultDoubleDelta : Double = 1E-14; DefaultSingleDelta : Single = 1E-9; DefaultExtendedDelta : Extended = 1E-14; { --------------------------------------------------------------------- Some test structures ---------------------------------------------------------------------} Type // General status code TTestError = ( teOK, // All ok teTestsRunning, // Tests already running teRegistryEmpty, // no tests in registry teNoMemory, // Could not allocate memory teNoSuite, // No suite specified teNoSuiteName, // No suite name specified teSuiteSetupFailed, // Suite setup failed teSuiteTeardownFailed, // Suite teardown failed teDuplicateSuite, // Duplicate suite name teSuiteInactive, // Attempt to run inactive suite teNoTest, // No test specified teNoTestName, // No test name specified teDuplicateTest, // Duplicate test name specified teTestNotInSuite, // Given Test not member of given suite teTestInactive, // Attempt to run inactive test teRunStartHandler, // An error occurred during the run start handler; teRunCompleteHandler // An error occurred during the run complete handler; ); // What to do if an error occurs during test suite TErrorAction = ( eaIgnore, // Ignore errors, continue testing eaFail, // Fail current test run. eaAbort // Abort all (Halt(1)); ); // Test prototypes. Empty result inficate succes, nonempty means failure // test suite setup. TTestSetup = Function : TTestString; // test suite teardown. TTestTearDown = Function : TTestString; // test run. TTestRun = Function : TTestString; // test run procedure. TTestRunProc = Procedure; // A single test TTestOption = (toInactive); TTestOptions = Set of TTestOption; PTest = ^TTest; TTest = Record Run : TTestRun; // Function to execute when test is run. RunProc : TTestRunProc; // Procedure to execute when test is run. Run takes precedence. Name : TTestString; // Name of the test. Must not be empty. Options : TTestOptions; // True if the test is active (default). Inactive tests are not run. Data : Pointer; // Data to be associated with the test. end; TTestArray = Array of PTest; // List of tests structure. TTestList = Record Items : TTestArray; // Array of Test pointers. Can be oversized. Initialized to InitListLength Count : Integer; // Actual number of tests in list. end; PTestList = ^TTestList; // A testsuite. TSuiteOption = (soInactive,soSetupTearDownPerTest); TSuiteOptions = Set of TSuiteOption; PSuiteList = ^TSuiteList; PSuite = ^TSuite; TSuiteArray = Array of PSuite; TSuiteList = Record Items : TSuiteArray; // Array of Suite pointers. Can be oversized. Initialized to InitListLength Count : Integer; // Actual number of suites in list. end; TSuite = Record Suites : TSuiteList; // Test Suites inside this suite Tests : TTestList; // Tests in this suite Setup : TTestSetup; // Setup function, executed once at start of suite. Teardown : TTestTearDown; // Teardown function. By Default executed once at end of suite (regardless of errors) Name : TTestString; // Name of the suite, must not be empty. Options: TSuiteOptions; // True if the suite is active ( ParentSuite : PSuite; // Parent suites of this suite Data : Pointer; // Data to be associated with the suite end; TTestResult = ( trEmpty, // test didn't call any assert or didn't report error. trOK, // Test ran OK trSuiteInactive, // Suite was inactive (only on suite records) trSuiteSetupFailed, // Suite setup failed (only on suite records) trSuiteTearDownFailed, // Suite setup failed (only on suite records) trTestInactive, // test was inactive trTestIgnore, // test was ignored trAssertFailed, // An assertion failed. trTestError, // An error happened during the test (exception) trHandlerError // An error occurred during the global test hooks (exception) ); { Results are stored in a tree. At each level if the } PResultRecord = ^TResultRecord; TResultRecord = record Suite : PSuite; // Testsuite from which this is a result. If the global run handlers have an error, a result record is created with Suite=Nil. Test : PTest; // Test from which this is the result. If this is nil, then the result is the global testsuite result. ElapsedTime : Integer; // time spent in test, in milliseconds. Only calculated if time hook is set TestResult : TTestResult; // Result. TestMessage : TTestString; // Error message, if any. If an exception is expected, then the message is set PRIOR to the error. ExpectException : TClass; // Exception to expect. ParentResult, // Parent result (suite result) ChildResults, // Child result (tests or suites) NextResult : PResultRecord; // Next result at this level. end; // Statistics about a suite test run. TSuiteStats = Record Suites, // Number of sub suites (recursively) TestsFailed, // Number of failed tests. TestsInactive, // Number of inactive tests. TestsIgnored, // Number of ignored tests. TestsRun, // Number of run tests. TestsError, // Number of tests with an error. TestsUnimplemented : Integer; // Number of unimplemented tests (no result or no Assert calls) end; TRunSummary = Record SuitesRun: Integer; // Number of suites that were run. SuitesFailed : Integer; // Number of suites that failed in setup/teardown). SuitesInactive : Integer; // Number of inactive suites in the test run TestsRun : Integer; // Number of tests that were run. TestsFailed : Integer; // Number of tests that failed. TestsIgnored : Integer; // Number of tests that were ignored. TestsUnimplemented : Integer; // Number of unimplemented tests. TestsInactive : Integer; // Number of inactive tests. AssertCount : Integer; // Number of times assert was called. Results : TResultRecord; // Detailed results for all tests/suites ElapsedTime : Integer; // time spent in test run, in milliseconds; Only calculated if time hook is set end; PRunSummary = ^TRunSummary; { EFail } // This exception can be raised to exit from a test. When caught, it will mark the test as failed, and copy the message to the testresult. EFail = Class(TObject) Private FMessage : TTestString; Public Constructor Create(Const AMessage : TTestString); Function ToString : RTLString; override; end; // This exception can be raised to exit from a test. When caught, it will mark the test as ignored, and copy the message to the testresult. EIgnore = Class(EFail); { --------------------------------------------------------------------- Test Registry management ---------------------------------------------------------------------} // Initialize the testregistry. The registry is implicitly initialized by the management functions Function SetupTestRegistry : TTestError; // Clean up the testregistry. The registry is implicitly cleaned up on program exit. Function TearDownTestRegistry : TTestError; // Check if the testregistry was initialized. Function TestRegistryOK : Boolean; // Suite management // Add a suite with name AName (Required, duplicates forbidden) and Setup/TearDown functions. Returns the new suite or nil on error. Function AddSuite(Const AName : TTestString; ASetup : TTestSetup = nil; ATearDown : TTestTearDown = Nil; AParent : PSuite = nil; aPerTestSetupTearDown : Boolean = false) : PSuite; Function AddSuite(Const AName : TTestString; AParent : PSuite) : PSuite; // Number of currently registered suites. If Recurse is false, only top-level suites are counted. Function GetSuiteCount(Recurse : Boolean = True) : Integer; // Number of currently registered nested suites. If Recurse is false, only directly nested suites are counted. Function GetSuiteCount(ASuite : PSuite; Recurse : Boolean = True) : Integer; // Return the 0-based index of the suite names AName (case sensitive). -1 if not found. Function GetSuiteIndex(Const AName : TTestString) : Integer; // Return the 0-based index of the nested suite names AName (case sensitive). -1 if not found. Function GetSuiteIndex(ASuite : PSuite; Const AName : TTestString) : Integer; // Return the suite at position AIndex. Nil on error. Function GetSuite(Const AIndex : Integer) : PSuite;overload; // Return the suite named AName, starting at AParent. Nil if it is not found. Suite can be named Suite1.Sub2.Sub3 Function GetSuite(Const AName : TTestString; AParent : PSuite = Nil) : PSuite;overload; // Test management // Register a test with name ATestName in suite ASuiteName. The test function is ARun. // If Suitename is empty, DefaultSuiteName is used, and registered if it does not exist yet. // Returns the newly created test. // It is allowed to register the same function with different names Function AddTest(Const ATestName : TTestString; ARun : TTestRun; Const ASuiteName : TTestString = '') : PTest; Function AddTest(Const ATestName : TTestString; ARun : TTestRunProc; Const ASuiteName : TTestString = '') : PTest; // Same as above, only the suite is explitly given. It may not be nil. Function AddTest(Const ATestName : TTestString; ARUn : TTestRun; Const ASuite : PSuite) : PTest; Function AddTest(Const ATestName : TTestString; ARUn : TTestRunProc; Const ASuite : PSuite) : PTest; // Return the 0-Based index of ATestName in suite ASuitename. Returns -1 on error or if nor found. Function GetTestIndex(Const ASuiteName : TTestString; Const ATestName : TTestString) : Integer; // Return the 0-Based index of ATestName in suite ASuit. Returns -1 on error or if nor found. Function GetTestIndex(Const ASuite : PSuite; Const ATestName : TTestString) : Integer; // Return 0-Based index of ATest in ASuite. Returns -1 if not found or on error. Function GetTestIndex(Const ASuite : PSuite; Const ATest : PTest) : Integer; // Return the number of tests in testsuite. On Error -1 is returned. Function GetTestCount(Const ASuiteName : TTestString) : Integer; // Return the number of tests in testsuite. On Error -1 is returned. Function GetTestCount(Const ASuite : PSuite) : Integer; // Return the test named ATestName in ASuiteName. Returns Nil if not found. Function GetTest(Const ASuiteName : TTestString; Const ATestName : TTestString) : PTest; // Return the test named ATestName in ASuite. Returns Nil if not found. Function GetTest(Const ASuite : PSuite; Const ATestName : TTestString) : PTest; // Return the test with index ATestindex in ASuite. Returns Nil if not found. Function GetTest(Const ASuite : PSuite; Const ATestIndex : Integer) : PTest; // Return True if ATest is part of ASuite. False otherwise or on error. Function TestIsInSuite(Const ASuite : PSuite; Const ATest : PTest) : Boolean; { --------------------------------------------------------------------- Running tests ---------------------------------------------------------------------} // The following are always complete test runs. // Results from previous runs are cleared when one of these functions is called. // Run all tests. Returns teOK if all tests were run without problems (failure is not a problem) Function RunAllTests : TTestError; // Run suite AName from the testsuite. Results can be viewed in GetCurrentRun. Function RunSuite(Const ASuiteName : TTestString) : TTestError; // Run suite ASuiteIndex in the testsuite. Results can be viewed in GetCurrentRun. Function RunSuite(ASuiteIndex : Integer) : TTestError; // Run suite ASuite (need not be registeredà. Results can be viewed in GetCurrentRun. Function RunSuite(ASuite : PSuite) : TTestError; // Running a test // Run test ATestName from Suite ASuiteName in the testsuite. Results can be viewed in GetCurrentRun. Function RunTest(Const ASuiteName : TTestString; Const ATestName: TTestString) : TTestError; // Run test ATestName from Suite ASuite. ASuite need not be registered. Results can be viewed in GetCurrentRun. Function RunTest(ASuite : PSuite; Const ATestName : TTestString) : TTestError; // Run test ATest from Suite ASuite. ASuite need not be registered. Results can be viewed in GetCurrentRun. Function RunTest(ASuite : PSuite; ATest : PTest) : TTestError; // Special function: will register a default test and runs all tests. // Intended for fast test suite creation and execution. // It will halt the program with the exit codes of RunAllSysTests // Additionally, an exit code of 2 may result if there was no test // Doing this will disable -t and -s command-line options.. Procedure RunTest(ARun : TTestRun); // Get run summary of the current test run. Remains available after run is finished, before a new run is started. Function GetCurrentRun : TRunSummary; // Get currently running suite, may be nil. Function GetCurrentSuite : PSuite; // Get currently running test, may be nil. Function GetCurrentTest : PTest; // Get currently test result record, may be nil. Function GetCurrentResult : PResultRecord; // Get result stats for a suite result record. Procedure GetSuiteStats(AResults : PResultRecord; Out Stats : TSuiteStats); { --------------------------------------------------------------------- Test Result management ---------------------------------------------------------------------} Function CountResults(Results : PResultRecord) : Integer; { --------------------------------------------------------------------- Assertions ---------------------------------------------------------------------} // Mark test as ignored with given message. Always returns false. Function Ignore(Const Msg : TTestString) : Boolean; // Mark test as failed with given message. Function Fail(Const Msg : TTestString) : Boolean; // Mark test as failed with given message, raising EFail. // will not return, but for symmetry has the same call signature Function FailExit(Const Msg : TTestString) : Boolean; // Mark test as ignored with given message, raising EIgnore. // will not return, but for symmetry has the same call signature Function IgnoreExit(Const Msg : TTestString) : Boolean; // If RequirePassed = True, then this must be called to mark a test as passed. // Otherwise it is marked 'unimplemented' if assert was never called during execution of the test. Function AssertPassed (AMessage : TTestString=''): Boolean; // Mark test as passed if ACondition = true, failed if False. Returns ACondition Function AssertTrue(const AMessage : TTestString; ACondition : Boolean): Boolean; // Mark test as passed if ACondition = false, failed if true. Returns Not ACondition Function AssertFalse(const AMessage : TTestString; ACondition : Boolean): Boolean; // Check if 2 strings are equal. Mark test as failed if not. Function AssertEquals(AMessage : TTestString; const AExpected, AActual : ShortString): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected, AActual : AnsiString): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected, AActual : UTF8String): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected, AActual : UnicodeString): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected: Char; AActual : UnicodeString): Boolean; // Check if 2 ordinals are equal. Mark test as failed if not. Function AssertEquals(AMessage : TTestString; const AExpected, AActual : Boolean): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected, AActual : Shortint): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected, AActual : Byte): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected, AActual : Smallint): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected, AActual : Word): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected, AActual : Longint): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected, AActual : Cardinal): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected, AActual : Int64): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected, AActual : QWord): Boolean; // Floating point types Function AssertEquals(AMessage : TTestString; const AExpected, AActual : Currency): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected, AActual: Double; ADelta : Double = 0): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected, AActual: Single; ADelta : Single = 0): Boolean; Function AssertEquals(AMessage : TTestString; const AExpected, AActual: Extended; ADelta : Extended = 0): Boolean; // Assert null Function AssertNull(AMessage : TTestString; const AValue : Pointer): Boolean; Function AssertNotNull(AMessage : TTestString; const AValue : Pointer): Boolean; // Check if 2 pointers are equal. Mark test as failed if not. Function AssertEquals(AMessage : TTestString; const AExpected, AActual : Pointer): Boolean; Function AssertDiffers(AMessage : TTestString; const AExpected, AActual : Pointer): Boolean; // Check if 2 class types are equal. Mark test as failed if not. Function AssertEquals(AMessage : TTestString; const AExpected, AActual : TClass): Boolean; // Check if 2 class types are equal. Mark test as failed if not. Function AssertInheritsFrom(AMessage : TTestString; const AChild, AParent : TObject): Boolean; Function AssertInheritsFrom(AMessage : TTestString; const AChild, AParent : TClass): Boolean; // Check if 2 object instances are equal. Mark test as failed if not. Function AssertSame(AMessage : TTestString; const AExpected, AActual : TObject): Boolean; // Check if 2 object instances are different. Mark test as failed if they are equal. Function AssertNotSame(AMessage : TTestString; const AExpected, AActual : TObject): Boolean; // Run procedure ARun. Expect an exception. If none is raised, or the class differs, mark the test as failed. Function AssertException(const AMessage: string; AExceptionClass: TClass; ARun: TProcedure) : boolean; Function AssertException(const AMessage: string; AExceptionClass: TClass; ARun: TTestRun) : boolean; // Tell the testsuite that the test will raise an exception of class ACLass. // If the test does not raise an exception, or the exception class differs, the test is marked as failed. Function ExpectException(AMessage : TTestString; AClass : TClass) : Boolean; { --------------------------------------------------------------------- Test Hooks (Decorators) ---------------------------------------------------------------------} Type // All arguments must be considered read-only. // Test Run hooks. // Handler called at the start of a testrun. Suites is an array of suites that will be run. TRunStartHandler = Procedure(Const Suites : TSuiteArray); // Handler called at the completion of a testrun. ARunResult is the run summary. TRunCompleteHandler = Procedure(Const ARunResult : TRunSummary); // Test suite hooks. // Handler called at the start of a suite, before suite setup. ASuite is the result. TSuiteStartHandler = Procedure(ASuite : PSuite); // Handler called at the end of a suite, after suite teardown. SuiteResults is an array of test results. The first record is a global suite result. TSuiteCompleteHandler = Procedure(ASuite : PSuite; Const SuiteResults : PResultRecord); // Handler called if the suite setup function failed (non-empty string returned or exception) TSuiteSetupFailureHandler = Procedure(ASuite : PSuite; Const AError : TTestString); // Handler called if the suite teardown function failed.(non-empty string returned or exception) TSuiteTearDownFailureHandler = Procedure(ASuite : PSuite; Const AError : TTestString); // Test hooks. // Handler called at the start of a test run. TTestStartHandler = Procedure(ATest : PTest; ASuite : PSuite); // Handler called at the end of a test run (regardless of pass/fail); TTestCompleteHandler = Procedure(ATest: PTest; ASuite : PSuite; Const TestResult : PResultRecord); // Other hooks // The sysutils or dos unit are not available to get the time. Support for getting time // can be enabled by including a function with the correct signature. For example: // using sysutils: SetTimeHook(@SysUtils.Now); TTimeHook = Function : TDateTime; // These functions set the various hooks. The old value is returned, so hooks can be chained. Function SetRunStartHandler(AHandler : TRunStartHandler) : TRunStartHandler; Function SetRunCompleteHandler(AHandler : TRunCompleteHandler) : TRunCompleteHandler; Function SetSuiteStartHandler(AHandler : TSuiteStartHandler) : TSuiteStartHandler; Function SetSuiteCompleteHandler(AHandler : TSuiteCompleteHandler) : TSuiteCompleteHandler; Function SetSuitesetupFailureHandler(AHandler : TSuitesetupFailureHandler) : TSuitesetupFailureHandler; Function SetSuiteTearDownFailureHandler(AHandler : TSuiteTearDownFailureHandler) : TSuiteTearDownFailureHandler; Function SetTestStartHandler(AHandler : TTestStartHandler) : TTestStartHandler; Function SetTestCompleteHandler(AHandler : TTestCompleteHandler) : TTestCompleteHandler; // These functions get the current value of the various hooks. Function GetSuiteStartHandler : TSuiteStartHandler; Function GetTestStartHandler : TTestStartHandler; Function GetTestCompleteHandler : TTestCompleteHandler; Function GetSuiteCompleteHandler : TSuiteCompleteHandler; Function GetRunStartHandler : TRunStartHandler; Function GetRunCompleteHandler : TRunCompleteHandler; Function GetSuitesetupFailureHandler : TSuitesetupFailureHandler; Function GetSuiteTearDownFailureHandler : TSuiteTearDownFailureHandler; // Clear all handlers Procedure ClearTestHooks; // Time hook management: Function GetTimeHook : TTimeHook; Function SetTimeHook(AHook : TTimeHook) : TTimeHook; // Is the time hook set ? Function HaveTimeHook : Boolean; inline; // Current time as returned by hook, or 0 if hook not set. Function GetTimeFromHook : TDateTime; // Timespan in milliseconds between Current time as returned by hook and From. 0 if hook not set. Function GetTimeDiff(From : TDateTime) : Integer; // Convert timespan in milliseconds to human readable string hh:nn:ss.ZZZ (z milliseconds) Function SysTimeString(MSec : Integer) : TTestString; { --------------------------------------------------------------------- Errors ---------------------------------------------------------------------} // Get the current error status. Function GetTestError : TTestError; // Get a message corresponding to the error. Function GetTestErrorMessage : TTestString; // Set test error. If the current is not teOK, it cannot be overwritten except by teOK. Function SetTestError(AError : TTestError) : TTestError; // What to do if a non-teOK value is set ? Function GetErrorAction : TErrorAction; // Set the error action, returns the old value. Function SetErrorAction(AError : TErrorAction) : TErrorAction; // System hooks Type // Verbosity of system hooks TSysRunVerbosity = ( rvQuiet, // No messages at all rvFailures, // only output failures rvNormal, // normal messages rvVerbose // Lots of messages ); // Setup system hooks. Called by unit initialization. Procedure SetupSysHandlers; // Teardown system hooks. Called by unit finalization. Procedure TearDownSysHandlers; // Get current run mode. Function GetSysRunVerbosity: TSysRunVerbosity; /// Set currentsystem run mode Function SetSysRunVerbosity(AMode : TSysRunVerbosity) : TSysRunVerbosity; // Set system hook variables based on commandline. // -v --verbose: verbose messaging // -f --failures: only output failures // -q --quiet: no messaging // -n --normal: no messaging // -o --output=Name: write to named file. // -s --suite=Suite: name of suite to run // -t --test=name of test to run. If no suite is specified, DefaultSuiteName is assumed. // -l --list simply list all tests. // -h --help show help Procedure ProcessSysCommandline; // Process command line, run tests based on variables set. // Program exit codes: // 0 : All tests completed succesfully // 1 : tests completed with failures. // 3 : Suite not found (-s --suite) // 4 : Testsuite didn't run correct. // 6 : Test not found (-t --test) Procedure RunAllSysTests; // Return the OS for which the system was compiled, as a lowercase string. // This can help when registering tests. Function GetSysTestOS : TTestString; // Get test setting. The settings file is by default a file called punit.cfg // Format is Name = Value. Comment lines start with ; or # Function SysGetSetting(Const AName : TTestString) : TTestString; implementation Const SExpected = 'Expected'; SActual = 'Actual'; SErrNoTestProcedure = 'No test procedure'; // SIsNotNil = 'Is not nil'; // SIsNil = 'Is nil'; Var CurrentError : TTestError; CurrentErrorAction : TErrorAction; CurrentTimeHook : TTimeHook; TestRegistry : TSuiteList; GlobalSuiteStartHandler : TSuiteStartHandler; GlobalTestStartHandler : TTestStartHandler; GlobalTestCompleteHandler : TTestCompleteHandler; GlobalSuiteCompleteHandler : TSuiteCompleteHandler; GlobalRunStartHandler : TRunStartHandler; GlobalRunCompleteHandler : TRunCompleteHandler; GlobalSuitesetupFailureHandler : TSuitesetupFailureHandler; GlobalSuiteTearDownFailureHandler : TSuiteTearDownFailureHandler; CurrentSuite : PSuite; CurrentTest : PTest; CurrentRun : TRunSummary; CurrentSuiteResult, CurrentResult : PResultRecord; { --------------------------------------------------------------------- Handler management ---------------------------------------------------------------------} function GetTimeHook: TTimeHook; begin Result:=CurrentTimeHook; end; function SetTimeHook(AHook: TTimeHook): TTimeHook; begin Result:=CurrentTimeHook; CurrentTimeHook:=AHook; end; function HaveTimeHook: Boolean; begin Result:=Assigned(CurrentTimeHook); end; function GetTimeFromHook: TDateTime; begin if HaveTimeHook then Result:=CurrentTimeHook() else Result:=0; end; function GetTimeDiff(From: TDateTime): Integer; const // Copied from sysutils; HoursPerDay = 24; MinsPerHour = 60; SecsPerMin = 60; MSecsPerSec = 1000; MinsPerDay = HoursPerDay * MinsPerHour; SecsPerDay = MinsPerDay * SecsPerMin; MSecsPerDay = SecsPerDay * MSecsPerSec; Var T : TDateTime; begin T:=GetTimeFromHook; if (T=0) or (From=0) then Result:=0 else Result:=Round((T-From)*MSecsPerDay); end; function SetSuiteStartHandler(AHandler: TSuiteStartHandler): TSuiteStartHandler; begin Result:=GlobalSuiteStartHandler; GlobalSuiteStartHandler:=AHandler; end; function SetTestStartHandler(AHandler: TTestStartHandler): TTestStartHandler; begin Result:=GlobalTestStartHandler; GlobalTestStartHandler:=AHandler; end; function SetTestCompleteHandler(AHandler: TTestCompleteHandler ): TTestCompleteHandler; begin Result:=GlobalTestCompleteHandler; GlobalTestCompleteHandler:=AHandler; end; function SetSuiteCompleteHandler(AHandler: TSuiteCompleteHandler ): TSuiteCompleteHandler; begin Result:=GlobalSuiteCompleteHandler; GlobalSuiteCompleteHandler:=AHandler; end; function SetRunCompleteHandler(AHandler: TRunCompleteHandler ): TRunCompleteHandler; begin Result:=GlobalRunCompleteHandler; GlobalRunCompleteHandler:=AHandler; end; function SetRunStartHandler(AHandler: TRunStartHandler): TRunStartHandler; begin Result:=GlobalRunStartHandler; GlobalRunStartHandler:=AHandler; end; function SetSuitesetupFailureHandler(AHandler: TSuitesetupFailureHandler ): TSuitesetupFailureHandler; begin Result:=GlobalSuitesetupFailureHandler; GlobalSuitesetupFailureHandler:=AHandler; end; function SetSuiteTearDownFailureHandler(AHandler: TSuiteTearDownFailureHandler ): TSuiteTearDownFailureHandler; begin Result:=GlobalSuiteTearDownFailureHandler; GlobalSuiteTearDownFailureHandler:=AHandler; end; function GetSuiteStartHandler: TSuiteStartHandler; begin Result:=GlobalSuiteStartHandler; end; function GetTestStartHandler: TTestStartHandler; begin Result:=GlobalTestStartHandler; end; function GetTestCompleteHandler: TTestCompleteHandler; begin Result:=GlobalTestCompleteHandler; end; function GetSuiteCompleteHandler: TSuiteCompleteHandler; begin Result:=GlobalSuiteCompleteHandler; end; function GetRunStartHandler: TRunStartHandler; begin Result:=GlobalRunStartHandler; end; function GetRunCompleteHandler: TRunCompleteHandler; begin Result:=GlobalRunCompleteHandler; end; function GetSuitesetupFailureHandler: TSuitesetupFailureHandler; begin Result:=GlobalSuiteSetupFailureHandler; end; function GetSuiteTearDownFailureHandler: TSuiteTearDownFailureHandler; begin Result:=GlobalSuiteTearDownFailureHandler; end; procedure ClearTestHooks; begin SetSuiteStartHandler(Nil); SetTestStartHandler(Nil); SetTestCompleteHandler(Nil); SetSuiteCompleteHandler(Nil); SetRunStartHandler(Nil); SetRunCompleteHandler(Nil); SetSuiteSetupFailureHandler(Nil); SetSuiteTearDownFailureHandler(Nil); end; { --------------------------------------------------------------------- Error management ---------------------------------------------------------------------} Const SErrUnknown = 'Unknown error'; SErrOK = 'OK'; SErrTestsRunning = 'Tests already running'; SErrRegistryEmpty = 'Testregistry emmpty'; SErrNoMemory = 'No memory available'; SErrNoSuite = 'No suite available'; SErrNoSuiteName = 'No suite name specified'; SErrSuiteSetupFailed = 'Suite setup failed'; SerrSuiteTeardownFailed = 'Suite teardown failed'; SErrDuplicateSuite = 'Duplicate suite name'; SErrSuiteInactive = 'Attempt to run inactive suite'; SErrNoTest = 'No test specified'; SErrNoTestName = 'No test name specified'; SErrDuplicateTest = 'Duplicate test name specified'; SErrTestNotInSuite = 'Test not member of suite'; SErrTestInactive = 'Attempt to run inactive test'; function GetTestError: TTestError; begin Result:=CurrentError; end; function GetTestErrorMessage: TTestString; begin Case GetTestError of teOK: Result:=SErrOK; teTestsRunning: Result:=SErrTestsRunning; teRegistryEmpty: Result:=SErrRegistryEmpty; teNoMemory: Result:=SErrNoMemory; teNoSuite: Result:=SErrNoSuite; teNoSuiteName: Result:=SErrNoSuiteName; teSuiteSetupFailed: Result:=SErrSuiteSetupFailed; teSuiteTeardownFailed: Result:=SErrSuiteTeardownFailed; teDuplicateSuite: Result:=SErrDuplicateSuite; teSuiteInactive: Result:=SErrSuiteInactive; teNoTest: Result:=SErrNoTest; teNoTestName: Result:=SErrNoTestName; teDuplicateTest: Result:=SErrDuplicateTest; teTestNotInSuite: Result:=SErrTestNotInSuite; teTestInactive: Result:=SErrTestInactive; else Result:=SErrUnknown; end; end; function SetTestError(AError: TTestError): TTestError; begin // Forces us to reset the error at all points if (AError=teOK) or (CurrentError=teOK) then CurrentError:=AError; Result:=CurrentError; If (AError<>teOK) and (CurrentErrorAction=eaAbort) then Halt(1); end; Function CombineError(Original, Additional : TTestError) : TTestError; begin if (teOK=Original) then Result:=Additional else Result:=Original; end; function GetErrorAction: TErrorAction; begin Result:=CurrentErrorAction; end; function SetErrorAction(AError: TErrorAction): TErrorAction; begin Result:=CurrentErrorAction; CurrentErrorAction:=AError; end; { --------------------------------------------------------------------- List management. ---------------------------------------------------------------------} Procedure CheckGrowSuiteList(AList : PSuiteList); Var L : Integer; begin L:=Length(AList^.Items); if (AList^.Count=L) then begin if (L=0) then L:=InitListLength else L:=Round(L*3/2); SetLength(AList^.Items,L); end; end; Procedure DoneSuiteList(Var Suites : TSuiteList); forward; Function DoneSuite(ASuite : PSuite) : TTestError; Var I : Integer; begin SetTestError(teOK); With ASuite^ do begin DoneSuiteList(Suites); For I:=0 to Tests.Count-1 do Dispose(Tests.Items[i]); SetLength(Tests.Items,0); Tests.Count:=0; end; Dispose(ASuite); Result:=GetTestError; end; Procedure DoneSuiteList(Var Suites : TSuiteList); Var I : Integer; begin For I:=0 to Suites.Count-1 do DoneSuite(Suites.Items[i]); SetLength(Suites.Items,0); Suites.Count:=0; end; Procedure CheckGrowTests(Var AList : TTestList); Var L : Integer; begin L:=Length(AList.Items); if (L=AList.Count) then begin if L=0 then L:=InitListLength else L:=Round(L*GrowFactor); SetLength(AList.Items,L); end; end; { --------------------------------------------------------------------- Testsuite Registry management ---------------------------------------------------------------------} function TestRegistryOK: Boolean; begin Result:=Length(TestRegistry.Items)<>0; end; Procedure InitSuiteList(Var Suites: TSuiteList); begin Suites.Count:=0; CheckGrowSuiteList(@Suites); end; Procedure DoSetupTestRegistry; begin if TestRegistry.Count<>0 then exit; InitSuiteList(TestRegistry); end; function SetupTestRegistry: TTestError; begin Result:=SetTestError(teOK); Result:=TearDownTestRegistry; if Result=teOK then DoSetupTestRegistry; end; function TearDownTestRegistry: TTestError; begin SetTestError(teOK); DoneSuiteList(TestRegistry); Result:=GetTestError; end; { --------------------------------------------------------------------- Suite management ---------------------------------------------------------------------} Function CheckInactive : Boolean; begin Result:=(CurrentSuite=Nil); If Not Result then SetTestError(teTestsRunning); end; function AddSuite(const AName: TTestString; AParent: PSuite): PSuite; begin Result:=AddSuite(AName,Nil,Nil,AParent); end; function GetSuiteCount(ASuite: PSuiteList; Recurse: Boolean): Integer; Var I : Integer; begin Result:=ASuite^.Count; if Recurse then For I:=0 to ASuite^.Count-1 do Result:=Result+GetSuiteCount(ASuite^.Items[i],True); end; function GetSuiteCount(Recurse: Boolean): Integer; begin Result:=GetSuiteCount(PsuiteList(@TestRegistry),Recurse); end; Function GetSuiteCount(ASuite : PSuite; Recurse : Boolean = True) : Integer; begin if (ASuite=Nil) then Result:=0 else Result:=GetSuiteCount(PSuiteList(@ASuite^.Suites),Recurse); end; Function GetSuiteIndex(Const AList : PSuiteList; Const AName: TTestString): Integer; begin Result:=-1; if (AList=Nil) then begin SetTestError(teNoSuite); Exit; end; SetTestError(teOK); Result:=AList^.Count-1; While (Result>=0) and (AList^.Items[Result]^.Name<>AName) do Dec(Result); end; function GetSuiteIndex(ASuite : PSuite; const AName: TTestString): Integer; begin if ASuite=Nil then Result:=0 else Result:=GetSuiteIndex(PSuiteList(@ASuite^.Suites),AName); end; function GetSuiteIndex(const AName: TTestString): Integer; begin Result:=GetSuiteIndex(PSuiteList(@TestRegistry),AName); end; Function GetSuite(const AList : PSuiteList; Const AIndex: Integer): PSuite; begin If (AIndex>=0) And (AIndex0) then begin Result:=GetSuite(L,Copy(N,1,P-1)); if (Result<>Nil) then L:=@Result^.Suites else L:=Nil; Delete(N,1,P); end; I:=GetSuiteIndex(L,N); If I<0 then Result:=Nil else Result:=L^.Items[I]; end; end; Function GetSuite(Const AName : TTestString; AParent : PSuite = Nil) : PSuite; Var L : PSuiteList; begin Result:=Nil; if (AParent<>Nil) then L:=@AParent^.Suites else L:=@TestRegistry; if L<>Nil then Result:=GetSuite(L,AName); end; function GetSuite(const AIndex: Integer): PSuite; begin Result:=GetSuite(@TestRegistry,AIndex); end; function AddSuite(const AName: TTestString; ASetup: TTestSetup; ATearDown: TTestTearDown; AParent: PSuite; aPerTestSetupTearDown : Boolean = false): PSuite; Var S : PSuite; L : PSuiteList; begin Result:=Nil; SetTestError(teOK); If not CheckInactive then exit; DoSetupTestRegistry; if AName='' then begin SetTestError(teNoSuiteName); Exit; end; S:=GetSuite(AName,AParent); if (S<>Nil) then begin SetTestError(teDuplicateSuite); Exit; end; if AParent<>Nil then L:=@AParent^.Suites else L:=@TestRegistry; CheckGrowSuiteList(L); New(Result); if (Result=Nil) then SetTestError(teNoMemory) else begin L^.Items[L^.Count]:=Result; FillChar(Result^,Sizeof(TSuite),0); Result^.Name:=AName; Result^.Setup:=ASetup; Result^.Teardown:=ATearDown; Result^.Options:=[]; if aPerTestSetupTearDown then Include(Result^.Options,soSetupTearDownPerTest); Result^.Tests.Count:=0; Result^.ParentSuite:=AParent; CheckGrowTests(Result^.Tests); Inc(L^.Count); end; end; { --------------------------------------------------------------------- Test management ---------------------------------------------------------------------} function DoAddTest(const ATestName: TTestString; const ASuite: PSuite): PTest; Var I : Integer; List : PTestList; begin Result:=Nil; SetTestError(teOK); if not CheckInactive then Exit; if (ASuite=Nil) then SetTestError(teNoSuite) else If (ATestName='') then SetTestError(teNoTestName) else begin I:=GetTestIndex(ASuite,ATestName); if (I<>-1) then SetTestError(teDuplicateTest) else begin List:=@ASuite^.Tests; CheckGrowTests(List^); New(Result); if (Result=Nil) then SetTestError(teNoMemory) else begin FillChar(Result^,SizeOf(TTest),0); Result^.Name:=ATestName; Result^.Options:=[]; List^.Items[List^.Count]:=Result; Inc(List^.Count); end; end; end; end; function AddTest(const ATestName: TTestString; ARun: TTestRun; const ASuite: PSuite): PTest; begin Result:=DoAddTest(aTestName,aSuite); if assigned(Result) then Result^.Run:=ARun; end; function AddTest(const ATestName: TTestString; ARun: TTestRunProc; const ASuite: PSuite): PTest; begin Result:=DoAddTest(aTestName,aSuite); if assigned(Result) then Result^.RunProc:=ARun; end; // Easy access function function EnsureSuite(aSuiteName : TTestString) : PSuite; var SN : TTestString; begin SetTestError(teOK); SN:=ASuiteName; if (SN='') then SN:=DefaultSuiteName; Result:=GetSuite(SN); if (Result=Nil) and (ASuiteName<>'') then SetTestError(teNoSuite) else begin If (Result=Nil) then Result:=AddSuite(SN,Nil,Nil); end; end; function AddTest(const ATestName: TTestString; ARun: TTestRun; const ASuiteName: TTestString): PTest; Var S : PSuite; begin Result:=Nil; S:=EnsureSuite(aSuiteName); If (S<>Nil) then Result:=AddTest(ATestName,ARun,S); end; Function AddTest(Const ATestName : TTestString; ARun : TTestRunProc; Const ASuiteName : TTestString = '') : PTest; Var S : PSuite; begin Result:=Nil; S:=EnsureSuite(aSuiteName); If (S<>Nil) then Result:=AddTest(ATestName,ARun,S); end; Function GetTestIndex(Const ASuiteIndex: Integer; Const ATestName: TTestString): Integer; begin Result:=GetTestIndex(GetSuite(ASuiteIndex),ATestName); end; function GetTestIndex(const ASuiteName: TTestString; const ATestName: TTestString): Integer; begin Result:=GetTestIndex(GetSuite(ASuiteName),ATestName); end; function GetTestIndex(const ASuite: PSuite; const ATestName: TTestString ): Integer; Var A : TTestArray; begin Result:=-1; SetTestError(teOK); if (ASuite=Nil) then SetTestError(teNoSuite) else begin Result:=ASuite^.Tests.Count-1; A:=ASuite^.Tests.Items; While (Result>=0) and (A[Result]^.Name<>ATestName) do Dec(Result); end; end; Function GetTest(Const ASuiteIndex: Integer; Const ATestName: TTestString ): PTest; begin Result:=GetTest(GetSuite(ASuiteIndex),ATestName); end; function GetTestCount(const ASuiteName: TTestString): Integer; begin Result:=GetTestCount(GetSuite(ASuiteName)); end; function GetTestCount(const ASuite: PSuite): Integer; begin SetTestError(teOK); Result:=-1; if (ASuite=Nil) then SetTestError(teNoSuite) else Result:=ASuite^.Tests.Count; end; function GetTest(const ASuiteName: TTestString; const ATestName: TTestString ): PTest; begin Result:=GetTest(GetSuite(ASuiteName),ATestName); end; function GetTest(const ASuite: PSuite; const ATestName: TTestString): PTest; Var I,P : Integer; N : TTestString; S : PSuite; begin N:=ATestName; S:=ASuite; P:=0; For I:=1 to Length(N) do if ATestName[I]='.' then P:=i; If (P>0) then begin S:=GetSuite(Copy(N,1,P-1),S); Delete(N,1,P); end; if (S=Nil) then begin SetTestError(teNoSuite); Exit; end; I:=GetTestIndex(S,N); If (I=-1) then Result:=Nil else Result:=S^.Tests.items[i]; end; function GetTest(const ASuite: PSuite; const ATestIndex: Integer): PTest; begin SetTestError(teOK); Result:=Nil; if (ASuite=Nil) then SetTestError(teNoSuite) else If (ATestIndex>=0) and (ATestIndex=0) and (ATest<>T[Result]) do Dec(Result); end; end; function TestIsInSuite(const ASuite: PSuite; const ATest: PTest): Boolean; begin Result:=GetTestIndex(ASuite,ATest)<>-1; end; { --------------------------------------------------------------------- Test result management ---------------------------------------------------------------------} Procedure SetTestResult(Var AResult : TResultRecord; AResultType : TTestResult; AMessage : TTestString; Force : Boolean = False); Var Prev : TTestResult; begin if Not ((AResult.TestResult=trEmpty) or Force) then Exit; Prev:=AResult.TestResult; AResult.TestResult:=AResultType; AResult.TestMessage:=AMessage; // Only increas in case of switch from non-error -> error if (Prev In [trEmpty,trOK]) and not (AResult.TestResult In [trEmpty,trOK]) And (AResult.Test<>Nil) then if AResult.TestResult=trTestIgnore then Inc(CurrentRun.TestsIgnored) else Inc(CurrentRun.TestsFailed); end; Procedure SetTestResult(AResultType : TTestResult; AMessage : TTestString; Force : Boolean = False); begin if Assigned(CurrentResult) then SetTestResult(CurrentResult^,AResultType,AMessage,Force); end; Function DoAssert(AResult : Boolean; ACondition : TTestString) : Boolean; begin Inc(CurrentRun.AssertCount); Result:=AResult; if (Not Result) and (Assigned(CurrentResult)) then SetTestResult(CurrentResult^,trAssertFailed,ACondition); end; function CountResults(Results: PResultRecord): Integer; begin Result:=0; While Results<>Nil do begin Inc(Result); Results:=Results^.NextResult; end; end; function Ignore(const Msg: TTestString): Boolean; begin SetTestResult(CurrentResult^,trTestIgnore,Msg); Result:=False; end; function Fail(const Msg: TTestString): Boolean; begin Result:=DoAssert(False,Msg); end; function FailExit(const Msg: TTestString): Boolean; begin Result:=False; Raise EFail.Create(Msg); end; function IgnoreExit(const Msg: TTestString): Boolean; begin Result:=False; Raise EIgnore.Create(Msg); end; function AssertPassed(AMessage: TTestString): Boolean; begin Result:=DoAssert(True,''); if Assigned(CurrentResult) then SetTestResult(CurrentResult^,trOK,AMessage); end; function AssertTrue(const AMessage: TTestString; ACondition: Boolean): Boolean; begin DoAssert(ACondition,AMessage); Result:=ACondition; end; Function ExpectMessage(AExpect,AActual : ShortString; Quote : Boolean = False) : ShortString; begin if Quote then begin AExpect:='"'+AExpect+'"'; AActual:='"'+AActual+'"'; end; Result:=SExpected+': '+AExpect+' '+SActual+': '+AActual; end; Function ExpectMessage(AExpect,AActual : AnsiString; Quote : Boolean = False) : AnsiString; begin if Quote then begin AExpect:='"'+AExpect+'"'; AActual:='"'+AActual+'"'; end; Result:=SExpected+': '+AExpect+' '+SActual+': '+AActual; end; Function ExpectMessage(AExpect,AActual : UnicodeString; Quote : Boolean = False) : UnicodeString; begin if Quote then begin AExpect:='"'+AExpect+'"'; AActual:='"'+AActual+'"'; end; Result:=SExpected+': '+AExpect+' '+SActual+': '+AActual; end; Function ExpectMessage(AExpect,AActual : UTF8String; Quote : Boolean = False) : UTF8String; begin Result:=UTF8Encode(ExpectMessage(UTF8Decode(aExpect),UTF8Decode(aActual),Quote)) end; function AssertFalse(const AMessage: TTestString; ACondition: Boolean): Boolean; begin Result:=AssertTrue(AMessage,Not ACondition); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: ShortString): Boolean; begin Result:=AssertTrue(AMessage+'. '+ExpectMessage(AExpected,AActual,True),AExpected=AActual); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: AnsiString): Boolean; begin Result:=AssertTrue(AMessage+'. '+ExpectMessage(AExpected,AActual,True),AExpected=AActual); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: UTF8String): Boolean; begin Result:=AssertTrue(AMessage+'. '+ExpectMessage(AExpected,AActual,True),AExpected=AActual); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: UnicodeString): Boolean; begin Result:=AssertTrue(AMessage+'. '+UTF8Encode(ExpectMessage(AExpected,AActual,True)),AExpected=AActual); end; Function AssertEquals(AMessage : TTestString; const AExpected: Char; AActual : UnicodeString): Boolean; begin Result:=AssertEquals(AMessage,RTLString(aExpected),aActual); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: Boolean ): Boolean; Const BStrs : Array[Boolean] of TTestString = ('False','True'); begin Result:=AssertTrue(AMessage+'. '+ExpectMessage(BStrs[AExpected],BStrs[AActual],False),AExpected=AActual); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: Shortint ): Boolean; Var SE,SA : TTestString; begin Str(AExpected,SE); Str(AActual,SA); Result:=AssertTrue(AMessage+'. '+ExpectMessage(SE,SA),AExpected=AActual); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: Byte ): Boolean; Var SE,SA : TTestString; begin Str(AExpected,SE); Str(AActual,SA); Result:=AssertTrue(AMessage+'. '+ExpectMessage(SE,SA),AExpected=AActual); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: Smallint ): Boolean; Var SE,SA : TTestString; begin Str(AExpected,SE); Str(AActual,SA); Result:=AssertTrue(AMessage+'. '+ExpectMessage(SE,SA),AExpected=AActual); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: Word ): Boolean; Var SE,SA : TTestString; begin Str(AExpected,SE); Str(AActual,SA); Result:=AssertTrue(AMessage+'. '+ExpectMessage(SE,SA),AExpected=AActual); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: Longint ): Boolean; Var SE,SA : TTestString; begin Str(AExpected,SE); Str(AActual,SA); Result:=AssertTrue(AMessage+'. '+ExpectMessage(SE,SA),AExpected=AActual); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: Cardinal ): Boolean; Var SE,SA : TTestString; begin Str(AExpected,SE); Str(AActual,SA); Result:=AssertTrue(AMessage+'. '+ExpectMessage(SE,SA),AExpected=AActual); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: Int64 ): Boolean; Var SE,SA : TTestString; begin Str(AExpected,SE); Str(AActual,SA); Result:=AssertTrue(AMessage+'. '+ExpectMessage(SE,SA),AExpected=AActual); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: QWord ): Boolean; Var SE,SA : TTestString; begin Str(AExpected,SE); Str(AActual,SA); Result:=AssertTrue(AMessage+'. '+ExpectMessage(SE,SA),AExpected=AActual); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: Currency ): Boolean; Var SE,SA : TTestString; begin Str(AExpected,SE); Str(AActual,SA); Result:=AssertTrue(AMessage+'. '+ExpectMessage(SE,SA),AExpected=AActual); end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: Double; ADelta: Double): Boolean; Var SE,SA : TTestString; begin Str(AExpected,SE); Str(AActual,SA); If ADelta=0 then ADelta:=DefaultDoubleDelta; Result:=AssertTrue(AMessage+'. '+ExpectMessage(SE,SA),Abs(AExpected-AActual)AActual) end; function AssertEquals(AMessage: TTestString; const AExpected, AActual: TClass ): Boolean; Function CN (AClass : TClass) : TTestString; begin If Assigned(AClass) then Result:=AClass.ClassName else Result:='Nil' end; Var SE,SA : TTestString; begin SE:=CN(AExpected); SA:=CN(AActual); Result:=AssertTrue(AMessage+'. '+ExpectMessage(SE,SA),AExpected=AActual); end; function AssertInheritsFrom(AMessage: TTestString; const AChild, AParent: TObject): Boolean; Var CC,CP : TClass; begin if Assigned(AParent) then CP:=AParent.ClassType else CP:=Nil; if Assigned(AChild) then CC:=AChild.ClassType else CC:=Nil; Result:=AssertInheritsFrom(AMessage,CC,CP) end; function AssertInheritsFrom(AMessage: TTestString; const AChild, AParent: TClass ): Boolean; begin Result:=AssertNotNull(AMessage,AChild); if Result then begin Result:=AssertNotNull(AMessage,AParent); if Result then Result:=AssertTrue(AMessage,AChild.InheritsFrom(AParent)); end; end; function AssertSame(AMessage: TTestString; const AExpected, AActual: TObject ): Boolean; Function CN (AClass : TObject) : TTestString; begin If Assigned(ACLass) then Result:=AClass.ClassName else Result:='Nil' end; Var SE,SA : TTestString; begin SE:=CN(AExpected); if AExpected<>Nil then SE:=SE+'('+HexStr(AExpected)+')'; SA:=CN(AActual); if AActual<>Nil then SA:=SA+'('+HexStr(AActual)+')'; Result:=AssertTrue(AMessage+'. '+ExpectMessage(SE,SA),AExpected=AActual); end; function AssertNotSame(AMessage: TTestString; const AExpected, AActual: TObject ): Boolean; Function CN (AClass : TObject) : TTestString; begin If Assigned(ACLass) then Result:=AClass.ClassName else Result:='Nil' end; Var SE,SA : TTestString; begin SE:=CN(AExpected); if AExpected<>Nil then SE:=SE+'('+HexStr(AExpected)+')'; SA:=CN(AActual); if AActual<>Nil then SA:=SA+'('+HexStr(AActual)+')'; Result:=AssertTrue(AMessage+'. '+ExpectMessage(SE,SA),AExpected<>AActual); end; function AssertException(const AMessage: string; AExceptionClass: TClass; ARun: TProcedure): boolean; Var EC : TClass; begin EC:=Nil; Try ARun(); except On E : TObject do EC:=E.ClassType; end; Result:=AssertNotNull(AMessage,EC); if Result then Result:=AssertEquals(AMessage,AExceptionClass,EC); end; function AssertException(const AMessage: string; AExceptionClass: TClass; ARun: TTestRun): boolean; Var EC : TClass; S : TTestString; begin EC:=Nil; S:=''; Try S:=ARun(); except On E : TObject do EC:=E.ClassType; end; Result:=AssertNotNull(AMessage,EC) and AssertEquals(AMessage,TTestString(''),S); if Result then Result:=AssertEquals(AMessage,AExceptionClass,EC); end; function ExpectException(AMessage: TTestString; AClass: TClass): Boolean; begin Result:=SetTestError(teOK)=teOK; Result:=AssertTrue(AMessage,Result and Assigned(CurrentResult) and (CurrentResult^.TestResult in [trEmpty,trOK])); If Result then begin CurrentResult^.ExpectException:=AClass; CurrentResult^.TestMessage:=AMessage; end; end; { --------------------------------------------------------------------- Auxiliary test run routines ---------------------------------------------------------------------} // Reset run summary results Procedure FreeResultRecord(P : PResultRecord; Recurse : Boolean); Var N : PResultRecord; begin if Not Assigned(P) then exit; Repeat Finalize(p^); N:=P^.NextResult; If Recurse then FreeResultRecord(P^.ChildResults,Recurse); FreeMem(P); P:=N; Until (P=Nil); end; Procedure ResetRun(Var ARun : TRunSummary); begin FreeResultRecord(ARun.Results.ChildResults,True); ARun:=Default(TRunSummary); ARun.Results:=Default(TResultRecord); CurrentSuiteResult:=@ARun.Results; CurrentResult:=@ARun.Results; end; // Check if the test run must be continued ? Function ContinueTest(AResult : TTestError) : Boolean; begin Result:=(AResult=teOK) or (CurrentErrorAction=eaIgnore);; end; // Set current test result Function AllocateCurrentSuiteResult(ASuite: PSuite; IsChild : Boolean): TTestError; Var P : PResultRecord; begin Result:=SetTestError(teOK); New(P); If (P=Nil) then SetTestError(teNoMemory) else begin P^:=Default(TResultRecord); p^.Suite:=ASuite; If IsChild then begin CurrentSuiteResult^.ChildResults:=P; P^.ParentResult:=CurrentSuiteResult; end else Begin CurrentSuiteResult^.NextResult:=P; P^.ParentResult:=CurrentSuiteResult^.ParentResult; end; CurrentSuiteResult:=P; CurrentResult:=CurrentSuiteResult; end; end; Function AllocateCurrentResult(ASuite: PSuite; ATest: PTest): TTestError; Var N,P : PResultRecord; begin Result:=SetTestError(teOK); New(P); If (P=Nil) then SetTestError(teNoMemory) else begin P^:=Default(TResultRecord); P^.TestResult:=trEmpty; P^.Suite:=ASuite; P^.Test:=ATest; P^.ExpectException:=Nil; // Hook up in tree. N:=CurrentSuiteResult^.ChildResults; if N=Nil then begin CurrentSuiteResult^.ChildResults:=P; P^.ParentResult:=CurrentSuiteResult; end else begin While (N^.NextResult<>Nil) do N:=N^.NextResult; N^.NextResult:=P; P^.ParentResult:=N^.ParentResult; end; CurrentResult:=P; end; end; { --------------------------------------------------------------------- Protected run of hook handlers. Catch exceptions and report them. ---------------------------------------------------------------------} // Run start hook Function RunGLobalRunStartHandler(Suites : TSuiteArray) : TTestError; begin Result:=SetTestError(teOK); Try GlobalRunStartHandler(Suites); except On E : TObject do begin CurrentResult:=@CurrentRun.Results; SetTestResult(trHandlerError,E.ToString,True); Result:=(SetTestError(teRunStartHandler)); end; end; end; // Run complete hook Function RunGLobalRunCompleteHandler(Run : TRunSummary) : TTestError; begin Result:=SetTestError(teOK); if Assigned(GlobalRunCompleteHandler) then Try GlobalRunCompleteHandler(Run); except On E : TObject do begin CurrentResult:=@CurrentRun.Results; SetTestResult(trHandlerError,E.ToString,False); Result:=(SetTestError(teRunCompleteHandler)); end; end; end; // Run suite start hook Function RunGlobalSuiteStartHandler(ASuite : PSuite) : TTestError; begin Result:=SetTestError(teOK); If Assigned(GlobalSuiteStartHandler) then try GlobalSuiteStartHandler(ASuite); except On E : EIgnore do SetTestResult(trTestIgnore,E.ToString); On E : EFail do SetTestResult(trAssertFailed,E.ToString); On E : TObject do SetTestResult(trHandlerError,E.ToString); end; end; // Run suite complete hook Function RunGlobalSuiteCompleteHandler(ASuite : PSuite; SuiteResult : PResultRecord) : TTestError; Var C : PresultRecord; begin Result:=SetTestError(teOK); If Assigned(GlobalSuiteCompleteHandler) then begin C:=CurrentResult; CurrentResult:=SuiteResult; try GlobalSuiteCompleteHandler(ASuite,SuiteResult); except On E : EIgnore do SetTestResult(trTestIgnore,E.ToString); On E : EFail do SetTestResult(SuiteResult^,trAssertFailed,E.ToString); On E : TObject do SetTestResult(SuiteResult^,trHandlerError,E.ToString); end; CurrentResult:=C; end; end; // Run suite setup Function RunSuiteSetup(ASuite : PSuite; SuiteResult : PResultRecord) : TTestError; var S : TTestString; begin Result:=SetTestError(teOK); if Not Assigned(ASuite^.Setup) then exit; S:=''; try S:=ASuite^.Setup(); Except On E : TObject Do S:=E.ToString; end; if (S<>'') then begin SetTestResult(SuiteResult^,trSuiteSetupFailed,S,True); Result:=SetTestError(teSuiteSetupFailed); Inc(CurrentRun.SuitesFailed); If Assigned(GlobalSuiteSetupFailureHandler) then GlobalSuiteSetupFailureHandler(ASuite,S); end end; // Run suite teardown Function RunSuiteTearDown(ASuite : PSuite; SuiteResult : PResultRecord) : TTestError; var S : TTestString; C : PresultRecord; begin Result:=SetTestError(teOK); if Not Assigned(ASuite^.Teardown) then exit; C:=CurrentResult; CurrentResult:=SuiteResult; S:=''; try S:=ASuite^.TearDown(); Except On E : TObject Do S:=E.ToString; end; if (S<>'') then begin SetTestResult(SuiteResult^,trSuiteTearDownFailed,S,True); Result:=SetTestError(teSuiteTeardownFailed); Inc(CurrentRun.SuitesFailed); If Assigned(GlobalSuiteTearDownFailureHandler) then GlobalSuiteTearDownFailureHandler(ASuite,S); end; CurrentResult:=C; end; // Run test handler Var SavedDefaultSystemCodePage, SavedDefaultUnicodeCodePage, SavedDefaultFileSystemCodePage, SavedDefaultRTLFileSystemCodePage, SavedUTF8CompareLocale : TSystemCodePage; Procedure SaveCodePages; begin SavedDefaultSystemCodePage:=DefaultSystemCodePage; SavedDefaultUnicodeCodePage:=DefaultUnicodeCodePage; SavedDefaultFileSystemCodePage:=DefaultFileSystemCodePage; SavedDefaultRTLFileSystemCodePage:=DefaultRTLFileSystemCodePage; SavedUTF8CompareLocale:=UTF8CompareLocale; end; Procedure RestoreCodePages; begin DefaultSystemCodePage:=SavedDefaultSystemCodePage; DefaultUnicodeCodePage:=SavedDefaultUnicodeCodePage; DefaultFileSystemCodePage:=SavedDefaultFileSystemCodePage; DefaultRTLFileSystemCodePage:=SavedDefaultRTLFileSystemCodePage; UTF8CompareLocale:=SavedUTF8CompareLocale; end; Function RunTestHandler(aTest : PTest) : String; Var EC : TClass; EM : TTestString; begin Result:=''; EC:=Nil; EM:=''; SaveCodePages; try if assigned(aTest^.Run) then Result:=aTest^.Run() else if assigned(aTest^.RunProc) then begin Result:=''; aTest^.RunProc(); end else Result:=SErrNoTestProcedure; RestoreCodePages; except On E : TObject do begin RestoreCodePages; EC:=E.ClassType; EM:=E.TOString; end; end; // Read IOResult so it is reset. if IOResult<>0 then; // Treat exception. if (EC<>CurrentResult^.ExpectException) then begin if (CurrentResult^.ExpectException=Nil) then Result:=EM else With CurrentResult^ do if (EC=Nil) then Result:=TestMessage+' '+ExpectMessage(ExpectException.ClassName,'Nil') else Result:=TestMessage+' '+ExpectMessage(ExpectException.ClassName,EC.ClassName); end; end; { --------------------------------------------------------------------- Running tests ---------------------------------------------------------------------} Function RunSingleTest(T : PTest) : TTestError; Type TTestStage = (tsStartHandler,tsSetup,tsRun,tsTearDown,tsCompleteHandler); Const Prefixes : Array[TTestStage] of TTestString = ('Test start handler','Test Setup','','Test TearDown','Test complete handler'); Errors : Array[TTestStage] of TTestResult = (trHandlerError,trSuiteSetupFailed, trTestError,trSuiteTearDownFailed,trHandlerError); Var S : TTestString; Stage : TTestStage; StartTime : TDateTime; CurrentAsserts : Integer; begin SetTestError(teOK); Assert(CurrentSuite<>Nil); CurrentTest:=T; try CurrentAsserts:=CurrentRun.AssertCount; Result:=AllocateCurrentResult(CurrentSuite,T); if (Result<>teOK) then Exit; Stage:=tsStartHandler; // We don't use a protected method. We use 1 try/except block that keeps track of the 'stage'. If Assigned(GlobalTestStartHandler) then GlobalTestStartHandler(T,CurrentSuite); if (soSetupTearDownPerTest in CurrentSuite^.Options) then begin Stage:=tsSetup; Result:=RunSuiteSetup(CurrentSuite,CurrentResult); end; if (Result=teOK) then If Not (toInactive in T^.Options) then begin StartTime:=GetTimeFromHook; try Stage:=tsRun; S:=RunTestHandler(T); // Protect and handle exception. if (S<>'') then Fail(S) else if (CurrentResult^.TestResult=trEmpty) then if (CurrentAsserts=CurrentRun.AssertCount) and RequirePassed then Inc(CurrentRun.TestsUnimplemented) else SetTestResult(trOK,''); Finally CurrentResult^.ElapsedTime:=GetTimeDiff(StartTime); Inc(CurrentRun.TestsRun); end; if (soSetupTearDownPerTest in CurrentSuite^.Options) then begin Stage:=tsTearDown; Result:=RunSuiteTearDown(CurrentSuite,CurrentResult); end; Stage:=tsCompleteHandler; end else begin Inc(CurrentRun.TestsInactive); SetTestResult(trTestInactive,'',True); Result:=SetTestError(teTestInactive); end; if Assigned(GlobalTestCompleteHandler) then GlobalTestCompleteHandler(T,CurrentSuite,CurrentResult); except On E : TObject do begin S:=Prefixes[Stage]; if (S<>'') then S:='['+S+'] '; S:=S+E.Tostring; SetTestResult(CurrentResult^,Errors[Stage],S,True); end; end; CurrentTest:=Nil; end; // Internal, run a single suite, collect results in RunSummary. Function RunSingleSuite(ASuite : PSuite; isChild : Boolean) : TTestError; Type TSuiteStage = (ssStartHandler,ssSetup,ssRun,ssTearDown,ssEndHandler); Const Prefixes : Array [TSuiteStage] of TTestString = ('Start handler','Setup','','Teardown','End Handler'); StageErrors : Array [TSuiteStage] of TTestResult = (trHandlerError,trSuiteSetupFailed,trTestError,trSuiteTearDownFailed,trHandlerError); Var S : TTestString; T : PTest; Stage : TSuiteStage; I : Integer; StartTime : TDateTime; R2 : TTestError; OldCurrentSuite : PSuite; SuiteResult : PResultRecord; begin if AllocateCurrentSuiteResult(ASuite,IsChild)<>teOK then exit; SetTestError(teOK); OldCurrentSuite:=CurrentSuite; SuiteResult:=CurrentSuiteResult; CurrentSuite:=ASuite; try Result:=teOK; Stage:=ssStartHandler; RunGlobalSuiteStartHandler(ASuite); // First, run all sub suites. If (soInactive in ASuite^.Options) then Inc(CurrentRun.SuitesInactive) else begin StartTime:=GetTimeFromHook; S:=''; try if not (soSetupTearDownPerTest in ASuite^.Options) then begin Stage:=ssSetup; Result:=RunSuiteSetup(ASuite,SuiteResult); end; Stage:=ssRun; For I:=0 to Asuite^.Suites.Count-1 do If (Result=teOK) or (CurrentErrorAction=eaIgnore) then Result:=RunSingleSuite(ASuite^.Suites.Items[i],I=0); // Reset current result CurrentSuiteResult:=SuiteResult; CurrentResult:=SuiteResult; For I:=0 to Asuite^.Tests.Count-1 do If (Result=teOK) or (CurrentErrorAction=eaIgnore) then begin T:=Asuite^.Tests.Items[i]; if Not (toInactive in T^.Options) then Result:=RunSingleTest(T) else Inc(CurrentRun.TestsInactive) end; Stage:=ssTeardown; Result:=RunSuiteTearDown(ASuite,SuiteResult); Finally Inc(CurrentRun.SuitesRun); SuiteResult^.ElapsedTime:=GetTimeDiff(StartTime); end; Stage:=ssEndHandler; R2:=RunGLobalSuiteCompleteHandler(ASuite,SuiteResult); if (Result=teOK) and (R2<>teOK) then Result:=R2; SetTestResult(SuiteResult^,trOK,'',False); end; except On E : TObject do begin S:=Prefixes[Stage]; if (S<>'') then S:='['+S+'] '; S:=S+E.Tostring; SetTestResult(SuiteResult^,StageErrors[Stage],S,True); end; end; CurrentSuite:=OldCurrentSuite; end; // Internal. At this point, ASuite and ATest are valid. Function DoRunTest(ASuite: PSuite; ATest: PTest): TTestError; Var A : TSuiteArray; StartTime : TDateTime; SuiteResult : PResultRecord; begin A:=[]; ResetRun(CurrentRun); if AllocateCurrentSuiteResult(ASuite,True)<>teOK then exit; Result:=SetTestError(teOK); SuiteResult:=CurrentResult; If Assigned(GlobalRunStartHandler) then begin SetLength(A,1); A[0]:=ASuite; Result:=RunGlobalRunStartHandler(A); SetLength(A,0); If not ContinueTest(Result) then exit; end; if (soInactive in ASuite^.Options) then begin SetTestResult(trSuiteInactive,'',True); Inc(CurrentRun.SuitesInactive); Inc(CurrentRun.SuitesFailed); RunGlobalRunCompleteHandler(CurrentRun); // Ignore status Exit(SetTestError(teSuiteInactive)); end; StartTime:=GetTimeFromHook; if Not ContinueTest(Result)then begin Result:=CombineError(Result,RunGlobalRunCompleteHandler(CurrentRun)); exit; end; CurrentSuite:=ASuite; try Result:=RunGlobalSuiteStartHandler(ASuite); if ContinueTest(Result) then begin Result:=RunSuiteSetup(ASuite,SuiteResult); if ContinueTest(Result) then begin Result:=CombineError(Result,RunSingleTest(ATest)); Result:=CombineError(Result,RunSuiteTearDown(ASuite,SuiteResult)); end; end; finally SetTestResult(SuiteResult^,trOK,''); Inc(CurrentRun.SuitesRun); CurrentSuite:=Nil; end; Result:=CombineError(Result,RunGlobalSuiteCompleteHandler(ASuite,SuiteResult)); CurrentRun.ElapsedTime:=GetTimeDiff(StartTime); Result:=CombineError(Result,RunGlobalRunCompleteHandler(CurrentRun)); end; // Internal. At this point, ASuite is valid. Function DoRunSuite(ASuite: PSuite): TTestError; Var A : TSuiteArray; StartTime : TDateTime; begin A:=[]; SetTestError(teOK); ResetRun(CurrentRun); If Assigned(GlobalRunStartHandler) then begin SetLength(A,1); A[0]:=ASuite; Result:=RunGlobalRunStartHandler(A); SetLength(A,0); if not ContinueTest(Result) then Exit; end; SetTestError(teOK); StartTime:=GetTimeFromHook; Result:=teOK; Result:=RunSingleSuite(ASuite,True); CurrentRun.ElapsedTime:=GetTimeDiff(StartTime); Result:=CombineError(Result,RunGlobalRunCompleteHandler(CurrentRun)); end; function RunSuite(ASuite: PSuite): TTestError; begin SetTestError(teOK); if (ASuite=Nil) then Result:=SetTestError(teNoSuite) else Result:=DoRunSuite(ASuite); end; function RunSuite(const ASuiteName: TTestString): TTestError; begin Result:=RunSuite(GetSuite(ASuiteName)); end; function RunSuite(ASuiteIndex: Integer): TTestError; begin Result:=RunSuite(GetSuite(ASuiteIndex)) end; Function RunTest(ASuiteIndex: Integer; Const ATestName: TTestString): TTestError; Var S : PSuite; begin S:=GetSuite(ASuiteIndex); Result:=RunTest(S,GetTest(S,ATestName)); end; Function RunTest(ASuite: PSuite; ATestIndex: Integer): TTestError; begin Result:=RunTest(ASuite,GetTest(ASuite,ATestIndex)); end; function RunTest(ASuite: PSuite; const ATestName: TTestString): TTestError; begin Result:=RunTest(ASuite,GetTest(ASuite,ATestName)); end; function RunTest(const ASuiteName: TTestString; const ATestName: TTestString ): TTestError; Var S : PSuite; begin S:=GetSuite(ASuiteName); Result:=RunTest(S,GetTest(S,ATestName)); end; function RunTest(ASuite: PSuite; ATest: PTest): TTestError; begin Result:=SetTestError(teOK); ProcessSysCommandline; if (ASuite=Nil) then Result:=SetTestError(teNoSuite) else if (ATest=Nil) then Result:=SetTestError(teNoTest) else if not TestIsInSuite(ASuite,ATest) then Result:=SetTestError(teTestNotInSuite) else Result:=DoRunTest(ASuite,ATest); end; Procedure SysHalt; begin if CurrentRun.TestsFailed<>0 then Halt(1) else Halt(0); end; Procedure DoRunSysTests(S : PSuite; T : PTest); forward; procedure RunTest(ARun: TTestRun); begin ProcessSysCommandLine; if ARun=Nil then Halt(2); if (AddTest('Global',ARun)=Nil) then Halt(3); DoRunSysTests(Nil,Nil); end; function GetCurrentRun: TRunSummary; begin Result:=CurrentRun; end; function GetCurrentSuite: PSuite; begin Result:=CurrentSuite; end; function GetCurrentTest: PTest; begin Result:=CurrentTest; end; function GetCurrentResult: PResultRecord; begin Result:=CurrentResult; end; function RunAllTests: TTestError; Var I : Integer; A : TSuiteArray; StartTime : TDateTime; begin A:=[]; Result:=SetTestError(teOK); ResetRun(CurrentRun); StartTime:=GetTimeFromHook; If Assigned(GlobalRunStartHandler) then begin // Array of actual size. SetLength(A,TestRegistry.Count); For I:=0 to TestRegistry.Count-1 do A[I]:=TestRegistry.Items[i]; GlobalRunStartHandler(A); SetLength(A,0); end; If (TestRegistry.Count=0) then Result:=SetTestError(teRegistryEmpty) else begin I:=0; While (ISysSuite) then begin SysSuiteIndent:=SysSuiteIndent+' '; Write(FSys^,SysSuiteIndent,SSuite,' ',ASuite^.Name,':'); if CurrentRunMode=rvVerbose then Writeln(FSys^,' (',ASuite^.Tests.Count,' ',STests+')') else Writeln(FSys^); SysSuite:=ASuite; end; end; Procedure SysTestStartHandler (ATest : PTest; ASuite : PSuite); begin if CurrentRunMode in [rvQuiet,rvFailures] then Exit; Write(FSys^,SysSuiteIndent+' ',STest,' ',ATest^.Name,': '); end; function SysTimeString(MSec: Integer): TTestString; Var S : TTestString; begin S:=''; Str(Msec mod 1000,Result); MSec:=Msec div 1000; If (Msec=0) then Result:='0.'+Result else begin Str(Msec mod 60,S); Result:=S+'.'+Result; Msec:=Msec div 60; If (Msec<>0) then begin Str(Msec mod 60,S); Result:=S+':'+Result; Msec:=Msec div 60; If (Msec<>0) then begin Str(Msec,S); Result:=S+':'+Result; end; end; end; Result:=STime+': '+Result; end; Procedure SysTestCompleteHandler (ATest: PTest; ASuite : PSuite; Const AResultRecord : PResultRecord); Var S : TTestString; F,O : Boolean; TR : TTestResult; begin if (CurrentRunMode=rvQuiet) then exit; F:=CurrentRunMode=rvFailures; O:=False; S:=AResultRecord^.TestMessage; TR:=AResultRecord^.TestResult; Case TR of trEmpty : if not F then Write(FSys^,SNotImplemented); trOK : if not F then Write(FSys^,SPassed); trTestIgnore: if not F then Write(FSys^,SIgnored,' (',S,')'); trSuiteSetupFailed, trSuiteTearDownFailed, trAssertFailed, trTestError, trHandlerError: begin if F then Write(FSys^,STest,' ',ASuite^.Name,'.',ATest^.Name,': '); if TR in [trTestError,trHandlerError] then Write(FSys^,SError) else Write(FSys^,SFailed); Write(FSys^,' (',SErrorMessage,': ',S,')'); O:=True; end; trTestInactive: if not F then Write(FSys^,SInactive); else if not F then Write(FSys^,SUnknown,' : ',AResultRecord^.TestMessage); end; if (not F) and HaveTimeHook then Writeln(FSys^,' ',SysTimeString(AResultRecord^.ElapsedTime)) else if (O or Not F) then Writeln(FSys^); end; Procedure GetResultStats(AResults : PResultRecord; Var Stats : TSuiteStats); begin If AResults^.Test<>Nil then begin Inc(Stats.TestsRun); Case AResults^.TestResult of trEmpty : Inc(Stats.TestsUnimplemented); trAssertFailed : Inc(Stats.TestsFailed); trTestInactive : Inc(Stats.TestsInactive); trTestIgnore : Inc(Stats.TestsIgnored); trTestError : Inc(Stats.TestsError); else // Do nothing, silence compiler warning end; end; end; Procedure DoGetSuiteStats(AResults : PResultRecord; Var Stats : TSuiteStats); Var R : PResultRecord; begin if AResults^.Test<>Nil then Exit; Inc(Stats.Suites); R:=AResults^.ChildResults; While R<>Nil do begin if R^.Test=Nil then DoGetSuiteStats(R,Stats) else GetResultStats(R,Stats); R:=R^.NextResult; end; end; Procedure GetSuiteStats(AResults : PResultRecord; Out Stats : TSuiteStats); begin Stats:=Default(TSuiteStats); DoGetSuiteStats(AResults,Stats); end; Procedure SysSuiteCompleteHandler (ASuite : PSuite; Const AResults : PResultRecord); Var Stats : TSuiteStats; begin if CurrentRunMode=rvFailures then Delete(SysSuiteIndent,1,2); if CurrentRunMode in [rvQuiet,rvFailures] then exit; Write(FSys^,SysSuiteIndent,SSuite,' ',ASuite^.Name,' ',SSummary,': '); GetSuiteStats(AResults,Stats); With Stats do begin Write(FSys^,SRunCount,': ',TestsRun,' ',SFailedCount,': ',TestsFailed,' ',SInactiveCount,': ',TestsInactive,' ',SIgnoredCount,': ',TestsIgnored); if RequirePassed then Write(FSys^,' ',SUnimplementedCount,': ',TestsUnimplemented); end; if HaveTimeHook then Writeln(FSys^,' ',SysTimeString(AResults^.ElapsedTime)) else Writeln(FSys^); Flush(FSys^); Delete(SysSuiteIndent,1,2); end; Procedure SysRunStartHandler (Const Suites: TSuiteArray); Var I,TC : Integer; begin if (CurrentRunmode in [rvQuiet,rvFailures]) then exit; TC:=0; For I:=0 to Length(Suites)-1 do Inc(TC,Suites[i]^.Tests.Count); Write(FSys^,STestRun,':'); If (CurrentRunMode<>rvVerbose) then Writeln(FSys^) else Writeln(FSys^,' ',Length(Suites),' ',SSuites,', ',TC,' ',STests); end; Procedure SysRunCompleteHandler (Const AResult : TRunSummary); begin if (CurrentRunMode=rvQuiet) then exit; if (CurrentRunMode=rvFailures) then begin Writeln(FSys^,SFailedCount,': ',AResult.TestsFailed); exit; end; Writeln(FSys^); Write(FSys^,SRunSummary,':'); if HaveTimeHook then Writeln(FSys^,' ',SysTimeString(AResult.ElapsedTime)) else Writeln(FSys^); Write(FSys^,' ',SSuitesSummary,':'); With AResult do if CurrentRunMode=rvVerbose then begin Writeln(FSys^); Writeln(FSys^,' ',SRunCount,': ',SuitesRun); Writeln(FSys^,' ',SFailedCount,': ',SuitesFailed); Writeln(FSys^,' ',SInactiveCount,': ',SuitesInactive); end else Writeln(FSys^,' ',SRunCount,': ',SuitesRun,' ',SFailedCount,': ',SuitesFailed,' ',SInactiveCount,': ',SuitesInactive); Write(FSys^,' ',STestsSummary,':'); With AResult do if CurrentRunMode=rvVerbose then begin Writeln(FSys^); Writeln(FSys^,' ',SRunCount,': ',TestsRun); Writeln(FSys^,' ',SInactiveCount,': ',TestsInactive); Writeln(FSys^,' ',SFailedCount,': ',TestsFailed); Writeln(FSys^,' ',SIgnoredCount,': ',TestsIgnored); if RequirePassed then Writeln(FSys^,' ',SUnimplementedCount,': ',TestsUnimplemented); end else begin Write(FSys^,' ',SRunCount,': ',TestsRun,' ',SFailedCount,': ',TestsFailed,' ',SInactiveCount,': ',TestsInactive,' ',SIgnoredCount,': ',TestsIgnored); if RequirePassed then Writeln(FSys^,' ',SUnimplementedCount,': ',TestsUnimplemented) else Writeln(FSys^); end; Flush(FSys^); end; Procedure SysSuiteSetupFailedHandler (ASuite : PSuite; Const AError : TTestString); begin If (CurrentRunMode=rvVerbose) then Writeln(FSys^,SSuiteSetupFailed,' : ',ASuite^.Name,' : ',AError) end; Procedure SysSuiteTearDownFailedHandler (ASuite : PSuite; Const AError : TTestString); begin If (CurrentRunMode=rvVerbose) then Writeln(FSys^,SSuiteTeardownFailed,' : ',ASuite^.Name,' : ',AError) end; procedure SetupSysIO; begin FSys:=@Output; CurrentRunmode:=rvNormal; end; procedure SetupSysHandlers; begin // Run SetRunStartHandler(@SysRunStartHandler); SetRunCompleteHandler(@SysRunCompleteHandler); // Suite SetSuiteCompleteHandler(@SysSuiteCompleteHandler); SetSuiteStartHandler(@SysSuiteStartHandler); SetSuiteSetupFailureHandler(@SysSuiteSetupFailedHandler); SetSuiteTearDownFailureHandler(@SysSuiteTearDownFailedHandler); // Test SetTestStartHandler(@SysTestStartHandler); SetTestCompleteHandler(@SysTestCompleteHandler); end; procedure TearDownSysHandlers; begin {$I-} Close(LogFile); {$I+} ClearTestHooks; end; function GetSysRunVerbosity: TSysRunVerbosity; begin Result:=CurrentRunMode; end; function SetSysRunVerbosity(AMode: TSysRunVerbosity): TSysRunVerbosity; begin Result:=CurrentRunMode; CurrentRunMode:=AMode; end; Function FullSuiteName(ASuite : PSuite) : AnsiString; begin Result:=''; While (ASuite<>Nil) do begin If (Result<>'') then Result:='.'+Result; Result:=ASuite^.Name+Result; ASuite:=ASuite^.ParentSuite; end; end; Procedure SysListTests(ASuiteList : PSuiteList; ASuite : Psuite; ATest : PTest); Var I,J : Integer; S : PSuite; T : PTest; begin if ASuiteList=Nil then exit; For i:=0 to ASuiteList^.Count-1 do begin S:=ASuiteList^.Items[I]; If (ASuite=Nil) or (ASuite=S) then Begin if (CurrentRunMode=rvVerbose) then Writeln(FSys^,SSuite,': ',FullSuiteName(S)); // First, list all sub suites. SysListTests(@S^.Suites,ASuite,ATest); For J:=0 to S^.Tests.Count-1 do begin T:=S^.Tests.Items[J]; If (ATest=Nil) or (ATest=T) then begin if (CurrentRunMode=rvVerbose) then Write(FSys^,' ',STest,': '); Writeln(FSys^,FullSuiteName(S),'.',T^.Name); end; end; end; end; end; procedure ProcessSysCommandline; Var i: Integer; S: TTestString; Function TestO(Const Short,Long: TTestString) : Boolean; Var L : Integer; LO : String; begin Result:=(S='-'+Short); if Result then begin Inc(I); S:=Paramstr(i); end else begin Lo:='--'+Long+'='; L:=Length(Lo); Result:=(Copy(S,1,L)=LO); if Result then Delete(S,1,L); end; end; begin SysRunMode:=rmTest; I:=1; While I<=ParamCount do begin S:=ParamStr(i); if (S='-v') or (S='--verbose') then SetSysRunVerbosity(rvverbose) else if (S='-q') or (S='--quiet') then SetSysRunVerbosity(rvQuiet) else if (S='-n') or (S='--normal') then SetSysRunVerbosity(rvNormal) else if (S='-f') or (S='--failures') then SetSysRunVerbosity(rvFailures) else if (S='-l') or (S='--list') then SysRunMode:=rmList else if (S='-h') or (S='--help') then SysRunMode:=rmHelp else if TestO('o','output') then begin If (S='') then begin S:=ParamStr(0) end; SysOutputFileName:=S; end else if TestO('s','suite') then SysSuiteName:=S else if TestO('t','test') then SysTestName:=S; Inc(i); end; if (SysOutputFileName<>'') then begin {$i-} Close(LogFile); Assign(LogFile,SysOutputFileName); Rewrite(LogFile); if (IOResult<>0) then FSys:=@LogFile else CurrentRunMode:=rvQuiet {$i+} end else end; Procedure SysShowHelp; begin Writeln(SUsage); Writeln(SHelpF); Writeln(SHelpH); Writeln(SHelpL); Writeln(SHelpN); Writeln(SHelpO); Writeln(SHelpQ); Writeln(SHelpS); Writeln(SHelpT); Writeln(SHelpV); If HaveTimeHook then Writeln(SHelpHasTime) else Writeln(SHelpNoTime); Writeln(SHelpExitCodes); Writeln(SHelpExit0); Writeln(SHelpExit1); Writeln(SHelpExit2); Writeln(SHelpExit3); Writeln(SHelpExit4); Writeln(SHelpExit5); end; procedure DoRunSysTests(S: PSuite; T: PTest); Var r : TTestError; begin Case SysRunMode of rmHelp: begin SysShowHelp; Halt(0); end; rmList: begin SysListTests(@TestRegistry,S,T); Halt(0); end; rmTest: begin if Assigned(T) then R:=RunTest(S,T) else if Assigned(S) then R:=RunSuite(S) else R:=RunAllTests; If (R<>teOK) then Halt(5) else SysHalt; end; end; end; procedure RunAllSysTests; Var S : PSuite; T : PTest; P : Integer; begin S:=Nil; T:=Nil; ProcessSysCommandline; P:=Pos('.',SysTestName); if (P>0) then begin SysSuiteName:=Copy(SysTestName,1,P-1); Delete(SysTestName,1,P); P:=Pos('.',SysTestName); While P<>0 do begin SysSuiteName:=SysSuiteName+'.'+Copy(SysTestName,1,P-1); Delete(SysTestName,1,P); P:=Pos('.',SysTestName); end; end; if (SysSuiteName<>'') then begin S:=GetSuite(SysSuiteName); if (S=Nil) then Halt(3); end; if (SysTestName<>'') then begin if (S=Nil) then begin S:=GetSuite(DefaultSuiteName); if (S=Nil) then Halt(3); end; T:=GetTest(S,SysTestName); if (T=Nil) then Halt(4); end; DoRunSysTests(S,T); end; { EFail } Constructor EFail.Create(Const AMessage: TTestString); begin FMessage:=AMessage; end; Function EFail.ToString: RTLString; begin Result:=FMessage; end; function GetSysTestOS: TTestString; begin GetSysTestOS := lowercase({$I %FPCTARGETOS%}); end; function SysGetSetting(const AName: TTestString): TTestString; Procedure Trim(Var S : TTestString); begin While (S<>'') and (S[1] in [' ',#9]) do Delete(S,1,1); While (S<>'') and (S[Length(S)] in [' ',#9]) do S:=Copy(S,1,Length(S)-1); end; Var F : Text; I: Integer; FN,N,V : TTestString; begin Result:=''; FN:=paramstr(0); I:=Length(Fn); While (I>0) and (FN[I]<>DirectorySeparator) do Dec(I); FN:=Copy(FN,1,I); Assign(f,FN+'punit.cfg'); {$i-} Reset(f); if IOResult<>0 then exit; {$i+} While (Result='') and not EOF(F) do begin ReadLn(F,V); N:=''; I:=Pos('=',V); if I>0 then begin N:=Copy(V,1,I-1); Delete(V,1,I); end; if (N<>'') and (Pos(';',N)<>1) and (Pos('#',N)<>1) then begin Trim(N); If upcase(N)=upcase(AName) then begin Result:=V; Trim(Result); end; end; end; Close(F); end; initialization SetupSysIO; SetupTestRegistry; SetupSysHandlers; finalization TearDownSysHandlers; TearDownTestRegistry; ResetRun(CurrentRun); end.