diff options
Diffstat (limited to 'wizards/source/sfunittests/SF_UnitTest.xba')
| -rw-r--r-- | wizards/source/sfunittests/SF_UnitTest.xba | 1818 |
1 files changed, 1818 insertions, 0 deletions
diff --git a/wizards/source/sfunittests/SF_UnitTest.xba b/wizards/source/sfunittests/SF_UnitTest.xba new file mode 100644 index 000000000..5007fb6a7 --- /dev/null +++ b/wizards/source/sfunittests/SF_UnitTest.xba @@ -0,0 +1,1818 @@ +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd"> +<script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_UnitTest" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option ClassModule + +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_UnitTest +''' =========== +''' Class providing a framework to execute and check sets of unit tests. +''' +''' The UnitTest unit testing framework was originally inspired by unittest.py in Python +''' and has a similar flavor as major unit testing frameworks in other languages. +''' +''' It supports test automation, sharing of setup and shutdown code for tests, +''' aggregation of tests into collections. +''' +''' Both the +''' - code describing the unit tests +''' - code to be tested +''' must be written exclusively in Basic (the code might call functions written in other languages). +''' Even if either code may be contained in the same module, a much better practice is to +''' store them in separate libraries. +''' Typically: +''' - in a same document when the code to be tested is contained in that document +''' - either in a "test" document or in a "My Macros" library when the code +''' to be tested is a shared library (My Macros or LibreOffice Macros). +''' The code to be tested may be released as an extension. It does not need to make +''' use of ScriptForge services in any way. +''' +''' The test reporting device is the Console. Read about the console in the ScriptForge.Exception service. +''' +''' Definitions: +''' - Test Case +''' A test case is the individual unit of testing. +''' It checks for a specific response to a particular set of inputs. +''' A test case in the UnitTest service is represented by a Basic Sub. +''' The name of the Sub starts conventionally with "Test_". +''' The test fails if one of the included AssertXXX methods returns False +''' - Test Suite +''' A test suite is a collection of test cases that should be executed together. +''' A test suite is represented by a Basic module. +''' A suite may include the tasks needed to prepare one or more tests, and any associated cleanup actions. +''' This may involve, for example, creating temporary files or directories, opening a document, loading libraries. +''' Conventionally those tasks are part pf the SetUp') and TearDown() methods. +''' - Unit test +''' A full unit test is a set of test suites (each suite in a separate Basic module), +''' each of them being a set of test cases (each case is located in a separate Basic Sub). +''' +''' Two modes: +''' Beside the normal mode ("full mode"), using test suites and test cases, a second mode exists, called "simple mode" +''' limited to the use exclusively of the Assert...() methods. +''' Their boolean returned value may support the execution of limited unit tests. +''' +''' Service invocation examples: +''' In full mode, the service creation is external to test cases +''' Dim myUnitTest As Variant +''' myUnitTest = CreateScriptService("UnitTest", ThisComponent, "Tests") +''' ' Test code is in the library "Tests" located in the current document +''' In simple mode, the service creation is internal to every test case +''' Dim myUnitTest As Variant +''' myUnitTest = CreateScriptService("UnitTest") +''' With myUnitTest +''' If Not .AssertTrue(...) Then ... ' Only calls to the Assert...() methods are allowed +''' ' ... +''' .Dispose() +''' End With +''' +''' Minimalist full mode example +''' Code to be tested (stored in library "Standard" of document "MyDoc.ods") : +''' Function ArraySize(arr As Variant) As Long +''' If IsArray(arr) Then ArraySize = UBound(arr) - LBound(arr) + 1 Else ArraySize = -1 +''' End Function +''' Test code (stored in module "AllTests" of library "Tests" of document "MyDoc.ods") : +''' Sub Main() ' Sub to trigger manually, f.i. from the Tools + Run Macro tabbed bar +''' GlobalScope.BasicLibraries.loadLibrary("ScriptForge") +''' Dim test : test = CreateScriptService("UnitTest", ThisComponent, "Tests") +''' test.RunTest("AllTests") ' AllTests is a module name ; test cases are named "Test_*" (default) +''' test.Dispose() +''' End Sub +''' REM ------------------------------------------------------------------------------ +''' Sub Setup(test) ' The unittest service is passed as argument +''' ' Optional Sub to initialize processing of the actual test suite +''' Dim exc : exc = CreateScriptService("Exception") +''' exc.Console(Modal := False) ' Watch test progress in the console +''' End Sub +''' REM ------------------------------------------------------------------------------ +''' Sub Test_ArraySize(test) +''' On Local Error GoTo CatchErr +''' test.AssertEqual(ArraySize(10), -1, "When not array") +''' test.AssertEqual(ArraySize(Array(1, 2, 3)), 3, "When simple array") +''' test.AssertEqual(ArraySize(DimArray(3)), 4, "When array with empty items") +''' Exit Sub +''' CatchErr: +''' test.ReportError("ArraySize() is corrupt") +''' End Sub +''' REM ------------------------------------------------------------------------------ +''' Sub TearDown(test) +''' ' Optional Sub to finalize processing of the actual test suite +''' End Sub +''' +''' Error handling +''' To support the debugging of the tested code, the UnitTest service, in cases of +''' - assertion failure +''' - Basic run-time error in the tested code +''' - Basic run-time error in the testing code (the unit tests) +''' will comment the error location and description in a message box and in the console log, +''' providing every test case (in either mode) implements an error handler containing at least: +''' Sub Test_Case1(test As Variant) +''' On Local Error GoTo Catch +''' ' ... (AssertXXX(), Fail(), ...) +''' Exit Sub +''' Catch: +''' test.ReportError() +''' End Sub +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_unittest.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const UNITTESTMETHODERROR = "UNITTESTMETHODERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be "UNITTEST" +Private ServiceName As String + +' Testing code +Private LibrariesContainer As String ' Document or user Basic library containing the test library +Private Scope As String ' Scope when running a Basic script with Session.ExecuteBasicScript() +Private Libraries As Variant ' Set of libraries +Private LibraryName As String ' Name of the library containing the test code +Private LibraryIndex As Integer ' Index in Libraries +Private Modules As Variant ' Set of modules +Private ModuleNames As Variant ' Set of module names +Private MethodNames As Variant ' Set of methods in a given module + +' Internals +Private _Verbose As Boolean ' When True, every assertion is reported,failing or not +Private _LongMessage As Boolean ' When False, only the message provided by the tester is considered + ' When True (default), that message is appended to the standard message +Private _WhenAssertionFails As Integer ' Determines what to do when a test fails + +' Test status +Private _Status As Integer ' 0 = standby + ' 1 = test suite started + ' 2 = setup started + ' 3 = test case started + ' 4 = teardown started +Private _ExecutionMode As Integer ' 1 = Test started with RunTest() + ' 2 = Test started with CreateScriptService() Only Assert() methods allowed +Private _Module As String ' Exact name of module currently running +Private _TestCase As String ' Exact name of test case currently running +Private _ReturnCode As Integer ' 0 = Normal end + ' 1 = Assertion failed + ' 2 = Skip request (in Setup() only) + '-1 = abnormal end +Private _FailedAssert As String ' Assert function that returned a failure + +' Timers +Private TestTimer As Object ' Started by CreateScriptService() +Private SuiteTimer As Object ' Started by RunTest() +Private CaseTimer As Object ' Started by new case + +' Services +Private Exception As Object ' SF_Exception +Private Session As Object ' SF_Session + +REM ============================================================ MODULE CONSTANTS + +' When assertion fails constants: error is reported + ... +Global Const FAILIGNORE = 0 ' Ignore the failure +Global Const FAILSTOPSUITE = 1 ' Module TearDown is executed, then next suite may be started (default in full mode) +Global Const FAILIMMEDIATESTOP = 2 ' Stop immediately (default in simple mode) + +' Unit tests status (internal use only => not Global) +Const STATUSSTANDBY = 0 ' No test active +Const STATUSSUITESTARTED = 1 ' RunTest() started +Const STATUSSETUP = 2 ' A Setup() method is running +Const STATUSTESTCASE = 3 ' A test case is running +Const STATUSTEARDOWN = 4 ' A TearDown() method is running + +' Return codes +Global Const RCNORMALEND = 0 ' Normal end of test or test not started +Global Const RCASSERTIONFAILED = 1 ' An assertion within a test case returned False +Global Const RCSKIPTEST = 2 ' A SkipTest() was issued by a Setup() method +Global Const RCABORTTEST = 3 ' Abnormal end of test + +' Execution modes +Global Const FULLMODE = 1 ' 1 = Test started with RunTest() +Global Const SIMPLEMODE = 2 ' 2 = Test started with CreateScriptService() Only Assert() methods allowed + +Const INVALIDPROCEDURECALL = "5" ' Artificial error raised when an assertion fails + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "UNITTEST" + ServiceName = "SFUnitTests.UnitTest" + LibrariesContainer = "" + Scope = "" + Libraries = Array() + LibraryName = "" + LibraryIndex = -1 + _Verbose = False + _LongMessage = True + _WhenAssertionFails = -1 + _Status = STATUSSTANDBY + _ExecutionMode = SIMPLEMODE + _Module = "" + _TestCase = "" + _ReturnCode = RCNORMALEND + _FailedAssert = "" + Set TestTimer = Nothing + Set SuiteTimer = Nothing + Set CaseTimer = Nothing + Set Exception = CreateScriptService("ScriptForge.Exception") + Set Session = CreateScriptService("ScriptForge.Session") +End Sub ' SFUnitTests.SF_UnitTest Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + If Not IsNull(CaseTimer) Then CaseTimer = CaseTimer.Dispose() + If Not IsNull(SuiteTimer) Then SuiteTimer = SuiteTimer.Dispose() + If Not IsNull(TestTimer) Then TestTimer = TestTimer.Dispose() + Call Class_Initialize() +End Sub ' SFUnitTests.SF_UnitTest Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFUnitTests.SF_UnitTest Explicit destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get LongMessage() As Variant +''' When False, only the message provided by the tester is considered +''' When True (default), that message is appended to the standard message + LongMessage = _PropertyGet("LongMessage") +End Property ' SFUnitTests.SF_UnitTest.LongMessage (get) + +REM ----------------------------------------------------------------------------- +Property Let LongMessage(Optional ByVal pvLongMessage As Variant) +''' Set the updatable property LongMessage + _PropertySet("LongMessage", pvLongMessage) +End Property ' SFUnitTests.SF_UnitTest.LongMessage (let) + +REM ----------------------------------------------------------------------------- +Property Get ReturnCode() As Integer +''' RCNORMALEND = 0 ' Normal end of test or test not started +''' RCASSERTIONFAILED = 1 ' An assertion within a test case returned False +''' RCSKIPTEST = 2 ' A SkipTest() was issued by a Setup() method +''' RCABORTTEST = 3 ' Abnormal end of test + ReturnCode = _PropertyGet("ReturnCode") +End Property ' SFUnitTests.SF_UnitTest.ReturnCode (get) + +REM ----------------------------------------------------------------------------- +Property Get Verbose() As Variant +''' The Verbose property indicates if all assertions (True AND False) are reported + Verbose = _PropertyGet("Verbose") +End Property ' SFUnitTests.SF_UnitTest.Verbose (get) + +REM ----------------------------------------------------------------------------- +Property Let Verbose(Optional ByVal pvVerbose As Variant) +''' Set the updatable property Verbose + _PropertySet("Verbose", pvVerbose) +End Property ' SFUnitTests.SF_UnitTest.Verbose (let) + +REM ----------------------------------------------------------------------------- +Property Get WhenAssertionFails() As Variant +''' What when an AssertXXX() method returns False +''' FAILIGNORE = 0 ' Ignore the failure +''' FAILSTOPSUITE = 1 ' Module TearDown is executed, then next suite may be started (default in FULL mode) +''' FAILIMMEDIATESTOP = 2 ' Stop immediately (default in SIMPLE mode) +''' In simple mode, only FAILIGNORE and FAILIMMEDIATESTOP are allowed. +''' In both modes, when WhenAssertionFails has not the value FAILIGNORE, +''' each test case MUST have a run-time error handler calling the ReportError() method. +''' Example: +''' Sub Test_sometest(Optional test) +''' On Local Error GoTo CatchError +''' ' ... one or more assert verbs +''' Exit Sub +''' CatchError: +''' test.ReportError() +''' End Sub + WhenAssertionFails = _PropertyGet("WhenAssertionFails") +End Property ' SFUnitTests.SF_UnitTest.WhenAssertionFails (get) + +REM ----------------------------------------------------------------------------- +Property Let WhenAssertionFails(Optional ByVal pvWhenAssertionFails As Variant) +''' Set the updatable property WhenAssertionFails + _PropertySet("WhenAssertionFails", pvWhenAssertionFails) +End Property ' SFUnitTests.SF_UnitTest.WhenAssertionFails (let) + +REM ===================================================================== METHODS + +REM ----------------------------------------------------------------------------- +Public Function AssertAlmostEqual(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Tolerance As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A and B are numerical values and are found close to each other. +''' It is typically used to compare very large or very small numbers. +''' Equality is confirmed when +''' - A and B can be converted to doubles +''' - The absolute difference between a and b, relative to the larger absolute value of a or b, +''' is lower or equal to the tolerance. The default tolerance is 1E-09, +''' Examples: 1E+12 and 1E+12 + 100 are almost equal +''' 1E-20 and 2E-20 are not almost equal +''' 100 and 95 are almost equal when Tolerance = 0.05 + +Dim bAssert As Boolean ' Return value +Const cstTolerance = 1E-09 +Const cstThisSub = "UnitTest.AssertAlmostEqual" +Const cstSubArgs = "A, B, [Tolerance=1E-09], [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Tolerance) Then Tolerance = cstTolerance + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(Tolerance, "Tolerance", ScriptForge.V_NUMERIC) Then GoTo Catch + +Try: + bAssert = _Assert("AssertAlmostEqual", True, A, B, Message, Tolerance) + +Finally: + AssertAlmostEqual = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertAlmostEqual + +REM ----------------------------------------------------------------------------- +Public Function AssertEqual(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A and B are found equal. +''' Equality is confirmed when +''' If A and B are scalars: +''' They should have the same VarType or both be numeric +''' Booleans and numeric values are compared with the = operator +''' Strings are compared with the StrComp() builtin function. The comparison is case-sensitive +''' Dates and times are compared up to the second +''' Null, Empty and Nothing are not equal, but AssertEqual(Nothing, Nothing) returns True +''' UNO objects are compared with the EqualUnoObjects() method +''' Basic objects are NEVER equal +''' If A and B are arrays: +''' They should have the same number of dimensions (maximum 2) +''' The lower and upper bounds must be identical for each dimension +''' Two empty arrays are equal +''' Their items must be equal one by one + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertEqual" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertEqual", True, A, B, Message) + +Finally: + AssertEqual = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertEqual + +REM ----------------------------------------------------------------------------- +Public Function AssertFalse(Optional ByRef A As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is a Boolean and its value is False + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertFalse" +Const cstSubArgs = "A, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertFalse", True, A, Empty, Message) + +Finally: + AssertFalse = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertFalse + +REM ----------------------------------------------------------------------------- +Public Function AssertGreater(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is greater than B. +''' To compare A and B: +''' They should have the same VarType or both be numeric +''' Eligible datatypes are String, Date or numeric. +''' String comparisons are case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertGreater" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertGreater", True, A, B, Message) + +Finally: + AssertGreater = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertGreater + +REM ----------------------------------------------------------------------------- +Public Function AssertGreaterEqual(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is greater than or equal to B. +''' To compare A and B: +''' They should have the same VarType or both be numeric +''' Eligible datatypes are String, Date or numeric. +''' String comparisons are case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertGreaterEqual" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertGreaterEqual", True, A, B, Message) + +Finally: + AssertGreaterEqual = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertGreaterEqual + +REM ----------------------------------------------------------------------------- +Public Function AssertIn(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A, a string, is found within B +''' B may be a 1D array, a ScriptForge dictionary or a string. +''' When B is an array, A may be a date or a numeric value. +''' String comparisons are case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertIn" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertIn", True, A, B, Message) + +Finally: + AssertIn = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertIn + +REM ----------------------------------------------------------------------------- +Public Function AssertIsInstance(Optional ByRef A As Variant _ + , Optional ByRef ObjectType As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is an object instance of the class ObjectType or a variable of type ObjectType. +''' A may be: +''' - a ScriptForge object +''' ObjectType is a string like "DICTIONARY", "calc", "Dialog", "exception", etc. +''' - a UNO object +''' ObjectType is a string identical with values returned by the SF_Session.UnoObjectType() +''' - any variable, providing it is neither an object nor an array +''' ObjectType is a string identifying a value returned by the TypeName() builtin function +''' - an array +''' ObjectType is expected to be "array" + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertIsInstance" +Const cstSubArgs = "A, ObjectType, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(ObjectType) Then ObjectType = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(ObjectType, "ObjectType", V_STRING) Then GoTo Catch + + +Try: + bAssert = _Assert("AssertIsInstance", True, A, Empty, Message, ObjectType) + +Finally: + AssertIsInstance = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertIsInstance + +REM ----------------------------------------------------------------------------- +Public Function AssertIsNothing(Optional ByRef A As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is an object that has the Nothing value + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertIsNothing" +Const cstSubArgs = "A, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertIsNothing", True, A, Empty, Message) + +Finally: + AssertIsNothing = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertIsNothing + +REM ----------------------------------------------------------------------------- +Public Function AssertIsNull(Optional ByRef A As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A has the Null value + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertIsNull" +Const cstSubArgs = "A, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertIsNull", True, A, Empty, Message) + +Finally: + AssertIsNull = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertIsNull + +REM ----------------------------------------------------------------------------- +Public Function AssertLess(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is less than B. +''' To compare A and B: +''' They should have the same VarType or both be numeric +''' Eligible datatypes are String, Date or numeric. +''' String comparisons are case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertLess" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertLess", False, A, B, Message) + +Finally: + AssertLess = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertLess + +REM ----------------------------------------------------------------------------- +Public Function AssertLessEqual(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is less than or equal to B. +''' To compare A and B: +''' They should have the same VarType or both be numeric +''' Eligible datatypes are String, Date or numeric. +''' String comparisons are case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertLessEqual" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertLessEqual", False, A, B, Message) + +Finally: + AssertLessEqual = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertLessEqual + +REM ----------------------------------------------------------------------------- +Public Function AssertLike(Optional ByRef A As Variant _ + , Optional ByRef Pattern As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True if string A matches a given pattern containing wildcards +''' Admitted wildcard are: the "?" represents any single character +''' the "*" represents zero, one, or multiple characters +''' The comparison is case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertLike" +Const cstSubArgs = "A, Pattern, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Pattern) Then Pattern = "" + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(Pattern, "Pattern", V_STRING) Then GoTo Catch + +Try: + bAssert = _Assert("AssertLike", True, A, Empty, Message, Pattern) + +Finally: + AssertLike = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertLike + +REM ----------------------------------------------------------------------------- +Public Function AssertNotAlmostEqual(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Tolerance As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A and B are numerical values and are not found close to each other. +''' Read about almost equality in the comments linked to the AssertEqual() method. + +Dim bAssert As Boolean ' Return value +Const cstTolerance = 1E-09 +Const cstThisSub = "UnitTest.AssertNotAlmostEqual" +Const cstSubArgs = "A, B, [Tolerance=1E-09], [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Tolerance) Then Tolerance = cstTolerance + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(Tolerance, "Tolerance", ScriptForge.V_NUMERIC) Then GoTo Catch + +Try: + bAssert = _Assert("AssertNotAlmostEqual", False, A, B, Message, Tolerance) + +Finally: + AssertNotAlmostEqual = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertNotAlmostEqual + +REM ----------------------------------------------------------------------------- +Public Function AssertNotEqual(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A and B are found unequal. +''' Read about equality in the comments linked to the AssertEqual() method. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertNotEqual" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertNotEqual", False, A, B, Message) + +Finally: + AssertNotEqual = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertNotEqual + +REM ----------------------------------------------------------------------------- +Public Function AssertNotIn(Optional ByRef A As Variant _ + , Optional ByRef B As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A, a string, is not found within B +''' B may be a 1D array, a ScriptForge dictionary or a string. +''' When B is an array, A may be a date or a numeric value. +''' String comparisons are case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertNotIn" +Const cstSubArgs = "A, B, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(B) Then B = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertNotIn", False, A, B, Message) + +Finally: + AssertNotIn = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertNotIn + +REM ----------------------------------------------------------------------------- +Public Function AssertNotInstance(Optional ByRef A As Variant _ + , Optional ByRef ObjectType As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is an object instance of the class ObjectType or a variable of type ObjectType. +''' More details to be read under the AssertInstance() function. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertNotInstance" +Const cstSubArgs = "A, ObjectType, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(ObjectType) Then ObjectType = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(ObjectType, "ObjectType", V_STRING) Then GoTo Catch + +Try: + bAssert = _Assert("AssertNotInstance", False, A, Empty, Message, ObjectType) + +Finally: + AssertNotInstance = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertNotInstance + +REM ----------------------------------------------------------------------------- +Public Function AssertNotLike(Optional ByRef A As Variant _ + , Optional ByRef Pattern As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True if A is not a string or does not match a given pattern containing wildcards +''' Admitted wildcard are: the "?" represents any single character +''' the "*" represents zero, one, or multiple characters +''' The comparison is case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertNotLike" +Const cstSubArgs = "A, Pattern, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Pattern) Then Pattern = "" + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(Pattern, "Pattern", V_STRING) Then GoTo Catch + +Try: + bAssert = _Assert("AssertNotLike", False, A, Empty, Message, Pattern) + +Finally: + AssertNotLike = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertNotLike + +REM ----------------------------------------------------------------------------- +Public Function AssertNotNothing(Optional ByRef A As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True except when A is an object that has the Nothing value + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertNotNothing" +Const cstSubArgs = "A, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertNotNothing", False, A, Empty, Message) + +Finally: + AssertNotNothing = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertNotNothing + +REM ----------------------------------------------------------------------------- +Public Function AssertNotNull(Optional ByRef A As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True except when A has the Null value + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertNotNull" +Const cstSubArgs = "A, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertNotNull", False, A, Empty, Message) + +Finally: + AssertNotNull = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertNotNull + +REM ----------------------------------------------------------------------------- +Public Function AssertNotRegex(Optional ByRef A As Variant _ + , Optional ByRef Regex As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is not a string or does not match the given regular expression. +''' The comparison is case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertNotRegex" +Const cstSubArgs = "A, Regex, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Regex) Then Regex = "" + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(Regex, "Regex", V_STRING) Then GoTo Catch + +Try: + bAssert = _Assert("AssertNotRegex", False, A, Empty, Message, Regex) + +Finally: + AssertNotRegex = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertNotRegex + +REM ----------------------------------------------------------------------------- +Public Function AssertRegex(Optional ByRef A As Variant _ + , Optional ByRef Regex As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when string A matches the given regular expression. +''' The comparison is case-sensitive. + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertRegex" +Const cstSubArgs = "A, Regex, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Regex) Then Regex = "" + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(Regex, "Regex", V_STRING) Then GoTo Catch + +Try: + bAssert = _Assert("AssertRegex", True, A, Empty, Message, Regex) + +Finally: + AssertRegex = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + bAssert = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.AssertRegex + +REM ----------------------------------------------------------------------------- +Public Function AssertTrue(Optional ByRef A As Variant _ + , Optional ByVal Message As Variant _ + ) As Boolean +''' Returns True when A is a Boolean and its value is True + +Dim bAssert As Boolean ' Return value +Const cstThisSub = "UnitTest.AssertTrue" +Const cstSubArgs = "A, [Message=""""]" + +Check: + If IsMissing(A) Then A = Empty + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("AssertTrue", True, A, Empty, Message) + +Finally: + AssertTrue = bAssert + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest.AssertTrue + +REM ----------------------------------------------------------------------------- +Public Sub Fail(Optional ByVal Message As Variant) +''' Forces a test failure + +Dim bAssert As Boolean ' Fictive return value +Const cstThisSub = "UnitTest.Fail" +Const cstSubArgs = "[Message=""""]" + +Check: + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + bAssert = _Assert("Fail", False, Empty, Empty, Message) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +End Sub ' SFUnitTests.SF_UnitTest.Fail + +REM ----------------------------------------------------------------------------- +Public Sub Log(Optional ByVal Message As Variant) +''' Records the given message in the test report (console) + +Dim bAssert As Boolean ' Fictive return value +Dim bVerbose As Boolean : bVerbose = _Verbose +Const cstThisSub = "UnitTest.Log" +Const cstSubArgs = "[Message=""""]" + +Check: + If IsMissing(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + +Try: + ' Force the display of the message in the console + _Verbose = True + bAssert = _Assert("Log", True, Empty, Empty, Message) + _Verbose = bVerbose + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +End Sub ' SFUnitTests.SF_UnitTest.Log + +REM ----------------------------------------------------------------------------- +Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant +''' Return the actual value of the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Returns: +''' The actual value of the property +''' Exceptions +''' ARGUMENTERROR The property does not exist +''' Examples: +''' myUnitTest.GetProperty("Duration") + +Const cstThisSub = "UnitTest.GetProperty" +Const cstSubArgs = "PropertyName" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + GetProperty = Null + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + GetProperty = _PropertyGet(PropertyName) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.Properties + +REM ----------------------------------------------------------------------------- +Public Function Methods() As Variant +''' Return the list or methods of the UnitTest class as an array + + Methods = Array( _ + "AssertAlmostEqual" _ + , "AssertEqual" _ + , "AssertFalse" _ + , "AssertGreater" _ + , "AssertGreaterEqual" _ + , "AssertIn" _ + , "AssertIsInstance" _ + , "AssertIsNothing" _ + , "AssertLike" _ + , "AssertNotRegex" _ + , "AssertIsNull" _ + , "AssertLess" _ + , "AssertLessEqual" _ + , "AssertNotAlmostEqual" _ + , "AssertNotEqual" _ + , "AssertNotIn" _ + , "AssertNotInstance" _ + , "AssertNotLike" _ + , "AssertNotNothing" _ + , "AssertNotNull" _ + , "AssertRegex" _ + , "AssertTrue" _ + , "Fail" _ + , "Log" _ + , "RunTest" _ + , "SkipTest" _ + ) + +End Function ' SFUnitTests.SF_UnitTest.Methods + +REM ----------------------------------------------------------------------------- +Public Function Properties() As Variant +''' Return the list or properties of the UnitTest class as an array + + Properties = Array( _ + "LongMessage" _ + , "ReturnCode" _ + , "Verbose" _ + , "WhenAssertionFails" _ + ) + +End Function ' SFUnitTests.SF_UnitTest.Properties + +REM ----------------------------------------------------------------------------- +Public Sub ReportError(Optional ByVal Message As Variant) +''' DIsplay a message box with the current property values of the "Exception" service. +''' Depending on the WhenAssertionFails property, a Raise() or RaiseWarning() +''' is issued. The Raise() method stops completely the Basic running process. +''' The ReportError() method is presumed present in a user script in an error +''' handling part of the actual testcase. +''' Args: +''' Message: a string to replace or to complete the standard message description +''' Example: +''' See the Test_ArraySize() sub in the module's heading example + +Dim sLine As String ' Line number where the error occurred +Dim sError As String ' Exception description +Dim sErrorCode As String ' Exception number +Const cstThisSub = "UnitTest.ReportError" +Const cstSubArgs = "[Message=""""]" + +Check: + If IsMissing(Message) Or IsEmpty(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If VarType(Message) <> V_STRING Then Message = "" + +Try: + sLine = "ln " & CStr(Exception.Source) + If _ExecutionMode = FULLMODE Then sLine = _Module & "." & _TestCase & " " & sLine + If Len(Message) > 0 Then + sError = Message + Else + If Exception.Number = INVALIDPROCEDURECALL Then + sError = "Test case failure" + sErrorCode = "ASSERTIONFAILED" + Else + sError = Exception.Description + sErrorCode = CStr(Exception.Number) + End If + End If + + Select Case _WhenAssertionFails + Case FAILIGNORE + Case FAILSTOPSUITE + Exception.RaiseWarning(sErrorCode, sLine, sError) + Case FAILIMMEDIATESTOP + Exception.Raise(sErrorCode, sLine, sError) + End Select + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Sub +End Sub ' SFUnitTests.SF_UnitTest.ReportError +REM ----------------------------------------------------------------------------- +Public Function RunTest(Optional ByVal TestSuite As Variant _ + , Optional ByVal TestCasePattern As Variant _ + , Optional ByVal Message As Variant _ + ) As Integer +''' Execute a test suite pointed out by a module name. +''' Each test case will be run independently from each other. +''' The names of the test cases to be run may be selected with a string pattern. +''' The test is "orchestrated" by this method: +''' 1. Execute the optional Setup() method present in the module +''' 2. Execute once each test case, in any order +''' 3, Execute the optional TearDown() method present in the module +''' Args: +''' TestSuite: the name of the module containing the set of test cases to run +''' TestCasePattern: the pattern that the test cases must match. The comparison is not case-sensitive. +''' Non-matching functions and subs are ignored. +''' Admitted wildcard are: the "?" represents any single character +''' the "*" represents zero, one, or multiple characters +''' The default pattern is "Test_*" +''' Message: the message to be displayed in the console when the test starts. +''' Returns: +''' One of the return codes of the execution (RCxxx constants) +''' Examples: +''' GlobalScope.BasicLibraries.loadLibrary("ScriptForge") +''' Dim test : test = CreateScriptService("UnitTest", ThisComponent, "Tests") +''' test.RunTest("AllTests") ' AllTests is a module name ; test cases are named "Test_*" (default) + +Dim iRun As Integer ' Return value +Dim sRunMessage As String ' Reporting +Dim iModule As Integer ' Index of module currently running +Dim vMethods As Variant ' Set of methods +Dim sMethod As String ' A single method +Dim iMethod As Integer ' Index in MethodNames +Dim m As Integer + +Const cstThisSub = "UnitTest.RunTest" +Const cstSubArgs = "TestSuite, [TestCasePattern=""Test_*""], [Message=""""]" + + iRun = RCNORMALEND + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(TestCasePattern) Or IsEmpty(TestCasePattern) Then TestCasePattern = "Test_*" + If IsMissing(Message) Or IsEmpty(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(TestSuite, "TestSuite", V_STRING, ModuleNames) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(TestCasePattern, "TestCasePattern", V_STRING) Then GoTo Catch + If Not ScriptForge.SF_Utils._Validate(Message, "Message", V_STRING) Then GoTo Catch + + ' A RunTest() is forbidden inside a test suite or when simple mode + If _Status <> STATUSSTANDBY Or _ExecutionMode <> FULLMODE Then GoTo CatchMethod + + ' Ignore any call when an abnormal end has been encountered + If _ReturnCode = RCABORTTEST Then GoTo Catch + +Try: + iModule = ScriptForge.SF_Array.IndexOf(ModuleNames, TestSuite, CaseSensitive := False, SortOrder := "ASC") + _Module = ModuleNames(iModule) + + ' Start timer + If Not IsNull(SuiteTimer) Then SuiteTimer = SuiteTimer.Dispose() + Set SuiteTimer = CreateScriptService("ScriptForge.Timer", True) + + ' Report the start of a new test suite + sRunMessage = "RUNTEST ENTER testsuite='" & LibraryName & "." & _Module & "', pattern='" & TestCasePattern & "'" + _ReportMessage(sRunMessage, Message) + _Status = STATUSSUITESTARTED + + ' Collect all the methods of the module + If Modules(iModule).hasChildNodes() Then + vMethods = Modules(iModule).getChildNodes() + MethodNames = Array() + For m = 0 To UBound(vMethods) + sMethod = vMethods(m).getName() + MethodNames = ScriptForge.SF_Array.Append(MethodNames, sMethod) + Next m + End If + + ' Execute the Setup() method, if it exists + iMethod = ScriptForge.SF_Array.IndexOf(MethodNames, "Setup", CaseSensitive := False, SortOrder := "ASC") + If iMethod >= 0 Then + _TestCase = MethodNames(iMethod) ' _TestCase is used in ReportError() + If Not _ExecuteScript(_TestCase) Then GoTo Catch + End If + + ' Execute the test cases that match the pattern + For iMethod = 0 To UBound(MethodNames) + If _ReturnCode = RCSKIPTEST Or _ReturnCode = RCASSERTIONFAILED Then Exit For + sMethod = MethodNames(iMethod) + If ScriptForge.SF_String.IsLike(sMethod, TestCasePattern, CaseSensitive := False) Then + _TestCase = sMethod + ' Start timer + If Not IsNull(CaseTimer) Then CaseTimer = CaseTimer.Dispose() + Set CaseTimer = CreateScriptService("ScriptForge.Timer", True) + If Not _ExecuteScript(sMethod) Then GoTo Catch + CaseTimer.Terminate() + _TestCase = "" + End If + Next iMethod + + If _ReturnCode <> RCSKIPTEST Then + ' Execute the TearDown() method, if it exists + iMethod = ScriptForge.SF_Array.IndexOf(MethodNames, "TearDown", CaseSensitive := False, SortOrder := "ASC") + If iMethod >= 0 Then + _TestCase = MethodNames(iMethod) ' _TestCase is used in ReportError() + If Not _ExecuteScript(_TestCase) Then GoTo Catch + End If + End If + + ' Report the end of the current test suite + sRunMessage = "RUNTEST EXIT testsuite='" & LibraryName & "." & _Module & "' " & _Duration("Suite", True) + _ReportMessage(sRunMessage, Message) + + ' Stop timer + SuiteTimer.Terminate() + + ' Housekeeping + MethodNames = Array() + _Module = "" + _Status = STATUSSTANDBY + +Finally: + _ReturnCode = iRun + RunTest = iRun + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + iRun = RCABORTTEST + GoTo Finally +CatchMethod: + ScriptForge.SF_Exception.RaiseFatal(UNITTESTMETHODERROR, "RunTest") + GoTo Catch +End Function ' SFUnitTests.SF_UnitTest.RunTest + +REM ----------------------------------------------------------------------------- +Public Function SetProperty(Optional ByVal PropertyName As Variant _ + , Optional ByRef Value As Variant _ + ) As Boolean +''' Set a new value to the given property +''' Args: +''' PropertyName: the name of the property as a string +''' Value: its new value +''' Exceptions +''' ARGUMENTERROR The property does not exist + +Const cstThisSub = "UnitTest.SetProperty" +Const cstSubArgs = "PropertyName, Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + SetProperty = False + +Check: + If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then + If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch + End If + +Try: + SetProperty = _PropertySet(PropertyName, Value) + +Finally: + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest.SetProperty + +REM ----------------------------------------------------------------------------- +Public Function SkipTest(Optional ByVal Message As Variant) As Boolean +''' Interrupt the running test suite. The TearDown() method is NOT executed. +''' The SkipTest() method is normally meaningful only in a Setup() method when not all the +''' conditions to run the test are met. +''' It is up to the Setup() script to exit shortly after the SkipTest() call.. +''' The method may also be executed in a test case. Next test cases will not be executed. +''' Remember however that the test cases are executed is an arbitrary order. +''' Args: +''' Message: the message to be displayed in the console +''' Returns: +''' True when successful +''' Examples: +''' GlobalScope.BasicLibraries.loadLibrary("ScriptForge") +''' Dim test : test = CreateScriptService("UnitTest", ThisComponent, "Tests") +''' test.SkipTest("AllTests") ' AllTests is a module name ; test cases are named "Test_*" (default) + +Dim bSkip As Boolean ' Return value +Dim sSkipMessage As String ' Reporting + +Const cstThisSub = "UnitTest.SkipTest" +Const cstSubArgs = "[Message=""""]" + + bSkip = False + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(Message) Or IsEmpty(Message) Then Message = "" + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional ! + If Not ScriptForge.SF_Utils._Validate(Message, "Message", V_STRING) Then GoTo Catch + + ' A SkipTest() is forbidden when simple mode + If _ExecutionMode <> FULLMODE Then GoTo CatchMethod + + ' Ignore any call when an abnormal end has been encountered + If _ReturnCode = RCABORTTEST Then GoTo Catch + +Try: + If _Status = STATUSSETUP Or _Status = STATUSTESTCASE Then + _ReturnCode = RCSKIPTEST + bSkip = True + ' Exit message + sSkipMessage = " SKIPTEST testsuite='" & LibraryName & "." & _Module & "' " & _Duration("Suite", True) + _ReportMessage(sSkipMessage, Message) + End If + +Finally: + SkipTest = bSkip + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + _ReturnCode = RCABORTTEST + GoTo Finally +CatchMethod: + ScriptForge.SF_Exception.RaiseFatal(UNITTESTMETHODERROR, "SkipTest") + GoTo Catch +End Function ' SFUnitTests.SF_UnitTest.SkipTest + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _Assert(ByVal psAssert As String _ + , ByVal pvReturn As Variant _ + , ByRef A As Variant _ + , ByRef B As Variant _ + , Optional ByVal pvMessage As Variant _ + , Optional ByVal pvArg As Variant _ + ) As Boolean +''' Evaluation of the assertion and management of the success or the failure +''' Args: +''' psAssert: the assertion verb as a string +''' pvReturn: may be True, False or Empty +''' When True (resp. False), the assertion must be evaluated as True (resp. False) +''' e.g. AssertEqual() will call _Assert("AssertEqual", True, ...) +''' AssertNotEqual() will call _Assert("AssertNotEqual", False, ...) +''' Empty may be used for recursive calls of the function (for comparing arrays, ...) +''' A: always present +''' B: may be empty +''' pvMessage: the message to display on the console +''' pvArg: optional additional argument of the assert function +''' Returns: +''' True when success + +Dim bAssert As Boolean ' Return value +Dim bEval As Boolean ' To be compared with pvReturn +Dim iVarTypeA As Integer ' Alias of _VarTypeExt(A) +Dim iVarTypeB As Integer ' Alias of _VarTypeExt(B) +Dim oVarTypeObjA As Object ' SF_Utils.ObjectDescriptor +Dim oVarTypeObjB As Object ' SF_Utils.ObjectDescriptor +Dim oUtils As Object : Set oUtils = ScriptForge.SF_Utils +Dim iDims As Integer ' Number of dimensions of array +Dim oAliasB As Object ' Alias of B to bypass the "Object variable not set" issue +Dim dblA As Double ' Alias of A +Dim dblB As Double ' Alias of B +Dim dblTolerance As Double ' Alias of pvArg +Dim oString As Object : Set oString = ScriptForge.SF_String +Dim sArgName As String ' Argument description +Dim i As Long, j As Long + +Check: + bAssert = False + If IsMissing(pvMessage) Then pvMessage = "" + If Not oUtils._Validate(pvMessage, "Message", V_STRING) Then GoTo Finally + If IsMissing(pvArg) Then pvArg = "" + +Try: + iVarTypeA = oUtils._VarTypeExt(A) + iVarTypeB = oUtils._VarTypeExt(B) + sArgName = "" + + Select Case UCase(psAssert) + Case UCase("AssertAlmostEqual"), UCase("AssertNotAlmostEqual") + bEval = ( iVarTypeA = iVarTypeB And iVarTypeA = ScriptForge.V_NUMERIC ) + If bEval Then + dblA = CDbl(A) + dblB = CDbl(B) + dblTolerance = Abs(CDbl(pvArg)) + bEval = ( Abs(dblA - dblB) <= (dblTolerance * Iif(Abs(dblA) > Abs(DblB), Abs(dblA), Abs(dblB))) ) + End If + Case UCase("AssertEqual"), UCase("AssertNotEqual") + If Not IsArray(A) Then + bEval = ( iVarTypeA = iVarTypeB ) + If bEval Then + Select Case iVarTypeA + Case V_EMPTY, V_NULL + Case V_STRING + bEval = ( StrComp(A, B, 1) = 0 ) + Case ScriptForge.V_NUMERIC, ScriptForge.V_BOOLEAN + bEval = ( A = B ) + Case V_DATE + bEval = ( Abs(DateDiff("s", A, B)) = 0 ) + Case ScriptForge.V_OBJECT + Set oVarTypeObjA = oUtils._VarTypeObj(A) + Set oVarTypeObjB = oUtils._VarTypeObj(B) + bEval = ( oVarTypeObjA.iVarType = oVarTypeObjB.iVarType ) + If bEval Then + Select Case oVarTypeObjA.iVarType + Case ScriptForge.V_NOTHING + Case ScriptForge.V_UNOOBJECT + bEval = EqualUnoObjects(A, B) + Case ScriptForge.V_SFOBJECT, ScriptForge.V_BASICOBJECT + bEval = False + End Select + End If + End Select + End If + Else ' Compare arrays + bEval = IsArray(B) + If bEval Then + iDims = ScriptForge.SF_Array.CountDims(A) + bEval = ( iDims = ScriptForge.SF_Array.CountDims(B) And iDims <= 2 ) + If bEval Then + Select Case iDims + Case -1, 0 ' Scalars (not possible) or empty arrays + Case 1 ' 1D array + bEval = ( LBound(A) = LBound(B) And UBound(A) = UBound(B) ) + If bEval Then + For i = LBound(A) To UBound(A) + bEval = _Assert(psAssert, Empty, A(i), B(i)) + If Not bEval Then Exit For + Next i + End If + Case 2 ' 2D array + bEval = ( LBound(A, 1) = LBound(B, 1) And UBound(A, 1) = UBound(B, 1) _ + And LBound(A, 2) = LBound(B, 2) And UBound(A, 2) = UBound(B, 2) ) + If bEval Then + For i = LBound(A, 1) To UBound(A, 1) + For j = LBound(A, 2) To UBound(A, 2) + bEval = _Assert(psAssert, Empty, A(i, j), B(i, j)) + If Not bEval Then Exit For + Next j + If Not bEval Then Exit For + Next i + End If + End Select + End If + End If + End If + Case UCase("AssertFalse") + If iVarTypeA = ScriptForge.V_BOOLEAN Then bEval = Not A Else bEval = False + Case UCase("AssertGreater"), UCase("AssertLessEqual") + bEval = ( iVarTypeA = iVarTypeB _ + And (iVarTypeA = ScriptForge.V_NUMERIC Or iVarTypeA = V_STRING Or iVarTypeA = V_DATE) ) + If bEval Then bEval = ( A > B ) + Case UCase("AssertGreaterEqual"), UCase("AssertLess") + bEval = ( iVarTypeA = iVarTypeB _ + And (iVarTypeA = ScriptForge.V_NUMERIC Or iVarTypeA = V_STRING Or iVarTypeA = V_DATE) ) + If bEval Then bEval = ( A >= B ) + Case UCase("AssertIn"), UCase("AssertNotIn") + Set oVarTypeObjB = oUtils._VarTypeObj(B) + Select Case True + Case iVarTypeA = V_STRING And iVarTypeB = V_STRING + bEval = ( Len(A) > 0 And Len(B) > 0 ) + If bEval Then bEval = ( InStr(1, B, A, 0) > 0 ) + Case (iVarTypeA = V_DATE Or iVarTypeA = V_STRING Or iVarTypeA = ScriptForge.V_NUMERIC) _ + And iVarTypeB >= ScriptForge.V_ARRAY + bEval = ( ScriptForge.SF_Array.CountDims(B) = 1 ) + If bEval Then bEval = ScriptForge.SF_Array.Contains(B, A, CaseSensitive := True) + Case oVarTypeObjB.iVarType = ScriptForge.V_SFOBJECT And oVarTypeObjB.sObjectType = "DICTIONARY" + bEval = ( Len(A) > 0 ) + If bEval Then + Set oAliasB = B + bEval = ScriptForge.SF_Array.Contains(oAliasB.Keys(), A, CaseSensitive := True) + End If + Case Else + bEval = False + End Select + Case UCase("AssertIsInstance"), UCase("AssertNotInstance") + Set oVarTypeObjA = oUtils._VarTypeObj(A) + sArgName = "ObjectType" + With oVarTypeObjA + Select Case .iVarType + Case ScriptForge.V_UNOOBJECT + bEval = ( pvArg = .sObjectType ) + Case ScriptForge.V_SFOBJECT + bEval = ( UCase(pvArg) = UCase(.sObjectType) Or UCase(pvArg) = "SF_" & UCase(.sObjectType) _ + Or UCase(pvArg) = UCase(.sServiceName) ) + Case ScriptForge.V_NOTHING, ScriptForge.V_BASICOBJECT + bEval = False + Case >= ScriptForge.V_ARRAY + bEval = ( UCase(pvArg) = "ARRAY" ) + Case Else + bEval = ( UCase(TypeName(A)) = UCase(pvArg) ) + End Select + End With + Case UCase("AssertIsNothing"), UCase("AssertNotNothing") + bEval = ( iVarTypeA = ScriptForge.V_OBJECT ) + If bEval Then bEval = ( A Is Nothing ) + Case UCase("AssertIsNull"), UCase("AssertNotNull") + bEval = ( iVarTypeA = V_NULL ) + Case UCase("AssertLike"), UCase("AssertNotLike") + sArgName = "Pattern" + bEval = ( iVarTypeA = V_STRING And Len(pvArg) > 0 ) + If bEval Then bEval = oString.IsLike(A, pvArg, CaseSensitive := True) + Case UCase("AssertRegex"), UCase("AssertNotRegex") + sArgName = "Regex" + bEval = ( iVarTypeA = V_STRING And Len(pvArg) > 0 ) + If bEval Then bEval = oString.IsRegex(A, pvArg, CaseSensitive := True) + Case UCase("AssertTrue") + If iVarTypeA = ScriptForge.V_BOOLEAN Then bEval = A Else bEval = False + Case UCase("FAIL"), UCase("Log") + bEval = True + Case Else + End Select + + ' Check the result of the assertion vs. what it should be + If IsEmpty(pvReturn) Then + bAssert = bEval ' Recursive call => Reporting and failure management are done by calling _Assert() procedure + Else ' pvReturn is Boolean => Call from user script + bAssert = Iif(pvReturn, bEval, Not bEval) + ' Report the assertion evaluation + If _Verbose Or Not bAssert Then + _ReportMessage(" " & psAssert _ + & Iif(IsEmpty(A), "", " = " & bAssert & ", A = " & oUtils._Repr(A)) _ + & Iif(IsEmpty(B), "", ", B = " & oUtils._Repr(B)) _ + & Iif(Len(sArgName) = 0, "", ", " & sArgName & " = " & pvArg) _ + , pvMessage) + End If + ' Manage assertion failure + If Not bAssert Then + _FailedAssert = psAssert + Select Case _WhenAssertionFails + Case FAILIGNORE ' Do nothing + Case Else + _ReturnCode = RCASSERTIONFAILED + ' Cause artificially a run-time error + Dim STRINGBADUSE As String + + '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + '+ To avoid a run-time error on next executable statement, + + '+ insert an error handler in the code of your test case: + + '+ Like in next code: + + '+ On Local Error GoTo Catch + + '+ ... + + '+ Catch: + + '+ myTest.ReportError() + + '+ Exit Sub + + '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + STRINGBADUSE = Right("", -1) ' Raises "#5 - Invalid procedure call" error + + End Select + End If + End If + +Finally: + _Assert = bAssert + Exit Function + +End Function ' SFUnitTests.SF_UnitTest._Assert + +REM ----------------------------------------------------------------------------- +Private Function _Duration(ByVal psTimer As String _ + , Optional ByVal pvBrackets As Variant _ + ) As String +''' Return the Duration property of the given timer +''' or the empty string if the timer is undefined or not started +''' Args: +''' psTimer: "Test", "Suite" or "TestCase" +''' pbBrackets: surround with brackets when True. Default = False + +Dim sDuration As String ' Return value +Dim oTimer As Object ' Alias of psTimer + +Check: + If IsMissing(pvBrackets) Or IsEmpty(pvBrackets) Then pvBrackets = False + +Try: + Select Case psTimer + Case "Test" : Set oTimer = TestTimer + Case "Suite" : Set oTimer = SuiteTimer + Case "TestCase", "Case" : Set oTimer = CaseTimer + End Select + If Not IsNull(oTimer) Then + sDuration = CStr(oTimer.Duration) & " " + If pvBrackets Then sDuration = "(" & Trim(sDuration) & " sec)" + Else + sDuration = "" + End If + +Finally: + _Duration = sDuration +End Function ' SFUnitTests.SF_UnitTest._Duration + +REM ----------------------------------------------------------------------------- +Private Function _ExecuteScript(psMethod As String) As Boolean +''' Run the given method and report start and stop +''' The targeted method is presumed not to return anything (Sub) +''' Args: +''' psMethod: the scope, the library and the module are predefined in the instance internals +''' Returns: +''' True when successful + +Dim bExecute As Boolean ' Return value +Dim sRun As String ' SETUP, TEARDOWN or TESTCASE + + On Local Error GoTo Catch + bExecute = True + +Try: + ' Set status before the effective execution + sRun = UCase(psMethod) + Select Case UCase(psMethod) + Case "SETUP" : _Status = STATUSSETUP + Case "TEARDOWN" : _Status = STATUSTEARDOWN + Case Else : _Status = STATUSTESTCASE + sRun = "TESTCASE" + End Select + + ' Report and execute + _ReportMessage(" " & sRun & " " & LibraryName & "." & _Module & "." & psMethod & "() ENTER") + Session.ExecuteBasicScript(Scope, LibraryName & "." & _Module & "." & psMethod, [Me]) + _ReportMessage(" " & sRun & " " & LibraryName & "." & _Module & "." & psMethod & "() EXIT" _ + & Iif(_STATUS = STATUSTESTCASE, " " & _Duration("Case", True), "")) + ' Reset status + _Status = STATUSSUITESTARTED + +Finally: + _ExecuteScript = bExecute + Exit Function +Catch: + bExecute = False + _ReturnCode = RCABORTTEST + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest._ExecuteScript + +REM ----------------------------------------------------------------------------- +Private Function _PropertyGet(Optional ByVal psProperty As String) +''' Return the named property +''' Args: +''' psProperty: the name of the property + +Dim cstThisSub As String +Dim cstSubArgs As String + + cstThisSub = "UnitTest.get" & psProperty + cstSubArgs = "" + SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + + Select Case UCase(psProperty) + Case UCase("LongMessage") + _PropertyGet = _LongMessage + Case UCase("ReturnCode") + _PropertyGet = _ReturnCode + Case UCase("Verbose") + _PropertyGet = _Verbose + Case UCase("WhenAssertionFails") + _PropertyGet = _WhenAssertionFails + Case Else + _PropertyGet = Null + End Select + +Finally: + SF_Utils._ExitFunction(cstThisSub) + Exit Function +End Function ' SFUnitTests.SF_UnitTest._PropertyGet + +REM ----------------------------------------------------------------------------- +Private Function _PropertySet(Optional ByVal psProperty As String _ + , Optional ByVal pvValue As Variant _ + ) As Boolean +''' Set the new value of the named property +''' Args: +''' psProperty: the name of the property +''' pvValue: the new value of the given property +''' Returns: +''' True if successful + +Dim bSet As Boolean ' Return value +Dim vWhenFailure As Variant ' WhenAssertionFails allowed values +Dim cstThisSub As String +Const cstSubArgs = "Value" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + bSet = False + + cstThisSub = "SFUnitTests.UnitTest.set" & psProperty + ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) + + bSet = True + Select Case UCase(psProperty) + Case UCase("LongMessage") + If Not ScriptForge.SF_Utils._Validate(pvValue, "LongMessage", ScriptForge.V_BOOLEAN) Then GoTo Finally + _LongMessage = pvValue + Case UCase("Verbose") + If Not ScriptForge.SF_Utils._Validate(pvValue, "Verbose", ScriptForge.V_BOOLEAN) Then GoTo Finally + _Verbose = pvValue + Case UCase("WhenAssertionFails") + If _ExecutionMode = SIMPLEMODE Then vWhenFailure = Array(0, 3) Else vWhenFailure = Array(0, 1, 2, 3) + If Not ScriptForge.SF_Utils._Validate(pvValue, "WhenAssertionFails", ScriptForge.V_NUMERIC, vWhenFailure) Then GoTo Finally + _WhenAssertionFails = pvValue + Case Else + bSet = False + End Select + +Finally: + _PropertySet = bSet + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest._PropertySet + +REM ----------------------------------------------------------------------------- +Private Function _ReportMessage(ByVal psSysMessage As String _ + , Optional ByVal pvMessage As Variant _ + ) As Boolean +''' Report in the console: +''' - either the standard message +''' - either the user message when not blank +''' - or both +''' Args: +''' psSysMessage: the standard message as built by the calling routine +''' psMessage: the message provided by the user script +''' Returns: +''' True when successful + +Dim bReport As Boolean ' Return value +Dim sIndent As String ' Indentation spaces + + bReport = False + On Local Error GoTo Catch + If IsMissing(pvMessage) Or IsEmpty(pvMessage) Then pvMessage = "" + +Try: + Select Case True + Case Len(pvMessage) = 0 + Exception.DebugPrint(psSysMessage) + Case _LongMessage + Exception.DebugPrint(psSysMessage, pvMessage) + Case Else + Select Case _Status + Case STATUSSTANDBY, STATUSSUITESTARTED : sIndent = "" + Case STATUSSUITESTARTED : sIndent = Space(2) + Case Else : sIndent = Space(4) + End Select + Exception.DebugPrint(sIndent & pvMessage) + End Select + +Finally: + _ReportMessage = bReport + Exit Function +Catch: + bReport = False + GoTo Finally +End Function ' SFUnitTests.SF_UnitTest._ReportMessage + +REM ----------------------------------------------------------------------------- +Private Function _Repr() As String +''' Convert the UnitTest instance to a readable string, typically for debugging purposes (DebugPrint ...) +''' Args: +''' Return: +''' "[UnitTest] + +Const cstUnitTest = "[UnitTest]" +Const cstMaxLength = 50 ' Maximum length for items + + _Repr = cstUnitTest + +End Function ' SFUnitTests.SF_UnitTest._Repr + +REM ============================================== END OF SFUNITTESTS.SF_UNITTEST +</script:module>
\ No newline at end of file |