Automagic testing framework for VBA

Question

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 as List and Tuple as well as various string helper methods in the Strings "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?

Answer 1

Look what I found

Dim procedureName As String, lastFound As String
Dim procedureBody As String

Personally I don't like declaring variables like this, and almost every language allows you to do this in some way or another.

I think this is one of those holy war issues though, some programmers like doing this and some programmers say this is bad practice.

Be wary of who is going to maintain this code and what they will say about you when you are gone.

---

I found something else, probably left overs of changing code or logic

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

I am guessing that you don't need

Dim result As Boolean

anymore and that it was leftover, although I think that you would want something like this instead

Private Function CanAddTestMethod(ByVal prospect As Method, ByRef testMethods As Dictionary) As Boolean
 CanAddTestMethod = false
 If Not IsTestMethodName(prospect) Then Exit Function
 If testMethods.Exists(prospect.name) Then Exit Function
 CanAddTestMethod = True
End Function

So that if you exit the function in one of your if statements it says "hey I am false, you can't add a test method"

but then I remember that we are talking about VBA here and I think that if you exit without setting the method it will automagically be false, so it would be just

Private Function CanAddTestMethod(ByVal prospect As Method, ByRef testMethods As Dictionary) As Boolean
 If Not IsTestMethodName(prospect) Then Exit Function
 If testMethods.Exists(prospect.name) Then Exit Function
 CanAddTestMethod = True
End Function

---

In the RunTest sub you wait until the third line of code to declare the error handling, I am not sure that this was on purpose or not, maybe the Error Description won't work if the GoTo is earlier and there is an error before the 3^rd line.

Just a thought.

---

Can we move the Exit Function code in the GetMethods function to the start of the function (削除) so we don't have to Dim variables we aren't going to use (削除ここまで)? It would be seen easier when debugging the code

instead of This

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

write it like this

Public Function GetMethods(ByVal projectName As String, ByVal className As String) As List
 Dim proj As VBProject
 Set proj = GetProject(projectName)
 If proj Is Nothing Then Exit Function
 Dim result As List
 Set result = List.Create
 Dim procedureName As String, lastFound As String
 Dim procedureBody As String
 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

---

And Where are all the Brackets and Semi-Colons?

• Mathieu Guindon: A couple of nice catches here. However VBA doesn't care where the Dim statement is - if it's declared in a function, then it's in-scope anywhere in that function; you cannot break on a Dim statement :)
• Malachi: @Mat'sMug take a look at it again. if you exit the function after things have been dimmed it has already used processing power to dim those variables, if you exit the function before those dim statements they aren't ever created, right?
• RubberDuck: That's correct. The List would never be created, but Mug is correct that Dims all happen at the same time for a scope.
• Comintern: "And Where are all the Brackets and Semi-Colons?" made my drink come out of my nose. +1 anyway for some good observations.
• Malachi: @RubberDuck, I get it now, it doesn't matter about exiting before they are dimmed because the compiler/interpreter/(whatever VBA uses) looks over the scope and sets the memory aside from the beginning and then runs through the scope. I get it now!

Answer 2

I've not really dug into everything here, perhaps someone else will give you a fresh perspective on the Unit Testing code. I want to address an algorithm issue in ClassModule.GetMethods. I am partly responsible for this inefficiency because, in previous answer, I pointed you to some code I had written a while back.

The algorithm you're currently using is \$O(n)\$ where \$N\$ is the number of lines in the module. It's possible to do it in \$O(log n)\$ time by switching to a while loop and directly finding the line number of the next method.

So, instead of this:

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

Use this:

Dim lineNumber as Long
lineNumber = module.CountOfDeclarationLines + 1
While (lineNumber < module.CountOfLines)
 procedureName = module.ProcOfLine(lineNumber, vbext_pk_Proc)
 procedureBody = module.Lines(module.ProcStartLine(procedureName, vbext_pk_Proc), module.ProcCountLines(procedureName, vbext_pk_Proc))
 result.Add Method.Create(procedureName, procedureBody)
 ' add current start line to the number of lines in current procedure to get the start line of the next procedure.
 lineNumber = lineNumber + module.ProcCountLines(procedureName, vbext_pk_Proc) + 1
Wend

---

