"
COPYRIGHT (c) 2006 by eXept Software AG
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
"{ Package: 'stx:libtool' }"
"{ NameSpace: Tools }"
AbstractTestRunner subclass:#TestRunnerEmbedded
instanceVariableNames:'runnerPanel selectedTestCases selectedClassesHolder
selectedProtocolsHolder selectedMethodsHolder
methodGeneratorHolder resultHolder resultInfoHolder
resultBackgroundColorHolder runningHolder progressHolder'
classVariableNames:''
poolDictionaries:''
category:'SUnit-UI'
!
Object subclass:#SuiteAndResult
instanceVariableNames:'suite result'
classVariableNames:''
poolDictionaries:''
privateIn:TestRunnerEmbedded
!
!TestRunnerEmbedded class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 2006 by eXept Software AG
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
! !
!TestRunnerEmbedded class methodsFor:'interface specs'!
windowSpec
"This resource specification was automatically generated
by the UIPainter of ST/X."
"Do not manually edit this!! If it is corrupted,
the UIPainter may not be able to read the specification."
"
UIPainter new openOnClass:Tools::TestRunnerEmbedded andSelector:#windowSpec
Tools::TestRunnerEmbedded new openInterface:#windowSpec
Tools::TestRunnerEmbedded open
"
<resource: #canvas>
^
#(FullSpec
name: windowSpec
window:
(WindowSpec
label: 'Test Runner Embedded'
name: 'Test Runner Embedded'
min: (Point 10 10)
bounds: (Rectangle 0 0 350 50)
)
component:
(SpecCollection
collection: (
(VerticalPanelViewSpec
name: 'Runners'
layout: (LayoutFrame 5 0 0 0 -5 1 0 1)
horizontalLayout: fit
verticalLayout: topSpaceFit
horizontalSpace: 0
verticalSpace: 5
elementsChangeSize: true
component:
(SpecCollection
collection: (
(ViewSpec
name: 'Runner'
backgroundChannel: resultBackgroundColorAspect
component:
(SpecCollection
collection: (
(HorizontalPanelViewSpec
name: 'RunnerInnerBox'
layout: (LayoutFrame 5 0 0 0 -5 1 0 1)
horizontalLayout: rightSpaceFit
verticalLayout: center
horizontalSpace: 0
elementsChangeSize: true
component:
(SpecCollection
collection: (
(ViewSpec
name: 'RunnerInfoBox'
backgroundChannel: resultBackgroundColorAspect
component:
(SpecCollection
collection: (
(LabelSpec
label: 'Run tests first!!'
name: 'ResultName'
layout: (LayoutFrame 0 0 0 0 0 1 -10 1)
backgroundChannel: resultBackgroundColorAspect
foregroundColor: (Color 100.0 100.0 100.0)
translateLabel: true
labelChannel: resultNameAspect
adjust: left
)
(LabelSpec
name: 'ResultInfo'
layout: (LayoutFrame 0 0 -10 1 0 1 0 1)
style: (FontDescription helvetica medium roman 8)
backgroundChannel: resultBackgroundColorAspect
foregroundColor: (Color 100.0 100.0 100.0)
translateLabel: true
labelChannel: resultInfoAspect
adjust: left
)
(ViewSpec
name: 'ProgressPanel'
layout: (LayoutFrame 0 0 0 0 0 1 0 1)
visibilityChannel: runningHolder
backgroundChannel: resultBackgroundColorAspect
component:
(SpecCollection
collection: (
(ProgressIndicatorSpec
name: 'RunningProgress'
layout: (LayoutFrame 5 0 -10 0.5 -5 1 10 0.5)
model: progressHolder
)
)
)
)
)
)
extent: (Point 151 30)
)
(ActionButtonSpec
label: 'Debug'
name: 'DebugButton'
initiallyInvisible: true
visibilityChannel: debugVisibleAspect
translateLabel: true
model: debug
extent: (Point 60 25)
)
(ActionButtonSpec
label: 'Run'
name: 'Run'
translateLabel: true
model: run
enableChannel: runEnabledHolder
extent: (Point 60 25)
)
(ActionButtonSpec
label: 'Run all'
name: 'RunAll'
translateLabel: true
model: runAll
enableChannel: runAllEnabledHolder
extent: (Point 60 25)
)
)
)
postBuildCallback: postBuildRunnerPanel:
)
)
)
extent: (Point 340 40)
)
)
)
)
)
)
)
! !
!TestRunnerEmbedded class methodsFor:'plugIn spec'!
aspectSelectors
"This resource specification was automatically generated
by the UIPainter of ST/X."
"Do not manually edit this. If it is corrupted,
the UIPainter may not be able to read the specification."
"Return a description of exported aspects;
these can be connected to aspects of an embedding application
(if this app is embedded in a subCanvas)."
^ #(
#methodGeneratorHolder
#selectedClassesHolder
#selectedMethodsHolder
#selectedProtocolsHolder
).
! !
!TestRunnerEmbedded methodsFor:'accessing'!
selectedTestMethods
^ (self selectedMethodsHolder value ? #()) select:
[:mthd |
(self isTestCaseLike:mthd mclass)
and:[ mthd mclass isTestSelector:mthd selector ] ]
"Created: / 15-03-2010 / 13:21:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 07-09-2010 / 08:30:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
selectedTestMethodsFromProtocols:protocols
|methods generator|
methods := Set new.
generator := self methodGeneratorHolder value.
generator ifNotNil:
[ generator do:
[:cls :cat :sel :mthd |
(mthd notNil
and:[ (self isTestCaseLike:cls) and:[ cls isTestSelector:sel ] ])
ifTrue:[ methods add:mthd ] ] ]
ifNil:
[ selectedTestCases do:
[:cls |
cls methodsDo:
[:mthd |
((protocols includes:mthd category)
and:[ cls isTestSelector:mthd selector ]) ifTrue:[ methods add:mthd ] ] ] ].
^ methods
"Created: / 15-03-2010 / 19:50:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 07-09-2010 / 08:29:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerEmbedded methodsFor:'actions'!
debug
| suiteAndResult |
suiteAndResult := self resultHolder value.
suiteAndResult suite tests size ~= 1 ifTrue:[^self breakPoint: #jv].
[suiteAndResult suite tests anyOne debug] fork
"Created: / 15-03-2010 / 15:43:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 15-03-2010 / 20:09:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
run
self run: resultHolder value suite
"Created: / 10-03-2010 / 19:42:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 15-03-2010 / 20:00:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
run: suite
| process suiteAndResult |
suite tests size == 0 ifTrue:[^self].
process :=
[| result incr run |
[
self progressHolder value: 0.
self runningHolder value: true.
incr := 100 / suite tests size.
run := 0.
result := suite runAfterEachDo:
[:test :result|
run := run + 1.
self progressHolder value: (incr * run) rounded].
suiteAndResult := SuiteAndResult
suite: suite
result: result.
] ensure:[
self resultHolder value: suiteAndResult.
self runningHolder value: false.
]
] newProcess.
process resume.
"Created: / 11-03-2010 / 10:22:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 06-09-2010 / 21:48:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
runAll
self run: self suiteForRunAll.
"Created: / 10-03-2010 / 19:42:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 15-03-2010 / 13:12:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerEmbedded methodsFor:'aspects'!
debugVisibleAspect
^BlockValue
with:
[:model|
model
ifNil:[false]
ifNotNil:[model testCount == 1 and:[model hasFailuresOrErrors]]]
argument:
self resultHolder
"Created: / 15-03-2010 / 15:40:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
methodGeneratorHolder
"return/create the 'methodGeneratorHolder' value holder (automatically generated)"
methodGeneratorHolder isNil ifTrue:[
methodGeneratorHolder := ValueHolder new.
methodGeneratorHolder addDependent:self.
].
^ methodGeneratorHolder
!
methodGeneratorHolder:something
"set the 'methodGeneratorHolder' value holder (automatically generated)"
|oldValue newValue|
methodGeneratorHolder notNil ifTrue:[
oldValue := methodGeneratorHolder value.
methodGeneratorHolder removeDependent:self.
].
methodGeneratorHolder := something.
methodGeneratorHolder notNil ifTrue:[
methodGeneratorHolder addDependent:self.
].
newValue := methodGeneratorHolder value.
oldValue ~~ newValue ifTrue:[
self update:#value with:newValue from:methodGeneratorHolder.
].
!
progressHolder
"return/create the 'progressHolder' value holder (automatically generated)"
progressHolder isNil ifTrue:[
progressHolder := ValueHolder new.
].
^ progressHolder
!
resultBackgroundColorAspect
<resource: #uiAspect>
resultBackgroundColorHolder isNil ifTrue:[
resultBackgroundColorHolder := BlockValue
with:
[:result :running|
running
ifTrue:
[View defaultBackgroundColor]
ifFalse:
[result
ifNil:[self class notRunColor]
ifNotNil:[result color]]]
argument: self resultHolder
argument: self runningHolder.
resultBackgroundColorHolder onChangeEvaluate:
[runnerPanel ifNotNil:[runnerPanel backgroundColor: resultBackgroundColorHolder value]].
].
^ resultBackgroundColorHolder.
"Created: / 15-03-2010 / 15:22:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 15-03-2010 / 21:02:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
resultHolder
"return/create the 'resultHolder' value holder (automatically generated)"
resultHolder isNil ifTrue:[
resultHolder := ValueHolder new.
].
^ resultHolder
!
resultInfoAspect
^BlockValue
with:
[:model|
model
ifNil:['']
ifNotNil:[model info]]
argument:
self resultHolder
"Created: / 15-03-2010 / 20:22:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
resultNameAspect
^BlockValue
with:
[:model|
model
ifNil:['Run the tests!!']
ifNotNil:[model name]]
argument:
self resultHolder
"Created: / 15-03-2010 / 14:57:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 15-03-2010 / 20:17:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
runAllEnabledHolder
^true
"Created: / 07-09-2010 / 09:15:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
runEnabledHolder
^BlockValue
with:
[:resultHolder | | result |
(result := resultHolder value) notNil and:[result testCount > 0 ]]
argument: self resultHolder
"Created: / 07-09-2010 / 09:15:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
runningHolder
"return/create the 'runningHolder' value holder (automatically generated)"
runningHolder isNil ifTrue:[
runningHolder := ValueHolder with: false.
].
^ runningHolder
"Modified: / 15-03-2010 / 20:29:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
selectedClassesHolder
"return/create the 'selectedClassesHolder' value holder (automatically generated)"
selectedClassesHolder isNil ifTrue:[
selectedClassesHolder := ValueHolder new.
selectedClassesHolder addDependent:self.
].
^ selectedClassesHolder
!
selectedClassesHolder:something
"set the 'selectedClassesHolder' value holder (automatically generated)"
|oldValue newValue|
selectedClassesHolder notNil ifTrue:[
oldValue := selectedClassesHolder value.
selectedClassesHolder removeDependent:self.
].
selectedClassesHolder := something.
selectedClassesHolder notNil ifTrue:[
selectedClassesHolder addDependent:self.
].
newValue := selectedClassesHolder value.
oldValue ~~ newValue ifTrue:[
self update:#value with:newValue from:selectedClassesHolder.
].
!
selectedMethodsHolder
"return/create the 'selectedMethodsHolder' value holder (automatically generated)"
selectedMethodsHolder isNil ifTrue:[
selectedMethodsHolder := ValueHolder new.
selectedMethodsHolder addDependent:self.
].
^ selectedMethodsHolder
!
selectedMethodsHolder:something
"set the 'selectedMethodsHolder' value holder (automatically generated)"
|oldValue newValue|
selectedMethodsHolder notNil ifTrue:[
oldValue := selectedMethodsHolder value.
selectedMethodsHolder removeDependent:self.
].
selectedMethodsHolder := something.
selectedMethodsHolder notNil ifTrue:[
selectedMethodsHolder addDependent:self.
].
newValue := selectedMethodsHolder value.
oldValue ~~ newValue ifTrue:[
self update:#value with:newValue from:selectedMethodsHolder.
].
!
selectedProtocolsHolder
"return/create the 'selectedProtocolsHolder' value holder (automatically generated)"
selectedProtocolsHolder isNil ifTrue:[
selectedProtocolsHolder := ValueHolder new.
selectedProtocolsHolder addDependent:self.
].
^ selectedProtocolsHolder
!
selectedProtocolsHolder:something
"set the 'selectedProtocolsHolder' value holder (automatically generated)"
|oldValue newValue|
selectedProtocolsHolder notNil ifTrue:[
oldValue := selectedProtocolsHolder value.
selectedProtocolsHolder removeDependent:self.
].
selectedProtocolsHolder := something.
selectedProtocolsHolder notNil ifTrue:[
selectedProtocolsHolder addDependent:self.
].
newValue := selectedProtocolsHolder value.
oldValue ~~ newValue ifTrue:[
self update:#value with:newValue from:selectedProtocolsHolder.
].
! !
!TestRunnerEmbedded methodsFor:'change & update'!
update:aspect with:param from: sender
"Invoked when an object that I depend upon sends a change notification."
sender == selectedClassesHolder ifTrue:[
self
updateTestCases;
updateTestSuiteAndResult;
updateVisibility.
^ self.
].
sender == selectedProtocolsHolder ifTrue:[
self updateTestSuiteAndResult.
^self
].
sender == selectedMethodsHolder ifTrue:[
self updateTestSuiteAndResult.
^self
].
sender == methodGeneratorHolder ifTrue:[
self updateTestSuiteAndResult.
^self
].
super update:aspect with:param from: sender
"Modified: / 07-09-2010 / 08:18:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
updateTestCases
selectedTestCases := (self selectedClassesHolder value
select:[:cls | self isTestCaseLike:cls ]).
selectedTestCases := selectedTestCases isEmpty
ifTrue:[ nil ]
ifFalse:[ selectedTestCases asArray ]
"Created: / 11-03-2010 / 10:31:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 15-03-2010 / 20:53:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
updateTestSuiteAndResult
| suite suiteAndResult |
self runningHolder value ifTrue:[^self].
selectedTestCases ifNil:[^self].
suiteAndResult := SuiteAndResult
suite: (suite := self suiteForRun)
result: (self resultForSuite: suite).
self resultHolder value: suiteAndResult.
"Created: / 15-03-2010 / 19:41:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 15-03-2010 / 20:55:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
updateVisibility
self hasTestCaseSelected
ifTrue:[self show]
ifFalse:[self hide]
"Created: / 11-03-2010 / 09:02:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerEmbedded methodsFor:'hooks'!
postBuildRunnerPanel: aView
runnerPanel := aView.
runnerPanel backgroundColor: self resultBackgroundColorAspect value
"Created: / 15-03-2010 / 14:26:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerEmbedded methodsFor:'private'!
hide
self visibility: false height: 0
"Created: / 11-03-2010 / 09:07:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
isTestCaseLike:cls
^(super isTestCaseLike: cls) and:
[(cls askFor: #isAbstract) not]
"Modified: / 04-03-2011 / 06:54:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
show
self visibility: true height: 50
"Created: / 11-03-2010 / 09:07:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
visibility: visibility height: height
| container list h |
(container := self window container) ifNil:[^self].
h := visibility ifFalse:[0] ifTrue:[height].
container isVisible == visibility ifFalse:
[container isVisible: visibility].
list := container container subViews first.
(list layout bottomOffset ~= height negated) ifTrue:
[list layout:
(list layout bottomOffset: height negated; yourself)].
"Created: / 11-03-2010 / 09:51:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerEmbedded methodsFor:'queries'!
hasTestCaseSelected
^selectedTestCases isNilOrEmptyCollection not
"Created: / 11-03-2010 / 09:06:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 15-03-2010 / 20:54:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerEmbedded methodsFor:'utilities'!
resultForSuite: suite
| result |
result := TestResult new.
suite tests do:
[:test|
(test class testSelectorPassed: test selector)
ifTrue:
[result passed add: test]
ifFalse:
[(test class testSelectorError: test selector)
ifTrue:
[result errors add: test]
ifFalse:
[(test class testSelectorFailed: test selector)
ifTrue:
[result failures add: test]]]].
^result
"Created: / 15-03-2010 / 19:46:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
suiteForRun
| methods protocols suite |
(methods := selectedMethodsHolder value) isNilOrEmptyCollection ifFalse:
[suite := TestSuite named: (self suiteNameFromMethods: methods).
self selectedTestMethods do:
[:mthd| | selector |
suite addTest: (mthd mclass asTestCase selector: mthd selector)].
^suite].
(protocols := selectedProtocolsHolder value) isNilOrEmptyCollection ifFalse:
[suite := TestSuite named: (self suiteNameFromProtocols: protocols).
(self selectedTestMethodsFromProtocols: protocols) do:
[:mthd| | selector |
suite addTest: (mthd mclass asTestCase selector: mthd selector)].
^suite].
^self suiteForRunAll
"Created: / 15-03-2010 / 13:13:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 04-03-2011 / 08:24:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
suiteForRunAll
|suite|
suite := TestSuite named:(self suiteNameFromClasses: selectedTestCases).
selectedTestCases
do:[:testCase | suite addTests:(self buildSuiteFromClass:testCase) tests].
^suite
"Modified: / 04-03-2011 / 06:57:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerEmbedded::SuiteAndResult class methodsFor:'instance creation'!
suite: suite result: result
^self new
suite: suite;
result: result.
"Modified: / 15-03-2010 / 15:27:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerEmbedded::SuiteAndResult methodsFor:'accessing'!
color
self testCount == 0 ifTrue:
[^TestRunnerEmbedded notRunColor].
result ifNil:[^TestRunnerEmbedded notRunColor].
self hasErrors ifTrue:[^TestRunnerEmbedded errorColor].
self hasFailures ifTrue:[^TestRunnerEmbedded failedColor].
self hasPassed ifTrue:[^TestRunnerEmbedded passedColor].
^TestRunnerEmbedded notRunColor
"Created: / 15-03-2010 / 15:24:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 07-09-2010 / 08:25:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
info
result ifNil:[^''].
(result passedCount + result failureCount + result errorCount) = 1 ifTrue:[^''].
^'%1 tests, %2 passed, %3 failed, %4 errors'
bindWith: suite tests size
with: result passedCount
with: result failureCount
with: result errorCount
"Created: / 15-03-2010 / 20:23:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
name
^suite name
"Created: / 15-03-2010 / 15:12:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
result
^ result
!
result:aTestResult
result := aTestResult.
!
suite
^ suite
!
suite:aTestSuite
suite := aTestSuite.
!
testCount
^suite tests size
"Created: / 15-03-2010 / 15:44:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerEmbedded::SuiteAndResult methodsFor:'queries'!
hasErrors
^result errorCount > 0
"Created: / 15-03-2010 / 15:21:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
hasFailures
^result failureCount > 0
"Created: / 15-03-2010 / 15:21:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
hasFailuresOrErrors
^self hasErrors or:[self hasFailures]
"Created: / 15-03-2010 / 15:45:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
hasPassed
^result passedCount > 0
"Created: / 15-03-2010 / 22:06:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerEmbedded class methodsFor:'documentation'!
version_CVS
^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.2 2011-06-30 19:53:48 cg Exp $'
!
version_SVN
^ '§Id: Tools__TestRunnerEmbedded.st 7681 2011-03-04 11:30:02Z vranyj1 §'
! !