amber/st/SUnit.st

Smalltalk current createPackage: 'SUnit' properties: #{}!
Object subclass: #ResultAnnouncement
	instanceVariableNames: 'result'
	package: 'SUnit'!

!ResultAnnouncement methodsFor: 'accessing'!

result
	^result
!

result: aTestResult
	result := aTestResult
! !

Object subclass: #RunningTestContext
	instanceVariableNames: 'finished testCase result'
	package: 'SUnit'!

!RunningTestContext methodsFor: 'accessing'!

finished: aBlock
	finished := aBlock
!

result: aTestResult
	result := aTestResult
!

testCase: aTestCase
	testCase := aTestCase
! !

!RunningTestContext methodsFor: 'private'!

exception: anException do: aBlock
	aBlock value
!

executeWithCleanup: aBlock
	| failed |
    testCase context: self.
    [ failed := true. aBlock value. failed := false ] ensure: [
        testCase context: nil.
        (failed and: [testCase isAsync]) ifTrue: [ testCase finished ].
        testCase isAsync ifFalse: [ testCase tearDown ]
    ]
! !

!RunningTestContext methodsFor: 'running'!

execute: aBlock
    [[[ self executeWithCleanup: aBlock ]
    on: TestFailure do: [:ex | self exception: ex do: [ result addFailure: testCase]]]
    on: Error do: [:ex | self exception: ex do: [ result addError: testCase]]]
    ensure: [ testCase isAsync ifFalse: [ result increaseRuns. finished value ]]
!

start
	self execute: [ testCase setUp. testCase performTest ]
! !

!RunningTestContext class methodsFor: 'instance creation'!

testCase: aTestCase result: aTestResult finished: aBlock
	^self new
        testCase: aTestCase;
        result: aTestResult;
        finished: aBlock;
        yourself
! !

RunningTestContext subclass: #ErroringTestContext
	instanceVariableNames: ''
	package: 'SUnit'!

!ErroringTestContext methodsFor: 'private'!

exception: anException do: aBlock
	anException signal
! !

!ErroringTestContext class methodsFor: 'instance creation'!

testCase: aTestCase
	^self
        testCase: aTestCase
        result: TestResult new
        finished: []
! !

Object subclass: #TestCase
	instanceVariableNames: 'testSelector asyncTimeout context'
	package: 'SUnit'!

!TestCase methodsFor: 'accessing'!

context: aRunningTestContext
	context := aRunningTestContext
!

selector
	^testSelector
!

setTestSelector: aSelector
	testSelector := aSelector
! !

!TestCase methodsFor: 'async'!

async: aBlock
	| c |
	self mustBeAsync: '#async'.
    c := context.
    ^[ self isAsync ifTrue: [ c execute: aBlock ]]
!

finished
	self mustBeAsync: '#finished'.
	asyncTimeout := nil
!

graceTime: millis
	asyncTimeout ifNotNil: [ asyncTimeout clearTimeout ].
	asyncTimeout := true. "to allow async:"
	asyncTimeout :=
		(self async: [ self assert: false description: 'SUnit grace time exhausted' ])
        valueWithTimeout: millis
!

isAsync
	^asyncTimeout notNil
!

mustBeAsync: aString
	self isAsync ifFalse: [ self error: aString, ' used without prior #graceTime:' ]
! !

!TestCase methodsFor: 'private'!

signalFailure: aString
	TestFailure new
		messageText: aString;
		signal
! !

!TestCase methodsFor: 'running'!

performTest
	asyncTimeout := nil.
	self perform: self selector
!

runCase
	"Runs a test case in isolated context, leaking all errors."

	(ErroringTestContext testCase: self) start
!

setUp
!

tearDown
! !

!TestCase methodsFor: 'testing'!

assert: aBoolean
	self assert: aBoolean description: 'Assertion failed'
!

assert: aBoolean description: aString
	aBoolean ifFalse: [self signalFailure: aString]
!

assert: expected equals: actual
	^ self assert: (expected = actual) description: 'Expected: ', expected asString, ' but was: ', actual asString
!

deny: aBoolean
	self assert: aBoolean not
!

should: aBlock
	self assert: aBlock value
!

should: aBlock raise: anExceptionClass
	self assert: ([aBlock value. false] 
		on: anExceptionClass 
		do: [:ex | true])
!

shouldnt: aBlock raise: anExceptionClass
	self assert: ([aBlock value. true] 
		on: anExceptionClass 
		do: [:ex | false])
! !

!TestCase class methodsFor: 'accessing'!

allTestSelectors
	| selectors |
	selectors := self testSelectors.
	self shouldInheritSelectors ifTrue: [
		selectors addAll: self superclass allTestSelectors].
	^selectors
!

buildSuite
	^self allTestSelectors collect: [:each | self selector: each]
!

lookupHierarchyRoot
	^TestCase
!

selector: aSelector
	^self new
		setTestSelector: aSelector;
		yourself
!

testSelectors
	^self methodDictionary keys select: [:each | each match: '^test']
! !

!TestCase class methodsFor: 'testing'!

isAbstract
	^ self name = 'TestCase'
!

shouldInheritSelectors
	^self ~= self lookupHierarchyRoot
! !

Error subclass: #TestFailure
	instanceVariableNames: ''
	package: 'SUnit'!

Object subclass: #TestResult
	instanceVariableNames: 'timestamp runs errors failures total'
	package: 'SUnit'!

!TestResult methodsFor: 'accessing'!

addError: anError
	self errors add: anError
!

addFailure: aFailure
	self failures add: aFailure
!

errors
	^errors
!

failures
	^failures
!

increaseRuns
	runs := runs + 1
!

runs
	^runs
!

status
	^self errors isEmpty 
		ifTrue: [
			self failures isEmpty 
				ifTrue: ['success']
				ifFalse: ['failure']]
		ifFalse: ['error']
!

timestamp
	^timestamp
!

total
	^total
!

total: aNumber
	total := aNumber
! !

!TestResult methodsFor: 'initialization'!

initialize
	super initialize.
	timestamp := Date now.
	runs := 0.
	errors := Array new.
	failures := Array new.
	total := 0
! !

Object subclass: #TestSuiteRunner
	instanceVariableNames: 'suite result announcer runNextTest'
	package: 'SUnit'!

!TestSuiteRunner methodsFor: 'accessing'!

announcer
	^announcer
!

result
	^result
!

suite: aCollection
	suite := aCollection
! !

!TestSuiteRunner methodsFor: 'actions'!

resume
	runNextTest fork.
    announcer announce: (ResultAnnouncement new result: result)
!

run
	result total: suite size.
	self resume
! !

!TestSuiteRunner methodsFor: 'initialization'!

initialize
	super initialize.
	announcer := Announcer new.
    result := TestResult new.
    runNextTest := [ | runs | runs := result runs. runs < result total ifTrue: [ (self contextOf: runs + 1) start ]].
! !

!TestSuiteRunner methodsFor: 'private'!

contextOf: anInteger
   	^RunningTestContext testCase: (suite at: anInteger) result: result finished: [ self resume ]
! !

!TestSuiteRunner class methodsFor: 'instance creation'!

new
	self shouldNotImplement
!

on: aCollection
	^super new suite: aCollection
! !