120 lines
3.4 KiB
OpenEdge ABL
120 lines
3.4 KiB
OpenEdge ABL
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
|