| blob | baeef90de3b38b50d052257f3e43f379bf7e5f1a |
3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_UnitTest" script:language="StarBasic" script:moduleType="normal">REM =======================================================================================================================
4 REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. ===
5 REM === Full documentation is available on https://help.libreoffice.org/ ===
6 REM =======================================================================================================================
8 Option Compatible
9 Option ClassModule
11 Option Explicit
13 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
14 ''' SF_UnitTest
15 ''' ===========
16 ''' Class providing a framework to execute and check sets of unit tests.
17 '''
18 ''' The UnitTest unit testing framework was originally inspired by unittest.py in Python
19 ''' and has a similar flavor as major unit testing frameworks in other languages.
20 '''
21 ''' It supports test automation, sharing of setup and shutdown code for tests,
22 ''' aggregation of tests into collections.
23 '''
24 ''' Both the
25 ''' - code describing the unit tests
26 ''' - code to be tested
27 ''' must be written exclusively in Basic (the code might call functions written in other languages).
28 ''' Even if either code may be contained in the same module, a much better practice is to
29 ''' store them in separate libraries.
30 ''' Typically:
31 ''' - in a same document when the code to be tested is contained in that document
32 ''' - either in a "test" document or in a "My Macros" library when the code
33 ''' to be tested is a shared library (My Macros or LibreOffice Macros).
34 ''' The code to be tested may be released as an extension. It does not need to make
35 ''' use of ScriptForge services in any way.
36 '''
37 ''' The test reporting device is the Console. Read about the console in the ScriptForge.Exception service.
38 '''
39 ''' Definitions:
40 ''' - Test Case
41 ''' A test case is the individual unit of testing.
42 ''' It checks for a specific response to a particular set of inputs.
43 ''' A test case in the UnitTest service is represented by a Basic Sub.
45 ''' The test fails if one of the included AssertXXX methods returns False
46 ''' - Test Suite
47 ''' A test suite is a collection of test cases that should be executed together.
48 ''' A test suite is represented by a Basic module.
49 ''' A suite may include the tasks needed to prepare one or more tests, and any associated cleanup actions.
50 ''' This may involve, for example, creating temporary files or directories, opening a document, loading libraries.
51 ''' Conventionally those tasks are part pf the SetUp') and TearDown() methods.
52 ''' - Unit test
53 ''' A full unit test is a set of test suites (each suite in a separate Basic module),
54 ''' each of them being a set of test cases (each case is located in a separate Basic Sub).
55 '''
56 ''' Two modes:
57 ''' Beside the normal mode ("full mode"), using test suites and test cases, a second mode exists, called "simple mode"
58 ''' limited to the use exclusively of the Assert...() methods.
59 ''' Their boolean returned value may support the execution of limited unit tests.
60 '''
61 ''' Service invocation examples:
62 ''' In full mode, the service creation is external to test cases
63 ''' Dim myUnitTest As Variant
64 ''' myUnitTest = CreateScriptService("UnitTest", ThisComponent, "Tests")
65 ''' ' Test code is in the library "Tests" located in the current document
66 ''' In simple mode, the service creation is internal to every test case
67 ''' Dim myUnitTest As Variant
69 ''' With myUnitTest
70 ''' If Not .AssertTrue(...) Then ... ' Only calls to the Assert...() methods are allowed
71 ''' ' ...
72 ''' .Dispose()
73 ''' End With
74 '''
75 ''' Minimalist full mode example
76 ''' Code to be tested (stored in library "Standard" of document "MyDoc.ods") :
77 ''' Function ArraySize(arr As Variant) As Long
78 ''' If IsArray(arr) Then ArraySize = UBound(arr) - LBound(arr) + 1 Else ArraySize = -1
79 ''' End Function
80 ''' Test code (stored in module "AllTests" of library "Tests" of document "MyDoc.ods") :
81 ''' Sub Main() ' Sub to trigger manually, f.i. from the Tools + Run Macro tabbed bar
83 ''' Dim test : test = CreateScriptService("UnitTest", ThisComponent, "Tests")
84 ''' test.RunTest("AllTests") ' AllTests is a module name ; test cases are named "Test_*" (default)
85 ''' test.Dispose()
86 ''' End Sub
87 ''' REM ------------------------------------------------------------------------------
89 ''' ' Optional Sub to initialize processing of the actual test suite
92 ''' End Sub
93 ''' REM ------------------------------------------------------------------------------
94 ''' Sub Test_ArraySize(test)
95 ''' On Local Error GoTo CatchErr
98 ''' test.AssertEqual(ArraySize(DimArray(3)), 4, "When array with empty items")
99 ''' Exit Sub
100 ''' CatchErr:
102 ''' End Sub
103 ''' REM ------------------------------------------------------------------------------
104 ''' Sub TearDown(test)
105 ''' ' Optional Sub to finalize processing of the actual test suite
106 ''' End Sub
107 '''
108 ''' Error handling
109 ''' To support the debugging of the tested code, the UnitTest service, in cases of
110 ''' - assertion failure
111 ''' - Basic run-time error in the tested code
112 ''' - Basic run-time error in the testing code (the unit tests)
113 ''' will comment the error location and description in a message box and in the console log,
114 ''' providing every test case (in either mode) implements an error handler containing at least:
115 ''' Sub Test_Case1(test As Variant)
116 ''' On Local Error GoTo Catch
117 ''' ' ... (AssertXXX(), Fail(), ...)
118 ''' Exit Sub
119 ''' Catch:
120 ''' test.ReportError()
121 ''' End Sub
122 '''
123 ''' Detailed user documentation:
124 ''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_unittest.html?DbPAR=BASIC
125 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
127 REM ================================================================== EXCEPTIONS
131 REM ============================================================= PRIVATE MEMBERS
133 Private [Me] As Object
134 Private [_Parent] As Object
136 Private ServiceName As String
138 ' Testing code
139 Private LibrariesContainer As String ' Document or user Basic library containing the test library
140 Private Scope As String ' Scope when running a Basic script with Session.ExecuteBasicScript()
141 Private Libraries As Variant ' Set of libraries
142 Private LibraryName As String ' Name of the library containing the test code
143 Private LibraryIndex As Integer ' Index in Libraries
144 Private Modules As Variant ' Set of modules
145 Private ModuleNames As Variant ' Set of module names
146 Private MethodNames As Variant ' Set of methods in a given module
148 ' Internals
149 Private _Verbose As Boolean ' When True, every assertion is reported,failing or not
150 Private _LongMessage As Boolean ' When False, only the message provided by the tester is considered
151 ' When True (default), that message is appended to the standard message
152 Private _WhenAssertionFails As Integer ' Determines what to do when a test fails
154 ' Test status
162 Private _Module As String ' Exact name of module currently running
163 Private _TestCase As String ' Exact name of test case currently running
168 Private _FailedAssert As String ' Assert function that returned a failure
170 ' Timers
171 Private TestTimer As Object ' Started by CreateScriptService()
172 Private SuiteTimer As Object ' Started by RunTest()
173 Private CaseTimer As Object ' Started by new case
175 ' Services
176 Private Exception As Object ' SF_Exception
177 Private Session As Object ' SF_Session
179 REM ============================================================ MODULE CONSTANTS
181 ' When assertion fails constants: error is reported + ...
183 Global Const FAILSTOPSUITE = 1 ' Module TearDown is executed, then next suite may be started (default in full mode)
193 ' Return codes
199 ' Execution modes
201 Global Const SIMPLEMODE = 2 ' 2 = Test started with CreateScriptService() Only Assert() methods allowed
203 Const INVALIDPROCEDURECALL = "5" ' Artificial error raised when an assertion fails
205 REM ===================================================== CONSTRUCTOR/DESTRUCTOR
207 REM -----------------------------------------------------------------------------
208 Private Sub Class_Initialize()
209 Set [Me] = Nothing
210 Set [_Parent] = Nothing
213 LibrariesContainer = ""
214 Scope = ""
215 Libraries = Array()
216 LibraryName = ""
217 LibraryIndex = -1
218 _Verbose = False
219 _LongMessage = True
220 _WhenAssertionFails = -1
221 _Status = STATUSSTANDBY
222 _ExecutionMode = SIMPLEMODE
223 _Module = ""
224 _TestCase = ""
225 _ReturnCode = RCNORMALEND
226 _FailedAssert = ""
227 Set TestTimer = Nothing
228 Set SuiteTimer = Nothing
229 Set CaseTimer = Nothing
230 Set Exception = ScriptForge.SF_Exception ' Do not use CreateScriptService to allow New SF_UnitTest from other libraries
231 Set Session = ScriptForge.SF_Session
232 End Sub ' SFUnitTests.SF_UnitTest Constructor
234 REM -----------------------------------------------------------------------------
235 Private Sub Class_Terminate()
236 If Not IsNull(CaseTimer) Then CaseTimer = CaseTimer.Dispose()
237 If Not IsNull(SuiteTimer) Then SuiteTimer = SuiteTimer.Dispose()
238 If Not IsNull(TestTimer) Then TestTimer = TestTimer.Dispose()
239 Call Class_Initialize()
240 End Sub ' SFUnitTests.SF_UnitTest Destructor
242 REM -----------------------------------------------------------------------------
243 Public Function Dispose() As Variant
244 Call Class_Terminate()
245 Set Dispose = Nothing
246 End Function ' SFUnitTests.SF_UnitTest Explicit destructor
248 REM ================================================================== PROPERTIES
250 REM -----------------------------------------------------------------------------
251 Property Get LongMessage() As Variant
252 ''' When False, only the message provided by the tester is considered
253 ''' When True (default), that message is appended to the standard message
255 End Property ' SFUnitTests.SF_UnitTest.LongMessage (get)
257 REM -----------------------------------------------------------------------------
258 Property Let LongMessage(Optional ByVal pvLongMessage As Variant)
259 ''' Set the updatable property LongMessage
261 End Property ' SFUnitTests.SF_UnitTest.LongMessage (let)
263 REM -----------------------------------------------------------------------------
264 Property Get ReturnCode() As Integer
270 End Property ' SFUnitTests.SF_UnitTest.ReturnCode (get)
272 REM -----------------------------------------------------------------------------
273 Property Get Verbose() As Variant
274 ''' The Verbose property indicates if all assertions (True AND False) are reported
276 End Property ' SFUnitTests.SF_UnitTest.Verbose (get)
278 REM -----------------------------------------------------------------------------
279 Property Let Verbose(Optional ByVal pvVerbose As Variant)
280 ''' Set the updatable property Verbose
282 End Property ' SFUnitTests.SF_UnitTest.Verbose (let)
284 REM -----------------------------------------------------------------------------
285 Property Get WhenAssertionFails() As Variant
286 ''' What when an AssertXXX() method returns False
288 ''' FAILSTOPSUITE = 1 ' Module TearDown is executed, then next suite may be started (default in FULL mode)
290 ''' In simple mode, only FAILIGNORE and FAILIMMEDIATESTOP are allowed.
291 ''' In both modes, when WhenAssertionFails has not the value FAILIGNORE,
292 ''' each test case MUST have a run-time error handler calling the ReportError() method.
293 ''' Example:
294 ''' Sub Test_sometest(Optional test)
295 ''' On Local Error GoTo CatchError
296 ''' ' ... one or more assert verbs
297 ''' Exit Sub
298 ''' CatchError:
299 ''' test.ReportError()
300 ''' End Sub
302 End Property ' SFUnitTests.SF_UnitTest.WhenAssertionFails (get)
304 REM -----------------------------------------------------------------------------
305 Property Let WhenAssertionFails(Optional ByVal pvWhenAssertionFails As Variant)
306 ''' Set the updatable property WhenAssertionFails
308 End Property ' SFUnitTests.SF_UnitTest.WhenAssertionFails (let)
310 REM ===================================================================== METHODS
312 REM -----------------------------------------------------------------------------
313 Public Function AssertAlmostEqual(Optional ByRef A As Variant _
314 , Optional ByRef B As Variant _
315 , Optional ByVal Tolerance As Variant _
316 , Optional ByVal Message As Variant _
317 ) As Boolean
318 ''' Returns True when A and B are numerical values and are found close to each other.
319 ''' It is typically used to compare very large or very small numbers.
320 ''' Equality is confirmed when
321 ''' - A and B can be converted to doubles
322 ''' - The absolute difference between a and b, relative to the larger absolute value of a or b,
328 Dim bAssert As Boolean ' Return value
329 Const cstTolerance = 1E-09
333 Check:
334 If IsMissing(A) Then A = Empty
335 If IsMissing(B) Then B = Empty
336 If IsMissing(Tolerance) Then Tolerance = cstTolerance
337 If IsMissing(Message) Then Message = ""
338 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
339 If Not ScriptForge.SF_Utils._Validate(Tolerance, "Tolerance", ScriptForge.V_NUMERIC) Then GoTo Catch
341 Try:
344 Finally:
345 AssertAlmostEqual = bAssert
346 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
347 Exit Function
348 Catch:
349 bAssert = False
350 GoTo Finally
351 End Function ' SFUnitTests.SF_UnitTest.AssertAlmostEqual
353 REM -----------------------------------------------------------------------------
354 Public Function AssertEqual(Optional ByRef A As Variant _
355 , Optional ByRef B As Variant _
356 , Optional ByVal Message As Variant _
357 ) As Boolean
358 ''' Returns True when A and B are found equal.
359 ''' Equality is confirmed when
360 ''' If A and B are scalars:
361 ''' They should have the same VarType or both be numeric
362 ''' Booleans and numeric values are compared with the = operator
363 ''' Strings are compared with the StrComp() builtin function. The comparison is case-sensitive
364 ''' Dates and times are compared up to the second
365 ''' Null, Empty and Nothing are not equal, but AssertEqual(Nothing, Nothing) returns True
366 ''' UNO objects are compared with the EqualUnoObjects() method
367 ''' Basic objects are NEVER equal
368 ''' If A and B are arrays:
370 ''' The lower and upper bounds must be identical for each dimension
371 ''' Two empty arrays are equal
372 ''' Their items must be equal one by one
374 Dim bAssert As Boolean ' Return value
378 Check:
379 If IsMissing(A) Then A = Empty
380 If IsMissing(B) Then B = Empty
381 If IsMissing(Message) Then Message = ""
382 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
384 Try:
387 Finally:
388 AssertEqual = bAssert
389 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
390 Exit Function
391 End Function ' SFUnitTests.SF_UnitTest.AssertEqual
393 REM -----------------------------------------------------------------------------
394 Public Function AssertFalse(Optional ByRef A As Variant _
395 , Optional ByVal Message As Variant _
396 ) As Boolean
397 ''' Returns True when A is a Boolean and its value is False
399 Dim bAssert As Boolean ' Return value
403 Check:
404 If IsMissing(A) Then A = Empty
405 If IsMissing(Message) Then Message = ""
406 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
408 Try:
411 Finally:
412 AssertFalse = bAssert
413 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
414 Exit Function
415 End Function ' SFUnitTests.SF_UnitTest.AssertFalse
417 REM -----------------------------------------------------------------------------
418 Public Function AssertGreater(Optional ByRef A As Variant _
419 , Optional ByRef B As Variant _
420 , Optional ByVal Message As Variant _
421 ) As Boolean
422 ''' Returns True when A is greater than B.
423 ''' To compare A and B:
424 ''' They should have the same VarType or both be numeric
425 ''' Eligible datatypes are String, Date or numeric.
426 ''' String comparisons are case-sensitive.
428 Dim bAssert As Boolean ' Return value
432 Check:
433 If IsMissing(A) Then A = Empty
434 If IsMissing(B) Then B = Empty
435 If IsMissing(Message) Then Message = ""
436 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
438 Try:
441 Finally:
442 AssertGreater = bAssert
443 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
444 Exit Function
445 End Function ' SFUnitTests.SF_UnitTest.AssertGreater
447 REM -----------------------------------------------------------------------------
448 Public Function AssertGreaterEqual(Optional ByRef A As Variant _
449 , Optional ByRef B As Variant _
450 , Optional ByVal Message As Variant _
451 ) As Boolean
452 ''' Returns True when A is greater than or equal to B.
453 ''' To compare A and B:
454 ''' They should have the same VarType or both be numeric
455 ''' Eligible datatypes are String, Date or numeric.
456 ''' String comparisons are case-sensitive.
458 Dim bAssert As Boolean ' Return value
462 Check:
463 If IsMissing(A) Then A = Empty
464 If IsMissing(B) Then B = Empty
465 If IsMissing(Message) Then Message = ""
466 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
468 Try:
471 Finally:
472 AssertGreaterEqual = bAssert
473 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
474 Exit Function
475 End Function ' SFUnitTests.SF_UnitTest.AssertGreaterEqual
477 REM -----------------------------------------------------------------------------
478 Public Function AssertIn(Optional ByRef A As Variant _
479 , Optional ByRef B As Variant _
480 , Optional ByVal Message As Variant _
481 ) As Boolean
482 ''' Returns True when A, a string, is found within B
484 ''' When B is an array, A may be a date or a numeric value.
485 ''' String comparisons are case-sensitive.
487 Dim bAssert As Boolean ' Return value
491 Check:
492 If IsMissing(A) Then A = Empty
493 If IsMissing(B) Then B = Empty
494 If IsMissing(Message) Then Message = ""
495 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
497 Try:
500 Finally:
501 AssertIn = bAssert
502 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
503 Exit Function
504 End Function ' SFUnitTests.SF_UnitTest.AssertIn
506 REM -----------------------------------------------------------------------------
507 Public Function AssertIsInstance(Optional ByRef A As Variant _
508 , Optional ByRef ObjectType As Variant _
509 , Optional ByVal Message As Variant _
510 ) As Boolean
511 ''' Returns True when A is an object instance of the class ObjectType or a variable of type ObjectType.
512 ''' A may be:
513 ''' - a ScriptForge object
514 ''' ObjectType is a string like "DICTIONARY", "calc", "Dialog", "exception", etc.
515 ''' - a UNO object
516 ''' ObjectType is a string identical with values returned by the SF_Session.UnoObjectType()
517 ''' - any variable, providing it is neither an object nor an array
518 ''' ObjectType is a string identifying a value returned by the TypeName() builtin function
519 ''' - an array
522 Dim bAssert As Boolean ' Return value
526 Check:
527 If IsMissing(A) Then A = Empty
528 If IsMissing(ObjectType) Then ObjectType = Empty
529 If IsMissing(Message) Then Message = ""
530 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
531 If Not ScriptForge.SF_Utils._Validate(ObjectType, "ObjectType", V_STRING) Then GoTo Catch
534 Try:
537 Finally:
538 AssertIsInstance = bAssert
539 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
540 Exit Function
541 Catch:
542 bAssert = False
543 GoTo Finally
544 End Function ' SFUnitTests.SF_UnitTest.AssertIsInstance
546 REM -----------------------------------------------------------------------------
547 Public Function AssertIsNothing(Optional ByRef A As Variant _
548 , Optional ByVal Message As Variant _
549 ) As Boolean
550 ''' Returns True when A is an object that has the Nothing value
552 Dim bAssert As Boolean ' Return value
556 Check:
557 If IsMissing(A) Then A = Empty
558 If IsMissing(Message) Then Message = ""
559 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
561 Try:
564 Finally:
565 AssertIsNothing = bAssert
566 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
567 Exit Function
568 End Function ' SFUnitTests.SF_UnitTest.AssertIsNothing
570 REM -----------------------------------------------------------------------------
571 Public Function AssertIsNull(Optional ByRef A As Variant _
572 , Optional ByVal Message As Variant _
573 ) As Boolean
574 ''' Returns True when A has the Null value
576 Dim bAssert As Boolean ' Return value
580 Check:
581 If IsMissing(A) Then A = Empty
582 If IsMissing(Message) Then Message = ""
583 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
585 Try:
588 Finally:
589 AssertIsNull = bAssert
590 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
591 Exit Function
592 End Function ' SFUnitTests.SF_UnitTest.AssertIsNull
594 REM -----------------------------------------------------------------------------
595 Public Function AssertLess(Optional ByRef A As Variant _
596 , Optional ByRef B As Variant _
597 , Optional ByVal Message As Variant _
598 ) As Boolean
599 ''' Returns True when A is less than B.
600 ''' To compare A and B:
601 ''' They should have the same VarType or both be numeric
602 ''' Eligible datatypes are String, Date or numeric.
603 ''' String comparisons are case-sensitive.
605 Dim bAssert As Boolean ' Return value
609 Check:
610 If IsMissing(A) Then A = Empty
611 If IsMissing(B) Then B = Empty
612 If IsMissing(Message) Then Message = ""
613 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
615 Try:
618 Finally:
619 AssertLess = bAssert
620 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
621 Exit Function
622 End Function ' SFUnitTests.SF_UnitTest.AssertLess
624 REM -----------------------------------------------------------------------------
625 Public Function AssertLessEqual(Optional ByRef A As Variant _
626 , Optional ByRef B As Variant _
627 , Optional ByVal Message As Variant _
628 ) As Boolean
629 ''' Returns True when A is less than or equal to B.
630 ''' To compare A and B:
631 ''' They should have the same VarType or both be numeric
632 ''' Eligible datatypes are String, Date or numeric.
633 ''' String comparisons are case-sensitive.
635 Dim bAssert As Boolean ' Return value
639 Check:
640 If IsMissing(A) Then A = Empty
641 If IsMissing(B) Then B = Empty
642 If IsMissing(Message) Then Message = ""
643 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
645 Try:
648 Finally:
649 AssertLessEqual = bAssert
650 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
651 Exit Function
652 End Function ' SFUnitTests.SF_UnitTest.AssertLessEqual
654 REM -----------------------------------------------------------------------------
655 Public Function AssertLike(Optional ByRef A As Variant _
656 , Optional ByRef Pattern As Variant _
657 , Optional ByVal Message As Variant _
658 ) As Boolean
659 ''' Returns True if string A matches a given pattern containing wildcards
662 ''' The comparison is case-sensitive.
664 Dim bAssert As Boolean ' Return value
668 Check:
669 If IsMissing(A) Then A = Empty
670 If IsMissing(Pattern) Then Pattern = ""
671 If IsMissing(Message) Then Message = ""
672 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
675 Try:
678 Finally:
679 AssertLike = bAssert
680 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
681 Exit Function
682 Catch:
683 bAssert = False
684 GoTo Finally
685 End Function ' SFUnitTests.SF_UnitTest.AssertLike
687 REM -----------------------------------------------------------------------------
688 Public Function AssertNotAlmostEqual(Optional ByRef A As Variant _
689 , Optional ByRef B As Variant _
690 , Optional ByVal Tolerance As Variant _
691 , Optional ByVal Message As Variant _
692 ) As Boolean
693 ''' Returns True when A and B are numerical values and are not found close to each other.
694 ''' Read about almost equality in the comments linked to the AssertEqual() method.
696 Dim bAssert As Boolean ' Return value
697 Const cstTolerance = 1E-09
701 Check:
702 If IsMissing(A) Then A = Empty
703 If IsMissing(B) Then B = Empty
704 If IsMissing(Tolerance) Then Tolerance = cstTolerance
705 If IsMissing(Message) Then Message = ""
706 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
707 If Not ScriptForge.SF_Utils._Validate(Tolerance, "Tolerance", ScriptForge.V_NUMERIC) Then GoTo Catch
709 Try:
712 Finally:
713 AssertNotAlmostEqual = bAssert
714 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
715 Exit Function
716 Catch:
717 bAssert = False
718 GoTo Finally
719 End Function ' SFUnitTests.SF_UnitTest.AssertNotAlmostEqual
721 REM -----------------------------------------------------------------------------
722 Public Function AssertNotEqual(Optional ByRef A As Variant _
723 , Optional ByRef B As Variant _
724 , Optional ByVal Message As Variant _
725 ) As Boolean
726 ''' Returns True when A and B are found unequal.
727 ''' Read about equality in the comments linked to the AssertEqual() method.
729 Dim bAssert As Boolean ' Return value
733 Check:
734 If IsMissing(A) Then A = Empty
735 If IsMissing(B) Then B = Empty
736 If IsMissing(Message) Then Message = ""
737 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
739 Try:
742 Finally:
743 AssertNotEqual = bAssert
744 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
745 Exit Function
746 End Function ' SFUnitTests.SF_UnitTest.AssertNotEqual
748 REM -----------------------------------------------------------------------------
749 Public Function AssertNotIn(Optional ByRef A As Variant _
750 , Optional ByRef B As Variant _
751 , Optional ByVal Message As Variant _
752 ) As Boolean
753 ''' Returns True when A, a string, is not found within B
755 ''' When B is an array, A may be a date or a numeric value.
756 ''' String comparisons are case-sensitive.
758 Dim bAssert As Boolean ' Return value
762 Check:
763 If IsMissing(A) Then A = Empty
764 If IsMissing(B) Then B = Empty
765 If IsMissing(Message) Then Message = ""
766 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
768 Try:
771 Finally:
772 AssertNotIn = bAssert
773 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
774 Exit Function
775 End Function ' SFUnitTests.SF_UnitTest.AssertNotIn
777 REM -----------------------------------------------------------------------------
778 Public Function AssertNotInstance(Optional ByRef A As Variant _
779 , Optional ByRef ObjectType As Variant _
780 , Optional ByVal Message As Variant _
781 ) As Boolean
782 ''' Returns True when A is an object instance of the class ObjectType or a variable of type ObjectType.
783 ''' More details to be read under the AssertInstance() function.
785 Dim bAssert As Boolean ' Return value
789 Check:
790 If IsMissing(A) Then A = Empty
791 If IsMissing(ObjectType) Then ObjectType = Empty
792 If IsMissing(Message) Then Message = ""
793 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
794 If Not ScriptForge.SF_Utils._Validate(ObjectType, "ObjectType", V_STRING) Then GoTo Catch
796 Try:
799 Finally:
800 AssertNotInstance = bAssert
801 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
802 Exit Function
803 Catch:
804 bAssert = False
805 GoTo Finally
806 End Function ' SFUnitTests.SF_UnitTest.AssertNotInstance
808 REM -----------------------------------------------------------------------------
809 Public Function AssertNotLike(Optional ByRef A As Variant _
810 , Optional ByRef Pattern As Variant _
811 , Optional ByVal Message As Variant _
812 ) As Boolean
813 ''' Returns True if A is not a string or does not match a given pattern containing wildcards
816 ''' The comparison is case-sensitive.
818 Dim bAssert As Boolean ' Return value
822 Check:
823 If IsMissing(A) Then A = Empty
824 If IsMissing(Pattern) Then Pattern = ""
825 If IsMissing(Message) Then Message = ""
826 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
829 Try:
832 Finally:
833 AssertNotLike = bAssert
834 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
835 Exit Function
836 Catch:
837 bAssert = False
838 GoTo Finally
839 End Function ' SFUnitTests.SF_UnitTest.AssertNotLike
841 REM -----------------------------------------------------------------------------
842 Public Function AssertNotNothing(Optional ByRef A As Variant _
843 , Optional ByVal Message As Variant _
844 ) As Boolean
845 ''' Returns True except when A is an object that has the Nothing value
847 Dim bAssert As Boolean ' Return value
851 Check:
852 If IsMissing(A) Then A = Empty
853 If IsMissing(Message) Then Message = ""
854 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
856 Try:
859 Finally:
860 AssertNotNothing = bAssert
861 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
862 Exit Function
863 End Function ' SFUnitTests.SF_UnitTest.AssertNotNothing
865 REM -----------------------------------------------------------------------------
866 Public Function AssertNotNull(Optional ByRef A As Variant _
867 , Optional ByVal Message As Variant _
868 ) As Boolean
869 ''' Returns True except when A has the Null value
871 Dim bAssert As Boolean ' Return value
875 Check:
876 If IsMissing(A) Then A = Empty
877 If IsMissing(Message) Then Message = ""
878 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
880 Try:
883 Finally:
884 AssertNotNull = bAssert
885 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
886 Exit Function
887 End Function ' SFUnitTests.SF_UnitTest.AssertNotNull
889 REM -----------------------------------------------------------------------------
890 Public Function AssertNotRegex(Optional ByRef A As Variant _
891 , Optional ByRef Regex As Variant _
892 , Optional ByVal Message As Variant _
893 ) As Boolean
894 ''' Returns True when A is not a string or does not match the given regular expression.
895 ''' The comparison is case-sensitive.
897 Dim bAssert As Boolean ' Return value
901 Check:
902 If IsMissing(A) Then A = Empty
903 If IsMissing(Regex) Then Regex = ""
904 If IsMissing(Message) Then Message = ""
905 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
908 Try:
911 Finally:
912 AssertNotRegex = bAssert
913 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
914 Exit Function
915 Catch:
916 bAssert = False
917 GoTo Finally
918 End Function ' SFUnitTests.SF_UnitTest.AssertNotRegex
920 REM -----------------------------------------------------------------------------
921 Public Function AssertRegex(Optional ByRef A As Variant _
922 , Optional ByRef Regex As Variant _
923 , Optional ByVal Message As Variant _
924 ) As Boolean
925 ''' Returns True when string A matches the given regular expression.
926 ''' The comparison is case-sensitive.
928 Dim bAssert As Boolean ' Return value
932 Check:
933 If IsMissing(A) Then A = Empty
934 If IsMissing(Regex) Then Regex = ""
935 If IsMissing(Message) Then Message = ""
936 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
939 Try:
942 Finally:
943 AssertRegex = bAssert
944 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
945 Exit Function
946 Catch:
947 bAssert = False
948 GoTo Finally
949 End Function ' SFUnitTests.SF_UnitTest.AssertRegex
951 REM -----------------------------------------------------------------------------
952 Public Function AssertTrue(Optional ByRef A As Variant _
953 , Optional ByVal Message As Variant _
954 ) As Boolean
955 ''' Returns True when A is a Boolean and its value is True
957 Dim bAssert As Boolean ' Return value
961 Check:
962 If IsMissing(A) Then A = Empty
963 If IsMissing(Message) Then Message = ""
964 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
966 Try:
969 Finally:
970 AssertTrue = bAssert
971 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
972 Exit Function
973 End Function ' SFUnitTests.SF_UnitTest.AssertTrue
975 REM -----------------------------------------------------------------------------
976 Public Sub Fail(Optional ByVal Message As Variant)
977 ''' Forces a test failure
979 Dim bAssert As Boolean ' Fictive return value
983 Check:
984 If IsMissing(Message) Then Message = ""
985 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
987 Try:
990 Finally:
991 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
992 Exit Sub
993 End Sub ' SFUnitTests.SF_UnitTest.Fail
995 REM -----------------------------------------------------------------------------
996 Public Sub Log(Optional ByVal Message As Variant)
997 ''' Records the given message in the test report (console)
999 Dim bAssert As Boolean ' Fictive return value
1000 Dim bVerbose As Boolean : bVerbose = _Verbose
1004 Check:
1005 If IsMissing(Message) Then Message = ""
1006 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
1008 Try:
1009 ' Force the display of the message in the console
1010 _Verbose = True
1012 _Verbose = bVerbose
1014 Finally:
1015 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1016 Exit Sub
1017 End Sub ' SFUnitTests.SF_UnitTest.Log
1019 REM -----------------------------------------------------------------------------
1020 Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant
1021 ''' Return the actual value of the given property
1022 ''' Args:
1023 ''' PropertyName: the name of the property as a string
1024 ''' Returns:
1025 ''' The actual value of the property
1026 ''' Exceptions
1027 ''' ARGUMENTERROR The property does not exist
1028 ''' Examples:
1034 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1035 GetProperty = Null
1037 Check:
1038 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1039 If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
1040 End If
1042 Try:
1043 GetProperty = _PropertyGet(PropertyName)
1045 Finally:
1046 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1047 Exit Function
1048 Catch:
1049 GoTo Finally
1050 End Function ' SFUnitTests.SF_UnitTest.Properties
1052 REM -----------------------------------------------------------------------------
1053 Public Function Methods() As Variant
1054 ''' Return the list or methods of the UnitTest class as an array
1056 Methods = Array( _
1083 )
1085 End Function ' SFUnitTests.SF_UnitTest.Methods
1087 REM -----------------------------------------------------------------------------
1088 Public Function Properties() As Variant
1089 ''' Return the list or properties of the UnitTest class as an array
1091 Properties = Array( _
1096 )
1098 End Function ' SFUnitTests.SF_UnitTest.Properties
1100 REM -----------------------------------------------------------------------------
1101 Public Sub ReportError(Optional ByVal Message As Variant)
1102 ''' DIsplay a message box with the current property values of the "Exception" service.
1103 ''' Depending on the WhenAssertionFails property, a Raise() or RaiseWarning()
1104 ''' is issued. The Raise() method stops completely the Basic running process.
1105 ''' The ReportError() method is presumed present in a user script in an error
1106 ''' handling part of the actual testcase.
1107 ''' Args:
1108 ''' Message: a string to replace or to complete the standard message description
1109 ''' Example:
1112 Dim sLine As String ' Line number where the error occurred
1113 Dim sError As String ' Exception description
1114 Dim sErrorCode As String ' Exception number
1118 Check:
1119 If IsMissing(Message) Or IsEmpty(Message) Then Message = ""
1120 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
1123 Try:
1125 If _ExecutionMode = FULLMODE Then sLine = _Module & "." & _TestCase & " " & sLine
1127 sError = Message
1128 Else
1129 If Exception.Number = INVALIDPROCEDURECALL Then
1132 Else
1133 sError = Exception.Description
1134 sErrorCode = CStr(Exception.Number)
1135 End If
1136 End If
1138 Select Case _WhenAssertionFails
1139 Case FAILIGNORE
1140 Case FAILSTOPSUITE
1141 Exception.RaiseWarning(sErrorCode, sLine, sError)
1142 Case FAILIMMEDIATESTOP
1143 Exception.Raise(sErrorCode, sLine, sError)
1144 End Select
1146 Finally:
1147 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1148 Exit Sub
1149 End Sub ' SFUnitTests.SF_UnitTest.ReportError
1150 REM -----------------------------------------------------------------------------
1151 Public Function RunTest(Optional ByVal TestSuite As Variant _
1152 , Optional ByVal TestCasePattern As Variant _
1153 , Optional ByVal Message As Variant _
1154 ) As Integer
1155 ''' Execute a test suite pointed out by a module name.
1156 ''' Each test case will be run independently from each other.
1157 ''' The names of the test cases to be run may be selected with a string pattern.
1162 ''' Args:
1163 ''' TestSuite: the name of the module containing the set of test cases to run
1164 ''' TestCasePattern: the pattern that the test cases must match. The comparison is not case-sensitive.
1165 ''' Non-matching functions and subs are ignored.
1169 ''' Message: the message to be displayed in the console when the test starts.
1170 ''' Returns:
1171 ''' One of the return codes of the execution (RCxxx constants)
1172 ''' Examples:
1174 ''' Dim test : test = CreateScriptService("UnitTest", ThisComponent, "Tests")
1175 ''' test.RunTest("AllTests") ' AllTests is a module name ; test cases are named "Test_*" (default)
1177 Dim iRun As Integer ' Return value
1178 Dim sRunMessage As String ' Reporting
1179 Dim iModule As Integer ' Index of module currently running
1180 Dim vMethods As Variant ' Set of methods
1181 Dim sMethod As String ' A single method
1182 Dim iMethod As Integer ' Index in MethodNames
1183 Dim m As Integer
1186 Const cstSubArgs = "TestSuite, [TestCasePattern=""Test_*""], [Message=""""]"
1188 iRun = RCNORMALEND
1189 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1191 Check:
1192 If IsMissing(TestCasePattern) Or IsEmpty(TestCasePattern) Then TestCasePattern = "Test_*"
1193 If IsMissing(Message) Or IsEmpty(Message) Then Message = ""
1194 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
1195 If Not ScriptForge.SF_Utils._Validate(TestSuite, "TestSuite", V_STRING, ModuleNames) Then GoTo Catch
1196 If Not ScriptForge.SF_Utils._Validate(TestCasePattern, "TestCasePattern", V_STRING) Then GoTo Catch
1199 ' A RunTest() is forbidden inside a test suite or when simple mode
1202 ' Ignore any call when an abnormal end has been encountered
1203 If _ReturnCode = RCABORTTEST Then GoTo Catch
1205 Try:
1206 iModule = ScriptForge.SF_Array.IndexOf(ModuleNames, TestSuite, CaseSensitive := False, SortOrder := "ASC")
1207 _Module = ModuleNames(iModule)
1209 ' Start timer
1210 If Not IsNull(SuiteTimer) Then SuiteTimer = SuiteTimer.Dispose()
1213 ' Report the start of a new test suite
1214 sRunMessage = "RUNTEST ENTER testsuite='" & LibraryName & "." & _Module & "', pattern='" & TestCasePattern & "'"
1215 _ReportMessage(sRunMessage, Message)
1216 _Status = STATUSSUITESTARTED
1218 ' Collect all the methods of the module
1219 If Modules(iModule).hasChildNodes() Then
1220 vMethods = Modules(iModule).getChildNodes()
1221 MethodNames = Array()
1222 For m = 0 To UBound(vMethods)
1223 sMethod = vMethods(m).getName()
1224 MethodNames = ScriptForge.SF_Array.Append(MethodNames, sMethod)
1225 Next m
1226 End If
1228 ' Execute the Setup() method, if it exists
1229 iMethod = ScriptForge.SF_Array.IndexOf(MethodNames, "Setup", CaseSensitive := False, SortOrder := "ASC")
1231 _TestCase = MethodNames(iMethod) ' _TestCase is used in ReportError()
1232 If Not _ExecuteScript(_TestCase) Then GoTo Catch
1233 End If
1235 ' Execute the test cases that match the pattern
1236 For iMethod = 0 To UBound(MethodNames)
1237 If _ReturnCode = RCSKIPTEST Or _ReturnCode = RCASSERTIONFAILED Then Exit For
1238 sMethod = MethodNames(iMethod)
1239 If ScriptForge.SF_String.IsLike(sMethod, TestCasePattern, CaseSensitive := False) Then
1240 _TestCase = sMethod
1241 ' Start timer
1242 If Not IsNull(CaseTimer) Then CaseTimer = CaseTimer.Dispose()
1244 If Not _ExecuteScript(sMethod) Then GoTo Catch
1245 CaseTimer.Terminate()
1246 _TestCase = ""
1247 End If
1248 Next iMethod
1250 If _ReturnCode <> RCSKIPTEST Then
1251 ' Execute the TearDown() method, if it exists
1252 iMethod = ScriptForge.SF_Array.IndexOf(MethodNames, "TearDown", CaseSensitive := False, SortOrder := "ASC")
1254 _TestCase = MethodNames(iMethod) ' _TestCase is used in ReportError()
1255 If Not _ExecuteScript(_TestCase) Then GoTo Catch
1256 End If
1257 End If
1259 ' Report the end of the current test suite
1260 sRunMessage = "RUNTEST EXIT testsuite='" & LibraryName & "." & _Module & "' " & _Duration("Suite", True)
1261 _ReportMessage(sRunMessage, Message)
1263 ' Stop timer
1264 SuiteTimer.Terminate()
1266 ' Housekeeping
1267 MethodNames = Array()
1268 _Module = ""
1269 _Status = STATUSSTANDBY
1271 Finally:
1272 _ReturnCode = iRun
1273 RunTest = iRun
1274 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1275 Exit Function
1276 Catch:
1277 iRun = RCABORTTEST
1278 GoTo Finally
1279 CatchMethod:
1281 GoTo Catch
1282 End Function ' SFUnitTests.SF_UnitTest.RunTest
1284 REM -----------------------------------------------------------------------------
1285 Public Function SetProperty(Optional ByVal PropertyName As Variant _
1286 , Optional ByRef Value As Variant _
1287 ) As Boolean
1288 ''' Set a new value to the given property
1289 ''' Args:
1290 ''' PropertyName: the name of the property as a string
1291 ''' Value: its new value
1292 ''' Exceptions
1293 ''' ARGUMENTERROR The property does not exist
1298 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1299 SetProperty = False
1301 Check:
1302 If ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
1303 If Not ScriptForge.SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
1304 End If
1306 Try:
1307 SetProperty = _PropertySet(PropertyName, Value)
1309 Finally:
1310 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1311 Exit Function
1312 Catch:
1313 GoTo Finally
1314 End Function ' SFUnitTests.SF_UnitTest.SetProperty
1316 REM -----------------------------------------------------------------------------
1317 Public Function SkipTest(Optional ByVal Message As Variant) As Boolean
1318 ''' Interrupt the running test suite. The TearDown() method is NOT executed.
1319 ''' The SkipTest() method is normally meaningful only in a Setup() method when not all the
1320 ''' conditions to run the test are met.
1321 ''' It is up to the Setup() script to exit shortly after the SkipTest() call..
1322 ''' The method may also be executed in a test case. Next test cases will not be executed.
1323 ''' Remember however that the test cases are executed is an arbitrary order.
1324 ''' Args:
1325 ''' Message: the message to be displayed in the console
1326 ''' Returns:
1327 ''' True when successful
1328 ''' Examples:
1330 ''' Dim test : test = CreateScriptService("UnitTest", ThisComponent, "Tests")
1331 ''' test.SkipTest("AllTests") ' AllTests is a module name ; test cases are named "Test_*" (default)
1333 Dim bSkip As Boolean ' Return value
1334 Dim sSkipMessage As String ' Reporting
1339 bSkip = False
1340 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1342 Check:
1343 If IsMissing(Message) Or IsEmpty(Message) Then Message = ""
1344 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs) ' Unconditional !
1347 ' A SkipTest() is forbidden when simple mode
1348 If _ExecutionMode <> FULLMODE Then GoTo CatchMethod
1350 ' Ignore any call when an abnormal end has been encountered
1351 If _ReturnCode = RCABORTTEST Then GoTo Catch
1353 Try:
1354 If _Status = STATUSSETUP Or _Status = STATUSTESTCASE Then
1355 _ReturnCode = RCSKIPTEST
1356 bSkip = True
1357 ' Exit message
1358 sSkipMessage = " SKIPTEST testsuite='" & LibraryName & "." & _Module & "' " & _Duration("Suite", True)
1359 _ReportMessage(sSkipMessage, Message)
1360 End If
1362 Finally:
1363 SkipTest = bSkip
1364 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1365 Exit Function
1366 Catch:
1367 _ReturnCode = RCABORTTEST
1368 GoTo Finally
1369 CatchMethod:
1371 GoTo Catch
1372 End Function ' SFUnitTests.SF_UnitTest.SkipTest
1374 REM =========================================================== PRIVATE FUNCTIONS
1376 REM -----------------------------------------------------------------------------
1377 Private Function _Assert(ByVal psAssert As String _
1378 , ByVal pvReturn As Variant _
1379 , ByRef A As Variant _
1380 , ByRef B As Variant _
1381 , Optional ByVal pvMessage As Variant _
1382 , Optional ByVal pvArg As Variant _
1383 ) As Boolean
1384 ''' Evaluation of the assertion and management of the success or the failure
1385 ''' Args:
1386 ''' psAssert: the assertion verb as a string
1387 ''' pvReturn: may be True, False or Empty
1388 ''' When True (resp. False), the assertion must be evaluated as True (resp. False)
1391 ''' Empty may be used for recursive calls of the function (for comparing arrays, ...)
1392 ''' A: always present
1393 ''' B: may be empty
1394 ''' pvMessage: the message to display on the console
1395 ''' pvArg: optional additional argument of the assert function
1396 ''' Returns:
1397 ''' True when success
1399 Dim bAssert As Boolean ' Return value
1400 Dim bEval As Boolean ' To be compared with pvReturn
1401 Dim iVarTypeA As Integer ' Alias of _VarTypeExt(A)
1402 Dim iVarTypeB As Integer ' Alias of _VarTypeExt(B)
1403 Dim oVarTypeObjA As Object ' SF_Utils.ObjectDescriptor
1404 Dim oVarTypeObjB As Object ' SF_Utils.ObjectDescriptor
1405 Dim oUtils As Object : Set oUtils = ScriptForge.SF_Utils
1406 Dim iDims As Integer ' Number of dimensions of array
1407 Dim oAliasB As Object ' Alias of B to bypass the "Object variable not set" issue
1408 Dim dblA As Double ' Alias of A
1409 Dim dblB As Double ' Alias of B
1410 Dim dblTolerance As Double ' Alias of pvArg
1411 Dim oString As Object : Set oString = ScriptForge.SF_String
1412 Dim sArgName As String ' Argument description
1413 Dim i As Long, j As Long
1415 Check:
1416 bAssert = False
1417 If IsMissing(pvMessage) Then pvMessage = ""
1419 If IsMissing(pvArg) Then pvArg = ""
1421 Try:
1422 iVarTypeA = oUtils._VarTypeExt(A)
1423 iVarTypeB = oUtils._VarTypeExt(B)
1424 sArgName = ""
1426 Select Case UCase(psAssert)
1428 bEval = ( iVarTypeA = iVarTypeB And iVarTypeA = ScriptForge.V_NUMERIC )
1429 If bEval Then
1430 dblA = CDbl(A)
1431 dblB = CDbl(B)
1432 dblTolerance = Abs(CDbl(pvArg))
1433 bEval = ( Abs(dblA - dblB) <= (dblTolerance * Iif(Abs(dblA) > Abs(DblB), Abs(dblA), Abs(dblB))) )
1434 End If
1436 If Not IsArray(A) Then
1437 bEval = ( iVarTypeA = iVarTypeB )
1438 If bEval Then
1439 Select Case iVarTypeA
1440 Case V_EMPTY, V_NULL
1441 Case V_STRING
1443 Case ScriptForge.V_NUMERIC, ScriptForge.V_BOOLEAN
1444 bEval = ( A = B )
1445 Case V_DATE
1447 Case ScriptForge.V_OBJECT
1448 Set oVarTypeObjA = oUtils._VarTypeObj(A)
1449 Set oVarTypeObjB = oUtils._VarTypeObj(B)
1450 bEval = ( oVarTypeObjA.iVarType = oVarTypeObjB.iVarType )
1451 If bEval Then
1452 Select Case oVarTypeObjA.iVarType
1453 Case ScriptForge.V_NOTHING
1454 Case ScriptForge.V_UNOOBJECT
1455 bEval = EqualUnoObjects(A, B)
1456 Case ScriptForge.V_SFOBJECT, ScriptForge.V_BASICOBJECT
1457 bEval = False
1458 End Select
1459 End If
1460 End Select
1461 End If
1462 Else ' Compare arrays
1463 bEval = IsArray(B)
1464 If bEval Then
1465 iDims = ScriptForge.SF_Array.CountDims(A)
1467 If bEval Then
1468 Select Case iDims
1471 bEval = ( LBound(A) = LBound(B) And UBound(A) = UBound(B) )
1472 If bEval Then
1473 For i = LBound(A) To UBound(A)
1474 bEval = _Assert(psAssert, Empty, A(i), B(i))
1475 If Not bEval Then Exit For
1476 Next i
1477 End If
1481 If bEval Then
1484 bEval = _Assert(psAssert, Empty, A(i, j), B(i, j))
1485 If Not bEval Then Exit For
1486 Next j
1487 If Not bEval Then Exit For
1488 Next i
1489 End If
1490 End Select
1491 End If
1492 End If
1493 End If
1495 If iVarTypeA = ScriptForge.V_BOOLEAN Then bEval = Not A Else bEval = False
1497 bEval = ( iVarTypeA = iVarTypeB _
1498 And (iVarTypeA = ScriptForge.V_NUMERIC Or iVarTypeA = V_STRING Or iVarTypeA = V_DATE) )
1499 If bEval Then bEval = ( A > B )
1501 bEval = ( iVarTypeA = iVarTypeB _
1502 And (iVarTypeA = ScriptForge.V_NUMERIC Or iVarTypeA = V_STRING Or iVarTypeA = V_DATE) )
1503 If bEval Then bEval = ( A >= B )
1505 Set oVarTypeObjB = oUtils._VarTypeObj(B)
1506 Select Case True
1507 Case iVarTypeA = V_STRING And iVarTypeB = V_STRING
1510 Case (iVarTypeA = V_DATE Or iVarTypeA = V_STRING Or iVarTypeA = ScriptForge.V_NUMERIC) _
1511 And iVarTypeB >= ScriptForge.V_ARRAY
1512 bEval = ( ScriptForge.SF_Array.CountDims(B) = 1 )
1513 If bEval Then bEval = ScriptForge.SF_Array.Contains(B, A, CaseSensitive := True)
1514 Case oVarTypeObjB.iVarType = ScriptForge.V_SFOBJECT And oVarTypeObjB.sObjectType = "DICTIONARY"
1516 If bEval Then
1517 Set oAliasB = B
1518 bEval = ScriptForge.SF_Array.Contains(oAliasB.Keys(), A, CaseSensitive := True)
1519 End If
1520 Case Else
1521 bEval = False
1522 End Select
1524 Set oVarTypeObjA = oUtils._VarTypeObj(A)
1526 With oVarTypeObjA
1527 Select Case .iVarType
1528 Case ScriptForge.V_UNOOBJECT
1529 bEval = ( pvArg = .sObjectType )
1530 Case ScriptForge.V_SFOBJECT
1531 bEval = ( UCase(pvArg) = UCase(.sObjectType) Or UCase(pvArg) = "SF_" & UCase(.sObjectType) _
1532 Or UCase(pvArg) = UCase(.sServiceName) )
1533 Case ScriptForge.V_NOTHING, ScriptForge.V_BASICOBJECT
1534 bEval = False
1535 Case >= ScriptForge.V_ARRAY
1537 Case Else
1538 bEval = ( UCase(TypeName(A)) = UCase(pvArg) )
1539 End Select
1540 End With
1542 bEval = ( iVarTypeA = ScriptForge.V_OBJECT )
1543 If bEval Then bEval = ( A Is Nothing )
1545 bEval = ( iVarTypeA = V_NULL )
1549 If bEval Then bEval = oString.IsLike(A, pvArg, CaseSensitive := True)
1553 If bEval Then bEval = oString.IsRegex(A, pvArg, CaseSensitive := True)
1555 If iVarTypeA = ScriptForge.V_BOOLEAN Then bEval = A Else bEval = False
1557 bEval = True
1558 Case Else
1559 End Select
1561 ' Check the result of the assertion vs. what it should be
1562 If IsEmpty(pvReturn) Then
1563 bAssert = bEval ' Recursive call => Reporting and failure management are done by calling _Assert() procedure
1565 bAssert = Iif(pvReturn, bEval, Not bEval)
1566 ' Report the assertion evaluation
1567 If _Verbose Or Not bAssert Then
1568 _ReportMessage(" " & psAssert _
1569 & Iif(IsEmpty(A), "", " = " & bAssert & ", A = " & oUtils._Repr(A)) _
1571 & Iif(Len(sArgName) = 0, "", ", " & sArgName & " = " & pvArg) _
1572 , pvMessage)
1573 End If
1574 ' Manage assertion failure
1575 If Not bAssert Then
1576 _FailedAssert = psAssert
1577 Select Case _WhenAssertionFails
1578 Case FAILIGNORE ' Do nothing
1579 Case Else
1580 _ReturnCode = RCASSERTIONFAILED
1581 ' Cause artificially a run-time error
1582 Dim STRINGBADUSE As String
1584 '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1585 '+ To avoid a run-time error on next executable statement, +
1586 '+ insert an error handler in the code of your test case: +
1587 '+ Like in next code: +
1588 '+ On Local Error GoTo Catch +
1589 '+ ... +
1590 '+ Catch: +
1591 '+ myTest.ReportError() +
1592 '+ Exit Sub +
1593 '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1595 STRINGBADUSE = Right("", -1) ' Raises "#5 - Invalid procedure call" error
1597 End Select
1598 End If
1599 End If
1601 Finally:
1602 _Assert = bAssert
1603 Exit Function
1605 End Function ' SFUnitTests.SF_UnitTest._Assert
1607 REM -----------------------------------------------------------------------------
1608 Private Function _Duration(ByVal psTimer As String _
1609 , Optional ByVal pvBrackets As Variant _
1610 ) As String
1611 ''' Return the Duration property of the given timer
1612 ''' or the empty string if the timer is undefined or not started
1613 ''' Args:
1615 ''' pbBrackets: surround with brackets when True. Default = False
1617 Dim sDuration As String ' Return value
1618 Dim oTimer As Object ' Alias of psTimer
1620 Check:
1621 If IsMissing(pvBrackets) Or IsEmpty(pvBrackets) Then pvBrackets = False
1623 Try:
1624 Select Case psTimer
1628 End Select
1629 If Not IsNull(oTimer) Then
1630 sDuration = CStr(oTimer.Duration) & " "
1632 Else
1633 sDuration = ""
1634 End If
1636 Finally:
1637 _Duration = sDuration
1638 End Function ' SFUnitTests.SF_UnitTest._Duration
1640 REM -----------------------------------------------------------------------------
1641 Private Function _ExecuteScript(psMethod As String) As Boolean
1642 ''' Run the given method and report start and stop
1643 ''' The targeted method is presumed not to return anything (Sub)
1644 ''' Args:
1645 ''' psMethod: the scope, the library and the module are predefined in the instance internals
1646 ''' Returns:
1647 ''' True when successful
1649 Dim bExecute As Boolean ' Return value
1650 Dim sRun As String ' SETUP, TEARDOWN or TESTCASE
1652 On Local Error GoTo Catch
1653 bExecute = True
1655 Try:
1656 ' Set status before the effective execution
1657 sRun = UCase(psMethod)
1658 Select Case UCase(psMethod)
1661 Case Else : _Status = STATUSTESTCASE
1663 End Select
1665 ' Report and execute
1666 _ReportMessage(" " & sRun & " " & LibraryName & "." & _Module & "." & psMethod & "() ENTER")
1667 Session.ExecuteBasicScript(Scope, LibraryName & "." & _Module & "." & psMethod, [Me])
1668 _ReportMessage(" " & sRun & " " & LibraryName & "." & _Module & "." & psMethod & "() EXIT" _
1669 & Iif(_STATUS = STATUSTESTCASE, " " & _Duration("Case", True), ""))
1670 ' Reset status
1671 _Status = STATUSSUITESTARTED
1673 Finally:
1674 _ExecuteScript = bExecute
1675 Exit Function
1676 Catch:
1677 bExecute = False
1678 _ReturnCode = RCABORTTEST
1679 GoTo Finally
1680 End Function ' SFUnitTests.SF_UnitTest._ExecuteScript
1682 REM -----------------------------------------------------------------------------
1683 Private Function _PropertyGet(Optional ByVal psProperty As String)
1684 ''' Return the named property
1685 ''' Args:
1686 ''' psProperty: the name of the property
1688 Dim cstThisSub As String
1689 Dim cstSubArgs As String
1692 cstSubArgs = ""
1693 SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
1695 Select Case UCase(psProperty)
1697 _PropertyGet = _LongMessage
1699 _PropertyGet = _ReturnCode
1701 _PropertyGet = _Verbose
1703 _PropertyGet = _WhenAssertionFails
1704 Case Else
1705 _PropertyGet = Null
1706 End Select
1708 Finally:
1709 SF_Utils._ExitFunction(cstThisSub)
1710 Exit Function
1711 End Function ' SFUnitTests.SF_UnitTest._PropertyGet
1713 REM -----------------------------------------------------------------------------
1714 Private Function _PropertySet(Optional ByVal psProperty As String _
1715 , Optional ByVal pvValue As Variant _
1716 ) As Boolean
1717 ''' Set the new value of the named property
1718 ''' Args:
1719 ''' psProperty: the name of the property
1720 ''' pvValue: the new value of the given property
1721 ''' Returns:
1722 ''' True if successful
1724 Dim bSet As Boolean ' Return value
1725 Dim vWhenFailure As Variant ' WhenAssertionFails allowed values
1726 Dim cstThisSub As String
1729 If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
1730 bSet = False
1733 ScriptForge.SF_Utils._EnterFunction(cstThisSub, cstSubArgs)
1735 bSet = True
1736 Select Case UCase(psProperty)
1738 If Not ScriptForge.SF_Utils._Validate(pvValue, "LongMessage", ScriptForge.V_BOOLEAN) Then GoTo Finally
1739 _LongMessage = pvValue
1741 If Not ScriptForge.SF_Utils._Validate(pvValue, "Verbose", ScriptForge.V_BOOLEAN) Then GoTo Finally
1742 _Verbose = pvValue
1744 If _ExecutionMode = SIMPLEMODE Then vWhenFailure = Array(0, 3) Else vWhenFailure = Array(0, 1, 2, 3)
1745 If Not ScriptForge.SF_Utils._Validate(pvValue, "WhenAssertionFails", ScriptForge.V_NUMERIC, vWhenFailure) Then GoTo Finally
1746 _WhenAssertionFails = pvValue
1747 Case Else
1748 bSet = False
1749 End Select
1751 Finally:
1752 _PropertySet = bSet
1753 ScriptForge.SF_Utils._ExitFunction(cstThisSub)
1754 Exit Function
1755 Catch:
1756 GoTo Finally
1757 End Function ' SFUnitTests.SF_UnitTest._PropertySet
1759 REM -----------------------------------------------------------------------------
1760 Private Function _ReportMessage(ByVal psSysMessage As String _
1761 , Optional ByVal pvMessage As Variant _
1762 ) As Boolean
1763 ''' Report in the console:
1764 ''' - either the standard message
1765 ''' - either the user message when not blank
1766 ''' - or both
1767 ''' Args:
1768 ''' psSysMessage: the standard message as built by the calling routine
1769 ''' psMessage: the message provided by the user script
1770 ''' Returns:
1771 ''' True when successful
1773 Dim bReport As Boolean ' Return value
1774 Dim sIndent As String ' Indentation spaces
1776 bReport = False
1777 On Local Error GoTo Catch
1778 If IsMissing(pvMessage) Or IsEmpty(pvMessage) Then pvMessage = ""
1780 Try:
1781 Select Case True
1782 Case Len(pvMessage) = 0
1783 Exception.DebugPrint(psSysMessage)
1784 Case _LongMessage
1785 Exception.DebugPrint(psSysMessage, pvMessage)
1786 Case Else
1787 Select Case _Status
1788 Case STATUSSTANDBY, STATUSSUITESTARTED : sIndent = ""
1789 Case STATUSSUITESTARTED : sIndent = Space(2)
1790 Case Else : sIndent = Space(4)
1791 End Select
1792 Exception.DebugPrint(sIndent & pvMessage)
1793 End Select
1795 Finally:
1796 _ReportMessage = bReport
1797 Exit Function
1798 Catch:
1799 bReport = False
1800 GoTo Finally
1801 End Function ' SFUnitTests.SF_UnitTest._ReportMessage
1803 REM -----------------------------------------------------------------------------
1804 Private Function _Repr() As String
1805 ''' Convert the UnitTest instance to a readable string, typically for debugging purposes (DebugPrint ...)
1806 ''' Args:
1807 ''' Return:
1808 ''' "[UnitTest]
1813 _Repr = cstUnitTest
1815 End Function ' SFUnitTests.SF_UnitTest._Repr
1817 REM ============================================== END OF SFUNITTESTS.SF_UNITTEST
1818 </script:module>