hg/stx-goodies-sunit: comparison TestRunner.st

equal deleted inserted replaced

-:914934672e32
+:8e6f482297fa
 !TestRunner class methodsFor:'documentation'!
 documentation
 "
 This GUI is based on SUnit2.7 and
 was ported to ST/X by Samuel S. Schuster (as 2.7)  (thanks, indeed)
 It was slightly enhanced by adding a rerun-defects, browse and
 a category selector (to minor revision 2.7d, in the meantime)
 "
 ! !
 !TestRunner class methodsFor:'defaults'!
 colorForFailedTests
 TestRunner open
 "
 <resource: #canvas>
 ^
 #(FullSpec
-name: windowSpec
+	name: windowSpec
-window:
+	window:
 (WindowSpec
-label: 'SUnit Camp Smalltalk 3.1/STX TestRunner'
+	  label: 'SUnit Camp Smalltalk 3.1/STX TestRunner'
-name: 'SUnit Camp Smalltalk 3.1/STX TestRunner'
+	  name: 'SUnit Camp Smalltalk 3.1/STX TestRunner'
-min: (Point 362 122)
+	  min: (Point 362 122)
-bounds: (Rectangle 0 0 493 175)
+	  bounds: (Rectangle 0 0 493 175)
-icon: defaultIcon
+	  icon: defaultIcon
-)
+	)
-component:
+	component:
 (SpecCollection
-collection: (
+	  collection: (
-(ActionButtonSpec
+	   (ActionButtonSpec
-label: 'Refresh'
+	      label: 'Refresh'
-name: 'RefreshButton'
+	      name: 'RefreshButton'
-layout: (LayoutFrame 0 0 0 0 75 0 48 0)
+	      layout: (LayoutFrame 0 0 0 0 75 0 48 0)
-activeHelpKey: refreshSuitesButton
+	      activeHelpKey: refreshSuitesButton
-tabable: true
+	      tabable: true
-model: refreshSuites
+	      model: refreshSuites
-)
+	    )
-(MenuButtonSpec
+	   (MenuButtonSpec
-name: 'category'
+	      name: 'category'
-layout: (LayoutFrame 76 0 0 0 -216 1 24 0)
+	      layout: (LayoutFrame 76 0 0 0 -216 1 24 0)
-activeHelpKey: suitesCategoryList
+	      activeHelpKey: suitesCategoryList
-tabable: true
+	      tabable: true
-model: category
+	      model: category
-menu: categoryList
+	      menu: categoryList
-)
+	    )
-(MenuButtonSpec
+	   (MenuButtonSpec
-name: tests
+	      name: tests
-layout: (LayoutFrame 76 0 24 0 -216 1 48 0)
+	      layout: (LayoutFrame 76 0 24 0 -216 1 48 0)
-activeHelpKey: suiteSelection
+	      activeHelpKey: suiteSelection
-tabable: true
+	      tabable: true
-model: script
+	      model: script
-menu: scriptModel
+	      menu: scriptModel
-useIndex: true
+	      useIndex: true
-)
+	    )
-(ActionButtonSpec
+	   (ActionButtonSpec
-label: 'Run'
+	      label: 'Run'
-name: 'RunButton'
+	      name: 'RunButton'
-layout: (LayoutFrame -215 1 0 0 -160 1 48 0)
+	      layout: (LayoutFrame -215 1 0 0 -160 1 48 0)
-activeHelpKey: runButton
+	      activeHelpKey: runButton
-tabable: true
+	      tabable: true
-model: runTests
+	      model: runTests
-enableChannel: enableRunButton
+	      enableChannel: enableRunButton
-)
+	    )
-(ActionButtonSpec
+	   (ActionButtonSpec
-label: 'ReRun Defects'
+	      label: 'ReRun Defects'
-name: 'ReRunButton'
+	      name: 'ReRunButton'
-layout: (LayoutFrame -159 1 0 0 -57 1 48 0)
+	      layout: (LayoutFrame -159 1 0 0 -57 1 48 0)
-activeHelpKey: rerunDefectsButton
+	      activeHelpKey: rerunDefectsButton
-tabable: true
+	      tabable: true
-model: runDefects
+	      model: runDefects
-enableChannel: enableDefects
+	      enableChannel: enableDefects
-)
+	    )
-(ActionButtonSpec
+	   (ActionButtonSpec
-label: 'Run All'
+	      label: 'Run All'
-name: 'RunAllButton'
+	      name: 'RunAllButton'
-layout: (LayoutFrame -56 1 0 0 0 1 48 0)
+	      layout: (LayoutFrame -56 1 0 0 0 1 48 0)
-activeHelpKey: runAllButton
+	      activeHelpKey: runAllButton
-tabable: true
+	      tabable: true
-model: runAllTests
+	      model: runAllTests
-)
+	    )
-(ProgressIndicatorSpec
+	   (ProgressIndicatorSpec
-name: 'ProgressIndicator1'
+	      name: 'ProgressIndicator1'
-layout: (LayoutFrame 0 0.0 49 0 0 1.0 60 0)
+	      layout: (LayoutFrame 0 0.0 49 0 0 1.0 60 0)
-visibilityChannel: percentageIndicatorVisible
+	      visibilityChannel: percentageIndicatorVisible
-model: percentageDone
+	      model: percentageDone
-foregroundColor: (Color 32.999160753796 32.999160753796 0.0)
+	      foregroundColor: (Color 32.999160753796 32.999160753796 0.0)
-backgroundColor: (Color 66.999313344015 66.999313344015 0.0)
+	      backgroundColor: (Color 66.999313344015 66.999313344015 0.0)
-showPercentage: false
+	      showPercentage: false
-)
+	    )
-(LabelSpec
+	   (LabelSpec
-label: '...'
+	      label: '...'
-name: 'details'
+	      name: 'details'
-layout: (LayoutFrame 0 0 21 0.5 0 1 -25 1)
+	      layout: (LayoutFrame 0 0 21 0.5 0 1 -25 1)
-labelChannel: details
+	      labelChannel: details
-)
+	    )
-(LabelSpec
+	   (LabelSpec
-label: 'N/A'
+	      label: 'N/A'
-name: 'mode'
+	      name: 'mode'
-layout: (LayoutFrame 0 0 49 0 0 1 35 0.5)
+	      layout: (LayoutFrame 0 0 49 0 0 1 35 0.5)
-style: (FontDescription Arial bold roman 14)
+	      style: (FontDescription Arial bold roman 14)
-labelChannel: mode
+	      labelChannel: mode
-)
+	    )
-(MenuButtonSpec
+	   (MenuButtonSpec
-name: defects
+	      name: defects
-layout: (LayoutFrame 0 0 -24 1 -152 1 0 1)
+	      layout: (LayoutFrame 0 0 -24 1 -152 1 0 1)
-isOpaque: true
+	      isOpaque: true
-flags: 40
+	      flags: 40
-activeHelpKey: defectsList
+	      activeHelpKey: defectsList
-tabable: true
+	      tabable: true
-model: selectionHolder
+	      model: selectionHolder
-initiallyDisabled: true
+	      initiallyDisabled: true
-enableChannel: enableDefects
+	      enableChannel: enableDefects
-menu: defectMenu
+	      menu: defectMenu
-ignoreReselect: false
+	      ignoreReselect: false
-)
+	    )
-(ActionButtonSpec
+	   (ActionButtonSpec
-label: 'Browse'
+	      label: 'Browse'
-name: 'BrowseButton'
+	      name: 'BrowseButton'
-layout: (LayoutFrame -151 1 -24 1 -76 1 0 1)
+	      layout: (LayoutFrame -151 1 -24 1 -76 1 0 1)
-activeHelpKey: browseButton
+	      activeHelpKey: browseButton
-tabable: true
+	      tabable: true
-model: browseSelectedTestCase
+	      model: browseSelectedTestCase
-initiallyDisabled: true
+	      initiallyDisabled: true
-enableChannel: enableRunButton
+	      enableChannel: enableRunButton
-)
+	    )
-(ActionButtonSpec
+	   (ActionButtonSpec
-label: 'Debug'
+	      label: 'Debug'
-name: 'DebugButton'
+	      name: 'DebugButton'
-layout: (LayoutFrame -75 1 -24 1 0 1 0 1)
+	      layout: (LayoutFrame -75 1 -24 1 0 1 0 1)
-activeHelpKey: debugButton
+	      activeHelpKey: debugButton
-tabable: true
+	      tabable: true
-model: debugSelectedFailure
+	      model: debugSelectedFailure
-initiallyDisabled: true
+	      initiallyDisabled: true
-enableChannel: enableDebugButton
+	      enableChannel: enableDebugButton
-)
+	    )
-)
+	   )
-)
+	)
 )
 ! !
 !TestRunner class methodsFor:'opening'!
 "/ the test should be executed by the TestRunner process (not the caller)
 "/ in oder for CTRL-C and busyCursor to work correctly.
 "/ Therefore, push event instead of executing the test here.
 "/runner runTests
 runner enqueueMessage:#runTests for:runner arguments:#().
 "
 self openOnTestCase:CompilerTest
 self openOnTestCase:ConstraintTests
 "Return a description of exported aspects;
 these can be connected to aspects of an embedding application
 (if this app is embedded in a subCanvas)."
 ^ #(
