28
\$\begingroup\$

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 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?

\$\endgroup\$

5 Answers 5

Reset to default
12
\$\begingroup\$

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 3rd 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?

\$\endgroup\$
5
  • 1
    \$\begingroup\$ 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 :) \$\endgroup\$ Commented Sep 16, 2014 at 19:41
  • \$\begingroup\$ @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? \$\endgroup\$ Commented Sep 16, 2014 at 19:46
  • 3
    \$\begingroup\$ That's correct. The List would never be created, but Mug is correct that Dims all happen at the same time for a scope. \$\endgroup\$ Commented Sep 16, 2014 at 19:54
  • 4
    \$\begingroup\$ "And Where are all the Brackets and Semi-Colons?" made my drink come out of my nose. +1 anyway for some good observations. \$\endgroup\$ Commented Sep 17, 2014 at 2:05
  • 3
    \$\begingroup\$ @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! \$\endgroup\$ Commented Sep 17, 2014 at 13:33
9
\$\begingroup\$

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.

\$\endgroup\$
2
  • 2
    \$\begingroup\$ 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. \$\endgroup\$ Commented Sep 17, 2014 at 2:12
  • \$\begingroup\$ I never meant to imply it would be any safer @Comintern. I only think it would be less confusing for a maintainer. \$\endgroup\$ Commented Sep 17, 2014 at 13:12
6
\$\begingroup\$

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.

\$\endgroup\$
4
\$\begingroup\$

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.

\$\endgroup\$
4
\$\begingroup\$

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
\$\endgroup\$

You must log in to answer this question.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.