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
|