"

COPYRIGHT (c) 2022 LabWare

"

"{ 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:'documentation'!

copyright

"

COPYRIGHT (c) 2022 LabWare

"

! !

!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 := answer asOrderedCollection.

    answer sort.

    ^ answer 

    "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:['test*' sunitMatch: aSelector]

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

    "Modified: / 01-09-2022 / 21:51:43 / Jan Vrany <jan.vrany@labware.com>"

!

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    

     thisTestCaseSelector thisTestCaseClassName|

    thisTestCase := thisOutcome testCase.

    thisTestCaseSelector := thisTestCase selector.

    thisTestCaseClassName := thisTestCase class name.

    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 == thisTestCaseSelector

        and: [someOtherTestCase class name = thisTestCaseClassName]) 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|

            |tc|

            (tc := any testCase) class name = self name

            and:[tc 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>"

!

testSelectorsWithLastOutcomes

    lastOutcomes isNil ifTrue:[^#()].

    ^lastOutcomes collect:[:outcome| outcome testCase selector] as:Set

! !

!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

    "the browser will use this as index into the toolbariconlibrary"

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

    |selectors|

    selectors := self sunitSelectors 

                    select: [:each | self isTestSelector: each].

    selectors := selectors asOrderedCollection.

    selectors sort.

    ^ selectors

    "Modified: / 01-09-2022 / 21:50:16 / Jan Vrany <jan.vrany@labware.com>"

! !

!TestCase class methodsFor:'queries'!

coveredClassNames

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

     this suite/case. 

     If not redefined, coveredPackageNames should be.

     These classes can be instrumented for coverage analysis,

     before running the suite to provide coverage analysis/report"

    ^ #()

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

!

coveredClasses

    "return a collection of classes which are tested by this suite/case.

     Do not redefine this; redefine either coveredClassNames or

     coveredPackageNames 

     (these return names, to avoid creating

     a package dependecy due to the class references)

     These classes can be instrumented for coverage analysis,

     before running the suite to provide coverage analysis/report"

    |names|

    (names := self coveredPackageNames) notEmptyOrNil ifTrue:[

        ^ names 

            collectAll:[:eachPackageOrPattern |

                eachPackageOrPattern includesMatchCharacters ifTrue:[

                    Smalltalk allClassesForWhich:[:cls | (cls package ?'') matches:eachPackageOrPattern].

                ] ifFalse:[    

                    Smalltalk allClassesInPackage:eachPackageOrPattern

                ]

        ].

    ].

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

     The package names may be glob patterns.

     These classes can be instrumented for coverage analysis,

     before running the suite to provide coverage analysis/report"

    ^ nil

!

isAbstract

        "Override to true if a TestCase subclass is Abstract and should not have

        TestCase instances built from it"

        ^self == TestCase

! !

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

run

    self suite run

    "

     SOAP::XeXMLTests run

    "

! !

!TestCase class methodsFor:'testing'!

isTestCaseLike

    ^true

    "Created: / 06-03-2011 / 00:16:06 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!