hg/stx-libtool: comparison Tools_

equal deleted inserted replaced

-:5d6cd56f9dcf
+:23bf4b9973a3
 "{ Package: 'stx:libtool' }"
 "{ NameSpace: Tools }"
 AbstractTestRunner subclass:#TestRunnerEmbedded
-	instanceVariableNames:'runnerPanel selectedTestCases selectedClassesHolder
+	instanceVariableNames:'runnerPanel selectedClassesHolder selectedProtocolsHolder
-		selectedProtocolsHolder selectedMethodsHolder
+		selectedMethodsHolder methodGeneratorHolder resultHolder
-		methodGeneratorHolder resultHolder resultInfoHolder
+		resultInfoHolder resultBackgroundColorHolder runningHolder
-		resultBackgroundColorHolder runningHolder progressHolder
+		progressHolder infoHolder testProcess allTestCases'
-		infoHolder'
 	classVariableNames:''
 	poolDictionaries:''
 	category:'SUnit-UI'
 !
 window:
 (WindowSpec
 label: 'Test Runner Embedded'
 name: 'Test Runner Embedded'
 min: (Point 10 10)
-bounds: (Rectangle 0 0 350 50)
+bounds: (Rectangle 0 0 595 50)
 )
 component:
 (SpecCollection
 collection: (
 (VerticalPanelViewSpec
 adjust: left
 )
 (LabelSpec
 name: 'ResultInfo'
 layout: (LayoutFrame 0 0 -10 1 0 1 0 1)
-style: (FontDescription helvetica medium roman 8)
+style: (FontDescription helvetica medium roman 8 #'iso10646-1')
 backgroundChannel: resultBackgroundColorAspect
 foregroundColor: (Color 100.0 100.0 100.0)
 translateLabel: true
 labelChannel: resultInfoAspect
 adjust: left
 )
 )
 )
 )
-extent: (Point 151 30)
+extent: (Point 336 30)
 )
 (ActionButtonSpec
 label: 'Debug'
 name: 'DebugButton'
 initiallyInvisible: true
-visibilityChannel: debugVisibleAspect
 translateLabel: true
 model: debug
 extent: (Point 60 25)
 )
 (ActionButtonSpec
+label: 'Stop'
+name: 'Button2'
+visibilityChannel: runningHolder
+translateLabel: true
+model: stop
+extent: (Point 60 25)
+)
+(ActionButtonSpec
 label: 'Run'
 name: 'Run'
+visibilityChannel: notRunningHolder
 translateLabel: true
 model: run
 enableChannel: runEnabledHolder
+extent: (Point 60 25)
+)
+(ActionButtonSpec
+label: 'Run Failed'
+name: 'Button1'
+translateLabel: true
+model: runFailed
+enableChannel: runFailedEnabledHolder
 extent: (Point 60 25)
 )
 (ActionButtonSpec
 label: 'Run all'
 name: 'RunAll'
 postBuildCallback: postBuildRunnerPanel:
 )
 )
 )
-extent: (Point 340 40)
+extent: (Point 585 40)
 )
 )
 )
 )
 methods := Set new.
 generator := self methodGeneratorHolder value.
 selectedClass := self theSingleTestCase.
