--- a/Tools__TestRunnerEmbedded.st Wed Feb 05 19:59:22 2014 +0100
+++ b/Tools__TestRunnerEmbedded.st Wed Feb 05 19:59:24 2014 +0100
@@ -320,6 +320,54 @@
allTestCases := nil
!
+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|
@@ -421,8 +469,8 @@
"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: / 22-08-2011 / 09:59:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 04-06-2012 / 19:46:38 / cg"
+ "Modified: / 03-12-2012 / 14:02:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
run
@@ -441,6 +489,14 @@
!
run:suite
+ ^self run: suite debug: false
+
+ "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>"
+!
+
+run:suite debug: debug
|suiteAndResult numTests|
numTests := suite tests size.
@@ -451,18 +507,18 @@
self stop.
testProcess := [
- |result incr run anyFail anyError|
+ |result incr run|
- anyFail := anyError := false.
+ result := debug ifFalse:[TestResult new] ifTrue:[TestResultForRunWithDebug].
[
-
self runningHolder value:true.
self progressIndicatorShownHolder value:(numTests > 1).
self progressHolder value:0.
incr := 100 / numTests.
run := 0.
result := suite
- runBeforeEachDo:[:test :result |
+ run: result
+ beforeEachDo:[:test :result |
infoHolder notNil ifTrue:[
infoHolder value:('Running "%1-%2"...'
bindWith:test name
@@ -474,14 +530,11 @@
self progressHolder value:(incr * run) truncated "rounded".
infoHolder notNil ifTrue:[
infoHolder value:('Done.')
- ].
- result hasPassed ifFalse:[
- progressIndicator foregroundColor:(Color red)
- ].
- ].
+ ]
+ ]
+ debug: debug.
suiteAndResult := SuiteAndResult suite:suite result:result.
] ensure:[
- progressIndicator initStyle.
self progressIndicatorShownHolder value:false.
self resultHolder setValue:nil; value:suiteAndResult; changed.
self runningHolder value:false.
@@ -491,9 +544,7 @@
testProcess priority:(Processor userBackgroundPriority).
testProcess 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>"
- "Modified: / 09-06-2012 / 20:23:58 / cg"
+ "Created: / 03-12-2012 / 13:59:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
runAll
@@ -524,7 +575,7 @@
suite := suiteAndResult suiteForRun.
].
- suite run: TestResultForRunWithDebug new
+ self run: suite debug: true
@@ -532,8 +583,8 @@
"/ [suiteAndResult suite tests anyOne debug] fork
"Created: / 05-07-2011 / 18:45:43 / cg"
- "Modified: / 22-08-2011 / 09:59:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 09-10-2011 / 10:55:46 / cg"
+ "Modified: / 03-12-2012 / 13:59:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
stop
@@ -896,17 +947,8 @@
!
updateTestCases
- allTestCases := Set new.
- (self selectedClassesHolder value ? #()) do:[:eachSelected |
- (self isTestCaseLike:eachSelected) ifTrue:[
- allTestCases add:eachSelected.
-"/ eachSelected allSuperclassesDo:[:eachClass |
-"/ (eachClass isTestCaseLike) ifTrue:[
-"/ allTestCases add:eachClass
-"/ ]
-"/ ]
- ]
- ].
+ allTestCases := ((self selectedClassesHolder value ? #())
+ select:[:cls | self isTestCaseLike:cls ]).
allTestCases := allTestCases asArray
"Created: / 11-03-2010 / 10:31:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
@@ -914,18 +956,26 @@
"Modified: / 04-06-2012 / 19:02:52 / cg"
!
+updateTestSuiteAndResult
+
+ | suite suiteAndResult |
+ self runningHolder value ifTrue:[^self].
+ allTestCases isEmptyOrNil ifTrue:[^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>"
+ "Modified: / 04-06-2012 / 19:03:15 / cg"
+!
+
updateVisibility
self hasTestCaseSelected
ifTrue:[self show]
- ifFalse:[self hide].
-
- (testProcess isNil or:[ testProcess isDead]) ifTrue:[
- "/ fix my ideo of being running, in case the testProcess died without
- "/ me being informed (hardTerminate)
- self runningHolder value:false.
- self progressIndicatorShownHolder value:false.
- ]
+ ifFalse:[self hide]
"Created: / 11-03-2010 / 09:02:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
@@ -1047,13 +1097,14 @@
is built and returned.
Otherwise, a suite for all methods in the class is built and returned"
- | methods protocols suite selectedClass |
+ | methods testMethods protocols suite selectedClass |
selectedClass := self theSingleTestCase.
(methods := selectedMethodsHolder value) notEmptyOrNil ifTrue:[
- suite := TestSuite named: (self suiteNameFromMethods: methods).
- (self selectedTestMethodsInClass:selectedClass) do:[:mthd|
+ testMethods := self selectedTestMethods.
+ suite := TestSuite named: (self suiteNameFromMethods: testMethods).
+ testMethods do:[:mthd|
| class selector |
class := selectedClass ifNil:[mthd mclass].
suite addTest: (class asTestCase selector: mthd selector)
@@ -1075,8 +1126,8 @@
^self suiteForRunAll
"Created: / 15-03-2010 / 13:13:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"
- "Modified: / 22-07-2011 / 15:48:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 04-08-2011 / 19:06:42 / cg"
+ "Modified: / 02-11-2012 / 11:17:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
suiteForRunAll
@@ -1265,14 +1316,14 @@
!TestRunnerEmbedded class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.36 2013-08-21 00:25:21 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.37 2014-02-05 18:59:24 cg Exp $'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.36 2013-08-21 00:25:21 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.37 2014-02-05 18:59:24 cg Exp $'
!
version_SVN
- ^ '$Id: Tools__TestRunnerEmbedded.st,v 1.36 2013-08-21 00:25:21 cg Exp $'
+ ^ '$Id: Tools__TestRunnerEmbedded.st,v 1.37 2014-02-05 18:59:24 cg Exp $'
! !