CampSmalltalk SUnit 2.7.1 for Squeak

Roger Whitney whitney at cs.sdsu.edu
Thu Aug 24 16:58:18 UTC 2000


I  have attached 4 change sets for what I call SUnit 2.7.1.  This is
CampSmalltalk 2.7 with the following changes:

1 List pane selection now works in the morphic version of TestRunner. These
are the changes done to SUnit 2.6 at UIUC earlier this summer.

2 Class category names are modified for better package browser support.
Category names are SUnit-*

I have tested this version of SUnit on Squeak 2.8 on a Mac. Some odd
behavior still remains on the mvc version of TestRunner. Debug windows open
up behind instead of in front of the TestRunner window.

Paul McDonough earlier set out a version of SUnit 2.6.
--------------
The four change sets are to be loaded in this order:
  SUnitPreload
  SUnit
  SUnitUI
  (optional) SUnitTests

SUnit is started via
	TestRunner new open (mvc)
	TestRunner new openAsMorph

-------------- next part --------------
'From Squeak2.8 of 13 June 2000 [latest update: #2359] on 23 August 2000 at
10:36:42 pm'!
Delay subclass: #SUnitDelay
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Preload'!
Object subclass: #SUnitNameResolver
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Preload'!
SUnitNameResolver class
	instanceVariableNames: ''!
Exception subclass: #TestFailure
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Preload'!

!Object methodsFor: 'Camp Smalltalk' stamp: 'SSS 7/3/2000 11:04'!
sunitAddDependent: anObject

	self addDependent: anObject! !

!Object methodsFor: 'Camp Smalltalk' stamp: 'SSS 7/3/2000 11:04'!
sunitChanged: anAspect

	self changed: anAspect! !

!Object methodsFor: 'Camp Smalltalk' stamp: 'SSS 7/3/2000 11:05'!
sunitRemoveDependent: anObject

	self removeDependent: anObject! !


!Behavior methodsFor: 'Camp Smalltalk' stamp: 'SSS 7/3/2000 10:41'!
sunitSelectors

	^self selectors asSortedCollection asOrderedCollection! !


!BlockContext methodsFor: 'Camp Smalltalk' stamp: 'SSS 7/3/2000 10:55'!
sunitEnsure: aBlock

	^self ensure: aBlock! !

!BlockContext methodsFor: 'Camp Smalltalk' stamp: 'SSS 7/3/2000 10:58'!
sunitOn: anException do: aHandlerBlock

	^self on: anException do: aHandlerBlock! !


!Class methodsFor: 'Camp Smalltalk' stamp: 'SSS 7/3/2000 10:59'!
sunitName

	^self name! !


!Exception methodsFor: 'Camp Smalltalk' stamp: 'SSS 7/3/2000 11:02'!
sunitExitWith: aValue

	self return: aValue! !


!Exception class methodsFor: 'Camp Smalltalk' stamp: 'SSS 7/3/2000 11:02'!
sunitSignalWith: aString

	^self signal: aString! !


!SUnitNameResolver class methodsFor: 'Camp Smalltalk' stamp: 'SSS 7/3/2000
11:11'!
classNamed: aSymbol

	^Smalltalk

		at: aSymbol

		ifAbsent: [nil].! !


!String methodsFor: 'Camp Smalltalk' stamp: 'SSS 7/3/2000 11:09'!
sunitAsSymbol

	^self asSymbol! !

!String methodsFor: 'Camp Smalltalk' stamp: 'SSS 7/3/2000 11:10'!
sunitMatch: aString

	^self match: aString! !

!String methodsFor: 'Camp Smalltalk' stamp: 'SSS 7/3/2000 11:10'!
sunitSubStrings

	^self substrings! !


!Symbol methodsFor: 'Camp Smalltalk' stamp: 'SSS 7/3/2000 11:12'!
sunitAsClass

	^SUnitNameResolver classNamed: self! !


!TestFailure methodsFor: 'Camp Smalltalk' stamp: 'Sames 4/11/2000 18:07'!
defaultAction

	Debugger

		openContext: initialContext

		label: messageText

		contents: initialContext shortStack! !

-------------- next part --------------
'From Squeak2.8 of 13 June 2000 [latest update: #2359] on 23 August 2000 at
10:36:48 pm'!
Object subclass: #TestCase
	instanceVariableNames: 'testSelector '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Core'!
TestCase class
	instanceVariableNames: ''!
Object subclass: #TestResult
	instanceVariableNames: 'runCount failures errors '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Core'!
TestResult class
	instanceVariableNames: ''!
Object subclass: #TestSuite
	instanceVariableNames: 'tests '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Core'!
Object subclass: #TestSuitesScripter
	instanceVariableNames: 'script stream '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Core'!
