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

"{ NameSpace: Smalltalk }"

TestAsserter subclass:#TestCase

	instanceVariableNames:'testSelector'

	classVariableNames:''

	poolDictionaries:''

	category:'SUnit-Base'

!

TestCase class instanceVariableNames:'lastOutcomes'

"

 No other class instance variables are inherited by this class.

"

!

!TestCase class methodsFor:'initialization'!

flushAll

    "Flush all remembered outcomes in all testcases"

    self withAllSubclassesDo:[:cls|

	cls flushRememberedOutcomes

    ]

    "Created: / 17-11-2011 / 19:18:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

flushRememberedOutcomes

    "Flushes all remembered outcomes for the receiver"

    | outcomes |

    lastOutcomes isNil ifTrue:[^self].

    outcomes := lastOutcomes.

    lastOutcomes := nil.

    outcomes do:[:outcome|

	self lastTestRunResultChanged: outcome selector.

    ]

    "Created: / 17-11-2011 / 19:17:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

initialize

    ResumableTestFailure autoload

    "

     self initialize

    "

!

postAutoload

    |pd|

    (pd := self projectDefinitionClass) notNil ifTrue:[

	pd loadExtensions

    ]

    "Modified: / 02-11-2011 / 15:44:58 / sr"

! !

!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:[

	    answer addAll: pivotClass testSelectors.

	    pivotClass := pivotClass superclass.

	]

    ].

    ^answer asSortedCollection asOrderedCollection

    "Modified: / 21-08-2011 / 15:06:11 / cg"

!

forgetLastTestRunResult

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

    self changed:#lastTestRunResult.

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

    "Modified: / 20-08-2011 / 15:10:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

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"

!

lastTestRunResultOrNil

    "Returns a state (TestResult stateXXX), depending

     on the state of the tests:

	statePass if all tests passed,

	stateError if any error,

	stateFail if any fail,

     or nil if never run

    "

    |anyFail|

    lastOutcomes isNil ifTrue:[^nil].

    lastOutcomes size ~= self testSelectors size ifTrue:[^nil].

    anyFail := false.

    lastOutcomes do:[:outcome|

	outcome result == (TestResult stateError) ifTrue:[

	    ^ TestResult stateError

	].

	outcome result == (TestResult stateFail) ifTrue:[

	    anyFail := true

	].

    ].

    anyFail ifTrue:[ ^ TestResult stateFail ].

    ^ TestResult statePass

    "Modified: / 20-08-2011 / 14:59:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

lookupHierarchyRoot

	^TestCase

!

rememberOutcome: thisOutcome

    |thisTestCase someOtherOutcome someOtherTestCase|

    thisTestCase := thisOutcome testCase.

    lastOutcomes isNil ifTrue:[

	lastOutcomes := OrderedCollection new.

    ].

    "Not a nice code, but portable (what: doWithIndex: is not portable?)"

    1 to: lastOutcomes size do:[:i|

	someOtherOutcome := lastOutcomes at: i.

	someOtherTestCase := someOtherOutcome testCase.

	"/ compare by classes name - in case it got redefined

	(someOtherTestCase selector == thisTestCase selector

	and: [someOtherTestCase class name = thisTestCase class name]) ifTrue:[

	    "remember; for the timestamp and other info"

	    lastOutcomes at: i put: thisOutcome.

	    someOtherOutcome result ~= thisOutcome result ifTrue:[

		"but only send out change notification to browser if state has changed"

		self lastTestRunResultChanged: thisOutcome selector.

	    ].

	    ^self.

	].

    ].

    lastOutcomes add: thisOutcome.

    self lastTestRunResultChanged: thisOutcome selector.

    ^self

    "Created: / 20-08-2011 / 12:43:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 04-06-2012 / 16:19:07 / cg"

!

rememberedOutcomeFor: selector

    lastOutcomes isNil ifTrue:[^nil].

    ^lastOutcomes

	detect: [:outcome| outcome testCase selector == selector]

	ifNone:[nil].

    "Created: / 20-08-2011 / 14:27:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

resources

	^#()

!

shouldFork

    ^false

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

!

sunitVersion

	^'4.0'

!

testSelector:selector result: result

    "return true, if the last run of this test had the outcome result"

    lastOutcomes isNil ifTrue:[^false].

    ^ lastOutcomes

	contains:[:any|

	    any testCase class name = self name

	    and:[any testCase selector == selector

	    and:[any result == result]]

	]

    "Created: / 20-08-2011 / 16:15:30 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 04-06-2012 / 16:12:17 / cg"

!

testSelectorError:selector

    "return true, if the last run of this test failed"

    ^self testSelector: selector result: (TestResult stateError)

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

!

testSelectorFailed:selector

    "return true, if the last run of this test failed"

    ^self testSelector: selector result: (TestResult stateFail)

    "Modified: / 20-08-2011 / 16:16:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

testSelectorPassed:selector

    "return true, if the last run of this test passed"

   ^self testSelector: selector result: (TestResult statePass)

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

!

testSelectorSkipped:selector

    "return true, if the last run of this test was skipped"

   ^self testSelector: selector result: (TestResult stateSkip)

    "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 notNil ifTrue:[

	lastResult == TestResult statePass ifTrue:[

	    ^ #testCasePassedIcon

	].

	lastResult == TestResult stateFail ifTrue:[

	    ^ #testCaseFailedIcon

	].

	lastResult == TestResult stateError ifTrue:[

	    ^ #testCaseErrorIcon

	].

    ].

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

!

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

coveredClassNames

    "should be redefined to return a collection of classes which are tested by

     These classes can be instrumented for coverage analysis,

    ^ #()

    "Created: / 06-07-2011 / 21:27:03 / cg"

!

coveredClasses

     These classes can be instrumented for coverage analysis,

    self coveredPackageNames notNil ifTrue:[

        ^ self coveredPackageNames 

                    collectAll:[:eachPackage | Smalltalk allClassesInPackage:eachPackage].

    ].

    ^ self coveredClassNames collect:[:each | Smalltalk classNamed:each]

!

coveredPackageNames

    "redefine this in a concrete testCase class to return non-nil,

     to return a collection of packages which are tested by this suite/case.

     If not redefined, coveredClassNames should be redefined.

     These classes can be instrumented for coverage analysis,

    ^ nil

! !

!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 should:[ 22 ] 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 outcomesDo:[:outcome|self rememberOutcome: outcome].

    "Created: / 05-08-2006 / 12:33:08 / cg"

    "Modified: / 20-08-2011 / 14:02:58 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

runTests

    ^self suite run

    "Modified: / 30-07-2011 / 09:26:11 / cg"

    "Modified: / 20-08-2011 / 16:14:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

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

!

shouldSkip

    "Returns true, if this testcase should be skipped when a testsuite is run.

     This inly a hint, a test runner is not obliged to respect return value.

     Currently, the only user is stx/goodies/builder/reports"

    | method |