-#script
+	#script
 ).
 ! !
 !TestRunner methodsFor:'accessing'!
 category
 |holder|
 (holder := builder bindingAt:#category) isNil ifTrue:[
-holder := '* all *' asValue.
+	holder := '* all *' asValue.
-builder aspectAt:#category put:holder.
+	builder aspectAt:#category put:holder.
-holder onChangeSend:#categorySelectionChanged to:self.
+	holder onChangeSend:#categorySelectionChanged to:self.
 ].
 ^ holder.
 !
 categoryList
 ^categoryModel isNil
-ifTrue: [categoryModel := ValueHolder new. self updateCategoryList. categoryModel]
+	ifTrue: [categoryModel := ValueHolder new. self updateCategoryList. categoryModel]
-ifFalse: [categoryModel]
+	ifFalse: [categoryModel]
 !
 defectMenu
 "automatically generated by UIPainter ..."
 "*** the code below creates a default model when invoked."
 "*** (which may not be the one you wanted)"
 "*** Please change as required and accept it in the browser."
 ^defectMenu isNil
 	ifTrue: [defectMenu := OrderedCollection new asValue]
 	ifFalse: [defectMenu]
 "Modified: / 4.4.2000 / 20:00:31 / Sames"
 !
 "*** the code below creates a default model when invoked."
 "*** (which may not be the one you wanted)"
 "*** Please change as required and accept it in the browser."
 script isNil ifTrue:[
-script := ValueHolder new.
+	script := ValueHolder new.
-script onChangeSend:#suiteSelectionChanged to:self.
+	script onChangeSend:#suiteSelectionChanged to:self.
 ].
 ^ script.
 "Created: / 21.6.2000 / 12:04:36 / Sames"
 !
 "Created: / 21.6.2000 / 12:04:36 / Sames"
 !
 scriptModel
 "This method was generated by UIDefiner.  Any edits made here
