commit 8cd1dabd49dd26f6d030555acc45ba2c9af577f9 Author: IRBorisov <8611739+IRBorisov@users.noreply.github.com> Date: Fri Jun 7 20:43:26 2024 +0300 Initial commit diff --git a/VBAMake.txt b/VBAMake.txt new file mode 100644 index 0000000..2d993da --- /dev/null +++ b/VBAMake.txt @@ -0,0 +1,36 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact_home, source_home + +id = VBABuilder +name = VBABuilder +description = Система сборки и тестирования VBA +artifact_home = VBABuilder +source_home = VBABuilder +install_home = \\fs1.concept.ru\projects\10 Автоматизация деятельности\01 Высокие технологии\VBABuilder + +%% +# === Build section === +# Available commands: +# build LOCAL_MANIFEST +# copy LOCAL_SOURCE -> [LOCAL_ARTIFACT] +# save_as LOCAL_ARTIFACT -> LOCAL_ARTIFACT +# run LOCAL_SOURCE.bat + +build script\manifest.txt +build script\TestCommons.txt +build script\TestVisio.txt +build script\TestWord.txt + +copy test + +%% +# === Install section == +# Available commands: +# install LOCAL_ARTIFACT -> [INSTALL_PATH] +# add_template LOCAL_ARTIFACT -> [LOCAL_TEMPLATE] +# run LOCAL_ARTIFACT.bat <- [PARAMETERS] +# run APPLICATION <- [PARAMETERS] + +install !Builder.xlsm \ No newline at end of file diff --git a/VERSION b/VERSION new file mode 100644 index 0000000..6085e94 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +1.2.1 diff --git a/script/TestCommons.txt b/script/TestCommons.txt new file mode 100644 index 0000000..48386c6 --- /dev/null +++ b/script/TestCommons.txt @@ -0,0 +1,102 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = TestCommons.xlsm +artifact = TestCommons.xlsm + +%% +# === Imports Section === +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SharedHome path + +api + ex_WinAPI.bas + API_Project.cls + API_VsoWrapper.cls + API_WordWrapper.cls + API_XLWrapper.cls + API_Path.cls + +parsers + z_ParserRegex.bas + ParserDate.cls + +utility + ex_VBA.bas + ex_Hash.bas + ex_Collection.bas + ex_Regex.bas + ex_Color.bas + + CDS_Edge.cls + CDS_Graph.cls + CDS_Node.cls + CDS_NodeSH.cls + CDS_StaticHierarchy.cls + CDS_Interval.cls + CDS_CompoundIntervals.cls + API_LinkedComponents.cls + API_StrongComponents.cls + API_GraphOrdering.cls + API_JSON.cls + API_Config.cls + +dev + DevTester.bas + API_Logger.cls + +%% +# === Source Code Section == +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SourceHome path + +src + commons + DevHelper.bas + Declarations.bas + Main.bas + MainImpl.bas + + test + TestCustomObject.cls + s_ExCollection.cls + s_ExVBA.cls + s_ExHash.cls + s_ExWinAPI.cls + s_ParseDate.cls + s_Logger.cls + s_XLWrapper.cls + s_VsoWrapper.cls + s_WordWrapper.cls + s_Graph.cls + s_StaticHierarchy.cls + s_ExColor.cls + s_CompoundIntervals.cls + s_Path.cls + s_JSON.cls + s_Config.cls + +%% +# ===== UI Section ======= +# Pairs of path to UI elements, use " -> " delimiter +# First component is a path relative to SourceHome\ui folders +# Second component is internal path inside project file + +%% +# === References Section === +# List dependencies in one of the formats +# global : GLOBAL_NAME +# guid : {REGISTERED_GUID} +# file : PATH_TO_LIBRARY + +global : VBScript_RegExp_55 +global : Scripting +global : Visio +global : Word +global : Shell32 +global : VBIDE +global : ADODB \ No newline at end of file diff --git a/script/TestVisio.txt b/script/TestVisio.txt new file mode 100644 index 0000000..5ea5255 --- /dev/null +++ b/script/TestVisio.txt @@ -0,0 +1,68 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = TestVisio.vsdm +artifact = TestVisio.vsdm + +%% +# === Imports Section === +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SharedHome path + +dev + DevTester.bas + +api + API_VsoWrapper.cls + +utility + ex_VBA.bas + CDS_Edge.cls + CDS_Factorizator.cls + CDS_Graph.cls + CDS_Node.cls + +visio + z_CCVsoExtension.bas + z_VsoGraph.bas + z_VsoUtilities.bas + API_UndoWrapper.cls + + +%% +# === Source Code Section == +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SourceHome path + +src + visio + DevHelper.bas + Declarations.bas + Main.bas + MainImpl.bas + + test + s_UndoWrapper.cls + s_Factorizator.cls + s_VsoUtilities.cls + s_VsoExtension.cls + s_VsoGraph.cls + +%% +# ===== UI Section ======= +# Pairs of path to UI elements, use " -> " delimiter +# First component is a path relative to SourceHome\ui folders +# Second component is internal path inside project file + +%% +# === References Section === +# List dependencies in one of the formats +# global : GLOBAL_NAME +# guid : {REGISTERED_GUID} +# file : PATH_TO_LIBRARY + +global : Scripting \ No newline at end of file diff --git a/script/TestWord.txt b/script/TestWord.txt new file mode 100644 index 0000000..6abb00c --- /dev/null +++ b/script/TestWord.txt @@ -0,0 +1,53 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = TestWord.docm +artifact = TestWord.docm + +%% +# === Imports Section === +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SharedHome path + +dev + DevTester.bas + +word + ex_Word.bas + +utility + ex_VBA.bas + +%% +# === Source Code Section == +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SourceHome path + +src + word + DevHelper.bas + Declarations.bas + Main.bas + MainImpl.bas + + test + s_TextEdit.cls + +%% +# ===== UI Section ======= +# Pairs of path to UI elements, use " -> " delimiter +# First component is a path relative to SourceHome\ui folders +# Second component is internal path inside project file + +%% +# === References Section === +# List dependencies in one of the formats +# global : GLOBAL_NAME +# guid : {REGISTERED_GUID} +# file : PATH_TO_LIBRARY + +global : Scripting \ No newline at end of file diff --git a/script/manifest.txt b/script/manifest.txt new file mode 100644 index 0000000..033a89e --- /dev/null +++ b/script/manifest.txt @@ -0,0 +1,110 @@ +# == Properties Section == +# configuration properties +# use .ini format to define properties +# mandatory properties: name, artifact + +name = !Builder.xlsm +artifact = !Builder.xlsm + +%% +# === Imports Section === +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SharedHome path + +dev + DevTools.bas + DevTester.bas + + CDS_InfoTests.cls + CDS_InfoFunction.cls + API_Logger.cls + API_TestRunner.cls + +api + ex_WinAPI.bas + API_Path.cls + API_Project.cls + API_VsoWrapper.cls + API_WordWrapper.cls + API_XLWrapper.cls + API_UserInteraction.cls + +excel + ex_Excel.bas + +utility + ex_VBA.bas + ex_Collection.bas + ex_DataPreparation.bas + ex_Version.bas + + API_Timer.cls + API_JSON.cls + API_DistrManifest.cls + +%% +# === Source Code Section == +# Hierarchy of folders and files +# Use Tabulator to mark next level in hierarchy +# All folders are nested into SourceHome path + +src + builder + DevHelper.bas + Declarations.bas + Main.bas + MainImpl.bas + z_UIRibbon.bas + z_UIMessages.bas + + CB_SharedModules.cls + CB_AddModule.cls + CB_AddProduct.cls + DescriptorUI.cls + InfoComponent.cls + InfoManifest.cls + InfoMakefile.cls + InfoProduct.cls + InfoAction.cls + InfoBuild.cls + InfoGlobals.cls + ItemActionEnvironment.cls + ItemVBReference.cls + + database + DataAccess.bas + DB_SharedModules.cls + DB_Products.cls + DB_Components.cls + DB_GlobalRefs.cls + DB_Tests.cls + IteratorSharedModule.cls + IteratorTest.cls + IteratorComponent.cls + IteratorProduct.cls + +%% +# ===== UI Section ======= +# Pairs of path to UI elements, use " -> " delimiter +# First component is a path relative to SourceHome\ui folders +# Second component is internal path inside project file + +.rels -> _rels\.rels +customUI.xml -> customUI\customUI.xml + +%% +# === References Section === +# List dependencies in one of the formats +# global : GLOBAL_NAME +# guid : {REGISTERED_GUID} +# file : PATH_TO_LIBRARY + +global : VBIDE +global : Shell32 +global : Scripting +global : ADODB +global : Visio +global : Word +global : MSForms +global : IWshRuntimeLibrary \ No newline at end of file diff --git a/skeleton/!Builder.xlsm b/skeleton/!Builder.xlsm new file mode 100644 index 0000000..ccc29c4 Binary files /dev/null and b/skeleton/!Builder.xlsm differ diff --git a/skeleton/TestCommons.xlsm b/skeleton/TestCommons.xlsm new file mode 100644 index 0000000..8b4267a Binary files /dev/null and b/skeleton/TestCommons.xlsm differ diff --git a/skeleton/TestVisio.vsdm b/skeleton/TestVisio.vsdm new file mode 100644 index 0000000..ac70ce9 Binary files /dev/null and b/skeleton/TestVisio.vsdm differ diff --git a/skeleton/TestWord.docm b/skeleton/TestWord.docm new file mode 100644 index 0000000..c4f8a61 Binary files /dev/null and b/skeleton/TestWord.docm differ diff --git a/src/builder/CB_AddModule.cls b/src/builder/CB_AddModule.cls new file mode 100644 index 0000000..764f5b2 --- /dev/null +++ b/src/builder/CB_AddModule.cls @@ -0,0 +1,65 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "CB_AddModule" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' Callback adding shared module from file +Option Explicit + +Private iOut_ As IteratorSharedModule +Private tester_ As VBIDE.VBProject +Private base_ As String +Private fso_ As Scripting.FileSystemObject + +Private Type ProcedureDescriptor + name_ As String + type_ As VBIDE.vbext_ProcKind +End Type + +Public Function Init(iOut As IteratorSharedModule, oTestProject As VBIDE.VBProject, sBasePath$) + Set iOut_ = iOut + base_ = sBasePath + Set tester_ = oTestProject + Set fso_ = New Scripting.FileSystemObject +End Function + +Public Function TryAddModule(aFile As Scripting.File) + If Not IsVBAModuleExtension(fso_.GetExtensionName(aFile.Name)) Then _ + Exit Function + + Dim sPath$: sPath = aFile.Path + Dim aComp As VBIDE.VBComponent + Set aComp = tester_.VBComponents.Import(sPath) + + With iOut_ + .Name = aComp.Name + .ModuleType = aComp.Type + .Path = VBA.Mid(sPath, Len(base_) + 2, VBA.Len(sPath) - VBA.Len(base_) - 2 - VBA.Len(aFile.Name)) + .Version = ExtractVersion(aComp.CodeModule) + .LoC = aComp.CodeModule.CountOfLines + .Declarations = aComp.CodeModule.CountOfDeclarationLines + .CountAPI = Dev_CountPublicAPI(aComp.CodeModule) + + Call .Increment + End With + + Call tester_.VBComponents.Remove(aComp) +End Function + +' ===== +Private Function ExtractVersion(target As VBIDE.CodeModule) As String + Const VERSION_PREFIX$ = "module version: " + Dim nLine& + For nLine = 1 To target.CountOfLines Step 1 + Dim sTxt$: sTxt = target.Lines(nLine, 1) + Dim nPrefix&: nPrefix = InStr(1, sTxt, VERSION_PREFIX) + If nPrefix <> 0 Then + ExtractVersion = Right(sTxt, Len(sTxt) - nPrefix + 1 - Len(VERSION_PREFIX)) + Exit Function + End If + Next nLine +End Function diff --git a/src/builder/CB_AddProduct.cls b/src/builder/CB_AddProduct.cls new file mode 100644 index 0000000..425cca6 --- /dev/null +++ b/src/builder/CB_AddProduct.cls @@ -0,0 +1,43 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "CB_AddProduct" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' Callback adding shared module from file +Option Explicit + +Private iProducts_ As DB_Products +Private fso_ As Scripting.FileSystemObject + +Public newCount_ As Long + +Public Function Init(iProducts As DB_Products) + newCount_ = 0 + Set iProducts_ = iProducts + Set fso_ = New Scripting.FileSystemObject +End Function + +Public Function ScanFolder(iFolder As Scripting.Folder) As Boolean +' Callback should return TRUE to continue recursive + Dim sMakefile$: sMakefile = fso_.BuildPath(iFolder, MAKEFILE_NAME) + ScanFolder = Not fso_.FileExists(sMakefile) + If ScanFolder Then _ + Exit Function + + Dim iMake As New InfoMakefile + If Not iMake.Init(sMakefile) Then _ + Exit Function + + If iProducts_.Contains(iMake.ProductName) Then + Dim iProduct As IteratorProduct: Set iProduct = iProducts_.Access(iMake.ProductName) + If VBA.UCase(iProduct.SourcePath) = VBA.UCase(iFolder.Path) Then _ + Call iProduct.SyncMakefile(iMake) + Else + Call iProducts_.Insert(iMake) + newCount_ = newCount_ + 1 + End If +End Function diff --git a/src/builder/CB_SharedModules.cls b/src/builder/CB_SharedModules.cls new file mode 100644 index 0000000..416422b --- /dev/null +++ b/src/builder/CB_SharedModules.cls @@ -0,0 +1,27 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "CB_SharedModules" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public data_ As Scripting.Dictionary +Private fso_ As Scripting.FileSystemObject + +Public Function Init() + Set data_ = New Scripting.Dictionary + Set fso_ = New Scripting.FileSystemObject +End Function + +Public Function ProcessFile(aFile As Scripting.File) + If Not IsVBAModuleExtension(fso_.GetExtensionName(aFile.Name)) Then _ + Exit Function + Dim sKey$: sKey = fso_.GetBaseName(aFile.Name) + If data_.Exists(sKey) Then _ + Exit Function + Call data_.Add(sKey, aFile.Path) +End Function diff --git a/src/builder/Declarations.bas b/src/builder/Declarations.bas new file mode 100644 index 0000000..fb011f1 --- /dev/null +++ b/src/builder/Declarations.bas @@ -0,0 +1,213 @@ +Attribute VB_Name = "Declarations" +Option Private Module +Option Explicit + +Public Const SERVER_PATH_CIHT = "\\fs1.concept.ru\projects\04 \60 " +Public Const SERVER_PATH_AUTOMATION = "\\fs1.concept.ru\projects\10 " + +' ========= Parameters ======= +Public Const MAKEFILE_NAME = "VBAMake.txt" +Public Const LOC_MINIMUM = 3 ' Minimum ammount of lines of code required to be listed in Modules + +Public Const FIRST_ROW = 2 + +Public Const TABLE_HEAD_PRODUCT = "ProductName" + +Public Const SUBFOLDER_SKELETON = "skeleton" +Public Const SUBFOLDER_SCRIPT = "script" +Public Const SUBFOLDER_UI = "ui" +Public Const SUBFOLDER_VERSION_ARCHIVE = "!Versions" + +Public Const SHEET_PRODUCTS = "Products" +Public Const SHEET_COMPONENTS = "Components" +Public Const SHEET_SHARED = "Shared" +Public Const SHEET_TESTS = "Tests" +Public Const SHEET_PARAMETERS = "Params" + +Public Const MANIFEST_PROPS_NAME = "name" +Public Const MANIFEST_PROPS_ARTIFACT = "artifact" + +Public Const MAKEFILE_PROPS_ID = "id" +Public Const MAKEFILE_PROPS_NAME = "name" +Public Const MAKEFILE_PROPS_DESCRIPTION = "description" +Public Const MAKEFILE_PROPS_ARTIFACT = "artifact_home" +Public Const MAKEFILE_PROPS_SOURCE = "source_home" +Public Const MAKEFILE_PROPS_INSTALL = "install_home" + +Public Enum TVBReference + T_REF_UNDEF = 0 + [_First] = 1 + + T_REF_GLOBAL_NAME = 1 + T_REF_GUID = 2 + T_REF_FILE = 3 + + [_Last] = 3 +End Enum + +Public Enum TBuildAction + T_ACT_UNDEF = 0 + [_First] = 1 + + T_ACT_BUILD = 1 + T_ACT_COPY = 2 + T_ACT_SAVE_AS = 3 + T_ACT_RUN = 4 + T_ACT_INSTALL = 5 + T_ACT_TEMPLATE = 6 + + [_Last] = 6 +End Enum + +' Domain for local paths +Public Enum TPathDomain + T_PD_UNDEF = 0 + [_First] = 1 + + T_PD_SOURCE = 1 + T_PD_ARTIFACT = 2 + T_PD_GLOBAL = 3 + + [_Last] = 3 +End Enum + +Public Enum TBuildStatus + T_BS_PENDING = 0 + T_BS_OK = 1 + T_BS_FAILED = 2 +End Enum + +Public Enum TBuildType + T_BUILD_DEBUG = 0 + T_BUILD_RELEASE = 1 +End Enum + +' _R_ - reference attributes +Public Enum RefsStruct + [_First] = 1 + + S_R_NAME = 1 + S_R_TYPE = 2 + S_R_FILE = 3 + S_R_GUID = 4 + S_R_BROKEN = 5 + S_R_MAJOR = 6 + S_R_MINOR = 7 + S_R_DESCRIPTION = 8 + + [_Last] = 8 +End Enum + +' _M_ - module attributes +Public Enum ModuleStruct + [_First] = 1 + + S_M_NAME = 1 + S_M_TYPE = 2 + S_M_SHARED = 3 + S_M_LINES_TOTAL = 4 + S_M_LINES_DECLARATIONS = 5 + S_M_COUNT_API = 6 + + [_Last] = 6 +End Enum + +' _S_ - shared module attributes +Public Enum SharedStruct + [_First] = 1 + + S_S_NAME = 1 + S_S_TYPE = 2 + S_S_PATH = 3 + S_S_VERSION = 4 + S_S_LINES_TOTAL = 5 + S_S_LINES_DECLARATIONS = 6 + S_S_API_COUNT = 7 + S_S_USAGE = 8 + + [_Last] = 8 +End Enum + +' _T_ - tests module attributes +Public Enum TestStruct + [_First] = 1 + + S_T_PRODUCT = 1 + S_T_COMPONENT = 2 + S_T_SUITE = 3 + S_T_TEST = 4 + S_T_DATE = 5 + S_T_DURATION = 6 + S_T_STATUS = 7 + S_T_MESSAGE = 8 + + [_Last] = 8 +End Enum + +' _G_ - global references +Public Enum GlobalRefsStruct + [_First] = 1 + + S_G_NAME_ID = 1 + S_G_GUID = 2 + S_G_MINOR = 3 + S_G_MAJOR = 4 + S_G_FULL_NAME = 5 + + [_Last] = 5 +End Enum + +' ========== Conversion API ======== +Public Function ActionType2Text(aType As TBuildAction) As String + Select Case aType + Case T_ACT_BUILD: ActionType2Text = "build" + Case T_ACT_COPY: ActionType2Text = "copy" + Case T_ACT_SAVE_AS: ActionType2Text = "save_as" + Case T_ACT_RUN: ActionType2Text = "run" + Case T_ACT_INSTALL: ActionType2Text = "install" + Case T_ACT_TEMPLATE: ActionType2Text = "add_template" + Case Else: ActionType2Text = "UNDEF" + End Select +End Function + +Public Function Text2ActionType(sText$) As TBuildAction + Select Case sText + Case "build": Text2ActionType = T_ACT_BUILD + Case "copy": Text2ActionType = T_ACT_COPY + Case "save_as": Text2ActionType = T_ACT_SAVE_AS + Case "run": Text2ActionType = T_ACT_RUN + Case "install": Text2ActionType = T_ACT_INSTALL + Case "add_template": Text2ActionType = T_ACT_TEMPLATE + Case Else: Text2ActionType = "UNDEF" + End Select +End Function + +Public Function RefTypeFrom(sTypeText$) As TVBReference + Select Case sTypeText + Case "global": RefTypeFrom = T_REF_GLOBAL_NAME + Case "guid": RefTypeFrom = T_REF_GUID + Case "file": RefTypeFrom = T_REF_FILE + Case Else: RefTypeFrom = T_REF_UNDEF + End Select +End Function + +Public Function RefTypeToString(iType As TVBReference) As String + Select Case iType + Case T_REF_GLOBAL_NAME: RefTypeToString = "global" + Case T_REF_GUID: RefTypeToString = "guid" + Case T_REF_FILE: RefTypeToString = "file" + Case Else: RefTypeToString = "UNDEF" + End Select +End Function + +Public Function BuildDescription(bType As TBuildType) As String + Select Case bType + Case T_BUILD_DEBUG: BuildDescription = "Debug" + Case T_BUILD_RELEASE: BuildDescription = "Release" + Case Else: BuildDescription = "UNKNOWN" + End Select +End Function + +Public Function IsVBAModuleExtension(sExt$) As Boolean + IsVBAModuleExtension = sExt = "cls" Or sExt = "frm" Or sExt = "bas" +End Function diff --git a/src/builder/DescriptorUI.cls b/src/builder/DescriptorUI.cls new file mode 100644 index 0000000..27b0220 --- /dev/null +++ b/src/builder/DescriptorUI.cls @@ -0,0 +1,13 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DescriptorUI" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public sourcePath_ As String +Public internalPath_ As String diff --git a/src/builder/DevHelper.bas b/src/builder/DevHelper.bas new file mode 100644 index 0000000..f0d91da --- /dev/null +++ b/src/builder/DevHelper.bas @@ -0,0 +1,25 @@ +Attribute VB_Name = "DevHelper" +Option Private Module +Option Explicit + +Public Function Dev_PrepareSkeleton() + Call ClearShared + Call ClearTests + + Call ThisWorkbook.Sheets(SHEET_COMPONENTS).UsedRange.Offset(1, 0).ClearContents + Call ThisWorkbook.Sheets(SHEET_PRODUCTS).UsedRange.Offset(1, 0).ClearContents +End Function + +Public Function Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_UndoWrapper" + Dim sTest$: sTest = "t_BasicUndo" + Dim sMsg$: sMsg = Dev_RunTestDebug(sSuite, sTest) + Debug.Print sMsg + Call MsgBox(sMsg) +End Function + +Public Function Dev_GetTestSuite(sName$) As Object + Select Case sName + ' Case "s_UndoWrapper": Set Dev_GetTestSuite = New s_UndoWrapper + End Select +End Function diff --git a/src/builder/InfoAction.cls b/src/builder/InfoAction.cls new file mode 100644 index 0000000..76f7739 --- /dev/null +++ b/src/builder/InfoAction.cls @@ -0,0 +1,183 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "InfoAction" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public type_ As TBuildAction +Public args_ As Collection + +Private Sub Class_Initialize() + Set args_ = New Collection +End Sub + +' ===== Properties ===== +Public Property Get Description() As String + Description = ActionType2Text(type_) + If args_.Count > 0 Then _ + Description = Description & " " & args_(1) + If args_.Count > 1 Then _ + Description = Description & " -> " & args_(2) +End Property + +Public Property Get IsBuildOnly() As Boolean + Select Case type_ + Case T_ACT_BUILD: IsBuildOnly = True + Case T_ACT_COPY: IsBuildOnly = True + Case T_ACT_SAVE_AS: IsBuildOnly = True + Case T_ACT_RUN: IsBuildOnly = False + Case T_ACT_INSTALL: IsBuildOnly = False + Case T_ACT_TEMPLATE: IsBuildOnly = False + Case Else: IsBuildOnly = False + End Select +End Property + +Public Property Get IsInstallOnly() As Boolean + Select Case type_ + Case T_ACT_BUILD: IsInstallOnly = False + Case T_ACT_COPY: IsInstallOnly = False + Case T_ACT_SAVE_AS: IsInstallOnly = False + Case T_ACT_RUN: IsInstallOnly = False + Case T_ACT_INSTALL: IsInstallOnly = True + Case T_ACT_TEMPLATE: IsInstallOnly = True + Case Else: IsInstallOnly = False + End Select +End Property + +' ===== Actions ===== +Public Function Execute(env As ItemActionEnvironment) As Boolean + Select Case type_ + Case T_ACT_BUILD: Execute = ExecuteBuild(env) + Case T_ACT_COPY: Execute = ExecuteCopy(env) + Case T_ACT_SAVE_AS: Execute = ExecuteSaveAs(env) + Case T_ACT_RUN: Execute = ExecuteRun(env) + Case T_ACT_INSTALL: Execute = ExecuteInstall(env) + Case T_ACT_TEMPLATE: Execute = ExecuteTemplate(env) + Case Else: Execute = False + End Select +End Function + +' ====== +Private Function ExecuteBuild(env As ItemActionEnvironment) As Boolean + ExecuteBuild = False + + Dim sManifest$: sManifest = CPath(args_(1)).ToGlobal(env.sourceHome_).Text + Dim iComponent As New InfoComponent + If Not iComponent.Init(sManifest, env.sourceHome_, env.artifactHome_, env.productVersion_) Then + Call env.reporter_.Log("Failed loading component manifest: " & sManifest) + Exit Function + End If + + Dim iData As IteratorComponent: Set iData = env.components_.Access(env.product_, iComponent.ItemName) + If iData Is Nothing Then + Call env.reporter_.Log("Failed accessing component: " & sManifest) + Exit Function + End If + + Dim testOut As IteratorTest: Set testOut = env.testDB_.OutputFor(env.product_, iComponent.ItemName) + Dim buildRes As InfoBuild: Set buildRes = iComponent.Build(env.buildType_, env.reporter_, testOut) + Call testOut.RemoveRow + + ExecuteBuild = buildRes.status_ = T_BS_OK + Call iData.SyncBuildInfo(buildRes) +End Function + +Private Function ExecuteCopy(env As ItemActionEnvironment) As Boolean + Dim sSource$: sSource = CPath(args_(1)).ToGlobal(env.sourceHome_).Text + Dim sDestination$ + If args_.Count < 2 Then + sDestination = env.artifactHome_ & "\" & env.fso_.GetFileName(sSource) + Else + sDestination = CPath(args_(2)).ToGlobal(env.artifactHome_).Text + End If + ExecuteCopy = CopyFileOrFolder(sSource, sDestination, env.fso_) +End Function + +Private Function ExecuteSaveAs(env As ItemActionEnvironment) As Boolean + ExecuteSaveAs = False + + Dim iSource As API_Path: Set iSource = CPath(args_(1)).ToGlobal(env.artifactHome_) + Dim iDestination As API_Path: Set iDestination = CPath(args_(2)).ToGlobal(env.artifactHome_) + If iSource.Extension = iDestination.Extension Then + Call CopyFileOrFolder(iSource.Text, iDestination.Text, env.fso_) + Else + Dim aWrap As Object: Set aWrap = AccessArtifact(iSource.Text, bReadOnly:=True) + If aWrap Is Nothing Then + Call env.reporter_.Log("Cannot access artifact: " & iSource.Text) + Exit Function + End If + + Call EnsureFolderExists(env.fso_.GetParentFolderName(iDestination.Text)) + Call aWrap.SaveAs(iDestination.Text) + Call aWrap.ReleaseDocument(bSaveChanges:=True) + End If + + ExecuteSaveAs = True +End Function + +Private Function ExecuteRun(env As ItemActionEnvironment) As Boolean + ExecuteRun = False + + Dim sExec$: sExec = args_(1) + If VBA.InStr(1, sExec, ".") <> 0 Then _ + sExec = CPath(sExec).ToGlobal(IIf(env.isBuilding_, env.sourceHome_, env.artifactHome_)).Text + + Dim fso As New Scripting.FileSystemObject + Dim sHome$: sHome = fso.GetParentFolderName(sExec) + Dim isPowerShell As Boolean: isPowerShell = VBA.UCase(fso.GetExtensionName(sExec)) = "PS1" + + If isPowerShell Then _ + sExec = "PowerShell -NoProfile -ExecutionPolicy Bypass -Command ""& '" & sExec & "'""" + If args_.Count > 1 Then _ + sExec = sExec & " " & args_(2) + + On Error GoTo EXECUTION_ERROR + Dim iShell As New WshShell + iShell.CurrentDirectory = sHome + ExecuteRun = iShell.Run(sExec, waitOnReturn:=True) = 0 + On Error GoTo 0 + Exit Function + +EXECUTION_ERROR: + Call env.reporter_.Log("Failed to interpret shell command: " & sExec) + On Error GoTo 0 +End Function + +Private Function ExecuteInstall(env As ItemActionEnvironment) As Boolean + Dim iSource As API_Path: Set iSource = CPath(args_(1)).ToGlobal(env.artifactHome_) + Dim sDestination$ + If args_.Count < 2 Then + sDestination = env.installHome_ & "\" & iSource.FileName + Else + sDestination = CPath(args_(2)).ToGlobal(env.installHome_).Text + End If + ExecuteInstall = CopyFileOrFolder(iSource.Text, sDestination, env.fso_) +End Function + +Private Function ExecuteTemplate(env As ItemActionEnvironment) As Boolean + ExecuteTemplate = False + + Dim sSource$: sSource = env.artifactHome_ & "\" & args_(1) + Dim sDestName$ + If args_.Count < 2 Then + sDestName = env.fso_.GetFileName(sSource) + Else + sDestName = args_(2) + End If + + Dim vPath As Variant + For Each vPath In Globals.TemplatePaths + Dim sDestination$: sDestination = CPath(sDestName).ToGlobal(CStr(vPath)).Text + If Not CopyFileOrFolder(sSource, sDestination, env.fso_) Then + Call env.reporter_.Log("Failed to install template: " & sDestination) + Exit Function + End If + Next vPath + + ExecuteTemplate = True +End Function diff --git a/src/builder/InfoBuild.cls b/src/builder/InfoBuild.cls new file mode 100644 index 0000000..ef9ec05 --- /dev/null +++ b/src/builder/InfoBuild.cls @@ -0,0 +1,20 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "InfoBuild" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public status_ As TBuildStatus +Public date_ As Double +Public tests_ As CDS_InfoTests + +Private Sub Class_Initialize() + status_ = T_BS_PENDING + Set tests_ = New CDS_InfoTests + date_ = Now() +End Sub diff --git a/src/builder/InfoComponent.cls b/src/builder/InfoComponent.cls new file mode 100644 index 0000000..7c95f3a --- /dev/null +++ b/src/builder/InfoComponent.cls @@ -0,0 +1,307 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "InfoComponent" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public manifest_ As InfoManifest + +Public sourceHome_ As String +Public artifactHome_ As String + +Private version_ As String +Private appWrap_ As Object +Private artSource_ As API_Project +Private bReadOnly_ As Boolean + +Public Function Init(sManifest$, sSources$, sArtifacts$, sVersion$) As Boolean + Set manifest_ = New InfoManifest + sourceHome_ = sSources + artifactHome_ = sArtifacts + version_ = sVersion + Init = manifest_.Init(sManifest) +End Function + +' == Properties = +Public Property Get ItemName() As String + ItemName = manifest_.properties_(MANIFEST_PROPS_NAME) +End Property + +Public Property Get Artifact() As String + Artifact = CPath(manifest_.properties_(MANIFEST_PROPS_ARTIFACT)).ToGlobal(artifactHome_).Text +End Property + +Public Property Get Skeleton() As String + Skeleton = sourceHome_ & "\" & SUBFOLDER_SKELETON & "\" & ItemName +End Property + +' ===== API ===== +Public Function ValidateManifest(bType As TBuildType) As Collection ' of string + If Not OpenArtifact(bReadOnly:=True) Then _ + Exit Function + Set ValidateManifest = manifest_.Validate(bType, appWrap_.Document.VBProject) + Call ReleaseArtifact(bSave:=False) +End Function + +Public Function OpenFileInNewProcess(bReadOnly As Boolean) As Object + Dim iWrap As Object: Set iWrap = AccessArtifact(Artifact, bReadOnly) + If Not iWrap Is Nothing Then _ + Set OpenFileInNewProcess = iWrap.Document +End Function + +Public Function ClearCode() As Boolean + ClearCode = OpenArtifact(bReadOnly:=False) + If ClearCode Then + Call artSource_.RemoveAll + Call ReleaseArtifact(bSave:=True) + End If +End Function + +Public Function ExportCode() As Boolean + ExportCode = OpenArtifact(bReadOnly:=True) + If ExportCode Then + Call artSource_.ExportSrcTo(sourceHome_) + Call ReleaseArtifact(bSave:=False) + ExportCode = manifest_.ExportUI(Artifact, sourceHome_ & "\" & SUBFOLDER_UI) + End If +End Function + +Public Function ExportShared() As Boolean + ExportShared = OpenArtifact(bReadOnly:=True) + If ExportShared Then + Call artSource_.ExportShared + Call ReleaseArtifact(bSave:=False) + End If +End Function + +Public Function ExportAll() As Boolean + ExportAll = OpenArtifact(bReadOnly:=True) + If ExportAll Then + Call artSource_.ExportSrcTo(sourceHome_) + Call artSource_.ExportShared + Call ReleaseArtifact(bSave:=False) + ExportAll = manifest_.ExportUI(Artifact, sourceHome_ & "\" & SUBFOLDER_UI) + End If +End Function + +Public Function ReloadCode() As Boolean + ReloadCode = False + If Not OpenArtifact(bReadOnly:=False) Then _ + Exit Function + Call artSource_.ImportSrcFrom(sourceHome_) + ReloadCode = manifest_.ImportRefs(appWrap_.Document.VBProject) + Call ReleaseArtifact(bSave:=True) + + If ReloadCode Then _ + ReloadCode = manifest_.ImportUI(sourceHome_ & "\" & SUBFOLDER_UI, Artifact) +End Function + +Public Function ReloadShared() As Boolean + ReloadShared = OpenArtifact(bReadOnly:=False) + If ReloadShared Then + Call artSource_.ImportShared + ReloadShared = manifest_.ImportRefs(appWrap_.Document.VBProject) + If ReloadShared Then _ + ReloadShared = CompileVBProject(appWrap_.Document.VBProject) + Call ReleaseArtifact(bSave:=True) + End If +End Function + +Public Function ReloadAll() As Boolean + ReloadAll = OpenArtifact(bReadOnly:=False) + If Not ReloadAll Then _ + Exit Function + + Call artSource_.RemoveAll + Call artSource_.ImportSrcFrom(sourceHome_) + Call artSource_.ImportShared + + ReloadAll = manifest_.ImportRefs(appWrap_.Document.VBProject) + Call ReleaseArtifact(bSave:=True) + + If ReloadAll Then _ + ReloadAll = manifest_.ImportUI(sourceHome_ & "\" & SUBFOLDER_UI, Artifact) +End Function + +Public Function UpdateSkeleton() As Boolean + UpdateSkeleton = manifest_.ExportUI(Artifact, sourceHome_ & "\" & SUBFOLDER_UI) + If Not UpdateSkeleton Then _ + Exit Function + + UpdateSkeleton = OpenArtifact(bReadOnly:=False) + If Not UpdateSkeleton Then _ + Exit Function + + Call artSource_.ExportSrcTo(sourceHome_) + Call artSource_.ExportShared + + Call PrepareSkeletonFor(appWrap_.Document) + Call artSource_.RemoveAll + + Dim fso As New Scripting.FileSystemObject + Dim sSkeletonFile$: sSkeletonFile = Skeleton + Call EnsureFolderExists(fso.GetParentFolderName(sSkeletonFile), fso) + Call appWrap_.SaveAs(sSkeletonFile) + + Call ReleaseArtifact(bSave:=True) +End Function + +Public Function Clear() + Dim fso As New Scripting.FileSystemObject + Dim sFile$: sFile = Artifact + If fso.FileExists(sFile) Then _ + Call fso.DeleteFile(sFile) +End Function + +Public Function Compile() As Boolean + Compile = OpenArtifact(bReadOnly:=True) + If Compile Then + Compile = CompileVBProject(appWrap_.Document.VBProject) + Call ReleaseArtifact(bSave:=False) + End If +End Function + +Public Function Test(ByRef reporter As API_Logger, ByRef iTestOut As IteratorTest) As CDS_InfoTests + If Not OpenArtifact(bReadOnly:=True) Then _ + Exit Function + Set Test = RunTestsInternal(reporter, iTestOut) + Call ReleaseArtifact(bSave:=False) +End Function + +Public Function Build(bType As TBuildType, ByRef reporter As API_Logger, ByRef iTestOut As IteratorTest) As InfoBuild + Set Build = New InfoBuild + Build.status_ = T_BS_FAILED + Call reporter.Log("Start building component: " & ItemName) + Call reporter.Log("Build type: " & BuildDescription(bType)) + + Dim sArtifact$: sArtifact = Artifact + Call reporter.Log("Ensure artifact exists: " & sArtifact) + If Not EnsureArtifactExists() Then _ + Exit Function + + Call reporter.Log("Accessing artifact file: " & sArtifact) + If Not OpenArtifact(bReadOnly:=False) Then _ + Exit Function + + Call reporter.Log("Loading code modules...") + Call artSource_.ImportSrcFrom(sourceHome_) + Call artSource_.ImportShared + Call manifest_.ImportRefs(appWrap_.Document.VBProject) + + If version_ <> vbNullString Then + Call reporter.Log("Writing version number...") + Call UpdateVersionStamp(appWrap_.Document.VBProject, version_) + End If + + Call reporter.Log("Compiling VBProject...") + If Not CompileVBProject(appWrap_.Document.VBProject) Then + Call reporter.Log("Compilation failed") + GoTo SAFE_EXIT + End If + + Call ReleaseArtifact(bSave:=True) + + Call reporter.Log("Importing UI elements...") + If Not manifest_.ImportUI(sourceHome_ & "\" & SUBFOLDER_UI, sArtifact) Then _ + Exit Function + + If Not OpenArtifact(bReadOnly:=True) Then _ + Exit Function + + Call reporter.Log("Validating manifest...") + Dim oErrors As Collection: Set oErrors = manifest_.Validate(bType, appWrap_.Document.VBProject) + If oErrors Is Nothing Then + Call reporter.Log("Validation failed") + GoTo SAFE_EXIT + ElseIf oErrors.Count > 0 Then + Call reporter.Log("Validation failed") + GoTo SAFE_EXIT + End If + + Call reporter.Log("Testing VBProject...") + Dim testResults As CDS_InfoTests: Set testResults = RunTestsInternal(reporter, iTestOut) + Set Build.tests_ = testResults + If testResults Is Nothing Then _ + GoTo SAFE_EXIT + Call reporter.Log("Tests summary: " & testResults.count_ & " | " & testResults.success_ & " / " & testResults.failed_) + If testResults.failed_ <> 0 Then + Call reporter.Log("Tests failed... interrupting build") + GoTo SAFE_EXIT + End If + + If testResults.failed_ <> 0 Then _ + GoTo SAFE_EXIT + + If bType = T_BUILD_RELEASE Then + Call ReleaseArtifact(bSave:=False) + If Not OpenArtifact(bReadOnly:=False) Then _ + Exit Function + Call reporter.Log("Removing debug code for release build...") + Call Dev_RemoveDebugCode(appWrap_.Document.VBProject) + If Not CompileVBProject(appWrap_.Document.VBProject) Then + Call reporter.Log("Compilation failed") + GoTo SAFE_EXIT + End If + End If + + Build.status_ = T_BS_OK +SAFE_EXIT: + Call ReleaseArtifact(bSave:=True) + Call reporter.Log("Finish building component: " & ItemName) +End Function + +' ==== +Private Function EnsureArtifactExists() As Boolean + EnsureArtifactExists = False + + Dim sArtifact$: sArtifact = Artifact + Dim fso As New FileSystemObject + If Not fso.FileExists(sArtifact) Then + Dim sSkeleton$: sSkeleton = Skeleton + If Not fso.FileExists(sSkeleton) Then _ + Exit Function + Call CopyFileOrFolder(sSkeleton, sArtifact, fso) + End If + + EnsureArtifactExists = True +End Function + +Private Function OpenArtifact(bReadOnly As Boolean) As Boolean + Set appWrap_ = AccessArtifact(Artifact, bReadOnly) + If appWrap_ Is Nothing Then + OpenArtifact = False + Exit Function + End If + + Set artSource_ = New API_Project + OpenArtifact = artSource_.Init(appWrap_.Document.VBProject, Globals.SharedHome) + If OpenArtifact Then + bReadOnly_ = bReadOnly + Call manifest_.InitSourceAPI(artSource_) + Else + Call ReleaseArtifact(bSave:=False) + End If +End Function + +Private Function ReleaseArtifact(bSave As Boolean) + If Not artSource_ Is Nothing Then + Call artSource_.Detach + Set artSource_ = Nothing + End If + If Not appWrap_ Is Nothing Then + Call appWrap_.ReleaseDocument(bSaveChanges:=Not bReadOnly_ And bSave) + Set appWrap_ = Nothing + End If +End Function + +Private Function RunTestsInternal(ByRef reporter As API_Logger, ByRef iTestOut As IteratorTest) As CDS_InfoTests + Dim runner As New API_TestRunner + Call runner.Init(appWrap_, reporter, iTestOut) + Set RunTestsInternal = runner.RunAllTests() + Set runner = Nothing +End Function diff --git a/src/builder/InfoGlobals.cls b/src/builder/InfoGlobals.cls new file mode 100644 index 0000000..5926b2f --- /dev/null +++ b/src/builder/InfoGlobals.cls @@ -0,0 +1,86 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "InfoGlobals" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private Const CELL_SHARED_HOME = "c_SharedHome" +Private Const CELL_CODE_BASE = "c_CodeBase" +Private Const CELL_ARTIFACT_HOME = "c_ArtifactsHome" +Private Const CELL_DEFAULT_REFS = "c_DefaultRefs" +Private Const CELL_LOG_FLAG = "c_LogFlag" +Private Const CELL_LOG_FOLDER = "c_LogLocation" +Private Const CELL_DISTRIBUTION = "c_Distribution" + +Private Const TABLE_GLOBAL_REFS = "t_GlobalRefs" + +Private Const RANGE_TEMPLATES = "r_Templates" + +Public build_ As TBuildType + +Private Sub Class_Initialize() + build_ = T_BUILD_DEBUG +End Sub + +Public Property Get Logger() As API_Logger + Static s_Log As API_Logger + If s_Log Is Nothing Then + Set s_Log = New API_Logger + If ThisWorkbook.Names(CELL_LOG_FLAG).RefersToRange = "True" Then + Dim sName$: sName = GenerateLogFilename(ThisWorkbook.Names(CELL_LOG_FOLDER).RefersToRange) + Call s_Log.Init(sName) + End If + End If + Set Logger = s_Log +End Property + +Public Property Get References() As DB_GlobalRefs + Static s_Refs As DB_GlobalRefs + If s_Refs Is Nothing Then + Set s_Refs = New DB_GlobalRefs + Call s_Refs.Init(ThisWorkbook.Worksheets(SHEET_PARAMETERS).ListObjects(TABLE_GLOBAL_REFS)) + End If + Set References = s_Refs +End Property + +Public Property Get SourceHome() As String + SourceHome = ThisWorkbook.Names(CELL_CODE_BASE).RefersToRange +End Property + +Public Property Get SharedHome() As String + SharedHome = ThisWorkbook.Names(CELL_SHARED_HOME).RefersToRange +End Property + +Public Property Get ArtifactHome() As String + ArtifactHome = ThisWorkbook.Names(CELL_ARTIFACT_HOME).RefersToRange +End Property + +Public Property Get DistributionHome() As String + DistributionHome = ThisWorkbook.Names(CELL_DISTRIBUTION).RefersToRange +End Property + +Public Function TemplatePaths() As Collection + Dim dataRange As Excel.Range: Set dataRange = ThisWorkbook.Names(RANGE_TEMPLATES).RefersToRange + Dim cResult As New Collection + Dim aCell As Excel.Range + For Each aCell In dataRange + Dim sTxt$: sTxt = aCell + If sTxt <> vbNullString Then _ + Call cResult.Add(CPath(sTxt).ToGlobal(ThisWorkbook.Path).Text) + Next aCell + Set TemplatePaths = cResult +End Function + +Public Function DefaultRefs() As String + DefaultRefs = ThisWorkbook.Names(CELL_DEFAULT_REFS).RefersToRange +End Function + +' ========== +Private Function GenerateLogFilename(sFolder$) As String + GenerateLogFilename = sFolder & "\" & Format(Now(), "yyyy-mm-dd") & ".txt" +End Function diff --git a/src/builder/InfoMakefile.cls b/src/builder/InfoMakefile.cls new file mode 100644 index 0000000..e41fce5 --- /dev/null +++ b/src/builder/InfoMakefile.cls @@ -0,0 +1,182 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "InfoMakefile" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public sPath_ As String + +Public properties_ As Scripting.Dictionary +Public buildActs_ As Collection ' of InfoAction +Public installActs_ As Collection ' of InfoAction + +Public Function Init(sFile$) As Boolean + sPath_ = sFile + + Set properties_ = New Scripting.Dictionary + Set buildActs_ = New Collection + Set installActs_ = New Collection + + Init = LoadFromFile +End Function + +Public Property Get ProductID() As String + ProductID = properties_(MAKEFILE_PROPS_ID) +End Property + +Public Property Get ProductName() As String + ProductName = properties_(MAKEFILE_PROPS_NAME) +End Property + +Public Function Validate(sSourceHome$, sArtifactHome$, bIsBuilding As Boolean) As Collection + On Error GoTo RETURN_NOTHING + + Dim oLog As New Collection + Dim sArtifacts As New Scripting.Dictionary + Set sArtifacts = ValidateBuildActions(sSourceHome, oLog) + Call ValidateInstallActions(sArtifactHome, oLog, sArtifacts, bIsBuilding) + + Set Validate = oLog +RETURN_NOTHING: +End Function + +' ======= +Private Function LoadFromFile() As Boolean + LoadFromFile = False + + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sPath_) Then _ + Exit Function + + Dim adoStream As New ADODB.Stream + adoStream.Charset = "utf-8" + Call adoStream.Open + Call adoStream.LoadFromFile(sPath_) + Dim sLines() As String: sLines = Split(adoStream.ReadText, vbCrLf) + Call adoStream.Close + + Dim nCurrent&: nCurrent = LBound(sLines, 1) + Dim nLast&: nLast = UBound(sLines, 1) + If Not ScanProperties(sLines, nCurrent, nLast) Then _ + Exit Function + If Not ScanActions(sLines, nCurrent, nLast, buildActs_) Then _ + Exit Function + If Not ScanActions(sLines, nCurrent, nLast, installActs_) Then _ + Exit Function + + LoadFromFile = True +End Function + +Private Function ScanProperties(sLines() As String, ByRef nCurrent&, nLast&) As Boolean + ScanProperties = ExtractProperties(sLines, nCurrent, properties_) + If Not ScanProperties Then _ + Exit Function + ScanProperties = _ + properties_.Exists(MAKEFILE_PROPS_ID) _ + And properties_.Exists(MAKEFILE_PROPS_NAME) _ + And properties_.Exists(MAKEFILE_PROPS_ARTIFACT) _ + And properties_.Exists(MAKEFILE_PROPS_SOURCE) _ + And properties_.Exists(MAKEFILE_PROPS_INSTALL) _ + And nCurrent <= nLast +End Function + +Private Function ScanActions(sLines() As String, ByRef nCurrent&, nLast&, ByRef oSink As Collection) As Boolean + ScanActions = False + + Dim iAction As InfoAction + Do While nCurrent <= nLast + Dim sLine$: sLine = sLines(nCurrent) + nCurrent = nCurrent + 1 + If sLine Like "%%*" Then _ + Exit Do + If Left(sLine, 1) = "#" Then _ + GoTo NEXT_LINE + + + Dim nSpace&: nSpace = InStr(1, sLine, " ") + If nSpace = 0 Then _ + GoTo NEXT_LINE + + Set iAction = New InfoAction + + iAction.type_ = Text2ActionType(Trim(Left(sLine, nSpace))) + sLine = Trim(Right(sLine, Len(sLine) - nSpace)) + + Dim nSeparator&: nSeparator = InStr(1, sLine, IIf(iAction.type_ = T_ACT_RUN, "<-", "->")) + If nSeparator = 0 Then + Call iAction.args_.Add(Trim(sLine)) + Else + Call iAction.args_.Add(Trim(Left(sLine, nSeparator - 1))) + Call iAction.args_.Add(Trim(Right(sLine, Len(sLine) - nSeparator - 2))) + End If + Call oSink.Add(iAction) + +NEXT_LINE: + Loop + + ScanActions = True +End Function + +Private Function ValidateBuildActions(sSourceHome$, oLog As Collection) As Scripting.Dictionary + Dim sArtifacts As New Scripting.Dictionary + + Dim anAction As InfoAction + For Each anAction In buildActs_ + Dim arg1$: arg1 = anAction.args_(1) + Dim iPath As API_Path: Set iPath = CPath(arg1).ToGlobal(sSourceHome) + If anAction.type_ <> T_ACT_SAVE_AS Then + If anAction.type_ <> T_ACT_RUN Then _ + If Not iPath.GlobalExists() Then _ + Call oLog.Add("Missing source: " & arg1) + Else + If Not sArtifacts.Exists(arg1) Then _ + Call oLog.Add("Unknown artifact: " & arg1) + End If + + If anAction.IsInstallOnly Or anAction.type_ = T_ACT_UNDEF Then _ + Call oLog.Add("Invalid build action type: " & anAction.Description) + + If anAction.type_ = T_ACT_BUILD Then + Dim iManifest As New InfoManifest + If iManifest.Init(iPath.Text) Then + Call sArtifacts.Add(iManifest.properties_(MANIFEST_PROPS_ARTIFACT), "") + End If + End If + + If anAction.args_.Count > 1 Then _ + Call sArtifacts.Add(anAction.args_(2), "") + If anAction.args_.Count = 1 And anAction.type_ = T_ACT_COPY Then + If iPath.Extension = vbNullString Then + Call sArtifacts.Add(iPath.BaseName, "") + Else + Call sArtifacts.Add(iPath.FileName, "") + End If + End If + Next anAction + + Set ValidateBuildActions = sArtifacts +End Function + +Private Function ValidateInstallActions(sArtifactHome$, oLog As Collection, sArtifacts As Scripting.Dictionary, bIsBuilding As Boolean) + Dim anAction As InfoAction + For Each anAction In installActs_ + If anAction.IsBuildOnly Or anAction.type_ = T_ACT_UNDEF Then _ + Call oLog.Add("Invalid install action type: " & anAction.Description) + + Dim arg1$: arg1 = anAction.args_(1) + Dim iPath As API_Path: Set iPath = CPath(arg1).ToGlobal(sArtifactHome) + If bIsBuilding Then + If Not sArtifacts.Exists(arg1) Then _ + Call oLog.Add("Unknown artifact: " & arg1) + Else + If Not iPath.GlobalExists Then _ + Call oLog.Add("Missing artifact: " & iPath.Text) + End If + Next anAction +End Function + diff --git a/src/builder/InfoManifest.cls b/src/builder/InfoManifest.cls new file mode 100644 index 0000000..ba9256c --- /dev/null +++ b/src/builder/InfoManifest.cls @@ -0,0 +1,413 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "InfoManifest" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public sPath_ As String + +Public properties_ As Scripting.Dictionary +Public contents_ As Scripting.Dictionary +Public sharedContents_ As Scripting.Dictionary +Public uiElements_ As Collection ' of DescriptorUI +Public references_ As Collection ' of ItemVBReference + +Private fso_ As Scripting.FileSystemObject + +Private Const IMPORTS_MAX_DEPTH = 9 + +Public Function Init(sManifestPath$) As Boolean + sPath_ = sManifestPath$ + + Set properties_ = New Scripting.Dictionary + + Set contents_ = New Scripting.Dictionary + Set sharedContents_ = New Scripting.Dictionary + + Set uiElements_ = New Collection + Set references_ = New Collection + + Set fso_ = New Scripting.FileSystemObject + + Init = LoadFromFile +End Function + +Public Function InitSourceAPI(ByRef target As API_Project) + Call target.SetInternals(contents_, sharedContents_) +End Function + +Public Function AddSrcItem(sName$, sFolder$) + Call contents_.Add(sName, sFolder) +End Function + +Public Function AddSharedItem(sName$, sFolder$) + Call sharedContents_.Add(sName, sFolder) +End Function + +Public Function ExportUI(sSourceFile$, sDestinationFolder$) As Boolean + ExportUI = False + + Dim sZip$: sZip = sDestinationFolder & "\" & "uiTMP" + If Not UnzipFile(sSourceFile, sZip) Then _ + Exit Function + + Dim itemInfo As DescriptorUI + Dim sSourceUI$ + Dim sDestUI$ + For Each itemInfo In uiElements_ + sSourceUI = sZip & "\" & itemInfo.internalPath_ + sDestUI = sDestinationFolder & "\" & itemInfo.sourcePath_ + Call EnsureFolderExists(fso_.GetParentFolderName(sDestUI)) + Call fso_.CopyFile(sSourceUI, sDestUI) + Next itemInfo + + Call fso_.DeleteFolder(sZip) + + ExportUI = True +End Function + +Public Function ImportUI(sSourceFolder$, sDestinationFile$) As Boolean + ImportUI = False + + Dim sZip$: sZip = sSourceFolder & "\" & "uiTMP" + If Not UnzipFile(sDestinationFile, sZip) Then _ + Exit Function + + Dim itemInfo As DescriptorUI + Dim sSourceUI$ + Dim sDestUI$ + For Each itemInfo In uiElements_ + sDestUI = sZip & "\" & itemInfo.internalPath_ + sSourceUI = sSourceFolder & "\" & itemInfo.sourcePath_ + Call EnsureFolderExists(fso_.GetParentFolderName(sDestUI)) + Call fso_.CopyFile(sSourceUI, sDestUI) + Next itemInfo + + ImportUI = ZipFolder(sZip, sDestinationFile) + Call fso_.DeleteFolder(sZip) +End Function + +Public Function ImportRefs(target As VBIDE.VBProject) As Boolean + ImportRefs = False + + Dim iReferences As DB_GlobalRefs: Set iReferences = Globals.References + Dim iRef As ItemVBReference + For Each iRef In references_ + Select Case iRef.type_ + Case T_REF_GLOBAL_NAME + Dim theRef As ItemVBReference: Set theRef = iReferences.GetGlobal(iRef.id_) + If theRef Is Nothing Then + Debug.Print "Invalid global name " & iRef.id_ + Exit Function + End If + If Not TryImportRefGUID(target, theRef.id_, theRef.major_, theRef.minor_) Then _ + Exit Function + Case T_REF_GUID + If Not TryImportRefGUID(target, iRef.id_) Then _ + Exit Function + Case T_REF_FILE + If Not TryImportRefFile(iRef.id_, target) Then _ + Exit Function + End Select + Next iRef + + ImportRefs = True +End Function + +Public Function Validate(bType As TBuildType, target As VBIDE.VBProject) As Collection + Dim oLog As New Collection + + Call ValidateCode(bType, target, Globals.SharedHome, oLog) + Call ValidateRefs(target, Globals.References, oLog) + + Set Validate = oLog +End Function + +' ======= +Private Function LoadFromFile() As Boolean + LoadFromFile = False + + If Not fso_.FileExists(sPath_) Then _ + Exit Function + + Dim adoStream As New ADODB.Stream + adoStream.Charset = "utf-8" + Call adoStream.Open + Call adoStream.LoadFromFile(sPath_) + Dim sLines() As String: sLines = Split(adoStream.ReadText, vbCrLf) + Call adoStream.Close + + Dim nCurrent&: nCurrent = LBound(sLines, 1) + Dim nLast&: nLast = UBound(sLines, 1) + If Not ScanProperties(sLines, nCurrent, nLast) Then _ + Exit Function + If Not ScanStructure(sLines, nCurrent, nLast, "AddSharedItem") Then _ + Exit Function + If Not ScanStructure(sLines, nCurrent, nLast, "AddSrcItem") Then _ + Exit Function + If Not ScanSubstitutes(sLines, nCurrent, nLast) Then _ + Exit Function + If Not ScanReferences(sLines, nCurrent, nLast) Then _ + Exit Function + + LoadFromFile = True +End Function + +Private Function ScanProperties(sLines() As String, ByRef nCurrent&, nLast&) As Boolean + ScanProperties = ExtractProperties(sLines, nCurrent, properties_) + If Not ScanProperties Then _ + Exit Function + ScanProperties = properties_.Exists(MANIFEST_PROPS_NAME) _ + And properties_.Exists(MANIFEST_PROPS_ARTIFACT) _ + And nCurrent <= nLast +End Function + +Private Function ScanStructure(sLines() As String, ByRef nCurrent&, nLast&, sCallback$) As Boolean + ScanStructure = False + + Dim sParts(0 To IMPORTS_MAX_DEPTH) As String + Dim lastLvl&: lastLvl = -1 + Do While nCurrent <= nLast + Dim sLine$: sLine = sLines(nCurrent) + nCurrent = nCurrent + 1 + If sLine Like "%%*" Then _ + Exit Do + + Dim sPart$: sPart = Replace(sLine, vbTab, "") + If sPart = vbNullString Then _ + GoTo NEXT_LINE + If Left(sPart, 1) = "#" Then _ + GoTo NEXT_LINE + + Dim nLevel&: nLevel = Len(sLine) - Len(sPart) + sPart = Trim(sPart) + If nLevel > lastLvl Then _ + GoTo NEXT_PART + + Dim sFile$: sFile = sParts(lastLvl) + If Not IsVBAModuleExtension(fso_.GetExtensionName(sFile)) Then _ + GoTo NEXT_PART + + Call CallByName(Me, sCallback, VbMethod, sFile, ConstructPath(sParts, 0, lastLvl - 1)) + +NEXT_PART: + sParts(nLevel) = sPart + lastLvl = nLevel + +NEXT_LINE: + Loop + If lastLvl <> -1 Then _ + If IsVBAModuleExtension(fso_.GetExtensionName(sParts(lastLvl))) Then _ + Call CallByName(Me, sCallback, VbMethod, sParts(lastLvl), ConstructPath(sParts, 0, lastLvl - 1)) + ScanStructure = nCurrent <= nLast +End Function + +Private Function ScanSubstitutes(sLines() As String, ByRef nCurrent&, nLast&) As Boolean + Dim oNewUI As DescriptorUI + Do While nCurrent <= nLast + Dim sLine$: sLine = sLines(nCurrent) + nCurrent = nCurrent + 1 + If sLine Like "%%*" Then _ + Exit Do + + Dim nSeparator&: nSeparator = InStr(1, sLine, "->") + If nSeparator = 0 Then _ + GoTo NEXT_LINE + If Left(sLine, 1) = "#" Then _ + GoTo NEXT_LINE + + Set oNewUI = New DescriptorUI + oNewUI.sourcePath_ = Trim(Left(sLine, nSeparator - 1)) + oNewUI.internalPath_ = Trim(Right(sLine, Len(sLine) - nSeparator - 1)) + Call uiElements_.Add(oNewUI) + +NEXT_LINE: + Loop + ScanSubstitutes = nCurrent <= nLast +End Function + +Private Function ScanReferences(sLines() As String, ByRef nCurrent&, nLast&) As Boolean + ScanReferences = False + + Dim oRef As ItemVBReference + Do While nCurrent <= nLast + Dim sLine$: sLine = sLines(nCurrent) + nCurrent = nCurrent + 1 + + Dim nSeparator&: nSeparator = InStr(1, sLine, ":") + If nSeparator = 0 Then _ + GoTo NEXT_LINE + If Left(sLine, 1) = "#" Then _ + GoTo NEXT_LINE + + Set oRef = New ItemVBReference + oRef.type_ = RefTypeFrom(Trim(Left(sLine, nSeparator - 1))) + If oRef.type_ = T_REF_UNDEF Then _ + Exit Function + oRef.id_ = Trim(Right(sLine, Len(sLine) - nSeparator)) + + Call references_.Add(oRef) + +NEXT_LINE: + Loop + + ScanReferences = True +End Function + +Private Function ConstructPath(sParts() As String, nFirst&, nLast&) As String + Dim nItem& + For nItem = nFirst To nLast Step 1 + ConstructPath = ConstructPath & sParts(nItem) & "\" + Next nItem + ConstructPath = Left(ConstructPath, Len(ConstructPath) - 1) +End Function + +Private Function ComponentName(target As VBComponent) As String + ComponentName = target.Name + Select Case target.Type + Case vbext_ct_ClassModule: ComponentName = ComponentName & ".cls" + Case vbext_ct_MSForm: ComponentName = ComponentName & ".frm" + Case vbext_ct_StdModule: ComponentName = ComponentName & ".bas" + Case Else: ComponentName = vbNullString + End Select +End Function + +Private Function ValidateCode(bType As TBuildType, target As VBIDE.VBProject, sSharedHome$, ByRef oLog As Collection) + Dim oNames As New Collection + Dim aComp As VBIDE.VBComponent + For Each aComp In target.VBComponents + If aComp.Type = vbext_ct_Document Then _ + GoTo NEXT_COMP + + Dim sName$: sName = ComponentName(aComp) + Call oNames.Add("", sName) + If contents_.Exists(sName) Then _ + GoTo NEXT_COMP + If sharedContents_.Exists(sName) Then _ + GoTo NEXT_COMP + + Call oLog.Add("Unlisted module: " & sName) + +NEXT_COMP: + Next aComp + + Dim aName As Variant + For Each aName In contents_ + If bType = T_BUILD_RELEASE Then _ + If Dev_IsTestingModule(CStr(aName)) Then _ + GoTo NEXT_NAME + If Not InCollection(CStr(aName), oNames) Then _ + Call oLog.Add("Missing module: " & aName) +NEXT_NAME: + Next aName + + For Each aName In sharedContents_ + If Not InCollection(CStr(aName), oNames) Then _ + Call oLog.Add("Missing shared module: " & aName) + Dim sItemPath$: sItemPath = sSharedHome & "\" & sharedContents_(aName) & "\" & aName + If Not fso_.FileExists(sItemPath) Then _ + Call oLog.Add("Missing shared file: " & sItemPath) + Next aName +End Function + +Private Function ValidateRefs(target As VBIDE.VBProject, Globals As DB_GlobalRefs, ByRef oLog As Collection) + Dim projRef As VBIDE.Reference + For Each projRef In target.References + If Not ValidateProjectRef(projRef, target, Globals) Then _ + Call oLog.Add("Unlisted reference: " & projRef.Name) + Next projRef + + Dim iRef As ItemVBReference + For Each iRef In references_ + If Not ValidateManifestRef(target, iRef, Globals) Then _ + Call oLog.Add("Missing reference: " & iRef.ToString) + Next iRef +End Function + +Private Function ValidateProjectRef(target As VBIDE.Reference, proj As VBIDE.VBProject, Globals As DB_GlobalRefs) As Boolean + If target.Type = vbext_rk_Project Then + ValidateProjectRef = True + Exit Function + End If + If IsBasicReference(target, proj) Then + ValidateProjectRef = True + Exit Function + End If + Dim iRef As ItemVBReference + For Each iRef In references_ + If iRef.Test(target) Then + ValidateProjectRef = True + Exit Function + End If + Next iRef + ValidateProjectRef = False +End Function + +Private Function ValidateManifestRef(proj As VBIDE.VBProject, target As ItemVBReference, Globals As DB_GlobalRefs) As Boolean + Dim aRef As VBIDE.Reference + For Each aRef In proj.References + If target.Test(aRef) Then + ValidateManifestRef = True + Exit Function + End If + Next aRef + ValidateManifestRef = False +End Function + +Private Function TryImportRefGUID(target As VBIDE.VBProject, sID$, Optional nMajor& = 0, Optional nMinor& = 0) As Boolean + Dim aRef As VBIDE.Reference + For Each aRef In target.References + If aRef.GUID = sID Then + TryImportRefGUID = True + Exit Function + End If + Next aRef + + On Error GoTo PARSE_ERRORS + Dim newRef As VBIDE.Reference: Set newRef = target.References.AddFromGuid(sID, nMajor, nMinor) + On Error GoTo 0 + + TryImportRefGUID = Not newRef.IsBroken + + Exit Function +PARSE_ERRORS: + TryImportRefGUID = ProcessImportError(Err.Number, Err.Description, sID) +End Function + +Private Function TryImportRefFile(sFile$, target As VBIDE.VBProject) As Boolean + Dim aRef As VBIDE.Reference + For Each aRef In target.References + If aRef.FullPath = sFile Then + TryImportRefFile = True + Exit Function + End If + Next aRef + + On Error GoTo PARSE_ERRORS + Dim newRef As VBIDE.Reference: Set newRef = target.References.AddFromFile(sFile) + On Error GoTo 0 + + TryImportRefFile = newRef.IsBroken + + Exit Function +PARSE_ERRORS: + TryImportRefFile = ProcessImportError(Err.Number, Err.Description, sFile) +End Function + +Private Function ProcessImportError(nID&, sDescription$, sData$) As Boolean + ProcessImportError = False + Select Case Err.Number + Case 48: Debug.Print "Failed loading " & sData + Case 1004: Debug.Print "Trust center is not cofigured properly" + Case -2147319779: Debug.Print "Unknown GUID " & sData + Case 32813 + Debug.Print "Already loaded " & sData + ProcessImportError = True + Case Else: Debug.Print "Unknown error " & nID & " " & sDescription + End Select +End Function diff --git a/src/builder/InfoProduct.cls b/src/builder/InfoProduct.cls new file mode 100644 index 0000000..ca9ded0 --- /dev/null +++ b/src/builder/InfoProduct.cls @@ -0,0 +1,151 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "InfoProduct" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public make_ As InfoMakefile +Public version_ As String +Public distribute_ As Boolean + +Public Function Init(sMakefile$, sVersion$, doDistribute As Boolean) As Boolean + Set make_ = New InfoMakefile + Init = make_.Init(sMakefile) + distribute_ = doDistribute + version_ = sVersion +End Function + +' == Properties = +Public Property Get ProductID() As String + ProductID = make_.properties_(MAKEFILE_PROPS_ID) +End Property + +Public Property Get Name() As String + Name = make_.properties_(MAKEFILE_PROPS_NAME) +End Property + +Public Property Get SourceHome() As String + SourceHome = CPath(make_.properties_(MAKEFILE_PROPS_SOURCE)).ToGlobal(Globals.SourceHome).Text +End Property + +Public Property Get ArtifactHome() As String + ArtifactHome = CPath(make_.properties_(MAKEFILE_PROPS_ARTIFACT)).ToGlobal(Globals.ArtifactHome).Text +End Property + +Public Property Get InstallHome() As String + InstallHome = make_.properties_(MAKEFILE_PROPS_INSTALL) +End Property + +' ===== Actions ====== +Public Function ValidateMakefile() As Collection ' of string + Set ValidateMakefile = make_.Validate(SourceHome, ArtifactHome, bIsBuilding:=True) +End Function + +Public Function Build(bType As TBuildType, reporter As API_Logger, dbComponents As DB_Components, testDB As DB_Tests, Optional sArtPath$ = vbNullString) As Boolean + Build = False + + If sArtPath = vbNullString Then _ + sArtPath = ArtifactHome + + Dim env As New ItemActionEnvironment + Call env.InitBuild(bType, Name, version_, sArtPath, SourceHome, reporter, dbComponents, testDB) + + Call reporter.Log("Start building product: " & Name) + Call reporter.Log("Version: " & version_) + + If version_ <> vbNullString Then + Call reporter.Log("Updating version file: " & version_) + If Not VersionCreateFile(env.sourceHome_, version_) Then _ + Exit Function + End If + + Call reporter.Log("Validating makefile...") + If Not ActValidateMakefile(env) Then _ + Exit Function + + Call reporter.Log("Processing build actions...") + If Not ActProcessActions(env) Then _ + Exit Function + + Build = True + Call reporter.Log("Finish building product: " & Name) +End Function + +Public Function Install(bType As TBuildType, reporter As API_Logger, dbComponents As DB_Components, sInstallPath$) As Boolean + Install = False + + Call reporter.Log("Start installing product: " & Name) + Call reporter.Log("Version: " & version_) + + Dim env As New ItemActionEnvironment + Call env.InitInstall(bType, Name, version_, ArtifactHome, SourceHome, reporter, dbComponents, sInstallPath) + + Call reporter.Log("Validating makefile...") + If Not ActValidateMakefile(env) Then _ + Exit Function + + Call reporter.Log("Processing installation actions...") + If Not ActProcessActions(env) Then _ + Exit Function + + If distribute_ Then + Call reporter.Log("Updating distribution manifest...") + If Not UpdateDistribution Then + Call reporter.Log("Failed to save distribution manifest...") + Exit Function + End If + End If + + Install = True + Call reporter.Log("Finish installing product: " & Name) +End Function + +' ============= +Private Function UpdateDistribution() As Boolean + Dim sManifest$: sManifest = Globals.DistributionHome & "\" & FILE_DISTRIBUTION_MANIFEST + Dim iDistribution As New API_DistrManifest + Call iDistribution.LoadFrom(sManifest) + Call iDistribution.SetVersion(make_.ProductID, version_) + UpdateDistribution = iDistribution.SaveTo(sManifest) +End Function + +Private Function ActValidateMakefile(env As ItemActionEnvironment) As Boolean + ActValidateMakefile = False + + Dim oErrors As Collection: Set oErrors = make_.Validate(env.sourceHome_, env.artifactHome_, env.isBuilding_) + If oErrors Is Nothing Then + Call env.reporter_.Log("Validation failed") + Exit Function + ElseIf oErrors.Count > 0 Then + Call env.reporter_.Log("Validation failed") + Exit Function + End If + + ActValidateMakefile = True +End Function + +Private Function ActProcessActions(env As ItemActionEnvironment) As Boolean + ActProcessActions = False + + Dim nAct&: nAct = 1 + Dim anAction As InfoAction + Dim acts As Collection: Set acts = IIf(env.isBuilding_, make_.buildActs_, make_.installActs_) + For Each anAction In acts + Call env.reporter_.Log("A" & nAct & "/" & acts.Count & ": " & anAction.Description) + On Error GoTo FAILED_ACTION + If Not anAction.Execute(env) Then +FAILED_ACTION: + Call env.reporter_.Log("Action failed: " & nAct) + Exit Function + End If + On Error GoTo 0 + nAct = nAct + 1 + Next anAction + + ActProcessActions = True +End Function diff --git a/src/builder/ItemActionEnvironment.cls b/src/builder/ItemActionEnvironment.cls new file mode 100644 index 0000000..7db4ed7 --- /dev/null +++ b/src/builder/ItemActionEnvironment.cls @@ -0,0 +1,66 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ItemActionEnvironment" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public reporter_ As API_Logger +Public isBuilding_ As Boolean +Public buildType_ As TBuildType + +Public product_ As String +Public productVersion_ As String +Public artifactHome_ As String +Public sourceHome_ As String +Public components_ As DB_Components + +Public installHome_ As String +Public testDB_ As DB_Tests + +Public fso_ As Scripting.FileSystemObject + +Public Function InitBuild(bType As TBuildType, sProduct$, sVersion$, sArtifacts$, sSources$, _ + aReporter As API_Logger, _ + dbComponents As DB_Components, _ + testDB As DB_Tests) + isBuilding_ = True + buildType_ = bType + Set fso_ = New Scripting.FileSystemObject + + product_ = sProduct + productVersion_ = sVersion + artifactHome_ = sArtifacts + sourceHome_ = sSources + + Set reporter_ = aReporter + Set components_ = dbComponents + Set testDB_ = testDB +End Function + +Public Function InitInstall(bType As TBuildType, sProduct$, sVersion$, sArtifacts$, sSources$, _ + aReporter As API_Logger, _ + dbComponents As DB_Components, sInstall$) + isBuilding_ = False + buildType_ = bType + Set fso_ = New Scripting.FileSystemObject + + product_ = sProduct + productVersion_ = sVersion + artifactHome_ = sArtifacts + sourceHome_ = sSources + + Set reporter_ = aReporter + Set components_ = dbComponents + + installHome_ = sInstall + + artifactHome_ = sArtifacts + sourceHome_ = sSources +End Function + + diff --git a/src/builder/ItemVBReference.cls b/src/builder/ItemVBReference.cls new file mode 100644 index 0000000..714a2f2 --- /dev/null +++ b/src/builder/ItemVBReference.cls @@ -0,0 +1,35 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ItemVBReference" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public type_ As TVBReference +Public id_ As String +Public major_ As Long +Public minor_ As Long + +Public Function Init(aType As TVBReference, sData$, nMajor&, nMinor&) + type_ = aType + id_ = sData + major_ = nMajor + minor_ = nMinor +End Function + +Public Function Test(target As VBIDE.Reference) As Boolean + Select Case type_ + Case T_REF_GLOBAL_NAME: Test = target.Name = id_ + Case T_REF_GUID: Test = target.GUID = id_ + Case T_REF_FILE: Test = target.FullPath = id_ + Case Else: Test = False + End Select +End Function + +Public Function ToString() As String + ToString = RefTypeToString(type_) & " : " & id_ +End Function diff --git a/src/builder/Main.bas b/src/builder/Main.bas new file mode 100644 index 0000000..f08fef7 --- /dev/null +++ b/src/builder/Main.bas @@ -0,0 +1,671 @@ +Attribute VB_Name = "Main" +Option Explicit + +Public Sub RunEditVBAMake() + Dim iProduct As IteratorProduct: Set iProduct = GetSelectedProduct + If iProduct Is Nothing Then _ + Exit Sub + + Dim fso As New Scripting.FileSystemObject + Dim sMake$: sMake = iProduct.Makefile + If Not fso.FileExists(sMake) Then + Call UserInteraction.ShowMessage(EM_MISSING_MAKEFILE, sMake) + Exit Sub + End If + + Dim oShell As New Shell32.Shell + Call oShell.Open(iProduct.Makefile) +End Sub + +Public Sub RunEditManifect() + Dim iComp As IteratorComponent: Set iComp = GetSelectedComponent + If iComp Is Nothing Then _ + Exit Sub + + Dim fso As New Scripting.FileSystemObject + Dim sManifest$: sManifest = iComp.ManifestFile + If Not fso.FileExists(sManifest) Then + Call UserInteraction.ShowMessage(EM_MISSING_MANIFEST, sManifest) + Exit Sub + End If + + Dim oShell As New Shell32.Shell + Call oShell.Open(sManifest) +End Sub + +Public Sub RunOpenSrc() + Dim iModel As InfoProduct: Set iModel = GetProductModel(GetSelectedProduct) + If iModel Is Nothing Then _ + Exit Sub + + Dim oShell As New Shell32.Shell + Call oShell.Open(iModel.SourceHome) +End Sub + +Public Sub RunOpenArtifact() + Dim iModel As InfoProduct: Set iModel = GetProductModel(GetSelectedProduct) + If iModel Is Nothing Then _ + Exit Sub + + Dim oShell As New Shell32.Shell + Call oShell.Open(iModel.ArtifactHome) +End Sub + +Public Sub RunTestVBAMake() + Dim iModel As InfoProduct: Set iModel = GetProductModel(GetSelectedProduct) + If iModel Is Nothing Then _ + Exit Sub + + Dim oErrors As Collection: Set oErrors = iModel.ValidateMakefile() + If oErrors Is Nothing Then + Call UserInteraction.ShowMessage(IM_MAKEFILE_FAILED, "") + ElseIf oErrors.Count = 0 Then + Call UserInteraction.ShowMessage(IM_MAKEFILE_OK) + Else + Call UserInteraction.ShowMessage(IM_MAKEFILE_FAILED, CollectionToLines(oErrors)) + End If +End Sub + +Public Sub RunBuildProduct() + Dim theTimer As New API_Timer: Call theTimer.Start + Dim iProduct As IteratorProduct: Set iProduct = GetSelectedProduct + Dim iModel As InfoProduct: Set iModel = GetProductModel(iProduct) + If iModel Is Nothing Then _ + Exit Sub + + Call ClearTests + If BuildProduct(Globals.build_, iProduct, iModel, Globals.Logger) Then + Call UserInteraction.ShowMessage(IM_BUILD_OK, theTimer.TimeStr) + Else + Call UserInteraction.ShowMessage(IM_BUILD_FAILED) + End If +End Sub + +Public Sub RunInstallProduct() + Dim theTimer As New API_Timer: Call theTimer.Start + Dim iProduct As IteratorProduct: Set iProduct = GetSelectedProduct + Dim iModel As InfoProduct: Set iModel = GetProductModel(iProduct) + If iModel Is Nothing Then _ + Exit Sub + + If InstallProduct(Globals.build_, iProduct, iModel, Globals.Logger) Then + Call UserInteraction.ShowMessage(IM_INSTALL_OK, theTimer.TimeStr) + Else + Call UserInteraction.ShowMessage(IM_INSTALL_FAILED) + End If +End Sub + +Public Sub RunAddProduct() + Dim sFolder$: sFolder = UserInteraction.PromptFolder(Globals.SourceHome & "\") + If sFolder = vbNullString Then _ + Exit Sub + + Dim sFile$: sFile = sFolder & "\" & MAKEFILE_NAME + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sFile) Then + Call UserInteraction.ShowMessage(EM_MAKEFILE_MISSING, sFile) + Exit Sub + End If + + Dim iMake As New InfoMakefile + If Not iMake.Init(sFolder & "\" & MAKEFILE_NAME) Then + Call UserInteraction.ShowMessage(EM_MAKEFILE_LOADING_FAILED) + Exit Sub + End If + + Dim dbProducts As DB_Products: Set dbProducts = AccessProducts + If Not dbProducts.Insert(iMake) Then + Call UserInteraction.ShowMessage(EM_PRODUCT_ALREADY_EXISTS, iMake.ProductName) + Else + Call UserInteraction.ShowMessage(IM_PRODUCT_ADDED, iMake.ProductName) + End If +End Sub + +Public Sub RunArchiveVersion() + Dim iProduct As IteratorProduct: Set iProduct = GetSelectedProduct + Dim iModel As InfoProduct: Set iModel = GetProductModel(iProduct) + If iModel Is Nothing Then _ + Exit Sub + + Dim sArchive$: sArchive = ArchiveNameFor(iModel, Now) + sArchive = CreateVersionArchive(Globals.build_, sArchive, iModel, Globals.Logger) + If sArchive = vbNullString Then + Call UserInteraction.ShowMessage(IM_BUILD_FAILED) + Exit Sub + End If + + Dim fso As New Scripting.FileSystemObject + Dim oShell As New Shell32.Shell + Call oShell.Open(fso.GetParentFolderName(sArchive)) +End Sub + +Public Sub RunTestManifest() + Dim iComp As IteratorComponent: Set iComp = GetSelectedComponent + Dim iModel As InfoComponent: Set iModel = GetComponentModel(iComp) + If iModel Is Nothing Then _ + Exit Sub + + Dim oErrors As Collection: Set oErrors = iModel.ValidateManifest(Globals.build_) + If oErrors Is Nothing Then + Call iComp.ResetBuildStatus + Call UserInteraction.ShowMessage(IM_MANIFEST_FAILED, "") + ElseIf oErrors.Count = 0 Then + Call UserInteraction.ShowMessage(IM_MANIFEST_OK) + Else + Call iComp.ResetBuildStatus + Call UserInteraction.ShowMessage(IM_MANIFEST_FAILED, CollectionToLines(oErrors)) + End If +End Sub + +Public Sub RunOpenComponent() + Dim iComp As IteratorComponent: Set iComp = GetSelectedComponent + Dim iModel As InfoComponent: Set iModel = GetComponentModel(iComp) + If iModel Is Nothing Then _ + Exit Sub + + Dim iDoc As Object: Set iDoc = iModel.OpenFileInNewProcess(bReadOnly:=False) + If Not iDoc Is Nothing Then _ + If Not TypeOf iDoc Is Visio.Document Then _ + Call iDoc.Activate +End Sub + +Public Sub RunOpenComponentReadOnly() + Dim iComp As IteratorComponent: Set iComp = GetSelectedComponent + Dim iModel As InfoComponent: Set iModel = GetComponentModel(iComp) + If iModel Is Nothing Then _ + Exit Sub + + Dim iDoc As Object: Set iDoc = iModel.OpenFileInNewProcess(bReadOnly:=True) + If Not iDoc Is Nothing Then _ + Call iDoc.Activate +End Sub + +Public Sub RunBuildComponent() + Dim theTimer As New API_Timer: Call theTimer.Start + Dim iComp As IteratorComponent: Set iComp = GetSelectedComponent + Dim iModel As InfoComponent: Set iModel = GetComponentModel(iComp) + If iModel Is Nothing Then _ + Exit Sub + If iModel.ItemName = ThisWorkbook.Name Then + Call UserInteraction.ShowMessage(EM_SELF_MODIFICATION) + Exit Sub + End If + + Call ClearTests + + Dim buildRes As InfoBuild + Set buildRes = iModel.Build(Globals.build_, Globals.Logger, AccessTests.OutputFor(iComp.Product, iComp.ItemName)) + Call iComp.SyncBuildInfo(buildRes) + If buildRes.status_ = T_BS_OK Then + Call UserInteraction.ShowMessage(IM_BUILD_OK, theTimer.TimeStr) + Else + Call UserInteraction.ShowMessage(IM_BUILD_FAILED) + End If +End Sub + +Public Sub RunTestComponent() + Dim iComp As IteratorComponent: Set iComp = GetSelectedComponent + Dim iModel As InfoComponent: Set iModel = GetComponentModel(iComp) + If iModel Is Nothing Then _ + Exit Sub + If iModel.ItemName = ThisWorkbook.Name Then + Call UserInteraction.ShowMessage(EM_SELF_MODIFICATION) + Exit Sub + End If + + Call ClearTests + + Dim theTimer As New API_Timer: Call theTimer.Start + + Dim iOutput As IteratorTest: Set iOutput = AccessTests.OutputFor(iComp.Product, iComp.ItemName) + Dim testRes As CDS_InfoTests: Set testRes = iModel.Test(Globals.Logger, iOutput) + If testRes Is Nothing Then + Call UserInteraction.ShowMessage(EM_TESTS_FAILED) + Exit Sub + End If + Call iComp.SyncTestInfo(testRes) + Call iOutput.RemoveRow + + If testRes.failed_ <> 0 Then _ + iComp.BuildStatus = T_BS_FAILED + If testRes.count_ = 0 Then + Call UserInteraction.ShowMessage(IM_TESTS_NOT_FOUND) + Else + Call UserInteraction.ShowMessage(IM_TESTS_COMPLETE, testRes.count_, testRes.success_, testRes.failed_, theTimer.TimeStr) + End If +End Sub + +Public Sub RunExportCode() + Dim iComp As IteratorComponent: Set iComp = GetSelectedComponent + Dim iModel As InfoComponent: Set iModel = GetComponentModel(iComp) + If iModel Is Nothing Then _ + Exit Sub + + Call iComp.ResetBuildStatus + If Not iModel.ExportCode() Then _ + Call UserInteraction.ShowMessage(EM_EXPORT_FAILED) +End Sub + +Public Sub RunExportShared() + Dim iComp As IteratorComponent: Set iComp = GetSelectedComponent + Dim iModel As InfoComponent: Set iModel = GetComponentModel(iComp) + If iModel Is Nothing Then _ + Exit Sub + + Call iComp.ResetBuildStatus + If Not iModel.ExportShared() Then _ + Call UserInteraction.ShowMessage(EM_EXPORT_FAILED) +End Sub + +Public Sub RunReloadCode() + Dim iComp As IteratorComponent: Set iComp = GetSelectedComponent + Dim iModel As InfoComponent: Set iModel = GetComponentModel(iComp) + If iModel Is Nothing Then _ + Exit Sub + If iModel.ItemName = ThisWorkbook.Name Then + Call UserInteraction.ShowMessage(EM_SELF_MODIFICATION) + Exit Sub + End If + + Call iComp.ResetBuildStatus + If Not iModel.ReloadCode() Then + Call iComp.SetBuildStatus(T_BS_FAILED) + Call UserInteraction.ShowMessage(EM_IMPORT_FAILED) + End If +End Sub + +Public Sub RunReloadShared() + Dim iComp As IteratorComponent: Set iComp = GetSelectedComponent + Dim iModel As InfoComponent: Set iModel = GetComponentModel(iComp) + If iModel Is Nothing Then _ + Exit Sub + If iModel.ItemName = ThisWorkbook.Name Then + Call UserInteraction.ShowMessage(EM_SELF_MODIFICATION) + Exit Sub + End If + + Call iComp.ResetBuildStatus + If Not iModel.ReloadShared() Then + Call iComp.SetBuildStatus(T_BS_FAILED) + Call UserInteraction.ShowMessage(EM_IMPORT_FAILED) + End If +End Sub + +Public Sub RunUpdateTarget() + Dim iModel As InfoComponent: Set iModel = GetComponentModel(GetSelectedComponent) + If iModel Is Nothing Then _ + Exit Sub + + Dim sFile$: sFile = UserInteraction.PromptFile(ThisWorkbook.Path & "\") + If sFile = vbNullString Then _ + Exit Sub + + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sFile) Then + Call UserInteraction.ShowMessage(EM_MISSING_FILE, sFile) + Exit Sub + End If + + If UpdateCodeIn(iModel, sFile) Then + Call UserInteraction.ShowMessage(IM_UPDATE_OK) + Else + Call UserInteraction.ShowMessage(IM_UPDATE_FAILED) + End If +End Sub + +Public Sub RunTargetClearCode() + Dim sFile$: sFile = UserInteraction.PromptFile(ThisWorkbook.Path & "\") + If sFile = vbNullString Then _ + Exit Sub + + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sFile) Then + Call UserInteraction.ShowMessage(EM_MISSING_FILE, sFile) + Exit Sub + End If + + If Not UserInteraction.AskQuestion(QM_CODE_DELETE_CONFIRM) Then _ + Exit Sub + + Dim wrap As Object: Set wrap = AccessArtifact(sFile, bReadOnly:=False) + If wrap Is Nothing Then _ + Exit Sub + + Dim proj As New API_Project: Call proj.Init(wrap.Document.VBProject, "") + Call proj.RemoveAll + + Call wrap.ReleaseDocument(bSaveChanges:=True) +End Sub + +Public Sub RunTargetUpdateShared() + Dim sFile$: sFile = UserInteraction.PromptFile(ThisWorkbook.Path & "\") + If sFile = vbNullString Then _ + Exit Sub + + Dim fso As New Scripting.FileSystemObject + If Not fso.FileExists(sFile) Then + Call UserInteraction.ShowMessage(EM_MISSING_FILE, sFile) + Exit Sub + End If + + Dim wrap As Object: Set wrap = AccessArtifact(sFile, bReadOnly:=False) + If wrap Is Nothing Then _ + Exit Sub + + Dim iUpdated As Collection: Set iUpdated = UpdateSharedIn(Globals.SharedHome, wrap.Document.VBProject) + Call wrap.ReleaseDocument(bSaveChanges:=True) + + If iUpdated Is Nothing Then + Call UserInteraction.ShowMessage(IM_UPDATE_SHARED_FAILED, iUpdated.Count) + Else + Call UserInteraction.ShowMessage(IM_UPDATE_SHARED_OK, iUpdated.Count, CollectionToLines(iUpdated)) + End If +End Sub + +Public Sub RunOpenLog() + Dim oShell As New Shell32.Shell + Call oShell.Open(Globals.Logger.LogFileName) +End Sub + +Public Sub RunOpenConfig() + Dim oShell As New Shell32.Shell + Call oShell.Open(VBA.Environ$("USERPROFILE") & "\.concept\concept-options.json") +End Sub + +Public Sub RunOpenConcept() + Dim oShell As New Shell32.Shell + Call oShell.Open(VBA.Environ$("USERPROFILE") & "\.concept") +End Sub + +Public Sub RunOpenVBCommons() + Dim oShell As New Shell32.Shell + Call oShell.Open(Globals.SharedHome) +End Sub + +Public Sub RunOpenAppData() + Dim oShell As New Shell32.Shell + Call oShell.Open(VBA.Environ$("APPDATA")) +End Sub + +Public Sub RunOpenUserProfile() + Dim oShell As New Shell32.Shell + Call oShell.Open(VBA.Environ$("USERPROFILE")) +End Sub + +Public Sub RunOpenCIHT() + Dim oShell As New Shell32.Shell + Call oShell.Open(SERVER_PATH_CIHT) +End Sub + +Public Sub RunOpenInstall() + Dim oShell As New Shell32.Shell + Call oShell.Open(SERVER_PATH_AUTOMATION) +End Sub + +Public Sub RunListRefs() + Dim iData As IteratorComponent: Set iData = GetSelectedComponent + If iData Is Nothing Then _ + Exit Sub + + Dim appWrap As Object: Set appWrap = AccessArtifact(iData.ArtifactFile, bReadOnly:=True) + If appWrap Is Nothing Then _ + Exit Sub + + Dim xlOut As New API_XLWrapper: Call xlOut.SetApplication(ThisWorkbook.Application) + Call ScanRefsFrom(appWrap.Document.VBProject, xlOut.NewDocument.Worksheets(1)) + Call appWrap.ReleaseDocument + Call xlOut.Document.Activate +End Sub + +Public Sub RunListModules() + Dim iData As IteratorComponent: Set iData = GetSelectedComponent + If iData Is Nothing Then _ + Exit Sub + + Dim appWrap As Object: Set appWrap = AccessArtifact(iData.ArtifactFile, bReadOnly:=True) + If appWrap Is Nothing Then _ + Exit Sub + + Dim xlOut As New API_XLWrapper: Call xlOut.SetApplication(ThisWorkbook.Application) + Call ScanModules(appWrap.Document.VBProject, xlOut.NewDocument.Worksheets(1)) + Call appWrap.ReleaseDocument + Call xlOut.Document.Activate +End Sub + +Public Sub RunListShared() + Call ClearShared + + Dim dbShared As DB_SharedModules: Set dbShared = AccessShared + Dim iOut As IteratorSharedModule: Set iOut = dbShared.INew + + Dim oErrors As Collection: Set oErrors = ScanShared(iOut, Globals.SharedHome, AccessComponents) + Call ThisWorkbook.Sheets(SHEET_SHARED).Activate + + If oErrors.Count <> 0 Then _ + Call UserInteraction.ShowMessage(IM_SHARED_INVALID, CollectionToLines(oErrors)) +End Sub + +Public Sub RunReloadAllShared() + Dim iData As IteratorComponent: Set iData = AccessComponents.IBegin + Dim oErrors As New Collection + Do While Not iData.IsDone + Dim iModel As InfoComponent: Set iModel = iData.Model + If iModel Is Nothing Then + Call oErrors.Add(iData.ItemName) + ElseIf Not iModel.ReloadShared Then + Call iData.SetBuildStatus(T_BS_FAILED) + Call oErrors.Add(iData.ItemName) + End If + Call iData.ResetBuildStatus + Call iData.Increment + Loop + + If oErrors.Count = 0 Then + Call UserInteraction.ShowMessage(IM_RELOAD_OK) + Else + Call UserInteraction.ShowMessage(IM_RELOAD_FAILED, CollectionToLines(oErrors)) + End If +End Sub + +Public Sub RunCompileAll() + Dim iData As IteratorComponent: Set iData = AccessComponents.IBegin + Dim oErrors As New Collection + Do While Not iData.IsDone + Dim iModel As InfoComponent: Set iModel = iData.Model + If iModel Is Nothing Then + Call oErrors.Add(iData.ItemName) + ElseIf Not iModel.Compile Then + Call oErrors.Add(iData.ItemName) + End If + Call iData.Increment + Loop + + If oErrors.Count = 0 Then + Call UserInteraction.ShowMessage(IM_COMPILATION_OK) + Else + Call UserInteraction.ShowMessage(IM_COMPILATION_FAILED, CollectionToLines(oErrors)) + End If +End Sub + +Public Sub RunAllTests() + Call ClearTests + + Dim theTimer As New API_Timer: Call theTimer.Start + Dim reporter As API_Logger: Set reporter = Globals.Logger + Dim totalRes As New CDS_InfoTests + + Dim iData As IteratorComponent: Set iData = AccessComponents.IBegin + Do While Not iData.IsDone + Dim iModel As InfoComponent: Set iModel = iData.Model + If iModel Is Nothing Then _ + GoTo NEXT_COMPONENT + + Dim iOutput As IteratorTest: Set iOutput = AccessTests.OutputFor(iData.Product, iData.ItemName) + Dim localRes As CDS_InfoTests: Set localRes = iModel.Test(reporter, iOutput) + If localRes Is Nothing Then + iData.BuildStatus = T_BS_FAILED + GoTo NEXT_COMPONENT + End If + If localRes.failed_ <> 0 Then _ + iData.BuildStatus = T_BS_FAILED + + Call iData.SyncTestInfo(localRes) + Call totalRes.MergeStats(localRes) + Call iOutput.RemoveRow + +NEXT_COMPONENT: + Call iData.Increment + Loop + + Call UserInteraction.ShowMessage(IM_TESTS_COMPLETE, totalRes.count_, totalRes.success_, totalRes.failed_, theTimer.TimeStr) +End Sub + +Public Sub RunBuildAll() + Call ClearTests + + Dim theTimer As New API_Timer: Call theTimer.Start + Dim bType As TBuildType: bType = Globals.build_ + Dim reporter As API_Logger: Set reporter = Globals.Logger + Dim iProduct As IteratorProduct: Set iProduct = AccessProducts.IBegin + Dim nCount&: nCount = 0 + Dim nSuccess&: nSuccess = 0 + Do While Not iProduct.IsDone + nCount = nCount + 1 + Dim iModel As InfoProduct: Set iModel = iProduct.Model(AccessComponents) + If iModel Is Nothing Then + Call iProduct.SetBuildStatus(T_BS_FAILED) + GoTo NEXT_PRODUCT + End If + + If BuildProduct(bType, iProduct, iModel, reporter) Then _ + nSuccess = nSuccess + 1 + +NEXT_PRODUCT: + Call iProduct.Increment + Loop + + Call UserInteraction.ShowMessage(IM_BATCH_BUILD, nSuccess, nCount, theTimer.TimeStr) +End Sub + +Public Sub RunInstallAll() + Call ClearTests + + Dim theTimer As New API_Timer: Call theTimer.Start + Dim bType As TBuildType: bType = Globals.build_ + Dim reporter As API_Logger: Set reporter = Globals.Logger + Dim iProduct As IteratorProduct: Set iProduct = AccessProducts.IBegin + Dim nCount&: nCount = 0 + Dim nSuccess&: nSuccess = 0 + Do While Not iProduct.IsDone + nCount = nCount + 1 + Dim iModel As InfoProduct: Set iModel = iProduct.Model(AccessComponents) + If iModel Is Nothing Then + Call iProduct.SetBuildStatus(T_BS_FAILED) + GoTo NEXT_PRODUCT + End If + + If InstallProduct(bType, iProduct, iModel, reporter) Then _ + nSuccess = nSuccess + 1 + +NEXT_PRODUCT: + Call iProduct.Increment + Loop + + Call UserInteraction.ShowMessage(IM_BATCH_INSTALL, nSuccess, nCount, theTimer.TimeStr) +End Sub + +Public Sub RunUpdateSkeleton() + Dim iModel As InfoComponent: Set iModel = GetComponentModel(GetSelectedComponent) + If iModel Is Nothing Then _ + Exit Sub + + If Not iModel.UpdateSkeleton() Then _ + Call UserInteraction.ShowMessage(EM_SKELETON_FAILED) +End Sub + +Public Sub RunScanFolder() + Dim sFolder$: sFolder = UserInteraction.PromptFolder(Globals.SourceHome & "\") + If sFolder = vbNullString Then _ + Exit Sub + + Dim nCount&: nCount = ScanProducts(sFolder) + Call UserInteraction.ShowMessage(IM_SCAN_OK, nCount) +End Sub + +' ====== +Private Function GetSelectedComponent() As IteratorComponent + Dim sel As Excel.Range: Set sel = Excel.Selection + If ThisWorkbook.ActiveSheet.Name <> SHEET_COMPONENTS _ + Or sel.Parent.Parent.Name <> ThisWorkbook.Name _ + Or sel.Rows.Count <> 1 Then + Call UserInteraction.ShowMessage(EM_INVALID_SELECTION) + Exit Function + End If + + Dim nRow&: nRow = sel.Cells(1, 1).Row + If nRow < FIRST_ROW Then + Call UserInteraction.ShowMessage(EM_INVALID_SELECTION) + Exit Function + End If + + Dim res As New IteratorComponent: Call res.Init(ThisWorkbook.Sheets(SHEET_COMPONENTS), nRow) + If res.IsDone() Then + Call UserInteraction.ShowMessage(EM_INVALID_SELECTION) + Exit Function + End If + + Set GetSelectedComponent = res +End Function + +Private Function GetComponentModel(target As IteratorComponent) As InfoComponent + If target Is Nothing Then _ + Exit Function + Dim iModel As InfoComponent: Set iModel = target.Model + If iModel Is Nothing Then + Call UserInteraction.ShowMessage(EM_INVALID_COMPONENT) + Exit Function + End If + Set GetComponentModel = iModel +End Function + +Private Function GetSelectedProduct() As IteratorProduct + Dim sel As Excel.Range: Set sel = Excel.Selection + If sel.Parent.Parent.Name <> ThisWorkbook.Name _ + Or sel.Rows.Count <> 1 Then + Call UserInteraction.ShowMessage(EM_INVALID_SELECTION) + Exit Function + End If + + Dim nRow&: nRow = sel.Cells(1, 1).Row + If nRow < FIRST_ROW Then + Call UserInteraction.ShowMessage(EM_INVALID_SELECTION) + Exit Function + End If + + Dim iTable As Excel.ListObject: Set iTable = sel.ListObject + If iTable Is Nothing Then _ + GoTo MISSING_PRODUCT + Dim iCell As Excel.Range: Set iCell = iTable.HeaderRowRange.Cells.Find("ProductName") + If iCell Is Nothing Then _ + GoTo MISSING_PRODUCT + + Dim sName$: sName = sel.Parent.Cells(nRow, iCell.Column) + Dim projects As New DB_Products: Set projects = AccessProducts + If projects.Contains(sName) Then + Set GetSelectedProduct = projects.Access(sName) + Else +MISSING_PRODUCT: + Call UserInteraction.ShowMessage(EM_MISSING_PRODUCT, sName) + End If +End Function + +Private Function GetProductModel(target As IteratorProduct) As InfoProduct + If target Is Nothing Then _ + Exit Function + Dim iModel As InfoProduct: Set iModel = target.Model(AccessComponents) + If iModel Is Nothing Then + Call UserInteraction.ShowMessage(EM_INVALID_PRODUCT) + Exit Function + End If + Set GetProductModel = iModel +End Function diff --git a/src/builder/MainImpl.bas b/src/builder/MainImpl.bas new file mode 100644 index 0000000..27c2fd0 --- /dev/null +++ b/src/builder/MainImpl.bas @@ -0,0 +1,234 @@ +Attribute VB_Name = "MainImpl" +Option Private Module +Option Explicit + +Public Function ClearTests() + Call ThisWorkbook.Sheets(SHEET_TESTS).UsedRange.Offset(1, 0).ClearContents +End Function + +Public Function ClearShared() + Call ThisWorkbook.Sheets(SHEET_SHARED).UsedRange.Offset(1, 0).ClearContents +End Function + +Public Function CPath(sPath$) As API_Path + Set CPath = New API_Path + Call CPath.FromString(sPath) +End Function + +Public Function ScanRefsFrom(target As VBIDE.VBProject, iOut As Excel.Worksheet) + iOut.Cells(1, S_R_NAME) = "Name" + iOut.Cells(1, S_R_TYPE) = "Type" + iOut.Cells(1, S_R_FILE) = "File" + iOut.Cells(1, S_R_GUID) = "GUID" + iOut.Cells(1, S_R_BROKEN) = "IsBroken" + iOut.Cells(1, S_R_MAJOR) = "Major" + iOut.Cells(1, S_R_MINOR) = "Minor" + iOut.Cells(1, S_R_DESCRIPTION) = "Description" + + Dim rowOut&: rowOut = 2 + Dim aRef As VBIDE.Reference + For Each aRef In target.References + iOut.Cells(rowOut, S_R_NAME) = aRef.Name + iOut.Cells(rowOut, S_R_TYPE) = aRef.Type + iOut.Cells(rowOut, S_R_FILE) = aRef.FullPath + iOut.Cells(rowOut, S_R_GUID) = aRef.GUID + iOut.Cells(rowOut, S_R_BROKEN) = IIf(aRef.IsBroken, 1, 0) + iOut.Cells(rowOut, S_R_MAJOR) = aRef.Major + iOut.Cells(rowOut, S_R_MINOR) = aRef.Minor + iOut.Cells(rowOut, S_R_DESCRIPTION) = aRef.Description + rowOut = rowOut + 1 + Next aRef +End Function + +Public Function ScanModules(target As VBIDE.VBProject, iOut As Excel.Worksheet) + Dim fso As New Scripting.FileSystemObject + + iOut.Cells(1, S_M_NAME) = "Name" + iOut.Cells(1, S_M_TYPE) = "Type" + iOut.Cells(1, S_M_SHARED) = "Shared" + iOut.Cells(1, S_M_LINES_TOTAL) = "LoC" + iOut.Cells(1, S_M_LINES_DECLARATIONS) = "LoD" + iOut.Cells(1, S_M_COUNT_API) = "API" + + Dim rowOut&: rowOut = 2 + Dim aComp As VBIDE.VBComponent + For Each aComp In target.VBComponents + If aComp.CodeModule.CountOfLines >= LOC_MINIMUM Then + iOut.Cells(rowOut, S_M_NAME) = aComp.Name + iOut.Cells(rowOut, S_M_TYPE) = aComp.Type + iOut.Cells(rowOut, S_M_SHARED) = GetSharedPrefix(aComp) + iOut.Cells(rowOut, S_M_LINES_TOTAL) = aComp.CodeModule.CountOfLines + iOut.Cells(rowOut, S_M_LINES_DECLARATIONS) = aComp.CodeModule.CountOfDeclarationLines + iOut.Cells(rowOut, S_M_COUNT_API) = Dev_CountPublicAPI(aComp.CodeModule) + rowOut = rowOut + 1 + End If + Next aComp +End Function + +Public Function ScanShared(iOut As IteratorSharedModule, sSource$, dbComponents As DB_Components) As Collection + Dim fso As New Scripting.FileSystemObject + If Not fso.FolderExists(sSource) Then _ + Exit Function + + Dim xlWrap As New API_XLWrapper: Call xlWrap.SetApplication(ThisWorkbook.Application) + If xlWrap.NewDocument() Is Nothing Then _ + Exit Function + + Dim oInserter As New CB_AddModule: Call oInserter.Init(iOut, xlWrap.Document.VBProject, fso.GetFolder(sSource).Path) + Call ForEachFileRecursive(sSource, oInserter, "TryAddModule") + Call xlWrap.ReleaseDocument + + Set ScanShared = UpdateSharedUsage(iOut, dbComponents) +End Function + +Public Function UpdateSharedIn(sShared$, target As VBIDE.VBProject) As Collection + Dim iShared As Scripting.Dictionary: Set iShared = GetAllSharedModules(sShared) + Dim iUpdated As New Collection + + Dim iProject As New API_Project: Call iProject.Init(target) + + Dim aComponent As VBComponent + For Each aComponent In target.VBComponents + Dim sName$: sName = aComponent.Name + If iShared.Exists(sName) Then _ + If iProject.ReloadFrom(iShared(sName)) Then _ + Call iUpdated.Add(sName) + Next aComponent + + If CompileVBProject(target) Then _ + Set UpdateSharedIn = iUpdated +End Function + +Public Function BuildProduct(bType As TBuildType, iProduct As IteratorProduct, iModel As InfoProduct, reporter As API_Logger) As Boolean + BuildProduct = iModel.Build(bType, reporter, AccessComponents, AccessTests) + Call iProduct.SetBuildStatus(IIf(BuildProduct, T_BS_OK, T_BS_FAILED)) +End Function + +Public Function InstallProduct(bType As TBuildType, iProduct As IteratorProduct, iModel As InfoProduct, reporter As API_Logger) As Boolean + If iProduct.Status <> T_BS_OK Then + Call reporter.Log("The project wasnt built... Rebuilding") + If Not BuildProduct(bType, iProduct, iModel, reporter) Then + InstallProduct = False + Exit Function + End If + End If + + InstallProduct = iModel.Install(bType, reporter, AccessComponents, iModel.InstallHome) + If InstallProduct Then _ + iProduct.InstallDate = Now +End Function + +Public Function UpdateCodeIn(iModel As InfoComponent, sTargetFile$) As Boolean + Call iModel.manifest_.properties_.Remove(MANIFEST_PROPS_ARTIFACT) + Call iModel.manifest_.properties_.Add(MANIFEST_PROPS_ARTIFACT, sTargetFile) + UpdateCodeIn = iModel.ReloadAll +End Function + +Public Function IsBasicReference(target As VBIDE.Reference, proj As VBIDE.VBProject) As Boolean + If VBA.InStr(1, Globals.DefaultRefs, target.Name) <> 0 Then + IsBasicReference = True + Exit Function + End If + + Dim fso As New FileSystemObject + Dim tAppl As TApplication: tAppl = ApplicationFromExtension(fso.GetExtensionName(proj.FileName)) + Select Case tAppl + Case T_APP_WORD: IsBasicReference = target.Name = "Word" + Case T_APP_EXCEL: IsBasicReference = target.Name = "Excel" + Case T_APP_VISIO: IsBasicReference = target.Name = "Visio" + Case Else: IsBasicReference = False + End Select +End Function + +Public Function CreateVersionArchive(bType As TBuildType, sArchiveFolder$, target As InfoProduct, theLog As API_Logger) As String + Call ClearTests + + Call theLog.Log("Preparing version files... Rebuilding project") + If Not target.Build(bType, theLog, AccessComponents, AccessTests, sArchiveFolder) Then _ + GoTo SAFE_EXIT + + Call theLog.Log("Creating archive") + Dim sArchiveFile$: sArchiveFile = sArchiveFolder & ".zip" + If ZipFolder(sArchiveFolder, sArchiveFile) Then _ + CreateVersionArchive = sArchiveFile + +SAFE_EXIT: + Dim fso As New Scripting.FileSystemObject + If fso.FolderExists(sArchiveFolder) Then _ + Call fso.DeleteFolder(sArchiveFolder) +End Function + +Public Function ArchiveNameFor(prod As InfoProduct, DDate As Double) As String + ArchiveNameFor = _ + prod.ArtifactHome & "\" & _ + SUBFOLDER_VERSION_ARCHIVE & "\" & _ + Format(DDate, "yyyymmdd") & " " & _ + prod.Name +End Function + +Public Function ScanProducts(sTarget$) As Long + Dim iCallback As New CB_AddProduct: Call iCallback.Init(AccessProducts) + Call ForEachFolderRecursive(sTarget, iCallback, "ScanFolder") + ScanProducts = iCallback.newCount_ +End Function + +' ===== +Private Function GetSharedPrefix(target As VBIDE.VBComponent) As String + Dim iShared As IteratorSharedModule: Set iShared = AccessShared.FindName(target.Name) + If Not iShared Is Nothing Then _ + GetSharedPrefix = iShared.Path +End Function + +Private Function GetAllSharedModules(sShared$) As Scripting.Dictionary + Dim iShared As New CB_SharedModules: Call iShared.Init + Call ForEachFileRecursive(sShared, iShared, "ProcessFile") + Set GetAllSharedModules = iShared.data_ +End Function + +Private Function UpdateSharedUsage(ByRef iOut As IteratorSharedModule, dbComponents As DB_Components) As Collection + Dim fso As New Scripting.FileSystemObject + Dim iComp As IteratorComponent: Set iComp = dbComponents.IBegin + Dim iData As New Scripting.Dictionary + Do While Not iComp.IsDone + Dim iManifest As InfoManifest: Set iManifest = iComp.ScanManifest + If iManifest Is Nothing Then _ + GoTo NEXT_COMPONENT + + Dim sComponent$: sComponent = iComp.ItemName + Dim vModule As Variant + For Each vModule In iManifest.sharedContents_ + Dim sModuleName$: sModuleName = fso.GetBaseName(CStr(vModule)) + If Not iData.Exists(sModuleName) Then _ + Call iData.Add(sModuleName, New Collection) + Call iData(sModuleName).Add(sComponent) + Next vModule +NEXT_COMPONENT: + Call iComp.Increment + Loop + + Call iOut.GoFirst + Do While Not iOut.IsDone + Dim sName$: sName = iOut.Name + If Not iData.Exists(sName) Then _ + GoTo NEXT_ROW + + Dim sItem As Variant + Dim sComps$: sComps = vbNullString + For Each sItem In iData(sName) + If sComps <> vbNullString Then _ + sComps = sComps & ", " + sComps = sComps & CStr(sItem) + Next sItem + iOut.UsedIn = sComps + Call iData.Remove(sName) +NEXT_ROW: + Call iOut.Increment + Loop + + Dim oErrors As New Collection + Dim aKey As Variant + For Each aKey In iData + Call oErrors.Add(CStr(aKey)) + Next aKey + Set UpdateSharedUsage = oErrors +End Function diff --git a/src/builder/database/DB_Components.cls b/src/builder/database/DB_Components.cls new file mode 100644 index 0000000..da14861 --- /dev/null +++ b/src/builder/database/DB_Components.cls @@ -0,0 +1,51 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DB_Components" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private data_ As Excel.Worksheet + +Public Function Init(target As Excel.Worksheet) + Set data_ = target +End Function + +Public Function IBegin() As IteratorComponent + Set IBegin = New IteratorComponent + Call IBegin.Init(data_) +End Function + +Public Function ILast() As IteratorComponent + Set ILast = New IteratorComponent + Call ILast.Init(data_) + Call ILast.GoLast +End Function + +Public Function INew() As IteratorComponent + Set INew = New IteratorComponent + Call INew.Init(data_) + Call INew.GoLast + Call INew.Increment +End Function + +Public Function Contains(sProduct$, sComponent$) As Boolean + Contains = Not Access(sProduct, sComponent) Is Nothing +End Function + +Public Function Access(sProduct$, sComponent$) As IteratorComponent + Dim iComp As New IteratorComponent: Call iComp.Init(data_) + Do While Not iComp.IsDone + If iComp.Product = sProduct Then + If iComp.ItemName = sComponent Then + Set Access = iComp + Exit Function + End If + End If + Call iComp.Increment + Loop +End Function diff --git a/src/builder/database/DB_GlobalRefs.cls b/src/builder/database/DB_GlobalRefs.cls new file mode 100644 index 0000000..38629f4 --- /dev/null +++ b/src/builder/database/DB_GlobalRefs.cls @@ -0,0 +1,31 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DB_GlobalRefs" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private data_ As Excel.ListObject + +Public Function Init(target As Excel.ListObject) + Set data_ = target +End Function + +Public Function GetGlobal(sGlobalName$) As ItemVBReference + Dim dataRng As Excel.Range: Set dataRng = data_.Range + Dim nRow&: nRow = FIRST_ROW + For nRow = FIRST_ROW To dataRng.Rows.Count Step 1 + If dataRng.Cells(nRow, S_G_NAME_ID) = sGlobalName Then + Set GetGlobal = New ItemVBReference + Call GetGlobal.Init(T_REF_GUID, _ + dataRng.Cells(nRow, S_G_GUID), _ + dataRng.Cells(nRow, S_G_MAJOR), _ + dataRng.Cells(nRow, S_G_MINOR)) + Exit Function + End If + Next nRow +End Function diff --git a/src/builder/database/DB_Products.cls b/src/builder/database/DB_Products.cls new file mode 100644 index 0000000..6d03c4e --- /dev/null +++ b/src/builder/database/DB_Products.cls @@ -0,0 +1,61 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DB_Products" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private data_ As Excel.Worksheet +Private components_ As DB_Components + +Public Function Init(target As Excel.Worksheet, iComponents As DB_Components) + Set components_ = iComponents + Set data_ = target +End Function + +Public Function IBegin() As IteratorProduct + Set IBegin = New IteratorProduct + Call IBegin.Init(data_) +End Function + +Public Function ILast() As IteratorProduct + Set ILast = New IteratorProduct + Call ILast.Init(data_) + Call ILast.GoLast +End Function + +Public Function INew() As IteratorProduct + Set INew = New IteratorProduct + Call INew.Init(data_) + Call INew.GoLast + Call INew.Increment +End Function + +Public Function Contains(sProduct$) As Boolean + Contains = Not Access(sProduct) Is Nothing +End Function + +Public Function Access(sProduct$) As IteratorProduct + Dim iProd As New IteratorProduct: Call iProd.Init(data_) + Do While Not iProd.IsDone + If iProd.Name = sProduct Then + Set Access = iProd + Exit Function + End If + Call iProd.Increment + Loop +End Function + +Public Function Insert(iMake As InfoMakefile) As Boolean + Insert = Not Contains(iMake.ProductName) + If Not Insert Then _ + Exit Function + + Dim iNewProduct As IteratorProduct: Set iNewProduct = INew + Call iNewProduct.SyncMakefile(iMake) + Call iNewProduct.SyncManifests(iMake, components_) +End Function diff --git a/src/builder/database/DB_SharedModules.cls b/src/builder/database/DB_SharedModules.cls new file mode 100644 index 0000000..0256a45 --- /dev/null +++ b/src/builder/database/DB_SharedModules.cls @@ -0,0 +1,46 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DB_SharedModules" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private data_ As Excel.Worksheet + +Public Function Init(target As Excel.Worksheet) + Set data_ = target +End Function + +Public Function IBegin() As IteratorSharedModule + Set IBegin = New IteratorSharedModule + Call IBegin.Init(data_) +End Function + +Public Function ILast() As IteratorSharedModule + Set ILast = New IteratorSharedModule + Call ILast.Init(data_) + Call ILast.GoLast +End Function + +Public Function INew() As IteratorSharedModule + Set INew = New IteratorSharedModule + Call INew.Init(data_) + Call INew.GoLast + Call INew.Increment +End Function + +Public Function FindName(sTarget$) As IteratorSharedModule + Dim iModule As IteratorSharedModule + Set iModule = IBegin + Do While Not iModule.IsDone + If iModule.Name = sTarget Then + Set FindName = iModule + Exit Function + End If + Call iModule.Increment + Loop +End Function diff --git a/src/builder/database/DB_Tests.cls b/src/builder/database/DB_Tests.cls new file mode 100644 index 0000000..b1fffca --- /dev/null +++ b/src/builder/database/DB_Tests.cls @@ -0,0 +1,41 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "DB_Tests" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private data_ As Excel.Worksheet + +Public Function Init(target As Excel.Worksheet) + Set data_ = target +End Function + +Public Function IBegin() As IteratorTest + Set IBegin = New IteratorTest + Call IBegin.Init(data_) +End Function + +Public Function ILast() As IteratorTest + Set ILast = New IteratorTest + Call ILast.Init(data_) + Call ILast.GoLast +End Function + +Public Function INew() As IteratorTest + Set INew = New IteratorTest + Call INew.Init(data_) + Call INew.GoLast + Call INew.Increment +End Function + +Public Function OutputFor(sProduct$, sComponent$) As IteratorTest + Dim iRes As IteratorTest: Set iRes = INew + iRes.Product = sProduct + iRes.Component = sComponent + Set OutputFor = iRes +End Function diff --git a/src/builder/database/DataAccess.bas b/src/builder/database/DataAccess.bas new file mode 100644 index 0000000..3e352a7 --- /dev/null +++ b/src/builder/database/DataAccess.bas @@ -0,0 +1,101 @@ +Attribute VB_Name = "DataAccess" +Option Private Module +Option Explicit + +Public Function Globals() As InfoGlobals + Static s_Globals As InfoGlobals + If s_Globals Is Nothing Then _ + Set s_Globals = New InfoGlobals + Set Globals = s_Globals +End Function + +Public Function AccessArtifact(sPath$, bReadOnly As Boolean) As Object + Dim fso As New Scripting.FileSystemObject + Dim tAppl As TApplication: tAppl = ApplicationFromExtension(fso.GetExtensionName(sPath)) + If tAppl = T_APP_UNDEF Then + Debug.Print "Unsupported file extenstion: " & sPath + Exit Function + End If + + Dim appWrap As Object: Set appWrap = GetWrapper(tAppl, sPath, bReadOnly) + If appWrap.Document Is Nothing Then _ + Exit Function + Set AccessArtifact = appWrap +End Function + +Public Function AccessProducts() As DB_Products + Static s_Products As DB_Products + + If s_Products Is Nothing Then + Set s_Products = New DB_Products + Call s_Products.Init(ThisWorkbook.Worksheets(SHEET_PRODUCTS), AccessComponents) + End If + + Set AccessProducts = s_Products +End Function + +Public Function AccessComponents() As DB_Components + Static s_Components As DB_Components + + If s_Components Is Nothing Then + Set s_Components = New DB_Components + Call s_Components.Init(ThisWorkbook.Worksheets(SHEET_COMPONENTS)) + End If + + Set AccessComponents = s_Components +End Function + +Public Function AccessTests() As DB_Tests + Static s_Tests As DB_Tests + + If s_Tests Is Nothing Then + Set s_Tests = New DB_Tests + Call s_Tests.Init(ThisWorkbook.Worksheets(SHEET_TESTS)) + End If + + Set AccessTests = s_Tests +End Function + +Public Function AccessShared() As DB_SharedModules + Static s_Shared As DB_SharedModules + + If s_Shared Is Nothing Then + Set s_Shared = New DB_SharedModules + Call s_Shared.Init(ThisWorkbook.Worksheets(SHEET_SHARED)) + End If + + Set AccessShared = s_Shared +End Function + +Public Function AccessProduct(target$) As IteratorProduct + Dim projects As DB_Products: Set projects = AccessProducts + If Not projects.Contains(target) Then _ + Exit Function + Set AccessProduct = projects.Access(target) +End Function + +' ======= +Private Function GetWrapper(tAppl As TApplication, sPath$, bReadOnly As Boolean) As Object + Select Case tAppl + Case T_APP_WORD + Set GetWrapper = New API_WordWrapper + Call GetWrapper.SetReporter(Globals.Logger) + Call GetWrapper.CreateApplication + Call GetWrapper.OpenDocument(sPath, bReadOnly:=bReadOnly) + + Case T_APP_EXCEL + Set GetWrapper = New API_XLWrapper + Call GetWrapper.SetReporter(Globals.Logger) + Call GetWrapper.CreateApplication + Call GetWrapper.OpenDocument(sPath, bReadOnly:=bReadOnly) + + Case T_APP_VISIO + Set GetWrapper = New API_VsoWrapper + Call GetWrapper.SetReporter(Globals.Logger) + Call GetWrapper.CreateApplication + Dim nFlags As Integer: nFlags = visOpenDontList + visOpenDeclineAutoRefresh + If bReadOnly Then _ + nFlags = nFlags + visOpenRO + Call GetWrapper.OpenDocument(sPath, nFlags) + End Select +End Function diff --git a/src/builder/database/IteratorComponent.cls b/src/builder/database/IteratorComponent.cls new file mode 100644 index 0000000..61abedb --- /dev/null +++ b/src/builder/database/IteratorComponent.cls @@ -0,0 +1,209 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "IteratorComponent" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' _C_ - project components +Private Enum ComponentStruct + [_First] = 1 + + S_C_PRODUCT = 1 + S_C_ITEM_NAME = 2 + S_C_PATH_ARTIFACT = 3 + S_C_LOCAL_MANIFEST = 4 + S_C_BUILD_STATUS = 5 + S_C_BUILD_DATE = 6 + S_C_TESTS_TOTAL = 7 + S_C_TESTS_FAIL = 8 + S_C_TESTS_OK = 9 + + [_Last] = 9 +End Enum + +Public row_ As Long +Private data_ As Excel.Worksheet + +Public Sub Init(target As Excel.Worksheet, Optional tRow& = FIRST_ROW) + Set data_ = target + row_ = tRow +End Sub + +Public Function Increment(Optional inc& = 1) + If row_ + inc > 0 Then _ + row_ = row_ + inc +End Function + +Public Function GoFirst() + row_ = FIRST_ROW +End Function + +Public Function GoLast() + row_ = data_.Columns(S_C_PRODUCT).Find(vbNullString, LookAt:=xlWhole).Row - 1 +End Function + +Public Function IsDone() As Boolean + IsDone = data_.Cells(row_, S_C_PRODUCT) = vbNullString +End Function + +Public Function RemoveRow() + Call data_.Rows(row_).Delete +End Function + +Public Function Model() As InfoComponent + Dim iProduct As IteratorProduct: Set iProduct = AccessProduct(Product) + If iProduct Is Nothing Then _ + Exit Function + + Dim oRes As New InfoComponent + If Not oRes.Init(ManifestFile, iProduct.SourcePath, iProduct.ArtifactPath, iProduct.Version) Then _ + Exit Function + + Call SyncManifest(Product, oRes.manifest_) + Set Model = oRes +End Function + +Public Function ScanManifest() As InfoManifest + Dim iManifest As New InfoManifest + If iManifest.Init(ManifestFile) Then _ + Set ScanManifest = iManifest +End Function + +Public Function SyncManifest(sProduct$, iSource As InfoManifest) + Dim fso As New Scripting.FileSystemObject + Product = sProduct + ItemName = iSource.properties_(MANIFEST_PROPS_NAME) + Artifact = iSource.properties_(MANIFEST_PROPS_ARTIFACT) + Manifest = fso.GetFileName(iSource.sPath_) + Call UpdateItemLink +End Function + +Public Function SyncBuildInfo(iSource As InfoBuild) + BuildStatus = iSource.status_ + BuildDate = iSource.date_ + TestsTotal = iSource.tests_.count_ + TestsOK = iSource.tests_.success_ + TestsFail = iSource.tests_.failed_ +End Function + +Public Function SyncTestInfo(iSource As CDS_InfoTests) + TestsTotal = iSource.count_ + TestsOK = iSource.success_ + TestsFail = iSource.failed_ +End Function + +Public Function ResetBuildStatus() + If BuildStatus <> T_BS_FAILED Then _ + BuildStatus = T_BS_PENDING +End Function + +Public Function SetBuildStatus(newVal As TBuildStatus) + BuildStatus = newVal + BuildDate = Now +End Function + +Public Function UpdateItemLink() + Call XLUpdateHyperlink(data_.Cells(row_, S_C_ITEM_NAME), ArtifactFile) +End Function + +'===== Propertiy Get ===== +Public Property Get ArtifactFile() As String + Dim iProduct As IteratorProduct: Set iProduct = AccessProduct(Product) + If iProduct Is Nothing Then _ + Exit Property + ArtifactFile = CPath(data_.Cells(row_, S_C_PATH_ARTIFACT)).ToGlobal(iProduct.ArtifactPath).Text +End Property + +Public Property Get ManifestFile() As String + ManifestFile = CPath(Manifest).ToGlobal(SourcePath & "\" & SUBFOLDER_SCRIPT).Text +End Property + +Public Property Get SkeletonFile() As String + SkeletonFile = SourcePath & "\" & SUBFOLDER_SKELETON & "\" & ItemName +End Property + +Public Property Get Product() As String + Product = data_.Cells(row_, S_C_PRODUCT) +End Property + +Public Property Get ItemName() As String + ItemName = data_.Cells(row_, S_C_ITEM_NAME) +End Property + +Public Property Get Artifact() As String + Artifact = data_.Cells(row_, S_C_PATH_ARTIFACT) +End Property + +Public Property Get Manifest() As String + Manifest = data_.Cells(row_, S_C_LOCAL_MANIFEST) +End Property + +Public Property Get BuildStatus() As TBuildStatus + BuildStatus = data_.Cells(row_, S_C_BUILD_STATUS) +End Property + +Public Property Get BuildDate() As Double + BuildDate = data_.Cells(row_, S_C_BUILD_DATE) +End Property + +Public Property Get TestsTotal() As Long + TestsTotal = data_.Cells(row_, S_C_TESTS_TOTAL) +End Property + +Public Property Get TestsFail() As Long + TestsFail = data_.Cells(row_, S_C_TESTS_FAIL) +End Property + +Public Property Get TestsOK() As Long + TestsOK = data_.Cells(row_, S_C_TESTS_OK) +End Property + +' ==== Property Let ==== +Public Property Let Product(newVal$) + data_.Cells(row_, S_C_PRODUCT) = newVal +End Property + +Public Property Let ItemName(newVal$) + data_.Cells(row_, S_C_ITEM_NAME) = newVal +End Property + +Public Property Let Artifact(newVal$) + data_.Cells(row_, S_C_PATH_ARTIFACT) = newVal +End Property + +Public Property Let Manifest(newVal$) + data_.Cells(row_, S_C_LOCAL_MANIFEST) = newVal +End Property + +Public Property Let BuildStatus(newVal As TBuildStatus) + data_.Cells(row_, S_C_BUILD_STATUS) = newVal +End Property + +Public Property Let BuildDate(newVal As Double) + data_.Cells(row_, S_C_BUILD_DATE) = newVal +End Property + +Public Property Let TestsTotal(newVal&) + data_.Cells(row_, S_C_TESTS_TOTAL) = newVal +End Property + +Public Property Let TestsFail(newVal&) + data_.Cells(row_, S_C_TESTS_FAIL) = newVal +End Property + +Public Property Let TestsOK(newVal&) + data_.Cells(row_, S_C_TESTS_OK) = newVal +End Property + +' ======= +Private Property Get SourcePath() As String + Dim iProduct As IteratorProduct: Set iProduct = AccessProduct(Product) + If iProduct Is Nothing Then _ + Exit Property + SourcePath = Globals().SourceHome & "\" & iProduct.SourceHome +End Property diff --git a/src/builder/database/IteratorProduct.cls b/src/builder/database/IteratorProduct.cls new file mode 100644 index 0000000..b7182b5 --- /dev/null +++ b/src/builder/database/IteratorProduct.cls @@ -0,0 +1,220 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "IteratorProduct" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' _P_ - projects +Private Enum ProductStruct + [_First] = 1 + + S_P_ID = 1 + S_P_VERSION = 2 + S_P_NAME = 3 + S_P_DESCRIPTION = 4 + S_P_ARTIFACT_HOME = 5 + S_P_SOURCE_HOME = 6 + S_P_INSTALL_HOME = 7 + + S_P_STATUS = 8 + S_P_LAST_BUILD = 9 + S_P_DISTRIBUTE = 10 + S_P_LAST_INSTALL = 11 + + [_Last] = 11 +End Enum + +Public row_ As Long + +Private data_ As Excel.Worksheet + +Public Sub Init(target As Excel.Worksheet, Optional tRow& = FIRST_ROW) + Set data_ = target + row_ = tRow +End Sub + +Public Function Increment(Optional inc& = 1) + If row_ + inc > 0 Then _ + row_ = row_ + inc +End Function + +Public Function GoFirst() + row_ = FIRST_ROW +End Function + +Public Function GoLast() + row_ = data_.Columns(S_P_NAME).Find(vbNullString, LookAt:=xlWhole).Row - 1 +End Function + +Public Function IsDone() As Boolean + IsDone = data_.Cells(row_, S_P_NAME) = vbNullString +End Function + +Public Function RemoveRow() + Call data_.Rows(row_).Delete +End Function + +Public Function Model(dbComponents As DB_Components) As InfoProduct + Dim oRes As New InfoProduct + If Not oRes.Init(Makefile, Version, IsDistributed) Then _ + Exit Function + + Call SyncMakefile(oRes.make_) + Call SyncManifests(oRes.make_, dbComponents) + Set Model = oRes +End Function + +Public Function SyncMakefile(iSource As InfoMakefile) + ProductID = iSource.properties_(MAKEFILE_PROPS_ID) + Name = iSource.properties_(MAKEFILE_PROPS_NAME) + ArtifactHome = iSource.properties_(MAKEFILE_PROPS_ARTIFACT) + SourceHome = iSource.properties_(MAKEFILE_PROPS_SOURCE) + InstallHome = iSource.properties_(MAKEFILE_PROPS_INSTALL) + If iSource.properties_.Exists(MAKEFILE_PROPS_DESCRIPTION) Then _ + Description = iSource.properties_(MAKEFILE_PROPS_DESCRIPTION) + Call UpdateHyperlinks +End Function + +Public Function SyncManifests(iSource As InfoMakefile, dbComponents As DB_Components) + Dim anAction As InfoAction + Dim sSource$: sSource = SourcePath + Dim sProduct$: sProduct = iSource.properties_(MAKEFILE_PROPS_NAME) + For Each anAction In iSource.buildActs_ + If Not anAction.type_ = T_ACT_BUILD Then _ + GoTo NEXT_ACTION + + Dim sManifest$: sManifest = CPath(anAction.args_(1)).ToGlobal(sSource).Text + Dim iManifest As New InfoManifest + If Not iManifest.Init(sManifest) Then _ + GoTo NEXT_ACTION + + Dim sComponent$: sComponent = iManifest.properties_(MANIFEST_PROPS_NAME) + Dim iComp As IteratorComponent + If dbComponents.Contains(sProduct, sComponent) Then + Set iComp = dbComponents.Access(sProduct, sComponent) + Else + Set iComp = dbComponents.INew + End If + Call iComp.SyncManifest(sProduct, iManifest) + +NEXT_ACTION: + Next anAction +End Function + +Public Function SetBuildStatus(newVal As TBuildStatus) + Status = newVal + BuildDate = Now +End Function + +Public Function UpdateHyperlinks() + Call XLUpdateHyperlink(data_.Cells(row_, S_P_INSTALL_HOME), InstallHome) + Call XLUpdateHyperlink(data_.Cells(row_, S_P_ARTIFACT_HOME), ArtifactPath) + Call XLUpdateHyperlink(data_.Cells(row_, S_P_SOURCE_HOME), SourcePath) +End Function + +'===== Propertiy Get ===== +Public Property Get Makefile() As String + Makefile = Globals.SourceHome & "\" & SourceHome & "\" & MAKEFILE_NAME +End Property + +Public Property Get SourcePath() As String + SourcePath = CPath(SourceHome).ToGlobal(Globals.SourceHome).Text +End Property + +Public Property Get ArtifactPath() As String + ArtifactPath = CPath(ArtifactHome).ToGlobal(Globals.ArtifactHome).Text +End Property + +Public Property Get ProductID() As String + ProductID = data_.Cells(row_, S_P_ID) +End Property + +Public Property Get Version() As String + Version = data_.Cells(row_, S_P_VERSION) +End Property + +Public Property Get Name() As String + Name = data_.Cells(row_, S_P_NAME) +End Property + +Public Property Get Description() As String + Description = data_.Cells(row_, S_P_DESCRIPTION) +End Property + +Public Property Get ArtifactHome() As String + ArtifactHome = data_.Cells(row_, S_P_ARTIFACT_HOME) +End Property + +Public Property Get SourceHome() As String + SourceHome = data_.Cells(row_, S_P_SOURCE_HOME) +End Property + +Public Property Get InstallHome() As String + InstallHome = data_.Cells(row_, S_P_INSTALL_HOME) +End Property + +Public Property Get Status() As TBuildStatus + Status = data_.Cells(row_, S_P_STATUS) +End Property + +Public Property Get BuildDate() As Double + BuildDate = data_.Cells(row_, S_P_LAST_BUILD) +End Property + +Public Property Get IsDistributed() As Boolean + IsDistributed = data_.Cells(row_, S_P_DISTRIBUTE) = "1" +End Property + +Public Property Get InstallDate() As Double + InstallDate = data_.Cells(row_, S_P_LAST_INSTALL) +End Property + +' ==== Property Let ==== +Public Property Let ProductID(newVal$) + data_.Cells(row_, S_P_ID) = newVal +End Property + +Public Property Let Version(newVal$) + data_.Cells(row_, S_P_VERSION) = newVal +End Property + +Public Property Let Name(newVal$) + data_.Cells(row_, S_P_NAME) = newVal +End Property + +Public Property Let Description(newVal$) + data_.Cells(row_, S_P_DESCRIPTION) = newVal +End Property + +Public Property Let ArtifactHome(newVal$) + data_.Cells(row_, S_P_ARTIFACT_HOME) = newVal +End Property + +Public Property Let SourceHome(newVal$) + data_.Cells(row_, S_P_SOURCE_HOME) = newVal +End Property + +Public Property Let InstallHome(newVal$) + data_.Cells(row_, S_P_INSTALL_HOME) = newVal +End Property + +Public Property Let Status(newVal As TBuildStatus) + data_.Cells(row_, S_P_STATUS) = newVal +End Property + +Public Property Let BuildDate(newVal As Double) + data_.Cells(row_, S_P_LAST_BUILD) = newVal +End Property + +Public Property Let IsDistributed(newVal As Boolean) + data_.Cells(row_, S_P_DISTRIBUTE) = IIf(newVal, "1", "0") +End Property + +Public Property Let InstallDate(newVal As Double) + data_.Cells(row_, S_P_LAST_INSTALL) = newVal +End Property diff --git a/src/builder/database/IteratorSharedModule.cls b/src/builder/database/IteratorSharedModule.cls new file mode 100644 index 0000000..8c4672a --- /dev/null +++ b/src/builder/database/IteratorSharedModule.cls @@ -0,0 +1,105 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "IteratorSharedModule" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public row_ As Long +Private data_ As Excel.Worksheet + +Public Sub Init(target As Excel.Worksheet, Optional tRow& = FIRST_ROW) + Set data_ = target + row_ = tRow +End Sub + +Public Function Increment(Optional inc& = 1) + If row_ + inc > 0 Then _ + row_ = row_ + inc +End Function + +Public Function GoFirst() + row_ = FIRST_ROW +End Function + +Public Function GoLast() + row_ = data_.Columns(S_S_NAME).Find(vbNullString, LookAt:=xlWhole).Row - 1 +End Function + +Public Function IsDone() As Boolean + IsDone = data_.Cells(row_, S_S_NAME) = vbNullString +End Function + +Public Function RemoveRow() + Call data_.Rows(row_).Delete +End Function + +'===== Propertiy Get ===== +Public Property Get Name() As String + Name = data_.Cells(row_, S_S_NAME) +End Property + +Public Property Get ModuleType() As VBIDE.vbext_ComponentType + ModuleType = data_.Cells(row_, S_S_TYPE) +End Property + +Public Property Get Path() As String + Path = data_.Cells(row_, S_S_PATH) +End Property + +Public Property Get Version() As String + Version = data_.Cells(row_, S_S_VERSION) +End Property + +Public Property Get LoC() As Long + LoC = data_.Cells(row_, S_S_LINES_TOTAL) +End Property + +Public Property Get Declarations() As Long + Declarations = data_.Cells(row_, S_S_LINES_DECLARATIONS) +End Property + +Public Property Get CountAPI() As Long + CountAPI = data_.Cells(row_, S_S_API_COUNT) +End Property + +Public Property Get UsedIn() As String + UsedIn = data_.Cells(row_, S_S_USAGE) +End Property + +' ==== Property Let ==== +Public Property Let Name(newVal$) + data_.Cells(row_, S_S_NAME) = newVal +End Property + +Public Property Let ModuleType(newVal As VBIDE.vbext_ComponentType) + data_.Cells(row_, S_S_TYPE) = newVal +End Property + +Public Property Let Path(newVal$) + data_.Cells(row_, S_S_PATH) = newVal +End Property + +Public Property Let Version(newVal$) + data_.Cells(row_, S_S_VERSION) = newVal +End Property + +Public Property Let LoC(newVal&) + data_.Cells(row_, S_S_LINES_TOTAL) = newVal +End Property + +Public Property Let Declarations(newVal&) + data_.Cells(row_, S_S_LINES_DECLARATIONS) = newVal +End Property + +Public Property Let CountAPI(newVal&) + data_.Cells(row_, S_S_API_COUNT) = newVal +End Property + +Public Property Let UsedIn(newVal$) + data_.Cells(row_, S_S_USAGE) = newVal +End Property diff --git a/src/builder/database/IteratorTest.cls b/src/builder/database/IteratorTest.cls new file mode 100644 index 0000000..e05e4cb --- /dev/null +++ b/src/builder/database/IteratorTest.cls @@ -0,0 +1,118 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "IteratorTest" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public row_ As Long +Private data_ As Excel.Worksheet + +Public Sub Init(target As Excel.Worksheet, Optional tRow& = FIRST_ROW) + Set data_ = target + row_ = tRow +End Sub + +Public Function Increment(Optional inc& = 1) + If row_ + inc > 0 Then _ + row_ = row_ + inc +End Function + +Public Function GoFirst() + row_ = FIRST_ROW +End Function + +Public Function GoLast() + row_ = data_.Columns(S_T_PRODUCT).Find(vbNullString, LookAt:=xlWhole).Row - 1 +End Function + +Public Function IsDone() As Boolean + IsDone = data_.Cells(row_, S_T_PRODUCT) = vbNullString +End Function + +Public Function RemoveRow() + Call data_.Rows(row_).Delete +End Function + +Public Function PushTestResult(sSuite$, sTest$, bResult As Boolean, sMsg$, dDuration As Double) + TestSuite = sSuite + TestName = sTest + Status = bResult + Message = sMsg + DDate = Now + Duration = dDuration + + Call Increment + Product = data_.Cells(row_ - 1, S_T_PRODUCT) + Component = data_.Cells(row_ - 1, S_T_COMPONENT) +End Function + +'===== Propertiy Get ===== +Public Property Get Product() As String + Product = data_.Cells(row_, S_T_PRODUCT) +End Property + +Public Property Get Component() As String + Component = data_.Cells(row_, S_T_COMPONENT) +End Property + +Public Property Get TestSuite() As String + TestSuite = data_.Cells(row_, S_T_SUITE) +End Property + +Public Property Get TestName() As String + TestName = data_.Cells(row_, S_T_TEST) +End Property + +Public Property Get DDate() As Double + DDate = data_.Cells(row_, S_T_DATE) +End Property + +Public Property Get Duration() As Double + DDate = data_.Cells(row_, S_T_DURATION) +End Property + +Public Property Get Status() As Boolean + Status = data_.Cells(row_, S_T_STATUS) = 1 +End Property + +Public Property Get Message() As String + Message = data_.Cells(row_, S_T_MESSAGE) +End Property + +' ==== Property Let ==== +Public Property Let Product(newVal$) + data_.Cells(row_, S_T_PRODUCT) = newVal +End Property + +Public Property Let Component(newVal$) + data_.Cells(row_, S_T_COMPONENT) = newVal +End Property + +Public Property Let TestSuite(newVal$) + data_.Cells(row_, S_T_SUITE) = newVal +End Property + +Public Property Let TestName(newVal$) + data_.Cells(row_, S_T_TEST) = newVal +End Property + +Public Property Let DDate(newVal As Double) + data_.Cells(row_, S_T_DATE) = newVal +End Property + +Public Property Let Duration(newVal As Double) + data_.Cells(row_, S_T_DURATION) = newVal +End Property + +Public Property Let Status(newVal As Boolean) + data_.Cells(row_, S_T_STATUS) = IIf(newVal, 1, 0) +End Property + +Public Property Let Message(newVal$) + data_.Cells(row_, S_T_MESSAGE) = newVal +End Property diff --git a/src/builder/z_UIMessages.bas b/src/builder/z_UIMessages.bas new file mode 100644 index 0000000..25b1b17 --- /dev/null +++ b/src/builder/z_UIMessages.bas @@ -0,0 +1,129 @@ +Attribute VB_Name = "z_UIMessages" +' Messaging module +Option Private Module +Option Explicit + +Public Enum MsgCode + MSG_OK = 0 + + EM_INVALID_SELECTION + EM_SELF_MODIFICATION + EM_IMPORT_FAILED + EM_EXPORT_FAILED + EM_MANIFEST_INVALID_FORMAT + EM_INVALID_COMPONENT + EM_SKELETON_FAILED + EM_MISSING_MAKEFILE + EM_MISSING_PRODUCT + EM_MISSING_MANIFEST + EM_INVALID_PRODUCT + EM_MISSING_FILE + EM_TESTS_FAILED + EM_MAKEFILE_MISSING + EM_MAKEFILE_LOADING_FAILED + EM_PRODUCT_ALREADY_EXISTS + + IM_MAKEFILE_OK + IM_MAKEFILE_FAILED + IM_MANIFEST_OK + IM_MANIFEST_FAILED + IM_COMPILATION_OK + IM_COMPILATION_FAILED + IM_BUILD_OK + IM_BUILD_FAILED + IM_INSTALL_OK + IM_INSTALL_FAILED + IM_RELOAD_OK + IM_RELOAD_FAILED + IM_TESTS_NOT_FOUND + IM_TESTS_COMPLETE + IM_UPDATE_OK + IM_UPDATE_FAILED + IM_SHARED_INVALID + IM_PRODUCT_ADDED + IM_BATCH_BUILD + IM_BATCH_INSTALL + IM_SCAN_OK + IM_UPDATE_SHARED_OK + IM_UPDATE_SHARED_FAILED + + QM_CODE_DELETE_CONFIRM +End Enum + +Private g_UI As API_UserInteraction + +Public Function UserInteraction() As API_UserInteraction + If g_UI Is Nothing Then _ + Set g_UI = New API_UserInteraction + Set UserInteraction = g_UI +End Function + +Public Function SetUserInteraction(newUI As API_UserInteraction) + Set g_UI = newUI +End Function + +Public Function UIShowMessage(theCode As MsgCode, ParamArray params() As Variant) + Dim unwrapped As Variant: unwrapped = params + unwrapped = FixForwardedParams(unwrapped) + + Select Case theCode + Case EM_INVALID_SELECTION: Call MsgBox("Invalid selection, please select single data item", vbExclamation) + Case EM_SELF_MODIFICATION: Call MsgBox("Cannot self-modify" & vbNewLine & "Please use renamed copy of this Workbook", vbExclamation) + Case EM_IMPORT_FAILED: Call MsgBox("Import failed", vbExclamation) + Case EM_EXPORT_FAILED: Call MsgBox("Export failed", vbExclamation) + Case EM_MANIFEST_INVALID_FORMAT: Call MsgBox("Invalid manifest format", vbExclamation) + Case EM_INVALID_COMPONENT: Call MsgBox("Cannot access selected component", vbExclamation) + Case EM_INVALID_PRODUCT: Call MsgBox("Cannot access selected product", vbExclamation) + Case EM_SKELETON_FAILED: Call MsgBox("Unable to produce skeleton", vbExclamation) + Case EM_MISSING_MAKEFILE: Call MsgBox(Fmt("Missing makefile: {1}", unwrapped), vbExclamation) + Case EM_MISSING_PRODUCT: Call MsgBox(Fmt("Missing product data entry: {1}", unwrapped), vbExclamation) + Case EM_MISSING_MANIFEST: Call MsgBox(Fmt("Missing manifest file: {1}", unwrapped), vbExclamation) + Case EM_MISSING_FILE: Call MsgBox(Fmt("Missing target file: {1}", unwrapped), vbExclamation) + Case EM_TESTS_FAILED: Call MsgBox("Failed to run the tests. See log output for more info", vbExclamation) + Case EM_MAKEFILE_MISSING: Call MsgBox(Fmt("Missing makefile: {1}", unwrapped), vbExclamation) + Case EM_MAKEFILE_LOADING_FAILED: Call MsgBox("Cannot load makefile contents", vbExclamation) + Case EM_PRODUCT_ALREADY_EXISTS: Call MsgBox(Fmt("Product with this name already exists: ", unwrapped), vbExclamation) + + Case IM_MAKEFILE_OK: Call MsgBox("Makefile is valid", vbInformation) + Case IM_MAKEFILE_FAILED: Call MsgBox(Fmt("Makefile is not valid!" & vbNewLine & vbNewLine & "{1}", unwrapped), vbExclamation) + Case IM_MANIFEST_OK: Call MsgBox("Manifest is valid", vbInformation) + Case IM_MANIFEST_FAILED: Call MsgBox(Fmt("Manifest is not valid!" & vbNewLine & vbNewLine & "{1}", unwrapped), vbExclamation) + Case IM_COMPILATION_OK: Call MsgBox("All components are compilable", vbInformation) + Case IM_COMPILATION_FAILED: Call MsgBox(Fmt("Some components are broken!" & vbNewLine & vbNewLine & "{1}", unwrapped), vbExclamation) + Case IM_RELOAD_OK: Call MsgBox("All components updated", vbInformation) + Case IM_RELOAD_FAILED: Call MsgBox(Fmt("Some components could not be updated!" & vbNewLine & vbNewLine & "{1}", unwrapped), vbExclamation) + Case IM_BUILD_OK: Call MsgBox(Fmt("Build successfull" & vbNewLine & "Time elapsed: {1}", unwrapped), vbInformation) + Case IM_BUILD_FAILED: Call MsgBox("Build failed. See debug output", vbExclamation) + Case IM_INSTALL_OK: Call MsgBox(Fmt("Installationg successfull" & vbNewLine & "Time elapsed: {1}", unwrapped), vbInformation) + Case IM_INSTALL_FAILED: Call MsgBox("Installation failed. See debug output", vbExclamation) + Case IM_TESTS_NOT_FOUND: Call MsgBox("No tests available for this component", vbInformation) + Case IM_UPDATE_OK: Call MsgBox("Target update success", vbInformation) + Case IM_UPDATE_FAILED: Call MsgBox("Target update failed", vbExclamation) + Case IM_UPDATE_SHARED_OK: Call MsgBox(Fmt("Target shared modules updated: {1}" & vbNewLine & "{2}", unwrapped), vbInformation) + Case IM_UPDATE_SHARED_FAILED: Call MsgBox("Failed to compile after update", vbExclamation) + Case IM_SHARED_INVALID: Call MsgBox(Fmt("Unknown shared modules" & vbNewLine & "{1}", unwrapped), vbExclamation) + Case IM_PRODUCT_ADDED: Call MsgBox(Fmt("Product added: {1}", unwrapped), vbInformation) + Case IM_BATCH_INSTALL: Call MsgBox(Fmt("Install all products complete: {1} / {2}" & vbNewLine & "Time elapsed: {3}", unwrapped), vbInformation) + Case IM_BATCH_BUILD: Call MsgBox(Fmt("Build all products complete: {1} / {2}" & vbNewLine & "Time elapsed: {3}", unwrapped), vbInformation) + Case IM_SCAN_OK: Call MsgBox(Fmt("Scanning makefiles complete. Found {1} new products", unwrapped), vbInformation) + Case IM_TESTS_COMPLETE + Call MsgBox(Fmt("Testing finished: {1} | {2} / {3}" & vbNewLine & "Time elapsed: {4}", unwrapped), IIf(unwrapped(2) = 0, vbInformation, vbExclamation)) + + Case Else: Call MsgBox("Invalid message code", vbCritical) + End Select +End Function + +Public Function UIAskQuestion(theCode As MsgCode, ParamArray params() As Variant) As Boolean + Dim unwrapped As Variant: unwrapped = params + unwrapped = FixForwardedParams(unwrapped) + + Dim answer&: answer = vbNo + Select Case theCode + Case QM_CODE_DELETE_CONFIRM + answer = MsgBox("Are you sure you want to delete ALL macros from target file?", vbYesNo + vbQuestion) + + Case Else + Call MsgBox("Invalid message code", vbCritical) + End Select + UIAskQuestion = answer = vbYes +End Function diff --git a/src/builder/z_UIRibbon.bas b/src/builder/z_UIRibbon.bas new file mode 100644 index 0000000..24ec5eb --- /dev/null +++ b/src/builder/z_UIRibbon.bas @@ -0,0 +1,62 @@ +Attribute VB_Name = "z_UIRibbon" +Option Private Module +Option Explicit + +Public Sub OnRibbonBtn(iControl As IRibbonControl) + Select Case iControl.ID + Case "EditVBAMake": Call RunEditVBAMake + Case "EditManifect": Call RunEditManifect + Case "OpenSrc": Call RunOpenSrc + Case "OpenArtifact": Call RunOpenArtifact + + Case "TestVBAMake": Call RunTestVBAMake + Case "BuildProduct": Call RunBuildProduct + Case "InstallProduct": Call RunInstallProduct + Case "AddProduct": Call RunAddProduct + Case "ArchiveVersion": Call RunArchiveVersion + + Case "TestManifest": Call RunTestManifest + Case "TestComponent": Call RunTestComponent + Case "BuildComponent": Call RunBuildComponent + Case "UpdateSkeleton": Call RunUpdateSkeleton + Case "OpenComponent": Call RunOpenComponent + Case "OpenComponentRO": Call RunOpenComponentReadOnly + + Case "ExportCode": Call RunExportCode + Case "ExportShared": Call RunExportShared + Case "ReloadCode": Call RunReloadCode + Case "UpdateShared": Call RunReloadShared + Case "ListRefs": Call RunListRefs + Case "ListModules": Call RunListModules + + Case "ReloadAllShared": Call RunReloadAllShared + Case "CompileAll": Call RunCompileAll + Case "RunAllTests": Call RunAllTests + Case "BuildAll": Call RunBuildAll + Case "InstallAll": Call RunInstallAll + Case "ScanFolder": Call RunScanFolder + + Case "TargetUpdateAll": Call RunUpdateTarget + Case "TargetUpdateShared": Call RunTargetUpdateShared + Case "TargetClearCode": Call RunTargetClearCode + + Case "OpenLog": Call RunOpenLog + Case "OpenConfig": Call RunOpenConfig + Case "OpenVBCommons": Call RunOpenVBCommons + Case "OpenAppData": Call RunOpenAppData + Case "OpenUserProfile": Call RunOpenUserProfile + Case "OpenConcept": Call RunOpenConcept + Case "OpenCIHT": Call RunOpenCIHT + Case "OpenInstall": Call RunOpenInstall + + Case "ListShared": Call RunListShared + End Select +End Sub + +Public Sub OnDefaultBuild(iControl As IRibbonControl, ByRef vVal) + vVal = Globals.build_ +End Sub + +Public Sub OnBuildTypeChange(iControl As IRibbonControl, idLabel$, nIndex As Variant) + Globals.build_ = nIndex +End Sub diff --git a/src/commons/Declarations.bas b/src/commons/Declarations.bas new file mode 100644 index 0000000..c8583e3 --- /dev/null +++ b/src/commons/Declarations.bas @@ -0,0 +1,4 @@ +Attribute VB_Name = "Declarations" +Option Private Module +Option Explicit + diff --git a/src/commons/DevHelper.bas b/src/commons/DevHelper.bas new file mode 100644 index 0000000..ad60c79 --- /dev/null +++ b/src/commons/DevHelper.bas @@ -0,0 +1,59 @@ +Attribute VB_Name = "DevHelper" +Option Explicit + +Public Const TEST_TARGET_FOLDER = "testFiles" +Public Const TEST_ARTIFACT_FOLDER = "test" + +Public Const TEST_WORD_TEMPLATE = "testTemplate.dotx" +Public Const TEST_WORD_DOCUMENT = "TestWord.docx" +Public Const TEST_WORD_INVALID = "TestInvalid.docx" + +Public Function Dev_PrepareSkeleton() + ' Do nothing +End Function + +Public Sub Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_Path" + Dim sTest$: sTest = "t_ToLocal" + Dim sMsg$: sMsg = Dev_RunTestDebug(sSuite, sTest) + Debug.Print sMsg + Call MsgBox(sMsg) +End Sub + +Public Function Dev_GetTestSuite(sName$) As Object + Select Case sName + Case "s_Config": Set Dev_GetTestSuite = New s_Config + Case "s_JSON": Set Dev_GetTestSuite = New s_JSON + Case "s_Path": Set Dev_GetTestSuite = New s_Path + Case "s_CompoundIntervals": Set Dev_GetTestSuite = New s_CompoundIntervals + Case "s_ExColor": Set Dev_GetTestSuite = New s_ExColor + Case "s_StaticHierarchy": Set Dev_GetTestSuite = New s_StaticHierarchy + Case "s_ParseDate": Set Dev_GetTestSuite = New s_ParseDate + Case "s_ExCollection": Set Dev_GetTestSuite = New s_ExCollection + Case "s_ExVBA": Set Dev_GetTestSuite = New s_ExVBA + Case "s_ExHash": Set Dev_GetTestSuite = New s_ExHash + Case "s_Logger": Set Dev_GetTestSuite = New s_Logger + Case "s_WordWrapper": Set Dev_GetTestSuite = New s_WordWrapper + Case "s_XLWrapper": Set Dev_GetTestSuite = New s_XLWrapper + Case "s_VsoWrapper": Set Dev_GetTestSuite = New s_VsoWrapper + Case "s_ExWinAPI": Set Dev_GetTestSuite = New s_ExWinAPI + Case "s_Graph": Set Dev_GetTestSuite = New s_Graph + End Select +End Function + +Public Function Dev_GetTestFolder() As String + Static sFolder$ + If sFolder = vbNullString Then + sFolder = ThisWorkbook.Path & "\" & TEST_TARGET_FOLDER + End If + Dev_GetTestFolder = sFolder +End Function + +Public Function Dev_GetArtifactFolder() As String + Static sFolder$ + If sFolder = vbNullString Then + sFolder = ThisWorkbook.Path & "\" & TEST_ARTIFACT_FOLDER + End If + Dev_GetArtifactFolder = sFolder +End Function + diff --git a/src/commons/Main.bas b/src/commons/Main.bas new file mode 100644 index 0000000..e50484d --- /dev/null +++ b/src/commons/Main.bas @@ -0,0 +1,3 @@ +Attribute VB_Name = "Main" +Option Private Module +Option Explicit diff --git a/src/commons/MainImpl.bas b/src/commons/MainImpl.bas new file mode 100644 index 0000000..50e4abe --- /dev/null +++ b/src/commons/MainImpl.bas @@ -0,0 +1,4 @@ +Attribute VB_Name = "MainImpl" +Option Private Module +Option Explicit + diff --git a/src/test/TestCustomObject.cls b/src/test/TestCustomObject.cls new file mode 100644 index 0000000..45c0dea --- /dev/null +++ b/src/test/TestCustomObject.cls @@ -0,0 +1,20 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "TestCustomObject" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Public data_ As Double + +Public Function Compare(rhs As Variant) As Double + Compare = data_ - rhs.data_ +End Function + +Public Function ToString(Optional nIndent& = 0) As String + ToString = data_ +End Function diff --git a/src/test/s_CompoundIntervals.cls b/src/test/s_CompoundIntervals.cls new file mode 100644 index 0000000..93698ef --- /dev/null +++ b/src/test/s_CompoundIntervals.cls @@ -0,0 +1,119 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_CompoundIntervals" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private intervals_ As CDS_CompoundIntervals + +Public Function Setup() + ' Mandatory setup function + Set intervals_ = New CDS_CompoundIntervals +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_IsEmpty() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty") + Call Dev_ExpectEQ(0, intervals_.Count) + Call Dev_ExpectTrue(intervals_.IsEmpty) + + Call Dev_NewCase("Not Empty") + Call intervals_.AddItem(2, 2) + Call Dev_ExpectEQ(1, intervals_.Count) + Call Dev_ExpectFalse(intervals_.IsEmpty) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_AddInverval() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Invalid interval") + Call intervals_.AddItem(1, -1) + Call Dev_ExpectEQ(0, intervals_.Count) + + Call Dev_NewCase("Zero length") + Call intervals_.AddItem(2, 2) + Call Dev_AssertEQ(1, intervals_.Count) + Call Dev_ExpectEQ(Interval(2, 2), intervals_.items_(1)) + + Call Dev_NewCase("Duplicate") + Call intervals_.AddItem(2, 2) + Call Dev_ExpectEQ(1, intervals_.Count) + + Call Dev_NewCase("Generic interval ordering") + Call intervals_.AddItem(3, 4) + Call intervals_.AddItem(-1, 0) + Call Dev_AssertEQ(3, intervals_.Count) + Call Dev_ExpectEQ(Interval(-1, 0), intervals_.items_(1)) + Call Dev_ExpectEQ(Interval(2, 2), intervals_.items_(2)) + Call Dev_ExpectEQ(Interval(3, 4), intervals_.items_(3)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Compounding() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Absorb zero length") + Call intervals_.AddItem(2, 2) + Call intervals_.AddItem(1, 2) + Call Dev_AssertEQ(1, intervals_.Count) + Call Dev_ExpectEQ(Interval(1, 2), intervals_.items_(1)) + Call intervals_.AddItem(1, 1) + Call Dev_ExpectEQ(1, intervals_.Count) + + Call Dev_NewCase("Merge borders") + Call intervals_.Clear + Call intervals_.AddItem(1, 2) + Call intervals_.AddItem(3, 4) + Call intervals_.AddItem(2, 3) + Call Dev_AssertEQ(1, intervals_.Count) + Call Dev_ExpectEQ(Interval(1, 4), intervals_.items_(1)) + + Call Dev_NewCase("Absorb nested") + Call intervals_.Clear + Call intervals_.AddItem(1, 4) + Call intervals_.AddItem(2, 3) + Call Dev_AssertEQ(1, intervals_.Count) + Call Dev_ExpectEQ(Interval(1, 4), intervals_.items_(1)) + + Call Dev_NewCase("Merge intersecting") + Call intervals_.Clear + Call intervals_.AddItem(1, 3) + Call intervals_.AddItem(2, 4) + Call Dev_AssertEQ(1, intervals_.Count) + Call Dev_ExpectEQ(Interval(1, 4), intervals_.items_(1)) + + Call Dev_NewCase("Merge multiple") + Call intervals_.Clear + Call intervals_.AddItem(1, 3) + Call intervals_.AddItem(4, 6) + Call intervals_.AddItem(2, 5) + Call Dev_AssertEQ(1, intervals_.Count) + Call Dev_ExpectEQ(Interval(1, 6), intervals_.items_(1)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +' ====== +Private Function Interval(nStart&, nFinish&) As CDS_Interval + Dim iNewItem As New CDS_Interval: Call iNewItem.Init(nStart, nFinish) + Set Interval = iNewItem +End Function diff --git a/src/test/s_Config.cls b/src/test/s_Config.cls new file mode 100644 index 0000000..0b87243 --- /dev/null +++ b/src/test/s_Config.cls @@ -0,0 +1,105 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_Config" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private fso_ As Scripting.FileSystemObject +Private config_ As API_Config + +Public Function Setup() + ' Mandatory setup function + Set fso_ = New Scripting.FileSystemObject + Set config_ = New API_Config + Call EnsureFolderExists(Dev_GetTestFolder) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call fso_.DeleteFolder(Dev_GetTestFolder) +End Function + +Public Function t_BasicDictionary() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty config") + Call Dev_ExpectFalse(config_.Contains("")) + Call Dev_ExpectFalse(config_.Contains("1")) + Call Dev_ExpectEQ(42, config_.GetValue("1", 42)) + Call Dev_ExpectEQ("", config_.GetValue("1")) + + Call Dev_NewCase("Basic type") + Call config_.SetValue("1", 42) + Call Dev_ExpectTrue(config_.Contains("1")) + Call Dev_ExpectEQ(42, config_.GetValue("1")) + Call config_.Clear + Call Dev_ExpectFalse(config_.Contains("1")) + + Call Dev_NewCase("Double set") + Call config_.SetValue("1", 1) + Call config_.SetValue("1", 2) + Call Dev_ExpectEQ(2, config_.GetValue("1")) + Call config_.Clear + + Call Dev_NewCase("Object type") + Call config_.SetValue("1", CColl(1, 2)) + Call Dev_ExpectEQ(CColl(1, 2), config_.GetValue("1")) + Call Dev_ExpectEQ(CColl(1, 2, 3), config_.GetValue("2", CColl(1, 2, 3))) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_FileIO() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Save to file") + Call config_.SetValue("0", "") + Call config_.SetValue("1", 1) + Call config_.SetValue("2", "42") + Call config_.SetValue("3", CColl(1, 2)) + Dim sTestFile$: sTestFile = Dev_GetTestFolder & "\test.json" + Call Dev_AssertTrue(config_.SaveToFile(sTestFile)) + + Call Dev_NewCase("Load from file") + Dim iLoad As New API_Config + Call Dev_AssertTrue(iLoad.LoadFromFile(sTestFile)) + Call Dev_ExpectEQ(config_.GetValue("0"), iLoad.GetValue("0")) + Call Dev_ExpectEQ(config_.GetValue("1"), iLoad.GetValue("1")) + Call Dev_ExpectEQ(config_.GetValue("2"), iLoad.GetValue("2")) + Call Dev_ExpectEQ(config_.GetValue("3"), iLoad.GetValue("3")) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_JSON_IO() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Save and Load JSON") + Call config_.SetValue("0", "") + Call config_.SetValue("1", 1) + Call config_.SetValue("2", "42") + Call config_.SetValue("3", CColl(1, 2)) + Call config_.SetValue("4", True) + Dim sJson$: sJson = config_.SaveToJSON() + + Dim iLoad As New API_Config + Call Dev_AssertTrue(iLoad.LoadFromJSON(sJson)) + Call Dev_ExpectEQ(config_.GetValue("0"), iLoad.GetValue("0")) + Call Dev_ExpectEQ(config_.GetValue("1"), iLoad.GetValue("1")) + Call Dev_ExpectEQ(config_.GetValue("2"), iLoad.GetValue("2")) + Call Dev_ExpectEQ(config_.GetValue("3"), iLoad.GetValue("3")) + Call Dev_ExpectEQ(config_.GetValue("4"), iLoad.GetValue("4")) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_ExCollection.cls b/src/test/s_ExCollection.cls new file mode 100644 index 0000000..d1f54ce --- /dev/null +++ b/src/test/s_ExCollection.cls @@ -0,0 +1,237 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_ExCollection" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Test suite for date Parsing ======= +Option Explicit + +Public Function Setup() + ' Mandatory setup function +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_InCollection() + On Error GoTo PROPAGATE_ERROR + + Dim aCol As Collection + Dim sKey$: sKey = "test" + Call Dev_ExpectFalse(InCollection(sKey, Nothing), "Nothing") + Call Dev_ExpectFalse(InCollection(sKey, aCol), "Undefined") + + Set aCol = New Collection + Call Dev_ExpectFalse(InCollection(sKey, aCol), "Empty") + + Dim nItem& + For nItem = 1 To 10 Step 1 + Call aCol.Add("", sKey & VBA.Int(VBA.Rnd * 1000)) + Next nItem + Call Dev_ExpectFalse(InCollection(sKey, aCol), "False") + + Call aCol.Add("", sKey) + Call Dev_ExpectTrue(InCollection(sKey, aCol), "True") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_IsArrayAllocated() + On Error GoTo PROPAGATE_ERROR + + Dim tArray() As String + + Call Dev_ExpectFalse(IsArrayAllocated(0), "Non-array basic type") + Call Dev_ExpectFalse(IsArrayAllocated(Nothing), "Nothing") + Call Dev_ExpectFalse(IsArrayAllocated(Me), "Object") + Call Dev_ExpectFalse(IsArrayAllocated(tArray), "No allocated") + + ReDim tArray(1 To 10) + Call Dev_ExpectTrue(IsArrayAllocated(tArray), "Allocated") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_IsSubsetOf() + On Error GoTo PROPAGATE_ERROR + + Dim aCol1 As New Collection + Dim aCol2 As New Collection + + Call Dev_ExpectFalse(IsSubsetOf(Nothing, Nothing), "Nothing is not subset of nothing") + Call Dev_ExpectFalse(IsSubsetOf(Nothing, aCol2), "Nothing is not subset of anything") + Call Dev_ExpectFalse(IsSubsetOf(aCol1, Nothing), "Anything is not subset of Nothing") + Call Dev_ExpectTrue(IsSubsetOf(aCol1, aCol2), "Empty is subset of Empty") + + Dim sKey1$: sKey1 = "test1" + Dim sKey2$: sKey2 = "test2" + Dim sKey3$: sKey3 = "test3" + Call aCol2.Add(sKey1, sKey1) + Call aCol2.Add(sKey2, sKey2) + Call Dev_ExpectTrue(IsSubsetOf(aCol1, aCol2), "Empty is subset of Anything") + + Call aCol1.Add(sKey1, sKey1) + Call Dev_ExpectTrue(IsSubsetOf(aCol1, aCol2), "Valid subset") + + Call aCol1.Add(sKey1, sKey2) + Call Dev_ExpectTrue(IsSubsetOf(aCol1, aCol2), "Self subset") + + Call aCol1.Add(sKey3, sKey3) + Call Dev_ExpectFalse(IsSubsetOf(aCol1, aCol2), "Not subset") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_SafeAddToCollection() + On Error GoTo PROPAGATE_ERROR + + Dim aCol As Collection + Dim sKey$: sKey = "test" + Call Dev_ExpectFalse(SafeAddToCollection("", sKey, Nothing), "Nothing") + Call Dev_ExpectFalse(SafeAddToCollection("", sKey, aCol), "Undefined") + + Call Dev_NewCase("Valid add") + Set aCol = New Collection + Call Dev_ExpectTrue(SafeAddToCollection("", sKey, aCol)) + Call Dev_ExpectTrue(InCollection(sKey, aCol)) + Call Dev_ExpectEQ(1, aCol.Count) + + Call Dev_NewCase("Add duplicate") + Call Dev_ExpectFalse(SafeAddToCollection("", sKey, aCol)) + Call Dev_ExpectTrue(InCollection(sKey, aCol)) + Call Dev_ExpectEQ(1, aCol.Count) + + Call Dev_NewCase("Add second item") + Dim sKey2$: sKey2 = "test2" + Call Dev_ExpectTrue(SafeAddToCollection("", sKey2, aCol)) + Call Dev_ExpectTrue(InCollection(sKey2, aCol)) + Call Dev_ExpectEQ(2, aCol.Count) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_SafeMergeCollection() + On Error GoTo PROPAGATE_ERROR + + Dim aCol1 As New Collection + Dim aCol2 As New Collection + + Call Dev_ExpectFalse(SafeMergeCollection(Nothing, Nothing), "Nothing merge nothing") + Call Dev_ExpectFalse(SafeMergeCollection(Nothing, aCol2), "Nothing merge anything") + Call Dev_ExpectFalse(SafeMergeCollection(aCol1, Nothing), "Anything merge Nothing") + Call Dev_ExpectTrue(SafeMergeCollection(aCol1, aCol2), "Empty merge Empty") + Call Dev_ExpectTrue(SafeMergeCollection(aCol1, aCol1), "Merge self") + + Call Dev_NewCase("Valid merge") + Dim sKey1$: sKey1 = "test1" + Dim sKey2$: sKey2 = "test2" + Dim sKey3$: sKey3 = "test3" + Call aCol1.Add(sKey1, sKey1) + Call aCol1.Add(sKey2, sKey2) + Call aCol2.Add(sKey1, sKey1) + Call aCol2.Add(sKey3, sKey3) + Call Dev_ExpectTrue(SafeMergeCollection(aCol1, aCol2)) + Call Dev_ExpectEQ(2, aCol1.Count) + Call Dev_ExpectEQ(3, aCol2.Count) + Call Dev_ExpectTrue(InCollection(sKey2, aCol2)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ArrayConversion() + On Error GoTo PROPAGATE_ERROR + + Dim tArray As Variant + Dim aCol As Collection + + Call Dev_ExpectNothing(FromArray(tArray), "Nothing from undef") + Call Dev_ExpectFalse(IsArrayAllocated(ToArray(Nothing)), "Nothing to undef") + + Call Dev_NewCase("Empty to empty") + Set aCol = New Collection + tArray = ToArray(aCol) + Call Dev_ExpectTrue(IsArrayAllocated(tArray)) + Call Dev_ExpectEQ(UBound(tArray, 1), LBound(tArray, 1)) + + Call Dev_NewCase("Empty from empty") + Set aCol = FromArray(tArray) + Call Dev_AssertNotNothing(aCol) + Call Dev_ExpectEQ(0, aCol.Count) + + Call Dev_NewCase("Valid collection to array") + Set aCol = New Collection + Const nCount& = 10 + Dim nItem& + For nItem = 1 To nCount Step 1 + Dim nVal&: nVal = VBA.Int(VBA.Rnd * 1000) + If Not InCollection(CStr(nVal), aCol) Then _ + Call aCol.Add(nVal, CStr(nVal)) + Next nItem + tArray = ToArray(aCol) + Call Dev_AssertEQ(nCount, UBound(tArray) - LBound(tArray) + 1) + For nItem = 1 To nCount Step 1 + Call Dev_ExpectTrue(InCollection(CStr(tArray(nItem - 1)), aCol)) + Next nItem + + Call Dev_NewCase("Valid collection from array") + Set aCol = Nothing + Set aCol = FromArray(tArray) + Call Dev_ExpectEQ(nCount, UBound(tArray) - LBound(tArray) + 1) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CollectionToIndex() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(CSet(), CollectionToIndex(CColl()), "Empty collection") + + Call Dev_NewCase("Unique elements") + Dim indicies As New Scripting.Dictionary + indicies(1337) = 1 + indicies("leet") = 2 + Call Dev_ExpectEQ(indicies, CollectionToIndex(CColl(1337, "leet"))) + + Call Dev_NewCase("Initialized duplicate elements") + Call Dev_ExpectEQ(indicies, CollectionToIndex(CColl(1337, "leet", 1337))) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_RevertCollection() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(CColl(), RevertCollection(CColl()), "Empty collection") + + Call Dev_NewCase("Unique elements") + Dim indicies As New Scripting.Dictionary + indicies(1337) = 1 + indicies("leet") = 2 + Call Dev_ExpectEQ(CColl("leet", 1337), RevertCollection(CColl(1337, "leet"))) + + Call Dev_NewCase("Palindrom") + Call Dev_ExpectEQ(CColl(1337, "leet", 1337), RevertCollection(CColl(1337, "leet", 1337))) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_ExColor.cls b/src/test/s_ExColor.cls new file mode 100644 index 0000000..078eafb --- /dev/null +++ b/src/test/s_ExColor.cls @@ -0,0 +1,62 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_ExColor" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' TODO: +' Public Function ColorGetRGB(nColorID&, aDocument As Object) As Long +' Public Function QueryColor(nColorID&, aDocument As Object) As ColorDetails + +Public Function Setup() + ' Mandatory setup function +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_GetLuma() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(255, ColorGetLuma(RGB(255, 255, 255)), "White") + Call Dev_ExpectEQ(0, ColorGetLuma(RGB(0, 0, 0)), "Black") + Call Dev_ExpectEQ(54, ColorGetLuma(RGB(255, 0, 0)), "Red") + Call Dev_ExpectEQ(182, ColorGetLuma(RGB(0, 255, 0)), "Green") + Call Dev_ExpectEQ(18, ColorGetLuma(RGB(0, 0, 255)), "Blue") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ColorString() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Invalid input") + Call Dev_ExpectEQ(HC_INVALID, ConvertStringToRGB("99999999999"), "Overflow long") + Call Dev_ExpectEQ(HC_INVALID, ConvertStringToRGB(RGB(255, 255, 255)), "Overflow integer") + Call Dev_ExpectEQ(HC_INVALID, ConvertStringToRGB("RGB(256,0,0)"), "Invalid color value") + Call Dev_ExpectEQ("RGB(255,255,255)", ConvertRGBtoString(&HFFFFFFFF), "Overflow color") + + Call Dev_NewCase("White") + Call Dev_ExpectEQ(RGB(255, 255, 255), ConvertStringToRGB("RGB(255,255,255)")) + Call Dev_ExpectEQ("RGB(255,255,255)", ConvertRGBtoString(RGB(255, 255, 255))) + + Call Dev_NewCase("Black") + Call Dev_ExpectEQ(RGB(0, 0, 0), ConvertStringToRGB("RGB(0,0,0)")) + Call Dev_ExpectEQ("RGB(0,0,0)", ConvertRGBtoString(RGB(0, 0, 0))) + + Call Dev_NewCase("Generic color") + Call Dev_ExpectEQ(RGB(165, 137, 99), ConvertStringToRGB("RGB(165,137,99)")) + Call Dev_ExpectEQ("RGB(55,67,77)", ConvertRGBtoString(RGB(55, 67, 77))) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_ExHash.cls b/src/test/s_ExHash.cls new file mode 100644 index 0000000..42bf850 --- /dev/null +++ b/src/test/s_ExHash.cls @@ -0,0 +1,39 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_ExHash" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Test suite for Hashing ======= +Option Explicit + +Public Function Setup() + ' Mandatory setup function +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_HashMD5() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Null string") + Call Dev_ExpectEQ("d41d8cd98f00b204e9800998ecf8427e", MD5AsString(vbNullString)) + Call Dev_ExpectEQ(319274370, MD5AsLong(vbNullString)) + + Call Dev_NewCase("Empty string") + Call Dev_ExpectEQ("d41d8cd98f00b204e9800998ecf8427e", MD5AsString("")) + Call Dev_ExpectEQ(319274370, MD5AsLong("")) + + Call Dev_NewCase("Known long string") + Call Dev_ExpectEQ("a802c7e23a696b5bc43fc002c4ab3361", MD5AsString("Testing long string")) + Call Dev_ExpectEQ(995413151, MD5AsLong("Testing long string")) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_ExVBA.cls b/src/test/s_ExVBA.cls new file mode 100644 index 0000000..77440d8 --- /dev/null +++ b/src/test/s_ExVBA.cls @@ -0,0 +1,645 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_ExVBA" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Test suite for date Parsing ======= +Option Explicit + +Public Function Setup() + ' Mandatory setup function +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_CreateCollection() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(New Collection, CColl(), "Empty collection") + + Call Dev_NewCase("Valid collection") + Dim iExpect As New Collection + Call iExpect.Add(1): Call iExpect.Add("13"): Call iExpect.Add(3): Call iExpect.Add(1) + Call Dev_ExpectEQ(iExpect, CColl(1, "13", 3, 1)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CSet() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(New Scripting.Dictionary, CSet(), "Empty set") + + Call Dev_NewCase("Valid set") + Dim iExpect As New Scripting.Dictionary + Call iExpect.Add(1, 0): Call iExpect.Add("13", 0): Call iExpect.Add(3, 0) + Call Dev_ExpectEQ(iExpect, CSet(1, "13", 3)) + + Call Dev_NewCase("Duplicate elements") + Call Dev_ExpectEQ(iExpect, CSet(1, "13", 3, 1, 3)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CreateDictionary() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(New Scripting.Dictionary, CDict(), "Empty dict") + + Call Dev_NewCase("Valid set") + Dim iExpect As New Scripting.Dictionary + Call iExpect.Add(1, 42): Call iExpect.Add("13", 1337): Call iExpect.Add(3, CDict()) + Call Dev_ExpectEQ(iExpect, CDict(1, 42, "13", 1337, 3, CDict())) + + Call Dev_NewCase("Invalid number of args") + On Error Resume Next + Set iExpect = CDict(1, "13", 3) + Call Dev_ExpectAnyError + On Error GoTo PROPAGATE_ERROR + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_UniqueList() + On Error GoTo PROPAGATE_ERROR + + Dim uList As Scripting.Dictionary + + Call Dev_ExpectEQ(0, UniqueList.Count, "Empty list") + + Call Dev_NewCase("Simple list") + Set uList = UniqueList(13, 37, 3) + Call Dev_AssertEQ(3, uList.Count) + Call Dev_ExpectEQ(1, uList(13)) + Call Dev_ExpectEQ(2, uList(37)) + Call Dev_ExpectEQ(3, uList(3)) + + Call Dev_NewCase("Repeating elements") + Set uList = UniqueList(13, 13, 3) + Call Dev_AssertEQ(2, uList.Count) + Call Dev_ExpectEQ(1, uList(13)) + Call Dev_ExpectEQ(3, uList(3)) + + Call Dev_NewCase("Mixed list") + Set uList = UniqueList(13, "37", 3.1) + Call Dev_AssertEQ(3, uList.Count) + Call Dev_ExpectEQ(1, uList(13)) + Call Dev_ExpectEQ(2, uList("37")) + Call Dev_ExpectEQ(3, uList(3.1)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ArraySize() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(VBA_INVALID_SIZE, ArraySize(Nothing, 1), "Nothing") + Call Dev_ExpectEQ(VBA_INVALID_SIZE, ArraySize(1, 1), "Non-array") + Call Dev_ExpectEQ(VBA_INVALID_SIZE, ArraySize(New Collection, 1), "Object") + + Dim unallocArr() As Variant + Call Dev_ExpectEQ(VBA_INVALID_SIZE, ArraySize(unallocArr, 1), "Unallocated") + + Dim arr1() As Variant + ReDim arr1(0 To 4) + Call Dev_ExpectEQ(5, ArraySize(arr1, 1), "1D Array 0-based") + Call Dev_ExpectEQ(VBA_INVALID_SIZE, ArraySize(arr1, 2), "Out of bounds dimension") + Call Dev_ExpectEQ(VBA_INVALID_SIZE, ArraySize(arr1, -1), "Invalid dimension") + + ReDim arr1(1 To 5) + Call Dev_ExpectEQ(5, ArraySize(arr1, 1), "1D Array 1-based") + + Call Dev_NewCase("2D array") + Dim arr2() As Variant + ReDim arr2(1 To 5, 1 To 7) + Call Dev_ExpectEQ(5, ArraySize(arr2, 1)) + Call Dev_ExpectEQ(7, ArraySize(arr2, 2)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ArrayToIndex() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectNothing(ArrayToIndex(Array()), "Not allocated") + + Call Dev_NewCase("Not initialized") + Dim arr(1 To 2) As Variant + Dim indicies As New Scripting.Dictionary + indicies(Empty) = 1 + Call Dev_ExpectEQ(indicies, ArrayToIndex(arr)) + + Call Dev_NewCase("Initialized unique elements") + Call indicies.RemoveAll + arr(1) = 1337: indicies(1337) = 1 + arr(2) = "leet": indicies("leet") = 2 + Call Dev_ExpectEQ(indicies, ArrayToIndex(arr)) + + Call Dev_NewCase("Initialized duplicate elements") + Call indicies.RemoveAll + arr(1) = 1337: indicies(1337) = 1 + arr(2) = 1337 + Call Dev_ExpectEQ(indicies, ArrayToIndex(arr)) + + Call Dev_NewCase("Custom base") + Dim arr2(2 To 5) As Variant + Call indicies.RemoveAll + indicies(Empty) = 2 + Call Dev_ExpectEQ(indicies, ArrayToIndex(arr2)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_IsArrayAllocated() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectFalse(IsArrayAllocated(Nothing), "Nothing") + Call Dev_ExpectFalse(IsArrayAllocated(1), "Non-array") + Call Dev_ExpectFalse(IsArrayAllocated(New Collection), "Object") + + Call Dev_NewCase("Unallocated") + Dim unallocArr() As Variant + Call Dev_ExpectFalse(IsArrayAllocated(unallocArr)) + Call Dev_ExpectNoError + + Dim arr1(1 To 5) As Variant + Call Dev_ExpectTrue(IsArrayAllocated(arr1), "Allocated empty array") + + Dim arr2 As Variant: arr2 = Array(1, 2, 3) + Call Dev_ExpectTrue(IsArrayAllocated(arr2), "Allocated full array") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_FixForwardedParams() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectFalse(IsArrayAllocated(TestForwardParams()), "No params") + Call Dev_ExpectEQ(Array(1), TestForwardParams(1), "Simple arg") + Call Dev_ExpectEQ(Array(1, "123"), TestForwardParams(1, "123"), "Multiple arg") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CompareApproximate() + On Error GoTo PROPAGATE_ERROR + + On Error Resume Next + Call Dev_ExpectEQ(0, CompareApproximate("a", "b", 0)) + Call Dev_ExpectError(SYS_ERR_TYPE_MISMATCH, "Invalid type comparison") + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Precision equals") + Call Dev_ExpectEQ(0, CompareApproximate(0, 0, 0)) + Call Dev_ExpectEQ(0, CompareApproximate(1, 1, 0)) + Call Dev_ExpectEQ(0, CompareApproximate(1.1, 1.1, 0)) + Call Dev_ExpectNE(0, CompareApproximate(1.1, 1, 1)) + Call Dev_ExpectEQ(0, CompareApproximate(1.1, 1, 0)) + Call Dev_ExpectEQ(0, CompareApproximate(11, 10, -1)) + Call Dev_ExpectEQ(0, CompareApproximate(111, 100, -2)) + Call Dev_ExpectEQ(11, CompareApproximate(111, 100, -1)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CompareDeepBasic() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Basic type equals") + Call Dev_ExpectEQ(0, CompareDeep(True, True)) + Call Dev_ExpectEQ(0, CompareDeep(0, 0)) + Call Dev_ExpectEQ(0, CompareDeep(0&, 0&)) + Call Dev_ExpectEQ(0, CompareDeep(1.1, 1.1)) + Call Dev_ExpectEQ(0, CompareDeep(1.1!, 1.1!)) + Call Dev_ExpectEQ(0, CompareDeep("", "")) + + Call Dev_NewCase("Basic type compare") + Call Dev_ExpectNE(0, CompareDeep(False, True)) + Call Dev_ExpectNE(0, CompareDeep(True, False)) + Call Dev_ExpectEQ(1, CompareDeep(2, 1)) + Call Dev_ExpectEQ(2, CompareDeep(3, 1)) + Call Dev_ExpectEQ(-2, CompareDeep(1, 3)) + Call Dev_ExpectEQ(2, CompareDeep(3&, 1&)) + Call Dev_ExpectEQ(-2, CompareDeep(1&, 3&)) + Call Dev_ExpectAEQ(2, CompareDeep(3.1, 1.1), 0) + Call Dev_ExpectAEQ(-2, CompareDeep(1.1, 3.1), 0) + Call Dev_ExpectAEQ(1.9, CompareDeep(3, 1.1), 1) + Call Dev_ExpectAEQ(2, CompareDeep(3.1!, 1.1!), 0) + Call Dev_ExpectAEQ(-2, CompareDeep(1.1!, 3.1!), 0) + Call Dev_ExpectEQ(2, CompareDeep("3", "1")) + Call Dev_ExpectEQ(-2, CompareDeep("1", "3")) + + Call Dev_NewCase("Basic type cross compare") + Call Dev_ExpectEQ(0, CompareDeep(0, False)) + Call Dev_ExpectEQ(0, CompareDeep(False, 0)) + Call Dev_ExpectEQ(0, CompareDeep(-1, True)) + Call Dev_ExpectEQ(0, CompareDeep(True, -1)) + Call Dev_ExpectEQ(1, CompareDeep(0, "")) + Call Dev_ExpectEQ(1, CompareDeep("", 0)) + Call Dev_ExpectEQ(0, CompareDeep(0, "0")) + Call Dev_ExpectEQ(0, CompareDeep("0", 0)) + Call Dev_ExpectEQ(0, CompareDeep(1, 1&)) + Call Dev_ExpectEQ(0, CompareDeep(1&, 1)) + Call Dev_ExpectEQ(0, CompareDeep(1, 1#)) + Call Dev_ExpectEQ(0, CompareDeep(1#, 1)) + Call Dev_ExpectAEQ(0, CompareDeep(1, 1!), 1) + Call Dev_ExpectAEQ(0, CompareDeep(1!, 1), 1) + Call Dev_ExpectAEQ(0, CompareDeep(1.1, 1.1!), 1) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CompareDeepObject() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(0, CompareDeep(Nothing, Nothing), "Nothing compare") + + On Error Resume Next + Call CompareDeep(ThisWorkbook, ThisWorkbook.Application) + Call Dev_ExpectError(SYS_ERR_INVALID_OPERATION, "Mismatched type comparison") + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(0, CompareDeep(Me, Me), "Compare equal object pointers") + Call Dev_ExpectEQ(1, CompareDeep(Me, New s_ExVBA), "Compare different object pointers") + + Call Dev_NewCase("Valid object compare") + Dim obj1 As New TestCustomObject: obj1.data_ = 2 + Dim obj2 As New TestCustomObject: obj2.data_ = 1 + Call Dev_ExpectEQ(1, CompareDeep(obj1, obj2)) + obj2.data_ = 2 + Call Dev_ExpectEQ(0, CompareDeep(obj1, obj2)) + obj2.data_ = 3 + Call Dev_ExpectEQ(-1, CompareDeep(obj1, obj2)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CompareDeepCollection() + On Error GoTo PROPAGATE_ERROR + + Dim colEmpty As New Collection + Dim colEmpty2 As New Collection + Dim col1 As New Collection: Call col1.Add(1): Call col1.Add(2) + Dim col2 As New Collection: Call col2.Add(2): Call col2.Add(1) + Dim col3 As New Collection: Call col3.Add(1): Call col3.Add(2) + Dim col4 As New Collection: Call col4.Add(1): Call col4.Add(2): Call col4.Add(3) + + Call Dev_ExpectEQ(0, CompareDeep(colEmpty, colEmpty2), "Empty comparison") + Call Dev_ExpectEQ(0, CompareDeep(colEmpty, colEmpty), "Empty self comparison") + + Call Dev_NewCase("Simple collection comparison") + Call Dev_ExpectEQ(0, CompareDeep(col1, col1)) + Call Dev_ExpectEQ(0, CompareDeep(col1, col3)) + Call Dev_ExpectNE(0, CompareDeep(col1, col2)) + Call Dev_ExpectNE(0, CompareDeep(col1, col4)) + + Call col1.Add("1") + Call col3.Add(1) + Call Dev_ExpectEQ(0, CompareDeep(col1, col3), "Mixed comparison") + + Dim obj1 As New TestCustomObject: obj1.data_ = 1 + Dim obj2 As New TestCustomObject: obj2.data_ = 1 + Call col1.Add(obj1) + Call col3.Add(obj2) + Call Dev_ExpectEQ(0, CompareDeep(col1, col3), "Object collection comparison") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CompareDeepDictionary() + On Error GoTo PROPAGATE_ERROR + + Dim dictEmpty As New Scripting.Dictionary + Dim dictEmpty2 As New Scripting.Dictionary + Dim d1 As New Scripting.Dictionary: Call d1.Add(1, 1): Call d1.Add(2, 2) + Dim d2 As New Scripting.Dictionary: Call d2.Add(1, 2): Call d2.Add(2, 1) + Dim d3 As New Scripting.Dictionary: Call d3.Add(1, 1): Call d3.Add(2, 2) + Dim d4 As New Scripting.Dictionary: Call d4.Add("1", 1): Call d4.Add("2", 2) + Dim d5 As New Scripting.Dictionary: Call d5.Add(1, 1): Call d5.Add(2, 2): Call d5.Add(3, 3) + + Call Dev_ExpectEQ(0, CompareDeep(dictEmpty, dictEmpty2), "Empty comparison") + Call Dev_ExpectEQ(0, CompareDeep(dictEmpty, dictEmpty), "Empty self comparison") + + Call Dev_NewCase("Dictionary compare") + Call Dev_ExpectEQ(0, CompareDeep(d1, d1)) + Call Dev_ExpectEQ(0, CompareDeep(d1, d3)) + Call Dev_ExpectNE(0, CompareDeep(d1, d2)) + Call Dev_ExpectNE(0, CompareDeep(d1, d4)) + Call Dev_ExpectNE(0, CompareDeep(d1, d5)) + + Call d1.Add(4, "1") + Call d3.Add(4, 1) + Call Dev_ExpectEQ(0, CompareDeep(d1, d3), "Mixed comparison") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CompareDeepArray() + On Error GoTo PROPAGATE_ERROR + + Dim unallocArr() As Variant + Dim arr1 As Variant: arr1 = Array(1, 2, 3) + Dim arr2 As Variant: arr2 = Array(2, 1, 3) + Dim arr3 As Variant: arr3 = Array(1, 2, 3) + Dim arr4 As Variant: arr4 = Array("1", 2, 3) + Dim arr5 As Variant: arr5 = Array("1", 2, 3, 4) + + Call Dev_ExpectEQ(0, CompareDeep(unallocArr, unallocArr), "Unallocated comparison") + + Call Dev_NewCase("Array compare") + Call Dev_ExpectEQ(0, CompareDeep(arr1, arr1)) + Call Dev_ExpectEQ(0, CompareDeep(arr1, arr3)) + Call Dev_ExpectNE(0, CompareDeep(arr1, arr2)) + Call Dev_ExpectEQ(0, CompareDeep(arr1, arr4)) + Call Dev_ExpectNE(0, CompareDeep(arr1, arr5)) + + Call Dev_NewCase("Compound array compare") + Dim arr6 As Variant: arr6 = Array(Array(1), Array(2, 3), Array("3")) + Call Dev_ExpectEQ(0, CompareDeep(arr6, arr6)) + Call Dev_ExpectNE(0, CompareDeep(arr1, arr6)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ExtractTimestamp() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(0, ExtractTimestamp(""), "Empty string") + Call Dev_ExpectEQ(0, ExtractTimestamp("INVALID"), "Invalid text") + Call Dev_ExpectEQ(0, ExtractTimestamp("2020-13-99"), "Invalid timestamp") + Call Dev_ExpectEQ(DateSerial(2020, 12, 30), ExtractTimestamp("2020-12-30"), "Short date") + Call Dev_ExpectEQ(0, ExtractTimestamp("2020-12-30: TestMsg"), "Short date and Msg") + + Call ExtractTimestamp("2020-13-99") + Call Dev_ExpectNoError("No error polution") + + Call Dev_NewCase("Full time date") + Call Dev_ExpectEQ(CDbl(VBA.TimeValue("11:59:59") + VBA.DateValue("2020-12-30")), ExtractTimestamp("2020-12-30 11:59:59")) + + Call Dev_NewCase("Full time date and Msg") + Call Dev_ExpectEQ(CDbl(VBA.TimeValue("11:59:59") + VBA.DateValue("2020-12-30")), ExtractTimestamp("2020-12-30 11:59:59: TestMsg")) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_TrimTimestamp() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(vbNullString, TrimTimestamp(""), "Empty string") + Call Dev_ExpectEQ("INVALID", TrimTimestamp("INVALID"), "Invalid text") + Call Dev_ExpectEQ("2020-13-99", TrimTimestamp("2020-13-99"), "Invalid timestamp") + Call Dev_ExpectEQ(vbNullString, TrimTimestamp("2020-12-30"), "Short date") + Call Dev_ExpectEQ("2020-12-30: TestMsg", TrimTimestamp("2020-12-30: TestMsg"), "Short date and Msg") + + Call Dev_NewCase("Full time date") + Call Dev_ExpectEQ(vbNullString, TrimTimestamp("2020-12-30 11:59:59")) + + Call Dev_NewCase("Full time date and Msg") + Call Dev_ExpectEQ("TestMsg", TrimTimestamp("2020-12-30 11:59:59: TestMsg")) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Fmt() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(vbNullString, Fmt(vbNullString), "Empty string") + Call Dev_ExpectEQ("{1}", Fmt("{1}"), "Missing arg") + Call Dev_ExpectEQ("{0}", Fmt("{0}", 1337), "Invalid indexing") + Call Dev_ExpectEQ("{2}", Fmt("{2}", 1337), "Missing index marker") + Call Dev_ExpectEQ("1337 12 1337", Fmt("{1} {2} {1}", 1337, 12), "Miltiple markers") + Call Dev_ExpectEQ("1337 12 1337 {3}", Fmt("{1} {2} {1} {3}", 1337, 12), "Partially valid") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_PrintBasic() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ("", PrettyPrint(vbNullString), "Empty string") + Call Dev_ExpectEQ("[Nothing]", PrettyPrint(Nothing), "Nothing") + Call Dev_ExpectEQ("[Null]", PrettyPrint(Null), "Not initialized variant") + Call Dev_ExpectEQ("abc", PrettyPrint("abc"), "String") + Call Dev_ExpectEQ("0", PrettyPrint(0), "Ineger") + Call Dev_ExpectEQ(CStr(3.14), PrettyPrint(3.14), "Float") + Call Dev_ExpectEQ("True", PrettyPrint(True), "Boolean") + + Dim vNotInit As Variant + Call Dev_ExpectEQ("[Empty]", PrettyPrint(vNotInit), "Not initialized variant") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_PrintObject() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ("[Workbook]", PrettyPrint(ThisWorkbook), "Non-stringable type") + Call Dev_ExpectEQ("Microsoft Excel", PrettyPrint(ThisWorkbook.Application), "Stringable type") + + Dim strObject As New TestCustomObject: strObject.data_ = 2 + Call Dev_ExpectEQ("2", PrettyPrint(strObject), "Custom object provides valid callback") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_PrintCollection() + On Error GoTo PROPAGATE_ERROR + + Dim testCol As New Collection + Call Dev_ExpectEQ("$Collection []", PrettyPrint(testCol), "Empty collection") + + Call Dev_NewCase("Basic elements") + Call testCol.Add(1): Call testCol.Add(2) + Dim sResult$ + sResult = "$Collection [" & vbNewLine & _ + Indent(1) & "1," & vbNewLine & _ + Indent(1) & "2" & vbNewLine & _ + "]" + Call Dev_ExpectEQ(sResult, PrettyPrint(testCol)) + + Call Dev_NewCase("Compound elements") + Dim intCol As New Collection: Call intCol.Add(3) + Call testCol.Add(intCol) + sResult = "$Collection [" & vbNewLine & _ + Indent(1) & "1," & vbNewLine & _ + Indent(1) & "2," & vbNewLine & _ + Indent(1) & "$Collection [" & vbNewLine & _ + Indent(2) & "3" & vbNewLine & _ + Indent(1) & "]" & vbNewLine & _ + "]" + Call Dev_ExpectEQ(sResult, PrettyPrint(testCol)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_PrintDictionary() + On Error GoTo PROPAGATE_ERROR + + Dim testDict As New Scripting.Dictionary + Call Dev_ExpectEQ("$Dictionary []", PrettyPrint(testDict), "Empty dictionary") + + Call Dev_NewCase("Basic elements") + Call testDict.Add(1, "a"): Call testDict.Add(2, "b") + Dim sResult$ + sResult = "$Dictionary [" & vbNewLine & _ + Indent(1) & "1: a," & vbNewLine & _ + Indent(1) & "2: b" & vbNewLine & _ + "]" + Call Dev_ExpectEQ(sResult, PrettyPrint(testDict)) + + Call Dev_NewCase("Compound elements") + Dim intDict As New Scripting.Dictionary: Call intDict.Add(3, "c") + Call testDict.Add(3, intDict) + sResult = "$Dictionary [" & vbNewLine & _ + Indent(1) & "1: a," & vbNewLine & _ + Indent(1) & "2: b," & vbNewLine & _ + Indent(1) & "3: $Dictionary [" & vbNewLine & _ + Indent(2) & "3: c" & vbNewLine & _ + Indent(1) & "]" & vbNewLine & _ + "]" + Call Dev_ExpectEQ(sResult, PrettyPrint(testDict)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_PrintArray() + On Error GoTo PROPAGATE_ERROR + + Dim testArr() As Variant + Call Dev_ExpectEQ("$Array []", PrettyPrint(testArr), "Unallocated array") + + Call Dev_NewCase("Uninit array") + ReDim testArr(1 To 2) + Dim sResult$ + sResult = "$Array [" & vbNewLine & _ + Indent(1) & "[Empty]," & vbNewLine & _ + Indent(1) & "[Empty]" & vbNewLine & _ + "]" + Call Dev_ExpectEQ(sResult, PrettyPrint(testArr)) + + Call Dev_NewCase("Basic elements") + testArr(1) = 1 + testArr(2) = 2 + sResult = "$Array [" & vbNewLine & _ + Indent(1) & "1," & vbNewLine & _ + Indent(1) & "2" & vbNewLine & _ + "]" + Call Dev_ExpectEQ(sResult, PrettyPrint(testArr)) + + Call Dev_NewCase("Compound elements") + + Set testArr(2) = New Collection + sResult = "$Array [" & vbNewLine & _ + Indent(1) & "1," & vbNewLine & _ + Indent(1) & "$Collection []" & vbNewLine & _ + "]" + Call Dev_ExpectEQ(sResult, PrettyPrint(testArr)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CommonPrefixLength() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty") + Call Dev_ExpectEQ(0, CommonPrefixLength("", "")) + Call Dev_ExpectEQ(0, CommonPrefixLength("abc", "")) + Call Dev_ExpectEQ(0, CommonPrefixLength("", "abc")) + + Call Dev_NewCase("Valid prefix") + Call Dev_ExpectEQ(3, CommonPrefixLength("123", "123")) + Call Dev_ExpectEQ(3, CommonPrefixLength("123", "1234")) + Call Dev_ExpectEQ(3, CommonPrefixLength("1234", "123")) + Call Dev_ExpectEQ(11, CommonPrefixLength("C:\Windows\Test", "C:\Windows\Process")) + + Call Dev_NewCase("Compare mode") + Call Dev_ExpectEQ(0, CommonPrefixLength("ABC", "abc", vbBinaryCompare)) + Call Dev_ExpectEQ(3, CommonPrefixLength("ABC", "abc", vbTextCompare)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_DictionaryAbsorbShallow() + On Error GoTo PROPAGATE_ERROR + + Dim iSource As New Scripting.Dictionary + Dim iDestination As New Scripting.Dictionary + iSource.Item(1) = 1337 + iSource.Item(42) = 43 + iDestination.Item(1) = 42 + Set iSource.Item(2) = CColl(1, 2, 3) + + Call DictionaryAbsorbShallow(iDestination, iSource) + Call Dev_AssertEQ(3, iDestination.Count, "Count elements") + Call Dev_ExpectEQ(43, iDestination(42), "Transfer basic values") + Call Dev_ExpectEQ(42, iDestination(1), "Do not overwrite common keys") + Call Dev_ExpectEQ(CColl(1, 2, 3), iDestination(2), "Transfer complex elements") + + Call Dev_NewCase("Shallow copy") + iSource.Item(42) = 44 + Call iSource.Item(2).Add(4) + Call Dev_ExpectEQ(43, iDestination(42)) + Call Dev_ExpectEQ(CColl(1, 2, 3, 4), iDestination(2)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +' ===== +Private Function TestForwardParams(ParamArray params() As Variant) As Variant + Dim val As Variant: val = params + TestForwardParams = FixForwardedParams(val) +End Function diff --git a/src/test/s_ExWinAPI.cls b/src/test/s_ExWinAPI.cls new file mode 100644 index 0000000..0cc3da7 --- /dev/null +++ b/src/test/s_ExWinAPI.cls @@ -0,0 +1,341 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_ExWinAPI" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' TODO: +' Public Function ForEachFileRecursive(sTargetFolder$, oCallback As Object, sFuncName$) +' Public Function UnzipFile(sTargetFile$, sDestinationFolder$) As Boolean +' Public Function ZipFolder(sTargetFolder$, sDestinationFile$) As Boolean +' Public Function ListFilesIn(sTargetFolder$, Optional sMask$ = "*.*") As Collection + +Private fso_ As Scripting.FileSystemObject + +Public Function Setup() + ' Mandatory setup function + Set fso_ = New Scripting.FileSystemObject + Call EnsureFolderExists(Dev_GetTestFolder) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call fso_.DeleteFolder(Dev_GetTestFolder) +End Function + +Public Function t_WindowsTempFolder() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(Environ("TEMP"), WindowsTempFolder, "Temp folder") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Clipboard() + On Error GoTo PROPAGATE_ERROR + + Dim sText$: sText = "test" & vbNewLine & "multiline" + Call AddToClipboard(sText) + Call Dev_ExpectEQ(sText, RetrieveFromClipboard, "Multiline text") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_EnsureFolderExists() + On Error GoTo PROPAGATE_ERROR + + On Error Resume Next + Call EnsureFolderExists("") + Call Dev_ExpectNoError("Empty input") + On Error GoTo PROPAGATE_ERROR + + On Error Resume Next + Call EnsureFolderExists("invalid input?") + Call Dev_ExpectNoError("Invalid input") + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Single folder") + Dim sFolder1$: sFolder1 = Dev_GetTestFolder & "\1" + Call EnsureFolderExists(sFolder1) + Call Dev_ExpectTrue(fso_.FolderExists(sFolder1)) + Call fso_.DeleteFolder(sFolder1) + + Call Dev_NewCase("Custom fso") + Call EnsureFolderExists(sFolder1, fso_) + Call Dev_ExpectTrue(fso_.FolderExists(sFolder1)) + Call fso_.DeleteFolder(sFolder1) + + Call Dev_NewCase("Chain folders") + Dim sFolder2$: sFolder2 = sFolder1 & "\2" + Call EnsureFolderExists(sFolder2) + Call Dev_ExpectTrue(fso_.FolderExists(sFolder1)) + Call Dev_ExpectTrue(fso_.FolderExists(sFolder2)) + Call fso_.DeleteFolder(sFolder1) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CreateTextFileUTF16() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectFalse(CreateTextFileUTF16(""), "Empty input") + + Call Dev_NewCase("Valid create file") + Dim sFile$: sFile = Dev_GetTestFolder & "\" & "test.txt" + Call Dev_ExpectTrue(CreateTextFileUTF16(sFile)) + Call Dev_ExpectTrue(fso_.FileExists(sFile), "Actually create the file") + Dim fs As Scripting.TextStream: Set fs = fso_.OpenTextFile(sFile, ForAppending, Format:=TristateTrue) + Call fs.WriteLine("test123") + Call fs.Close + + Call Dev_NewCase("Do not overwrite") + Call Dev_ExpectFalse(CreateTextFileUTF16(sFile, bOverwrite:=False)) + Set fs = fso_.OpenTextFile(sFile, ForReading, Format:=TristateTrue) + Dim sText$: sText = fs.ReadLine + Call fs.Close + Call Dev_ExpectEQ("test123", sText, "Do not overwrite file") + + Call Dev_NewCase("Overwrite") + Call Dev_ExpectTrue(CreateTextFileUTF16(sFile, bOverwrite:=True)) + Set fs = fso_.OpenTextFile(sFile, ForReading, Format:=TristateTrue) + Call Dev_ExpectTrue(fs.AtEndOfStream, "Overwrite contents") + Call fs.Close + + Call Dev_NewCase("Cannot overwrite") + Set fs = fso_.OpenTextFile(sFile, ForWriting) + Call Dev_ExpectFalse(CreateTextFileUTF16(sFile, bOverwrite:=True)) + Call fs.Close + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_AppendTextToFileUTF16() + On Error GoTo PROPAGATE_ERROR + + Dim sFile$: sFile = Dev_GetTestFolder & "\" & "test.txt" + Dim sMsg1$: sMsg1 = "testMsg1" + Dim sMsg2$: sMsg2 = "testMsg2" + + Call Dev_ExpectFalse(AppendTextToFileUTF16("", ""), "Empty input") + Call Dev_ExpectFalse(AppendTextToFileUTF16("", sMsg1), "Empty output file") + Call Dev_ExpectFalse(AppendTextToFileUTF16(sFile, sMsg1), "Non-existent output file") + + Call Dev_NewCase("Append text to empty file") + Call CreateTextFileUTF16(sFile) + Call Dev_ExpectTrue(AppendTextToFileUTF16(sFile, sMsg1), "Append text") + Dim fs As Scripting.TextStream: Set fs = fso_.OpenTextFile(sFile, ForReading, Format:=TristateTrue) + Dim sText$: sText = fs.ReadAll + Call fs.Close + Call Dev_ExpectEQ(sMsg1 & vbNewLine, sText, "Confirm message") + + Call Dev_NewCase("Append text to file") + Call Dev_ExpectTrue(AppendTextToFileUTF16(sFile, sMsg2), "Append text") + Set fs = fso_.OpenTextFile(sFile, ForReading, Format:=TristateTrue) + sText = fs.ReadAll + Call fs.Close + Call Dev_ExpectEQ(sMsg1 & vbNewLine & sMsg2 & vbNewLine, sText, "Confirm message") + + Call Dev_NewCase("Cannot append") + Set fs = fso_.OpenTextFile(sFile, ForAppending, Format:=TristateTrue) + Call Dev_ExpectFalse(AppendTextToFileUTF16(sFile, sMsg2)) + Call fs.Close + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ReadTextFromFileUTF16() + On Error GoTo PROPAGATE_ERROR + + Dim sFile$: sFile = Dev_GetTestFolder & "\" & "test.txt" + Dim sMsg$: sMsg = "testMsg" + Dim sResult$: sResult = "test" + + Call Dev_NewCase("Empty input") + Call Dev_ExpectFalse(ReadTextFromFileUTF16("", sResult)) + Call Dev_ExpectEQ("test", sResult, "Do not overwrite output on fail") + + Call Dev_NewCase("Non-existent output file") + Call Dev_ExpectFalse(ReadTextFromFileUTF16(sFile, sResult)) + Call Dev_ExpectEQ("test", sResult, "Do not overwrite output on fail") + + Call CreateTextFileUTF16(sFile) + Dim fs As Scripting.TextStream: Set fs = fso_.OpenTextFile(sFile, ForAppending, Format:=TristateTrue) + Call fs.Write(sMsg) + Call fs.Close + + Call Dev_NewCase("Valid read text") + Call Dev_ExpectTrue(ReadTextFromFileUTF16(sFile, sResult)) + Call Dev_ExpectEQ(sMsg, sResult) + + Call Dev_NewCase("Read from occupied file") + Set fs = fso_.OpenTextFile(sFile, ForAppending, Format:=TristateTrue) + sResult = "" + Call Dev_ExpectTrue(ReadTextFromFileUTF16(sFile, sResult)) + Call Dev_ExpectEQ(sMsg, sResult) + Call fs.Close + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CopyFileOrFolder() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectFalse(CopyFileOrFolder("", ""), "Empty input") + + Dim sFolder1$: sFolder1 = Dev_GetTestFolder & "\1" + Dim sFolder2$: sFolder2 = Dev_GetTestFolder & "\2" + Dim sFolder3$: sFolder3 = Dev_GetTestFolder & "\3" + Dim sFile1$: sFile1 = Dev_GetTestFolder & "\" & "test1.txt" + Dim sFile2$: sFile2 = Dev_GetTestFolder & "\" & "test2.txt" + + Call Dev_ExpectFalse(CopyFileOrFolder("", sFile1), "Empty source") + + Call fso_.CreateTextFile(sFile1).Close + Call Dev_ExpectFalse(CopyFileOrFolder(sFile1, ""), "Empty destination") + + Call fso_.CreateFolder(sFolder1) + Call Dev_ExpectFalse(CopyFileOrFolder(sFile1, sFolder1), "Copy file as folder") + + Call Dev_NewCase("Rename file") + Call Dev_ExpectTrue(CopyFileOrFolder(sFile1, sFile2)) + Call Dev_ExpectTrue(fso_.FileExists(sFile1), "Do not delete initial file") + Call Dev_ExpectTrue(fso_.FileExists(sFile2), "Create copy") + Call fso_.DeleteFile(sFile2) + + Call Dev_NewCase("Custom fso") + Call Dev_ExpectTrue(CopyFileOrFolder(sFile1, sFile2, fso_)) + Call Dev_ExpectTrue(fso_.FileExists(sFile1), "Do not delete initial file") + Call Dev_ExpectTrue(fso_.FileExists(sFile2), "Create copy") + + Call Dev_NewCase("Replace existing file") + Dim sMsg$: sMsg = "test1" + Call AppendTextToFileUTF16(sFile1, sMsg) + Call Dev_ExpectTrue(CopyFileOrFolder(sFile1, sFile2, fso_)) + Dim sResult$: Call ReadTextFromFileUTF16(sFile2, sResult) + Call Dev_ExpectEQ(sMsg & vbNewLine, sResult) + + Call Dev_NewCase("Copy file to new folder") + Dim sNewFile1$: sNewFile1 = sFolder1 & "\" & "test11.txt" + Call Dev_ExpectTrue(CopyFileOrFolder(sFile1, sNewFile1)) + Call Dev_ExpectTrue(fso_.FileExists(sFile1), "Do not delete initial file") + Call Dev_ExpectTrue(fso_.FileExists(sNewFile1), "Create copy") + + Call Dev_NewCase("Copy file to folder") + Call fso_.CreateFolder(sFolder2) + Dim sNewFile2$: sNewFile2 = sFolder2 & "\" & "test12.txt" + Call Dev_ExpectTrue(CopyFileOrFolder(sFile1, sNewFile2)) + Call Dev_ExpectTrue(fso_.FileExists(sFile1), "Do not delete initial file") + Call Dev_ExpectTrue(fso_.FileExists(sNewFile2), "Create copy") + + Call Dev_NewCase("Copy folder to new folder") + Call Dev_ExpectTrue(CopyFileOrFolder(sFolder1, sFolder3)) + Call Dev_ExpectTrue(fso_.FolderExists(sFolder1), "Do not delete initial folder") + Call Dev_ExpectTrue(fso_.FolderExists(sFolder3), "Create destination folder") + Call Dev_ExpectTrue(fso_.FileExists(sFolder3 & "\" & "test11.txt"), "Copy contained file") + + Call Dev_NewCase("Copy folder to folder") + Call Dev_ExpectTrue(CopyFileOrFolder(sFolder2, sFolder3)) + Call Dev_ExpectTrue(fso_.FolderExists(sFolder2), "Do not delete initial folder") + Call Dev_ExpectTrue(fso_.FileExists(sFolder3 & "\" & "test11.txt"), "Keep existing contents") + Call Dev_ExpectTrue(fso_.FileExists(sFolder3 & "\" & "test12.txt"), "Copy contained file") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_MoveFileOrFolder() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectFalse(MoveFileOrFolder("", ""), "Empty input") + + Dim sFolder1$: sFolder1 = Dev_GetTestFolder & "\1" + Dim sFolder2$: sFolder2 = Dev_GetTestFolder & "\2" + Dim sFolder3$: sFolder3 = Dev_GetTestFolder & "\3" + Dim sFile1$: sFile1 = Dev_GetTestFolder & "\" & "test1.txt" + Dim sFile2$: sFile2 = Dev_GetTestFolder & "\" & "test2.txt" + + Call Dev_ExpectFalse(MoveFileOrFolder("", sFile1), "Empty source") + + Call Dev_NewCase("Empty destination") + Call CreateTextFileUTF16(sFile1) + Call Dev_ExpectFalse(MoveFileOrFolder(sFile1, "")) + Call Dev_ExpectTrue(fso_.FileExists(sFile1), "Do not delete source if move failed") + + Call Dev_NewCase("Move file as folder") + Call fso_.CreateFolder(sFolder1) + Call Dev_ExpectFalse(MoveFileOrFolder(sFile1, sFolder1)) + Call Dev_ExpectTrue(fso_.FileExists(sFile1), "Do not delete source if move failed") + + Call Dev_NewCase("Move self") + Call Dev_ExpectFalse(MoveFileOrFolder(sFile1, sFile1)) + Call Dev_ExpectTrue(fso_.FileExists(sFile1), "Do not delete source if move failed") + + Call Dev_NewCase("Rename file") + Call Dev_ExpectTrue(MoveFileOrFolder(sFile1, sFile2)) + Call Dev_ExpectFalse(fso_.FileExists(sFile1), "Delete initial file") + Call Dev_ExpectTrue(fso_.FileExists(sFile2), "Renamed file exists") + + Call Dev_NewCase("Custom fso") + Call Dev_ExpectTrue(MoveFileOrFolder(sFile2, sFile1, fso_)) + Call Dev_ExpectFalse(fso_.FileExists(sFile2), "Delete initial file") + Call Dev_ExpectTrue(fso_.FileExists(sFile1), "Renamed file exists") + + Call Dev_NewCase("Replace existing file") + Call CreateTextFileUTF16(sFile2) + Dim sMsg$: sMsg = "test1" + Call AppendTextToFileUTF16(sFile2, sMsg) + Call Dev_ExpectTrue(MoveFileOrFolder(sFile2, sFile1, fso_)) + Call Dev_ExpectFalse(fso_.FileExists(sFile2), "Delete initial file") + Call Dev_ExpectTrue(fso_.FileExists(sFile1), "Renamed file exists") + Dim sResult$: Call ReadTextFromFileUTF16(sFile1, sResult) + Call Dev_ExpectEQ(sMsg & vbNewLine, sResult, "Replace content") + + Call Dev_NewCase("Move file to new folder") + Dim sNewFile1$: sNewFile1 = sFolder1 & "\" & "test11.txt" + Call Dev_ExpectTrue(MoveFileOrFolder(sFile1, sNewFile1)) + Call Dev_ExpectFalse(fso_.FileExists(sFile1), "Delete initial file") + Call Dev_ExpectTrue(fso_.FileExists(sNewFile1), "Moved file exists") + + Call Dev_NewCase("Move file to folder") + Call fso_.CreateFolder(sFolder2) + Dim sNewFile2$: sNewFile2 = sFolder2 & "\" & "test12.txt" + Call Dev_ExpectTrue(MoveFileOrFolder(sNewFile1, sNewFile2)) + Call Dev_ExpectFalse(fso_.FileExists(sNewFile1), "Delete initial file") + Call Dev_ExpectTrue(fso_.FileExists(sNewFile2), "Moved file exists") + + Call Dev_NewCase("Move folder to new folder") + Call Dev_ExpectTrue(MoveFileOrFolder(sFolder2, sFolder3)) + Call Dev_ExpectFalse(fso_.FolderExists(sFolder2), "Delete initial folder") + Call Dev_ExpectTrue(fso_.FolderExists(sFolder3), "Moved folder exists") + Call Dev_ExpectTrue(fso_.FileExists(sFolder3 & "\" & "test12.txt"), "Move contained file") + + Call Dev_NewCase("Move folder to folder") + Call CreateTextFileUTF16(sFile1) + Call Dev_ExpectTrue(MoveFileOrFolder(sFolder3, sFolder1)) + Call Dev_ExpectFalse(fso_.FolderExists(sFolder3), "Delete initial folder") + Call Dev_ExpectTrue(fso_.FileExists(sFile1), "Keep existing contents") + Call Dev_ExpectTrue(fso_.FileExists(sFolder1 & "\" & "test12.txt"), "Move contained file") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + diff --git a/src/test/s_Factorizator.cls b/src/test/s_Factorizator.cls new file mode 100644 index 0000000..555ccb3 --- /dev/null +++ b/src/test/s_Factorizator.cls @@ -0,0 +1,68 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_Factorizator" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Test suite for Factorizator ======= +Option Explicit + +Private factors_ As CDS_Factorizator + +Public Function Setup() + ' Mandatory setup function + Set factors_ = New CDS_Factorizator +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_Access() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty input") + Call factors_.Init(0) + Call Dev_ExpectEQ(CSet(), factors_.Values) + Call Dev_ExpectEQ(Empty, factors_.FactorFor(1337)) + Call Dev_ExpectEQ(0, factors_.FactorValueFor(1337)) + + Call Dev_NewCase("Access valid items") + Call Dev_AssertTrue(factors_.Insert(1337, 1)) + Call Dev_AssertFalse(factors_.Insert(1337, 3), "Duplicate inserts") + Call Dev_AssertTrue(factors_.Insert(42, 2)) + Dim iVals As New Scripting.Dictionary + iVals(1337) = 1 + iVals(42) = 2 + Call Dev_ExpectEQ(iVals, factors_.Values) + Call Dev_ExpectEQ(1337, factors_.FactorFor(1337)) + Call Dev_ExpectEQ(1, factors_.FactorValueFor(1337)) + Call Dev_ExpectEQ(42, factors_.FactorFor(42)) + Call Dev_ExpectEQ(2, factors_.FactorValueFor(42)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Factorization() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Maximum gap") + Call factors_.Init(10) + Call factors_.Insert(1, 1) + Call factors_.Insert(2, 11) + Call Dev_ExpectEQ(2, factors_.FactorFor(1)) + Call Dev_ExpectEQ(2, factors_.FactorFor(2)) + + Call Dev_NewCase("Minimal increment") + Call factors_.Insert(3, 11 + 0.001) + Call Dev_ExpectEQ(3, factors_.FactorFor(3)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_Graph.cls b/src/test/s_Graph.cls new file mode 100644 index 0000000..bf916bf --- /dev/null +++ b/src/test/s_Graph.cls @@ -0,0 +1,414 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_Graph" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Test suite for Graph data structure ======= +Option Explicit + +Private graph_ As CDS_Graph + +Public Function Setup() + ' Mandatory setup function + Set graph_ = New CDS_Graph +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_AddNode() + On Error GoTo PROPAGATE_ERROR + + Call graph_.AddNode(1337) + Call Dev_ExpectEQ(1, graph_.Size, "Valid add") + Call Dev_ExpectTrue(graph_.HasNode(1337)) + Call Dev_ExpectFalse(graph_.HasNode("1337"), "Do not use type conversion for node comparisons") + + Call graph_.AddNode(1337) + Call Dev_ExpectEQ(1, graph_.Size, "Duplicate add") + + Call Dev_NewCase("Different node data types") + Call graph_.AddNode("abc") + Call Dev_ExpectEQ(2, graph_.Size) + Call Dev_ExpectEQ(CColl(1337, "abc"), graph_.Nodes) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_AddEdge() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid edge") + Call graph_.AddNode(1) + Call graph_.AddNode(2) + Dim iEdge As CDS_Edge: Set iEdge = graph_.AddEdge(1, 2) + Call Dev_AssertNotNothing(iEdge) + Call Dev_ExpectTrue(graph_.HasEdge(1, 2)) + Call Dev_ExpectEQ(1, iEdge.source_) + Call Dev_ExpectEQ(2, iEdge.dest_) + + Call Dev_NewCase("Duplicate edge") + Call Dev_ExpectNothing(graph_.AddEdge(1, 2)) + + Call Dev_NewCase("Self edge") + Set iEdge = graph_.AddEdge(1, 1) + Call Dev_AssertNotNothing(iEdge) + Call Dev_ExpectTrue(graph_.HasEdge(1, 1)) + Call Dev_ExpectEQ(1, iEdge.source_) + Call Dev_ExpectEQ(1, iEdge.dest_) + + Call Dev_NewCase("Add missing nodes") + Set iEdge = graph_.AddEdge(3, 4) + Call Dev_AssertNotNothing(iEdge) + Call Dev_ExpectTrue(graph_.HasEdge(3, 4)) + Call Dev_ExpectEQ(3, iEdge.source_) + Call Dev_ExpectEQ(4, iEdge.dest_) + Call Dev_ExpectEQ(4, graph_.Size, "Check node count") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Clear() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty graph") + On Error Resume Next + Call graph_.Clear + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + Call Dev_ExpectEQ(0, graph_.Size) + + Call Dev_NewCase("Valid graph") + Call graph_.AddNode(1) + Call graph_.AddEdge(2, 3) + Call Dev_ExpectEQ(3, graph_.Size) + Call Dev_ExpectTrue(graph_.HasEdge(2, 3)) + Call graph_.Clear + Call Dev_ExpectEQ(0, graph_.Size) + Call Dev_ExpectFalse(graph_.HasEdge(2, 3)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_FilterInternalEdges() + On Error GoTo PROPAGATE_ERROR + + Dim iEdges As New Collection + Call Dev_ExpectEQ(iEdges, graph_.FilterInternalEdges(CSet()), "Empty graph") + + Call Dev_NewCase("No edges") + Call graph_.AddNode(1): Call graph_.AddNode(2) + Call Dev_ExpectEQ(iEdges, graph_.FilterInternalEdges(CSet()), "Empty filter") + Call Dev_ExpectEQ(iEdges, graph_.FilterInternalEdges(CSet(3, 4)), "Invalid nodes") + Call Dev_ExpectEQ(iEdges, graph_.FilterInternalEdges(CSet(1, 2)), "No edges") + + Call Dev_NewCase("Valid filter") + Dim edge1 As CDS_Edge: Set edge1 = graph_.AddEdge(1, 2) + Dim edge2 As CDS_Edge: Set edge2 = graph_.AddEdge(1, 3) + Call Dev_ExpectEQ(iEdges, graph_.FilterInternalEdges(CSet(2)), "Filter end") + Call Dev_ExpectEQ(iEdges, graph_.FilterInternalEdges(CSet(1)), "Filter start") + Call iEdges.Add(edge1.Clone) + Call Dev_ExpectEQ(iEdges, graph_.FilterInternalEdges(CSet(1, 2)), "Filter internal") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_StrongComponents() + On Error GoTo PROPAGATE_ERROR + + Dim iProcessor As New API_StrongComponents + Dim iComponents As New Collection + Call Dev_ExpectEQ(iComponents, iProcessor.GetComponents(graph_), "Empty graph") + + Call Dev_NewCase("No edges") + Call graph_.AddNode(1): Call graph_.AddNode(2) + Call Dev_ExpectEQ(iComponents, iProcessor.GetComponents(graph_)) + + Call Dev_NewCase("Self edge") + Set iComponents = CColl(CSet(1)) + Call graph_.AddEdge(1, 1) + Call Dev_ExpectEQ(iComponents, iProcessor.GetComponents(graph_)) + + Call Dev_NewCase("Valid strong components") + Set iComponents = CColl(CSet(2, 3, 4), CSet(1)) + Call graph_.AddEdge(1, 2) + Call graph_.AddEdge(2, 3) + Call graph_.AddEdge(3, 2) + Call graph_.AddEdge(2, 4) + Call graph_.AddEdge(4, 2) + Call Dev_ExpectEQ(iComponents, iProcessor.GetComponents(graph_)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_LinkedComponents() + On Error GoTo PROPAGATE_ERROR + + Dim iProcessor As New API_LinkedComponents + + Call Dev_NewCase("Empty graph") + Dim iComponents As New Scripting.Dictionary + Call Dev_ExpectEQ(iComponents, iProcessor.GetComponents(graph_)) + Call Dev_ExpectEQ(0, iProcessor.CountComponents) + + Call Dev_NewCase("No edges") + Call graph_.AddNode(1): Call graph_.AddNode(2) + iComponents(1) = 0 + iComponents(2) = 1 + Call Dev_ExpectEQ(iComponents, iProcessor.GetComponents(graph_)) + Call Dev_ExpectEQ(2, iProcessor.CountComponents) + + Call Dev_NewCase("Simple component - straight") + Call graph_.AddEdge(1, 2) + iComponents(1) = 0 + iComponents(2) = 0 + Call Dev_ExpectEQ(iComponents, iProcessor.GetComponents(graph_)) + Call Dev_ExpectEQ(1, iProcessor.CountComponents) + + Call Dev_NewCase("Simple component - reversed") + Set graph_ = New CDS_Graph + Call graph_.AddEdge(2, 1) + iComponents(1) = 0 + iComponents(2) = 0 + Call Dev_ExpectEQ(iComponents, iProcessor.GetComponents(graph_)) + Call Dev_ExpectEQ(1, iProcessor.CountComponents) + + Call Dev_NewCase("Multiple components") + Call graph_.AddEdge(3, 4) + Call graph_.AddEdge(4, 3) + Call graph_.AddEdge(4, 5) + Call graph_.AddNode(6) + iComponents(1) = 0 + iComponents(2) = 0 + iComponents(3) = 1 + iComponents(4) = 1 + iComponents(5) = 1 + iComponents(6) = 2 + Call Dev_ExpectEQ(iComponents, iProcessor.GetComponents(graph_)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Expansions() + On Error GoTo PROPAGATE_ERROR + + Dim iEmpty As New Scripting.Dictionary + Dim iTest As New Scripting.Dictionary + + Call Dev_NewCase("Empty graph") + Call graph_.ExpandOutsOnce(iTest) + Call Dev_ExpectEQ(iEmpty, iTest, "Outs once") + Call graph_.ExpandInsOnce(iTest) + Call Dev_ExpectEQ(iEmpty, iTest, "Ins once") + Call graph_.ExpandBiderctionalOnce(iTest) + Call Dev_ExpectEQ(iEmpty, iTest, "Both once") + Call graph_.ExpandOutputs(iTest) + Call Dev_ExpectEQ(iEmpty, iTest, "Outs all") + Call graph_.ExpandInputs(iTest) + Call Dev_ExpectEQ(iEmpty, iTest, "Ins all") + Call graph_.ExpandBiderctional(iTest) + Call Dev_ExpectEQ(iEmpty, iTest, "Both all") + + Call Dev_NewCase("Empty input") + Call graph_.AddEdge(1, 2): Call graph_.AddEdge(3, 1) + Call graph_.AddEdge(3, 4): Call graph_.AddEdge(5, 6): Call graph_.AddEdge(5, 8) + Call graph_.AddEdge(6, 7): Call graph_.AddEdge(7, 6): Call graph_.AddEdge(9, 3) + Call graph_.ExpandOutsOnce(iTest) + Call Dev_ExpectEQ(iEmpty, iTest, "Outs once") + Call graph_.ExpandInsOnce(iTest) + Call Dev_ExpectEQ(iEmpty, iTest, "Ins once") + Call graph_.ExpandBiderctionalOnce(iTest) + Call Dev_ExpectEQ(iEmpty, iTest, "Both once") + Call graph_.ExpandOutputs(iTest) + Call Dev_ExpectEQ(iEmpty, iTest, "Outs all") + Call graph_.ExpandInputs(iTest) + Call Dev_ExpectEQ(iEmpty, iTest, "Ins all") + Call graph_.ExpandBiderctional(iTest) + Call Dev_ExpectEQ(iEmpty, iTest, "Both all") + + Call Dev_NewCase("Valid expansion") + Set iTest = CSet(1, 5) + Call graph_.ExpandOutsOnce(iTest) + Call Dev_ExpectEQ(CSet(1, 5, 2, 8, 6), iTest, "Outs once") + Set iTest = CSet(1, 5) + Call graph_.ExpandInsOnce(iTest) + Call Dev_ExpectEQ(CSet(1, 5, 3), iTest, "Ins once") + Set iTest = CSet(1, 5) + Call graph_.ExpandBiderctionalOnce(iTest) + Call Dev_ExpectEQ(CSet(1, 5, 2, 8, 6, 3), iTest, "Both once") + Set iTest = CSet(1, 5) + Call graph_.ExpandOutputs(iTest) + Call Dev_ExpectEQ(CSet(1, 5, 2, 8, 6, 7), iTest, "Outs all") + Set iTest = CSet(1, 5) + Call graph_.ExpandInputs(iTest) + Call Dev_ExpectEQ(CSet(1, 5, 3, 9), iTest, "Ins all") + Set iTest = CSet(1, 5) + Call graph_.ExpandBiderctional(iTest) + Call Dev_ExpectEQ(CSet(1, 5, 2, 3, 4, 6, 7, 8, 9), iTest, "Both all") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Ordering() + On Error GoTo PROPAGATE_ERROR + + Dim iProcessor As New API_GraphOrdering: Call iProcessor.Init(graph_) + Dim iEmpty As New Collection + + Call Dev_NewCase("Empty graph") + Call Dev_ExpectEQ(iEmpty, iProcessor.TopologicalOrder) + Call Dev_ExpectEQ(iEmpty, iProcessor.ReverseTopologicalOrder) + Call Dev_ExpectEQ(iEmpty, iProcessor.TopologicalComponentOrder) + Call Dev_ExpectEQ(iEmpty, iProcessor.ReverseTopologicalComponentOrder) + + Call Dev_NewCase("Empty input") + Call graph_.AddEdge(1, 2): Call graph_.AddEdge(3, 1) + Call graph_.AddEdge(3, 4): Call graph_.AddEdge(5, 6): Call graph_.AddEdge(5, 8) + Call graph_.AddEdge(6, 7): Call graph_.AddEdge(7, 6): Call graph_.AddEdge(9, 3) + Call iProcessor.Init(graph_) + + Call Dev_NewCase("Valid ordering") + Call Dev_ExpectTrue(TestTopological(iProcessor.TopologicalOrder)) + Call Dev_ExpectTrue(TestTopological(RevertCollection(iProcessor.ReverseTopologicalOrder))) + Call Dev_ExpectTrue(TestComponent(iProcessor.TopologicalComponentOrder)) + Call Dev_ExpectTrue(TestComponent(RevertCollection(iProcessor.ReverseTopologicalComponentOrder))) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_SortLayers() + On Error GoTo PROPAGATE_ERROR + + Dim iProcessor As New API_GraphOrdering: Call iProcessor.Init(graph_) + Dim iEmpty As New Collection + + Call Dev_ExpectEQ(iEmpty, iProcessor.SortLayers(iEmpty), "Empty graph") + + Call graph_.AddEdge(1, 2): Call graph_.AddEdge(3, 1) + Call graph_.AddEdge(3, 4): Call graph_.AddEdge(5, 6): Call graph_.AddEdge(5, 8) + Call graph_.AddEdge(6, 7): Call graph_.AddEdge(7, 6): Call graph_.AddEdge(9, 3) + Call iProcessor.Init(graph_) + + Call Dev_ExpectEQ(iEmpty, iProcessor.SortLayers(iEmpty), "Empty input") + Call Dev_ExpectEQ(iEmpty, iProcessor.SortLayers(CColl(1337, 42)), "Ignore invalid IDs") + + Call Dev_NewCase("Sorting") + Call Dev_ExpectEQ(CColl(5, 6, 8, 7, 9, 3, 1, 4, 2), iProcessor.SortLayers(CColl(1, 2, 3, 4, 5, 6, 7, 8, 9)), "Full order") + Call Dev_ExpectEQ(CColl(9, 3, 4, 1, 2, 5, 8, 6, 7), iProcessor.SortLayers(CColl(9, 8, 7, 6, 5, 4, 3, 2, 1)), "Reversed order") + Call Dev_ExpectEQ(CColl(5, 6, 8, 7, 9, 3, 1, 4, 2), iProcessor.SortLayers(CColl(1, 2, 3, 4, 5, 6, 7, 8, 9, 1337, 42)), "Mixed invalid") + Call Dev_ExpectEQ(CColl(5, 7, 9, 3, 1), iProcessor.SortLayers(CColl(1, 3, 5, 7, 9)), "Partial order") + Call Dev_ExpectEQ(CColl(9, 1), iProcessor.SortLayers(CColl(1, 9)), "Missing component") + + Call Dev_NewCase("Sibling sorting") + Call graph_.Clear + Call graph_.AddEdge(1, 3): Call graph_.AddEdge(2, 3) + Call graph_.AddEdge(4, 5): Call graph_.AddEdge(3, 5): Call graph_.AddEdge(3, 6) + Call iProcessor.Init(graph_) + Call Dev_ExpectEQ(CColl(1, 2, 4, 3, 5, 6), iProcessor.SortLayers(CColl(1, 2, 3, 4, 5, 6))) + Call graph_.AddEdge(6, 5) + Call iProcessor.Init(graph_) + Call Dev_ExpectEQ(CColl(1, 2, 4, 3, 6, 5), iProcessor.SortLayers(CColl(1, 2, 3, 4, 5, 6))) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_SortDeep() + On Error GoTo PROPAGATE_ERROR + + Dim iProcessor As New API_GraphOrdering: Call iProcessor.Init(graph_) + Dim iEmpty As New Collection + + Call Dev_ExpectEQ(iEmpty, iProcessor.SortDeep(iEmpty), "Empty graph") + + Call graph_.AddEdge(1, 2): Call graph_.AddEdge(3, 1) + Call graph_.AddEdge(3, 4): Call graph_.AddEdge(5, 6): Call graph_.AddEdge(5, 8) + Call graph_.AddEdge(6, 7): Call graph_.AddEdge(7, 6): Call graph_.AddEdge(9, 3) + Call iProcessor.Init(graph_) + + Call Dev_ExpectEQ(iEmpty, iProcessor.SortDeep(iEmpty), "Empty input") + Call Dev_ExpectEQ(iEmpty, iProcessor.SortDeep(CColl(1337, 42)), "Ignore invalid IDs") + + Call Dev_NewCase("Sorting") + Call Dev_ExpectEQ(CColl(5, 6, 7, 8, 9, 3, 1, 2, 4), iProcessor.SortDeep(CColl(1, 2, 3, 4, 5, 6, 7, 8, 9)), "Full order") + Call Dev_ExpectEQ(CColl(9, 3, 4, 1, 2, 5, 8, 6, 7), iProcessor.SortDeep(CColl(9, 8, 7, 6, 5, 4, 3, 2, 1)), "Reversed order") + Call Dev_ExpectEQ(CColl(5, 6, 7, 8, 9, 3, 1, 2, 4), iProcessor.SortDeep(CColl(1, 2, 3, 4, 5, 6, 7, 8, 9, 1337, 42)), "Mixed invalid") + Call Dev_ExpectEQ(CColl(5, 7, 9, 3, 1), iProcessor.SortDeep(CColl(1, 3, 5, 7, 9)), "Partial order") + Call Dev_ExpectEQ(CColl(9, 1), iProcessor.SortDeep(CColl(1, 9)), "Missing component") + + Call Dev_NewCase("Sibling sorting") + Call graph_.Clear + Call graph_.AddEdge(1, 3): Call graph_.AddEdge(2, 3) + Call graph_.AddEdge(4, 5): Call graph_.AddEdge(3, 5): Call graph_.AddEdge(3, 6) + Call iProcessor.Init(graph_) + Call Dev_ExpectEQ(CColl(1, 3, 5, 6, 2, 4), iProcessor.SortDeep(CColl(1, 2, 3, 4, 5, 6))) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +' ====== +Private Function TestTopological(iOrder As Collection) As Boolean + TestTopological = False + + Dim nItem1& + Dim nItem2& + For nItem1 = iOrder.Count To 2 Step -1 + For nItem2 = 1 To nItem1 - 1 Step 1 + If graph_.HasEdge(iOrder(nItem1), iOrder(nItem2)) Then _ + If Not graph_.HasEdge(iOrder(nItem2), iOrder(nItem1)) Then _ + Exit Function + Next nItem2 + Next nItem1 + + TestTopological = True +End Function + +Private Function TestComponent(iOrder As Collection) As Boolean + TestComponent = False + If Not TestTopological(iOrder) Then _ + Exit Function + + Dim iProcessor As New API_LinkedComponents + Dim iComponents As Scripting.Dictionary: Set iComponents = iProcessor.GetComponents(graph_) + + Dim iVisited As New Scripting.Dictionary + Dim nLast&: nLast = -1 + Dim nComponent& + Dim vNode As Variant + For Each vNode In iOrder + nComponent = iComponents(vNode) + If nLast <> nComponent Then + If iVisited.Exists(nComponent) Then _ + Exit Function + Call iVisited.Add(nComponent, 0) + nLast = nComponent + End If + Next vNode + + TestComponent = True +End Function + diff --git a/src/test/s_JSON.cls b/src/test/s_JSON.cls new file mode 100644 index 0000000..585cd6b --- /dev/null +++ b/src/test/s_JSON.cls @@ -0,0 +1,212 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_JSON" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private json_ As API_JSON + +Public Function Setup() + ' Mandatory setup function + Set json_ = New API_JSON +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_GeneratePlain() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Invalid object") + On Error Resume Next + Call json_.CreateJSON(json_) + Call Dev_ExpectAnyError + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Basic types") + Call Dev_ExpectEQ("""""", json_.CreateJSON("")) + Call Dev_ExpectEQ(json_.CreateJSON(0), "0") + Call Dev_ExpectEQ(json_.CreateJSON(-1), "-1") + Call Dev_ExpectEQ(json_.CreateJSON(1.234), "1.234") + + Call Dev_NewCase("String") + Call Dev_ExpectEQ(json_.CreateJSON("test"), """test""") + Call Dev_ExpectEQ(json_.CreateJSON(""), """""", "Cyrillic") + Call Dev_ExpectEQ(json_.CreateJSON("1 "" 2"), """1 \"" 2""", "Escape quote") + Call Dev_ExpectEQ(json_.CreateJSON("test1" & vbNewLine & "test2"), """test1\r\ntest2""", "Escape special symbol") + + Call Dev_NewCase("Array 1D") + Call Dev_ExpectEQ(json_.CreateJSON(Array()), "[]") + Call Dev_ExpectEQ(json_.CreateJSON(Array(1, 2, Array())), "[1,2,[]]") + Call Dev_ExpectEQ(json_.CreateJSON(Array(Array(1, 2), 3)), "[[1,2],3]") + + Call Dev_NewCase("Array 2D") + Dim testArr(1 To 2, 1 To 2) As Variant + testArr(1, 1) = 1337 + testArr(2, 2) = 42 + Call Dev_ExpectEQ(json_.CreateJSON(testArr), "[[1337,null],[null,42]]") + + Call Dev_NewCase("Collection") + Call Dev_ExpectEQ(json_.CreateJSON(CColl()), "[]") + Call Dev_ExpectEQ(json_.CreateJSON(CColl(1, 2, 3)), "[1,2,3]") + Call Dev_ExpectEQ(json_.CreateJSON(CColl(1, CColl(2, 3))), "[1,[2,3]]") + + Call Dev_NewCase("Dictionary") + Dim testDict As New Scripting.Dictionary + Call Dev_ExpectEQ(json_.CreateJSON(testDict), "{}") + testDict.Item(1) = 42 + testDict.Item("test") = 1337 + Set testDict.Item(2) = CColl(1, 2) + Call Dev_ExpectEQ(json_.CreateJSON(testDict), "{""1"":42,""test"":1337,""2"":[1,2]}") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GenerateMods() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Escape unicode") + json_.escapeUnicode_ = True + Call Dev_ExpectEQ(json_.CreateJSON(""), """\u0442\u0435\u0441\u0442""") + json_.escapeUnicode_ = False + Call Dev_ExpectEQ(json_.CreateJSON(""), """""") + + Call Dev_NewCase("Escape slash") + json_.escapeSlash_ = True + Call Dev_ExpectEQ(json_.CreateJSON("/"), """\/""") + json_.escapeSlash_ = False + Call Dev_ExpectEQ(json_.CreateJSON("/"), """/""") + + Call Dev_NewCase("Pretty print") + Dim test1$: test1 = _ + "[" & vbNewLine & _ + " 1," & vbNewLine & _ + " [" & vbNewLine & _ + " 2," & vbNewLine & _ + " 3" & vbNewLine & _ + " ]" & vbNewLine & _ + "]" + Call json_.SetupMultiline(2) + Call Dev_ExpectEQ(json_.CreateJSON(Array(1, Array(2, 3))), test1, "Print2") + + Dim test2$: test2 = _ + "[" & vbNewLine & _ + " 1," & vbNewLine & _ + " [" & vbNewLine & _ + " 2," & vbNewLine & _ + " 3" & vbNewLine & _ + " ]" & vbNewLine & _ + "]" + Call json_.SetupMultiline(4) + Call Dev_ExpectEQ(json_.CreateJSON(Array(1, Array(2, 3))), test2, "Print4") + + Dim test3$: test3 = _ + "[" & vbNewLine & _ + "-1," & vbNewLine & _ + "-[" & vbNewLine & _ + "--2," & vbNewLine & _ + "--3" & vbNewLine & _ + "-]" & vbNewLine & _ + "]" + Call json_.SetupMultiline("-") + Call Dev_ExpectEQ(json_.CreateJSON(Array(1, Array(2, 3))), test3, "Print-") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ParseValid() + On Error GoTo PROPAGATE_ERROR + + Dim testDict As Scripting.Dictionary + + Call Dev_NewCase("Empty") + Call Dev_ExpectEQ(json_.Parse("[]"), CColl()) + Call Dev_ExpectEQ(json_.Parse("{}"), CSet()) + + Call Dev_NewCase("Basic types") + Call Dev_ExpectEQ(json_.Parse("[1,2,""3""]"), CColl(1, 2, "3")) + Call Dev_ExpectEQ(json_.Parse("[1,2,null]"), CColl(1, 2, Null)) + Set testDict = New Scripting.Dictionary + testDict.Item("key1") = 1.234 + testDict.Item("key2") = 0 + Call Dev_ExpectEQ(json_.Parse("{""key1"":1.234,""key2"":0}"), testDict) + + Call Dev_NewCase("Compound structures") + Call Dev_ExpectEQ(json_.Parse("[1,[2,3],{}]"), CColl(1, CColl(2, 3), CSet())) + Set testDict = New Scripting.Dictionary + Set testDict.Item("key1") = CColl(1, 2) + Set testDict.Item("key2") = CColl(42) + Call Dev_ExpectEQ(json_.Parse("{""key1"":[1,2],""key2"":[42]}"), testDict) + + Call Dev_NewCase("Slashes") + + + Call Dev_NewCase("Pretty printed") + Call json_.SetupMultiline(2) + Dim sInput$: sInput = json_.CreateJSON(Array(1, Array(2, 3))) + Call Dev_ExpectEQ(json_.Parse(sInput), CColl(1, CColl(2, 3))) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ParsePath() + On Error GoTo PROPAGATE_ERROR + + Dim testDict As Scripting.Dictionary + + json_.escapeSlash_ = False + Set testDict = New Scripting.Dictionary + testDict.Item("key1") = "C:ToolsPython39-venvScriptspython.exe" + Call Dev_ExpectEQ(json_.Parse("{""key1"": ""C:\Tools\Python39-venv\Scripts\python.exe""}"), testDict) + testDict.Item("key1") = "C:\Tools\Python39-venv\Scripts\python.exe" + Call Dev_ExpectEQ(json_.Parse("{""key1"": ""C:\\Tools\\Python39-venv\\Scripts\\python.exe""}"), testDict) + testDict.Item("key1") = "C:/Tools/Python39-venv/Scripts/python.exe" + Call Dev_ExpectEQ(json_.Parse("{""key1"": ""C:/Tools/Python39-venv/Scripts/python.exe""}"), testDict) + testDict.Item("key1") = "C:/Tools/Python39-venv/Scripts/python.exe" + Call Dev_ExpectEQ(json_.Parse("{""key1"": ""C:\/Tools\/Python39-venv\/Scripts\/python.exe""}"), testDict) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ParseInvalid() + On Error GoTo PROPAGATE_ERROR + + Call ExpectParserError("") + Call ExpectParserError("]") + Call ExpectParserError("}") + Call ExpectParserError("{") + Call ExpectParserError("[") + Call ExpectParserError("[[]") + Call ExpectParserError("[]]") + Call ExpectParserError("{{}") + Call ExpectParserError("{}}") + Call ExpectParserError("abc") + Call ExpectParserError("{key:1}") + Call ExpectParserError("[{]}") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +' ====== +Private Function ExpectParserError(sInput$, Optional sClause$ = "") + On Error Resume Next + Call json_.Parse(sInput) + Call Dev_ExpectAnyError(sClause & vbNewLine & "Input: " & sInput) + On Error GoTo 0 +End Function diff --git a/src/test/s_Logger.cls b/src/test/s_Logger.cls new file mode 100644 index 0000000..a69f15f --- /dev/null +++ b/src/test/s_Logger.cls @@ -0,0 +1,119 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_Logger" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private fso_ As Scripting.FileSystemObject +Private logFile_ As String +Private log_ As API_Logger + +Private Const TEST_LOG_NAME = "testlog.log" + +Public Function Setup() + ' Mandatory setup function + Set fso_ = New Scripting.FileSystemObject + Call Teardown + + logFile_ = ThisWorkbook.Path & "\" & TEST_LOG_NAME + Set log_ = New API_Logger + Call log_.Init(logFile_) +End Function + +Public Function Teardown() + ' Mandatory teardown function + If fso_.FileExists(logFile_) Then _ + Call fso_.DeleteFile(logFile_) +End Function + +Public Function t_Init() + On Error GoTo PROPAGATE_ERROR + + Dim newLog As New API_Logger + + Call Dev_NewCase("Empty Init") + On Error Resume Next + Call newLog.Init("") + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("File Init") + Dim sFile1$: sFile1 = logFile_ & "1" + Call newLog.Init(sFile1) + + Call Dev_ExpectTrue(fso_.FileExists(logFile_)) + Call Dev_ExpectEQ(sFile1, newLog.LogFileName) + Dim cLines As Collection: Set cLines = ReadLogLines(sFile1) + Call Dev_AssertEQ(1, cLines.Count) + Call Dev_ExpectLike(cLines(1), "*Log file created") + + Call Dev_NewCase("Reinit") + Dim sFile2$: sFile2 = logFile_ & "2" + Call newLog.Init(sFile2) + Call Dev_ExpectTrue(fso_.FileExists(logFile_)) + Call Dev_ExpectTrue(fso_.FileExists(sFile2)) + + Call fso_.DeleteFile(sFile1) + Call fso_.DeleteFile(sFile2) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Timestamp() + On Error GoTo PROPAGATE_ERROR + + Dim cLines As Collection: Set cLines = ReadLogLines(logFile_) + Call Dev_AssertEQ(1, cLines.Count) + Dim dTime As Double: dTime = ExtractTimestamp(cLines(1)) + Call Dev_ExpectAEQ(Now(), dTime, 0, "Valid stamp") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Log() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid messaging") + Call log_.Log("") + Call log_.Log("test") + Call log_.Log("Multiline: line1" & vbNewLine & "Multiline: line2") + Dim cLines As Collection: Set cLines = ReadLogLines(logFile_) + Call Dev_AssertEQ(5, cLines.Count) + Call Dev_ExpectEQ("Log file created", TrimTimestamp(cLines(1))) + Call Dev_ExpectEQ("", TrimTimestamp(cLines(2))) + Call Dev_ExpectEQ("test", TrimTimestamp(cLines(3))) + Call Dev_ExpectEQ("Multiline: line1", TrimTimestamp(cLines(4))) + Call Dev_ExpectEQ("Multiline: line2", TrimTimestamp(cLines(5))) + + Call Dev_NewCase("Try logging when log was deleted") + Call fso_.DeleteFile(logFile_) + On Error Resume Next + Call log_.Log("test") + Call Dev_ExpectNoError + Call Dev_ExpectFalse(fso_.FileExists(logFile_)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +' ===== +Private Function ReadLogLines(sFile$) As Collection + Const UTF16_MODE = TristateTrue + Set ReadLogLines = New Collection + Dim fso As New Scripting.FileSystemObject + Dim fs As Scripting.TextStream: Set fs = fso.OpenTextFile(sFile, ForReading, Format:=UTF16_MODE) + Do While Not fs.AtEndOfStream + Call ReadLogLines.Add(fs.ReadLine) + Loop + Call fs.Close +End Function diff --git a/src/test/s_ParseDate.cls b/src/test/s_ParseDate.cls new file mode 100644 index 0000000..677ace7 --- /dev/null +++ b/src/test/s_ParseDate.cls @@ -0,0 +1,160 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_ParseDate" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Test suite for date Parsing ======= +Option Explicit + +Private parser_ As ParserDate + +Public Function Setup() + ' Mandatory setup function + Set parser_ = New ParserDate +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_DefaultState() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(0, parser_.day_) + Call Dev_ExpectEQ(0, parser_.month_) + Call Dev_ExpectEQ(0, parser_.year_) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Init() + On Error GoTo PROPAGATE_ERROR + + Call parser_.Init(12, 1, 20) + Call Dev_NewCase("Init real date") + Call Dev_ExpectEQ(12, parser_.day_) + Call Dev_ExpectEQ(1, parser_.month_) + Call Dev_ExpectEQ(20, parser_.year_) + + Call Dev_NewCase("Init invalid date") + Call parser_.Init(99, 99, 20) + Call Dev_ExpectEQ(99, parser_.day_) + Call Dev_ExpectEQ(99, parser_.month_) + Call Dev_ExpectEQ(20, parser_.year_) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Date() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty") + Call Dev_ExpectFalse(parser_.IsValidDate) + Call Dev_ExpectEQ(0, parser_.DDate) + + Call Dev_NewCase("Valid date value") + Call parser_.Init(31, 1, 20) + Call Dev_ExpectTrue(parser_.IsValidDate) + Call Dev_ExpectEQ(43861#, parser_.DDate) + + Call Dev_NewCase("Invalid date value") + Call parser_.Init(32, 1, 20) + Call Dev_ExpectFalse(parser_.IsValidDate) + Call Dev_ExpectEQ(0#, parser_.DDate) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_AsString() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty") + Call Dev_ExpectEQ("00.00.00", parser_.AsDigitsString) + Call Dev_ExpectEQ("INVALID_DATE", parser_.AsTextString) + + Call Dev_NewCase("Short year") + Call parser_.Init(31, 1, 20) + Call Dev_ExpectEQ("31.01.20", parser_.AsDigitsString) + Call Dev_ExpectEQ("31 2020 ", parser_.AsTextString) + + Call Dev_NewCase("Long year") + Call parser_.Init(31, 1, 1989) + Call Dev_ExpectEQ("31.01.1989", parser_.AsDigitsString) + Call Dev_ExpectEQ("31 1989 ", parser_.AsTextString) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Test() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty string") + Call Dev_ExpectFalse(parser_.Test("")) + + Call Dev_NewCase("Invalid inputs") + Call Dev_ExpectFalse(parser_.Test("123")) + Call Dev_ExpectFalse(parser_.Test("12 2000 ")) + + Call Dev_NewCase("Incomplete inputs") + Call Dev_ExpectFalse(parser_.Test("12 20")) + Call Dev_ExpectFalse(parser_.Test(" 2000 ")) + Call Dev_ExpectFalse(parser_.Test("13 2000 ")) + Call Dev_ExpectFalse(parser_.Test("13 00 ")) + + Call Dev_ExpectTrue(parser_.Test("13.01.2000"), "Valid input: 13.01.2000") + Call Dev_ExpectTrue(parser_.Test("13.01.2000 ."), "Valid input: 13.01.2000 .") + Call Dev_ExpectTrue(parser_.Test("13.01.00"), "Valid input: 13.01.00") + Call Dev_ExpectTrue(parser_.Test("13 2000 "), "Valid input: 13 2000 ") + Call Dev_ExpectTrue(parser_.Test("13 2000 "), "Valid input: 13 2000 ") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Parse() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectFalse(parser_.Parse(""), "Parse empty string") + Call Dev_ExpectFalse(parser_.Parse("123"), "Parse invalid") + + Call Dev_NewCase("Parse 13.01.2000") + Call Dev_AssertTrue(parser_.Parse("13.01.2000")) + Call Dev_ExpectEQ(13, parser_.day_) + Call Dev_ExpectEQ(1, parser_.month_) + Call Dev_ExpectEQ(2000, parser_.year_) + + Call Dev_NewCase("Do not reset after fail?") + Call Dev_AssertFalse(parser_.Parse("123")) + Call Dev_ExpectEQ(13, parser_.day_) + Call Dev_ExpectEQ(1, parser_.month_) + Call Dev_ExpectEQ(2000, parser_.year_) + + Call Dev_NewCase("Parse 13 2000 ") + Call Dev_AssertTrue(parser_.Parse("13 2000 ")) + Call Dev_ExpectEQ(13, parser_.day_) + Call Dev_ExpectEQ(1, parser_.month_) + Call Dev_ExpectEQ(2000, parser_.year_) + + Call Dev_NewCase("Parse 13.01.00") + Call Dev_AssertTrue(parser_.Parse("13.01.00")) + Call Dev_ExpectEQ(13, parser_.day_) + Call Dev_ExpectEQ(1, parser_.month_) + Call Dev_ExpectEQ(0, parser_.year_) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_Path.cls b/src/test/s_Path.cls new file mode 100644 index 0000000..99258aa --- /dev/null +++ b/src/test/s_Path.cls @@ -0,0 +1,209 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_Path" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private path_ As API_Path + +Public Function Setup() + ' Mandatory setup function + Set path_ = New API_Path +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_FromString() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ("", path_.FromString("").Text, "Empty string") + Call Dev_ExpectEQ("???.txt", path_.FromString("???.txt").Text, "Invalid string") + Call Dev_ExpectEQ("D:\Dev\test.txt", path_.FromString("D:\Dev\test.txt").Text, "Global drive") + Call Dev_ExpectEQ("..\local\test.txt", path_.FromString("..\local\test.txt").Text, "Local file") + Call Dev_ExpectEQ("C:\LocalFolder", path_.FromString("C:\LocalFolder").Text, "Folder") + Call Dev_ExpectEQ("%APPDATA%\text.txt", path_.FromString("%APPDATA%\text.txt").Text, "Environ") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_AccessProperties() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty") + Call path_.FromString("") + Call Dev_ExpectEQ("", path_.ParentFolder, "ParentFolder") + Call Dev_ExpectEQ("", path_.FileName, "FileName") + Call Dev_ExpectEQ("", path_.BaseName, "BaseName") + Call Dev_ExpectEQ("", path_.Extension, "Extension") + + Call Dev_NewCase("Invalid") + Call path_.FromString("invalid?&.!") + Call Dev_ExpectEQ("", path_.ParentFolder, "ParentFolder") + Call Dev_ExpectEQ("invalid?&.!", path_.FileName, "FileName") + Call Dev_ExpectEQ("invalid?&", path_.BaseName, "BaseName") + Call Dev_ExpectEQ("!", path_.Extension, "Extension") + + Call Dev_NewCase("Valid file") + Call path_.FromString("\\fs1.concept.ru\projects\test.txt") + Call Dev_ExpectEQ("\\fs1.concept.ru\projects", path_.ParentFolder, "ParentFolder") + Call Dev_ExpectEQ("test.txt", path_.FileName, "FileName") + Call Dev_ExpectEQ("test", path_.BaseName, "BaseName") + Call Dev_ExpectEQ("txt", path_.Extension, "Extension") + + Call Dev_NewCase("Valid folder") + Call path_.FromString("C:\Windows\test") + Call Dev_ExpectEQ("C:\Windows", path_.ParentFolder, "ParentFolder") + Call Dev_ExpectEQ("test", path_.FileName, "FileName") + Call Dev_ExpectEQ("test", path_.BaseName, "BaseName") + Call Dev_ExpectEQ("", path_.Extension, "Extension") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ToGlobal() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty") + Call path_.FromString("") + Call Dev_ExpectEQ("", path_.ToGlobal("").Text) + + Call Dev_NewCase("Invalid") + Call path_.FromString("invalid?&.!") + Call Dev_ExpectEQ("\invalid?&.!", path_.ToGlobal("").Text) + Call path_.FromString("invalid?&.!") + Call Dev_ExpectEQ("\\fs1.concept.ru\invalid?&.!", path_.ToGlobal("\\fs1.concept.ru").Text) + + Call Dev_NewCase("Global to Global") + Call path_.FromString("\\fs1.concept.ru\projects\test.txt") + Call Dev_ExpectEQ("\\fs1.concept.ru\projects\test.txt", path_.ToGlobal("\\fs1.concept.ru").Text) + + Call Dev_NewCase("Environ to Global") + Call path_.FromString("%APPDATA%\test.txt") + Call Dev_ExpectEQ(VBA.Environ$("APPDATA") & "\test.txt", path_.ToGlobal("\\fs1.concept.ru").Text) + Call path_.FromString("%INVALID_VARIABLE%\test.txt") + Call Dev_ExpectEQ("\test.txt", path_.ToGlobal("\\fs1.concept.ru").Text) + + Call Dev_NewCase("Local to Global") + Call path_.FromString("test.txt") + Call Dev_ExpectEQ("\\fs1.concept.ru\test.txt", path_.ToGlobal("\\fs1.concept.ru").Text) + Call path_.FromString("..\test.txt") + Call Dev_ExpectEQ("\\fs1.concept.ru\1\2\test.txt", path_.ToGlobal("\\fs1.concept.ru\1\2\3").Text) + Call path_.FromString("..\..\test.txt") + Call Dev_ExpectEQ("\\fs1.concept.ru\1\test.txt", path_.ToGlobal("\\fs1.concept.ru\1\2\3").Text) + Call Dev_ExpectEQ("\\fs1.concept.ru\1\test.txt", path_.Text) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ToLocal() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty") + Call path_.FromString("") + Call Dev_ExpectEQ("", path_.ToLocal("").Text) + + Call Dev_NewCase("Invalid") + Call path_.FromString("invalid?&.!") + Call Dev_ExpectEQ("invalid?&.!", path_.ToLocal("").Text) + Call path_.FromString("invalid?&.!") + Call Dev_ExpectEQ("invalid?&.!", path_.ToLocal("\\fs1.concept.ru").Text) + + Call Dev_NewCase("Global to Local") + Call path_.FromString("\\fs1.concept.ru\projects\test.txt") + Call Dev_ExpectEQ("test.txt", path_.Clone().ToLocal("\\fs1.concept.ru\projects").Text) + Call Dev_ExpectEQ("..\test.txt", path_.Clone().ToLocal("\\fs1.concept.ru\projects\1").Text) + Call Dev_ExpectEQ("projects\test.txt", path_.Clone().ToLocal("\\fs1.concept.ru").Text) + Call Dev_ExpectEQ("..\..\projects\test.txt", path_.Clone().ToLocal("\\fs1.concept.ru\1\2").Text) + + Call Dev_NewCase("Environ to Local") + Call path_.FromString("%APPDATA%\test.txt") + Call Dev_ExpectEQ("%APPDATA%\test.txt", path_.ToLocal("\\fs1.concept.ru").Text) + + Call Dev_NewCase("Local to Local") + Call path_.FromString("test.txt") + Call Dev_ExpectEQ("test.txt", path_.ToLocal("\\fs1.concept.ru").Text) + Call path_.FromString("..\test.txt") + Call Dev_ExpectEQ("..\test.txt", path_.ToLocal("\\fs1.concept.ru\1\2\3").Text) + Call path_.FromString("..\..\test.txt") + Call Dev_ExpectEQ("..\..\test.txt", path_.ToLocal("\\fs1.concept.ru\1\2\3").Text) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ToServer() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty") + Call path_.FromString("") + Call Dev_ExpectEQ("", path_.ToServer("").Text) + Call Dev_ExpectEQ("", path_.GlobalToServer().Text) + + Call Dev_NewCase("Invalid") + Call path_.FromString("invalid?&.!") + Call Dev_ExpectEQ("\invalid?&.!", path_.ToServer("").Text) + Call Dev_ExpectEQ("\invalid?&.!", path_.GlobalToServer().Text) + Call path_.FromString("invalid?&.!") + Call Dev_ExpectEQ("\\fs1.concept.ru\invalid?&.!", path_.ToServer("\\fs1.concept.ru").Text) + + Call Dev_NewCase("Global to Server") + Call path_.FromString("C:\Windows\test.txt") + Call Dev_ExpectEQ("C:\Windows\test.txt", path_.Clone().ToServer("").Text) + Call Dev_ExpectEQ("C:\Windows\test.txt", path_.Clone().GlobalToServer().Text) + Call path_.FromString("P:\test\test.txt") + Call Dev_ExpectEQ("\\fs1.concept.ru\projects\test\test.txt", path_.Clone().ToServer("").Text) + Call Dev_ExpectEQ("\\fs1.concept.ru\projects\test\test.txt", path_.Clone().GlobalToServer().Text) + + Call Dev_NewCase("Environ to Server") + Call path_.FromString("%APPDATA%\test.txt") + Call Dev_ExpectEQ(path_.Clone.ToGlobal("").Text, path_.ToServer("").Text) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CheckExistance() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty") + Call path_.FromString("") + Call Dev_ExpectFalse(path_.LocalExists("")) + Call Dev_ExpectFalse(path_.GlobalExists()) + + Call Dev_NewCase("Invalid") + Call path_.FromString("invalid?&.!") + Call Dev_ExpectFalse(path_.LocalExists("")) + Call Dev_ExpectFalse(path_.LocalExists("\\fs1.concept.ru")) + Call Dev_ExpectFalse(path_.GlobalExists()) + + Call Dev_NewCase("Valid file") + Call path_.FromString(ThisWorkbook.FullName) + Call Dev_ExpectTrue(path_.LocalExists("")) + Call Dev_ExpectTrue(path_.LocalExists("\\fs1.concept.ru")) + Call Dev_ExpectTrue(path_.GlobalExists()) + + Call Dev_NewCase("Valid folder") + Call path_.FromString(path_.ParentFolder) + Call Dev_ExpectTrue(path_.LocalExists("")) + Call Dev_ExpectTrue(path_.LocalExists("\\fs1.concept.ru")) + Call Dev_ExpectTrue(path_.GlobalExists()) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_StaticHierarchy.cls b/src/test/s_StaticHierarchy.cls new file mode 100644 index 0000000..7657f11 --- /dev/null +++ b/src/test/s_StaticHierarchy.cls @@ -0,0 +1,124 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_StaticHierarchy" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +Private iTree_ As CDS_StaticHierarchy + +Public Function Setup() + ' Mandatory setup function + Set iTree_ = New CDS_StaticHierarchy +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_SingleRoot() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty") + Call Dev_ExpectEQ(0, iTree_.Size, "Count nodes") + Call Dev_ExpectEQ(0, iTree_.MaxDepth, "Max Depth") + + Call Dev_NewCase("Push root") + Dim iRoot As CDS_NodeSH + Set iRoot = iTree_.PushItem(1) + Call Dev_AssertNotNothing(iRoot) + Call Dev_ExpectEQ(1, iTree_.Size, "Add node") + Call Dev_ExpectEQ(iRoot, iTree_.nodes_(1), "Add node") + Call Dev_ExpectEQ(1, iTree_.MaxDepth, "Max Depth") + Call Dev_ExpectEQ(1, iRoot.id_, "ID") + Call Dev_ExpectEQ(1, iRoot.rank_, "Rank") + Call Dev_ExpectNothing(iRoot.parent_, "Parent") + Call Dev_ExpectEQ(0, iRoot.children_.Count, "Children") + Call Dev_ExpectNothing(iRoot.data_, "Payload") + + Call Dev_NewCase("Push regular structure") + Call Dev_ExpectNotNothing(iTree_.PushItem(2)) + Call Dev_ExpectNotNothing(iTree_.PushItem(3)) + Call Dev_ExpectNotNothing(iTree_.PushItem(4)) + Call Dev_ExpectNotNothing(iTree_.PushItem(2)) + Call Dev_ExpectEQ(5, iTree_.Size, "Count nodes") + Call Dev_ExpectEQ(4, iTree_.MaxDepth, "Max Depth") + Call Dev_ExpectEQ(2, iRoot.children_.Count, "Count children") + Call Dev_ExpectEQ(iRoot, iRoot.children_(1).parent_, "Parent assignment") + Call Dev_ExpectEQ(iRoot, iRoot.children_(2).parent_, "Parent assignment") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_MultipleRoots() + On Error GoTo PROPAGATE_ERROR + + Call iTree_.PushItem(2) + Call iTree_.PushItem(3) + + Call Dev_NewCase("New root same rank") + Call Dev_AssertNotNothing(iTree_.PushItem(2)) + Call Dev_ExpectNothing(iTree_.nodes_(3).parent_, "New root") + Call Dev_ExpectNothing(iTree_.nodes_(1).parent_, "Old root") + + Call Dev_NewCase("New root lower rank") + Call Dev_AssertNotNothing(iTree_.PushItem(1)) + Call Dev_AssertNotNothing(iTree_.PushItem(2)) + Call Dev_ExpectNothing(iTree_.nodes_(4).parent_, "New root") + Call Dev_ExpectNothing(iTree_.nodes_(1).parent_, "Old root") + Call Dev_ExpectEQ(1, iTree_.nodes_(4).children_.Count, "Do not assume old roots as children!") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_StructuralErrors() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Invalid level gap") + Call iTree_.PushItem(10) + Call Dev_ExpectNothing(iTree_.PushItem(12)) + + Call Dev_ExpectNotNothing(iTree_.PushItem(11)) + Call Dev_ExpectNotNothing(iTree_.PushItem(12)) + Call Dev_ExpectNotNothing(iTree_.PushItem(13)) + Call Dev_ExpectNotNothing(iTree_.PushItem(11)) + Call Dev_ExpectNothing(iTree_.PushItem(13)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CountDescendants() + On Error GoTo PROPAGATE_ERROR + + Call iTree_.PushItem(1) ' 1: 1 + Call iTree_.PushItem(2) ' 2: 1.1 + Call iTree_.PushItem(3) ' 3: 1.1.1 + Call iTree_.PushItem(3) ' 4: 1.1.2 + Call iTree_.PushItem(1) ' 5: 2 + Call iTree_.PushItem(1) ' 6: 3 + Call iTree_.PushItem(2) ' 7: 3.1 + Call iTree_.PushItem(2) ' 8: 3.2 + + Call Dev_ExpectEQ(3, iTree_.nodes_(1).descendantsCount_, "Node 1") + Call Dev_ExpectEQ(2, iTree_.nodes_(2).descendantsCount_, "Node 2") + Call Dev_ExpectEQ(0, iTree_.nodes_(3).descendantsCount_, "Node 3") + Call Dev_ExpectEQ(0, iTree_.nodes_(4).descendantsCount_, "Node 4") + Call Dev_ExpectEQ(0, iTree_.nodes_(5).descendantsCount_, "Node 5") + Call Dev_ExpectEQ(2, iTree_.nodes_(6).descendantsCount_, "Node 6") + Call Dev_ExpectEQ(0, iTree_.nodes_(7).descendantsCount_, "Node 7") + Call Dev_ExpectEQ(0, iTree_.nodes_(8).descendantsCount_, "Node 8") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_TextEdit.cls b/src/test/s_TextEdit.cls new file mode 100644 index 0000000..f96eef1 --- /dev/null +++ b/src/test/s_TextEdit.cls @@ -0,0 +1,134 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_TextEdit" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Test suite for date Parsing ======= +Option Explicit + +Private Const STYLE_TEST_PARA$ = "TestParagraph" +Private Const STYLE_TEST_CHAR$ = "TestCharacter" + +Private doc_ As Word.Document + +Public Function Setup() + ' Mandatory setup function + Set doc_ = ThisDocument +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call doc_.Range.Delete + Call doc_.Range.Select + Call Word.Selection.ClearFormatting +End Function + +Public Function t_AdjustRange() + On Error GoTo PROPAGATE_ERROR + ' =========== 12345678900123456678 + doc_.Range = " """" 1" & vbNewLine & " " + + Call Dev_ExpectEQ("", WordAdjustRange(doc_.Range(0, 0)), "Start of document") + Call Dev_ExpectEQ(" ", WordAdjustRange(doc_.Range(1, 1)), "Zero length") + Call Dev_ExpectEQ(" ", WordAdjustRange(doc_.Range(1, 8)), "Valid word") + Call Dev_ExpectEQ(" ", WordAdjustRange(doc_.Range(2, 7)), "Partial word") + Call Dev_ExpectEQ(" ", WordAdjustRange(doc_.Range(1, 9)), "Ignore end space") + Call Dev_ExpectEQ(" """" ", WordAdjustRange(doc_.Range(1, 11)), "Quoted words") + Call Dev_ExpectEQ(""""" ", WordAdjustRange(doc_.Range(12, 13)), "Do not extend leading space") + Call Dev_ExpectEQ(" ", WordAdjustRange(doc_.Range(8, 9)), "Single space") + Call Dev_ExpectEQ(doc_.Paragraphs.First.Range, WordAdjustRange(doc_.Paragraphs.First.Range), "Whole paragraph") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_AddText() + On Error GoTo PROPAGATE_ERROR + + doc_.Range = "1" & vbNewLine & "2" & vbNewLine & "3" + + Call Dev_NewCase("Put text in position") + Dim sTxt1$: sTxt1 = "testI" + Dim firstPara As Word.Range: Set firstPara = doc_.Paragraphs(1).Range + Dim insertedRes As Word.Range: Set insertedRes = WordPutText(sTxt1, doc_, 0) + Call Dev_ExpectEQ(sTxt1, insertedRes.Text) + Call Dev_ExpectEQ(Len(sTxt1) + 2, firstPara.End) + + Call Dev_NewCase("Add text after") + Dim secondPara As Word.Range: Set secondPara = doc_.Paragraphs(2).Range + Dim sTxt2$: sTxt2 = "testII" + Set insertedRes = WordAddLine(sTxt2, secondPara, STYLE_TEST_PARA) + Call insertedRes.MoveEnd(wdCharacter, -1) + Call Dev_ExpectEQ(doc_.Paragraphs(2).Range.End, secondPara.End) + Call Dev_ExpectEQ(secondPara.End, insertedRes.Start) + Call Dev_ExpectEQ(sTxt2, insertedRes.Text) + Call Dev_ExpectEQ(STYLE_TEST_PARA, insertedRes.Style) + + Call Dev_NewCase("Append text") + Dim sTxt3$: sTxt3 = "testIII" + Set secondPara = secondPara.Characters.First + Set insertedRes = WordAppendTo(sTxt3, secondPara, STYLE_TEST_CHAR) + Call Dev_ExpectEQ(doc_.Paragraphs(2).Range.Characters.First.End + Len(sTxt3), secondPara.End) + Call Dev_ExpectEQ("2" & sTxt3, secondPara.Text) + Call Dev_ExpectNE(STYLE_TEST_CHAR, secondPara.Characters.First) + Call Dev_ExpectEQ(insertedRes.Text, sTxt3) + Call Dev_ExpectEQ(STYLE_TEST_CHAR, insertedRes.Style) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_AddTextToEnd() + On Error GoTo PROPAGATE_ERROR + + Call WordAddLine("test1", doc_.Content) + Call Dev_ExpectEQ(2, doc_.Content.Paragraphs.Count) + + Call WordAppendTo("test2", doc_.Content) + Call Dev_ExpectEQ(2, doc_.Content.Paragraphs.Count, "Append to empty line at document end") + + Call WordAppendTo("test3", doc_.Content) + Call Dev_ExpectEQ(2, doc_.Content.Paragraphs.Count, "Append to non-empty line at document end") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_AddTextToTable() + On Error GoTo PROPAGATE_ERROR + Dim sTxt$: sTxt = "test" + + Dim aTable As Word.Table: Set aTable = doc_.Tables.Add(doc_.Content, 1, 2) + aTable.Cell(1, 1).Range = "123" + Dim newRng As Word.Range: Set newRng = WordAddLine(sTxt, aTable.Cell(1, 1).Range, STYLE_TEST_PARA) + Dim cellRng As Word.Range: Set cellRng = aTable.Cell(1, 1).Range + Call Dev_AssertEQ(2, cellRng.Paragraphs.Count) + Call Dev_ExpectEQ(sTxt, newRng.Text, "Add text after") + Call Dev_ExpectEQ(STYLE_TEST_PARA, newRng.Style, "Add text after") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_StyleExists() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectFalse(WordStyleExists(doc_, ""), "Empty input") + Call Dev_ExpectFalse(WordStyleExists(doc_, "Invalid1234567"), "Invalid style") + Call Dev_ExpectTrue(WordStyleExists(doc_, doc_.Paragraphs.First.Range.Style), "Default style") + Call Dev_ExpectTrue(WordStyleExists(doc_, doc_.Paragraphs.First.Range.Style.NameLocal), "Default style local") + Call Dev_ExpectTrue(WordStyleExists(doc_, STYLE_TEST_PARA), "Paragraph style") + Call Dev_ExpectTrue(WordStyleExists(doc_, STYLE_TEST_CHAR), "Character style") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_UndoWrapper.cls b/src/test/s_UndoWrapper.cls new file mode 100644 index 0000000..72204c8 --- /dev/null +++ b/src/test/s_UndoWrapper.cls @@ -0,0 +1,98 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_UndoWrapper" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Test suite for UndoWrapper ======= +Option Explicit + +Private wrapper_ As API_UndoWrapper +Private targetPage_ As Visio.Page + +Public Function Setup() + ' Mandatory setup function + Set wrapper_ = New API_UndoWrapper + Call wrapper_.Init(ThisDocument.Application) + Set targetPage_ = ThisDocument.Pages(1) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call ThisDocument.Application.PurgeUndo +End Function + +Public Function t_BasicUndo() + On Error GoTo PROPAGATE_ERROR + + Dim oldCount&: oldCount = targetPage_.Shapes.Count + + Call wrapper_.BeginScope("Test") + Call AddTwoRectangles + Call wrapper_.EndScope + + Call targetPage_.Application.Undo + Call Dev_ExpectEQ(oldCount, targetPage_.Shapes.Count) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_CancelOnEndScope() + On Error GoTo PROPAGATE_ERROR + + Dim oldCount&: oldCount = targetPage_.Shapes.Count + + Call wrapper_.BeginScope("Test") + Call AddTwoRectangles + Call wrapper_.EndScope(bCommit:=False) + + Call Dev_ExpectEQ(oldCount, targetPage_.Shapes.Count) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_EndBeforeStart() + On Error GoTo PROPAGATE_ERROR + + Call wrapper_.EndScope + Call wrapper_.EndScope(bCommit:=False) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_DoubleStart() + On Error GoTo PROPAGATE_ERROR + + Dim oldCount&: oldCount = targetPage_.Shapes.Count + + Call wrapper_.BeginScope("Test") + Call wrapper_.BeginScope("Test") + Call AddTwoRectangles + Call wrapper_.BeginScope("Test2") + Call AddTwoRectangles + Call wrapper_.EndScope + + Call targetPage_.Application.Undo + Call Dev_ExpectEQ(oldCount, targetPage_.Shapes.Count, "Nested scope doesnt work. Only first scope is relevant") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +' ====== +Private Function AddTwoRectangles() + Dim oldCount&: oldCount = targetPage_.Shapes.Count + Call targetPage_.DrawRectangle(1, 1, 2, 2) + Call targetPage_.DrawRectangle(3, 3, 4, 4) + Call Dev_AssertEQ(oldCount + 2, targetPage_.Shapes.Count) +End Function diff --git a/src/test/s_VsoExtension.cls b/src/test/s_VsoExtension.cls new file mode 100644 index 0000000..d6b41aa --- /dev/null +++ b/src/test/s_VsoExtension.cls @@ -0,0 +1,34 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_VsoExtension" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Test suite for Visio extension ======= +Option Explicit + +' TODO: +' Public Sub CC_CreateConnectors() +' Public Sub CC_RedirectConnectors() +' Public Function VsoAlignShapes(target As Collection, dGap As Double, bAlignTop As Boolean) + +Public Function Setup() + ' Mandatory setup function +End Function + +Public Function Teardown() + ' Mandatory teardown function +End Function + +Public Function t_Init() + On Error GoTo PROPAGATE_ERROR + + + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_VsoGraph.cls b/src/test/s_VsoGraph.cls new file mode 100644 index 0000000..500d0d6 --- /dev/null +++ b/src/test/s_VsoGraph.cls @@ -0,0 +1,89 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_VsoGraph" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Test suite for Visio Graph scanner ======= +Option Explicit + +' TODO: +' Public Function ScanGraph(iSeed As Collection, bReverseLinks As Boolean) As CDS_Graph + +Private page_ As Visio.Page + +Public Function Setup() + ' Mandatory setup function + Set page_ = ThisDocument.Pages(1) + ThisDocument.DiagramServicesEnabled = visServiceStructureFull +End Function + +Public Function Teardown() + ' Mandatory teardown function + ThisDocument.DiagramServicesEnabled = 0 + Call ClearAll +End Function + +Public Function t_ScanConnector() + On Error GoTo PROPAGATE_ERROR + + Dim iResult As ItemConnector + + Call Dev_NewCase("Free arrow") + Dim iArrow As Visio.Shape: Set iArrow = page_.Drop(FindMaster(ThisDocument, MASTER_CONNECTOR), 30, 30) + iResult = ScanConnector(iArrow) + Call Dev_ExpectNothing(iResult.begin_) + Call Dev_ExpectNothing(iResult.end_) + Call Dev_ExpectEQ(T_CD_STRAIGHT, iResult.dir_) + + Call Dev_NewCase("Arrow directions") + iArrow.CellsU("BeginArrow") = 9 + iArrow.CellsU("EndArrow") = 9 + iResult = ScanConnector(iArrow) + Call Dev_ExpectEQ(T_CD_NONE, iResult.dir_) + + iArrow.CellsU("BeginArrow") = 9 + iArrow.CellsU("EndArrow") = 1 + iResult = ScanConnector(iArrow) + Call Dev_ExpectEQ(T_CD_STRAIGHT, iResult.dir_) + + iArrow.CellsU("BeginArrow") = 1 + iArrow.CellsU("EndArrow") = 9 + iResult = ScanConnector(iArrow) + Call Dev_ExpectEQ(T_CD_REVERSE, iResult.dir_) + + iArrow.CellsU("BeginArrow") = 1 + iArrow.CellsU("EndArrow") = 1 + iResult = ScanConnector(iArrow) + Call Dev_ExpectEQ(T_CD_MUTUAL, iResult.dir_) + + Call Dev_NewCase("Attached shapes") + Dim elem1 As Visio.Shape: Set elem1 = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 10, 10) + Dim elem2 As Visio.Shape: Set elem2 = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 20, 20) + iArrow.CellsU("BeginArrow") = 9 + iArrow.CellsU("EndArrow") = 1 + + Call iArrow.CellsU("BeginX").GlueTo(elem1.CellsU("PinX")) + iResult = ScanConnector(iArrow) + Call Dev_ExpectEQ(elem1, iResult.begin_) + Call Dev_ExpectNothing(iResult.end_) + + Call iArrow.Disconnect(visConnectorBothEnds, 0, 0, visFeet) + Call iArrow.CellsU("EndX").GlueTo(elem2.CellsU("PinX")) + iResult = ScanConnector(iArrow) + Call Dev_ExpectNothing(iResult.begin_) + Call Dev_ExpectEQ(elem2, iResult.end_) + + Call iArrow.CellsU("BeginX").GlueTo(elem1.CellsU("PinX")) + Call iArrow.CellsU("EndX").GlueTo(elem2.CellsU("PinX")) + iResult = ScanConnector(iArrow) + Call Dev_ExpectEQ(elem1, iResult.begin_) + Call Dev_ExpectEQ(elem2, iResult.end_) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_VsoUtilities.cls b/src/test/s_VsoUtilities.cls new file mode 100644 index 0000000..bc71305 --- /dev/null +++ b/src/test/s_VsoUtilities.cls @@ -0,0 +1,236 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_VsoUtilities" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +' ===== Test suite for Visio Utilities ======= +Option Explicit + +' Public Function VsoIncrementWidth(target As Visio.Shape, valueInMM&) + +Private page_ As Visio.Page + +Public Function Setup() + ' Mandatory setup function + Set page_ = ThisDocument.Pages(1) + ThisDocument.DiagramServicesEnabled = visServiceStructureFull +End Function + +Public Function Teardown() + ' Mandatory teardown function + ThisDocument.DiagramServicesEnabled = 0 + Call ClearAll +End Function + +Public Function t_FindMaster() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectNothing(FindMaster(ThisDocument, "Invalid"), "Invalid master name") + Call Dev_ExpectNothing(FindMaster(Nothing, MASTER_ELEMENT), "Invalid document") + Call Dev_ExpectEQ(ThisDocument.Masters.Item(MASTER_ELEMENT), FindMaster(ThisDocument, MASTER_ELEMENT), "Valid master") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_GetContainingShape() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Element") + Dim elem As Visio.Shape: Set elem = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 10, 10) + Dim iArrow As Visio.Shape: Set iArrow = page_.Drop(FindMaster(ThisDocument, MASTER_CONNECTOR), 30, 30) + Call Dev_ExpectNothing(GetContainingShape(elem)) + Call Dev_ExpectNothing(GetContainingShape(iArrow)) + + Call Dev_NewCase("Container") + Dim iContainer As Visio.Shape: Set iContainer = page_.Drop(FindMaster(ThisDocument, MASTER_CONTAINER), 20, 20) + Call Dev_ExpectNothing(GetContainingShape(iContainer)) + Call iContainer.ContainerProperties.AddMember(elem, visMemberAddExpandContainer) + Call iContainer.ContainerProperties.AddMember(iArrow, visMemberAddExpandContainer) + Call Dev_ExpectNothing(GetContainingShape(iContainer)) + Call Dev_ExpectEQ(iContainer, GetContainingShape(elem)) + + Call Dev_NewCase("List") + Dim iList As Visio.Shape: Set iList = page_.Drop(FindMaster(ThisDocument, MASTER_LIST), 0, 0) + Call iList.ContainerProperties.AddMember(iContainer, visMemberAddExpandContainer) + Call Dev_ExpectNothing(GetContainingShape(iList)) + Call Dev_ExpectEQ(iContainer, GetContainingShape(elem)) + Call Dev_ExpectEQ(iContainer, GetContainingShape(iArrow)) + Call Dev_ExpectEQ(iList, GetContainingShape(iContainer)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_VsoShapeExists() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty page") + Call Dev_ExpectFalse(VsoShapeExists(vbNullString, page_)) + Call Dev_ExpectFalse(VsoShapeExists("", page_)) + Call Dev_ExpectFalse(VsoShapeExists("invalid", page_)) + + Call Dev_NewCase("Valid shape") + Dim elem As Visio.Shape: Set elem = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 10, 10) + Call Dev_ExpectFalse(VsoShapeExists("", page_), "Empty input") + Call Dev_ExpectFalse(VsoShapeExists("Test", page_), "Invalid name") + Call Dev_ExpectTrue(VsoShapeExists(elem.Name, page_), "Default name") + elem.Name = "Test1337" + Call Dev_ExpectTrue(VsoShapeExists(elem.Name, page_), "Custom name") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_VsoCalculateFillingFor() + On Error GoTo PROPAGATE_ERROR + + Call Dev_ExpectEQ(0, VsoCalculateFillingFor(page_), "Empty page") + + Call Dev_NewCase("Arrow") + Dim iArrow As Visio.Shape: Set iArrow = page_.Drop(FindMaster(ThisDocument, MASTER_CONNECTOR), 0, 0) + Call Dev_ExpectEQ(0, VsoCalculateFillingFor(page_)) + + Call Dev_NewCase("Valid shape") + Dim elem As Visio.Shape: Set elem = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 0, 0) + Call Dev_ExpectNE(0, VsoCalculateFillingFor(page_)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_VsoIsListContainer() + On Error GoTo PROPAGATE_ERROR + + Dim testShape As Visio.Shape + + Call Dev_NewCase("Element") + Set testShape = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 0, 0) + Call Dev_ExpectFalse(VsoIsListContainer(testShape)) + Call testShape.Delete + + Call Dev_NewCase("Arrow") + Set testShape = page_.Drop(FindMaster(ThisDocument, MASTER_CONNECTOR), 0, 0) + Call Dev_ExpectFalse(VsoIsListContainer(testShape)) + Call testShape.Delete + + Call Dev_NewCase("Container") + Set testShape = page_.Drop(FindMaster(ThisDocument, MASTER_CONTAINER), 0, 0) + Call Dev_ExpectFalse(VsoIsListContainer(testShape)) + Call testShape.Delete + + Call Dev_NewCase("List") + Set testShape = page_.Drop(FindMaster(ThisDocument, MASTER_LIST), 0, 0) + Call Dev_ExpectTrue(VsoIsListContainer(testShape)) + Call testShape.Delete + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_VsoIsMovable() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Element") + Dim elem As Visio.Shape: Set elem = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 10, 10) + Dim iArrow As Visio.Shape: Set iArrow = page_.Drop(FindMaster(ThisDocument, MASTER_CONNECTOR), 30, 30) + Call Dev_ExpectTrue(VsoIsMovable(elem)) + Call Dev_ExpectFalse(VsoIsMovable(iArrow)) + + Call Dev_NewCase("Container") + Dim iContainer As Visio.Shape: Set iContainer = page_.Drop(FindMaster(ThisDocument, MASTER_CONTAINER), 20, 20) + Call Dev_ExpectFalse(VsoIsMovable(iContainer)) + Call iContainer.ContainerProperties.AddMember(elem, visMemberAddExpandContainer) + Call Dev_ExpectTrue(VsoIsMovable(elem)) + + Call Dev_NewCase("List") + Set elem = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 0, 0) + Dim iList As Visio.Shape: Set iList = page_.Drop(FindMaster(ThisDocument, MASTER_LIST), 0, 0) + Call iList.ContainerProperties.InsertListMember(elem, 1) + Call Dev_ExpectTrue(VsoIsMovable(iList)) + Call Dev_ExpectFalse(VsoIsMovable(elem)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_VsoIsConnected() + On Error GoTo PROPAGATE_ERROR + + Dim elem1 As Visio.Shape: Set elem1 = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 10, 10) + Dim elem2 As Visio.Shape: Set elem2 = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 20, 20) + Dim iArrow As Visio.Shape: Set iArrow = page_.Drop(FindMaster(ThisDocument, MASTER_CONNECTOR), 30, 30) + + Call Dev_NewCase("Not connected") + Call Dev_ExpectFalse(VsoIsConnected(elem1, elem1), "Self") + Call Dev_ExpectFalse(VsoIsConnected(iArrow, elem1), "Connector") + Call Dev_ExpectFalse(VsoIsConnected(elem2, iArrow), "Connector") + + Call Dev_NewCase("Valid connection") + Call elem1.AutoConnect(elem2, visAutoConnectDirNone) + Call Dev_ExpectTrue(VsoIsConnected(elem1, elem2), "Straight connection") + Call Dev_ExpectFalse(VsoIsConnected(elem2, elem1), "Reverse connection") + Call Dev_ExpectFalse(VsoIsConnected(elem1, elem1), "Self connection") + + Call Dev_NewCase("Self connection") + Call iArrow.CellsU("BeginX").GlueTo(elem1.CellsU("PinX")) + Call iArrow.CellsU("EndX").GlueTo(elem1.CellsU("PinX")) + Call Dev_ExpectTrue(VsoIsConnected(elem1, elem1)) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_VsoGeometricSort() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Empty input") + Dim ids() As Long + On Error Resume Next + Call VsoGeometricSort(ids, page_) + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Valid elementary") + Dim testIDs() As Long: ReDim testIDs(1 To 4) + ReDim ids(1 To 4) + Dim iShape1 As Visio.Shape: Set iShape1 = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 0, 0) + Dim iShape2 As Visio.Shape: Set iShape2 = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 0, 1) + Dim iShape3 As Visio.Shape: Set iShape3 = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 1, 0) + Dim iShape4 As Visio.Shape: Set iShape4 = page_.Drop(FindMaster(ThisDocument, MASTER_ELEMENT), 1, 1) + ids(1) = iShape1.ID: testIDs(1) = iShape2.ID + ids(2) = iShape2.ID: testIDs(2) = iShape4.ID + ids(3) = iShape3.ID: testIDs(3) = iShape1.ID + ids(4) = iShape4.ID: testIDs(4) = iShape3.ID + Call VsoGeometricSort(ids, page_) + Call Dev_ExpectEQ(testIDs, ids) + + Call Dev_NewCase("Valid different shapes") + Set iShape1 = page_.DrawRectangle(0, 0, 10, 10) + Set iShape2 = page_.DrawRectangle(11, 5, 17, -5) + Set iShape3 = page_.DrawRectangle(0, 0, 10, 10 + 0.001) + Set iShape4 = page_.DrawRectangle(0, 6, 7, 16) + + ids(1) = iShape1.ID: testIDs(1) = iShape4.ID + ids(2) = iShape2.ID: testIDs(2) = iShape1.ID + ids(3) = iShape3.ID: testIDs(3) = iShape3.ID + ids(4) = iShape4.ID: testIDs(4) = iShape2.ID + + Call VsoGeometricSort(ids, page_) + Call Dev_ExpectEQ(testIDs, ids) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_VsoWrapper.cls b/src/test/s_VsoWrapper.cls new file mode 100644 index 0000000..fb6aa09 --- /dev/null +++ b/src/test/s_VsoWrapper.cls @@ -0,0 +1,98 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_VsoWrapper" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' Note: Testing only functions different from API_WordWrapper +' TODO: test open document flags + +Private vso_ As API_VsoWrapper +Private fso_ As Scripting.FileSystemObject + +Public Function Setup() + ' Mandatory setup function + Set vso_ = New API_VsoWrapper + Call vso_.DisableMessages + Call vso_.CreateApplication + Set fso_ = New Scripting.FileSystemObject + Call EnsureFolderExists(Dev_GetTestFolder) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call fso_.DeleteFolder(Dev_GetTestFolder) + Call vso_.ReleaseApplication + Set vso_ = Nothing +End Function + +Public Function t_SaveAs() + On Error GoTo PROPAGATE_ERROR + + Dim sTemplate$: sTemplate = Dev_GetTestFolder & "\" & "testFile" + Dim sFile$: sFile = sTemplate & ".vsdx" + Dim sTarget$ + Dim oReader As New API_VsoWrapper + Call oReader.CreateApplication + Call oReader.DisableMessages + + Call Dev_NewCase("No document") + On Error Resume Next + Call Dev_ExpectFalse(vso_.SaveAs(sFile)) + Call Dev_ExpectNoError + On Error Resume Next + + Call vso_.NewDocument + Call vso_.Document.Pages(1).DrawRectangle(1, 1, 2, 2) + Call Dev_ExpectFalse(vso_.SaveAs("invalid!?"), "Invalid filename") + + Call Dev_NewCase("Save as vsdx") + sTarget = sTemplate & ".vsdx" + Call Dev_ExpectTrue(vso_.SaveAs(sTarget)) + Call vso_.ReleaseDocument(bCloseApplication:=False) + Call Dev_ExpectTrue(fso_.FileExists(sTarget), "File created") + Call Dev_AssertTrue(oReader.OpenDocument(sTarget), "Open saved document") + Call Dev_ExpectEQ(1, oReader.Document.Pages(1).Shapes.Count, "Validate contents") + Call oReader.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Save as vsdm") + Call vso_.OpenDocument(sFile) + sTarget = sTemplate & ".vsdm" + Call Dev_ExpectTrue(vso_.SaveAs(sTarget)) + Call vso_.ReleaseDocument(bCloseApplication:=False) + Call Dev_AssertTrue(fso_.FileExists(sTarget), "File created") + Call Dev_ExpectTrue(oReader.OpenDocument(sTarget), "Open saved document") + Call Dev_ExpectEQ(1, oReader.Document.Pages(1).Shapes.Count, "Validate contents") + Call oReader.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Save as vstx") + Call vso_.OpenDocument(sFile) + sTarget = sTemplate & ".vstx" + Call Dev_ExpectTrue(vso_.SaveAs(sTarget)) + Call vso_.ReleaseDocument(bCloseApplication:=False) + Call Dev_AssertTrue(fso_.FileExists(sTarget), "File created") + Call Dev_ExpectTrue(oReader.OpenDocument(sTarget), "Open saved document") + Call Dev_ExpectEQ(1, oReader.Document.Pages(1).Shapes.Count, "Validate contents") + Call oReader.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Save as vstm") + Call vso_.OpenDocument(sFile) + sTarget = sTemplate & ".vstm" + Call Dev_ExpectTrue(vso_.SaveAs(sTarget)) + Call vso_.ReleaseDocument(bCloseApplication:=False) + Call Dev_AssertTrue(fso_.FileExists(sTarget), "File created") + Call Dev_ExpectTrue(oReader.OpenDocument(sTarget), "Open saved document") + Call Dev_ExpectEQ(1, oReader.Document.Pages(1).Shapes.Count, "Validate contents") + Call oReader.ReleaseDocument(bCloseApplication:=False) + + Call oReader.ReleaseApplication + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_WordWrapper.cls b/src/test/s_WordWrapper.cls new file mode 100644 index 0000000..4827041 --- /dev/null +++ b/src/test/s_WordWrapper.cls @@ -0,0 +1,611 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_WordWrapper" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' TODO: test reset paused status +' TODO: test reporter + +Private fso_ As Scripting.FileSystemObject +Private word_ As API_WordWrapper + +Public Function Setup() + ' Mandatory setup function + Set word_ = New API_WordWrapper + Call word_.DisableMessages + Call word_.CreateApplication + Set fso_ = New Scripting.FileSystemObject + Call EnsureFolderExists(Dev_GetTestFolder) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call fso_.DeleteFolder(Dev_GetTestFolder) + Call word_.ReleaseApplication + Set word_ = Nothing +End Function + +Public Function t_CreateApplication() + On Error GoTo PROPAGATE_ERROR + + Dim word1 As New API_WordWrapper + Dim word2 As New API_WordWrapper + + Call Dev_NewCase("Create visible application") + Call Dev_AssertNotNothing(word1.CreateApplication(bIsVisible:=True)) + Call Dev_ExpectTrue(word1.Application.Visible) + + Call Dev_NewCase("Create hidden application") + Call Dev_AssertNotNothing(word2.CreateApplication(bIsVisible:=False)) + Call Dev_ExpectFalse(word2.Application.Visible) + + Call Dev_NewCase("Create application twice") + Dim app1 As Word.Application: Set app1 = word1.Application + Call Dev_ExpectNotNothing(app1, "Create 1st application") + Dim app2 As Word.Application: Set app2 = word1.CreateApplication + Call Dev_ExpectNotNothing(app2, "Create 2nd application") + Call Dev_ExpectObjectValid(app1, "Do not close first application before creating new") + + Call word1.ReleaseApplication + Call word2.ReleaseApplication + Call app1.Quit + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_SetApplication() + On Error GoTo PROPAGATE_ERROR + + Dim word1 As New API_WordWrapper + Dim word2 As New API_WordWrapper + Dim app1 As Word.Application: Set app1 = word1.CreateApplication(bIsVisible:=True) + + Call Dev_NewCase("Set application valid") + Call word2.SetApplication(app1) + Call Dev_ExpectEQ(app1, word2.Application) + + Call Dev_NewCase("Set application nothing") + Call word2.SetApplication(Nothing) + Call Dev_ExpectNothing(word2.Application) + + Call Dev_NewCase("Set self") + Call word1.SetApplication(word1.Application) + Call word1.ReleaseApplication + Call Dev_ExpectObjectInvalid(app1, "Do not reset ownership on self set") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_Destructor() + On Error GoTo PROPAGATE_ERROR + + Dim word1 As New API_WordWrapper + + Call Dev_NewCase("No application") + On Error Resume Next + Set word1 = Nothing + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Owned empty application") + Dim app1 As Word.Application: Set app1 = word1.CreateApplication + Set word1 = Nothing + Call Sleep(500) + Call Dev_ExpectObjectInvalid(app1) + + Call Dev_NewCase("Owned application with document") + Set word1 = New API_WordWrapper + Set app1 = word1.CreateApplication + Dim doc1 As Word.Document: Set doc1 = word1.NewDocument + Set word1 = Nothing + Call Dev_ExpectObjectValid(doc1, "Do not close document") + Call Dev_ExpectObjectValid(app1, "Do not close application") + + Call app1.Quit(SaveChanges:=False) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ReleaseApplication() + On Error GoTo PROPAGATE_ERROR + + Dim word1 As New API_WordWrapper + Dim word2 As New API_WordWrapper + + Call Dev_NewCase("No application") + On Error Resume Next + Call word1.ReleaseApplication + Call Dev_ExpectNoError + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Owned application") + Dim app1 As Word.Application: Set app1 = word1.CreateApplication + Call word1.ReleaseApplication + Call Dev_ExpectNothing(word1.Application, "Reset application") + Call Dev_ExpectObjectInvalid(app1, "Close application") + + Call Dev_NewCase("Non-owned application") + Set app1 = word1.CreateApplication + Call word2.SetApplication(app1) + Call word2.ReleaseApplication + Call Dev_ExpectNothing(word2.Application, "Reset application") + Call Dev_ExpectObjectValid(app1, "Do not close application") + Call word1.ReleaseApplication + + Call Dev_NewCase("Owned application with owned open document") + Set app1 = word1.CreateApplication + Dim doc1 As Word.Document: Set doc1 = word1.NewDocument + Call word1.ReleaseApplication + Call Dev_ExpectNothing(word1.Application, "Reset application") + Call Dev_ExpectObjectInvalid(doc1, "Close document") + Call Dev_ExpectObjectInvalid(app1, "Close application") + + Call Dev_NewCase("Owned application with non-owned open document") + Set app1 = word1.CreateApplication + Call word2.SetApplication(app1) + Set doc1 = word2.NewDocument + Call word1.ReleaseApplication + Call Dev_ExpectNothing(word1.Application, "Reset application") + Call Dev_ExpectNotNothing(word2.Application, "Do not reset shared application") + Call Dev_ExpectObjectInvalid(doc1, "Close document") + Call Dev_ExpectObjectInvalid(app1, "Close application") + + On Error Resume Next + Set word2 = Nothing + Call Dev_ExpectNoError("Terminate correctly invalid application") + On Error GoTo PROPAGATE_ERROR + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_NewDocument() + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Default template") + Call Dev_ExpectNotNothing(word_.NewDocument) + Call word_.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Custom template") + Dim sTemplate$: sTemplate = Dev_GetArtifactFolder & "\" & TEST_WORD_TEMPLATE + Call Dev_AssertNotNothing(word_.NewDocument(sTemplate)) + Call Dev_ExpectEQ("test123", word_.Document.Words.First.Text) + Call word_.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Missing template") + Call Dev_ExpectNothing(word_.NewDocument(sTemplate:="invalid", bDefaultIfFail:=False), "No deafult fallback") + Call Dev_AssertNotNothing(word_.NewDocument(sTemplate:="invalid", bDefaultIfFail:=True), "Default fallback") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_SetDocument() + On Error GoTo PROPAGATE_ERROR + + Dim word1 As New API_WordWrapper + Dim word2 As New API_WordWrapper + + Call Dev_NewCase("Set nothing to nothing") + On Error Resume Next + Call word_.SetDocument(Nothing) + Call Dev_ExpectNoError("No error") + On Error GoTo PROPAGATE_ERROR + Call Dev_ExpectNothing(word_.Document, "Document is set to nothing") + Call Dev_ExpectNotNothing(word_.Application, "Application is not reset") + + Call Dev_NewCase("Set valid document") + Call word1.SetApplication(word_.Application) + Dim doc1 As Word.Document: Set doc1 = word1.NewDocument + Call word_.SetDocument(doc1) + Call Dev_ExpectEQ(doc1, word_.Document, "Check document") + Call word_.SetDocument(Nothing) + Call Dev_ExpectNothing(word_.Document, "Set valid to nothing") + Call word1.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Set document from another application") + Call word2.CreateApplication + Call word1.SetApplication(word_.Application) + Set doc1 = word2.NewDocument + Call word1.SetDocument(doc1) + Call Dev_ExpectEQ(doc1, word1.Document, "Check document") + Call Dev_ExpectEQ(word2.Application, word1.Application, "Update application document") + Call word1.ReleaseDocument(bCloseApplication:=False) + Call Dev_ExpectObjectValid(doc1, "Do not transfer ownership") + Call word2.ReleaseApplication + + Call Dev_NewCase("Transfer document ownership") + Call word1.SetApplication(word_.Application) + Set doc1 = word1.NewDocument + Call word_.SetDocument(doc1, bOwnership:=True) + Call Dev_ExpectEQ(doc1, word_.Document, "Check document") + Call word_.ReleaseDocument(bCloseApplication:=False) + Call Dev_ExpectObjectInvalid(doc1, "Transfer ownership") + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_OpenDocumentRead() + On Error GoTo PROPAGATE_ERROR + + Dim word1 As New API_WordWrapper: Call word1.DisableMessages + Dim word2 As New API_WordWrapper: Call word2.DisableMessages + Dim doc1 As Word.Document + Dim doc2 As Word.Document + Dim sFile$: sFile = Dev_GetArtifactFolder & "\" & TEST_WORD_DOCUMENT + Dim sInvalid$: sInvalid = Dev_GetArtifactFolder & "\" & TEST_WORD_INVALID + Dim sText$: sText = "TestWord" + + Call Dev_NewCase("Invalid filename") + Call Dev_ExpectNothing(word1.OpenDocument("invalid", bReadOnly:=True), "Wrapper without application") + Call Dev_ExpectNothing(word1.Application, "Do not open application for invalid document") + Call Dev_ExpectNothing(word_.OpenDocument("invalid", bReadOnly:=True), "Wrapper with application") + Call Dev_ExpectObjectValid(word_.Application, "Do not reset application after failed document open") + + Call Dev_NewCase("Invalid file format") + Call Dev_ExpectNothing(word1.OpenDocument(sInvalid, bReadOnly:=True), "Wrapper without application") + Call Dev_ExpectNothing(word1.Application, "Do not open application for invalid document") + Call Dev_ExpectNothing(word_.OpenDocument(sInvalid, bReadOnly:=True), "Wrapper with application") + Call Dev_ExpectObjectValid(word_.Application, "Do not reset application after failed document open") + + Call Dev_NewCase("Valid file - existing application") + Call Dev_AssertNotNothing(word_.OpenDocument(sFile, bReadOnly:=True)) + Call Dev_ExpectEQ(sText, word_.Document.Words.First.Text) + Call Dev_ExpectNothing(word_.OpenDocument(sFile, bReadOnly:=True), "Cannot open another document while one is open already") + Call word_.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Valid file - borrowing application") + Call Dev_AssertNotNothing(word1.OpenDocument(sFile, bReadOnly:=True)) + Call Dev_ExpectEQ(sText, word1.Document.Words.First.Text) + Call Dev_ExpectEQ(word_.Application, word1.Application, "Already open application should be used") + Call word1.ReleaseDocument + Call word1.ReleaseApplication + Call Dev_ExpectObjectValid(word_.Application, "Do not claim ownership of borrowed application") + + Call Dev_NewCase("Valid file - no application") + Call word_.ReleaseApplication + Call Dev_AssertNotNothing(word_.OpenDocument(sFile, bReadOnly:=True)) + Call Dev_ExpectObjectValid(word_.Application, "Valid application") + Call word_.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Valid file - already open READONLY in same application") + Set doc1 = word_.OpenDocument(sFile, bReadOnly:=True) + Call word2.SetApplication(word_.Application) + Set doc2 = word2.OpenDocument(sFile, bReadOnly:=True) + Call Dev_AssertNotNothing(doc2, "Open file") + Call Dev_ExpectEQ(sText, doc2.Words.First.Text) + Call Dev_ExpectEQ(ObjPtr(doc1), ObjPtr(doc2), "Do not reopen same document") + Call word2.ReleaseDocument + Call Dev_ExpectObjectValid(doc1, "Do not claim ownership of borrowed document") + Call word_.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Valid file - already open MODIFY in same application") + Set doc1 = word_.OpenDocument(sFile, bReadOnly:=False) + Call word2.SetApplication(word_.Application) + Set doc2 = word2.OpenDocument(sFile, bReadOnly:=True) + Call Dev_AssertNotNothing(doc2, "Open file") + Call Dev_ExpectEQ(sText, doc2.Words.First.Text) + Call Dev_ExpectEQ(ObjPtr(doc1), ObjPtr(doc2), "Do not reopen same document") + Call word2.ReleaseDocument + Call Dev_ExpectObjectValid(doc1, "Do not claim ownership of borrowed document") + Call word_.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Valid file - already open in another application") + Call word2.CreateApplication + Set doc2 = word2.OpenDocument(sFile, bReadOnly:=True) + Call Dev_ExpectEQ(sText, doc2.Words.First.Text) + Call Dev_ExpectNE(ObjPtr(doc1), ObjPtr(doc2), "Reopen document in new application") + Call word2.ReleaseDocument + Call word2.ReleaseApplication + + Call word_.ReleaseDocument + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_OpenDocumentModify() + On Error GoTo PROPAGATE_ERROR + + Dim word1 As New API_WordWrapper: Call word1.DisableMessages + Dim word2 As New API_WordWrapper: Call word2.DisableMessages + Dim doc1 As Word.Document + Dim doc2 As Word.Document + Dim sFile$: sFile = Dev_GetTestFolder & "\" & TEST_WORD_DOCUMENT + Dim sText1$: sText1 = "TestWord" + Dim sText2$: sText2 = "Test1Word2" + + Call fso_.CopyFile(Dev_GetArtifactFolder & "\" & TEST_WORD_DOCUMENT, sFile) + + Call Dev_NewCase("Valid file - existing application") + Call Dev_AssertNotNothing(word_.OpenDocument(sFile, bReadOnly:=False)) + Call Dev_ExpectEQ(sText1, word_.Document.Words.First.Text, "Validate opened file") + word_.Document.Words.First = sText2 + Call word_.ReleaseDocument(bCloseApplication:=False, bSaveChanges:=True) + Call Dev_AssertNotNothing(word_.OpenDocument(sFile, bReadOnly:=True)) + Call Dev_ExpectEQ(sText2, word_.Document.Words.First.Text, "Confirm modification") + Call word_.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Readonly file") + fso_.GetFile(sFile).Attributes = ReadOnly + Call Dev_ExpectNothing(word_.OpenDocument(sFile, bReadOnly:=False)) + Call Dev_ExpectNotNothing(word_.OpenDocument(sFile, bReadOnly:=True)) + Call word_.ReleaseDocument(bCloseApplication:=False) + fso_.GetFile(sFile).Attributes = Normal + + Call Dev_NewCase("Valid file - already open MODIFY in same application") + Call word_.OpenDocument(sFile, bReadOnly:=False) + Call word2.SetApplication(word_.Application) + Set doc2 = word2.OpenDocument(sFile, bReadOnly:=False) + Call Dev_ExpectNotNothing(doc2, "Find already opened file") + Call Dev_ExpectEQ(ObjPtr(word_.Document), ObjPtr(doc2), "Get same document") + Call word2.ReleaseDocument(bCloseApplication:=False) + Call word_.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Valid file - already open READONLY in same application") + Call word_.OpenDocument(sFile, bReadOnly:=True) + Call word2.SetApplication(word_.Application) + Call Dev_ExpectNothing(word2.OpenDocument(sFile, bReadOnly:=False), "Do not open blocked document") + Call word_.ReleaseDocument(bCloseApplication:=False) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_ReleaseDocument() + On Error GoTo PROPAGATE_ERROR + + Dim word1 As New API_WordWrapper: Call word1.DisableMessages + Dim word2 As New API_WordWrapper: Call word2.DisableMessages + Dim sFile$: sFile = Dev_GetTestFolder & "\" & TEST_WORD_DOCUMENT + Dim doc1 As Word.Document + Dim doc2 As Word.Document + Dim app1 As Word.Application + Dim sText$: sText = "TestWord" + + Set app1 = word_.Application + + Call Dev_NewCase("Empty wrapper") + Call Dev_ExpectFalse(word1.ReleaseDocument) + + Call Dev_NewCase("No open document") + Call Dev_ExpectFalse(word_.ReleaseDocument(bCloseApplication:=False), "Do not force close application") + Call Dev_ExpectNotNothing(word_.Application, "Do not reset application") + Call Dev_ExpectObjectValid(app1, "Do not close application") + Call Dev_ExpectFalse(word_.ReleaseDocument(bCloseApplication:=True), "Force close application") + Call Dev_ExpectNotNothing(word_.Application, "Do not reset application") + Call Dev_ExpectObjectValid(app1, "Do not close application") + + Call Dev_NewCase("Release owned document - newly created no save changes") + Set doc1 = word_.NewDocument + doc1.Words.First = sText + Call Dev_ExpectTrue(word_.ReleaseDocument(bCloseApplication:=False, bSaveChanges:=False)) + Call Dev_ExpectNotNothing(word_.Application, "Do not reset application") + Call Dev_ExpectNothing(word_.Document, "Reset document") + Call Dev_ExpectObjectValid(app1, "Do not close application") + Call Dev_ExpectObjectInvalid(doc1, "Close document") + + Call Dev_NewCase("Release owned document - newly created save changes") + Set doc1 = word_.NewDocument + doc1.Words.First = sText + Call Dev_ExpectTrue(word_.ReleaseDocument(bCloseApplication:=False, bSaveChanges:=True)) + Call Dev_ExpectNotNothing(word_.Application, "Do not reset application") + Call Dev_ExpectNothing(word_.Document, "Reset document") + Call Dev_ExpectObjectInvalid(doc1, "Close document") + Call Dev_ExpectObjectValid(app1, "Do not close application") + + Call Dev_NewCase("Release owned document - dont save changes") + Set doc1 = word_.NewDocument + Call word_.SaveAs(sFile) + word_.Document.Words.First = sText + Call Dev_ExpectTrue(word_.ReleaseDocument(bCloseApplication:=False, bSaveChanges:=False)) + Call Dev_ExpectNothing(word_.Document, "Reset document") + Call Dev_ExpectNotNothing(word_.Application, "Do not reset application") + Call Dev_ExpectObjectInvalid(doc1, "Close document") + Call Dev_ExpectObjectValid(app1, "Do not close application") + Call word_.OpenDocument(sFile, bReadOnly:=False) + Call Dev_ExpectNE(sText, word_.Document.Words.First, "Do not save changes") + Call word_.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Release owned document - save changes") + Set doc1 = word_.NewDocument + Call word_.SaveAs(sFile) + word_.Document.Words.First = sText + Call Dev_ExpectTrue(word_.ReleaseDocument(bCloseApplication:=False, bSaveChanges:=True)) + Call Dev_ExpectNothing(word_.Document, "Reset document") + Call Dev_ExpectNotNothing(word_.Application, "Do not reset application") + Call Dev_ExpectObjectInvalid(doc1, "Close document") + Call Dev_ExpectObjectValid(app1, "Do not close application") + Call word_.OpenDocument(sFile, bReadOnly:=False) + Call Dev_ExpectEQ(sText, word_.Document.Words.First, "Save changes") + Call word_.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Release owned document - close app") + Set doc1 = word_.NewDocument + Call Dev_ExpectTrue(word_.ReleaseDocument(bCloseApplication:=True, bSaveChanges:=True)) + Call Dev_ExpectNothing(word_.Document, "Reset document") + Call Dev_ExpectNothing(word_.Application, "Reset application") + Call Dev_ExpectObjectInvalid(doc1, "Close document") + Call Dev_ExpectObjectInvalid(app1, "Close application") + + Call Dev_NewCase("Release non-owned document") + Set doc1 = word1.NewDocument + Call word2.SetDocument(doc1, bOwnership:=False) + Call Dev_ExpectTrue(word2.ReleaseDocument) + Call Dev_ExpectNothing(word2.Document, "Reset document") + Call Dev_ExpectNotNothing(word1.Document, "Do not reset owner") + Call Dev_ExpectObjectValid(doc1, "Do not close document") + Call word1.ReleaseDocument + + Call Dev_NewCase("Release owned dangling document") + Set doc1 = word1.NewDocument + Call word2.SetDocument(doc1, bOwnership:=True) + Call word1.ReleaseDocument + Call Dev_ExpectObjectInvalid(doc1, "Close document") + Call Dev_ExpectFalse(word2.ReleaseDocument) + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_PauseUI() + On Error GoTo PROPAGATE_ERROR + + Dim word1 As New API_WordWrapper + Dim doc As Word.Document + + Call Dev_NewCase("Empty wrapper") + On Error Resume Next + Call word1.PauseUI + Call Dev_ExpectNoError + Call Dev_ExpectFalse(word1.IsUIPaused, "Pause") + On Error Resume Next + Call word1.ResumeUI + Call Dev_ExpectNoError + Call Dev_ExpectFalse(word1.IsUIPaused, "Resume") + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("No document") + On Error Resume Next + Call word_.PauseUI + Call Dev_ExpectNoError + Call Dev_ExpectFalse(word_.IsUIPaused) + On Error Resume Next + Call word_.ResumeUI + Call Dev_ExpectNoError + Call Dev_ExpectFalse(word_.IsUIPaused) + On Error GoTo PROPAGATE_ERROR + + Call Dev_NewCase("Owned document") + Set doc = word_.NewDocument + Call Dev_ExpectTrue(word_.Application.ScreenUpdating) + Call word_.PauseUI + Call Dev_ExpectTrue(word_.IsUIPaused, "Pause") + Call Dev_ExpectFalse(word_.Application.ScreenUpdating, "Pause") + Call word_.ResumeUI + Call Dev_ExpectFalse(word_.IsUIPaused, "Resume") + Call Dev_ExpectTrue(word_.Application.ScreenUpdating, "Resume") + Call word_.ReleaseDocument + + Call Dev_NewCase("Non-owned document") + Set doc = word1.NewDocument + Call word_.SetDocument(doc, bOwnership:=False) + Call word_.PauseUI + Call Dev_ExpectTrue(word_.IsUIPaused, "Pause") + Call Dev_ExpectFalse(word1.IsUIPaused, "Do not pause owner") + Call Dev_ExpectFalse(word_.Application.ScreenUpdating, "Pause") + Call word_.ResumeUI + Call Dev_ExpectFalse(word_.IsUIPaused, "Resume") + Call Dev_ExpectTrue(word_.Application.ScreenUpdating, "Resume") + + Call Dev_NewCase("Overlapped pause different wrappers") + Call word_.PauseUI + Call word1.PauseUI + Call Dev_ExpectTrue(word_.IsUIPaused, "Pause") + Call Dev_ExpectTrue(word1.IsUIPaused, "Pause") + Call Dev_ExpectFalse(word_.Application.ScreenUpdating, "Pause") + Call word1.ResumeUI + Call Dev_ExpectFalse(word1.IsUIPaused, "Resume inner") + Call Dev_ExpectTrue(word_.IsUIPaused, "Do not resume outer") + Call Dev_ExpectFalse(word_.Application.ScreenUpdating, "Do not enable UI") + Call word_.ResumeUI + Call Dev_ExpectFalse(word1.IsUIPaused, "Resume inner") + Call Dev_ExpectFalse(word_.IsUIPaused, "Resume outer") + Call Dev_ExpectTrue(word_.Application.ScreenUpdating, "Enable UI") + + Call word1.ReleaseDocument + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function + +Public Function t_SaveAs() + On Error GoTo PROPAGATE_ERROR + + Dim sFile$: sFile = Dev_GetTestFolder & "\" & TEST_WORD_DOCUMENT + Dim sTemplate$: sTemplate = Dev_GetTestFolder & "\" & "testFile" + Dim sText$: sText = "TestWord" + Dim sTarget$ + Call fso_.CopyFile(Dev_GetArtifactFolder & "\" & TEST_WORD_DOCUMENT, sFile) + Dim oReader As New API_WordWrapper + Call oReader.CreateApplication + Call oReader.DisableMessages + + Call Dev_NewCase("No document") + On Error Resume Next + Call Dev_ExpectFalse(word_.SaveAs(sTemplate & ".docx")) + Call Dev_ExpectNoError + On Error Resume Next + + Call Dev_AssertTrue(word_.OpenDocument(sFile)) + Call Dev_ExpectFalse(word_.SaveAs("invalid!?"), "Invalid filename") + + Call Dev_NewCase("Save as docx") + sTarget = sTemplate & ".docx" + Call Dev_ExpectTrue(word_.SaveAs(sTarget)) + Call Dev_AssertTrue(fso_.FileExists(sTarget), "File created") + Call Dev_ExpectTrue(oReader.OpenDocument(sTarget, bReadOnly:=True), "Open saved document") + Call Dev_ExpectEQ(sText, oReader.Document.Words.First, "Validate contents") + Call oReader.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Save as docm") + sTarget = sTemplate & ".docm" + Call Dev_ExpectTrue(word_.SaveAs(sTarget)) + Call Dev_AssertTrue(fso_.FileExists(sTarget), "File created") + Call Dev_ExpectTrue(oReader.OpenDocument(sTarget, bReadOnly:=True), "Open saved document") + Call Dev_ExpectEQ(sText, oReader.Document.Words.First, "Validate contents") + Call oReader.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Save as dotx") + sTarget = sTemplate & ".dotx" + Call Dev_ExpectTrue(word_.SaveAs(sTarget)) + Call Dev_AssertTrue(fso_.FileExists(sTarget), "File created") + Call Dev_ExpectTrue(oReader.OpenDocument(sTarget, bReadOnly:=True), "Open saved document") + Call Dev_ExpectEQ(sText, oReader.Document.Words.First, "Validate contents") + Call oReader.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Save as dotm") + sTarget = sTemplate & ".dotm" + Call Dev_ExpectTrue(word_.SaveAs(sTarget)) + Call Dev_AssertTrue(fso_.FileExists(sTarget), "File created") + Call Dev_ExpectTrue(oReader.OpenDocument(sTarget, bReadOnly:=True), "Open saved document") + Call Dev_ExpectEQ(sText, oReader.Document.Words.First, "Validate contents") + Call oReader.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Overwrite") + sTarget = sTemplate & ".docx" + sText = "test2" + word_.Document.Words.First = sText + Call Dev_ExpectTrue(word_.SaveAs(sTarget)) + Call Dev_AssertTrue(fso_.FileExists(sTarget), "File created") + Call Dev_ExpectTrue(oReader.OpenDocument(sTarget, bReadOnly:=True), "Open saved document") + Call Dev_ExpectEQ(sText, oReader.Document.Words.First, "Validate contents") + Call oReader.ReleaseDocument(bCloseApplication:=False) + + Call oReader.ReleaseApplication + Call word_.ReleaseDocument + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/test/s_XLWrapper.cls b/src/test/s_XLWrapper.cls new file mode 100644 index 0000000..016f570 --- /dev/null +++ b/src/test/s_XLWrapper.cls @@ -0,0 +1,100 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "s_XLWrapper" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit + +' Note: Testing only functions different from API_WordWrapper +' TODO: test OpenDocument with ignore folder + +Private xl_ As API_XLWrapper +Private fso_ As Scripting.FileSystemObject + +Public Function Setup() + ' Mandatory setup function + Set xl_ = New API_XLWrapper + Call xl_.DisableMessages + Call xl_.CreateApplication + Set fso_ = New Scripting.FileSystemObject + Call EnsureFolderExists(Dev_GetTestFolder) +End Function + +Public Function Teardown() + ' Mandatory teardown function + Call fso_.DeleteFolder(Dev_GetTestFolder) + Call xl_.ReleaseApplication + Set xl_ = Nothing +End Function + +Public Function t_SaveAs() + On Error GoTo PROPAGATE_ERROR + + Dim sTemplate$: sTemplate = Dev_GetTestFolder & "\" & "testFile" + Dim sText$: sText = "TestWord" + Dim sTarget$ + Dim oReader As New API_XLWrapper + Call oReader.CreateApplication + Call oReader.DisableMessages + + Call Dev_NewCase("No document") + On Error Resume Next + Call Dev_ExpectFalse(xl_.SaveAs(sTemplate & ".xlsx")) + Call Dev_ExpectNoError + On Error Resume Next + + Call xl_.NewDocument + xl_.Document.Worksheets(1).Cells(1, 1) = sText + Call Dev_ExpectFalse(xl_.SaveAs("invalid!?"), "Invalid filename") + + Call Dev_NewCase("Save as xlsx") + sTarget = sTemplate & ".xlsx" + Call Dev_ExpectTrue(xl_.SaveAs(sTarget)) + Call Dev_AssertTrue(fso_.FileExists(sTarget), "File created") + Call Dev_ExpectTrue(oReader.OpenDocument(sTarget, bReadOnly:=True), "Open saved document") + Call Dev_ExpectEQ(sText, oReader.Document.Worksheets(1).Cells(1, 1).Text, "Validate contents") + Call oReader.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Save as xlsm") + sTarget = sTemplate & ".xlsm" + Call Dev_ExpectTrue(xl_.SaveAs(sTarget)) + Call Dev_AssertTrue(fso_.FileExists(sTarget), "File created") + Call Dev_ExpectTrue(oReader.OpenDocument(sTarget, bReadOnly:=True), "Open saved document") + Call Dev_ExpectEQ(sText, oReader.Document.Worksheets(1).Cells(1, 1).Text, "Validate contents") + Call oReader.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Save as xltx") + sTarget = sTemplate & ".xltx" + Call Dev_ExpectTrue(xl_.SaveAs(sTarget)) + Call Dev_AssertTrue(fso_.FileExists(sTarget), "File created") + Call Dev_ExpectTrue(oReader.OpenDocument(sTarget, bReadOnly:=True), "Open saved document") + Call Dev_ExpectEQ(sText, oReader.Document.Worksheets(1).Cells(1, 1).Text, "Validate contents") + Call oReader.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Save as xltm") + sTarget = sTemplate & ".xltm" + Call Dev_ExpectTrue(xl_.SaveAs(sTarget)) + Call Dev_AssertTrue(fso_.FileExists(sTarget), "File created") + Call Dev_ExpectTrue(oReader.OpenDocument(sTarget, bReadOnly:=True), "Open saved document") + Call Dev_ExpectEQ(sText, oReader.Document.Worksheets(1).Cells(1, 1).Text, "Validate contents") + Call oReader.ReleaseDocument(bCloseApplication:=False) + + Call Dev_NewCase("Save as xlam") + sTarget = sTemplate & ".xlam" + Call Dev_ExpectTrue(xl_.SaveAs(sTarget)) + Call Dev_AssertTrue(fso_.FileExists(sTarget), "File created") + Call Dev_ExpectTrue(oReader.OpenDocument(sTarget, bReadOnly:=True), "Open saved document") + Call Dev_ExpectEQ(sText, oReader.Document.Worksheets(1).Cells(1, 1).Text, "Validate contents") + Call oReader.ReleaseDocument(bCloseApplication:=False) + + Call xl_.ReleaseDocument + Call oReader.ReleaseApplication + + Exit Function +PROPAGATE_ERROR: + Call Dev_LogError(Err.Number, Err.Description) +End Function diff --git a/src/visio/Declarations.bas b/src/visio/Declarations.bas new file mode 100644 index 0000000..645a9cf --- /dev/null +++ b/src/visio/Declarations.bas @@ -0,0 +1,8 @@ +Attribute VB_Name = "Declarations" +Option Private Module +Option Explicit + +Public Const MASTER_ELEMENT = "SimpleElement" +Public Const MASTER_LIST = "ListContainer" +Public Const MASTER_CONTAINER = "MembersContainer" +Public Const MASTER_CONNECTOR = "Connector" diff --git a/src/visio/DevHelper.bas b/src/visio/DevHelper.bas new file mode 100644 index 0000000..8096c8b --- /dev/null +++ b/src/visio/DevHelper.bas @@ -0,0 +1,25 @@ +Attribute VB_Name = "DevHelper" +Option Explicit + +Public Function Dev_PrepareSkeleton() + ' Do nothing + Call ClearAll +End Function + +Public Sub Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_VsoUtilities" + Dim sTest$: sTest = "t_VsoIsMovable" + Dim sMsg$: sMsg = Dev_RunTestDebug(sSuite, sTest) + Debug.Print sMsg + Call MsgBox(sMsg) +End Sub + +Public Function Dev_GetTestSuite(sName$) As Object + Select Case sName + Case "s_UndoWrapper": Set Dev_GetTestSuite = New s_UndoWrapper + Case "s_Factorizator": Set Dev_GetTestSuite = New s_Factorizator + Case "s_VsoExtension": Set Dev_GetTestSuite = New s_VsoExtension + Case "s_VsoGraph": Set Dev_GetTestSuite = New s_VsoGraph + Case "s_VsoUtilities": Set Dev_GetTestSuite = New s_VsoUtilities + End Select +End Function diff --git a/src/visio/Main.bas b/src/visio/Main.bas new file mode 100644 index 0000000..e471a10 --- /dev/null +++ b/src/visio/Main.bas @@ -0,0 +1,7 @@ +Attribute VB_Name = "Main" +Option Private Module +Option Explicit + +Public Sub ClearAll() + Call VsoClearPage(ActivePage) +End Sub diff --git a/src/visio/MainImpl.bas b/src/visio/MainImpl.bas new file mode 100644 index 0000000..50e4abe --- /dev/null +++ b/src/visio/MainImpl.bas @@ -0,0 +1,4 @@ +Attribute VB_Name = "MainImpl" +Option Private Module +Option Explicit + diff --git a/src/word/Declarations.bas b/src/word/Declarations.bas new file mode 100644 index 0000000..c8583e3 --- /dev/null +++ b/src/word/Declarations.bas @@ -0,0 +1,4 @@ +Attribute VB_Name = "Declarations" +Option Private Module +Option Explicit + diff --git a/src/word/DevHelper.bas b/src/word/DevHelper.bas new file mode 100644 index 0000000..eeb3620 --- /dev/null +++ b/src/word/DevHelper.bas @@ -0,0 +1,20 @@ +Attribute VB_Name = "DevHelper" +Option Explicit + +Public Function Dev_PrepareSkeleton() + ' Do nothing +End Function + +Public Sub Dev_ManualRunTest() + Dim sSuite$: sSuite = "s_TextEdit" + Dim sTest$: sTest = "t_AdjustRange" + Dim sMsg$: sMsg = Dev_RunTestDebug(sSuite, sTest) + Debug.Print sMsg + Call MsgBox(sMsg) +End Sub + +Public Function Dev_GetTestSuite(sName$) As Object + Select Case sName + Case "s_TextEdit": Set Dev_GetTestSuite = New s_TextEdit + End Select +End Function diff --git a/src/word/Main.bas b/src/word/Main.bas new file mode 100644 index 0000000..e50484d --- /dev/null +++ b/src/word/Main.bas @@ -0,0 +1,3 @@ +Attribute VB_Name = "Main" +Option Private Module +Option Explicit diff --git a/src/word/MainImpl.bas b/src/word/MainImpl.bas new file mode 100644 index 0000000..50e4abe --- /dev/null +++ b/src/word/MainImpl.bas @@ -0,0 +1,4 @@ +Attribute VB_Name = "MainImpl" +Option Private Module +Option Explicit + diff --git a/test/TestInvalid.docx b/test/TestInvalid.docx new file mode 100644 index 0000000..b5a22d3 Binary files /dev/null and b/test/TestInvalid.docx differ diff --git a/test/TestWord.docx b/test/TestWord.docx new file mode 100644 index 0000000..2dab4f2 Binary files /dev/null and b/test/TestWord.docx differ diff --git a/test/testTemplate.dotx b/test/testTemplate.dotx new file mode 100644 index 0000000..8162010 Binary files /dev/null and b/test/testTemplate.dotx differ diff --git a/ui/.rels b/ui/.rels new file mode 100644 index 0000000..3107a8e --- /dev/null +++ b/ui/.rels @@ -0,0 +1,2 @@ + + \ No newline at end of file diff --git a/ui/customUI.xml b/ui/customUI.xml new file mode 100644 index 0000000..aa32755 --- /dev/null +++ b/ui/customUI.xml @@ -0,0 +1,199 @@ + + + + + + +