1818 lines
No EOL
78 KiB
XML
1818 lines
No EOL
78 KiB
XML
<?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 := oAliasB.CaseSensitive)
|
|
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> |