author | Jan Vrany <jan.vrany@fit.cvut.cz> |
Sun, 05 Feb 2012 01:49:41 +0000 | |
branch | jv |
changeset 12144 | 18c25ec50d96 |
parent 12128 | a7ff7d66ee85 |
child 12254 | b1237f76f501 |
permissions | -rw-r--r-- |
" 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:#TestRunnerEmbedded instanceVariableNames:'runnerPanel selectedTestCases selectedClassesHolder selectedProtocolsHolder selectedMethodsHolder methodGeneratorHolder resultHolder resultInfoHolder resultBackgroundColorHolder runningHolder progressHolder infoHolder' classVariableNames:'' poolDictionaries:'' category:'SUnit-UI' ! Object subclass:#SuiteAndResult instanceVariableNames:'suite result' classVariableNames:'' poolDictionaries:'' privateIn:TestRunnerEmbedded ! !TestRunnerEmbedded 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 " ! ! !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'! 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 ifNotNil: [ generator do: [:cls :cat :sel :mthd | (mthd notNil and:[ (self isTestCaseLike:(selectedClass ? cls)) and:[ (selectedClass ? 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: / 22-07-2011 / 15:53:43 / Jan Vrany <jan.vrany@fit.cvut.cz>" ! theSingleTestCase selectedTestCases isEmptyOrNil ifTrue:[^nil]. selectedTestCases size > 1 ifTrue:[^nil]. ^selectedTestCases anyOne. "Created: / 22-07-2011 / 15:44:23 / Jan Vrany <jan.vrany@fit.cvut.cz>" ! ! !TestRunnerEmbedded methodsFor:'actions'! debug | suiteAndResult suite test result | suiteAndResult := self resultHolder value. suite := suiteAndResult suiteForRun. suite tests size ~= 1 ifTrue:[^self breakPoint: #jv]. test := suiteAndResult suite tests anyOne. [ test debug. (test class testSelectorPassed:test selector) ifTrue:[ result := TestResult new. result passed add: test. suiteAndResult := SuiteAndResult suite: suite result: result. self resultHolder value:suiteAndResult. ]. ] fork "Created: / 15-03-2010 / 15:43:39 / Jan Vrany <jan.vrany@fit.cvut.cz>" "Modified: / 05-07-2011 / 19:05:31 / cg" "Modified: / 07-07-2011 / 11:33:48 / Jan Vrany <jan.vrant@fit.cvut,cz>" "Modified (format): / 02-08-2011 / 18:18:38 / cg" "Modified: / 22-08-2011 / 09:59:10 / Jan Vrany <jan.vrany@fit.cvut.cz>" ! run |suite| resultHolder value isNil ifTrue:[ suite := self suiteForRun ] ifFalse:[ suite := resultHolder value suiteForRun ]. self run:suite "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" ! run:suite |process suiteAndResult numTests| numTests := suite tests size. numTests == 0 ifTrue:[ ^ self ]. process := [ |result incr run| [ self progressHolder value:0. self runningHolder value:true. incr := 100 / numTests. run := 0. result := suite runBeforeEachDo:[:test :result | infoHolder notNil ifTrue:[ infoHolder value:('Running "%1-%2"...' bindWith:test name with:test getTestName allBold) ] ] afterEachDo:[:test :result | run := run + 1. self progressHolder value:(incr * run) truncated "rounded". infoHolder notNil ifTrue:[ infoHolder value:('Done.') ] ]. 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>" "Modified: / 06-07-2011 / 14:28:02 / cg" ! 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>" ! 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 := self resultHolder value. suiteAndResult isNil ifTrue:[ suite := self suiteForRun. ] ifFalse:[ suite := suiteAndResult suiteForRun. ]. suite run: TestResultForRunWithDebug new "/ suiteAndResult suite tests size ~= 1 ifTrue:[^self breakPoint: #jv]. "/ [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" ! ! !TestRunnerEmbedded methodsFor:'aspects'! debugVisibleAspect ^ BlockValue with:[:model | model notNil and:[ model testCount == 1 and:[ model hasFailuresOrErrors ]] ] argument:self resultHolder "Created: / 15-03-2010 / 15:40:54 / Jan Vrany <jan.vrany@fit.cvut.cz>" "Modified: / 02-08-2011 / 18:19:14 / cg" ! 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:[ self class currentlyRunningColor "/ 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>" "Modified (comment): / 05-07-2011 / 14:13:30 / cg" ! 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 ] ] argument:self resultHolder "Created: / 15-03-2010 / 20:22:44 / Jan Vrany <jan.vrany@fit.cvut.cz>" "Modified: / 02-08-2011 / 18:20:26 / cg" ! resultNameAspect ^ BlockValue with:[:model | model isNil ifTrue:[ 'Run the tests!!' ] ifFalse:[ 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>" "Modified: / 02-08-2011 / 18:20:38 / cg" ! 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 ]. sender == Smalltalk ifTrue:[ aspect == #lastTestRunResult ifTrue:[ (selectedTestCases notNil and:[selectedTestCases 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>" ! 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: / 24-01-2012 / 22:09:14 / 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'! 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>" ! releaseAsSubCanvas Smalltalk removeDependent: self. "Created: / 17-11-2011 / 21:03:18 / 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 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" ! ! !TestRunnerEmbedded methodsFor:'utilities'! resultForSuite:suite |result| result := TestResult new. 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: / 02-08-2011 / 18:20:00 / cg" "Modified: / 20-08-2011 / 14:30:36 / Jan Vrany <jan.vrany@fit.cvut.cz>" ! suiteForRun | methods protocols suite selectedClass | selectedClass := self theSingleTestCase. (methods := selectedMethodsHolder value) notEmptyOrNil ifTrue:[ suite := TestSuite named: (self suiteNameFromMethods: methods). self selectedTestMethods do:[:mthd| | class selector | class := selectedClass ifNil:[mthd mclass]. suite addTest: (class asTestCase selector: mthd selector) ]. ^suite ]. (protocols := selectedProtocolsHolder value) isEmptyOrNil ifFalse:[ suite := TestSuite named: (self suiteNameFromProtocols: protocols). (self selectedTestMethodsFromProtocols: protocols) do:[:mthd| | class selector | class := selectedClass ifNil:[mthd mclass]. 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: / 22-07-2011 / 15:48:33 / Jan Vrany <jan.vrany@fit.cvut.cz>" "Modified: / 04-08-2011 / 19:06:42 / cg" ! 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. ! 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 ^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 ^ '$Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.22 2012/01/24 22:20:06 vrany Exp $' ! version_CVS ^ '§Header: /cvs/stx/stx/libtool/Tools__TestRunnerEmbedded.st,v 1.22 2012/01/24 22:20:06 vrany Exp §' ! version_SVN ^ '$Id: Tools__TestRunnerEmbedded.st 7854 2012-01-30 17:49:41Z vranyj1 $' ! !