While I'm thinking about it, I'm not a big fan of this line of code, which I did not change in the improved algorithm version above.

procedureBody = module.Lines(module.ProcStartLine(procedureName, vbext_pk_Proc), module.ProcCountLines(procedureName, vbext_pk_Proc))

It's not your fault. The extensibility library is terribly clunky. That's why I extended it. What I don't quite understand is why you created a Method class, but didn't implement anything that would make these types of calls easier. Particularly, StartLine, CountOfLines, EndLine, and Body. (You're actually the one who wrote a number of properties in my library.) Consider the equivalent code where vbeProcedure (Method) has those properties.

Dim lineNumber As Long
lineNumber = codeMod.CountOfDeclarationLines + 1
While (lineNumber < codeMod.CountOfLines)
 procName = codeMod.ProcOfLine(lineNumber, vbext_pk_Proc)
 Set proc = New vbeProcedure
 proc.Initialize procName, codeMod
 procs.Add proc
 lineNumber = proc.EndLine + 1
Wend
Set GetProcedures = procs

Of course, doing that means the each Method has to know what parent module it belongs to, so if you take that approach, be careful of circular references and be sure to dispose of Methods properly.

---

GetProject is overly complicated. This is all you really need.

Private Function GetProject(ByVal projectName As String) As VBProject
 GetProject = Application.VBE.VBProjects(projectName)
End Function

Of course, it will blow up if you pass it an empty string or a Name that doesn't exist, but that's a good thing. Your code will blow up too, it will just do it farther up the stack trace and you'll be left wondering why Project Is Nothing. Let it fail early, especially when you're mucking around with meta-programming.

Scratch that. I see you put some code in to catch that.

If proj Is Nothing Then Exit Function

But I still don't like it. I'd prefer a error message to a silent failure any day of the week.

• Comintern: Nice post, but I'd question whether calling Application.VBE.VBProjects(projectName) is safer than iterating through Application.VBE.VBProjects. In my experience with VBE, you don't typically get an error message or a silent failure. Either of them have a wicked tendency to take down the VBA host unpredictably. I don't know if this has improved in more recent versions of Office, but I kind of doubt it. I'd say it's a good habit to avoid as much possibility of errors as possible when you're mucking around in the same context your code runs in.
• RubberDuck: I never meant to imply it would be any safer @Comintern. I only think it would be less confusing for a maintainer.

Answer 3

IsTestMethodName is lousy. The function should be IsTestMethod, and could use a few constants:

Private Const TestMethodNamePrefix As String = "Test"
Private Const TestMethodAttribute As String = "TestMethod"

Given a few more properties and a helper function in the Reflection.Method class:

Friend Property Let Body(ByVal value As String)
 this.Body = value
 FindSignature
End Property
Public Property Get Signature() As String
 Signature = this.Signature
End Property
'Private Const MethodAttributeMarker As String = "'@" 
Public Function HasAttribute(ByVal value As String) As Boolean
 HasAttribute = this.AttributeComment = MethodAttributeMarker & Trim(value)
End Function
Private Sub FindSignature()
 Dim lines() As String
 lines = Split(this.Body, vbNewLine)
 Dim i As Integer
 For i = LBound(lines) To UBound(lines)
 If framework.Strings.StartsWithAny(lines(i), False, "public sub", _
 "private sub", _
 "friend sub", _
 "sub", _
 "public function", _
 "private function", _
 "friend function", _
 "function") _
 Then
 this.Signature = lines(i)
 If i > 0 Then
 If framework.Strings.StartsWith(AttributeMarker, lines(i - 1)) Then
 this.AttributeComment = lines(i - 1)
 End If
 End If
 Exit Sub
 End If
 Next
End Sub

...you can turn IsTestMethodName into IsTestMethod in a whim. One issue with the current implementation is the hard-coding of Body line indices - the code assumes it will find a '@TestMethod "attribute" on the 2nd line (at index 1).. but a procedure's body doesn't start at its signature: it starts on the line that the VBA editor marks with a horizontal rule: the client code could very well have 5 blank lines between methods, and that would break your code.

So, given the above properties, IsTestMethod would look like this:

Private Function IsTestMethod(ByVal testMethod As Method) As Boolean
 Dim result As Boolean
 result = _
 Framework.Strings.StartsWith(TestMethodNamePrefix, testMethod.name, False) Or _
 testMethod.HasAttribute(TestMethodAttribute)
 If Not result Then Exit Function
 result = result And Framework.Strings.StartsWith("public sub", testMethod.Signature, False)
 IsTestMethod = result
End Function

And now if there's a problem with the values of testMethod.Name, testMethod.AttributeComment or testMethod.Signature, the bug isn't in that code - it can only be in the Reflection code.

Answer 4

BUG!

I can't believe I let this one slip:

2014年09月16日 00:24:20 TestInconclusive: [PASS]

The TestInconclusive test method should have output this:

2014年09月16日 00:24:20 TestInconclusive: [INCONCLUSIVE] - No idea.

The TestEngine.CurrentTestFailedResults() function could be renamed to CurrentTestNotPassedResults(), and take Inconclusive results into account:

For Each result In this.CurrentTestResults
 If result.TestOutcome = Failed Or result.TestOutcome = Inconclusive Then resultList.Add result
Next

And then the assertion_Completed handler could be modified as such:

Private Sub assertion_Completed(ByVal result As TestResult)
 this.CurrentTestResults.Add result
 If (result.TestOutcome = Inconclusive Or result.TestOutcome = Failed) _
 And CurrentTestNotPassedResults.Count = 0 _
 Then
 this.Output.WriteResult this.CurrentTest, result
 End If
End Sub

That fixes the bug, and makes this test:

Public Sub TestInconclusive()
 assert.IsTrue True
 assert.Inconclusive "No idea."
 assert.Fail "shouldn't output this result."
End Sub

Output this single result, as it should:

2014年09月21日 12:29:01 TestInconclusive: [INCONCLUSIVE] - No idea.

---

Tuple

It fixes the bug, but there's still something that smells: the RegisteredTests private member is a Dictionary<string,Tuple>:

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

This leads to this line of code - as it turns out, it's the most important line of all, and it reads like this:

CallByName test.Item1, test.Item2, VbMethod

Item1 and Item2 are both Variant, and mean absolutely nothing. As is the case in .NET code, using a Tuple is symptomatic of a missing abstraction - here a simple TestMethod class:

 If CanAddTestMethod(prospect, result) Then
 
 result.Add prospect.name, TestMethod.Create(classInstance, prospect.name)
 Debug.Print "Registered test: " & TypeName(classInstance) & "." & prospect.name
 
 End If

Isn't this much clearer?

Dim test As TestMethod
Set test = this.RegisteredTests(name)
CallByName test.OwnerInstance, test.MethodName, VbMethod

---

CurrentTestNotPassedResults()

This function looks like patchwork. It works, but smells... badly. And it's not efficient at all: the "failed/inconclusive" list of test results gets rebuilt every time a test is executed (heck, every time an assertion is made in a test), which means the more tests a client test class has to run, the longer it will take to process the later tests. Not nice.

The TestEngine would really benefit from having a private FailedOrInconclusiveResults list, instead of this function:

Private Type TTestEngine
 Output As ITestOutput
 RegisteredTests As Dictionary
 CurrentTest As String
 CurrentTestAllResults As List
 CurrentTestFailedOrInconclusiveResults As List
End Type

Then the assert_Completed handler can be simplified:

Private Sub assertion_Completed(ByVal result As TestResult)
 this.CurrentTestAllResults.Add result
 If result.TestOutcome = Inconclusive Or result.TestOutcome = Failed Then
 this.CurrentTestFailedOrInconclusiveResults.Add result
 End If
End Sub

Which removes all but one test.Output.WriteResult calls - the only one remaining is in the RunTest method, after the test executed. Much cleaner.

Answer 5

Bug

This one is subtle.

procedureBody = module.Lines(module.ProcStartLine(procedureName, vbext_pk_Proc), module.ProcCountLines(procedureName, vbext_pk_Proc))

Specifically, this:

module.ProcStartLine(procedureName, vbext_pk_Proc)

It will work 100% fine as long as you never pass it the name of a property. To be fair, you're Test Classes shouldn't ever have properties, but if one ever does.... Oh boy! Look out! Runtime Error #35 is waiting to peak its ugly head.

The problem is ProcStartLine needs to know what kind of method it's looking up by name. Which is a problem, because when using the extensibility library in this way, we are extremely unlikely to know whether we're dealing with a property or method upfront.

So, all that stuff in my other answer about an \$O(log n)\$ solution, forget it. In order to do this safely, you have to parse the code module line by line. Here's the solution I came up with. It's not pretty, but it makes the code safe.

Private Function GetProcedureType(signatureLine As String) As vbext_ProcKind
 If InStr(1, signatureLine, "Property Get") > 0 Then
 GetProcedureType = vbext_pk_Get
 ElseIf InStr(1, signatureLine, "Property Let") > 0 Then
 GetProcedureType = vbext_pk_Let
 ElseIf InStr(1, signatureLine, "Property Set") > 0 Then
 GetProcedureType = vbext_pk_Set
 ElseIf InStr(1, signatureLine, "Sub") > 0 Or InStr(1, signatureLine, "Function") > 0 Then
 GetProcedureType = vbext_pk_Proc
 Else
 Const InvalidProcedureCallOrArgument As Long = 5
 Err.Raise InvalidProcedureCallOrArgument
 End If
End Function
Private Function IsSignature(line As String) As Boolean
 If line = vbNullString Then Exit Function
 Dim propertyPosition As Long
 Dim functionPosition As Long
 Dim subPosition As Long
 Dim commentPosition As Long
 propertyPosition = InStr(1, line, "Property")
 functionPosition = InStr(1, line, "Function")
 subPosition = InStr(1, line, "Sub")
 commentPosition = InStr(1, line, "'")
 If propertyPosition > 0 Or functionPosition > 0 Or subPosition > 0 Then
 If InStr(1, line, "End") = 0 Then
 If commentPosition > propertyPosition Then
 Exit Function
 ElseIf commentPosition > functionPosition Then
 Exit Function
 ElseIf commentPosition > subPosition Then
 Exit Function
 Else
 IsSignature = True
 End If
 End If
 End If
End Function

Applying it to your code would look something like this. Note that I added procKind as a member of Method and there's no need to check this proc name again the last proc name because we only add a method if we're on a signature line.

Dim procKind As vbext_ProcKind
Dim i As Long
For i = Module.CountOfDeclarationLines + 1 To Module.CountOfLines
 line = Module.Lines(i, 1)
 If IsSignature(line) Then
 procKind = GetProcedureType(line)
 procedureName = Module.ProcOfLine(i, procKind)
 procedureBody = Module.Lines(Module.ProcStartLine(procedureName, procKind), Module.ProcCountLines(procedureName, procKind))
 result.Add Method.Create(procedureName, procedureBody, procKind)
 End If
Next

Of course, you might want to check the ProcKind before registering it as a TestMethod as well. I suspect CallByName won't like being told it's getting a vbMethod when it's really getting a property.

Sidenote: You may find it interesting to know that ProcOfLine does not suffer from this. As far as I can tell, you can pass that one any vbext_ProcKind and it will happily run with it.

---

We've already discussed this in chat, but for the sake of future readers, I'm adding this here. The \$O(n)\$ solution is possible after all. The reason ProcOfLine will take any vbext_ProcKind you throw at it is because it is an OUT parameter.

Note that the pprockind argument indicates whether the line belongs to a Sub or Function procedure, a Property Get procedure, a Property Let procedure, or a Property Set procedure. To determine what type of procedure a line is in, pass a variable of type Long to the ProcOfLine property, then check the value of that variable.

From the 2013 MS Access documentation. This is easily missed because both the 2013 Office and VB6 versions of the Visual Basic Add-in Object Reference don't mention it at all.

The solution is to simply declare a procKind variable, and let it capture the procKind for you.

Dim procKind as vbext_ProcKind
Dim lineNumber as Long
lineNumber = module.CountOfDeclarationLines + 1
While (lineNumber < module.CountOfLines)
 procedureName = module.ProcOfLine(lineNumber, procKind) 'procKind is an OUT param
 procedureBody = module.Lines(module.ProcStartLine(procedureName, procKind), module.ProcCountLines(procedureName, procKind))
 result.Add Method.Create(procedureName, procedureBody)
 ' add current start line to the number of lines in current procedure to get the start line of the next procedure.
 lineNumber = lineNumber + module.ProcCountLines(procedureName, procKind) + 1
Wend