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

TestAsserter subclass:#TestCase

	instanceVariableNames:'testSelector'

	classVariableNames:''

	poolDictionaries:''

	category:'SUnit-Base'

!

"

 No other class instance variables are inherited by this class.

"

!

!TestCase class methodsFor:'initialization'!

initialize

    ResumableTestFailure autoload

    "

     self initialize

    "

!

postAutoload

    self projectDefinitionClass loadExtensions

! !

!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 superclass.

        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"

!

!

lookupHierarchyRoot

        ^TestCase

!

    ].

!

!

resources

        ^#()

!

shouldFork

    ^false

    "Created: / 13-06-2011 / 16:46:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

sunitVersion

        ^'4.0'

!

testSelectorError:selector

    "Created: / 15-03-2010 / 19:44:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

testSelectorFailed:selector

!

testSelectorPassed: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:'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

    "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>"

!

testCount

    ^1

    "Created: / 04-08-2011 / 13:03:25 / 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

!