-generator ifNotNil:
+generator notNil ifTrue:[
-[ generator do:
+generator do: [:cls :cat :sel :mthd |
-[:cls :cat :sel :mthd |
+(mthd notNil
-(mthd notNil
+and:[ (self isTestCaseLike:(selectedClass ? cls))
-and:[ (self isTestCaseLike:(selectedClass ? cls)) and:[ (selectedClass ? cls) isTestSelector:sel ] ])
+and:[ (selectedClass ? cls) isTestSelector:sel ] ])
-ifTrue:[ methods add:mthd ] ] ]
+ifTrue:[ methods add:mthd ]
-ifNil:
+]
-[ selectedTestCases do:
+] ifFalse:[
-[:cls |
+allTestCases do: [:cls |
-cls methodsDo:
+cls methodsDo: [:mthd |
-[:mthd |
+((protocols includes:mthd category) and:[ cls isTestSelector:mthd selector ])
-((protocols includes:mthd category)
+ifTrue:[
-and:[ cls isTestSelector:mthd selector ]) ifTrue:[ methods add:mthd ] ] ] ].
+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"
 !
 theSingleTestCase
-selectedTestCases isEmptyOrNil ifTrue:[^nil].
+allTestCases isEmptyOrNil ifTrue:[^nil].
-selectedTestCases size > 1 ifTrue:[^nil].
+allTestCases size > 1 ifTrue:[^nil].
-^selectedTestCases anyOne.
+^allTestCases anyOne.
 "Created: / 22-07-2011 / 15:44:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 ! !
 !TestRunnerEmbedded methodsFor:'actions'!
 "Modified: / 22-08-2011 / 09:58:33 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 "Modified: / 09-10-2011 / 10:56:39 / cg"
 !
 run:suite
-|process suiteAndResult numTests|
+|suiteAndResult numTests|
 numTests := suite tests size.
 numTests == 0 ifTrue:[
 ^ self
 ].
-process := [
+self stop.
+testProcess := [
 |result incr run|
 [
+self runningHolder value:true.
 self progressHolder value:0.
-self runningHolder value:true.
 incr := 100 / numTests.
 run := 0.
 result := suite
 runBeforeEachDo:[:test :result |
 infoHolder notNil ifTrue:[
 ] ensure:[
 self resultHolder value:suiteAndResult.
 self runningHolder value:false.
 ]
 ] newProcess.
-process resume.
+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: / 06-07-2011 / 14:28:02 / cg"
+"Modified: / 04-06-2012 / 19:08:40 / cg"
 !
 runAll
-self run: self suiteForRunAll.
+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"
+!
+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 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"
+!
+stop
+|p|
+(p := testProcess) notNil ifTrue:[
+testProcess := nil.
+p terminate
+].
+"Created: / 04-06-2012 / 18:34:07 / cg"
 ! !
 !TestRunnerEmbedded methodsFor:'aspects'!
 debugVisibleAspect
 ].
 newValue := methodGeneratorHolder value.
 oldValue ~~ newValue ifTrue:[
 self update:#value with:newValue from:methodGeneratorHolder.
 ].
+!
+notRunningHolder
+^ BlockValue forLogicalNot:(self runningHolder)
+"Created: / 04-06-2012 / 18:38:48 / cg"
 !
 progressHolder
 "return/create the 'progressHolder' value holder (automatically generated)"
 "Modified: / 02-08-2011 / 18:20:38 / cg"
 !
 runAllEnabledHolder
-^true
+^ 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:
-[:resultHolder | | result |
+[:result :running |
-(result := resultHolder value) notNil and:[result testCount > 0 ]]
+running not
+and:[ result notNil
+and:[ result testCount > 0 ]]
+]
 argument: self resultHolder
+argument: self runningHolder
 "Created: / 07-09-2010 / 09:15:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+"Modified: / 04-06-2012 / 18:52:41 / cg"
+!
+runFailedEnabledHolder
+^BlockValue
+with:
+[:running |
+|result|
+result := (self resultForSuite:self suiteForRunAll).
+running not
+and:[ 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"
 !
 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>"
+"Modified (comment): / 04-06-2012 / 18:38:52 / cg"
 !
 selectedClassesHolder
 "return/create the 'selectedClassesHolder' value holder (automatically generated)"
 ].
 newValue := selectedProtocolsHolder value.
 oldValue ~~ newValue ifTrue:[
 self update:#value with:newValue from:selectedProtocolsHolder.
 ].
+!
+stopEnabledHolder
+^ self runningHolder
+"Created: / 04-06-2012 / 18:29:01 / cg"
 ! !
 !TestRunnerEmbedded methodsFor:'change & update'!
 update:aspect with:param from: sender
 ^self
 ].
 sender == Smalltalk ifTrue:[
 aspect == #lastTestRunResult ifTrue:[
-(selectedTestCases notNil and:[selectedTestCases includesIdentical: param first]) ifTrue:[
+(allTestCases includesIdentical: param first) ifTrue:[
 self updateTestSuiteAndResult.
 ^self
 ]
 ]
 ].
 super update:aspect with:param from: sender
 "Modified: / 20-11-2011 / 12:40:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+"Modified: / 04-06-2012 / 19:03:34 / cg"
 !
 updateTestCases
-selectedTestCases := ((self selectedClassesHolder value ? #())
+allTestCases := ((self selectedClassesHolder value ? #())
 select:[:cls | self isTestCaseLike:cls ]).
-selectedTestCases := selectedTestCases isEmpty
+allTestCases := allTestCases asArray
-ifTrue:[ nil ]
-ifFalse:[ selectedTestCases asArray ]
 "Created: / 11-03-2010 / 10:31:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
 "Modified: / 24-01-2012 / 22:09:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+"Modified: / 04-06-2012 / 19:02:52 / cg"
 !
 updateTestSuiteAndResult
 | suite suiteAndResult |
 self runningHolder value ifTrue:[^self].
-selectedTestCases ifNil:[^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
 !TestRunnerEmbedded methodsFor:'queries'!
 hasTestCaseSelected
-^selectedTestCases notEmptyOrNil
+^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"
 ! !
 "Modified: / 04-08-2011 / 19:06:42 / cg"
 !
 suiteForRunAll
 |suite|
-suite := TestSuite named:(self suiteNameFromClasses: selectedTestCases).
+suite := TestSuite named:(self suiteNameFromClasses: allTestCases).
-selectedTestCases do:[:testCase |
+allTestCases isNil ifTrue:[
+self updateTestCases.
+].
+allTestCases do:[:testCase |
 suite addTests:(self buildSuiteFromClass:testCase) tests
 ].
 ^suite
 "Modified: / 04-03-2011 / 06:57:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+"Modified: / 04-06-2012 / 19:01:48 / cg"
+!
+suiteForRunFailed
+|suite|
+suite := TestSuite named:(self suiteNameFromClasses: allTestCases).
+allTestCases do:[:testCase |
+(self buildSuiteFromClass:testCase) tests do:[:eachTest |
+| sel cls |
+sel := eachTest selector.
+cls := eachTest class.
+(cls testSelectorPassed:sel) ifFalse:[
+suite addTest:eachTest
+]
+]
+].
+^suite
+"Modified: / 04-03-2011 / 06:57:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+"Created: / 04-06-2012 / 18:32:40 / cg"
 ! !
 !TestRunnerEmbedded::SuiteAndResult class methodsFor:'instance creation'!
 suite: suite result: result
 ! !
 !TestRunnerEmbedded class methodsFor:'documentation'!
 version
-^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.22 2012-01-24 22:20:06 vrany Exp $'
+^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.23 2012-06-04 17:13:51 cg Exp $'
 !
 version_CVS
-^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.22 2012-01-24 22:20:06 vrany Exp $'
+^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.23 2012-06-04 17:13:51 cg Exp $'
 !
 version_SVN
 ^ '�Id�'
 ! !

changeset 11552	23bf4b9973a3
parent 11197	86b60ba78ad2
child 11553	d510e15157cd