TestSuitesScripter class
	instanceVariableNames: ''!

!TestCase methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 12:50'!
assert: aBoolean
	aBoolean ifFalse: [self signalFailure: 'Assertion failed']! !

!TestCase methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 12:50'!
deny: aBoolean
	self assert: aBoolean not! !

!TestCase methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 12:50'!
should: aBlock
	self assert: aBlock value! !

!TestCase methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 12:51'!
should: aBlock raise: anExceptionalEvent
	^self assert: (self executeShould: aBlock inScopeOf:
anExceptionalEvent)! !

!TestCase methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 12:51'!
shouldnt: aBlock
	self deny: aBlock value! !

!TestCase methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 12:51'!
shouldnt: aBlock raise: anExceptionalEvent
	^self assert: (self executeShould: aBlock inScopeOf:
anExceptionalEvent) not! !

!TestCase methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 12:52'!
signalFailure: aString
	TestResult failure sunitSignalWith: aString
! !

!TestCase methodsFor: 'Dependencies' stamp: 'SSS 7/3/2000 12:52'!
addDependentToHierachy: anObject
	"an empty method. for Composite compability with TestSuite"
! !

!TestCase methodsFor: 'Dependencies' stamp: 'SSS 7/3/2000 12:53'!
removeDependentFromHierachy: anObject
	"an empty method. for Composite compability with TestSuite"
! !

!TestCase methodsFor: 'Printing' stamp: 'SSS 7/3/2000 12:54'!
printOn: aStream
	aStream nextPutAll: self class printString.
	aStream nextPutAll: '>>'.
	aStream nextPutAll: testSelector! !

!TestCase methodsFor: 'Private' stamp: 'SSS 7/3/2000 12:55'!
executeShould: aBlock inScopeOf: anExceptionalEvent
	[[aBlock value]
		sunitOn: anExceptionalEvent
		do: [:ex | ^true]]
			sunitOn: TestResult error
			do: [:ex | ^false].
	^false.! !

!TestCase methodsFor: 'Private' stamp: 'SSS 7/3/2000 12:55'!
setTestSelector: aSymbol
	testSelector := aSymbol! !

!TestCase methodsFor: 'Running' stamp: 'SSS 7/3/2000 12:55'!
debug
	(self class selector: testSelector) runCase! !

!TestCase methodsFor: 'Running' stamp: 'SSS 7/3/2000 12:56'!
debugAsFailure
	(self class selector: testSelector) runCaseAsFailure! !

!TestCase methodsFor: 'Running' stamp: 'SSS 7/3/2000 12:56'!
openDebuggerOnFailingTestMethod
	"SUnit has halted one step in front of the failing test method.
	Step over the 'self halt' and send into 'self perform: testSelector'
	to see the failure from the beginning"

	self halt.
	self perform: testSelector sunitAsSymbol! !

!TestCase methodsFor: 'Running' stamp: 'SSS 7/3/2000 12:56'!
run
	| result |
	result := TestResult new.
	self run: result.
	^result! !

!TestCase methodsFor: 'Running' stamp: 'SSS 7/3/2000 12:57'!
run: aResult
	aResult runCase: self! !

!TestCase methodsFor: 'Running' stamp: 'SSS 7/3/2000 12:57'!
runCase
	self setUp.
	[self perform: testSelector sunitAsSymbol] sunitEnsure: [self
tearDown]! !

!TestCase methodsFor: 'Running' stamp: 'SSS 7/3/2000 12:57'!
runCaseAsFailure
	self setUp.
	[[self openDebuggerOnFailingTestMethod] sunitEnsure: [self
tearDown]] fork! !

!TestCase methodsFor: 'Running' stamp: 'SSS 7/3/2000 12:57'!
setUp! !

!TestCase methodsFor: 'Running' stamp: 'SSS 7/3/2000 12:57'!
tearDown! !


!TestCase class methodsFor: 'Instance Creation' stamp: 'SSS 7/3/2000 12:58'!
debug: aSymbol
	^(self selector: aSymbol) debug! !

!TestCase class methodsFor: 'Instance Creation' stamp: 'SSS 7/3/2000 12:58'!
run: aSymbol
	^(self selector: aSymbol) run! !

!TestCase class methodsFor: 'Instance Creation' stamp: 'SSS 7/3/2000 12:59'!
selector: aSymbol
	^self new setTestSelector: aSymbol! !

!TestCase class methodsFor: 'Instance Creation' stamp: 'SSS 7/3/2000 12:59'!
suite
	| testSelectors result |
	testSelectors := self sunitSelectors select: [:each | 'test*'
sunitMatch: each].
	result := TestSuite new.
	testSelectors do: [:each | result addTest: (self selector: each)].
	^result! !