-may be lost whenever methods are automatically defined.  The
+	may be lost whenever methods are automatically defined.  The
-initialization provided below may have been preempted by an
+	initialization provided below may have been preempted by an
-initialize method."
+	initialize method."
 ^scriptModel isNil
-ifTrue: [scriptModel := ValueHolder new. self updateSuitesList. scriptModel]
+	ifTrue: [scriptModel := ValueHolder new. self updateSuitesList. scriptModel]
-ifFalse: [scriptModel]
+	ifFalse: [scriptModel]
 "Modified: / 2.4.2000 / 14:37:51 / Sames"
 !
 selection
 selectionHolder
 |holder|
 (holder := builder bindingAt:#selectionHolder) isNil ifTrue:[
-holder := AspectAdaptor new subject:self; forAspect:#selection.
+	holder := AspectAdaptor new subject:self; forAspect:#selection.
-builder aspectAt:#selectionHolder put:holder.
+	builder aspectAt:#selectionHolder put:holder.
 ].
 ^ holder.
 "Created: / 4.4.2000 / 18:46:08 / Sames"
 "Modified: / 4.4.2000 / 18:47:31 / Sames"
 browseSelectedTestCase
 |testCaseName testCase browser defect singleCase|
 testCaseName := self selectedScript.
 testCaseName isNil ifTrue:[
-testCaseName := self tests contents.
+	testCaseName := self tests contents.
-testCaseName notNil ifTrue:[
+	testCaseName notNil ifTrue:[
-testCaseName := testCaseName string
+	    testCaseName := testCaseName string
-]
+	]
 ].
 testCaseName notNil ifTrue:[
-testCase := Smalltalk at:testCaseName asSymbol.
+	testCase := Smalltalk at:testCaseName asSymbol.
-testCase notNil ifTrue:[
+	testCase notNil ifTrue:[
-browser := UserPreferences current systemBrowserClass openInClass:testCase.
+	    browser := UserPreferences current systemBrowserClass openInClass:testCase.
-MessageNotUnderstood
+	    MessageNotUnderstood
-handle:[:ex | ]
+		handle:[:ex | ]
-do:[
+		do:[
-(defect := self selection) notNil ifTrue:[
+		    (defect := self selection) notNil ifTrue:[
-singleCase := allDefects at:defect ifAbsent: [nil].
+			singleCase := allDefects at:defect ifAbsent: [nil].
-].
+		    ].
-singleCase notNil ifTrue:[
+		    singleCase notNil ifTrue:[
-browser switchToSelector:singleCase selector
+			browser switchToSelector:singleCase selector
-] ifFalse:[
+		    ] ifFalse:[
-browser selectProtocolsMatching:'test*'
+			browser selectProtocolsMatching:'test*'
-]
+		    ]
-]
+		]
-]
+	]
 ]
 !
 categorySelectionChanged
 |selectedScriptIndex selectedScript oldSuitesList newSuitesList
 newScriptSelectionIndex|
 selectedScriptIndex := self script value.
 oldSuitesList := self scriptModel value.
 (selectedScriptIndex notNil and:[selectedScriptIndex ~~0]) ifTrue:[
-selectedScript := (oldSuitesList at:selectedScriptIndex) string
+	selectedScript := (oldSuitesList at:selectedScriptIndex) string
 ].
 self updateSuitesList.
 newSuitesList := self scriptModel value.
 newScriptSelectionIndex := newSuitesList indexOf:selectedScript.
 self script value:(newScriptSelectionIndex == 0
-ifTrue:[nil]
+			    ifTrue:[nil]
-ifFalse:[newScriptSelectionIndex]).
+			    ifFalse:[newScriptSelectionIndex]).
 !
 debugSelectedFailure
 	self debugTest: self selection
 "Created: / 21.6.2000 / 10:58:58 / Sames"
 "Modified: / 21.6.2000 / 12:21:05 / Sames"
 !
 debugTest: aTestCaseName
 | testCase |
 defect := aTestCaseName.
 testCase := allDefects at: aTestCaseName ifAbsent: [nil].
 testCase isNil ifTrue: [^self enableDebugButton value: false].
 self displayMode: 'Debugging'.
 "/ defect := nil.
 self withWaitCursorDo:[
-((result isFailure: testCase) "or:[(result isError: testCase)]")
+	((result isFailure: testCase) "or:[(result isError: testCase)]")
-ifTrue: [testCase debugAsFailure]
+	    ifTrue: [testCase debugAsFailure]
-ifFalse: [testCase debug].
+	    ifFalse: [testCase debug].
 ].
 "Modified: / 21.6.2000 / 12:12:09 / Sames"
 !
 "Created: / 21.6.2000 / 10:47:34 / Sames"
 !
 refreshSuites
