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

        ^ 'test*' match: aSelector

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

lastTestRunResultOrNil
    ^ lastTestRunResultOrNil
!

rememberFailedTest:selector
    lastTestRunsFailedTests isNil ifTrue:[
        lastTestRunsFailedTests := Set new.
    ].
    
    (lastTestRunsFailedTests includes:selector) not ifTrue:[
        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

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

!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:'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"
    
    <resource: #skipInDebuggersWalkBack>

    ^ self assert:(self executeShould:aBlock inScopeOf:anExceptionalEvent)
!

should: aBlock raise: anExceptionalEvent description: aString 
    <resource: #skipInDebuggersWalkBack>

    ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent)
            description: aString
!

shouldnt:aBlock 
    "fail, if the block does evaluate to true"
    
    <resource: #skipInDebuggersWalkBack>

    self deny:aBlock value
!

shouldnt: aBlock description: aString
    <resource: #skipInDebuggersWalkBack>

    self deny: aBlock value description: aString
!

shouldnt:aBlock raise:anExceptionalEvent 
    "fail, if the block does raise the given event"
    
    <resource: #skipInDebuggersWalkBack>

    ^ self 
        assert:(self executeShould:aBlock inScopeOf:anExceptionalEvent) not
!

shouldnt: aBlock raise: anExceptionalEvent description: aString 
    <resource: #skipInDebuggersWalkBack>

    ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not            description: aString
! !

!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:'printing'!

name
        ^ self class name.
!

printOn: aStream

"/        aStream
"/                nextPutAll: self class printString;
"/                nextPutAll: '>>#';
"/                nextPutAll: testSelector
                        
        aStream nextPutAll: self name.
        aStream nextPutAll: '>>'.
        testSelector printOn: aStream
!

testName
        ^ 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

        self perform: testSelector asSymbol
!

setTestSelector: aSymbol
	testSelector := aSymbol
			
!

signalFailure: aString

"/        TestResult failure sunitSignalWith: aString
    TestResult failure raiseErrorString:aString in:thisContext sender sender .
!

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
!

isTestSuite
    ^ false
! !

!TestCase methodsFor:'running'!

debug

"/        self signalUnavailableResources.
"/        [(self class selector: testSelector) runCase] 
"/                sunitEnsure: [self resources do: [:each | each reset]]
        self debugUsing:#runCase.
!

debugAsFailure
    |semaphore|

    self signalUnavailableResources.
    semaphore := Semaphore new.
    [
        semaphore wait.
        self resources do:[:each | 
            each reset
        ]
    ] fork.

    "/ used to be: 
    "/  (self class selector:testSelector) runCaseAsFailure:semaphore
    "/ 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) runCaseAsFailure:semaphore.
    self 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
!

run
	| result |
	result := TestResult new.
	self run: result.
	^result
			
!

run: aResult
	aResult runCase: self
			
!

run: aResult afterEachDo:block2
        aResult runCase: self.
        block2 value:self value:aResult.
!

run: aResult beforeEachDo:block1 afterEachDo:block2
        block1 value:self value:aResult.
        aResult runCase: self.
        block2 value:self value:aResult.
!

run: aResult beforeEachTestCaseDo:block1 afterEachTestCaseDo:block2
        block1 value:self value:aResult.
        aResult runCase: self.
        block2 value:self value:aResult.
!

runCase
    [
        self setUp.
        self performTest
    ] ensure:[
        Error ,  AbortOperationRequest
            handle:[:ex |
                ex signal ~~ AbortOperationRequest ifTrue:[
                    Transcript showCR:'Error during tearDown: "', ex description, '" - ignored'. 
                ]
            ]
            do:[ self tearDown ]
    ]
!

runCaseAsFailure
        self setUp.
        [[self openDebuggerOnFailingTestMethod] ensure: [self tearDown]] fork

    "Modified: / 21.6.2000 / 10:04:33 / Sames"
!

runCaseAsFailure: aSemaphore
        [self setUp.
        self openDebuggerOnFailingTestMethod] ensure: [
                self tearDown.
                aSemaphore signal]
!

setUp
			
!

tearDown
			
! !

!TestCase class methodsFor:'documentation'!

version
    ^ '$Header: /cvs/stx/stx/goodies/sunit/TestCase.st,v 1.49 2009-01-16 10:57:20 cg Exp $'
! !

TestCase initialize!