VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "API_TestRunner"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'================ VBA tests runner =============
' Shared module version: 20220410
' Depends on: DevTester, DevTools, DataTools, API_Logger, CDS_InfoTests, CDS_InfoFunction, API_Timer
' Required reference: Scripting, VBIDE, Word, Excel, Visio
Option Explicit

Public testsDB_ As Scripting.Dictionary ' Value = Collection of tests
Private target_ As Object ' Wrapper
Private logger_ As API_Logger
Private timer_ As API_Timer

' Sink object should implement function PushTestResult(sSuite$, sTest$, bResult As Boolean, sMsg$, dDuration as Double)
Private sink_ As Object

Private Sub Class_Initialize()
  Set timer_ = New API_Timer
End Sub

Private Sub Class_Terminate()
  Set target_ = Nothing
End Sub

Public Function Init(targetWrapper As Object, oLog As API_Logger, Optional oSink As Object = Nothing)
  Set target_ = targetWrapper
  Set logger_ = oLog
  Set sink_ = oSink
  Set testsDB_ = New Scripting.Dictionary
End Function

Public Function ScanTests() As Boolean
  On Error GoTo RETURN_FALSE
  
  Call logger_.Log("Scanning for tests...")
  Dim nCount&: nCount = Dev_ScanTests(target_.Document.VBProject, testsDB_)
  ScanTests = True
  Call logger_.Log("Found tests: " & nCount)
  Exit Function
  
RETURN_FALSE:
  ScanTests = False
  Call logger_.Log("Failed to scan tests. Error code " & Err.Number & ":" & Err.Description)
End Function

Public Function RunAllTests() As CDS_InfoTests
  If Not ScanTests Then _
    Exit Function

  Dim iResult As New CDS_InfoTests
  Dim sSuite As Variant
  Dim tests As Collection
  For Each sSuite In testsDB_
    Set tests = testsDB_(sSuite)
    Dim sTest As Variant
    For Each sTest In tests
      Call iResult.AddTest(RunTest(CStr(sSuite), CStr(sTest)))
    Next sTest
  Next sSuite

  Set RunAllTests = iResult
End Function

Public Function RunTest(sSuite$, sTest$) As Boolean
  RunTest = False
  
  Call timer_.Start
  On Error GoTo CANNOT_RUN
  Dim sMsg$: sMsg = RunInternal(sSuite, sTest)
  On Error GoTo 0
  
  RunTest = sMsg = "OK"
  If Not sink_ Is Nothing Then _
    Call sink_.PushTestResult(sSuite, sTest, RunTest, sMsg, timer_.TimeElapsed)
  Call logger_.Log(sSuite & "." & sTest & " ... " & sMsg)
  
  Exit Function
CANNOT_RUN:
  Call logger_.Log(sSuite & "." & sTest & " ... " & "Failed to run the test")
End Function

' =====
Private Function RunInternal(sSuite$, sTest$) As String
  If TypeOf target_.Application Is Visio.Application Then
    RunInternal = RunFileIO(sSuite, sTest)
  Else
    RunInternal = target_.Run("DevTester.Dev_RunTest", sSuite, sTest)
  End If
End Function

Private Function RunFileIO(sSuite$, sTest$) As String
  Const UTF16_MODE = TristateTrue
  
  Dim sFileName$: sFileName = target_.Document.Name & "_IO.txt"
  Dim sPath$: sPath = target_.Document.Path & sFileName

  Dim fso As New Scripting.FileSystemObject
  If fso.FileExists(sPath) Then _
    Call fso.DeleteFile(sPath)
  
  Call target_.Run("Dev_RunTestFileIO", sSuite, sTest, sFileName)
  
  If Not fso.FileExists(sPath) Then
    Call logger_.Log(sSuite & "." & sTest & " ... " & "Failed to run the test")
    Exit Function
  End If
  
  Dim fs As Scripting.TextStream: Set fs = fso.OpenTextFile(sPath, ForReading, Format:=UTF16_MODE)
  RunFileIO = fs.ReadAll
  Call fs.Close
  Call fso.DeleteFile(sPath)
End Function