--- a/Tools__TestRunnerEmbedded.st Wed Oct 31 11:22:31 2012 +0100
+++ b/Tools__TestRunnerEmbedded.st Wed Oct 31 14:33:51 2012 +0100
@@ -300,6 +300,13 @@
!TestRunnerEmbedded methodsFor:'accessing'!
+allTestCases
+ allTestCases isNil ifTrue:[
+ self updateTestCases
+ ].
+ ^ allTestCases
+!
+
infoHolder:something
"to show something in the browsers info area (near the bottom"
@@ -308,39 +315,26 @@
"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"
+invalidateAllTestCases
+ allTestCases := nil
!
-selectedTestMethodsFromProtocols:protocols
+selectedTestMethodsFromProtocols:protocols inClass:aTestClass
- |methods generator selectedClass|
+ |methods generator|
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 ] ])
+ and:[ (self isTestCaseLike:(aTestClass ? cls))
+ and:[ (aTestClass ? cls) isTestSelector:sel ] ])
ifTrue:[ methods add:mthd ]
]
] ifFalse:[
- allTestCases do: [:cls |
+ self allTestCases do: [:cls |
cls methodsDo: [:mthd |
((protocols includes:mthd category) and:[ cls isTestSelector:mthd selector ])
ifTrue:[
@@ -356,9 +350,21 @@
"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
- allTestCases isEmptyOrNil ifTrue:[^nil].
+ self allTestCases isEmptyOrNil ifTrue:[^nil].
allTestCases size > 1 ifTrue:[^nil].
^allTestCases anyOne.
@@ -795,36 +801,51 @@
!TestRunnerEmbedded methodsFor:'change & update'!
+invalidateSuiteAndResult
+ self resultHolder value:nil.
+!
+
+invalidateTestCases
+ allTestCases := nil.
+!
+
update:aspect with:param from: sender
"Invoked when an object that I depend upon sends a change notification."
sender == selectedClassesHolder ifTrue:[
self
- updateTestCases;
- updateTestSuiteAndResult;
+ invalidateTestCases; "/ updateTestSuite;
+ invalidateSuiteAndResult; "/ updateTestSuiteAndResult;
updateVisibility.
+ self enqueueDelayedAction:[ self updateTestCases; updateSuiteAndResult ].
^ self.
].
sender == selectedProtocolsHolder ifTrue:[
- self updateTestSuiteAndResult.
+ self invalidateSuiteAndResult. "/ updateTestSuiteAndResult.
+ self enqueueDelayedAction:[ self updateSuiteAndResult ].
^self
].
sender == selectedMethodsHolder ifTrue:[
- self updateTestSuiteAndResult.
+ self invalidateSuiteAndResult. "/ updateTestSuiteAndResult.
+ self enqueueDelayedAction:[ self updateSuiteAndResult ].
^self
].
sender == methodGeneratorHolder ifTrue:[
- self updateTestSuiteAndResult.
+ self invalidateSuiteAndResult. "/ updateTestSuiteAndResult.
+ self enqueueDelayedAction:[ self updateSuiteAndResult ].
^self
].
sender == Smalltalk ifTrue:[
aspect == #lastTestRunResult ifTrue:[
- (allTestCases includesIdentical: param first) ifTrue:[
- self updateTestSuiteAndResult.
- ^self
- ]
+ allTestCases notNil ifTrue:[
+ (allTestCases includesIdentical: param first) ifTrue:[
+ self invalidateSuiteAndResult. "/ updateTestSuiteAndResult.
+ self enqueueDelayedAction:[ self updateSuiteAndResult ].
+ ^self
+ ]
+ ].
]
].
@@ -836,6 +857,22 @@
"Modified: / 04-06-2012 / 19:03:34 / cg"
!
+updateSuiteAndResult
+ | suite suiteAndResult |
+
+ self runningHolder value ifTrue:[^self].
+ 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"
+!
+
updateTestCases
allTestCases := ((self selectedClassesHolder value ? #())
select:[:cls | self isTestCaseLike:cls ]).
@@ -846,21 +883,6 @@
"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
@@ -940,7 +962,7 @@
hasTestCaseSelected
- ^allTestCases notEmptyOrNil
+ ^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>"
@@ -981,9 +1003,10 @@
| methods protocols suite selectedClass |
selectedClass := self theSingleTestCase.
+
(methods := selectedMethodsHolder value) notEmptyOrNil ifTrue:[
suite := TestSuite named: (self suiteNameFromMethods: methods).
- self selectedTestMethods do:[:mthd|
+ (self selectedTestMethodsInClass:selectedClass) do:[:mthd|
| class selector |
class := selectedClass ifNil:[mthd mclass].
suite addTest: (class asTestCase selector: mthd selector)
@@ -993,7 +1016,7 @@
(protocols := selectedProtocolsHolder value) isEmptyOrNil ifFalse:[
suite := TestSuite named: (self suiteNameFromProtocols: protocols).
- (self selectedTestMethodsFromProtocols: protocols) do:[:mthd|
+ (self selectedTestMethodsFromProtocols: protocols inClass:selectedClass) do:[:mthd|
| class selector |
class := selectedClass ifNil:[mthd mclass].
suite addTest: (mthd mclass asTestCase selector: mthd selector)
@@ -1010,10 +1033,11 @@
suiteForRunAll
|suite|
- suite := TestSuite named:(self suiteNameFromClasses: allTestCases).
+
allTestCases isNil ifTrue:[
self updateTestCases.
].
+ suite := TestSuite named:(self suiteNameFromClasses: self allTestCases).
allTestCases do:[:testCase |
suite addTests:(self buildSuiteFromClass:testCase) tests
@@ -1027,8 +1051,8 @@
suiteForRunFailed
|suite|
- suite := TestSuite named:(self suiteNameFromClasses: allTestCases).
- allTestCases do:[:testCase |
+ suite := TestSuite named:(self suiteNameFromClasses: self allTestCases).
+ self allTestCases do:[:testCase |
(self buildSuiteFromClass:testCase) tests do:[:eachTest |
| sel cls |
@@ -1160,11 +1184,11 @@
!TestRunnerEmbedded class methodsFor:'documentation'!
version
- ^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.30 2012-10-23 19:01:57 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.31 2012-10-31 13:33:51 cg Exp $'
!
version_CVS
- ^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.30 2012-10-23 19:01:57 cg Exp $'
+ ^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.31 2012-10-31 13:33:51 cg Exp $'
!
version_SVN