173 lines
4.1 KiB
Text
173 lines
4.1 KiB
Text
' Gambas class file
|
|
|
|
' ' Gambas class file
|
|
'
|
|
' ' The UnitTrace control is used to trace the progress and status of the executing test cases.
|
|
' ' The control displays all trace messages associated with each executing test case and groups
|
|
' ' them in a tree. Test cases that execute successfully are identified with a green ball.
|
|
' ' Test cases that contain failures receive a yellow ball, and test cases with errors receive
|
|
' ' a red ball. The UnitTrace control is useful if detailed information on the running tests is
|
|
' ' required.
|
|
'
|
|
' Constants
|
|
|
|
Property Result As TestResult
|
|
|
|
' Member variables
|
|
Private $Result As TestResult
|
|
|
|
Private $oTestCase As ITestCase
|
|
Private $RootKey As String
|
|
Private $CurrentKey As String
|
|
|
|
Private $Obs As Observer
|
|
Private $Obs2 As Observer
|
|
|
|
Private $ErrPosition As Integer
|
|
Private $IsError As Boolean
|
|
Private $IsFailure As Boolean
|
|
|
|
Private $PictureOk As Picture
|
|
Private $PictureError As Picture
|
|
Private $PictureFail As Picture
|
|
|
|
Public Sub _new()
|
|
|
|
Me.Reset()
|
|
$PictureError = Picture.Load("error.png")
|
|
$PictureFail = Picture.Load("failure.png")
|
|
$PictureOk = Picture.Load("ok.png")
|
|
|
|
End
|
|
|
|
' Class destructor
|
|
Private Sub Class_Terminate()
|
|
|
|
$Result = Null
|
|
$oTestCase = Null
|
|
|
|
End Sub
|
|
|
|
Private Sub UserControl_Resize()
|
|
|
|
' tvTrace.Width = ScaleWidth
|
|
' tvTrace.Height = ScaleHeight
|
|
|
|
End Sub
|
|
|
|
' Resets the UnitTrace control clearing the results of the last test run.
|
|
Public Sub Reset()
|
|
|
|
tvTrace.Clear
|
|
tvTrace.Add("Root", "All Tests")
|
|
$RootKey = "Root"
|
|
tvTrace[$RootKey].Expanded = True
|
|
tvTrace["Root"].Picture = $PictureOk
|
|
$ErrPosition = 0
|
|
$CurrentKey = "Root"
|
|
|
|
End Sub
|
|
|
|
Public Sub ResultEvent_AfterStartTest(oTestCase As ITestCase)
|
|
|
|
'Set oKey = tvTrace.Keys.Add($CurrentKey.Index, tvwChild, TestName(oTestCase), TestName(oTestCase), cOkImage)
|
|
$CurrentKey = TestName(oTestCase)
|
|
tvTrace.Add($CurrentKey, TestName(oTestCase), $PictureOk, $RootKey)
|
|
tvTrace.Add(GetErrPosition(), "Test Started", $PictureOk, $CurrentKey)
|
|
$oTestCase = oTestCase
|
|
|
|
End Sub
|
|
|
|
Public Sub ResultEvent_AfterEndTest()
|
|
|
|
Dim Key As String, ChildKey As String, lImage As Long
|
|
|
|
tvTrace.Add(GetErrPosition(), "End Test Case", $PictureOk, $CurrentKey)
|
|
If tvTrace[$CurrentKey].Picture = $PictureOk Then
|
|
tvTrace[$CurrentKey].Expanded = False
|
|
Else
|
|
tvTrace[$CurrentKey].Expanded = True
|
|
Endif
|
|
|
|
End Sub
|
|
|
|
Public Sub ResultEvent_AfterAddError(oError As TestError)
|
|
|
|
Dim err, key As String
|
|
|
|
key = GetErrPosition()
|
|
err = "Error: " & GetErrorMsg(oError)
|
|
tvTrace.Add(key, err, $PictureError, $CurrentKey)
|
|
tvTrace[$CurrentKey].Picture = $PictureError
|
|
tvTrace["Root"].Picture = $PictureError
|
|
|
|
End Sub
|
|
|
|
Public Sub ResultEvent_AfterAddFailure(oError As TestError)
|
|
|
|
Dim fail As String
|
|
|
|
fail = "Failure: " & oError.Description
|
|
tvTrace.Add(GetErrPosition(), fail, $PictureFail, $CurrentKey)
|
|
|
|
If tvTrace[$CurrentKey].Picture = $PictureOk Then
|
|
tvTrace[$CurrentKey].Picture = $PictureFail
|
|
Endif
|
|
|
|
If tvTrace["Root"].Picture = $PictureOk Then
|
|
|
|
'Debug "Root";; tvTrace["Root"].Picture
|
|
'Debug "Error";; $PictureError
|
|
'Debug "Fail";; $PictureFail
|
|
'Debug "Set Fail"
|
|
tvTrace["Root"].Picture = $PictureFail
|
|
Endif
|
|
|
|
End Sub
|
|
|
|
Public Sub ResultEvent_AfterAddTrace(sMessage As String)
|
|
|
|
Dim trace As String
|
|
|
|
trace = "Trace: " & sMessage
|
|
tvTrace.Add(GetErrPosition(), trace, Picture.Load("ok.png"), $CurrentKey)
|
|
|
|
End Sub
|
|
|
|
Public Function GetErrPosition() As String
|
|
|
|
Dim KeyName As String
|
|
|
|
KeyName = $CurrentKey & "-" & $ErrPosition
|
|
Inc $ErrPosition
|
|
Return KeyName
|
|
|
|
End
|
|
|
|
Private Function GetErrorMsg(oError As TestError) As String
|
|
|
|
Return oError.Source & " (" & oError.ErrNumber & "): " & oError.Description
|
|
|
|
End Function
|
|
|
|
Private Function TestName(oTestCase As TestCase) As String
|
|
|
|
If (oTestCase <> Null) Then
|
|
Return oTestCase.Container.Name & "." & oTestCase.Name
|
|
End If
|
|
|
|
End Function
|
|
|
|
Private Function Result_Read() As TestResult
|
|
|
|
Return $Result
|
|
|
|
End
|
|
|
|
Private Sub Result_Write(Value As TestResult)
|
|
|
|
Reset
|
|
$Result = Value
|
|
$Obs = New Observer($Result) As "ResultEvent"
|
|
|
|
End
|