Current File : //usr/lib/libreoffice/share/basic/SFUnitTests/SF_UnitTest.xba
<?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 = 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
</script:module>
Mini Shell