"{ Package: 'stx:goodies/sunit' }"
TestAsserter subclass:#TestCase
instanceVariableNames:'testSelector'
classVariableNames:''
poolDictionaries:''
category:'SUnit-Base'
!
TestCase class instanceVariableNames:'lastTestRunResultOrNil lastTestRunsPassedTests lastTestRunsFailedTests
lastTestRunsErrorTests'
"
No other class instance variables are inherited by this class.
"
!
TestCase comment:''
!
!TestCase class methodsFor:'initialization'!
initialize
ResumableTestFailure autoload
"
self initialize
"
! !
!TestCase class methodsFor:'instance creation'!
asTestCase
^ self
"Created: / 02-08-2011 / 09:12:13 / cg"
!
debug: aSymbol
^(self selector: aSymbol) debug
!
run: aSymbol
^(self selector: aSymbol) run
!
selector: aSymbol
^self new setTestSelector: aSymbol
!
suite
^self buildSuite
! !
!TestCase class methodsFor:'accessing'!
allTestSelectors
| answer pivotClass lookupRoot |
answer := Set withAll: self testSelectors.
self shouldInheritSelectors ifTrue:
[pivotClass := self.
lookupRoot := self lookupHierarchyRoot.
[pivotClass == lookupRoot] whileFalse:
[pivotClass := pivotClass superclass.
answer addAll: pivotClass testSelectors]].
^answer asSortedCollection asOrderedCollection
!
forgetLastTestRunResult
lastTestRunResultOrNil ~~ nil ifTrue:[
lastTestRunResultOrNil := nil.
Smalltalk changed:#lastTestRunResult with:(Array with:self with:nil).
self changed:#lastTestRunResult.
]
"Modified: / 06-08-2006 / 11:40:07 / cg"
!
isTestSelector:aSelector
^aSelector notNil and:[aSelector startsWith:'test']
"Created: / 06-08-2006 / 11:46:17 / cg"
"Modified: / 05-12-2009 / 18:50:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 02-08-2011 / 17:46:51 / cg"
!
lastTestRunResult
| result |
result := TestResult new.
lastTestRunsPassedTests ? #() do:
[:selector|result passed add: (self selector: selector)].
lastTestRunsFailedTests ? #() do:
[:selector|result failures add: (self selector: selector)].
lastTestRunsErrorTests ? #() do:
[:selector|result errors add: (self selector: selector)].
"Created: / 15-03-2010 / 19:12:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
lastTestRunResultOrNil
^ lastTestRunResultOrNil
!
lookupHierarchyRoot
^TestCase
!
rememberErrorTest:selector
| emitChange |
lastTestRunsErrorTests isNil ifTrue:[
lastTestRunsErrorTests := Set new.
].
emitChange := (self removeSelector: selector from: lastTestRunsPassedTests).
emitChange := (self removeSelector: selector from: lastTestRunsFailedTests) or:[emitChange].
emitChange := (self addSelector: selector to: lastTestRunsErrorTests) or:[emitChange].
emitChange ifTrue:[self lastTestRunResultChanged: selector].
self rememberFailedTestRun
"Modified: / 06-08-2006 / 11:01:08 / cg"
"Created: / 15-03-2010 / 19:16:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
rememberFailedTest:selector
| emitChange |
lastTestRunsFailedTests isNil ifTrue:[
lastTestRunsFailedTests := Set new.
].
emitChange := (self removeSelector: selector from: lastTestRunsPassedTests).
emitChange := (self removeSelector: selector from: lastTestRunsErrorTests) or:[emitChange].
emitChange := (self addSelector: selector to: lastTestRunsFailedTests) or:[emitChange].
emitChange ifTrue:[self lastTestRunResultChanged: selector].
self rememberFailedTestRun
"Modified: / 06-08-2006 / 11:01:08 / cg"
"Modified: / 15-03-2010 / 19:15:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
rememberFailedTestRun
lastTestRunResultOrNil ~~ false ifTrue:[
lastTestRunResultOrNil := false.
Smalltalk changed:#lastTestRunResult with:(Array with:self with:nil).
self changed:#lastTestRunResult.
]
"Modified: / 06-08-2006 / 11:00:42 / cg"
!
rememberFailedTestRunWithResult:result
self rememberFailedTestRun.
self rememberFailedTestsFromResult:result.
"Modified: / 05-08-2006 / 12:45:19 / cg"
!
rememberFailedTestsFromResult:result
(result failures union:result errors) do:[:eachFailedTest |
self rememberFailedTest:(eachFailedTest selector).
].
"Created: / 05-08-2006 / 12:45:01 / cg"
"Modified: / 06-08-2006 / 10:54:31 / cg"
!
rememberPassedTest:selector
| emitChange |
lastTestRunsPassedTests isNil ifTrue:[
lastTestRunsPassedTests := Set new.
].
emitChange := (self removeSelector: selector from: lastTestRunsFailedTests).
emitChange := (self removeSelector: selector from: lastTestRunsErrorTests) or:[emitChange].
emitChange := (self addSelector: selector to: lastTestRunsPassedTests) or:[emitChange].
emitChange ifTrue:[self lastTestRunResultChanged: selector].
self rememberPassedTestRun
"Modified: / 06-08-2006 / 11:01:08 / cg"
"Modified: / 15-03-2010 / 19:15:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
rememberPassedTestRun
lastTestRunResultOrNil ~~ true ifTrue:[
lastTestRunResultOrNil := true.
"/lastTestRunsFailedTests := nil.
Smalltalk changed:#lastTestRunResult with:(Array with:self with:nil).
self changed:#lastTestRunResult.
]
"Modified: / 06-08-2006 / 11:01:22 / cg"
"Modified: / 15-03-2010 / 18:22:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
rememberPassedTestsFromResult:result
(result passed) do:[:eachPassedTest |
self rememberPassedTest:(eachPassedTest selector).
].
"Created: / 06-08-2006 / 10:29:47 / cg"
"Modified: / 06-08-2006 / 11:42:01 / cg"
!
resources
^#()
!
shouldFork
^false
"Created: / 13-06-2011 / 16:46:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
sunitVersion
^'4.0'
!
testSelectorError:selector
^ lastTestRunsErrorTests notNil and:[lastTestRunsErrorTests includes:selector]
"Created: / 15-03-2010 / 19:44:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
testSelectorFailed:selector
^ (lastTestRunsFailedTests notNil and:[lastTestRunsFailedTests includes:selector]) or:
[lastTestRunsErrorTests notNil and:[lastTestRunsErrorTests includes:selector]]
"Modified: / 15-03-2010 / 19:44:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
testSelectorPassed:selector
^ lastTestRunsPassedTests notNil and:[lastTestRunsPassedTests includes:selector]
"Created: / 15-03-2010 / 17:58:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestCase class methodsFor:'building suites'!
buildSuite
| suite |
^self isAbstract
ifTrue:
[suite := self suiteClass named: self name asString.
self allSubclasses
do: [:each | each isAbstract ifFalse: [suite addTest: each buildSuiteFromSelectors]].
suite]
ifFalse: [self buildSuiteFromSelectors]
!
buildSuiteFromMethods: testMethods
^testMethods
inject: (self suiteClass named: self name asString)
into: [:suite :selector |
suite
addTest: (self selector: selector);
yourself]
!
buildSuiteFromSelectors
^self buildSuiteFromMethods: self allTestSelectors
!
suiteClass
^TestSuite
! !
!TestCase class methodsFor:'converting'!
asTestCase
^self
"Created: / 02-08-2011 / 13:08:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestCase class methodsFor:'misc ui support'!
iconInBrowserSymbol
<resource: #programImage>
|lastResult|
self theNonMetaclass isAbstract ifTrue:[^ super iconInBrowserSymbol].
lastResult := self lastTestRunResultOrNil.
lastResult == true ifTrue:[
^ #testCasePassedIcon
].
lastResult == false ifTrue:[
^ #testCaseFailedIcon
].
^ #testCaseClassIcon
! !
!TestCase class methodsFor:'private'!
addSelector: selector to: collection
"Adds given selector from collection. Answers
true iff selector was really added"
^(collection includes: selector)
ifTrue:[false]
ifFalse:[collection add: selector. true]
"Created: / 15-03-2010 / 18:06:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 21-04-2010 / 23:19:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
lastTestRunResultChanged: selector
Smalltalk changed:#lastTestRunResult with:(Array with:self with:selector).
self changed:#lastTestRunResult with:selector.
"Created: / 15-03-2010 / 19:15:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
removeSelector: selector from: collection
"Removes given selector from collection. Answers
true iff selector was really removed"
collection ifNil:[^false]." trivial case "
^(collection includes: selector)
ifTrue:[collection remove: selector. true]
ifFalse:[false]
"Created: / 15-03-2010 / 18:05:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
testSelectors
"The API method is allTestSelectors which now includes #shouldInheritSelectors and so handles all cases. Unlike that method, this does not guarantee to return a sorted ordered collection."
^self sunitSelectors select: [:each | 'test*' sunitMatch: each]
! !
!TestCase class methodsFor:'quick testing'!
assert: aBoolean
^ self new assert: aBoolean
"
TestCase assert: true
"
!
should: aBlock raise: anError
^ self new should: aBlock raise: anError
"
TestCase should:[ self error ] raise: Error
"
! !
!TestCase class methodsFor:'testing'!
isAbstract
"Override to true if a TestCase subclass is Abstract and should not have
TestCase instances built from it"
^self sunitName = #TestCase
!
isTestCaseLike
^true
"Created: / 06-03-2011 / 00:16:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
rememberResult:result
result hasPassed ifTrue:[
self rememberPassedTestRun
] ifFalse:[
self rememberFailedTestRunWithResult:result
].
"Created: / 05-08-2006 / 12:33:08 / cg"
!
runTests
|result|
result := self suite run.
self rememberResult:result.
^ result
"Modified: / 30-07-2011 / 09:26:11 / cg"
!
shouldInheritSelectors
"I should inherit from an Abstract superclass but not from a concrete one by default, unless I have no testSelectors in which case I must be expecting to inherit them from my superclass. If a test case with selectors wants to inherit selectors from a concrete superclass, override this to true in that subclass."
^self ~~ self lookupHierarchyRoot
and: [self superclass isAbstract
or: [self testSelectors isEmpty]]
! !
!TestCase methodsFor:'accessing'!
resources
"We give TestCase this instance-side method so that methods polymorphic with TestSuite can be code-identical. Having this instance-side method also helps when writing tests of resource behaviour. Except for such tests, it is rare to override this method and should not be done without thought. If there were a good reason why a single test case needed to share tests requiring different resources, it might be legitimate."
^self class resources
!
selector
^testSelector
!
shouldFork
^self class shouldFork
"Created: / 13-06-2011 / 16:45:43 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !
!TestCase methodsFor:'accessing & queries'!
unfinished
"indicates an unfinished test"
! !
!TestCase methodsFor:'assertions'!
assert:aBlock completesInSeconds:aNumber
"fail, if aBlock does not finish its work in aNumber seconds"
<resource: #skipInDebuggersWalkBack>
|done process semaphore|
done := false.
semaphore := Semaphore new.
process := [
aBlock value.
done := true.
semaphore signal
] fork.
semaphore waitWithTimeout: aNumber.
process terminate.
self assert: done
"
self new assert:[Delay waitForSeconds:2] completesInSeconds:1
"
"
self new assert:[Delay waitForSeconds:1] completesInSeconds:2
"
!
assert: aBoolean message:messageIfFailing
^self assert: aBoolean description: messageIfFailing
"Modified: / 05-12-2009 / 18:16:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
assertFalse:aBoolean
<resource: #skipInDebuggersWalkBack>
^ self assert:aBoolean not
!
assertFalse:aBoolean named:testName
<resource: #skipInDebuggersWalkBack>
^ self assert:aBoolean not
!
assertTrue:aBoolean
<resource: #skipInDebuggersWalkBack>
^ self assert:aBoolean
!
assertTrue:aBoolean named:testName
<resource: #skipInDebuggersWalkBack>
^ self assert:aBoolean
! !
!TestCase methodsFor:'dependencies'!
addDependentToHierachy: anObject
"an empty method. for Composite compability with TestSuite"
!
removeDependentFromHierachy: anObject
"an empty method. for Composite compability with TestSuite"
! !
!TestCase methodsFor:'deprecated'!
should: aBlock
self assert: aBlock value
!
should: aBlock description: aString
self assert: aBlock value description: aString
!
shouldnt: aBlock
self deny: aBlock value
!
shouldnt: aBlock description: aString
self deny: aBlock value description: aString
!
signalFailure: aString
TestResult failure sunitSignalWith: aString.
! !
!TestCase methodsFor:'printing'!
getTestName
^testSelector.
"Modified: / 05-12-2009 / 17:47:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
name
^ self class name.
!
printOn: aStream
aStream
nextPutAll: self class printString;
nextPutAll: '>>#';
nextPutAll: testSelector
! !
!TestCase methodsFor:'private'!
executeShould: aBlock inScopeOf: anExceptionalEvent
"/ ^[aBlock value.
"/ false] sunitOn: anExceptionalEvent
"/ do: [:ex | ex sunitExitWith: true]
"/ [[aBlock value]
"/ on: anExceptionalEvent
"/ do: [:ex | ^true]]
"/ on: TestResult exError
"/ do: [:ex | ^false].
[aBlock value]
on: anExceptionalEvent
do: [:ex | ^true].
^false.
!
performTest
startTime := Timestamp now.
[
self perform: testSelector sunitAsSymbol
] ensure:[
endTime := Timestamp now
].
"Modified: / 30-07-2011 / 10:08:55 / cg"
!
setTestSelector: aSymbol
testSelector := aSymbol
!
signalFailure:aString resumable:isResumable
"/ TestResult failure sunitSignalWith: aString
<resource: #skipInDebuggersWalkBack>
isResumable ifTrue:[
TestResult resumableFailure
raiseRequestWith:nil
errorString:aString
in:thisContext sender sender
] ifFalse:[
TestResult failure
raiseErrorString:aString
in:thisContext sender sender
].
"Modified: / 06-08-2006 / 22:55:55 / cg"
!
signalUnavailableResources
self resources do:[:res |
res isAvailable ifFalse:[
^ res signalInitializationError
]
].
! !
!TestCase methodsFor:'queries'!
isTestCase
^ true
!
isTestCaseLike
^ true
"Created: / 29-06-2011 / 20:37:57 / cg"
!
isTestSuite
^ false
! !
!TestCase methodsFor:'running'!
debug
[
(self class selector: testSelector) runCase.
self class rememberPassedTest: testSelector.
] sunitEnsure: [
TestResource resetResources: self resources
].
"Modified: / 07-07-2011 / 11:10:50 / jv"
"Modified: / 07-07-2011 / 11:34:08 / Jan Vrany <jan.vrant@fit.cvut,cz>"
!
debugAsFailure
| semaphore |
semaphore := Semaphore new.
[semaphore wait. TestResource resetResources: self resources] fork.
(self class selector: testSelector) runCaseAsFailure: semaphore.
!
debugUsing:aSymbol
self signalUnavailableResources.
[
"/ used to be:
"/ (self class selector:testSelector) perform:aSymbol
"/ which is bad for subclasses which need more arguments.
"/ why not use:
"/ self copy perform:aSymbol
"/ or even
"/ self perform:aSymbol
"/ (self class selector:testSelector) perform:aSymbol
self perform:aSymbol
] ensure:[
self resources do:[:each |
each reset
]
]
!
failureLog
^SUnitNameResolver class >> #defaultLogDevice
!
isLogging
"By default, we're not logging failures. If you override this in
a subclass, make sure that you override #failureLog"
^false
!
logFailure: aString
self isLogging ifTrue: [
self failureLog
cr;
nextPutAll: aString;
flush]
!
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;
performTest
"Modified: / 05-12-2009 / 18:40:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
run
^self run: TestResult new
"Modified: / 29-07-2011 / 12:07:57 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
run: aResult
^self run: aResult beforeEachDo: [:test :result|] afterEachDo: [:test :result|]
"Modified: / 29-07-2011 / 12:07:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
run: aResult afterEachDo:block2
^self run: aResult beforeEachDo: [:test :result|] afterEachDo:block2
"Modified: / 29-07-2011 / 12:07:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
run: aResult beforeEachDo:block1 afterEachDo:block2
^self run: aResult beforeEachDo:block1 afterEachDo:block2 resetResources: true
"Modified: / 29-07-2011 / 12:06:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
run: result beforeEachDo: before afterEachDo: after resetResources: reset
"Workhorse for running a testcase. If reset is true, then
the resources are reset, otherwise not"
"1. Execute before block"
"This code is ugly in Smalltalk/X but it is so because
it is more portable - numArgs in ANSI (?)"
before numArgs == 2 ifTrue:[
before value: self value: result
] ifFalse:[
before numArgs == 1 ifTrue:[
before value: self
] ifFalse:[
before value.
]
].
"2. Run the testcase"
reset ifTrue:[
[
result runCase: self
] sunitEnsure: [
TestResource resetResources: self resources
].
] ifFalse:[
result runCase: self
].
"3. Execute after block"
"This code is ugly in Smalltalk/X but it is so because
it is more portable - numArgs in ANSI (?)"
after numArgs == 2 ifTrue:[
after value: self value: result
] ifFalse:[
after numArgs == 1 ifTrue:[
after value: self
] ifFalse:[
after value.
]
].
^result
"Created: / 29-07-2011 / 12:04:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
"Modified: / 01-08-2011 / 10:22:09 / cg"
!
run: aResult beforeEachTestCaseDo:block1 afterEachTestCaseDo:block2
<resource: #obsolete>
self obsoleteMethodWarning: 'Use #run:beforeEachDo:afterEachDo: instead'.
^self run: aResult beforeEachDo:block1 afterEachDo:block2
"Modified: / 29-07-2011 / 12:06:15 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!
runCase
self resources do: [:each | each availableFor: self].
[
self setUp.
self performTest
] sunitEnsure: [
self tearDown
]
"Modified (format): / 05-07-2011 / 18:21:33 / cg"
!
runCaseAsFailure
self setUp.
[[self openDebuggerOnFailingTestMethod] ensure: [self tearDown]] fork
"Modified: / 21.6.2000 / 10:04:33 / Sames"
!
runCaseAsFailure: aSemaphore
[self resources do: [:each | each availableFor: self].
[self setUp.
self openDebuggerOnFailingTestMethod]
sunitEnsure: [self tearDown]]
sunitEnsure: [aSemaphore signal].
!
setUp
!
tearDown
! !
!TestCase class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/goodies/sunit/TestCase.st,v 1.69 2011-08-02 16:57:10 vrany Exp $'
!
version_CVS
^ '$Header: /cvs/stx/stx/goodies/sunit/TestCase.st,v 1.69 2011-08-02 16:57:10 vrany Exp $'
!
version_SVN
^ '§Id: TestCase.st 218 2011-06-13 15:45:06Z vranyj1 §'
! !
TestCase initialize!