-self updateCategoryList.
+	self updateCategoryList.
-self updateSuitesList.
+	self updateSuitesList.
-self script value:nil.
+	self script value:nil.
-self tests selection: 0.
+	self tests selection: 0.
-self defects selection: 0.
+	self defects selection: 0.
-result := TestResult new.
+	result := TestResult new.
-lastTestCase := nil.
+	lastTestCase := nil.
-self displayRefresh
+	self displayRefresh
 "Created: / 21.6.2000 / 10:58:34 / Sames"
 "Modified: / 21.6.2000 / 12:19:54 / Sames"
 !
 	^ self runDefectTests
 ].
 self runTests
 !
-runSuite: aTestSuite
+runSuite:aTestSuite
 |numTests|
+"/ count the number of individual tests
-"/ count the number of individual tests
+numTests := 0.
-numTests := 0.
+aTestSuite tests do:
-aTestSuite tests do:[:eachTestOrSubSuite |
+	    [:eachTestOrSubSuite |
-(eachTestOrSubSuite isKindOf:TestSuite) ifTrue:[
+	    (eachTestOrSubSuite isKindOf:TestSuite)
-numTests := numTests + eachTestOrSubSuite tests size.
+		ifTrue:[numTests := numTests + eachTestOrSubSuite tests size.]
-] ifFalse:[
+		ifFalse:[numTests := numTests + 1.]].
-numTests := numTests + 1.
+numberOfTestsToRun := numTests.
-]
+self percentageDone value:0.
-].
+Cursor wait showWhile:
-numberOfTestsToRun := numTests.
+	    [|errorCountBefore failureCountBefore|
-self percentageDone value:0.
+	    self displayRunning.
-Cursor
+	    "/ self displayDetails: '...'.
-wait
-showWhile:[
+	    aTestSuite addDependentToHierachy:self.
-|errorCountBefore failureCountBefore|
+	    result := TestResult new.
+	    lastTestCase := aTestSuite.
-self displayRunning.
+	    self showPercentageIndicator.
-"/ self displayDetails: '...'.
+	    errorCountBefore := result errorCount.
-aTestSuite addDependentToHierachy: self.
+	    failureCountBefore := result failureCount.
-result := TestResult new.
-lastTestCase := aTestSuite.
+	    [|caseName|
-self showPercentageIndicator.
+	    aTestSuite
+		run:result
-errorCountBefore :=  result errorCount.
+		beforeEachDo:
-failureCountBefore := result failureCount.
+		    [:eachCase :eachResult |
+		    caseName := eachCase getTestName.
-[
+		    caseName size == 0 ifTrue:[self halt].
-|caseName|
+		    self displayDetails:(caseName , '...').
+		    self testPassed:caseName]
-aTestSuite
+		afterEachDo:
-run:result
+		    [:eachCase :eachResult |
-beforeEachDo:[:eachCase :eachResult |
+		    |passed errorCountAfter failureCountAfter|
-caseName := eachCase testName.
+		    errorCountAfter := result errorCount.
-caseName size == 0 ifTrue:[self halt].
+		    failureCountAfter := result failureCount.
+		    passed := (errorCountAfter == errorCountBefore)
-self displayDetails:(caseName , '...').
+				& (failureCountAfter == failureCountBefore).
-self testPassed:caseName
+		    passed == true
-]
+			ifTrue:
-afterEachDo:[:eachCase :eachResult |
+			    ["/                                    testsWhichPassed add:caseName.
-|passed errorCountAfter failureCountAfter|
+			    "/                                    testsWhichFailed remove:caseName ifAbsent:nil.
+			    ]
-errorCountAfter := result errorCount.
+			ifFalse:[self testFailed:caseName withResult:result].
-failureCountAfter := result failureCount.
+		    errorCountBefore := errorCountAfter.
-passed := (errorCountAfter == errorCountBefore)
+		    failureCountBefore := failureCountAfter]] ensure:
-& (failureCountAfter == failureCountBefore).
+			[aTestSuite removeDependentFromHierachy:self.
+			self hidePercentageIndicator.
-passed == true ifTrue:[
+			self displayNormalColorInProgress.].
-"/                                    testsWhichPassed add:caseName.
+	    self updateWindow]
-"/                                    testsWhichFailed remove:caseName ifAbsent:nil.
-] ifFalse:[
-self testFailed:caseName withResult:result
-].
-errorCountBefore :=  errorCountAfter.
-failureCountBefore := failureCountAfter
-]
-] ensure: [
-aTestSuite removeDependentFromHierachy: self.
-self hidePercentageIndicator.
-self displayNormalColorInProgress.
-].
-self updateWindow
-]
 !
 runTests
 	| testSuite |
 	(testSuite := self freshTestSuite) notNil ifTrue:
 !
 selection: aValue
 aValue = '' ifTrue:[
-defect := aValue.
+	defect := aValue.
 ] ifFalse:[
-self debugTest: aValue
+	self debugTest: aValue
 ].
 "Created: / 4.4.2000 / 18:54:09 / Sames"
 "Modified: / 4.4.2000 / 19:01:33 / Sames"
 !
 "/ self enableRunButton value:ok.
 self enableRunButton value:self script value notNil.
 self enableDefects value:(ok and:[allDefects size > 0]).
 self script value notNil ifTrue:[
-self selectedScript notNil ifTrue:[
+	self selectedScript notNil ifTrue:[
-className := self selectedScript string.
+	    className := self selectedScript string.
-].
+	].
-(ok and:[className notNil]) ifTrue:[
+	(ok and:[className notNil]) ifTrue:[
-cls := Smalltalk at:className.
+	    cls := Smalltalk at:className.
-(cls class includesSelector:#description) ifTrue:[
+	    (cls class includesSelector:#description) ifTrue:[
-description := cls description.
+		description := cls description.
-]
+	    ]
-].
+	].
 ].
 self displayDetails:nil.
 self displayMode: (description ? '').
 self displayGray.
 "Created: / 21.6.2000 / 11:31:25 / Sames"
 "Modified: / 21.6.2000 / 11:32:54 / Sames"
 !
 suitesInCategory
