SUnit

Paul McDonough wnchips at yahoo.com
Mon Aug 21 20:34:23 UTC 2000


It looks like the version of Squeak SUnit included in
the 2.9a update stream is rather out of date.  I think
it's the same version we started with to build an
SUnit port suitable for Camp Smalltalk.  Since then,
there have been (I think) at least 3 passes at
improving SUnit/Squeak:
  Camp Smalltalk 1
  ObjectWeb project at UIUC
  Camp Smalltalk 2

We could benefit by including these improvements, if
SUnit is to be part of the core release stream.  A
recent version (including UI access to the tool) is
attached.  Four change sets, to be loaded in this
order:
  SUnitPreload
  SUnit
  SUnitUI
  (optional) SUnitTests

Alternatively, someone could set up with the CS gang
to keep in sync, as they will likely continue to work
on the SUnit port from time to time.

__________________________________________________
Do You Yahoo!?
Yahoo! Mail – Free email you can access from anywhere!
http://mail.yahoo.com/
-------------- next part --------------
'From Squeak2.8alpha of 19 January 2000 [latest update: #2158] on 14 July 2000 at 9:17:53 am'!
Exception subclass: #TestFailure
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Preload'!

!Exception methodsFor: 'SUnitPreload' stamp: 'rww 7/14/2000 01:44'!
exitWith: aValue
	self return: aValue! !


!Exception class methodsFor: 'SUnitPreload' stamp: 'rww 7/14/2000 01:44'!
signalWith: aString
	self signal: aString! !


!TestFailure methodsFor: 'exceptionSignaler' stamp: 'rww 7/14/2000 01:44'!
defaultAction
	Debugger
		openContext: initialContext
		label: messageText
		contents: initialContext shortStack! !

-------------- next part --------------
'From Squeak2.8alpha of 19 January 2000 [latest update: #2158] on 14 July 2000 at 9:17:57 am'!
Object subclass: #TestCase
	instanceVariableNames: 'testSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Core'!
Object subclass: #TestResult
	instanceVariableNames: 'runCount failures errors '
	classVariableNames: 'ExFailure '
	poolDictionaries: ''
	category: 'SUnit-Core'!
Object subclass: #TestSuite
	instanceVariableNames: 'tests '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Core'!
Object subclass: #TestSuitesScripter
	instanceVariableNames: 'script stream '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Core'!

!TestCase methodsFor: 'dependencies' stamp: 'rww 7/14/2000 01:44'!
addDependentToHierachy: anObject 
	"an empty method. for Composite compability with TestSuite"! !

!TestCase methodsFor: 'dependencies' stamp: 'rww 7/14/2000 01:44'!
removeDependentFromHierachy: anObject 
	"an empty method. for Composite compability with TestSuite"! !

!TestCase methodsFor: 'private' stamp: 'rww 7/14/2000 01:44'!
executeShould: aBlock inScopeOf: anExceptionalEvent 
	[[aBlock value]
		on: anExceptionalEvent
		do: [:ex | ^true]]
			on: TestResult error
			do: [:ex | ^false].
	^false.! !

!TestCase methodsFor: 'private' stamp: 'rww 7/14/2000 01:44'!
setTestSelector: aSymbol
	testSelector := aSymbol! !

!TestCase methodsFor: 'printing' stamp: 'rww 7/14/2000 01:44'!
printOn: aStream
	aStream nextPutAll: self class printString.
	aStream nextPutAll: '>>'.
	aStream nextPutAll: testSelector! !

!TestCase methodsFor: 'asserting' stamp: 'rww 7/14/2000 01:44'!
assert: aBoolean 
	aBoolean ifFalse: [self signalFailure: 'Assertion failed - ', thisContext sender printString]! !

!TestCase methodsFor: 'asserting' stamp: 'rww 7/14/2000 01:44'!
deny: aBoolean
	self assert: aBoolean not! !

!TestCase methodsFor: 'asserting' stamp: 'rww 7/14/2000 01:44'!
should: aBlock
	self assert: aBlock value! !

!TestCase methodsFor: 'asserting' stamp: 'rww 7/14/2000 01:44'!
should: aBlock raise: anExceptionalEvent 
	^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent)! !

