Building on @RubberDuck's recommendations, I now have something I find... beautiful. I'm sure there's a couple of things left to polish - this site is about making great code out of good any code, right?
This code requires trusted programmatic access to Visual Basic Project.
1. Client Code
I want my test classes to look like this:
TestClass1 class module (client code)
Option Explicit
Public Sub ThisIsNoTest()
Err.Raise 5
End Sub
'@TestMethod
Public Sub MagicCommentWorks()
End Sub
Public Sub TestAreEqual()
assert.AreEqual 12, 12, "Values should be equal."
End Sub
Public Sub TestAreNotEqual()
assert.AreNotEqual 12, 34, "Values should not be equal."
End Sub
Public Sub TestAreSame()
assert.AreSame New Collection, New Collection, "Objects should be same reference."
End Sub
Public Sub TestAreNotSame()
assert.AreNotSame New Collection, New Collection, "Objects should not be the same reference."
End Sub
Public Sub TestFail()
assert.Fail "This wasn't meant to be."
End Sub
Public Sub TestInconclusive()
assert.Inconclusive "No idea."
End Sub
Public Sub TestIsFalse()
assert.IsFalse False, "True should be False."
End Sub
Public Sub TestIsNothing()
Dim foo As Object
assert.IsNothing foo, "Foo should be nothing."
End Sub
Public Sub TestIsNotNothing()
Dim foo As New Collection
assert.IsNotNothing foo, "Foo shouldn't be nothing."
End Sub
Public Sub TestIsTrue()
assert.IsTrue True, "False should be True."
End Sub
Public Sub TestBlowUp()
assert.IsTrue True
assert.AreEqual False, True
Debug.Print 1 / 0
assert.Fail "Test should have failed by now."
End Sub
Public Sub TestNoAssert()
End Sub
Output
I want to be able to run my tests from a simple "command-line" call in the immediate pane:
TestEngine.RunAllTests "VBAProject", New TestClass1
Registered test: TestClass1.MagicCommentWorks
Registered test: TestClass1.TestAreEqual
Registered test: TestClass1.TestAreNotEqual
Registered test: TestClass1.TestAreSame
Registered test: TestClass1.TestAreNotSame
Registered test: TestClass1.TestFail
Registered test: TestClass1.TestInconclusive
Registered test: TestClass1.TestIsFalse
Registered test: TestClass1.TestIsNothing
Registered test: TestClass1.TestIsNotNothing
Registered test: TestClass1.TestIsTrue
Registered test: TestClass1.TestBlowUp
Registered test: TestClass1.TestNoAssert
2014-09-16 00:24:20 MagicCommentWorks: [INCONCLUSIVE] - No assertions made.
2014-09-16 00:24:20 TestAreEqual: [PASS]
2014-09-16 00:24:20 TestAreNotEqual: [PASS]
2014-09-16 00:24:20 TestAreSame: [FAIL] - AreSame failed: Objects should be same reference.
2014-09-16 00:24:20 TestAreNotSame: [PASS]
2014-09-16 00:24:20 TestFail: [FAIL] - Fail failed: This wasn't meant to be.
2014-09-16 00:24:20 TestInconclusive: [PASS]
2014-09-16 00:24:20 TestIsFalse: [PASS]
2014-09-16 00:24:20 TestIsNothing: [PASS]
2014-09-16 00:24:20 TestIsNotNothing: [PASS]
2014-09-16 00:24:20 TestIsTrue: [PASS]
2014-09-16 00:24:20 TestBlowUp: [INCONCLUSIVE] - Test raised an error: Division by zero
2014-09-16 00:24:20 TestNoAssert: [INCONCLUSIVE] - No assertions made.
The client code must reference an Excel add-ins:
- UnitTesting contains the test engine.
That's all. UnitTesting
references these .xlam Excel add-ins:
System contains the
Framework
"namespace", which exposes custom types such asList
andTuple
as well as various string helper methods in theStrings
"namespace".Reflection is used by the UnitTesting add-in, and references the Microsoft Visual Basic for Applications Extensibility 5.3 library, as well as the System add-in.
I'm mostly interested on feedback about the UnitTesting
project, but the Reflection
project is also open to critics!
2. UnitTesting
Provided that the add-in's dependencies are installed, this module is the only add-in that the client code must reference (although nothing forbids also referencing System).
The only thing the client code needs to know about, is the TestEngine
's default instance.
TestEngine class module
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "TestEngine"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
Private Type TTestEngine
Output As ITestOutput
RegisteredTests As Dictionary
CurrentTest As String
CurrentTestResults As List
End Type
Private WithEvents assertion As Assert
Attribute assertion.VB_VarHelpID = -1
Private this As TTestEngine
Public Sub RunAllTests(ByVal projectName As String, ByRef classInstance As Object)
Set this.RegisteredTests = ReflectTestMethods(projectName, classInstance)
Dim test As Variant
For Each test In this.RegisteredTests
RunTest test
Next
End Sub
Private Function ReflectTestMethods(ByVal projectName As String, ByRef classInstance As Object) As Dictionary
Dim classMethods As List
Set classMethods = ClassModule.GetMethods(projectName, TypeName(classInstance))
Dim result As New Dictionary
Dim prospect As Method
For Each prospect In classMethods
If CanAddTestMethod(prospect, result) Then
result.Add prospect.name, Tuple.Create(classInstance, prospect.name)
Debug.Print "Registered test: " & TypeName(classInstance) & "." & prospect.name
End If
Next
Set ReflectTestMethods = result
End Function
Private Function CanAddTestMethod(ByVal prospect As Method, ByRef testMethods As Dictionary) As Boolean
Dim result As Boolean
If Not IsTestMethodName(prospect) Then Exit Function
If testMethods.Exists(prospect.name) Then Exit Function
CanAddTestMethod = True
End Function
Private Function IsTestMethodName(ByVal testMethod As Method) As Boolean
IsTestMethodName = _
Framework.Strings.StartsWith("Test", testMethod.name, False) Or _
Framework.Strings.StartsWith("'@TestMethod", Split(testMethod.Body, vbNewLine)(1), False)
End Function
Private Sub RunTest(ByVal name As String)
this.CurrentTest = name
Set this.CurrentTestResults = List.Create
Dim result As TestResult
On Error GoTo CleanFail
Dim testOutput As New DebugTestOutput
Set this.Output = testOutput
Dim test As Tuple
Set test = this.RegisteredTests(name)
CallByName test.Item1, test.Item2, VbMethod
If this.CurrentTestResults.Count = 0 Then
Set result = TestResult.Create(Inconclusive, "No assertions made.")
ElseIf CurrentTestFailedResults.Count = 0 Then
Set result = TestResult.Create(Succeeded)
ElseIf CurrentTestFailedResults.Count > 0 Then
Set result = CurrentTestFailedResults.First
End If
CleanExit:
this.Output.WriteResult this.CurrentTest, result
this.CurrentTest = vbNullString
Exit Sub
CleanFail:
Set result = TestResult.Create(Inconclusive, "Test raised an error: " & Err.Description)
Resume CleanExit
End Sub
Private Function CurrentTestFailedResults() As List
Dim resultList As List
Set resultList = List.Create
Dim result As TestResult
For Each result In this.CurrentTestResults
If result.TestOutcome = Failed Then resultList.Add result
Next
Set CurrentTestFailedResults = resultList
End Function
Private Sub assertion_Completed(ByVal result As TestResult)
this.CurrentTestResults.Add result
If result.TestOutcome = Failed And CurrentTestFailedResults.Count = 0 Then
this.Output.WriteResult this.CurrentTest, result
End If
End Sub
Private Sub Class_Initialize()
Set assertion = Assert.DefaultInstance
End Sub
Assert class module
The Assert
class has undergone a thorough simplification:
Public Event Completed(ByVal result As TestResult)
Option Explicit
Private Sub OnAssertSucceeded()
RaiseEvent Completed(TestResult.Create(Succeeded))
End Sub
Private Sub OnAssertFailed(ByVal name As String, ByVal message As String)
RaiseEvent Completed(TestResult.Create(Failed, name & " failed: " & message))
End Sub
Private Sub OnAssertInconclusive(ByVal message As String)
RaiseEvent Completed(TestResult.Create(0, message))
End Sub
Public Property Get DefaultInstance() As Assert
Set DefaultInstance = Me
End Property
Public Sub IsTrue(ByVal condition As Boolean, Optional ByVal message As String)
If condition Then
OnAssertSucceeded
Else
OnAssertFailed "IsTrue", message
End If
End Sub
Public Sub IsFalse(ByVal condition As Boolean, Optional ByVal message As String)
If Not condition Then
OnAssertSucceeded
Else
OnAssertFailed "IsFalse", message
End If
End Sub
Public Sub Inconclusive(Optional ByVal message As String)
OnAssertInconclusive message
End Sub
Public Sub Fail(Optional ByVal message As String)
OnAssertFailed "Fail", message
End Sub
Public Sub IsNothing(ByVal value As Object, Optional ByVal message As String)
If value Is Nothing Then
OnAssertSucceeded
Else
OnAssertFailed "IsNothing", message
End If
End Sub
Public Sub IsNotNothing(ByVal value As Object, Optional ByVal message As String)
If Not value Is Nothing Then
OnAssertSucceeded
Else
OnAssertFailed "IsNotNothing", message
End If
End Sub
Public Sub AreEqual(ByVal value1 As Variant, ByVal value2 As Variant, Optional ByVal message As String)
Dim result As Boolean
result = (value1 = value2)
If IsObject(value1) And IsObject(value2) Then
If TypeOf value1 Is IEquatable And TypeOf value2 Is IEquatable Then
Dim equatable1 As IEquatable
Set equatable1 = value1
Dim equatable2 As IEquatable
Set equatable2 = value2
result = equatable1.Equals(equatable2)
End If
End If
If result Then
OnAssertSucceeded
Else
OnAssertFailed "AreEqual", message
End If
End Sub
Public Sub AreNotEqual(ByVal value1 As Variant, ByVal value2 As Variant, Optional ByVal message As String)
Dim result As Boolean
result = (value1 = value2)
If IsObject(value1) And IsObject(value2) Then
If TypeOf value1 Is IEquatable And TypeOf value2 Is IEquatable Then
Dim equatable1 As IEquatable
Set equatable1 = value1
Dim equatable2 As IEquatable
Set equatable2 = value2
result = equatable1.Equals(equatable2)
End If
End If
If Not result Then
OnAssertSucceeded
Else
OnAssertFailed "AreNotEqual", message
End If
End Sub
Public Sub AreSame(ByVal value1 As Object, ByVal value2 As Object, Optional ByVal message As String)
If (ObjPtr(value1) = ObjPtr(value2)) Then
OnAssertSucceeded
Else
OnAssertFailed "AreSame", message
End If
End Sub
Public Sub AreNotSame(ByVal value1 As Object, ByVal value2 As Object, Optional ByVal message As String)
If Not (ObjPtr(value1) = ObjPtr(value2)) Then
OnAssertSucceeded
Else
OnAssertFailed "AreNotSame", message
End If
End Sub
3. Reflection
I didn't mean to do this. I blame thank @RubberDuck for this wonderful idea. I don't like to have to ask the client code to lower its security settings, but in this case the benefits clearly outweight the "risks".
This is a bit of meta-programming here, and it's my first serious usage of VBE. Surely something could improve here.
ClassModule class module
This class is pretty much a helper that gets a list of method members of a CodeModule
instance. For now.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ClassModule"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
Public Function GetMethods(ByVal projectName As String, ByVal className As String) As List
Dim result As List
Set result = List.Create
Dim procedureName As String, lastFound As String
Dim procedureBody As String
Dim proj As VBProject
Set proj = GetProject(projectName)
If proj Is Nothing Then Exit Function
Dim module As CodeModule
Set module = GetClass(proj, className)
Dim i As Long
For i = module.CountOfDeclarationLines + 1 To module.CountOfLines
procedureName = module.ProcOfLine(i, vbext_pk_Proc)
If procedureName <> lastFound Then
procedureBody = module.Lines(module.ProcStartLine(procedureName, vbext_pk_Proc), module.ProcCountLines(procedureName, vbext_pk_Proc))
result.Add Method.Create(procedureName, procedureBody)
lastFound = procedureName
End If
Next
Set GetMethods = result
End Function
Private Function GetProject(ByVal projectName As String) As VBProject
Dim proj As VBProject
For Each proj In Application.VBE.VBProjects
If proj.Name = projectName Then
Set GetProject = proj
Exit Function
End If
Next
End Function
Private Function GetClass(ByVal project As VBProject, ByVal className As String) As CodeModule
Dim component As VBComponent
For Each component In project.VBComponents
If component.Name = className Then
Set GetClass = component.CodeModule
Exit Function
End If
Next
End Function
Method class module
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "Method"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Private Type TMethod
Name As String
Body As String
End Type
Private this As TMethod
Option Explicit
Public Property Get Name() As String
Name = this.Name
End Property
Friend Property Let Name(ByVal value As String)
this.Name = value
End Property
Public Property Get Body() As String
Body = this.Body
End Property
Friend Property Let Body(ByVal value As String)
this.Body = value
End Property
Public Function Create(ByVal methodName As String, ByVal methodBody As String) As Method
Dim result As New Method
result.Name = methodName
result.Body = methodBody
Set Create = result
End Function
This can certainly be improved. How?