-|suites cat allCategories|
+	|suites cat allCategories|
-cat := self category value.
+	cat := self category value.
-allCategories := (cat = '* all *').
+	allCategories := (cat = '* all *').
-suites := TestCase allSubclasses
+	suites := TestCase allSubclasses
-select:[:each |
+			select:[:each |
-true "/ "cg:TestCaseHelper is gone -->" ((each isSubclassOf:TestCaseHelper) not)
+				true "/ "cg:TestCaseHelper is gone -->" ((each isSubclassOf:TestCaseHelper) not)
-and:[each isAbstract not
+				and:[each isAbstract not
-and:[allCategories or:[cat = each category]]]]
+				and:[allCategories or:[cat = each category]]]]
-thenCollect: [:each | each name].
+			thenCollect: [:each | each name].
-suites sort.
+	suites sort.
-^ suites
+	^ suites
 !
 updateCategoryList
-|categories|
+	|categories|
-categories := (TestCase allSubclasses collect: [:each | each category]) asSet asOrderedCollection.
+	categories := (TestCase allSubclasses collect: [:each | each category]) asSet asOrderedCollection.
-categories sort.
+	categories sort.
-categories addFirst:'* all *'.
+	categories addFirst:'* all *'.
-self categoryList value:categories.
+	self categoryList value:categories.
 !
 updateSuitesList