!TestResult methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 13:01'!
correctCount
	^self runCount - self failureCount - self errorCount! !

!TestResult methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 13:01'!
defects
	^self errors, self failures! !

!TestResult methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 13:01'!
errorCount
	^self errors size! !

!TestResult methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 13:01'!
errors
	errors isNil ifTrue: [errors := OrderedCollection new].
	^errors! !

!TestResult methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 13:02'!
failureCount
	^self failures size! !

!TestResult methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 13:02'!
failures
	failures isNil ifTrue: [failures := OrderedCollection new].
	^failures! !

!TestResult methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 13:02'!
runCount
	^runCount! !

!TestResult methodsFor: 'Init / Release' stamp: 'SSS 7/3/2000 13:03'!
initialize
	runCount := 0! !

!TestResult methodsFor: 'Printing' stamp: 'SSS 7/3/2000 13:03'!
printOn: aStream
	aStream
		nextPutAll: self runCount printString;
		nextPutAll: ' run, ';
		nextPutAll: self failureCount printString;
		nextPutAll: ' failed, ';
		nextPutAll: self errorCount printString;
		nextPutAll:' error'.
	self errorCount ~= 1
		ifTrue: [aStream nextPut: $s].! !

!TestResult methodsFor: 'Running' stamp: 'SSS 7/3/2000 13:03'!
runCase: aTestCase
	runCount := runCount + 1.
	[[aTestCase runCase]
		sunitOn: self class failure
		do:
			[:signal |
			self failures add: aTestCase.
			signal sunitExitWith: nil]]
			sunitOn: self class error
			do:
				[:signal |
				self errors add: aTestCase.
				signal sunitExitWith: nil]! !

!TestResult methodsFor: 'Testing' stamp: 'SSS 7/3/2000 13:04'!
hasPassed
	^self runCount = self correctCount! !

!TestResult methodsFor: 'Testing' stamp: 'SSS 7/3/2000 13:04'!
isFailure: aTestCase
	^self failures includes: aTestCase! !


!TestResult class methodsFor: 'Exceptions' stamp: 'SSS 7/3/2000 13:05'!
error
	^self exError! !

!TestResult class methodsFor: 'Exceptions' stamp: 'SSS 7/3/2000 13:06'!
exError
	"Change for Dialect"
	^ Error! !

!TestResult class methodsFor: 'Exceptions' stamp: 'SSS 7/3/2000 13:06'!
failure
	^TestFailure! !

!TestResult class methodsFor: 'Exceptions' stamp: 'SSS 7/3/2000 13:06'!
signalErrorWith: aString
	self error sunitSignalWith: aString! !

!TestResult class methodsFor: 'Exceptions' stamp: 'SSS 7/3/2000 13:07'!
signalFailureWith: aString
	self failure sunitSignalWith: aString! !

!TestResult class methodsFor: 'Init / Release' stamp: 'SSS 7/3/2000 13:07'!
new
	^super new initialize! !


!TestSuite methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 13:09'!
addTest: aTest
	self tests add: aTest! !

!TestSuite methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 13:10'!
addTests: aCollection
	aCollection do: [:eachTest | self addTest: eachTest]! !

!TestSuite methodsFor: 'Accessing' stamp: 'SSS 7/3/2000 13:10'!
tests
	tests isNil ifTrue: [tests := OrderedCollection new].
	^tests! !

!TestSuite methodsFor: 'Dependencies' stamp: 'SSS 7/3/2000 13:11'!
addDependentToHierachy: anObject
	self sunitAddDependent: anObject.
	self tests do: [ :each | each addDependentToHierachy: anObject]! !

!TestSuite methodsFor: 'Dependencies' stamp: 'SSS 7/3/2000 13:11'!
removeDependentFromHierachy: anObject
	self sunitRemoveDependent: anObject.
	self tests do: [ :each | each removeDependentFromHierachy: anObject]! !

!TestSuite methodsFor: 'Running' stamp: 'SSS 7/3/2000 13:12'!
run
	| result |
	result := TestResult new.
	self run: result.
	^result! !

!TestSuite methodsFor: 'Running' stamp: 'SSS 7/3/2000 13:12'!
run: aResult
	self tests do:
		[:each |
		self sunitChanged: each.
		each run: aResult]! !


!TestSuitesScripter methodsFor: 'Printing' stamp: 'SSS 7/3/2000 13:12'!
printOn: aStream
	aStream nextPutAll: (script isNil
		ifFalse: [script]
		ifTrue: ['N/A'])! !

