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

Object subclass:#TestResult

	instanceVariableNames:'name timestamp failures errors passed'

	classVariableNames:''

	poolDictionaries:''

	category:'SUnit-Base'

!

TestResult comment:''

!

!TestResult class methodsFor:'instance creation'!

new

	^super new initialize

! !

!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 errors size

!

errors

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

	^errors

!

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 failures size

!

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 := Set new].

	^failures

!

name

    ^ name

!

name:aString

    name := aString.

!

passed

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

	^passed

!

passedCount

	^self passed size

!

runCount

	^self passedCount + self failureCount + self errorCount

!

tests

	^(OrderedCollection new: self runCount)

		addAll: self passed;

		addAll: self errors;

		addAll: self failures;

		yourself

!

timestamp

    ^ timestamp

!

timestamp:something

    timestamp := something.

! !

!TestResult methodsFor:'adding'!

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

        testcase class rememberErrorTest: testcase selector.

        ^self errors add: testcase

    "Modified: / 11-09-2010 / 17:19:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"

    "Created: / 03-08-2011 / 13:50:42 / 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'"

        testcase class rememberFailedTest: testcase selector.

        ^self failures add: testcase

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

!

addPass: testcase

        testcase class rememberPassedTest: testcase selector.

        ^self passed add: testcase

    "Modified: / 11-09-2010 / 17:19:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!TestResult methodsFor:'deprecated'!

correctCount

	"deprecated - use #passedCount"

	^self passedCount

! !

!TestResult methodsFor:'initialize-release'!

initialize

! !

!TestResult methodsFor:'printing'!

exceptionInfoStringFor:anException in:aTestCase

    "the following should be pretty portable;

     if not, comment the following, and uncomment the false

     to return nil (thats what you had before)"

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

    "false" 

    ifTrue:[

        ^ String streamContents:[:s |

            |con endReached|

            endReached := false.

            con := anException suspendedContext.

            [ con isNil or:[ endReached ]] whileFalse:[

                con printOn:s.

                s cr.

                ((con selector == aTestCase selector) 

                and:[ con receiver == aTestCase ]) ifTrue:[

                    endReached := true.

                ].

                con := con sender.

            ]

        ].

    ].

    ^ nil

    "Created: / 02-08-2011 / 18:10:46 / cg"

!

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 

    [ 

        self performCase:aTestCase.

        self addPass:aTestCase 

    ] sunitOn:self exceptions do: [:ex | 

        ex sunitAnnounce:aTestCase toResult:self 

    ].

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

    "Modified (format): / 03-08-2011 / 17:20:12 / 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 §'

! !