-|suites|
+	|suites|
-suites := self suitesInCategory.
+	suites := self suitesInCategory.
-suites := suites
+	suites := suites
-collect:[:eachSuiteName |
+		    collect:[:eachSuiteName |
-(testsWhichFailed includes:eachSuiteName) ifTrue:[
+				(testsWhichFailed includes:eachSuiteName) ifTrue:[
-eachSuiteName colorizeAllWith:(self class colorForFailedTests).
+				    eachSuiteName colorizeAllWith:(self class colorForFailedTests).
-] ifFalse:[
+				] ifFalse:[
-(testsWhichPassed includes:eachSuiteName) ifTrue:[
+				    (testsWhichPassed includes:eachSuiteName) ifTrue:[
-eachSuiteName colorizeAllWith:(self class colorForPassedTests).
+					eachSuiteName colorizeAllWith:(self class colorForPassedTests).
-] ifFalse:[
+				    ] ifFalse:[
-eachSuiteName
+					eachSuiteName
-]
+				    ]
-].
+				].
-].
+			    ].
-self scriptModel value: suites.
+	self scriptModel value: suites.
 ! !
 !TestRunner methodsFor:'private'!
 addToFailedTests:caseName
 addToPassedTests:caseName
 testsWhichPassed add:caseName.
 !
 allTestSuite
-"generate and return a suite for all tests, except SUnitTests"
+	"generate and return a suite for all tests, except SUnitTests"
-| tokens stream suite|
+	| tokens stream suite|
-tokens := (self suitesInCategory
+	tokens := (self suitesInCategory
-collect: [:eachName | eachName ", '*' " ])
+			  collect: [:eachName | eachName ", '*' " ])
-copyWithout: 'SUnitTest* '.
+		      copyWithout: 'SUnitTest* '.
-stream := WriteStream on: String new.
+	stream := WriteStream on: String new.
-tokens do: [:each | stream nextPutAll:each; space].
+	tokens do: [:each | stream nextPutAll:each; space].
-suite := TestSuitesScripter run: stream contents.
+	suite := TestSuitesScripter run: stream contents.
-suite name:'all'.
+	suite name:'all'.
-^ suite
+	^ suite
 !
 defectTestSuite
-|suite|
+	|suite|
-suite := TestSuite new.
+	suite := TestSuite new.
-suite name:'defects'.
+	suite name:'defects'.
-allDefects keysAndValuesDo:[:nm :test |
+	allDefects keysAndValuesDo:[:nm :test |
-suite addTest:test.
+	    suite addTest:test.
-].
+	].
-^suite
+	^suite
 !
 formatTime: aTime
 	aTime hours > 0 ifTrue: [^aTime hours printString , 'h'].
 	aTime minutes > 0 ifTrue: [^aTime minutes printString , 'min'].
 	^aTime seconds printString , ' sec'
 !
 freshTestSuite