!TestSuitesScripter methodsFor: 'Private' stamp: 'SSS 7/3/2000 13:13'!
executeSingleSuiteScript: aString
	| useHierachy realName testCase |
	aString last = $*
		ifTrue:
			[realName := aString copyFrom: 1 to: aString size - 1.
			useHierachy := true]
		ifFalse:
			[realName := aString.
			useHierachy := false].
	realName isEmpty ifTrue: [^nil].
	testCase := SUnitNameResolver classNamed: realName sunitAsSymbol.
	testCase isNil ifTrue: [^nil].
	^useHierachy
		ifTrue: [self hierachyOfTestSuitesFrom: testCase]
		ifFalse: [testCase suite]! !

!TestSuitesScripter methodsFor: 'Private' stamp: 'SSS 7/3/2000 13:13'!
getNextToken
	[stream atEnd not and: [stream peek first = $"]] whileTrue: [self
skipComment].
	^stream atEnd not
		ifTrue: [stream next]
		ifFalse: [nil]! !

!TestSuitesScripter methodsFor: 'Private' stamp: 'SSS 7/3/2000 13:13'!
hierachyOfTestSuitesFrom: aTestCase
	| subSuite |
	subSuite := TestSuite new.
	subSuite addTest: aTestCase suite.
	aTestCase allSubclasses do: [:each | subSuite addTest: each
sunitName sunitAsSymbol sunitAsClass suite].
	^subSuite! !

!TestSuitesScripter methodsFor: 'Private' stamp: 'SSS 7/3/2000 13:14'!
setScript: aString
	script := aString! !

!TestSuitesScripter methodsFor: 'Private' stamp: 'SSS 7/3/2000 13:14'!
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: 'Running' stamp: 'SSS 7/3/2000 13:15'!
run: aString
	| suite subSuite token |
	suite := TestSuite new.
	stream := ReadStream on: aString sunitSubStrings.
	[stream atEnd] whileFalse:
		[token := self getNextToken.
		token notNil ifTrue: [
			subSuite := self executeSingleSuiteScript: token.
			subSuite notNil ifTrue:[suite addTest: subSuite]]].
	^suite! !

!TestSuitesScripter methodsFor: 'Running' stamp: 'SSS 7/3/2000 13:15'!
value
	^self run: script! !


!TestSuitesScripter class methodsFor: 'Example' stamp: 'SSS 7/3/2000 13:16'!
exampleScripting
	(TestSuitesScripter script: ' "scratch suite 3" ExampleSetTest
SUnitTest* ') value! !

!TestSuitesScripter class methodsFor: 'Init / Release' stamp: 'SSS 7/3/2000
13:16'!
run: aString
	^self new run: aString! !

!TestSuitesScripter class methodsFor: 'Init / Release' stamp: 'SSS 7/3/2000
13:17'!
script: aString
	^self new setScript: aString! !

-------------- next part --------------
'From Squeak2.8 of 13 June 2000 [latest update: #2359] on 23 August 2000 at
10:37:05 pm'!
Model subclass: #TestRunner
	instanceVariableNames: 'result details passFail failures errors
tests testSuite passFailText detailsText lastPass testsList
selectedFailureTest selectedErrorTest selectedSuite '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-UI'!
TestRunner class
	instanceVariableNames: ''!

!TestRunner methodsFor: 'constants' stamp: 'SSS 7/5/2000 13:53'!
debugButtonLabel
	^ 'DEBUG'! !

!TestRunner methodsFor: 'constants' stamp: 'SSS 7/5/2000 14:08'!
debugState

	^true! !

!TestRunner methodsFor: 'constants' stamp: 'Sames 4/11/2000 19:13'!
errorColor
	^ Color red! !

!TestRunner methodsFor: 'constants' stamp: 'Sames 4/11/2000 19:13'!
failColor
	^ Color yellow! !

!TestRunner methodsFor: 'constants' stamp: 'Sames 4/11/2000 19:13'!
passColor
	^ Color green! !

!TestRunner methodsFor: 'constants' stamp: 'SSS 7/5/2000 13:53'!
refreshButtonLabel
	^ 'REFRESH'! !

!TestRunner methodsFor: 'constants' stamp: 'SSS 7/5/2000 13:59'!
refreshButtonState

	^true! !

!TestRunner methodsFor: 'constants' stamp: 'SSS 7/5/2000 14:30'!
resetColor
	^ Color white! !

!TestRunner methodsFor: 'constants' stamp: 'Sames 4/11/2000 19:32'!
runButtonColor
	^ Color yellow! !

!TestRunner methodsFor: 'constants' stamp: 'Sames 4/11/2000 18:14'!
runButtonLabel
	^ 'RUN ALL'! !

!TestRunner methodsFor: 'constants' stamp: 'Sames 4/11/2000 17:32'!
runButtonState

	^true! !

!TestRunner methodsFor: 'constants' stamp: 'Sames 4/11/2000 18:17'!
runOneButtonLabel
	^ 'RUN'! !

!TestRunner methodsFor: 'constants' stamp: 'SSS 7/5/2000 14:23'!
windowLabel

	^'SUnit Camp Smalltalk 2.7.1 Test Runner'! !

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

!TestRunner methodsFor: 'processing' stamp: 'rew 8/23/2000 21:49'!
debugFailureTest: anInteger

	(anInteger ~= 0)
		ifTrue: [(result failures at: anInteger) debugAsFailure].

	selectedFailureTest _ anInteger.
	selectedErrorTest _ 0.
	self changed: #selectedErrorTest.
	self changed: #selectedFailureTest.
! !

!TestRunner methodsFor: 'processing' stamp: 'SSS 7/5/2000 13:59'!
debugTest! !

!TestRunner methodsFor: 'processing' stamp: 'rew 8/23/2000 20:47'!
refreshTests
	tests _ (TestCase allSubclasses collect: [:each | each name])
asOrderedCollection.
	self changed: #tests.
	testSuite := nil.
	selectedSuite _ 0.
	selectedFailureTest _ 0.
	selectedErrorTest _ 0.
	self changed: #selectedFailureTest.		"added rew"
	self changed: #selectedErrorTest.		"added rew"
	self changed: #selectedSuite.
	self refreshWindow! !

!TestRunner methodsFor: 'processing' stamp: 'rew 8/23/2000 21:06'!
runOneTest
	Cursor execute showWhile:
		[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: 'rew 8/23/2000 21:05'!
runTests
	Cursor execute showWhile:
		[self runWindow.
		result _ self suite run.
		self updateWindow: result]! !

!TestRunner methodsFor: 'processing' stamp: 'rew 5/15/2000 21:08'!
selectedErrorTest
	^selectedErrorTest! !

!TestRunner methodsFor: 'processing' stamp: 'rew 8/23/2000 21:01'!
selectedFailureTest

	^selectedFailureTest! !

!TestRunner methodsFor: 'processing' stamp: 'rew 5/15/2000 21:08'!
selectedSuite

	^selectedSuite! !

!TestRunner methodsFor: 'processing' stamp: 'rew 8/23/2000 20:52'!
selectedSuite: anInteger
	anInteger ~= 0 ifTrue: [testSuite _ tests at: 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.! !

!TestRunner methodsFor: 'interface opening' stamp: 'SSS 7/5/2000 14:21'!
open
	"TestRunner new open"
	"=== build the parts ... ==="
	| topWindow runButton errorsList failuresList runOneButton
refreshButton debugButton |
	(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.
	refreshButton _ PluggableButtonView
				on: self
				getState: #refreshButtonState
				action: #refreshTests
				label: #refreshButtonLabel.
	refreshButton label: self refreshButtonLabel;
	 clearInside: self runButtonColor;
	 insideColor: self runButtonColor.
	debugButton _ PluggableButtonView
				on: self
				getState: #debugState
				action: #debugTest
				label: #debugButtonLabel.
	debugButton label: self debugButtonLabel;
	 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: nil
				changeSelected: #selectedSuite:.
	failuresList _ PluggableListView
				on: self
				list: #failures
				selected: nil
				changeSelected: #debugFailureTest:.
	errorsList _ PluggableListView
				on: self
				list: #errors
				selected: nil
				changeSelected: #debugErrorTest:.
	"=== size the parts ... ==="
	runButton borderWidth: 1;
	 window: (0 @ 0 corner: 20 @ 15).
	runOneButton borderWidth: 1;
	 window: (0 @ 0 corner: 20 @ 15).
	refreshButton borderWidth: 1;
		window: (0 @ 0 corner: 20 @ 30).
	passFailText borderWidth: 1;
	 window: (0 @ 0 corner: 100 @ 10).
	detailsText borderWidth: 1;
	 window: (0 @ 0 corner: 100 @ 10).
	testsList borderWidth: 1;
	 	window: (0 @ 0 corner: 60 @ 30).
	failuresList borderWidth: 1;
	 window: (0 @ 0 corner: 100 @ 30).
	errorsList borderWidth: 1;
	 window: (0 @ 0 corner: 100 @ 30).
"	debugButton borderWidth: 1;
		window: (0 @ 0 corner: 20 @ 60)."
	"=== assemble the whole ... ==="
	topWindow addSubView: refreshButton.
	topWindow addSubView: testsList toRightOf: refreshButton.
	topWindow addSubView: runOneButton toRightOf: testsList.
	topWindow addSubView: runButton below: runOneButton.
	topWindow addSubView: passFailText below: refreshButton.
	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: 'rew 8/23/2000 21:44'!
openAsMorph
	"TestRunner new openAsMorph"
	"=== build the parts ... ==="
	| topWindow runButton errorsList failuresList runOneButton
refreshButton |
	Smalltalk isMorphic
		ifFalse: [^self open].
	(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.
	refreshButton _ PluggableButtonMorph
				on: self
				getState: #refreshButtonState
				action: #refreshTests
				label: #refreshButtonLabel.
	refreshButton color: self runButtonColor.
	refreshButton 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
				changeSelected: #selectedSuite:.
	testsList autoDeselect: false.
	failuresList _ PluggableListMorph
				on: self
				list: #failures
				selected: #selectedFailureTest
				changeSelected: #debugFailureTest:.
	errorsList _ PluggableListMorph
				on: self
				list: #errors
				selected: #selectedErrorTest
				changeSelected: #debugErrorTest:.
	"=== assemble the whole ... ==="
	topWindow addMorph: refreshButton frame: (0.0 @ 0.0 extent: 0.2 @ 0.2).
	topWindow addMorph: testsList frame: (0.2 @ 0.0 extent: 0.6 @ 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.
	self refreshWindow.
	^ topWindow! !

!TestRunner methodsFor: 'accessing' stamp: 'Sames 4/11/2000 17:25'!
details

	^details! !

!TestRunner methodsFor: 'accessing' stamp: 'Sames 4/11/2000 17:25'!
errors

	^errors! !

!TestRunner methodsFor: 'accessing' stamp: 'Sames 4/11/2000 17:26'!
failures

	^failures! !

!TestRunner methodsFor: 'accessing' stamp: 'Sames 4/12/2000 18:12'!
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: 'Sames 4/11/2000 17:26'!
passFail

	^passFail! !

!TestRunner methodsFor: 'accessing' stamp: 'Sames 4/11/2000 18:20'!
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: 'Sames 4/11/2000 18:39'!
tests
	^ tests! !

!TestRunner methodsFor: 'accessing' stamp: 'Sames 4/12/2000 18:19'!
timeSinceLastPassAsString: aResult
	(lastPass isNil or: [aResult hasPassed not]) ifTrue: [^ ''].
	^ ', ' , (self formatTime: (Time now subtractTime: lastPass)) , '
since last Pass'! !

!TestRunner methodsFor: 'initialize' stamp: 'rew 8/23/2000 20:57'!
initialize
	result _ TestResult new.
	passFail _ 'N/A'.
	details _ '...'.
	failures _ OrderedCollection new.
	errors _ OrderedCollection new.
	tests _ (TestCase allSubclasses collect: [:each | each name])
asOrderedCollection.
	selectedSuite _ 0.
	selectedFailureTest _ 0.
	selectedErrorTest _ 0.
! !

!TestRunner methodsFor: 'updating' stamp: 'Sames 4/11/2000 17:38'!
displayDetails: aString
	details := aString.
	self changed: #details! !

!TestRunner methodsFor: 'updating' stamp: 'Sames 4/11/2000 17:37'!
displayErrors: anOrderedCollection

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

!TestRunner methodsFor: 'updating' stamp: 'Sames 4/11/2000 17:37'!
displayFailures: anOrderedCollection

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

!TestRunner methodsFor: 'updating' stamp: 'Sames 4/11/2000 17:36'!
displayPassFail: aString
	passFail := aString.
	self changed: #passFail! !

!TestRunner methodsFor: 'updating' stamp: 'SSS 7/5/2000 14:31'!
refreshWindow
	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: 'N/A'.
	self displayDetails: '...'! !

!TestRunner methodsFor: 'updating' stamp: 'Sames 4/12/2000 18:52'!
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: 'Sames 4/12/2000 18:20'!
updateDetails: aTestResult
	self displayDetails: aTestResult printString , (self
timeSinceLastPassAsString: aTestResult).
	aTestResult hasPassed ifTrue: [lastPass _ Time now]! !

!TestRunner methodsFor: 'updating' stamp: 'Sames 4/11/2000 17:35'!
updateErrors: aTestResult

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

!TestRunner methodsFor: 'updating' stamp: 'Sames 4/11/2000 17:35'!
updateFailures: aTestResult

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

!TestRunner methodsFor: 'updating' stamp: 'Sames 4/12/2000 18:57'!
updatePartColors: aColor
	passFailText isMorph
		ifTrue:
			[passFailText color: aColor.
			detailsText color: aColor]
		ifFalse:
			[passFailText insideColor: aColor.
			detailsText insideColor: aColor]! !

!TestRunner methodsFor: 'updating' stamp: 'Sames 4/11/2000 18:27'!
updatePassFail: aTestResult
	| message |
	message _ aTestResult hasPassed
				ifTrue: ['Pass']
				ifFalse: ['Fail'].
	self displayPassFail: message! !

!TestRunner methodsFor: 'updating' stamp: 'Sames 4/12/2000 18:54'!
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 class methodsFor: 'instance creation' stamp: 'Sames 4/11/2000
17:33'!
new

	^super new initialize! !

-------------- next part --------------
'From Squeak2.8 of 13 June 2000 [latest update: #2359] on 23 August 2000 at
10:37:11 pm'!
TestCase subclass: #ExampleSetTest
	instanceVariableNames: 'full empty '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Tests'!
TestCase subclass: #SUnitTest
	instanceVariableNames: 'hasRun hasSetup hasRanOnce '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Tests'!
SUnitTest subclass: #TestSuitesHierarchyScriptTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Tests'!
TestSuitesHierarchyScriptTest subclass: #TestSuitesCompoundScriptTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Tests'!
SUnitTest subclass: #TestSuitesScriptTest
	instanceVariableNames: 'scripter suite '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SUnit-Tests'!

!ExampleSetTest methodsFor: 'Running' stamp: 'SSS 7/5/2000 13:31'!
setUp
	empty := Set new.
	full := Set with: 5 with: #abc! !

!ExampleSetTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:32'!
testAdd
	empty add: 5.
	self assert: (empty includes: 5)! !

!ExampleSetTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:32'!
testGrow
	empty addAll: (1 to: 100).
	self assert: empty size = 100! !

!ExampleSetTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:32'!
testIllegal
	self
		should: [empty at: 5]
		raise: TestResult error.
	self
		should: [empty at: 5 put: #abc]
		raise: TestResult error! !

!ExampleSetTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:32'!
testIncludes
	self assert: (full includes: 5).
	self assert: (full includes: #abc)! !

!ExampleSetTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:33'!
testOccurrences
	self assert: (empty occurrencesOf: 0) = 0.
	self assert: (full occurrencesOf: 5) = 1.
	full add: 5.
	self assert: (full occurrencesOf: 5) = 1! !

!ExampleSetTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:33'!
testRemove
	full remove: 5.
	self assert: (full includes: #abc).
	self deny: (full includes: 5)! !


!SUnitTest methodsFor: 'Accessing' stamp: 'SSS 7/5/2000 13:33'!
hasRun
	^hasRun! !

!SUnitTest methodsFor: 'Accessing' stamp: 'SSS 7/5/2000 13:34'!
hasSetup
	^hasSetup! !

!SUnitTest methodsFor: 'Private' stamp: 'SSS 7/5/2000 13:34'!
error
	3 zork! !

!SUnitTest methodsFor: 'Private' stamp: 'SSS 7/5/2000 13:34'!
fail
	self assert: false! !

!SUnitTest methodsFor: 'Private' stamp: 'SSS 7/5/2000 13:34'!
noop! !

!SUnitTest methodsFor: 'Private' stamp: 'SSS 7/5/2000 13:35'!
setRun
	hasRun := true! !

!SUnitTest methodsFor: 'Running' stamp: 'SSS 7/5/2000 13:35'!
setUp
	hasSetup := true! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:35'!
testAssert
	self assert: true.
	self deny: false! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:36'!
testDebugUI
	"This should break"
	3 zork! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:36'!
testDefects
	| result suite error failure |
	suite := TestSuite new.
	suite addTest: (error := self class selector: #error).
	suite addTest: (failure := self class selector: #fail).
	result := suite run.
	self assert: result defects asArray = (Array with: error with:
failure)! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:36'!
testDialectLocalizedException
	self should: [TestResult signalFailureWith: 'Foo'] raise:
TestResult failure.
	self should: [TestResult signalErrorWith: 'Foo'] raise: TestResult
error.
	self shouldnt: [TestResult signalErrorWith: 'Foo'] raise:
TestResult failure.! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:37'!
testError
	| case result |
	case := self class selector: #error.
	result := case run.
	self assert: result correctCount = 0.
	self assert: result failureCount = 0.
	self assert: result runCount = 1.
	self assert: result errorCount = 1! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:37'!
testException
	self should: [self error: 'foo'] raise: TestResult error! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:37'!
testFail
	| case result |
	case := self class selector: #fail.
	result := case run.
	self assert: result correctCount = 0.
	self assert: result failureCount = 1.
	self assert: result runCount = 1! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:37'!
testFailureDebugUI
	"This should fail !!"
	self fail! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:38'!
testIsNotRerunOnDebug
	| case |
	case := self class selector: #testRanOnlyOnce.
	case run.
	case debug! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:38'!
testRan
	| case |
	case := self class selector: #setRun.
	case run.
	self assert: case hasSetup.
	self assert: case hasRun! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:38'!
testRanOnlyOnce
	self assert: hasRanOnce ~= true.
	hasRanOnce := true.! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:38'!
testResult
	| case result |
	case := self class selector: #noop.
	result := case run.
	self assert: result runCount = 1.
	self assert: result correctCount = 1! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:38'!
testRunning
	(SUnitDelay forSeconds: 2) wait! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:38'!
testShould
	self should: [true].
	self shouldnt: [false]! !

!SUnitTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:39'!
testSuite
	| suite result |
	suite := TestSuite new.
	suite addTest: (self class selector: #noop).
	suite addTest: (self class selector: #fail).
	result := suite run.
	self assert: result runCount = 2.
	self assert: result correctCount = 1.
	self assert: result failureCount = 1! !


!TestSuitesHierarchyScriptTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000
13:39'!
testRan
	self setRun! !


!TestSuitesCompoundScriptTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000
13:40'!
testRan
	super testRan! !


!TestSuitesScriptTest methodsFor: 'Running' stamp: 'SSS 7/5/2000 13:40'!
setUp
	scripter := TestSuitesScripter new.! !

!TestSuitesScriptTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:40'!
testCompoundScript
	| allTestCaseClasses superCase subCase |
	allTestCaseClasses := (scripter run: 'TestSuitesHierarchyScriptTest
TestSuitesCompoundScriptTest') tests.
	self assert: allTestCaseClasses size = 2.
	superCase := (allTestCaseClasses at: 1) tests first.
	self assert: superCase class sunitName sunitAsSymbol =
#TestSuitesHierarchyScriptTest.
	subCase := (allTestCaseClasses at: 2) tests first.
	self assert: subCase class sunitName sunitAsSymbol =
#TestSuitesCompoundScriptTest.! !

!TestSuitesScriptTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:41'!
testEmbeddedNameCommentScript
	suite := scripter run: ' "This comment contains the name of a
SUnitTest Case"  TestSuitesScriptTest'.
	self assert: suite tests size = 1! !

!TestSuitesScriptTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:41'!
testEmptyCommentScript
	suite := scripter run: ' " " TestSuitesScriptTest'.
	self assert: suite tests size = 1! !

!TestSuitesScriptTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:41'!
testEmptyHierachyScript
	suite := scripter run: '*'.
	self assert: suite tests isEmpty! !

!TestSuitesScriptTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:42'!
testEmptyScript
	suite := scripter run: ''.
	self assert: suite tests isEmpty! !

!TestSuitesScriptTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:42'!
testHierachyScript
	| allTestCaseClasses superCase subCase |
	suite := scripter run: 'TestSuitesHierarchyScriptTest*'.
	allTestCaseClasses := suite tests.
	self assert: allTestCaseClasses size = 1.
	superCase := (allTestCaseClasses first tests at: 1) tests first.
	self assert: superCase class sunitName sunitAsSymbol =
#TestSuitesHierarchyScriptTest.
	subCase := (allTestCaseClasses first tests at: 2) tests first.
	self assert: subCase class sunitName sunitAsSymbol =
#TestSuitesCompoundScriptTest.! !

!TestSuitesScriptTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:42'!
testOpenCommentScript
	suite := scripter run: ' "SUnitTest'.
	self assert: suite tests isEmpty! !

!TestSuitesScriptTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:42'!
testSimpleScript
	| allTestCaseClasses case |
	suite := scripter run: 'TestSuitesHierarchyScriptTest'.
	allTestCaseClasses := suite tests.
	self assert: allTestCaseClasses size = 1.
	case := (allTestCaseClasses at: 1) tests at: 1.
	self assert: case class sunitName sunitAsSymbol =
#TestSuitesHierarchyScriptTest.! !

!TestSuitesScriptTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:42'!
testSingleWordCommentScript
	suite := scripter run: ' "SUnitTest" TestSuitesScriptTest'.
	self assert: suite tests size = 1! !

!TestSuitesScriptTest methodsFor: 'Testing' stamp: 'SSS 7/5/2000 13:43'!
testTwoCommentsScript
	suite := scripter run: ' " SUnitTest "  " SUnitTest "
TestSuitesScriptTest'.
	self assert: suite tests size = 1! !

-------------- next part --------------

Roger Whitney              Mathematical & Computer Sciences Department
whitney at cs.sdsu.edu        San Diego State University
http://www.eli.sdsu.edu/   San Diego, CA 92182-7720
(619) 583-1978
(619) 594-3535 (office)
(619) 594-6746 (fax)


More information about the Squeak-dev mailing list