!TestCase methodsFor: 'asserting' stamp: 'rww 7/14/2000 01:44'!
shouldnt: aBlock
	self deny: aBlock value! !

!TestCase methodsFor: 'asserting' stamp: 'rww 7/14/2000 01:44'!
shouldnt: aBlock raise: anExceptionalEvent 
	^ self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not! !

!TestCase methodsFor: 'asserting' stamp: 'rww 7/14/2000 01:44'!
signalFailure: aString
	TestResult failure signalWith: aString! !

!TestCase methodsFor: 'running' stamp: 'rww 7/14/2000 01:44'!
debug
	(self class selector: testSelector) runCase! !

!TestCase methodsFor: 'running' stamp: 'rww 7/14/2000 01:44'!
debugAsFailure
	(self class selector: testSelector) runCaseAsFailure! !

!TestCase methodsFor: 'running' stamp: 'rww 7/14/2000 01:44'!
openDebuggerOnFailingTestMethod
	"SUnit has halted one step in front of the failing test method.     
	Step over the 'self halt' (in anything but Squeak)
	and send into 'self perform: testSelector' (in anything but Squeak)  
	to see the failure from the beginning

	For Squeak, just proceed, and you'll get an Assertion failure"

	self halt.
	self perform: testSelector! !

!TestCase methodsFor: 'running' stamp: 'rww 7/14/2000 01:44'!
run
	| result |
	result := TestResult new.
	self run: result.
	^result! !

!TestCase methodsFor: 'running' stamp: 'rww 7/14/2000 01:44'!
run: aResult
	aResult runCase: self! !

!TestCase methodsFor: 'running' stamp: 'rww 7/14/2000 01:44'!
runCase
	self setUp.
	[self perform: testSelector] ensure: [self tearDown]! !

!TestCase methodsFor: 'running' stamp: 'rww 7/14/2000 01:44'!
runCaseAsFailure
	self setUp.
	[self openDebuggerOnFailingTestMethod]
		ensure: [self tearDown]! !

!TestCase methodsFor: 'running' stamp: 'rww 7/14/2000 01:44'!
setUp! !

!TestCase methodsFor: 'running' stamp: 'rww 7/14/2000 01:44'!
tearDown
	^ self! !

!TestCase methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
testSelector
	^testSelector! !


!TestCase class methodsFor: 'instance creation' stamp: 'rww 7/14/2000 01:44'!
debug: aSymbol
	^(self selector: aSymbol) debug! !

!TestCase class methodsFor: 'instance creation' stamp: 'rww 7/14/2000 01:44'!
run: aSymbol
	^(self selector: aSymbol) run! !

!TestCase class methodsFor: 'instance creation' stamp: 'rww 7/14/2000 01:44'!
selector: aSymbol
	^self new setTestSelector: aSymbol! !

!TestCase class methodsFor: 'instance creation' stamp: 'rww 7/14/2000 01:44'!
suite
	| testSelectors result |
	testSelectors _ self selectors asSortedCollection select: [:each | 'test*' match: each].
	result _ TestSuite new.
	testSelectors do: [:each | result addTest: (self selector: each)].
	^ result! !


!TestResult methodsFor: 'printing' stamp: 'rww 7/14/2000 01:44'!
printString
	^self runCount printString , ' run, ' , self failureCount printString , ' failed, ' , self errorCount printString , ' error(s)'! !

!TestResult methodsFor: 'initializing' stamp: 'rww 7/14/2000 01:44'!
initialize
	runCount := 0! !

!TestResult methodsFor: 'running' stamp: 'rww 7/14/2000 01:44'!
runCase: aTestCase
	runCount := runCount + 1.
	[[aTestCase runCase] 
		on: self class failure
		do: 
			[:signal | 
			self failures add: aTestCase.
			signal exitWith: nil]]
			on: self class error
			do:
				[:signal |
				self errors add: aTestCase.
				signal exitWith: nil]! !

!TestResult methodsFor: 'testing' stamp: 'rww 7/14/2000 01:44'!
hasPassed
	^self runCount = self correctCount! !

!TestResult methodsFor: 'testing' stamp: 'rww 7/14/2000 01:44'!
isFailure: aTestCase
	^self failures includes: aTestCase! !

