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 = ScriptForge.SF_Exception ' Do not use CreateScriptService to allow New SF_UnitTest from other libraries Set Session = ScriptForge.SF_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