#REFACTORING by exept
class: MultiViewToolApplication
added: #askForFile:default:forSave:thenDo:
changed:
#askForFile:default:thenDo:
#askForFile:thenDo:
#menuSaveAllAs
#menuSaveAs
"{ Encoding: utf8 }"
"
Copyright (c) 2007-2010 Jan Vrany, SWING Research Group, Czech Technical University in Prague
Copyright (c) 2009-2010 eXept Software AG
Permission is hereby granted, free of charge, to any person
obtaining a copy of this software and associated documentation
files (the 'Software'), to deal in the Software without
restriction, including without limitation the rights to use,
copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following
conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.
"
"{ Package: 'stx:libtool' }"
"{ NameSpace: Tools }"
AbstractTestRunner subclass:#TestRunnerMini
instanceVariableNames:'runnerPanel selectedClassesHolder selectedProtocolsHolder
selectedMethodsHolder methodGeneratorHolder resultHolder
resultInfoHolder resultBackgroundColorHolder runningHolder
progressHolder progressIndicatorShownHolder infoHolder
testProcess allTestCases progressIndicator resultNameAspect
currentTestCaseName'
classVariableNames:''
poolDictionaries:''
category:'SUnit-UI'
!
Object subclass:#SuiteAndResult
instanceVariableNames:'suite result'
classVariableNames:''
poolDictionaries:''
privateIn:TestRunnerMini
!
!TestRunnerMini class methodsFor:'documentation'!
copyright
"
Copyright (c) 2007-2010 Jan Vrany, SWING Research Group, Czech Technical University in Prague
Copyright (c) 2009-2010 eXept Software AG
Permission is hereby granted, free of charge, to any person
obtaining a copy of this software and associated documentation
files (the 'Software'), to deal in the Software without
restriction, including without limitation the rights to use,
copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the
Software is furnished to do so, subject to the following
conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
OTHER DEALINGS IN THE SOFTWARE.
"
!
documentation
"
a tiny runner to be embedded in a system browser
"
! !
!TestRunnerMini class methodsFor:'help specs'!
helpSpec
"This resource specification was automatically generated
by the UIHelpTool of ST/X."
"Do not manually edit this!! If it is corrupted,
the UIHelpTool may not be able to read the specification."
"
UIHelpTool openOnClass:Tools::TestRunnerEmbedded
"
<resource: #help>
^ super helpSpec addPairsFrom:#(
#debugSelected
'Run the selected test(s) with debugging enabled.\\A debugger is opened on error or assertion failure'
#runAll
'Run all tests.\\No debugger is opened on error or assertion failure,\but the test outcomes are remembered'
#runFailed
'Only rerun failed tests.\\No debugger is opened on error or assertion failure,\but the test outcomes are remembered'
#runSelected
'Run the selected test(s).\\No debugger is opened on error or assertion failure,\but the test outcomes are remembered'
#stopRun
'Stop the test-run'
#pin
'Pin the runner for the selected testcase as floating window.'
#runAllWithCoverage
'Run all tests with coverage measurement.\\This first recompiles all classes which are covered by the test(s) with instrumentation enabled,\so that reached code is recorded (runs a bit slower).\After the run, the browser will colorize reached code in green, unreached code in red, and partially reached code in orange.\\Classes to be coverage tested are defined by the test''s #coveredClasses or #coveredClassNames method'
)
"Created: / 04-06-2012 / 19:27:47 / cg"
"Modified: / 21-03-2019 / 22:31:07 / Claus Gittinger"
! !
!TestRunnerMini class methodsFor:'image specs'!
pinIcon
<resource: #programImage>
^ self pinIcon2
"Modified: / 28-07-2018 / 09:49:24 / Claus Gittinger"
!
pinIcon1
"This resource specification was automatically generated
by the ImageEditor of ST/X."
"Do not manually edit this!! If it is corrupted,
the ImageEditor may not be able to read the specification."
"
self pinIcon1 inspect
ImageEditor openOnClass:self andSelector:#pinIcon1
Icon flushCachedIcons
"
<resource: #image>
^Icon
constantNamed:'Tools::TestRunnerMini pinIcon1'
ifAbsentPut:[(Depth8Image new) width:14; height:13; bits:(ByteArray fromPackedString:'
NC 8NC 8NC 8NB8/L# 8NC 8NC 8NC 8J3@1L# 8NC 8NC 8NB80J3@/APXDB@8OB3L+L3L0KB8RD1TVE1$ZJ2<0L2,8N@TGA@$JD@00KR<-M3 8M04MCP4M
CPD0KSL7NC 7CRD\HRDAHRD!!HS\8NCXMH!!4"H!!4TGQ4#M# 8M@4[IRP^IQ8XIRT5NC *CRX_I!!<_I!!<QG2$8N@LMI2 ''HB\ HB\ @# 8@@@@@@@@@@@@@@@@
NC b') ; colorMapFromArray:#[136 149 174 23 50 93 145 154 169 144 154 168 48 116 186 68 118 170 70 119 171 70 120 171 62 133 196 62 132 195 93 155 206 170 202 228 171 202 228 197 223 244 93 156 206 132 180 218 132 181 218 205 228 246 90 156 204 111 182 226 179 216 240 88 182 232 115 196 236 153 212 241 186 225 246 189 226 245 217 238 249 242 251 255 235 249 255 238 250 255 241 251 255 245 252 255 248 253 255 235 250 255 238 251 255 239 251 255 241 252 255 242 252 255 245 253 255 248 254 255 247 254 255 157 161 160 157 162 160 0 114 54 0 97 46 0 82 39 0 149 62 53 155 88 114 182 73 125 181 81 163 202 129 159 167 110 170 170 151 171 169 151 183 177 142 191 182 136 255 255 255]; mask:((Depth1Image new) width:14; height:13; bits:(ByteArray fromPackedString:'@C @O@A<??3?<O?0??C?<O?0??C?<O?0??@b') ; yourself); yourself]
!
pinIcon2
"This resource specification was automatically generated
by the ImageEditor of ST/X."
"Do not manually edit this!! If it is corrupted,
the ImageEditor may not be able to read the specification."
"
self pinIcon2 inspect
ImageEditor openOnClass:self andSelector:#pinIcon2
Icon flushCachedIcons
"
<resource: #image>
^Icon
constantNamed:'Tools::TestRunnerMini pinIcon2'
ifAbsentPut:[(Depth8Image new) width:14; height:13; bits:(ByteArray fromPackedString:'
NC 8NC 8NC 8HR8/L"D8NC 8NC 8NC !!J3@1L# 8NC 8NC 8HR80J3@/APXDB@8OB3L+L3L0KB8RD1TVE1$ZJ2<0L2,!!HPTGA@$JD@00KR<-M3 8M04MCP4M
CPD0KSL7NC 7CRD\HRDAHRD!!HS\8NCXMH!!4"H!!4TGQ4#M# 8M@4[IRP^IQ8XIRT5NC *CRX_I!!<_I!!<QG2$8N@LMI2 ''HB\ HB\ @# 8@@@@@@@@@@@@@@@@
NC b') ; colorMapFromArray:#[136 149 174 23 50 93 145 154 169 144 154 168 48 116 186 68 118 170 70 119 171 70 120 171 62 133 196 62 132 195 93 155 206 170 202 228 171 202 228 197 223 244 93 156 206 132 180 218 132 181 218 205 228 246 90 156 204 111 182 226 179 216 240 88 182 232 115 196 236 153 212 241 186 225 246 189 226 245 217 238 249 242 251 255 235 249 255 238 250 255 241 251 255 245 252 255 248 253 255 235 250 255 238 251 255 239 251 255 241 252 255 242 252 255 245 253 255 248 254 255 247 254 255 157 161 160 157 162 160 114 0 18 97 25 0 82 21 0 149 30 0 155 66 53 182 73 138 181 81 147 202 129 179 163 110 167 170 170 151 171 169 151 183 177 142 191 182 136 255 255 255]; mask:((Depth1Image new) width:14; height:13; bits:(ByteArray fromPackedString:'@G0@_@C<??3??O?0??C?<O?0??C?<O?0??@b') ; yourself); yourself]
! !
!TestRunnerMini 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::TestRunnerMini andSelector:#windowSpec
Tools::TestRunnerMini new openInterface:#windowSpec
Tools::TestRunnerMini open
"
<resource: #canvas>
^
#(FullSpec
name: windowSpec
uuid: '0d236cb2-50b6-11e9-a55c-b8f6b1108e05'
window:
(WindowSpec
label: 'Mini Test Runner'
name: 'Mini Test Runner'
uuid: 'e9826d32-50a4-11e9-a55c-b8f6b1108e05'
min: (Point 10 10)
bounds: (Rectangle 0 0 600 50)
)
component:
(SpecCollection
collection: (
(ViewSpec
name: 'Box1'
layout: (LayoutFrame 0 0 0 0 0 1 0 1)
uuid: 'e9827192-50a4-11e9-a55c-b8f6b1108e05'
backgroundChannel: resultBackgroundColorAspect
component:
(SpecCollection
collection: (
(HorizontalPanelViewSpec
name: 'RunnerInnerBox'
layout: (LayoutFrame 0 0 0 0 -2 1 0 1)
uuid: 'e9827372-50a4-11e9-a55c-b8f6b1108e05'
backgroundChannel: resultBackgroundColorAspect
horizontalLayout: rightSpaceFit
verticalLayout: topSpace
horizontalSpace: 0
elementsChangeSize: true
component:
(SpecCollection
collection: (
(ViewSpec
name: 'RunnerInfoBox'
uuid: 'e98275ca-50a4-11e9-a55c-b8f6b1108e05'
backgroundChannel: resultBackgroundColorAspect
component:
(SpecCollection
collection: (
(ActionButtonSpec
name: 'Button3'
layout: (LayoutFrame 5 0 3 0 21 0 17 0)
activeHelpKey: pin
uuid: 'e98276b0-50a4-11e9-a55c-b8f6b1108e05'
level: 0
visibilityChannel: pinButtonVisibleHolder
backgroundChannel: resultBackgroundColorAspect
hasCharacterOrientedLabel: false
translateLabel: true
labelChannel: pinIcon
model: pin
)
(LabelSpec
label: 'Run tests first!!'
name: 'ResultName'
layout: (LayoutFrame 22 0 -2 0 0 1 -12 1)
uuid: 'e9827a5c-50a4-11e9-a55c-b8f6b1108e05'
backgroundChannel: resultBackgroundColorAspect
foregroundChannel: resultTextForegroundColorAspect
foregroundColor: (Color 100.0 100.0 100.0)
translateLabel: true
labelChannel: resultNameAspect
adjust: left
)
(ViewSpec
name: 'ProgressPanel'
layout: (LayoutFrame 0 0 -12 1 0 1.0 -6 1)
uuid: 'e9827c6e-50a4-11e9-a55c-b8f6b1108e05'
initiallyInvisible: true
visibilityChannel: progressIndicatorShownHolder
backgroundChannel: resultBackgroundColorAspect
component:
(SpecCollection
collection: (
(ProgressIndicatorSpec
name: 'ProgressIndicator1'
layout: (LayoutFrame 5 0 0 0 -5 1 0 1)
uuid: 'e9827d90-50a4-11e9-a55c-b8f6b1108e05'
level: 0
model: progressHolder
postBuildCallback: postBuildProgressIndicator:
)
)
)
)
)
)
extent: (Point 206 31)
)
(ActionButtonSpec
label: 'Debug'
name: 'DebugButton'
activeHelpKey: debugSelected
uuid: 'e982804c-50a4-11e9-a55c-b8f6b1108e05'
translateLabel: true
model: debug
enableChannel: runEnabledHolder
extent: (Point 60 25)
)
(ActionButtonSpec
label: 'Stop'
name: 'Button2'
activeHelpKey: stopRun
uuid: 'e98281fa-50a4-11e9-a55c-b8f6b1108e05'
visibilityChannel: runningHolder
translateLabel: true
model: stop
extent: (Point 60 25)
)
(ActionButtonSpec
label: 'Run'
name: 'Run'
activeHelpKey: runSelected
uuid: 'e98283a8-50a4-11e9-a55c-b8f6b1108e05'
visibilityChannel: notRunningHolder
translateLabel: true
model: run
enableChannel: runEnabledHolder
extent: (Point 60 25)
)
(ActionButtonSpec
label: 'Failed'
name: 'Button1'
activeHelpKey: runFailed
uuid: 'e982852e-50a4-11e9-a55c-b8f6b1108e05'
visibilityChannel: runFailedButtonVisibleHolder
translateLabel: true
model: runFailed
enableChannel: runFailedEnabledHolder
extent: (Point 60 25)
)
(ActionButtonSpec
label: 'Run All'
name: 'RunAll'
activeHelpKey: runAll
uuid: 'e9828696-50a4-11e9-a55c-b8f6b1108e05'
visibilityChannel: runAllButtonVisibleHolder
translateLabel: true
model: runAll
enableChannel: runAllEnabledHolder
extent: (Point 60 25)
)
(ActionButtonSpec
label: 'Coverage'
name: 'Button4'
activeHelpKey: runAllWithCoverage
uuid: 'e98287fe-50a4-11e9-a55c-b8f6b1108e05'
visibilityChannel: runAllButtonVisibleHolder
translateLabel: true
model: runAllWithCoverage
enableChannel: runAllEnabledHolder
extent: (Point 80 25)
)
)
)
postBuildCallback: postBuildRunnerPanel:
)
(LabelSpec
name: 'ResultInfo'
layout: (LayoutFrame 0 0 -20 1 0 1 0 1)
style: (FontDescription helvetica medium roman 10 #'iso10646-1' nil nil)
uuid: 'e9828984-50a4-11e9-a55c-b8f6b1108e05'
backgroundChannel: resultBackgroundColorAspect
foregroundChannel: resultTextForegroundColorAspect
translateLabel: true
labelChannel: resultInfoAspect
adjust: left
)
)
)
)
)
)
)
! !
!TestRunnerMini class methodsFor:'queries'!
shouldRememberLastExtent
"to be redefined by concrete applications:
if true is answered, the application's extent is remembered on close
and used as a default when opened the next time"
^ false
"Created: / 22-09-2014 / 14:02:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerMini methodsFor:'accessing'!
allTestCases
allTestCases isNil ifTrue:[
self updateTestCases
].
^ allTestCases
!
allTestCases:something
allTestCases := something.
!
infoHolder:something
"to show something in the browsers info area (near the bottom"
infoHolder := something.
"Created: / 05-07-2011 / 16:22:24 / cg"
!
selectedTestMethods
| selectedClass |
selectedClass := self theSingleTestCase.
^ (self selectedMethodsHolder value ? #()) select:
[:mthd | | cls |
(cls := selectedClass) isNil ifTrue:[cls := mthd mclass].
(self isTestCaseLike:selectedClass)
and:[ selectedClass isTestSelector:mthd selector ] ]
"Created: / 15-03-2010 / 13:21:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 22-07-2011 / 15:46:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 02-08-2011 / 17:46:38 / cg"
!
selectedTestMethodsFromProtocols:protocols
|methods generator selectedClass|
methods := Set new.
generator := self methodGeneratorHolder value.
selectedClass := self theSingleTestCase.
generator notNil ifTrue:[
generator do: [:cls :cat :sel :mthd |
(mthd notNil
and:[ (self isTestCaseLike:(selectedClass ? cls))
and:[ (selectedClass ? cls) isTestSelector:sel ] ])
ifTrue:[ methods add:mthd ]
]
] ifFalse:[
allTestCases 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: / 22-07-2011 / 15:53:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified (format): / 04-06-2012 / 19:05:32 / cg"
!
selectedTestMethodsFromProtocols:protocols inClass:aTestClass
|methods generator|
methods := Set new.
generator := self methodGeneratorHolder value.
generator notNil ifTrue:[
generator do: [:cls :cat :sel :mthd |
(mthd notNil
and:[ (self isTestCaseLike:(aTestClass ? cls))
and:[ (aTestClass ? cls) isTestSelector:sel ] ])
ifTrue:[ methods add:mthd ]
]
] ifFalse:[
self allTestCases do: [:cls |
cls methodsDo: [:mthd |
((protocols includes:mthd category) and:[ cls isTestSelector:mthd selector ])
ifTrue:[
methods add:mthd
]
]
]
].
methods := methods asOrderedCollection.
methods sortBySelector:#selector.
^ methods
"Created: / 15-03-2010 / 19:50:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 22-07-2011 / 15:53:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified (format): / 04-06-2012 / 19:05:32 / cg"
!
selectedTestMethodsInClass:testClass
^ (self selectedMethodsHolder value ? #()) select:
[:mthd | | cls |
(cls := testClass) isNil ifTrue:[cls := mthd mclass].
(self isTestCaseLike:testClass)
and:[ testClass isTestSelector:mthd selector ] ]
"Created: / 15-03-2010 / 13:21:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 22-07-2011 / 15:46:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 02-08-2011 / 17:46:38 / cg"
!
theSingleTestCase
self allTestCases isEmptyOrNil ifTrue:[^nil].
allTestCases size > 1 ifTrue:[^nil].
^allTestCases anyOne.
"Created: / 22-07-2011 / 15:44:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerMini methodsFor:'actions'!
debug
"run the selected test(s), opening a debugger on error/fail.
Also executes tests which want to be skipped"
| suiteAndResult suite result testRunAction|
suiteAndResult := resultHolder value.
suite := suiteAndResult suiteForRun.
"/ ^self run:suite debug: true coverageContext: nil.
"/ suite tests size ~= 1 ifTrue:[^self breakPoint: #jv].
"/ test := suiteAndResult suite tests anyOne.
result := TestResult defaultResultClass new.
suiteAndResult := SuiteAndResult suite: suite result: result.
self stop.
testRunAction := [
"/ debug run is synchronous
[
self runningHolder value:true.
self windowGroup repairDamage.
suite tests do:[:test |
|skipped|
skipped := false.
[
[
self activityNotification:('running %1...' bindWith:test selector).
test debug.
] on:TestResult skipped do:[:ex |
ex proceed.
"/ skipped := true.
].
] ifCurtailed:[
result failureOutcomes add: test.
resultHolder value:suiteAndResult; changed.
].
skipped ifTrue:[
result skippedOutcomes add: test.
resultHolder value:suiteAndResult; changed.
] ifFalse:[
(test class testSelectorPassed:test selector) ifTrue:[
"/ result := TestResult defaultResultClass new.
"/ result passed add: test.
"/ suiteAndResult := SuiteAndResult suite: suite result: result.
result passedOutcomes add: test.
resultHolder value:suiteAndResult; changed.
] ifFalse:[
(test class testSelectorFailed:test selector) ifTrue:[
"/ result := TestResult defaultResultClass new.
"/ result failures add: test.
"/ suiteAndResult := SuiteAndResult suite: suite result: result.
result failureOutcomes add: test.
resultHolder value:suiteAndResult; changed.
]
].
].
self windowGroup repairDamage
].
] ensure:[
self runningHolder value:false.
].
].
testRunAction value.
"/ testProcess := testRunAction newProcess.
"/ testProcess priority:(Processor userBackgroundPriority).
"/ testProcess resume.
"Created: / 15-03-2010 / 15:43:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 07-07-2011 / 11:33:48 / Jan Vrany <jan.vrant@fit.cvut,cz>"
"Modified: / 03-12-2012 / 14:02:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 18-02-2016 / 16:49:14 / cg"
"Modified: / 26-06-2019 / 15:17:02 / Claus Gittinger"
!
pin
"create a new pinned runner;
that is one in its own top window"
| runner screen |
runner := TestRunnerMini new.
runner resultHolder value: resultHolder value copy.
runner allButOpen.
screen := Screen current.
(screen notNil and:[ screen isX11Platform ]) ifTrue:[
"/ Use EWMH hint to tell the WM that the window is
"/ a sort of floating tool so WM can decorate it according to
"/ DE standards.
runner window id isNil ifTrue:[
runner window create.
].
screen setWindowType:#'_NET_WM_WINDOW_TYPE_UTILITY' in:runner window id.
].
runner open.
"Modified: / 23-09-2014 / 12:05:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 25-07-2019 / 12:32:39 / Claus Gittinger"
!
run
"run the selected test(s), NOT opening a debugger on error/fail.
Also executes tests which want to be skipped"
|suite|
resultHolder value isNil ifTrue:[
suite := self suiteForRun
] ifFalse:[
suite := resultHolder value suiteForRun
].
[
self run:suite debug:false coverageContext:nil
] on:TestResult skipped do:[:ex |
ex proceed.
]
"Created: / 10-03-2010 / 19:42:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 22-08-2011 / 09:58:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 09-10-2011 / 10:56:39 / cg"
"Modified: / 27-03-2019 / 16:16:26 / Claus Gittinger"
!
run:suite
^self run:suite debug:false coverageContext:nil
"Created: / 11-03-2010 / 10:22:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 09-06-2012 / 20:23:58 / cg"
"Modified: / 03-12-2012 / 13:59:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 27-03-2019 / 16:16:14 / Claus Gittinger"
!
run:suite debug: debug
self run:suite debug:debug coverageContext:nil
"Modified (format): / 27-03-2019 / 16:16:05 / Claus Gittinger"
!
run:suite debug: debug coverageContext: coverageContextOrNil
|suiteAndResult numTests testRunAction|
numTests := suite tests size.
numTests == 0 ifTrue:[
^ self
].
self stop.
testRunAction :=
[
|result incr run|
result := (debug ifFalse:[TestResult] ifTrue:[TestResultForRunWithDebug]) new.
suiteAndResult := SuiteAndResult suite:suite result:result.
resultHolder setValue:nil; value:suiteAndResult; changed.
[
self runningHolder value:true.
self progressIndicatorShownHolder value:(numTests > 1).
self progressHolder value:0.
incr := 100 / numTests.
run := 0.
result := suite
run: result
beforeEachDo:[:test :result |
currentTestCaseName := (' (run: ',test getTestName allBold,')').
resultHolder changed.
infoHolder notNil ifTrue:[
infoHolder value:('Running "%1-%2"...'
bindWith:test name
with:test getTestName allBold).
self window repairDamage.
] ifFalse:[
self activityNotification:('Running "%1-%2"...'
bindWith:test name
with:test getTestName allBold).
]
]
afterEachDo:[:test :result |
currentTestCaseName := nil.
run := run + 1.
self progressHolder value:(incr * run) truncated "rounded".
infoHolder notNil ifTrue:[
infoHolder value:('Done.').
self window repairDamage.
].
resultHolder setValue:nil; value:suiteAndResult; changed.
]
debug: debug.
suiteAndResult := SuiteAndResult suite:suite result:result.
] ensure:[
self progressIndicatorShownHolder value:false.
resultHolder setValue:nil; value:suiteAndResult; changed.
self runningHolder value:false.
infoHolder notNil ifTrue:[
infoHolder value:('Finished.').
] ifFalse:[
self activityNotification:('Finished.').
]
]
].
coverageContextOrNil notNil ifTrue:[
|realAction|
realAction := testRunAction.
testRunAction := [ coverageContextOrNil run:realAction ]
].
testProcess := testRunAction newProcess.
testProcess priority:(Processor userBackgroundPriority).
testProcess resume.
"Created: / 03-12-2012 / 13:59:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 18-02-2016 / 16:57:27 / cg"
"Modified: / 26-06-2019 / 15:22:35 / Claus Gittinger"
!
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>"
"Modified: / 04-06-2012 / 19:00:14 / cg"
!
runAllWithCoverage
"return a collection of classes which are covered by the selected
tests. Requires that the testcase returns a non-empty collection
from the coveredClasses query"
|testedClasses suite instrumentPackage suiteClasses suiteClass
answer coveredClassNamesString coveredClassNames coveredClasses|
suite := self suiteForRunAll.
instrumentPackage := false.
testedClasses := suite allCoveredClasses.
testedClasses isEmpty ifTrue:[
suite tests isEmpty ifTrue:[
Dialog warn:(resources stringWithCRs:'The test suite is empty - nothing covered, I assume.').
^ self.
].
suiteClasses := suite tests collect:#class.
suiteClasses size == 1 ifTrue:[
suiteClass := suiteClasses first
].
suiteClass notNil ifTrue:[
answer := Dialog
confirmWithCancel:(resources stringWithCRs:'The test cases do not define any covered class.\(missing #coveredClassNames or #coveredPackageNames method on the TestCase''s class side)\\Define covered classes now?\(click on "No" to run without coverage)')
labels:(resources array:#('Cancel' 'No' 'Yes')).
answer isNil ifTrue:[^ self].
answer == true ifTrue:[
coveredClassNamesString := Dialog request:'Name(s) of class(es) covered by test\(separate by blanks)'.
coveredClassNamesString isEmptyOrNil ifTrue:[^ self].
coveredClassNames := (coveredClassNamesString splitBy:' ') collect:#withoutSeparators.
coveredClasses := coveredClassNames
collect:[:nm |
|cls|
(cls := Smalltalk classNamed:nm) isNil ifTrue:[
Dialog warn:'No class named "%1" found' with:nm
].
cls]
thenSelect:[:cls | cls notNil].
(suiteClass theMetaclass includesSelector:#coveredClassNames) ifFalse:[
suiteClass theMetaclass
compile:('coveredClassNames
"These classes will be instrumented for coverage analysis,
before running the suite to provide coverage analysis/report"
^ %1
' bindWith:(coveredClasses collect:#name as:Array) storeString)
classified:'queries'.
testedClasses := suite allCoveredClasses.
].
].
].
].
testedClasses notEmptyOrNil ifTrue:[
self withWaitCursorDo:[
infoHolder notNil ifTrue:[
infoHolder value:('Instrumenting...')
].
testedClasses do:[:eachClass |
masterApplication recompileClassWithInstrumentation:eachClass.
InstrumentationInfo cleanAllInfoFor:eachClass withChange:true.
].
].
infoHolder notNil ifTrue:[
infoHolder value:('Running test...')
].
].
self
run:suite
debug:false
coverageContext:(InstrumentationContext new coverageOnly:true)
"Modified: / 19-07-2017 / 12:47:18 / cg"
"Modified (format): / 21-08-2018 / 17:38:50 / Claus Gittinger"
!
runFailed
self run: self suiteForRunFailed.
"Created: / 04-06-2012 / 18:32:19 / cg"
!
runWithDebug
"/ cg: I really do not want to run them twice to get a debugger
"/ - I want to run them either with a debugger coming right away, or not.
| suiteAndResult suite|
suiteAndResult := resultHolder value.
suiteAndResult isNil ifTrue:[
suite := self suiteForRun.
] ifFalse:[
suite := suiteAndResult suiteForRun.
].
self run: suite debug: true
"/ suiteAndResult suite tests size ~= 1 ifTrue:[^self breakPoint: #jv].
"/ [suiteAndResult suite tests anyOne debug] fork
"Created: / 05-07-2011 / 18:45:43 / cg"
"Modified: / 09-10-2011 / 10:55:46 / cg"
"Modified: / 03-12-2012 / 13:59:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
stop
|p|
(p := testProcess) notNil ifTrue:[
testProcess := nil.
p terminate
].
"Created: / 04-06-2012 / 18:34:07 / cg"
! !
!TestRunnerMini methodsFor:'aspects'!
debugVisibleAspect
^ BlockValue
with:[:model |
model notNil
and:[ model countTests == 1
and:[ model hasFailuresOrErrors ]]
]
argument:resultHolder
"Created: / 15-03-2010 / 15:40:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 02-08-2011 / 18:19:14 / cg"
!
notRunningHolder
^ BlockValue forLogicalNot:(self runningHolder)
"Created: / 04-06-2012 / 18:38:48 / cg"
!
progressHolder
"return/create the 'progressHolder' value holder (automatically generated)"
progressHolder isNil ifTrue:[
progressHolder := ValueHolder new.
].
^ progressHolder
!
progressIndicatorShownHolder
progressIndicatorShownHolder isNil ifTrue:[
progressIndicatorShownHolder := ValueHolder with: false.
].
^ progressIndicatorShownHolder
"Modified: / 15-03-2010 / 20:29:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified (comment): / 04-06-2012 / 18:38:52 / cg"
"Created: / 04-06-2012 / 19:42:59 / cg"
!
resultBackgroundColorAspect
<resource: #uiAspect>
resultBackgroundColorHolder isNil ifTrue:[
resultBackgroundColorHolder := BlockValue
with:[:result :running |
running ifTrue:[
self class currentlyRunningColor
"/ View defaultBackgroundColor
] ifFalse:[
result isNil ifTrue:[
self class notRunColor
] ifFalse:[
result color
]
].
]
argument:resultHolder
argument:self runningHolder.
resultBackgroundColorHolder
onChangeEvaluate:[
runnerPanel notNil ifTrue:[
runnerPanel backgroundColor:resultBackgroundColorHolder value
]
].
].
^ resultBackgroundColorHolder.
"Created: / 15-03-2010 / 15:22:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 04-06-2012 / 19:40:11 / cg"
"Modified: / 23-09-2014 / 09:46:03 / 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 isNil
ifTrue:[ '' ]
ifFalse:[ model info,(currentTestCaseName ? '') ]
]
argument:resultHolder
"Created: / 15-03-2010 / 20:22:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 02-08-2011 / 18:20:26 / cg"
"Modified: / 27-03-2019 / 16:19:23 / Claus Gittinger"
!
resultNameAspect
resultNameAspect isNil ifTrue:[
resultNameAspect := BlockValue
with:[:model | model isNil ifTrue:[ 'Run the tests!!' ] ifFalse:[ model name ] ]
argument:resultHolder.
].
^ resultNameAspect
"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>"
"Modified: / 02-08-2011 / 18:20:38 / cg"
"Modified: / 27-03-2019 / 16:09:41 / Claus Gittinger"
!
resultTextForegroundColorAspect
<resource: #uiAspect>
^ BlockValue
with:[:bgColor |
bgColor brightness > 0.6 ifTrue:[
Color black
] ifFalse:[
Color white
].
]
argument:self resultBackgroundColorAspect
!
runAllEnabledHolder
^ self notRunningHolder
"Created: / 07-09-2010 / 09:15:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 04-06-2012 / 18:40:46 / cg"
!
runEnabledHolder
^BlockValue
with:
[:result :running |
running not
and:[ result notNil
and:[ result countTests > 0 ]]
]
argument: self resultHolder
argument: self runningHolder
"Created: / 07-09-2010 / 09:15:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 18-02-2016 / 16:54:29 / cg"
!
runFailedEnabledHolder
^BlockValue
with:
[:running |
|result|
running not
and:[ TestResult notNil
and:[ TestResult isLoaded
and:[ result := self resultForSuite:self suiteForRunAll. result notNil
and:[ result hasFailuresOrErrors ]]]]
]
"/ argument: self resultHolder
argument: self runningHolder
"Created: / 07-09-2010 / 09:15:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Created: / 04-06-2012 / 18:28:12 / cg"
"Modified: / 18-07-2012 / 09:55:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
runningHolder
runningHolder isNil ifTrue:[
runningHolder := ValueHolder with: false.
].
^ runningHolder
"Modified: / 15-03-2010 / 20:29:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified (comment): / 04-06-2012 / 18:38:52 / cg"
!
stopEnabledHolder
^ self runningHolder
"Created: / 04-06-2012 / 18:29:01 / cg"
! !
!TestRunnerMini methodsFor:'aspects-visibility'!
pinButtonVisibleHolder
^ false
"Created: / 23-09-2014 / 10:11:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
runAllButtonVisibleHolder
^ false
"Created: / 23-09-2014 / 10:12:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
runFailedButtonVisibleHolder
^ false
"Created: / 23-09-2014 / 10:12:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerMini methodsFor:'change & update'!
invalidateSuiteAndResult
resultHolder value:nil.
!
update:aspect with:param from:sender
sender == Smalltalk ifTrue:[
aspect == #lastTestRunResult ifTrue:[
allTestCases notNil ifTrue:[
(allTestCases includesIdentical: param first) ifTrue:[
self invalidateSuiteAndResult. "/ updateSuiteAndResult.
self enqueueDelayedAction:[ self updateSuiteAndResult ].
^self
]
].
]
].
super update:aspect with:param from:sender
"Modified: / 23-09-2014 / 10:23:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified (comment): / 27-03-2019 / 16:14:24 / Claus Gittinger"
!
updateSuiteAndResult
| suite suiteAndResult |
self runningHolder value ifTrue:[^self].
self allTestCases isEmptyOrNil ifTrue:[^self].
suite := self suiteForRun.
suiteAndResult := SuiteAndResult
suite: suite
result: (self resultForSuite: suite).
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>"
"Modified: / 04-06-2012 / 19:03:15 / cg"
!
updateTestCases
"/ Nothing to do here
"Created: / 23-09-2014 / 12:02:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
updateTestSuiteAndResult
<resource: #obsolete>
"/ ouch: duplicate code
^ self updateSuiteAndResult
"/ | suite suiteAndResult |
"/
"/ self runningHolder value ifTrue:[^self].
"/ allTestCases isEmptyOrNil ifTrue:[^self].
"/
"/ suite := self suiteForRun.
"/ suiteAndResult := SuiteAndResult
"/ suite: suite
"/ result: (self resultForSuite: suite).
"/ 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>"
"Modified: / 04-06-2012 / 19:03:15 / cg"
"Modified: / 27-03-2019 / 16:15:00 / Claus Gittinger"
!
updateVisibility
"/ cg: now done by embedder via a valueHolder on the visibility
^ self.
"/ self hasTestCaseSelected
"/ ifTrue:[self show]
"/ ifFalse:[self hide]
"Created: / 11-03-2010 / 09:02:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerMini methodsFor:'hooks'!
commonPostOpen
super commonPostOpen.
Smalltalk addDependent: self.
"Created: / 17-11-2011 / 20:59:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
postBuildRunnerPanel: aView
runnerPanel := aView.
runnerPanel backgroundColor: self resultBackgroundColorAspect value
"Created: / 15-03-2010 / 14:26:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
release
super release.
Smalltalk removeDependent: self.
"Created: / 23-09-2014 / 10:22:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 16-07-2017 / 12:21:08 / cg"
!
releaseAsSubCanvas
Smalltalk removeDependent: self.
"Created: / 17-11-2011 / 21:03:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerMini methodsFor:'initialization'!
initialize
super initialize.
resultHolder := ValueHolder new.
! !
!TestRunnerMini methodsFor:'private'!
isTestCaseLike:cls
^(super isTestCaseLike: cls) and:
[(cls askFor: #isAbstract) not]
"Modified: / 04-03-2011 / 06:54:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
postBuildProgressIndicator:aWidget
progressIndicator := aWidget
! !
!TestRunnerMini methodsFor:'queries'!
allCoveredClasses
"return a collection of classes which are covered by the selected
tests. Requires that the testcase returns a non-empty collection
from the coveredClasses query"
^ self suiteForRunAll allCoveredClasses.
!
hasTestCaseSelected
^self allTestCases notEmptyOrNil
"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>"
"Modified: / 04-08-2011 / 20:42:10 / cg"
! !
!TestRunnerMini methodsFor:'utilities'!
resultForSuite:suite
|result|
result := TestResult defaultResultClass new.
suite isNil ifTrue:[ ^ result ].
suite tests do:[:test |
| sel cls |
sel := test selector.
cls := test class.
(cls testSelectorPassed:sel) ifTrue:[
result passedOutcomes add: (cls rememberedOutcomeFor: sel)
] ifFalse:[
(cls testSelectorError:sel) ifTrue:[
result errorOutcomes add:(cls rememberedOutcomeFor: sel)
] ifFalse:[
(cls testSelectorFailed:sel) ifTrue:[
result failureOutcomes add:(cls rememberedOutcomeFor: sel)
]
]
]
].
^ result
"Created: / 15-03-2010 / 19:46:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 20-08-2011 / 14:30:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 18-02-2016 / 16:43:39 / cg"
!
suiteForRun
|result|
(result := resultHolder value) isNil ifTrue:[^ nil].
^ result suiteForRun
"Modified: / 23-09-2014 / 12:07:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
suiteForRunAll
"raise an error: must be redefined in concrete subclass(es)"
^ self suiteForRun
"Modified: / 23-09-2014 / 12:07:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
suiteForRunFailed
|suite numTests|
suite := TestSuite named:(self suiteNameFromClasses: self allTestCases).
numTests := 0.
self suiteForRunAll tests do:[:eachTest |
| sel cls |
sel := eachTest selector.
cls := eachTest class.
(cls testSelectorPassed:sel) ifFalse:[
suite addTest:eachTest.
numTests := numTests + 1.
]
].
numTests == 1 ifTrue:[
suite name:(suite tests first selector)
] ifFalse:[
suite name:(suite tests size printString,' tests')
].
^suite
"Modified: / 23-09-2014 / 12:09:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerMini::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>"
! !
!TestRunnerMini::SuiteAndResult methodsFor:'accessing'!
color
|numTests numRun|
self countTests > 0 ifTrue:[
result notNil ifTrue:[
self hasErrors ifTrue:[^AbstractTestRunner errorColor].
self hasFailures ifTrue:[^AbstractTestRunner failedColor].
self hasSkipped ifTrue:[^AbstractTestRunner notRunColor].
self hasPassed ifTrue:[
numTests := suite tests size.
numRun := result passedCount + result failureCount + result errorCount.
numRun = numTests ifTrue:[
^AbstractTestRunner passedColor
]
].
]
].
^ AbstractTestRunner notRunColor
"Created: / 15-03-2010 / 15:24:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 23-09-2014 / 10:04:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
countTests
^suite tests size
"Created: / 15-03-2010 / 15:44:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
info
|numTests numRun skippedCount passedCount failureCount errorCount|
result ifNil:[^''].
numTests := suite tests size.
skippedCount := result skippedCount.
passedCount := result passedCount.
failureCount := result failureCount.
errorCount := result errorCount.
numRun := passedCount + failureCount + errorCount.
"/ (passedCount + failureCount + errorCount) = 1 ifTrue:[^''].
numRun == 0 ifTrue:[
numTests == 1 ifTrue:[
result skippedOutcomes size == 1 ifTrue:[
^ (result skippedOutcomes first exceptionDetail ? 'skipped') asString
].
^ 'not run'
].
^ '%1 tests, 0 run' bindWith: numTests
].
numRun < numTests ifTrue:[
skippedCount > 0 ifTrue:[
^'%1 tests, %2 run, %5 skipped, %3 passed, %4 fail or error'
bindWith: numTests
with: numRun
with: passedCount
with: (failureCount+errorCount)
with: skippedCount
].
^'%1 tests, %2 run, %3 passed, %4 fail or error'
bindWith: numTests
with: numRun
with: passedCount
with: (failureCount+errorCount)
].
skippedCount > 0 ifTrue:[
^'%1 tests, %5 skipped, %2 passed, %3 failed, %4 errors'
bindWith: numTests
with: passedCount
with: failureCount
with: errorCount
with: skippedCount
].
^'%1 tests, %2 passed, %3 failed, %4 errors'
bindWith: numTests
with: passedCount
with: failureCount
with: errorCount
"Created: / 15-03-2010 / 20:23:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 23-03-2019 / 10:24:23 / Claus Gittinger"
!
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.
!
suiteForRun
| suiteForRun |
suiteForRun := suite class named: suite name.
suiteForRun addTests:
(suite tests collect:[:testCase|testCase class selector: testCase selector]).
^suiteForRun
"Created: / 22-08-2011 / 09:56:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
testCount
"obsoleted, because all methods starting with 'test'
are considered to be tests; so this is a bad name;
please use countTests"
^ self countTests
"Created: / 15-03-2010 / 15:44:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestRunnerMini::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>"
!
hasSkipped
^result skippedCount > 0
! !
!TestRunnerMini class methodsFor:'documentation'!
version
^ '$Header$'
!
version_CVS
^ '$Header$'
!
version_SVN
^ '$Id$'
! !