!TestResult methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
correctCount
	^runCount - self failureCount - self errorCount! !

!TestResult methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
defects
	^self errors , self failures! !

!TestResult methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
errorCount
	^self errors size! !

!TestResult methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
errors
	errors isNil ifTrue: [errors := OrderedCollection new].
	^errors! !

!TestResult methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
failureCount
	^ self failures size! !

!TestResult methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
failures
	failures isNil ifTrue: [failures := OrderedCollection new].
	^failures! !

!TestResult methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
runCount
	^runCount! !


!TestResult class methodsFor: 'exceptions' stamp: 'rww 7/14/2000 01:44'!
error
	^self exError! !

!TestResult class methodsFor: 'exceptions' stamp: 'rww 7/14/2000 01:44'!
exError
	"Change for Dialect"
	^ Error! !

!TestResult class methodsFor: 'exceptions' stamp: 'rww 7/14/2000 01:44'!
exFailure
	"Change for Dialect"
	
	^TestFailure! !

!TestResult class methodsFor: 'exceptions' stamp: 'rww 7/14/2000 01:44'!
failure
	^self exFailure! !

!TestResult class methodsFor: 'exceptions' stamp: 'rww 7/14/2000 01:44'!
signalErrorWith: aString 
	self error signalWith: aString! !

!TestResult class methodsFor: 'exceptions' stamp: 'rww 7/14/2000 01:44'!
signalFailureWith: aString 
	self failure signalWith: aString! !

!TestResult class methodsFor: 'instance creation' stamp: 'rww 7/14/2000 01:44'!
new
	^super new initialize! !


!TestSuite methodsFor: 'running' stamp: 'rww 7/14/2000 01:44'!
run
	| result |
	result := TestResult new.
	self run: result.
	^result! !

!TestSuite methodsFor: 'running' stamp: 'rww 7/14/2000 01:44'!
run: aResult 
	self tests
		do: 
			[:each | 
			self changed: each.
			each run: aResult]! !

!TestSuite methodsFor: 'dependencies' stamp: 'rww 7/14/2000 01:44'!
addDependentToHierachy: anObject
	self addDependent: anObject.
	self tests do: [ :each | each addDependentToHierachy: anObject]! !

!TestSuite methodsFor: 'dependencies' stamp: 'rww 7/14/2000 01:44'!
removeDependentFromHierachy: anObject
	self removeDependent: anObject.
	self tests do: [ :each | each removeDependentFromHierachy: anObject]! !

!TestSuite methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
addTest: aTest
	self tests add: aTest! !

!TestSuite methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
addTests: aCollection 
	aCollection do: [:eachTest | self addTest: eachTest]! !

!TestSuite methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
tests
	tests isNil ifTrue: [tests := OrderedCollection new].
	^tests! !


!TestSuitesScripter methodsFor: 'private' stamp: 'rww 7/14/2000 01:44'!
executeSingleSuiteScript: name 
	| useHierachy realName testCase |
	name last = $*
		ifTrue: 
			[realName _ name copyFrom: 1 to: name size - 1.
			useHierachy _ true]
		ifFalse: 
			[realName _ name.
			useHierachy _ false].
	realName isEmpty ifTrue: [^nil].
	testCase _ Smalltalk at: realName asSymbol ifAbsent: [^ nil].
	useHierachy
		ifTrue: [^ self hierachyOfTestSuitesFrom: testCase]
		ifFalse: [^ testCase suite]! !

