Object subclass: #TestCase instanceVariableNames: 'selector ' classVariableNames: 'FailedCheckSignal ' poolDictionaries: '' category: 'Testing Framework'! !TestCase methodsFor: 'set up'! setUp "Run whatever code you need to get ready for the test to run."! tearDown "Release whatever resources you used for the test."! ! !TestCase methodsFor: 'running'! performTest self perform: selector! run self setUp. [self performTest] valueNowOrOnUnwindDo: [self tearDown]! run: aTestResult self setUp. [self errorException handle: [:exception | aTestResult error: exception in: self] do: [self testFailedException handle: [:exception | aTestResult failure: exception in: self] do: [self performTest]]] valueNowOrOnUnwindDo: [self tearDown]! ! !TestCase methodsFor: 'checking'! should: aBlock aBlock value ifFalse: [self testFailedException raise]! should: aBlock raise: anException anException handle: [:ex | ^self] do: aBlock. self testFailedException raiseWith: 'Should have raised ' , anException printString! shouldnt: aBlock aBlock value ifTrue: [self testFailedException raise]! ! !TestCase methodsFor: 'printing'! printOn: aStream aStream nextPutAll: 'Test case '. self class printOn: aStream. aStream nextPutAll: '>>'; nextPutAll: selector! ! !TestCase methodsFor: 'private'! errorException ^self errorSignal! setSelector: aSymbol selector := aSymbol! testFailedException FailedCheckSignal isNil ifTrue: [FailedCheckSignal := (self errorSignal newSignal) notifierString: 'Check failed - '; nameClass: self message: #checkSignal]. ^FailedCheckSignal! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestCase class instanceVariableNames: ''! !TestCase class methodsFor: 'instance creation'! selector: aSymbol ^self new setSelector: aSymbol! ! Object subclass: #TestFailure instanceVariableNames: 'testCase exception ' classVariableNames: '' poolDictionaries: '' category: 'Testing Framework'! !TestFailure methodsFor: 'printing'! printOn: aStream testCase printOn: aStream. aStream nextPutAll: ' failed because of '. exception printOn: aStream! ! !TestFailure methodsFor: 'private'! setTestCase: aTestCase exception: anException testCase := aTestCase. exception := anException! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestFailure class instanceVariableNames: ''! !TestFailure class methodsFor: 'instance creation'! testCase: aTestCase exception: anException ^self new setTestCase: aTestCase exception: anException! ! Object subclass: #TestSuite instanceVariableNames: 'name testCases ' classVariableNames: '' poolDictionaries: '' category: 'Testing Framework'! !TestSuite methodsFor: 'accessing'! addTestCase: aTestCase testCases add: aTestCase! addTestCases: aCollection aCollection do: [:each | self addTestCase: each]! name ^name! ! !TestSuite methodsFor: 'running'! run | result | result := self defaultTestResult. result start. self run: result. result stop. ^result! run: aTestResult testCases do: [:each | each run: aTestResult]! ! !TestSuite methodsFor: 'private'! defaultTestResult ^self defaultTestResultClass test: self! defaultTestResultClass ^TestResult! setName: aString name := aString. testCases := OrderedCollection new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestSuite class instanceVariableNames: ''! !TestSuite class methodsFor: 'instance creation'! named: aString ^self new setName: aString! ! TestCase subclass: #SetTestCase instanceVariableNames: 'full empty ' classVariableNames: '' poolDictionaries: '' category: 'Testing Framework'! !SetTestCase methodsFor: 'set up'! setUp empty := Set new. full := Set with: 5 with: #abc! ! !SetTestCase methodsFor: 'running'! testAdd empty add: 5. self should: [empty includes: 5]! testError 2 + 'abc'! testFailure "This case is here to test the testing machinery only." self should: [false]! testGrow empty addAll: (1 to: 100). self should: [empty size = 100]! testIllegal self should: [empty at: 5] raise: self errorException. self should: [empty at: 5 put: #abc] raise: self errorException! testIncludes self should: [full includes: 5]. self should: [full includes: #abc]! testMinus self should: [(full - full copy) isEmpty]! testOccurrences self should: [(empty occurrencesOf: 0) = 0]. self should: [(full occurrencesOf: 5) = 1]. full add: 5. self should: [(full occurrencesOf: 5) = 1]! testRemove full remove: 5. self should: [full includes: #abc]. self shouldnt: [full includes: 5]! testTrim empty addAll: (1 to: 100). empty removeAll: (1 to: 99). empty trim. self should: [empty basicSize < 5]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! SetTestCase class instanceVariableNames: ''! !SetTestCase class methodsFor: 'running'! run | test | test := TestSuite named: 'Set Example'. test addTestCases: self testCases. ^test run! runAll | test | test := TestSuite named: 'Set Example'. test addTestCases: self allTestCases. ^test run! ! !SetTestCase class methodsFor: 'examples'! allTestCases | result | result := self testCases. result add: (self selector: #testIllegal). result add: (self selector: #testFailure). result add: (self selector: #testError). ^result! testCases | result | result := OrderedCollection new. result add: (self selector: #testAdd). result add: (self selector: #testRemove). result add: (self selector: #testIncludes). result add: (self selector: #testGrow). result add: (self selector: #testOccurrences). ^result! ! Object subclass: #TestResult instanceVariableNames: 'startTime stopTime testName failures errors ' classVariableNames: '' poolDictionaries: '' category: 'Testing Framework'! !TestResult methodsFor: 'running'! start startTime := Date dateAndTimeNow! stop stopTime := Date dateAndTimeNow! ! !TestResult methodsFor: 'testing'! hasNoErrors ^errors isEmpty! hasNoFailures ^failures isEmpty! wasSuccessful ^self hasNoFailures & self hasNoErrors! ! !TestResult methodsFor: 'logging'! error: anException in: aTestCase errors add: (TestFailure testCase: aTestCase exception: anException)! failure: anException in: aTestCase failures add: (TestFailure testCase: aTestCase exception: anException)! ! !TestResult methodsFor: 'printing'! printError: error on: aStream aStream nextPutAll: 'Error- '. error printOn: aStream! printErrorsOn: aStream errors do: [:each | aStream cr; tab. self printError: each on: aStream]! printFailure: failure on: aStream aStream nextPutAll: 'Failure- '. failure printOn: aStream! printFailuresOn: aStream failures do: [:each | aStream cr; tab. self printFailure: each on: aStream]! printHeaderOn: aStream aStream nextPutAll: 'Test results for '; nextPutAll: testName; cr; tab; nextPutAll: 'Start time: '. startTime printOn: aStream. aStream cr; tab; nextPutAll: 'Stop time: '. stopTime printOn: aStream! printOn: aStream self printHeaderOn: aStream. self printErrorsOn: aStream. self printFailuresOn: aStream! ! !TestResult methodsFor: 'private'! setTest: aTest testName := aTest name. failures := OrderedCollection new. errors := OrderedCollection new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! TestResult class instanceVariableNames: ''! !TestResult class methodsFor: 'instance creation'! test: aTest ^self new setTest: aTest! !