-|tests suite|
+	|tests suite|
-tests := self tests contents.
+	tests := self tests contents.
-tests isNil ifTrue:[ ^ nil].
+	tests isNil ifTrue:[ ^ nil].
-tests := tests string.
+	tests := tests string.
-suite := TestSuitesScripter run: tests.
+	suite := TestSuitesScripter run: tests.
-^ suite
+	^ suite
 "Modified: / 4.4.2000 / 20:13:41 / Sames"
 !
 initialize
 testsWhichPassed := Set new.
 testsWhichFailed := Set new.
 TestCase allSubclassesDo:[:cls |
-|lastResult className|
+	|lastResult className|
-cls isAbstract ifFalse:[
+	cls isAbstract ifFalse:[
-lastResult := cls lastTestRunResultOrNil.
+	    lastResult := cls lastTestRunResultOrNil.
-lastResult notNil ifTrue:[
+	    lastResult notNil ifTrue:[
-className := cls name.
+		className := cls name.
-lastResult == true ifTrue:[
+		lastResult == true ifTrue:[
-testsWhichPassed add:className
+		    testsWhichPassed add:className
-] ifFalse:[
+		] ifFalse:[
-testsWhichFailed add:className
+		    testsWhichFailed add:className
-]
+		]
-]
+	    ]
-]
+	]
 ].
 !
 postOpenWith: aBuilder
 "automatically generated by UIPainter ..."
 super postOpenWith: aBuilder.
 self tests defaultLabel: ''.
 "/ self tests selection: 'ExampleSetTest'. self script value:1.
 self updateCategoryList.
 scriptClass := Smalltalk at:aScriptName asSymbol.
 scriptClass notNil ifTrue:[
-self category value:scriptClass category.
+	self category value:scriptClass category.
 ]
 !
 selectedScript
 |scriptIndex|
 scriptIndex := self script value.
 scriptIndex isNil ifTrue:[
-^ ''
+	^ ''
 ].
 ^ self scriptModel value at:scriptIndex ifAbsent:nil.
 !
 testFailed:caseName withResult:result
 self removeFromPassedTests:caseName.
 self addToFailedTests:caseName.
 (cls := Smalltalk classNamed:caseName) notNil ifTrue:[
-cls rememberFailedTestRunWithResult:result.
+	cls rememberFailedTestRunWithResult:result.
 ].
 !
 testPassed:caseName
 |cls|
 "/    Transcript show:'passed: '; showCR:caseName.
 "/    Transcript show:'passed: '; showCR:caseName className.
 (cls := Smalltalk classNamed:caseName) notNil ifTrue:[
-cls rememberPassedTestRun
+	cls rememberPassedTestRun
 ].
 !
 timeSinceLastPassAsString
 	lastPass isNil ifTrue: [^''].
 "Created: / 21.6.2000 / 12:28:06 / Sames"
 "Modified: / 21.6.2000 / 12:35:09 / Sames"
 !
 displayDefects: aCollection
 | failedTests|
 aCollection isEmpty ifTrue: [
-self selectionHolder value:''.
+	self selectionHolder value:''.
-self enableDefects value:false.
+	self enableDefects value:false.
-self enableDebugButton value:false.
+	self enableDebugButton value:false.
-^ self
+	^ self
 ].
 allDefects := Dictionary new.
 aCollection do: [:each | allDefects at: each printString put: each].
 failedTests := allDefects keys asOrderedCollection sort.
 self defectMenu value: failedTests.
 self enableDefects value:true.
 "Modified: / 4.4.2000 / 20:11:06 / Sames"
 !
 displayDetails: aString
 self details value: aString.
 self repairDamage.
 "Modified: / 21.6.2000 / 11:10:14 / Sames"
 !
 displayGreen
 	self displayColor: ColorValue green
 !
 displayMode: aString
