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
|