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

Object subclass:#TestResult

	instanceVariableNames:'name timestamp failures errors passed outcome'

	classVariableNames:'DefaultClass'

	poolDictionaries:''

	category:'SUnit-Base'

!

TestResult comment:''

!

!TestResult class methodsFor:'documentation'!

documentation

"

    runInfoPerTest:

        will keep additional info for a testCase run:

            startTime, endTime, backtrace (if fail or error) and collectedStdout

"

! !

!TestResult class methodsFor:'instance creation'!

new

    self sunitName == #TestCase ifTrue:[

        ^ self defaultResultClass basicNew initialize.

    ] ifFalse:[

        ^ self basicNew initialize

    ].

    "

        TestResult new.

        TestResultForRunWithDebug new.

    "

    "Modified (comment): / 20-08-2011 / 17:34:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TestResult class methodsFor:'accessing'!

defaultResultClass

    DefaultClass notNil ifTrue:[^DefaultClass].

    ((Smalltalk respondsTo: #isSmalltalkX) and:[Smalltalk isSmalltalkX]) ifTrue:[

        DefaultClass := TestResultStX.

        ^DefaultClass

    ].

    "Add more dialects here, if you want..."

    "Default"

    DefaultClass := self.

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

! !

!TestResult class methodsFor:'exceptions'!

error

	^self exError

!

exError

	^SUnitNameResolver errorObject

!

failure

	^TestFailure

!

resumableFailure

	^ResumableTestFailure

!

signalErrorWith: aString

	self error sunitSignalWith: aString

!

signalFailureWith: aString

	self failure sunitSignalWith: aString

! !

!TestResult methodsFor:'accessing'!

defects

	^OrderedCollection new

		addAll: self errors;

		addAll: self failures; yourself

!

errorCount

        ^self errorOutcomes size

    "Modified: / 16-08-2011 / 15:58:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

errorOutcomes

    errors isNil ifTrue: [errors := OrderedCollection new].

    ^errors

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

!

errors

    errors isNil ifTrue: [^#()].

    ^errors collect:[:outcome|outcome testCase]

    "Modified: / 16-08-2011 / 15:54:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

exceptions

    "Returns a set of exceptions to be handled. Bu default,

     failure and generic error is handled. This method may

     be overriden by custom TestResult subclasses to add more.

     For example, a 'self halt' is not handled by default

     exceptions set"

    ^self class failure , self class error

    "Created: / 03-08-2011 / 14:11:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

failureCount

        ^self failureOutcomes size

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

!

failureOutcomes

    failures isNil ifTrue: [failures := Set new].

    ^failures

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

!

failures

        "We use a Set, not an OrderedCollection as #errors and #passed do, because a resumable test failure in a loop can raise many failures against the same test.  In current Sunit UIs, this could result in bizarre test count reporting (-27 tests run, and suchlike).  This will be reviewed."

    failures isNil ifTrue: [^#()].

    ^failures collect:[:outcome|outcome testCase]

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

!

name

    ^ name

!

name:aString

    name := aString.

!

outcomes

    ^OrderedCollection new

        addAll: failures;

        addAll: errors;

        addAll: passed;

        yourself

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

!

outcomesDo: aBlock

    failures notNil ifTrue:[failures do: aBlock].

    errors notNil ifTrue:[errors do: aBlock].

    passed notNil ifTrue:[passed do: aBlock].

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

!

passed

        passed isNil ifTrue: [

            "/ cg: exposed and added to (see TestRunnerEmbedded>>debug)

            passed := OrderedCollection new.

            ^ passed.

        ].

        ^passed collect:[:outcome|outcome testCase]

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

    "Modified: / 07-11-2011 / 11:19:57 / cg"

!

passedCount

        ^self passedOutcomes size

    "Modified: / 16-08-2011 / 15:58:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

passedOutcomes

    passed isNil ifTrue: [passed := OrderedCollection new].

    ^passed

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

!

runCount

	^self passedCount + self failureCount + self errorCount

!

testOutcomes

        ^(OrderedCollection new: self runCount)

                addAll: self passedOutcomes;

                addAll: self errorOutcomes;

                addAll: self failureOutcomes;

                yourself

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

!

tests

	^(OrderedCollection new: self runCount)

		addAll: self passed;

		addAll: self errors;

		addAll: self failures;

		yourself

!

timestamp

    ^ timestamp

!

timestamp:something

    timestamp := something.

! !

!TestResult methodsFor:'adding / removing'!

addError:testcase detail:detail 

    "Called when a test outcome is error. testCase 

     is the errorneous testcase, detail is platform

     specific object describing the error. Actually,

     on all platforms exept GemStone, detail is an instance

     of an exception that caused the error"

    "JV2011-08-03: TODO: Validate the comment above with GS,

     possibly change name to 'exception'"

    outcome result: #error.

    outcome remember.

    ^ self errorOutcomes add:outcome.

    "Created: / 03-08-2011 / 13:50:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 06-08-2011 / 09:46:41 / cg"

    "Modified: / 20-08-2011 / 12:46:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

addFailure:testcase detail:detail 

    "Called when a test fails. testCase is the failed 

     testcase, detail is platform specific object describing

     the failure. Actually, on all platforms exept GemStone,

     detail is an instance of an exception that caused the failure"

    "JV2011-08-03: TODO: Validate the comment above with GS,

     possibly change name to 'exception'"

     "Special handling here, because failures can be resumable"

    self failureOutcomes do:[:outcome | 

        outcome testCase = testcase ifTrue:[

            ^ self

        ].

    ].

    outcome result: #fail.

    outcome remember.

    ^ self failureOutcomes add: outcome

    "Created: / 03-08-2011 / 13:53:18 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 06-08-2011 / 09:55:17 / cg"

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

!

addPass:testCase 

    outcome result: #pass.

    outcome remember.

    ^ self passedOutcomes add: outcome

    "Modified: / 20-08-2011 / 12:44:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

remove: aTestCase

    "Removes an outcome for given testcase, if any.

    Use with care."

    | remover |

    remover := [:outcomes|

        | o |

        outcomes notNil ifTrue:[

            o := outcomes detect:[:each|each testCase == aTestCase] ifNone: [nil].

            o notNil ifTrue:[outcomes remove: o. ^self].

        ].

    ].

    remover value: errors.

    remover value: failures.

    remover value: passed.

    "Created: / 16-01-2012 / 20:36:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TestResult methodsFor:'deprecated'!

correctCount

	"deprecated - use #passedCount"

	^self passedCount

! !

!TestResult methodsFor:'initialize-release'!

initialize

! !

!TestResult methodsFor:'outcome'!

createOutcome

    ^TestCaseOutcome new.

    "Created: / 16-08-2011 / 17:14:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

rememberEndTime

    ^nil

    "Created: / 16-08-2011 / 17:31:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

rememberException:detail

    "Created: / 16-08-2011 / 17:35:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

rememberStartTime

    ^nil

    "Created: / 16-08-2011 / 17:31:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TestResult methodsFor:'printing'!

printOn: aStream

	aStream

		nextPutAll: self runCount printString;

		nextPutAll: ' run, ';

		nextPutAll: self correctCount printString;

		nextPutAll: ' passed, ';

		nextPutAll: self failureCount printString;

		nextPutAll: ' failed, ';

		nextPutAll: self errorCount printString;

		nextPutAll: ' error'.

	self errorCount ~= 1

		ifTrue: [aStream nextPut: $s]

! !

!TestResult methodsFor:'running'!

performCase:aTestCase 

    "Actually performs the case. The TestCase>>runCase itself calls

     a setUp/tearDown methods. The possible error/failure is handled

     in TestResult>>runCase:. This method is meant to be overriden by

     custom TestResult subclasses."

    aTestCase runCase.

    "Modified: / 02-08-2011 / 18:10:09 / cg"

    "Created: / 03-08-2011 / 14:02:14 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

runCase:aTestCase 

    "run a testcase, catching exceptions"

    self runCase:aTestCase debugged:false

    "Modified: / 16-08-2011 / 17:35:37 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Modified: / 21-08-2011 / 17:48:28 / cg"

!

runCase:aTestCase debugged:debugged

    "run a testcase, debugging exceptions"

    [

        [ 

            outcome := self createOutcome.

            outcome testCase: aTestCase.

            self rememberStartTime.

            self performCase:aTestCase.

            self rememberEndTime.

            self addPass:aTestCase.

            outcome := nil.

        ] sunitOn:self exceptions do: [:ex |

            self rememberEndTime.

            self rememberException: ex.

            debugged ifTrue:[ ex reject ].

            ex sunitAnnounce:aTestCase toResult:self.

        ].

    ] sunitOn: self exceptions do:[:ex|

        self remove: aTestCase.

        debugged ifTrue:[ ex reject ].

        ex sunitAnnounce:aTestCase toResult:self.

    ]

    "Created: / 21-08-2011 / 17:48:19 / cg"

    "Modified: / 16-01-2012 / 20:37:52 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TestResult methodsFor:'testing'!

hasErrors

	^self errors size > 0

!

hasFailures

	^self failures size > 0

!

hasPassed

	^self hasErrors not and: [self hasFailures not]

!

isError: aTestCase

	^self errors includes: aTestCase

!

isFailure: aTestCase

	^self failures includes: aTestCase

!

isPassed: aTestCase

	^self passed includes: aTestCase

! !

!TestResult class methodsFor:'documentation'!

version

!

version_CVS

!

version_SVN

    ^ '§Id: TestResult.st 205 2010-09-11 15:23:01Z vranyj1 §'

! !