-self mode value: aString.
+	self mode value: aString.
-self repairDamage.
+	self repairDamage.
 "Modified: / 21.6.2000 / 11:14:19 / Sames"
 !
 displayNormalColorInProgress
 backgroundColor: (Color red:67 green:67 blue:0)
 !
 displayPass
 self displayGreen.
 (lastTestCase notNil
 and:[lastTestCase name notNil]) ifTrue:[
-self displayMode: 'Pass ' , lastTestCase name.
+	self displayMode: 'Pass ' , lastTestCase name.
 ] ifFalse:[
-self displayMode: 'Pass'.
+	self displayMode: 'Pass'.
 ].
 self displayDetails: result runCount printString , ' run' , self timeSinceLastPassAsString.
 lastPass := Time now
 "Modified: / 21.6.2000 / 12:14:52 / Sames"
 "Created: / 21.6.2000 / 12:14:11 / Sames"
 "Modified: / 21.6.2000 / 12:28:24 / Sames"
 !
 displayRunning
-self displayRunning:(self selectedScript ? 'all') string.
+	self displayRunning:(self selectedScript ? 'all') string.
 !
 displayRunning:scriptName
-self displayYellow.
+	self displayYellow.
-self displayMode:('running ' , scriptName allBold).
+	self displayMode:('running ' , scriptName allBold).
 "/        self displayDetails: '...'.
-self repairDamage.
+	self repairDamage.
 !
 displayYellow
 	self displayColor: ColorValue yellow
 !
 self percentageIndicatorVisible value:true.
 !
 update:something with:aParameter from:changedObject
 changedObject == Smalltalk ifTrue:[
-(changedObject isBehavior and:[changedObject isSubclassOf:TestCase]) ifTrue:[
+	(changedObject isBehavior and:[changedObject isSubclassOf:TestCase]) ifTrue:[
-self updateSuitesList
+	    self updateSuitesList
-].
+	].
-^ self
+	^ self
 ].
 (changedObject isKindOf: TestSuite) ifTrue: [
-self displayRunning:changedObject name.
+	self displayRunning:changedObject name.
-^ self
+	^ self
 ].
 (changedObject isKindOf: TestCase) ifTrue: [
-(result errorCount + result failureCount) > 0 ifTrue:[
+	(result errorCount + result failureCount) > 0 ifTrue:[
-self displayErrorColorInProgress.
+	    self displayErrorColorInProgress.
-].
+	].
-self percentageDone value:(result runCount / numberOfTestsToRun * 100) rounded.
+	self percentageDone value:(result runCount / numberOfTestsToRun * 100) rounded.
-self displayDetails: changedObject printString.
+	self displayDetails: changedObject printString.
-^ self
+	^ self
 ].
 super update:something with:aParameter from:changedObject
 !
 updateDefects
-|script|
+	|script|
-script := self selectedScript.
+	script := self selectedScript.
-script notNil ifTrue:[script := script string].
+	script notNil ifTrue:[script := script string].
-self displayDefects: result defects.
+	self displayDefects: result defects.
-script notNil ifTrue:[
+	script notNil ifTrue:[
-result hasPassed ifTrue:[
+	    result hasPassed ifTrue:[
-self testPassed:script
+		self testPassed:script
-] ifFalse:[
+	    ] ifFalse:[
-self testFailed:script withResult:result
+		self testFailed:script withResult:result
-].
+	    ].
-].
+	].
 !
 updateWindow
-result hasPassed
+	result hasPassed
-ifTrue: [self displayPass]
+		ifTrue: [self displayPass]
-ifFalse: [self displayFail].
+		ifFalse: [self displayFail].
-self updateDefects.
+	self updateDefects.
-self updateSuitesList. "/ for colors
+	self updateSuitesList. "/ for colors
 ! !
 !TestRunner class methodsFor:'documentation'!
 version
-^ '$Header: /cvs/stx/stx/goodies/sunit/TestRunner.st,v 1.59 2009-10-04 13:24:40 cg Exp $'
+^ '$Header: /cvs/stx/stx/goodies/sunit/TestRunner.st,v 1.60 2011-06-29 19:15:49 cg Exp $'
 !
 version_CVS
-^ '$Header: /cvs/stx/stx/goodies/sunit/TestRunner.st,v 1.59 2009-10-04 13:24:40 cg Exp $'
+^ '$Header: /cvs/stx/stx/goodies/sunit/TestRunner.st,v 1.60 2011-06-29 19:15:49 cg Exp $'
+!
+version_SVN
+^ '�Id: TestRunner.st 182 2009-12-05 18:12:17Z vranyj1 �'
 ! !

changeset 222	8e6f482297fa
parent 206	19f999435a5c
child 442	3b3e35ac7096