!TestSuitesScripter methodsFor: 'private' stamp: 'rww 7/14/2000 01:44'!
getNextToken
	[stream atEnd not and: [stream peek first = $"]]
		whileTrue: [self skipComment].
	stream atEnd not
		ifTrue: [^stream next]
		ifFalse: [^nil]! !

!TestSuitesScripter methodsFor: 'private' stamp: 'rww 7/14/2000 01:44'!
hierachyOfTestSuitesFrom: aTestCase 
	| subSuite |
	subSuite := TestSuite new.
	subSuite addTest: aTestCase suite.
	aTestCase allSubclasses do: [:each | subSuite addTest: each suite].
	^subSuite! !

!TestSuitesScripter methodsFor: 'private' stamp: 'rww 7/14/2000 01:44'!
setScript: aString
	script := aString! !

!TestSuitesScripter methodsFor: 'private' stamp: 'rww 7/14/2000 01:44'!
skipComment
	| token inComment |
	token := stream next.
	token size > 1 & (token last = $") ifTrue: [^nil].
	inComment := true.
	[inComment & stream atEnd not]
		whileTrue: 
			[token := stream next.
			token last = $" ifTrue: [inComment := false]]! !

!TestSuitesScripter methodsFor: 'scripting' stamp: 'rww 7/14/2000 01:44'!
run: aString 
	| suite token subSuite |
	suite _ TestSuite new.
	stream _ ReadStream on: aString substrings.
	[stream atEnd]
		whileFalse: 
			[token _ self getNextToken.
			token notNil
				ifTrue: 
					[subSuite _ self executeSingleSuiteScript: token.
					subSuite notNil ifTrue: [suite addTest: subSuite]]].
	^ suite! !

!TestSuitesScripter methodsFor: 'scripting' stamp: 'rww 7/14/2000 01:44'!
value
	^self run: script! !

!TestSuitesScripter methodsFor: 'printing' stamp: 'rww 7/14/2000 01:44'!
printString
	^script isNil ifFalse: [script] ifTrue: ['N/A']! !


!TestSuitesScripter class methodsFor: 'Examples' stamp: 'rww 7/14/2000 01:44'!
exampleScripting
	(TestSuitesScripter script: ' "scratch suite 3" ExampleSetTest SUnitTest* ') value! !

!TestSuitesScripter class methodsFor: 'instance creation' stamp: 'rww 7/14/2000 01:44'!
run: aString
	^self new run: aString! !

!TestSuitesScripter class methodsFor: 'instance creation' stamp: 'rww 7/14/2000 01:44'!
script: aString
	^self new setScript: aString! !

-------------- next part --------------
'From Squeak2.8alpha of 19 January 2000 [latest update: #2158] on 14 July 2000 at 9:18:05 am'!
Model subclass: #TestRunner
	instanceVariableNames: 'result details passFail failures errors tests testSuite passFailText detailsText lastPass testsList selectedSuite selectedFailureTest selectedErrorTest '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnitUI'!

!TestRunner methodsFor: 'updating' stamp: 'rww 7/14/2000 01:44'!
displayDetails: aString
	details := aString.
	self changed: #details! !

!TestRunner methodsFor: 'updating' stamp: 'rww 7/14/2000 01:44'!
displayErrors: anOrderedCollection

	errors := anOrderedCollection.
	self changed: #errors! !

!TestRunner methodsFor: 'updating' stamp: 'rww 7/14/2000 01:44'!
displayFailures: anOrderedCollection

	failures := anOrderedCollection.
	self changed: #failures! !

!TestRunner methodsFor: 'updating' stamp: 'rww 7/14/2000 01:44'!
displayPassFail: aString
	passFail := aString.
	self changed: #passFail! !

!TestRunner methodsFor: 'updating' stamp: 'rww 7/14/2000 01:44'!
runWindow
	passFailText isMorph
		ifTrue: 
			[passFailText color: Color white.
			detailsText color: Color white]
		ifFalse: 
			[passFailText insideColor: Color white.
			detailsText insideColor: Color white].
	self updateErrors: TestResult new.
	self updateFailures: TestResult new.
	self displayPassFail: 'Running...'.
	self displayDetails: '...'! !

!TestRunner methodsFor: 'updating' stamp: 'rww 7/14/2000 01:44'!
updateDetails: aTestResult 
	self displayDetails: aTestResult printString , (self timeSinceLastPassAsString: aTestResult).
	aTestResult hasPassed ifTrue: [lastPass _ Time now]! !

!TestRunner methodsFor: 'updating' stamp: 'rww 7/14/2000 01:44'!
updateErrors: aTestResult

	self displayErrors: (aTestResult errors collect: [:error | error printString])! !

!TestRunner methodsFor: 'updating' stamp: 'rww 7/14/2000 01:44'!
updateFailures: aTestResult

	self displayFailures: (aTestResult failures collect: [:failure | failure printString])! !

!TestRunner methodsFor: 'updating' stamp: 'rww 7/14/2000 01:44'!
updatePartColors: aColor 
	passFailText isMorph
		ifTrue: 
			[passFailText color: aColor.
			detailsText color: aColor]
		ifFalse: 
			[passFailText insideColor: aColor.
			detailsText insideColor: aColor]! !

!TestRunner methodsFor: 'updating' stamp: 'rww 7/14/2000 01:44'!
updatePassFail: aTestResult 
	| message |
	message _ aTestResult hasPassed
				ifTrue: ['Pass']
				ifFalse: ['Fail'].
	self displayPassFail: message! !

!TestRunner methodsFor: 'updating' stamp: 'rww 7/14/2000 01:44'!
updateWindow: aTestResult 
	aTestResult errors size + aTestResult failures size = 0
		ifTrue: [self updatePartColors: self passColor]
		ifFalse: [aTestResult errors size > 0
				ifTrue: [self updatePartColors: self errorColor]
				ifFalse: [self updatePartColors: self failColor]].
	self updatePassFail: aTestResult.
	self updateDetails: aTestResult.
	self updateFailures: aTestResult.
	self updateErrors: aTestResult! !

!TestRunner methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
details

	^details! !

!TestRunner methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
errors

	^errors! !

!TestRunner methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
failures

	^failures! !

!TestRunner methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
formatTime: aTime 
	aTime hours > 0 ifTrue: [^aTime hours printString , 'h'].
	aTime minutes > 0 ifTrue: [^aTime minutes printString , 'min'].
	^aTime seconds printString , ' sec'! !

!TestRunner methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
passFail

	^passFail! !

!TestRunner methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
suite
	| tokens stream |
	tokens := (TestCase subclasses collect: [:each | each name , '* '])
				copyWithout: 'SUnitTest* '.
	stream := WriteStream on: String new.
	tokens do: [:each | stream nextPutAll: each].
	^TestSuitesScripter run: stream contents! !

!TestRunner methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
tests
	^ tests! !

!TestRunner methodsFor: 'accessing' stamp: 'rww 7/14/2000 01:44'!
timeSinceLastPassAsString: aResult
	(lastPass isNil or: [aResult hasPassed not]) ifTrue: [^ ''].
	^ ', ' , (self formatTime: (Time now subtractTime: lastPass)) , ' since last Pass'! !

!TestRunner methodsFor: 'initialize' stamp: 'rww 7/14/2000 01:44'!
initialize
	result _ TestResult new.
	passFail _ 'N/A'.
	details _ '...'.
	failures _ OrderedCollection new.
	errors _ OrderedCollection new.
	tests _ (TestCase allSubclasses collect: [:each | each name]) asOrderedCollection.
	selectedSuite _ 0.		"Added rew"
	selectedFailureTest _ 0.
	selectedErrorTest _ 0! !

!TestRunner methodsFor: 'processing' stamp: 'rww 7/14/2000 01:44'!
debugErrorTest: anInteger
	selectedErrorTest _ anInteger.  "added rew"
	selectedFailureTest _ 0.
	self changed: #selectedFailureTest.		"added rew"
	self changed: #selectedErrorTest.		"added rew"
	(anInteger ~= 0)
		ifTrue: [(result errors at: anInteger) debug].
! !

!TestRunner methodsFor: 'processing' stamp: 'rww 7/14/2000 01:44'!
debugFailureTest: anInteger
	selectedFailureTest _ anInteger.
	selectedErrorTest _ 0.
	self changed: #selectedErrorTest.
	self changed: #selectedFailureTest.
	(anInteger ~= 0)
		ifTrue: [(result failures at: anInteger) debugAsFailure].
! !

!TestRunner methodsFor: 'processing' stamp: 'rww 7/14/2000 01:44'!
runOneTest
	testSuite notNil
		ifTrue: 
			[self runWindow.
			result _ (TestSuitesScripter run: testSuite) run.
			self updateWindow: result]
		ifFalse: 
			[self runWindow.
			self displayPassFail: 'No Test Suite Selected']! !

!TestRunner methodsFor: 'processing' stamp: 'rww 7/14/2000 01:44'!
runTests
	self runWindow.
	result _ self suite run.
	self updateWindow: result! !

!TestRunner methodsFor: 'processing' stamp: 'rww 7/14/2000 01:44'!
selectedErrorTest
	^selectedErrorTest! !

!TestRunner methodsFor: 'processing' stamp: 'rww 7/14/2000 01:44'!
selectedFailureTest
	^selectedFailureTest! !

!TestRunner methodsFor: 'processing' stamp: 'rww 7/14/2000 01:44'!
selectedSuite

	^selectedSuite! !

!TestRunner methodsFor: 'processing' stamp: 'rww 7/14/2000 01:44'!
selectedSuite: anInteger 
	selectedSuite _ selectedSuite = anInteger
					ifTrue:[0]
					ifFalse:[anInteger]. 
	selectedFailureTest _ 0.
	selectedErrorTest _ 0.
	self changed: #selectedFailureTest.		"added rew"
	self changed: #selectedErrorTest.		"added rew"
	self changed: #selectedSuite.
	selectedSuite ~= 0 ifTrue: [testSuite _ tests at: selectedSuite].
! !

!TestRunner methodsFor: 'constants' stamp: 'rww 7/14/2000 01:44'!
errorColor
	^ Color red! !

!TestRunner methodsFor: 'constants' stamp: 'rww 7/14/2000 01:44'!
failColor
	^ Color yellow! !

!TestRunner methodsFor: 'constants' stamp: 'rww 7/14/2000 01:44'!
passColor
	^ Color green! !

!TestRunner methodsFor: 'constants' stamp: 'rww 7/14/2000 01:44'!
runButtonColor
	^ Color yellow! !

!TestRunner methodsFor: 'constants' stamp: 'rww 7/14/2000 01:44'!
runButtonLabel
	^ 'RUN ALL'! !

!TestRunner methodsFor: 'constants' stamp: 'rww 7/14/2000 01:44'!
runButtonState

	^true! !

!TestRunner methodsFor: 'constants' stamp: 'rww 7/14/2000 01:44'!
runOneButtonLabel
	^ 'RUN'! !

!TestRunner methodsFor: 'constants' stamp: 'rww 7/14/2000 01:44'!
windowLabel

	^'SUnit Camp Smalltalk 2.6'! !

!TestRunner methodsFor: 'interface opening' stamp: 'rww 7/14/2000 01:44'!
open
	"TestRunner new open"
	"=== build the parts ... ==="
	| topWindow runButton errorsList failuresList runOneButton |
	(topWindow _ StandardSystemView new) label: self windowLabel;
	 model: self.
	runButton _ PluggableButtonView
				on: self
				getState: #runButtonState
				action: #runTests
				label: #runButtonLabel.
	runButton label: self runButtonLabel;
	 insideColor: self runButtonColor.
	runOneButton _ PluggableButtonView
				on: self
				getState: #runButtonState
				action: #runOneTest
				label: #runOneButtonLabel.
	runOneButton label: self runOneButtonLabel;
	 clearInside: self runButtonColor;
	 insideColor: self runButtonColor.
	passFailText _ PluggableTextView
				on: self
				text: #passFail
				accept: nil.
	detailsText _ PluggableTextView
				on: self
				text: #details
				accept: nil.
	testsList _ PluggableListView
				on: self
				list: #tests
				selected: #selectedSuite			"changed from nil"
				changeSelected: #selectedSuite:.
	failuresList _ PluggableListView
				on: self
				list: #failures
				selected: #selectedFailureTest		"Changed rew"
				changeSelected: #debugFailureTest:.
	errorsList _ PluggableListView
				on: self
				list: #errors
				selected: #selectedErrorTest		"Changed rew"
				changeSelected: #debugErrorTest:.
	"=== size the parts ... ==="
	runButton borderWidth: 1;
	 window: (0 @ 0 corner: 20 @ 15).
	runOneButton borderWidth: 1;
	 window: (0 @ 0 corner: 20 @ 15).
	passFailText borderWidth: 1;
	 window: (0 @ 0 corner: 100 @ 10).
	"(0.2 at 0.0 extent: 0.8 at 0.1)"
	detailsText borderWidth: 1;
	 window: (0 @ 0 corner: 100 @ 10).
	"(0.0 at 0.1 extent: 1.0 at 0.1)"
	testsList borderWidth: 1;
	 window: (0 @ 0 corner: 80 @ 30).
	failuresList borderWidth: 1;
	 window: (0 @ 0 corner: 100 @ 30).
	"(0.0 at 0.2 extent: 1.0 at 0.4)"
	errorsList borderWidth: 1;
	 window: (0 @ 0 corner: 100 @ 30).
	"(0.0 at 0.6 extent: 1.0 at 0.4)"
	"=== assemble the whole ... ==="
	topWindow addSubView: testsList.
	topWindow addSubView: runOneButton toRightOf: testsList.
	topWindow addSubView: runButton below: runOneButton.
	topWindow addSubView: passFailText below: testsList.
	topWindow addSubView: detailsText below: passFailText.
	topWindow addSubView: failuresList below: detailsText.
	topWindow addSubView: errorsList below: failuresList.
	"=== open it ... ==="
	topWindow minimumSize: 200 @ 200.
	topWindow controller open! !

!TestRunner methodsFor: 'interface opening' stamp: 'rww 7/14/2000 01:44'!
openAsMorph
	"TestRunner new openAsMorph"
	"=== build the parts ... ==="
	| topWindow runButton errorsList failuresList runOneButton |
	(topWindow _ SystemWindow labelled: self windowLabel) model: self.
	runButton _ PluggableButtonMorph
				on: self
				getState: #runButtonState
				action: #runTests
				label: #runButtonLabel.
	runButton color: self runButtonColor.
	runButton onColor: self runButtonColor offColor: self runButtonColor.
	runOneButton _ PluggableButtonMorph
				on: self
				getState: #runButtonState
				action: #runOneTest
				label: #runOneButtonLabel.
	runOneButton color: self runButtonColor.
	runOneButton onColor: self runButtonColor offColor: self runButtonColor.
	passFailText _ PluggableTextMorph
				on: self
				text: #passFail
				accept: nil.
	passFailText retractable: true.
	detailsText _ PluggableTextMorph
				on: self
				text: #details
				accept: nil.
	detailsText retractable: true.
	testsList _ PluggableListMorph
				on: self
				list: #tests
				selected: #selectedSuite		"Changed rew"
				changeSelected: #selectedSuite:.
	testsList autoDeselect: false.
	failuresList _ PluggableListMorph
				on: self
				list: #failures
				selected: #selectedFailureTest		"Changed rew"
				changeSelected: #debugFailureTest:.
	errorsList _ PluggableListMorph
				on: self
				list: #errors
				selected: #selectedErrorTest		"Changed rew"
				changeSelected: #debugErrorTest:.
	"=== assemble the whole ... ==="
	topWindow addMorph: testsList frame: (0.0 @ 0.0 extent: 0.8 @ 0.2).
	topWindow addMorph: runOneButton frame: (0.8 @ 0.0 extent: 0.2 @ 0.1).
	topWindow addMorph: runButton frame: (0.8 @ 0.1 extent: 0.2 @ 0.1).
	topWindow addMorph: passFailText frame: (0.0 @ 0.2 extent: 1.0 @ 0.1).
	topWindow addMorph: detailsText frame: (0.0 @ 0.3 extent: 1.0 @ 0.1).
	topWindow addMorph: failuresList frame: (0.0 @ 0.4 extent: 1.0 @ 0.3).
	topWindow addMorph: errorsList frame: (0.0 @ 0.7 extent: 1.0 @ 0.3).
	"=== open it ... ==="
	topWindow openInWorldExtent: 400 @ 200.
	^ topWindow! !


!TestRunner class methodsFor: 'instance creation' stamp: 'rww 7/14/2000 01:44'!
new

	^super new initialize! !

!TestRunner class methodsFor: 'instance creation' stamp: 'rww 7/14/2000 01:44'!
open
	"TestRunner open"
	| testRunner |
	testRunner _ super new initialize.
	World isNil
		ifTrue:[testRunner open]
		ifFalse:[testRunner openAsMorph].
	^testRunner! !



More information about the Squeak-dev mailing list