"{ Package: 'stx:goodies/sunit' }"

Object subclass:#TestCase

	instanceVariableNames:'testSelector'

	classVariableNames:''

	poolDictionaries:''

	category:'SUnit-Base'

!

TestCase class instanceVariableNames:'lastTestRunResultOrNil lastTestRunsFailedTests'

"

 No other class instance variables are inherited by this class.

"

!

TestCase comment:'A TestCase is a Command representing the future running of a test case. Create one with the class method #selector: aSymbol, passing the name of the method to be run when the test case runs.

When you discover a new fixture, subclass TestCase, declare instance variables for the objects in the fixture, override #setUp to initialize the variables, and possibly override# tearDown to deallocate any external resources allocated in #setUp.

When you are writing a test case method, send #assert: aBoolean when you want to check for an expected value. For example, you might say "self assert: socket isOpen" to test whether or not a socket is open at a point in a test.'

!

!TestCase class methodsFor:'initialization'!

initialize

    ResumableTestFailure autoload

    "

     self initialize

    "

! !

!TestCase class methodsFor:'instance creation'!

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

        ^ (self allSelectors select: [:each | self isTestSelector:each]) asOrderedCollection sort

    "Modified: / 06-08-2006 / 11:46:32 / cg"

!

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 ~= #testName 

        and:[aSelector startsWith: 'test']

    "Created: / 06-08-2006 / 11:46:17 / cg"

    "Modified: / 19-08-2009 / 14:42:58 / Jan Vrany <vranyj1@fel.cvut.cz>"

!

lastTestRunResultOrNil

    ^ lastTestRunResultOrNil

!

rememberFailedTest:selector

    lastTestRunsFailedTests isNil ifTrue:[

        lastTestRunsFailedTests := Set new.

    ].

    (lastTestRunsFailedTests includes:selector) ifFalse:[

        lastTestRunsFailedTests add:selector.

        Smalltalk changed:#lastTestRunResult with:(Array with:self with:selector).

        self changed:#lastTestRunResult with:selector.

    ].

    self rememberFailedTestRun

    "Modified: / 06-08-2006 / 11:01:08 / cg"

!

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

    lastTestRunsFailedTests notNil ifTrue:[

        (lastTestRunsFailedTests includes:selector) ifTrue:[

            lastTestRunsFailedTests remove:selector ifAbsent:nil.

            Smalltalk changed:#lastTestRunResult with:(Array with:self with:selector).

            self changed:#lastTestRunResult with:selector.

            lastTestRunsFailedTests isEmpty ifTrue:[

                lastTestRunsFailedTests := nil.

                self forgetLastTestRunResult.

            ].

        ].

    ].

    "Modified: / 06-08-2006 / 11:40:16 / cg"

!

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"

!

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

	^#()

!

sunitVersion

	^'3.1'

!

testSelectorFailed:selector

    ^ lastTestRunsFailedTests notNil and:[lastTestRunsFailedTests includes:selector]

!

testSelectors

    "the default here is all methods in a test*-category;

     this can, of course, be redefined in a testCase-class, which knows better"

    ^ (self selectors select: [:each | 'test*' match: each]) asOrderedCollection sort

    "Modified: / 24-04-2010 / 14:04:51 / cg"

!

testedClasses

    "for the browser and for coverage analysis:

     return a collection of classNames, which are tested by this testCase"

    ^ #()

! !

!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]

!

buildSuiteFromAllSelectors

	^self buildSuiteFromMethods: self allTestSelectors

!

buildSuiteFromLocalSelectors

	^self buildSuiteFromMethods: self testSelectors

!

buildSuiteFromMethods: testMethods

	^testMethods

		inject: (self suiteClass named: self name asString)

		into: [:suite :selector |

			suite

				addTest: (self selector: selector);

				yourself]

!

buildSuiteFromSelectors

	^self shouldInheritSelectors

		ifTrue: [self buildSuiteFromAllSelectors]

		ifFalse: [self buildSuiteFromLocalSelectors]

!

suiteClass

	^TestSuite

! !

!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:'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 == TestCase

!

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.

    "Modified: / 05-08-2006 / 12:33:20 / 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 superclass isAbstract

		or: [self testSelectors isEmpty]

"$QA Ignore:Sends system method(superclass)$"

! !

!TestCase methodsFor:'accessing'!

resources

	| allResources resourceQueue |

	allResources := Set new.

	resourceQueue := OrderedCollection new.

	resourceQueue addAll: self class resources.

	[resourceQueue isEmpty] whileFalse: [

		| next |

		next := resourceQueue removeFirst.

		allResources add: next.

		resourceQueue addAll: next resources].

	^allResources

!

selector

	^testSelector

! !

!TestCase methodsFor:'accessing & queries'!

unfinished

	"indicates an unfinished test"

! !

!TestCase methodsFor:'assertions'!

assert: aBoolean

    "fail, if the argument is not true"

    <resource: #skipInDebuggersWalkBack>

"/        aBoolean ifFalse: [self signalFailure: 'Assertion failed']

    self assert: aBoolean message:'Assertion failed'

!

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 description:aString 

    <resource: #skipInDebuggersWalkBack>

    aBoolean ifFalse:[

        self logFailure:aString.

        self signalFailure:aString resumable:true

    ]

    "Modified: / 06-08-2006 / 22:56:27 / cg"

!

assert:aBoolean description:aString resumable:resumableBoolean 

    <resource: #skipInDebuggersWalkBack>

    aBoolean ifFalse:[

        self logFailure:aString.

        self signalFailure:aString resumable:resumableBoolean

    ]

!

assert: aBoolean message:messageIfFailing

    "fail, if the argument is not true"

    <resource: #skipInDebuggersWalkBack>

    "check the testCase itself"

    (aBoolean isBoolean) ifFalse:[ self error:'non boolean assertion' ].

    aBoolean ifFalse: [self signalFailure: messageIfFailing resumable:true]

    "Modified: / 21-06-2000 / 10:00:05 / Sames"

    "Modified: / 06-08-2006 / 22:56:21 / cg"

!

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

!

deny:aBoolean 

    "fail, if the argument is not false"

    <resource: #skipInDebuggersWalkBack>

    self assert:aBoolean not

!

deny: aBoolean description: aString

    <resource: #skipInDebuggersWalkBack>

    self assert: aBoolean not description: aString

!

deny: aBoolean description: aString resumable: resumableBoolean 

    <resource: #skipInDebuggersWalkBack>

    self

            assert: aBoolean not

            description: aString

            resumable: resumableBoolean

!

should:aBlock 

    "fail, if the block does not evaluate to true"

    <resource: #skipInDebuggersWalkBack>

    self assert:aBlock value

!

should: aBlock description: aString

    <resource: #skipInDebuggersWalkBack>

    self assert: aBlock value description: aString

!

should:aBlock raise:anExceptionalEvent 

    "fail, if the block does not raise the given event"