Repository.mk | 1 desktop/CppunitTest_desktop_lib.mk | 1 scp2/source/ooo/directory_ooo.scp | 5 wizards/Module_wizards.mk | 1 wizards/Package_sfunittests.mk | 30 wizards/source/configshare/dialog.xlc | 1 wizards/source/configshare/script.xlc | 1 wizards/source/scriptforge/SF_Exception.xba | 10 wizards/source/scriptforge/SF_Root.xba | 15 wizards/source/scriptforge/SF_Services.xba | 1 wizards/source/scriptforge/SF_Utils.xba | 7 wizards/source/scriptforge/po/ScriptForge.pot | 22 wizards/source/scriptforge/po/en.po | 22 wizards/source/sfunittests/SF_Register.xba | 202 ++ wizards/source/sfunittests/SF_UnitTest.xba | 1820 ++++++++++++++++++++++++++ wizards/source/sfunittests/__License.xba | 26 wizards/source/sfunittests/dialog.xlb | 3 wizards/source/sfunittests/script.xlb | 7 18 files changed, 2171 insertions(+), 4 deletions(-)
New commits: commit 14c7bc1c90d671743c2f25b6958bb54f03140597 Author: Jean-Pierre Ledure <[email protected]> AuthorDate: Fri Jun 3 17:51:57 2022 +0200 Commit: Jean-Pierre Ledure <[email protected]> CommitDate: Sat Jun 4 12:08:36 2022 +0200 ScriptForge - New 'UnitTest' service for Basic The "UnitTest" service is implemented as a new Basic library called 'SFUnitTests'. ScriptForge unit tests (SF_UnitTest class module) ====================== 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 setupand shutdown code - 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). The code to be tested may be released as an extension. It does not need to make use of ScriptForge services. The test reporting device is the Console. Definitions: - Test Case: each test case is a Basic Sub. - Test Suite: a collection of test cases stored in 1 Basic module. - Unit test: a set of test suites stored in 1 library. Two modes: - the normal mode ("full mode"), using test suites and test cases The UnitTest service is passed as argument to each test case. - the "simple mode" limited to the use of the Assert...() methods. 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 ... ' ... .Dispose() End With 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 a call to the ReportError() method. Change-Id: I9d9b889b148f172cd868af455493c8c696d1e953 Reviewed-on: https://gerrit.libreoffice.org/c/core/+/135365 Tested-by: Jean-Pierre Ledure <[email protected]> Tested-by: Jenkins Reviewed-by: Jean-Pierre Ledure <[email protected]> diff --git a/Repository.mk b/Repository.mk index 5532b993dfde..4004cbe142df 100644 --- a/Repository.mk +++ b/Repository.mk @@ -1002,6 +1002,7 @@ $(eval $(call gb_Helper_register_packages_for_install,ooo,\ wizards_basicsrvsfdatabases \ wizards_basicsrvsfdialogs \ wizards_basicsrvsfdocuments \ + wizards_basicsrvsfunittests \ wizards_basicsrvsfwidgets \ wizards_basicsrvstandard \ wizards_basicsrvtemplate \ diff --git a/desktop/CppunitTest_desktop_lib.mk b/desktop/CppunitTest_desktop_lib.mk index 61d5cb1f31c5..d8f58cac18da 100644 --- a/desktop/CppunitTest_desktop_lib.mk +++ b/desktop/CppunitTest_desktop_lib.mk @@ -75,6 +75,7 @@ $(eval $(call gb_CppunitTest_use_packages,desktop_lib, \ wizards_basicsrvsfdatabases \ wizards_basicsrvsfdialogs \ wizards_basicsrvsfdocuments \ + wizards_basicsrvsfunittests \ wizards_basicsrvsfwidgets \ wizards_basicsrvtemplate \ wizards_basicsrvtools \ diff --git a/scp2/source/ooo/directory_ooo.scp b/scp2/source/ooo/directory_ooo.scp index 66c895575a7f..71bc2f2f76eb 100644 --- a/scp2/source/ooo/directory_ooo.scp +++ b/scp2/source/ooo/directory_ooo.scp @@ -285,6 +285,11 @@ Directory gid_Dir_Basic_SFDocuments DosName = "SFDocuments"; End +Directory gid_Dir_Basic_SFUnitTests + ParentID = gid_Dir_Basic; + DosName = "SFUnitTests"; +End + Directory gid_Dir_Basic_SFWidgets ParentID = gid_Dir_Basic; DosName = "SFWidgets"; diff --git a/wizards/Module_wizards.mk b/wizards/Module_wizards.mk index 14757e57bb10..580eafcdea29 100644 --- a/wizards/Module_wizards.mk +++ b/wizards/Module_wizards.mk @@ -33,6 +33,7 @@ $(eval $(call gb_Module_add_targets,wizards,\ Package_sfdatabases \ Package_sfdialogs \ Package_sfdocuments \ + Package_sfunittests \ Package_sfwidgets \ Package_standard \ Package_template \ diff --git a/wizards/Package_sfunittests.mk b/wizards/Package_sfunittests.mk new file mode 100644 index 000000000000..54b50e016e5a --- /dev/null +++ b/wizards/Package_sfunittests.mk @@ -0,0 +1,30 @@ +# -*- Mode: makefile-gmake; tab-width: 4; indent-tabs-mode: t -*- +# +# This file is part of the LibreOffice project. +# +# This Source Code Form is subject to the terms of the Mozilla Public +# License, v. 2.0. If a copy of the MPL was not distributed with this +# file, You can obtain one at http://mozilla.org/MPL/2.0/. +# +# This file incorporates work covered by the following license notice: +# +# Licensed to the Apache Software Foundation (ASF) under one or more +# contributor license agreements. See the NOTICE file distributed +# with this work for additional information regarding copyright +# ownership. The ASF licenses this file to you under the Apache +# License, Version 2.0 (the "License"); you may not use this file +# except in compliance with the License. You may obtain a copy of +# the License at http://www.apache.org/licenses/LICENSE-2.0 . +# + +$(eval $(call gb_Package_Package,wizards_basicsrvsfunittests,$(SRCDIR)/wizards/source/sfunittests)) + +$(eval $(call gb_Package_add_files,wizards_basicsrvsfunittests,$(LIBO_SHARE_FOLDER)/basic/SFUnitTests,\ + SF_Register.xba \ + SF_UnitTest.xba \ + __License.xba \ + dialog.xlb \ + script.xlb \ +)) + +# vim: set noet sw=4 ts=4: diff --git a/wizards/source/configshare/dialog.xlc b/wizards/source/configshare/dialog.xlc index 8db62f073800..2849d7a9b79e 100644 --- a/wizards/source/configshare/dialog.xlc +++ b/wizards/source/configshare/dialog.xlc @@ -14,5 +14,6 @@ <library:library library:name="SFDatabases" xlink:href="$(INST)/@LIBO_SHARE_FOLDER@/basic/SFDatabases/dialog.xlb/" xlink:type="simple" library:link="true" library:readonly="false"/> <library:library library:name="SFDialogs" xlink:href="$(INST)/@LIBO_SHARE_FOLDER@/basic/SFDialogs/dialog.xlb/" xlink:type="simple" library:link="true" library:readonly="false"/> <library:library library:name="SFDocuments" xlink:href="$(INST)/@LIBO_SHARE_FOLDER@/basic/SFDocuments/dialog.xlb/" xlink:type="simple" library:link="true" library:readonly="false"/> + <library:library library:name="SFUnitTests" xlink:href="$(INST)/@LIBO_SHARE_FOLDER@/basic/SFUnitTests/dialog.xlb/" xlink:type="simple" library:link="true" library:readonly="false"/> <library:library library:name="SFWidgets" xlink:href="$(INST)/@LIBO_SHARE_FOLDER@/basic/SFWidgets/dialog.xlb/" xlink:type="simple" library:link="true" library:readonly="false"/> </library:libraries> diff --git a/wizards/source/configshare/script.xlc b/wizards/source/configshare/script.xlc index d1de5ea4f948..ff05ff37b026 100644 --- a/wizards/source/configshare/script.xlc +++ b/wizards/source/configshare/script.xlc @@ -14,5 +14,6 @@ <library:library library:name="SFDatabases" xlink:href="$(INST)/@LIBO_SHARE_FOLDER@/basic/SFDatabases/script.xlb/" xlink:type="simple" library:link="true" library:readonly="false"/> <library:library library:name="SFDialogs" xlink:href="$(INST)/@LIBO_SHARE_FOLDER@/basic/SFDialogs/script.xlb/" xlink:type="simple" library:link="true" library:readonly="false"/> <library:library library:name="SFDocuments" xlink:href="$(INST)/@LIBO_SHARE_FOLDER@/basic/SFDocuments/script.xlb/" xlink:type="simple" library:link="true" library:readonly="false"/> + <library:library library:name="SFUnitTests" xlink:href="$(INST)/@LIBO_SHARE_FOLDER@/basic/SFUnitTests/script.xlb/" xlink:type="simple" library:link="true" library:readonly="false"/> <library:library library:name="SFWidgets" xlink:href="$(INST)/@LIBO_SHARE_FOLDER@/basic/SFWidgets/script.xlb/" xlink:type="simple" library:link="true" library:readonly="false"/> </library:libraries> diff --git a/wizards/source/scriptforge/SF_Exception.xba b/wizards/source/scriptforge/SF_Exception.xba index aeac2fb91aab..11e97b02b753 100644 --- a/wizards/source/scriptforge/SF_Exception.xba +++ b/wizards/source/scriptforge/SF_Exception.xba @@ -133,6 +133,10 @@ Const SQLSYNTAXERROR = "SQLSYNTAXERROR" ' Python Const PYTHONSHELLERROR = "PYTHONSHELLERROR" +' SF_UnitTest +Const UNITTESTLIBRARYERROR = "UNITTESTLIBRARYERROR" +Const UNITTESTMETHODERROR = "UNITTESTMETHODERROR" + REM ============================================================= PRIVATE MEMBERS ' User defined errors @@ -1025,6 +1029,12 @@ Try: Case PYTHONSHELLERROR ' SF_Exception.PythonShell (Python only) sMessage = sLocation _ & "\n" & "\n" & .GetText("PYTHONSHELL") + Case UNITTESTLIBRARYERROR ' SFUnitTests._NewUnitTest(LibraryName) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("UNITTESTLIBRARY", pvArgs(0)) + Case UNITTESTMETHODERROR ' SFUnitTests.SF_UnitTest(Method) + sMessage = sLocation _ + & "\n" & "\n" & .GetText("UNITTESTMETHOD", pvArgs(0)) Case Else End Select End With diff --git a/wizards/source/scriptforge/SF_Root.xba b/wizards/source/scriptforge/SF_Root.xba index f0d81252469e..4db0efb42c1d 100644 --- a/wizards/source/scriptforge/SF_Root.xba +++ b/wizards/source/scriptforge/SF_Root.xba @@ -1012,6 +1012,21 @@ Try: , Comment := "SF_Exception.PythonShell error message" _ & "APSO: to leave unchanged" _ ) + ' SFUnitTests._NewUnitTest + .AddText( Context := "UNITTESTLIBRARY" _ + , MsgId := "The requested library could not be located.\n" _ + & "The UnitTest service has not been initialized.\n\n" _ + & "Library name : « %1 »" _ + , Comment := "SFUnitTest could not locate the library gven as argument\n" _ + & "%1: The name of the library" _ + ) + ' SFUnitTests.SF_UnitTest + .AddText( Context := "UNITTESTMETHOD" _ + , MsgId := "The method '%1' is unexpected in the current context.\n" _ + & "The UnitTest service cannot proceed further with the on-going test." _ + , Comment := "SFUnitTest finds a RunTest() call in a inappropriate location\n" _ + & "%1: The name of a method" _ + ) End With End If diff --git a/wizards/source/scriptforge/SF_Services.xba b/wizards/source/scriptforge/SF_Services.xba index a2ab63828819..627dc4d2e8fe 100644 --- a/wizards/source/scriptforge/SF_Services.xba +++ b/wizards/source/scriptforge/SF_Services.xba @@ -130,6 +130,7 @@ Try: sLibrary = "SFDocuments" Case "dialog", "dialogevent" : sLibrary = "SFDialogs" Case "database" : sLibrary = "SFDatabases" + Case "unittest" : sLibrary = "SFUnitTests" Case "menu", "popupmenu" : sLibrary = "SFWidgets" Case Else End Select diff --git a/wizards/source/scriptforge/SF_Utils.xba b/wizards/source/scriptforge/SF_Utils.xba index e26cca66a776..91b703c46431 100644 --- a/wizards/source/scriptforge/SF_Utils.xba +++ b/wizards/source/scriptforge/SF_Utils.xba @@ -51,8 +51,9 @@ Global Const V_SFOBJECT = 103 ' ScriptForge object: has Object Global Const V_BASICOBJECT = 104 ' User Basic object Type _ObjectDescriptor ' Returned by the _VarTypeObj() method - iVarType As Integer ' One of the V_NOTHING, V_xxxOBJECT constants - sObjectType As String ' Either "" or "com.sun.star..." or a ScriptForge object type (ex. "SF_SESSION" or "DICTIONARY") + iVarType As Integer ' One of the V_NOTHING, V_xxxOBJECT constants + sObjectType As String ' Either "" or "com.sun.star..." or a ScriptForge object type (ex. "SF_SESSION" or "DICTIONARY") + sServiceName As String ' Either "" or the service name of a ScriptForge object type (ex. "ScriptForge.Exception"- End Type REM ================================================================== EXCEPTIONS @@ -1065,6 +1066,7 @@ Try: With oObjDesc .iVarType = VarType(pvValue) .sObjectType = "" + .sServiceName = "" bUno = False If .iVarType = V_OBJECT Then If IsNull(pvValue) Then @@ -1089,6 +1091,7 @@ Try: bUno = False ' Try if the Basic object has an ObjectType property .sObjectType = oValue.ObjectType + .sServiceName = oValue.ServiceName End If ' Derive the return value from the object type Select Case True diff --git a/wizards/source/scriptforge/po/ScriptForge.pot b/wizards/source/scriptforge/po/ScriptForge.pot index b1727527da58..248d800c017c 100644 --- a/wizards/source/scriptforge/po/ScriptForge.pot +++ b/wizards/source/scriptforge/po/ScriptForge.pot @@ -14,7 +14,7 @@ msgid "" msgstr "" "Project-Id-Version: PACKAGE VERSION\n" "Report-Msgid-Bugs-To: https://bugs.libreoffice.org/enter_bug.cgi?product=LibreOffice&bug_status=UNCONFIRMED&component=UI\n"; -"POT-Creation-Date: 2022-03-09 14:52:15\n" +"POT-Creation-Date: 2022-05-04 18:07:20\n" "PO-Revision-Date: YYYY-MM-DD HH:MM:SS\n" "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n" "Language-Team: LANGUAGE <EMAIL@ADDRESS>\n" @@ -952,4 +952,24 @@ msgctxt "PYTHONSHELL" msgid "" "The APSO extension could not be located in your LibreOffice " "installation." +msgstr "" + +#. SFUnitTest could not locate the library gven as argument +#. %1: The name of the library +#, kde-format +msgctxt "UNITTESTLIBRARY" +msgid "" +"The requested library could not be located.\n" +"The UnitTest service has not been initialized.\n" +"\n" +"Library name : « %1 »" +msgstr "" + +#. SFUnitTest finds a RunTest() call in a inappropriate location +#. %1: The name of a method +#, kde-format +msgctxt "UNITTESTMETHOD" +msgid "" +"The method '%1' is unexpected in the current context.\n" +"The UnitTest service cannot proceed further with the on-going test." msgstr "" \ No newline at end of file diff --git a/wizards/source/scriptforge/po/en.po b/wizards/source/scriptforge/po/en.po index b1727527da58..248d800c017c 100644 --- a/wizards/source/scriptforge/po/en.po +++ b/wizards/source/scriptforge/po/en.po @@ -14,7 +14,7 @@ msgid "" msgstr "" "Project-Id-Version: PACKAGE VERSION\n" "Report-Msgid-Bugs-To: https://bugs.libreoffice.org/enter_bug.cgi?product=LibreOffice&bug_status=UNCONFIRMED&component=UI\n"; -"POT-Creation-Date: 2022-03-09 14:52:15\n" +"POT-Creation-Date: 2022-05-04 18:07:20\n" "PO-Revision-Date: YYYY-MM-DD HH:MM:SS\n" "Last-Translator: FULL NAME <EMAIL@ADDRESS>\n" "Language-Team: LANGUAGE <EMAIL@ADDRESS>\n" @@ -952,4 +952,24 @@ msgctxt "PYTHONSHELL" msgid "" "The APSO extension could not be located in your LibreOffice " "installation." +msgstr "" + +#. SFUnitTest could not locate the library gven as argument +#. %1: The name of the library +#, kde-format +msgctxt "UNITTESTLIBRARY" +msgid "" +"The requested library could not be located.\n" +"The UnitTest service has not been initialized.\n" +"\n" +"Library name : « %1 »" +msgstr "" + +#. SFUnitTest finds a RunTest() call in a inappropriate location +#. %1: The name of a method +#, kde-format +msgctxt "UNITTESTMETHOD" +msgid "" +"The method '%1' is unexpected in the current context.\n" +"The UnitTest service cannot proceed further with the on-going test." msgstr "" \ No newline at end of file diff --git a/wizards/source/sfunittests/SF_Register.xba b/wizards/source/sfunittests/SF_Register.xba new file mode 100644 index 000000000000..360abba50381 --- /dev/null +++ b/wizards/source/sfunittests/SF_Register.xba @@ -0,0 +1,202 @@ +<?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_Register" script:language="StarBasic" script:moduleType="normal">REM ======================================================================================================================= +REM === The ScriptForge library and its associated libraries are part of the LibreOffice project. === +REM === The SFUnitTests library is one of the associated libraries. === +REM === Full documentation is available on https://help.libreoffice.org/ === +REM ======================================================================================================================= + +Option Compatible +Option Explicit + +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' +''' SF_Register +''' =========== +''' The ScriptForge framework includes +''' the master ScriptForge library +''' a number of "associated" libraries SF* +''' any user/contributor extension wanting to fit into the framework +''' +''' The main methods in this module allow the current library to cling to ScriptForge +''' - RegisterScriptServices +''' Register the list of services implemented by the current library +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const UNITTESTLIBRARYERROR = "UNITTESTLIBRARYERROR" + +REM ============================================================== PUBLIC METHODS + +REM ----------------------------------------------------------------------------- +Public Sub RegisterScriptServices() As Variant +''' Register into ScriptForge the list of the services implemented by the current library +''' Each library pertaining to the framework must implement its own version of this method +''' +''' It consists in successive calls to the RegisterService() and RegisterEventManager() methods +''' with 2 arguments: +''' ServiceName: the name of the service as a case-insensitive string +''' ServiceReference: the reference as an object +''' If the reference refers to a module, then return the module as an object: +''' GlobalScope.Library.Module +''' If the reference is a class instance, then return a string referring to the method +''' containing the New statement creating the instance +''' "libraryname.modulename.function" + + With GlobalScope.ScriptForge.SF_Services + .RegisterService("UnitTest", "SFUnitTests.SF_Register._NewUnitTest") ' Reference to the function initializing the service + End With + +End Sub ' SFUnitTests.SF_Register.RegisterScriptServices + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Public Function _NewUnitTest(Optional ByVal pvArgs As Variant) As Object +''' Create a new instance of the SF_UnitTest class +' Args: +''' Location: if empty, the location of the library is presumed to be in GlobalScope.BasicLibraries +''' Alternatives are: +''' - the name of a document: see SF_UI.WindowName +''' - an explicit SFDocuments.Document instance +''' - the component containing the library, typically ThisComponent +''' LibraryName: the name of the library containing the test code +''' Returns: +''' The instance or Nothing +''' Exceptions: +''' UNITTESTLIBRARYNOTFOUND The library could not be found + +Dim oUnitTest As Object ' Return value +Dim vLocation As Variant ' Alias of pvArgs(0) +Dim vLibraryName As Variant ' alias of pvArgs(1) +Dim vLocations As Variant ' "user", "share" or document +Dim sLocation As String ' A single location +Dim sTargetLocation As String ' "user" or the document name +Dim vLanguages As Variant ' "Basic", "Python", ... programming languages +Dim sLanguage As String ' A single programming language +Dim vLibraries As Variant ' Library names +Dim sLibrary As String ' A single library +Dim vModules As Variant ' Module names +Dim sModule As String ' A single module +Dim vModuleNames As Variant ' Module names +Dim oRoot As Object ' com.sun.star.script.browse.BrowseNodeFactory +Dim iLibrary As Integer ' The index of the target location in vLibraries + +Dim FSO As Object ' SF_FileSystem +Dim i As Integer, j As Integer, k As Integer, l As Integer + +Const cstService = "SFUnitTests.UnitTest" + + If ScriptForge.SF_Utils._ErrorHandling() Then On Local Error GoTo Catch + +Check: + If IsMissing(pvArgs) Or IsEmpty(pvArgs) Then pvArgs = Array() + If UBound(pvArgs) >= 0 Then vLocation = pvArgs(0) Else vLocation = "" + If IsEmpty(vLocation) Then vLocation = "" + If UBound(pvArgs) >= 1 Then vLibraryName = pvArgs(1) Else vLibraryName = "" + If IsEmpty(vLibraryName) Then vLibraryName = "" + If Not ScriptForge.SF_Utils._Validate(vLocation, "Location", Array(V_STRING, ScriptForge.V_OBJECT)) Then GoTo Finally + If Not ScriptForge.SF_Utils._Validate(vLibraryName, "LibraryName", V_STRING) Then GoTo Finally + + Set oUnitTest = Nothing + Set FSO = CreateScriptService("ScriptForge.FileSystem") + + ' Determine the library container hosting the test code + + ' Browsing starts from root element + Set oRoot = SF_Utils._GetUNOService("BrowseNodeFactory").createView(com.sun.star.script.browse.BrowseNodeFactoryViewTypes.MACROORGANIZER) + + If Len(vLibraryName) > 0 Then + + ' Determine the target location, as a string. The location is either: + ' - the last component of a document's file name + ' - "user" = My Macros & Dialogs + If VarType(vLocation) = ScriptForge.V_OBJECT Then + sTargetLocation = FSO.GetName(vLocation.URL) + ElseIf Len(vLocation) = 0 Then + sTargetLocation = "user" ' Testing code is presumed NOT in "share" + Else + sTargetLocation = FSO.GetName(vLocation) + End If + + ' Exploration is done via tree nodes + iLibrary = -1 + If Not IsNull(oRoot) Then + If oRoot.hasChildNodes() Then + vLocations = oRoot.getChildNodes() + For i = 0 To UBound(vLocations) + sLocation = vLocations(i).getName() + If sLocation = sTargetLocation Then + If vLocations(i).hasChildNodes() Then + vLanguages = vLocations(i).getChildNodes() + For j = 0 To UBound(vLanguages) + sLanguage = vLanguages(j).getName() + ' Consider Basic libraries only + If sLanguage = "Basic" Then + If vLanguages(j).hasChildNodes() Then + vLibraries = vLanguages(j).getChildNodes() + For k = 0 To UBound(vLibraries) + sLibrary = vLibraries(k).getName() + ' Consider the targeted library only + If sLibrary = vLibraryName Then + iLibrary = k + If vLibraries(k).hasChildNodes() Then + vModules = vLibraries(k).getChildNodes() + vModuleNames = Array() + For l = 0 To UBound(vModules) + sModule = vModules(l).getName() + vModuleNames = ScriptForge.SF_Array.Append(vModuleNames, sModule) + Next l + End If + Exit For + End If + Next k + End If + End If + If iLibrary >= 0 Then Exit For + Next j + End If + End If + If iLibrary >= 0 Then Exit For + Next i + End If + End If + If iLibrary < 0 Then GoTo CatchLibrary + + End If + +Try: + ' Create the unittest Basic object and initialize its attributes + Set oUnitTest = New SF_UnitTest + With oUnitTest + Set .[Me] = oUnitTest + If Len(vLibraryName) > 0 Then + .LibrariesContainer = sTargetLocation + .Scope = Iif(sTargetLocation = "user", "application", "document") + .Libraries = vLibraries + .LibraryName = sLibrary + .LibraryIndex = iLibrary + .Modules = vModules + .ModuleNames = vModuleNames + ._ExecutionMode = .FULLMODE + ._WhenAssertionFails = .FAILSTOPSUITE + ' Launch the test timer + .TestTimer = CreateScriptService("ScriptForge.Timer", True) + Else + ._ExecutionMode = .SIMPLEMODE + ._WhenAssertionFails = .FAILIMMEDIATESTOP + End If + End With + +Finally: + Set _NewUnitTest = oUnitTest + Exit Function +Catch: + GoTo Finally +CatchLibrary: + ScriptForge.SF_Exception.RaiseFatal(UNITTESTLIBRARYERROR, vLibraryName) + GoTo Finally +End Function ' SFUnitTests.SF_Register._NewUnitTest + +REM ============================================== END OF SFUNITTESTS.SF_REGISTER +</script:module> \ No newline at end of file diff --git a/wizards/source/sfunittests/SF_UnitTest.xba b/wizards/source/sfunittests/SF_UnitTest.xba new file mode 100644 index 000000000000..c3a1daa9dc9d --- /dev/null +++ b/wizards/source/sfunittests/SF_UnitTest.xba @@ -0,0 +1,1820 @@ +<?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 abount the console in the ScriptForge.Exception service. +''' +''' Definitions: +''' - Test Case +''' A test case is the individual unit of testing. +''' It checks for a specific response to a particular set of inputs. +''' A test case in the UnitTest service is represented by a Basic Sub. +''' The name of the Sub starts conventionally with "Test_". +''' The test fails if one of the included AssertXXX methods returns False +''' - Test Suite +''' A test suite is a collection of test cases that should be executed together. +''' A test suite is represented by a Basic module. +''' A suite may include the tasks needed to prepare one or more tests, and any associated cleanup actions. +''' This may involve, for example, creating temporary files or directories, opening a document, loading libraries. +''' Conventionally those tasks are part pf the SetUp') and TearDown() methods. +''' - Unit test +''' A full unit test is a set of test suites (each suite in a separate Basic module), +''' each of them being a set of test cases (each case is located in a separate Basic Sub). +''' +''' Two modes: +''' Beside the normal mode ("full mode"), using test suites and test cases, a second mode exists, called "simple mode" +''' limited to the use exclusively of the Assert...() methods. +''' Their boolean returned value may support the execution of limited unit tests. +''' +''' Service invocation examples: +''' In full mode, the service creation is external to test cases +''' Dim myUnitTest As Variant +''' myUnitTest = CreateScriptService("UnitTest", ThisComponent, "Tests") +''' ' Test code is in the library "Tests" located in the current document +''' In simple mode, the service creation is internal to every test case +''' Dim myUnitTest As Variant +''' myUnitTest = CreateScriptService("UnitTest") +''' With myUnitTest +''' If Not .AssertTrue(...) Then ... ' Only calls to the Assert...() methods are allowed +''' ' ... +''' .Dispose() +''' End With +''' +''' Minimalist full mode example +''' Code to be tested (stored in library "Standard" of document "MyDoc.ods") : +''' Function ArraySize(arr As Variant) As Long +''' If IsArray(arr) Then ArraySize = UBound(arr) - LBound(arr) + 1 Else ArraySize = -1 +''' End Function +''' Test code (stored in module "AllTests" of library "Tests" of document "MyDoc.ods") : +''' Sub Main() ' Sub to trigger manually, f.i. from the Tools + Run Macro tabbed bar +''' GlobalScope.BasicLibraries.loadLibrary("ScriptForge") +''' Dim test : test = CreateScriptService("UnitTest", ThisComponent, "Tests") +''' test.RunTest("AllTests") ' AllTests is a module name ; test cases are named "Test_*" (default) +''' test.Dispose() +''' End Sub +''' REM ------------------------------------------------------------------------------ +''' Sub Setup(test) ' The unittest service is passed as argument +''' ' Optional Sub to initialize processing of the actual test suite +''' Dim exc : exc = CreateScriptService("Exception") +''' exc.Console(Modal := False) ' Watch test progress in the console +''' End Sub +''' REM ------------------------------------------------------------------------------ +''' Sub Test_ArraySize(test) +''' On Local Error GoTo CatchErr +''' test.AssertEqual(ArraySize(10), -1, "When not array") +''' test.AssertEqual(ArraySize(Array(1, 2, 3)), 3, "When simple array") +''' test.AssertEqual(ArraySize(DimArray(3)), 4, "When array with empty items") +''' Exit Sub +''' CatchErr: +''' test.ReportError("ArraySize() is corrupt") +''' End Sub +''' REM ------------------------------------------------------------------------------ +''' Sub TearDown(test) +''' ' Optional Sub to finalize processing of the actual test suite +''' End Sub +''' +''' Error handling +''' To support the debugging of the tested code, the UnitTest service, in cases of +''' - assertion failure +''' - Basic run-time error in the tested code +''' - Basic run-time error in the testing code (the unit tests) +''' will comment the error location and description in a message box and in the console log, +''' providing every test case (in either mode) implements an error handler containing at least: +''' Sub Test_Case1(test As Variant) +''' On Local Error GoTo Catch +''' ' ... (AssertXXX(), Fail(), ...) +''' Exit Sub +''' Catch: +''' test.ReportError() +''' End Sub +''' +''' Detailed user documentation: +''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_unittest.html?DbPAR=BASIC +''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' + +REM ================================================================== EXCEPTIONS + +Private Const UNITTESTMETHODERROR = "UNITTESTMETHODERROR" + +REM ============================================================= PRIVATE MEMBERS + +Private [Me] As Object +Private [_Parent] As Object +Private ObjectType As String ' Must be "UNITTEST" +Private ServiceName As String + +' Testing code +Private LibrariesContainer As String ' Document or user Basic library containing the test library +Private Scope As String ' Scope when running a Basic script with Session.ExecuteBasicScript() +Private Libraries As Variant ' Set of libraries +Private LibraryName As String ' Name of the library containing the test code +Private LibraryIndex As Integer ' Index in Libraries +Private Modules As Variant ' Set of modules +Private ModuleNames As Variant ' Set of module names +Private MethodNames As Variant ' Set of methods in a given module + +' Internals +Private _Verbose As Boolean ' When True, every assertion is reported,failing or not +Private _LongMessage As Boolean ' When False, only the message provided by the tester is considered + ' When True (default), that message is appended to the standard message +Private _WhenAssertionFails As Integer ' Determines what to do when a test fails + +' Test status +Private _Status As Integer ' 0 = standby + ' 1 = test suite started + ' 2 = setup started + ' 3 = test case started + ' 4 = teardown started +Private _ExecutionMode As Integer ' 1 = Test started with RunTest() + ' 2 = Test started with CreateScriptService() Only Assert() methods allowed +Private _Module As String ' Exact name of module currently running +Private _TestCase As String ' Exact name of test case currently running +Private _ReturnCode As Integer ' 0 = Normal end + ' 1 = Assertion failed + ' 2 = Skip request (in Setup() only) + '-1 = abnormal end +Private _FailedAssert As String ' Assert function that returned a failure + +' Timers +Private TestTimer As Object ' Started by CreateScriptService() +Private SuiteTimer As Object ' Started by RunTest() +Private CaseTimer As Object ' Started by new case + +' Services +Private Exception As Object ' SF_Exception +Private Session As Object ' SF_Session + +REM ============================================================ MODULE CONSTANTS + +' When assertion fails constants: error is reported + ... +Global Const FAILIGNORE = 0 ' Ignore the failure +Global Const FAILSTOPSUITE = 1 ' Module TearDown is executed, then next suite may be started (default in full mode) +Global Const FAILIMMEDIATESTOP = 2 ' Stop immediately (default in simple mode) + +' Unit tests status (internal use only => not Global) +Const STATUSSTANDBY = 0 ' No test active +Const STATUSSUITESTARTED = 1 ' RunTest() started +Const STATUSSETUP = 2 ' A Setup() method is running +Const STATUSTESTCASE = 3 ' A test case is running +Const STATUSTEARDOWN = 4 ' A TearDown() method is running + +' Return codes +Global Const RCNORMALEND = 0 ' Normal end of test or test not started +Global Const RCASSERTIONFAILED = 1 ' An assertion within a test case returned False +Global Const RCSKIPTEST = 2 ' A SkipTest() was issued by a Setup() method +Global Const RCABORTTEST = 3 ' Abnormal end of test + +' Execution modes +Global Const FULLMODE = 1 ' 1 = Test started with RunTest() +Global Const SIMPLEMODE = 2 ' 2 = Test started with CreateScriptService() Only Assert() methods allowed + +Const INVALIDPROCEDURECALL = "5" ' Artificial error raised when an assertion fails + +REM ===================================================== CONSTRUCTOR/DESTRUCTOR + +REM ----------------------------------------------------------------------------- +Private Sub Class_Initialize() + Set [Me] = Nothing + Set [_Parent] = Nothing + ObjectType = "UNITTEST" + ServiceName = "SFUnitTests.UnitTest" + LibrariesContainer = "" + Scope = "" + Libraries = Array() + LibraryName = "" + LibraryIndex = -1 + _Verbose = False + _LongMessage = True + _WhenAssertionFails = -1 + _Status = STATUSSTANDBY + _ExecutionMode = SIMPLEMODE + _Module = "" + _TestCase = "" + _ReturnCode = RCNORMALEND + _FailedAssert = "" + Set TestTimer = Nothing + Set SuiteTimer = Nothing + Set CaseTimer = Nothing + Set Exception = CreateScriptService("ScriptForge.Exception") + Set Session = CreateScriptService("ScriptForge.Session") +End Sub ' SFUnitTests.SF_UnitTest Constructor + +REM ----------------------------------------------------------------------------- +Private Sub Class_Terminate() + If Not IsNull(CaseTimer) Then CaseTimer = CaseTimer.Dispose() + If Not IsNull(SuiteTimer) Then SuiteTimer = SuiteTimer.Dispose() + If Not IsNull(TestTimer) Then TestTimer = TestTimer.Dispose() + Call Class_Initialize() +End Sub ' SFUnitTests.SF_UnitTest Destructor + +REM ----------------------------------------------------------------------------- +Public Function Dispose() As Variant + Call Class_Terminate() + Set Dispose = Nothing +End Function ' SFUnitTests.SF_UnitTest Explicit destructor + +REM ================================================================== PROPERTIES + +REM ----------------------------------------------------------------------------- +Property Get LongMessage() As Variant +''' When False, only the message provided by the tester is considered +''' When True (default), that message is appended to the standard message + LongMessage = _PropertyGet("LongMessage") +End Property ' SFUnitTests.SF_UnitTest.LongMessage (get) + +REM ----------------------------------------------------------------------------- +Property Let LongMessage(Optional ByVal pvLongMessage As Variant) +''' Set the updatable property LongMessage + _PropertySet("LongMessage", pvLongMessage) +End Property ' SFUnitTests.SF_UnitTest.LongMessage (let) + +REM ----------------------------------------------------------------------------- +Property Get ReturnCode() As Integer +''' RCNORMALEND = 0 ' Normal end of test or test not started +''' RCASSERTIONFAILED = 1 ' An assertion within a test case returned False +''' RCSKIPTEST = 2 ' A SkipTest() was issued by a Setup() method +''' RCABORTTEST = 3 ' Abnormal end of test + ReturnCode = _PropertyGet("ReturnCode") +End Property ' SFUnitTests.SF_UnitTest.ReturnCode (get) + +REM ----------------------------------------------------------------------------- +Property Get Verbose() As Variant +''' The Verbose property indicates if all sertions 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 +''' Elgible 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 +''' Elgible 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 +''' Elgible 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 +''' Elgible 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 +''' Args: + + +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) +''' Forces a test Logure + +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 finctions 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: +''' The return code of the esecution (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: +''' The return code of the esecution (RCxxx constants +''' 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 = _Duration("Test", True) & "SKIPTEST TESTSUITE='" & _Module & "'" + _ReportMessage(sSkipMessage, Message) + End If + +Finally: + SkipTest = bSkip + ScriptForge.SF_Utils._ExitFunction(cstThisSub) + Exit Function +Catch: + _ReturnCode = RCABORTTEST + GoTo Finally +CatchMethod: + ScriptForge.SF_Exception.RaiseFatal(UNITTESTMETHODERROR, "SkipTest") + GoTo Catch +End Function ' SFUnitTests.SF_UnitTest.SkipTest + +REM =========================================================== PRIVATE FUNCTIONS + +REM ----------------------------------------------------------------------------- +Private Function _Assert(ByVal psAssert As String _ + , ByVal pvReturn As Variant _ + , ByRef A As Variant _ + , ByRef B As Variant _ + , Optional ByVal pvMessage As Variant _ + , Optional ByVal pvArg As Variant _ + ) As Boolean +''' Evaluation of the assertion and management of the success or the failure +''' Args: +''' psAssert: the assertion verb as a string +''' pvReturn: may be True, False or Empty +''' When True (resp. False), the assertion must be evaluated as True (resp. False) +''' e.g. AssertEqual() will call _Assert("AssertEqual", True, ...) +''' AssertNotEqual() will call _Assert("AssertNotEqual", False, ...) +''' Empty may be used for recursive calls of the function (for comparing arrays, ...) +''' A: always present +''' B: may be empty +''' pvMessage: the message to display on the console +''' pvArg: optional additional argument of the assert function +''' Returns: +''' True when success + +Dim bAssert As Boolean ' Return value +Dim bEval As Boolean ' To be compared with pvReturn +Dim iVarTypeA As Integer ' Alias of _VarTypeExt(A) +Dim iVarTypeB As Integer ' Alias of _VarTypeExt(B) +Dim oVarTypeObjA As Object ' SF_Utils.ObjectDescriptor +Dim oVarTypeObjB As Object ' SF_Utils.ObjectDescriptor +Dim oUtils As Object : Set oUtils = ScriptForge.SF_Utils +Dim iDims As Integer ' Number of dimensions of array +Dim oAliasB As Object ' Alias of B to bypass the "Object variable not set" issue +Dim dblA As Double ' Alias of A +Dim dblB As Double ' Alias of B +Dim dblTolerance As Double ' Alias of pvArg +Dim oString As Object : Set oString = ScriptForge.SF_String +Dim sArgName As String ' Argument description +Dim i As Long, j As Long + +Check: + bAssert = False + If IsMissing(pvMessage) Then pvMessage = "" + If Not oUtils._Validate(pvMessage, "Message", V_STRING) Then GoTo Finally + If IsMissing(pvArg) Then pvArg = "" + +Try: + iVarTypeA = oUtils._VarTypeExt(A) + iVarTypeB = oUtils._VarTypeExt(B) + sArgName = "" + + Select Case UCase(psAssert) + Case UCase("AssertAlmostEqual"), UCase("AssertNotAlmostEqual") + bEval = ( iVarTypeA = iVarTypeB And iVarTypeA = ScriptForge.V_NUMERIC ) + If bEval Then + dblA = CDbl(A) + dblB = CDbl(B) + dblTolerance = Abs(CDbl(pvArg)) + bEval = ( Abs(dblA - dblB) <= (dblTolerance * Iif(Abs(dblA) > Abs(DblB), Abs(dblA), Abs(dblB))) ) + End If + Case UCase("AssertEqual"), UCase("AssertNotEqual") + If Not IsArray(A) Then + bEval = ( iVarTypeA = iVarTypeB ) + If bEval Then + Select Case iVarTypeA + Case V_EMPTY, V_NULL + Case V_STRING + bEval = ( StrComp(A, B, 1) = 0 ) + Case ScriptForge.V_NUMERIC, ScriptForge.V_BOOLEAN + bEval = ( A = B ) + Case V_DATE + bEval = ( Abs(DateDiff("s", A, B)) = 0 ) + Case ScriptForge.V_OBJECT + Set oVarTypeObjA = oUtils._VarTypeObj(A) + Set oVarTypeObjB = oUtils._VarTypeObj(B) + bEval = ( oVarTypeObjA.iVarType = oVarTypeObjB.iVarType ) + If bEval Then + Select Case oVarTypeObjA.iVarType + Case ScriptForge.V_NOTHING + Case ScriptForge.V_UNOOBJECT + bEval = EqualUnoObjects(A, B) + Case ScriptForge.V_SFOBJECT, ScriptForge.V_BASICOBJECT + bEval = False + End Select + End If + End Select + End If + Else ' Compare arrays + bEval = IsArray(B) + If bEval Then + iDims = ScriptForge.SF_Array.CountDims(A) + bEval = ( iDims = ScriptForge.SF_Array.CountDims(B) And iDims <= 2 ) + If bEval Then + Select Case iDims + Case -1, 0 ' Scalars (not possible) or empty arrays + Case 1 ' 1D array + bEval = ( LBound(A) = LBound(B) And UBound(A) = UBound(B) ) + If bEval Then + For i = LBound(A) To UBound(A) + bEval = _Assert(psAssert, Empty, A(i), B(i)) + If Not bEval Then Exit For + Next i + End If + Case 2 ' 2D array + bEval = ( LBound(A, 1) = LBound(B, 1) And UBound(A, 1) = UBound(B, 1) _ + And LBound(A, 2) = LBound(B, 2) And UBound(A, 2) = UBound(B, 2) ) + If bEval Then + For i = LBound(A, 1) To UBound(A, 1) + For j = LBound(A, 2) To UBound(A, 2) + bEval = _Assert(psAssert, Empty, A(i, j), B(i, j)) + If Not bEval Then Exit For + Next j + If Not bEval Then Exit For + Next i + End If + End Select + End If + End If + End If + Case UCase("AssertFalse") + If iVarTypeA = ScriptForge.V_BOOLEAN Then bEval = Not A Else bEval = False + Case UCase("AssertGreater"), UCase("AssertLessEqual") + bEval = ( iVarTypeA = iVarTypeB _ + And (iVarTypeA = ScriptForge.V_NUMERIC Or iVarTypeA = V_STRING Or iVarTypeA = V_DATE) ) + If bEval Then bEval = ( A > B ) + Case UCase("AssertGreaterEqual"), UCase("AssertLess") + bEval = ( iVarTypeA = iVarTypeB _ + And (iVarTypeA = ScriptForge.V_NUMERIC Or iVarTypeA = V_STRING Or iVarTypeA = V_DATE) ) + If bEval Then bEval = ( A >= B ) + Case UCase("AssertIn"), UCase("AssertNotIn") + Set oVarTypeObjB = oUtils._VarTypeObj(B) + Select Case True + Case iVarTypeA = V_STRING And iVarTypeB = V_STRING + bEval = ( Len(A) > 0 And Len(B) > 0 ) + If bEval Then bEval = ( InStr(1, B, A, 0) > 0 ) + Case (iVarTypeA = V_DATE Or iVarTypeA = V_STRING Or iVarTypeA = ScriptForge.V_NUMERIC) _ + And iVarTypeB >= ScriptForge.V_ARRAY + bEval = ( ScriptForge.SF_Array.CountDims(B) = 1 ) + If bEval Then bEval = ScriptForge.SF_Array.Contains(B, A, CaseSensitive := True) + Case oVarTypeObjB.iVarType = ScriptForge.V_SFOBJECT And oVarTypeObjB.sObjectType = "DICTIONARY" + bEval = ( Len(A) > 0 ) + If bEval Then + Set oAliasB = B + bEval = ScriptForge.SF_Array.Contains(oAliasB.Keys(), A, CaseSensitive := True) + End If + Case Else + bEval = False + End Select + Case UCase("AssertIsInstance"), UCase("AssertNotInstance") + Set oVarTypeObjA = oUtils._VarTypeObj(A) + sArgName = "ObjectType" + With oVarTypeObjA + Select Case .iVarType + Case ScriptForge.V_UNOOBJECT + bEval = ( pvArg = .sObjectType ) + Case ScriptForge.V_SFOBJECT + bEval = ( UCase(pvArg) = UCase(.sObjectType) Or UCase(pvArg) = "SF_" & UCase(.sObjectType) _ + Or UCase(pvArg) = UCase(.sServiceName) ) + Case ScriptForge.V_NOTHING, ScriptForge.V_BASICOBJECT + bEval = False + Case >= ScriptForge.V_ARRAY + bEval = ( UCase(pvArg) = "ARRAY" ) + Case Else + bEval = ( UCase(TypeName(A)) = UCase(pvArg) ) + End Select + End With + Case UCase("AssertIsNothing"), UCase("AssertNotNothing") + bEval = ( iVarTypeA = ScriptForge.V_OBJECT ) + If bEval Then bEval = ( A Is Nothing ) + Case UCase("AssertIsNull"), UCase("AssertNotNull") + bEval = ( iVarTypeA = V_NULL ) + Case UCase("AssertLike"), UCase("AssertNotLike") + sArgName = "Pattern" + bEval = ( iVarTypeA = V_STRING And Len(pvArg) > 0 ) + If bEval Then bEval = oString.IsLike(A, pvArg, CaseSensitive := True) + Case UCase("AssertRegex"), UCase("AssertNotRegex") + sArgName = "Regex" + bEval = ( iVarTypeA = V_STRING And Len(pvArg) > 0 ) + If bEval Then bEval = oString.IsRegex(A, pvArg, CaseSensitive := True) + Case UCase("AssertTrue") + If iVarTypeA = ScriptForge.V_BOOLEAN Then bEval = A Else bEval = False + Case UCase("FAIL"), UCase("Log") + bEval = True + Case Else + End Select + + ' Check the result of the assertion vs. what it should be + If IsEmpty(pvReturn) Then + bAssert = bEval ' Recursive call => Reporting and failure management are done by calling _Assert() procedure + Else ' pvReturn is Boolean => Call from user script + bAssert = Iif(pvReturn, bEval, Not bEval) + ' Report the assertion evaluation + If _Verbose Or Not bAssert Then + _ReportMessage(" " & psAssert _ + & Iif(IsEmpty(A), "", " = " & bAssert & ", A = " & oUtils._Repr(A)) _ + & Iif(IsEmpty(B), "", ", B = " & oUtils._Repr(B)) _ + & Iif(Len(sArgName) = 0, "", ", " & sArgName & " = " & pvArg) _ + , pvMessage) + End If + ' Manage assertion failure + If Not bAssert Then + _FailedAssert = psAssert + Select Case _WhenAssertionFails + Case FAILIGNORE ' Do nothing + Case Else + _ReturnCode = RCASSERTIONFAILED + ' Cause artificially a run-time error + Dim STRINGBADUSE As String + + '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + '+ To avoid a run-time error on next executable statement, + + '+ insert an error handler in the code of your test case: + + '+ Like in next code: + + '+ On Local Error GoTo Catch + + '+ ... + ... etc. - the rest is truncated
